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.

diff --git a/src/runtime/infutl.scm b/src/runtime/infutl.scm
index 61bd7dc681c09ff1b3028ec0a0325aa9fa502689..f32bf83fd84426b644ff50ee37c8bb044c91699e 100644 (file)
--- 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)))))))))
 \f
 (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 f6d845ed673b2f6cf21666364f9023aea474a5eb..8cddbb2163285e2c61aa9c293b5e792ff308104e 100644 (file)
--- 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)