From 76e46a658a25a616389329630ae3ae1cc29e79c5 Mon Sep 17 00:00:00 2001
From: Matt Birkholz <matt@birkholz.chandler.az.us>
Date: Sat, 7 Sep 2013 15:59:44 -0700
Subject: [PATCH] with-system-library-directories: prepend to library directory
 path.

This is for test scripts that want a new FFI shim to shadow an
installed shim, and requires canonicalize-debug-info-pathname to be
fixed to deal -- to SEARCH the library-directory-path.  At least, for
relative pathnames with at least one directory name, it now searches
the directory path for that name.
---
 src/runtime/infutl.scm | 15 ++++++++++++++-
 src/runtime/pathnm.scm |  6 ++++--
 2 files changed, 18 insertions(+), 3 deletions(-)

diff --git a/src/runtime/infutl.scm b/src/runtime/infutl.scm
index 61bd7dc68..f32bf83fd 100644
--- a/src/runtime/infutl.scm
+++ b/src/runtime/infutl.scm
@@ -279,7 +279,20 @@ USA.
    (let ((value (get-environment-variable "MITSCHEME_INF_DIRECTORY")))
      (if value
 	 (pathname-as-directory value)
-	 (system-library-directory-pathname)))))
+	 (or (%find-library-directory pathname)
+	     (system-library-directory-pathname))))))
+
+(define (%find-library-directory pathname)
+  (let ((dir (pathname-directory pathname)))
+    (or (and (pair? dir)
+	     (eq? 'RELATIVE (car dir))
+	     (pair? (cdr dir))
+	     (string? (cadr dir))
+	     (let ((libdir (system-library-directory-pathname (cadr dir))))
+	       (and libdir
+		    (pathname-new-directory libdir
+					    (except-last-pair
+					     (pathname-directory libdir)))))))))
 
 (define-integrable (dbg-block/layout-first-offset block)
   (let ((layout (dbg-block/layout block)))
diff --git a/src/runtime/pathnm.scm b/src/runtime/pathnm.scm
index f6d845ed6..8cddbb216 100644
--- a/src/runtime/pathnm.scm
+++ b/src/runtime/pathnm.scm
@@ -622,6 +622,7 @@ these rules:
       (%find-library-directory)))
 
 (define (with-system-library-directories directories thunk)
+
   (define (existing-directory directory)
     (let ((dirpath (pathname-as-directory (merge-pathnames directory))))
       (if (file-directory? dirpath)
@@ -630,9 +631,10 @@ these rules:
 				"find" "directory" "no such directory"
 				'with-system-library-directories
 				directories))))
+
   (fluid-let ((library-directory-path
-	       (append library-directory-path
-		       (map existing-directory directories))))
+	       (append (map existing-directory directories)
+		       library-directory-path)))
     (thunk)))
 
 (define (%find-library-directory)
-- 
2.25.1