Add optional REQUIRED? arguments to SYSTEM-LIBRARY-PATHNAME and

SYSTEM-LIBRARY-DIRECTORY-PATHNAME.  When new arg not supplied, each
behaves as it used to.

diff --git a/v7/src/runtime/option.scm b/v7/src/runtime/option.scm
index b9b64ff73c7a3e1c2a5eb98d144e86a3da087a67..f3fdeb60778cc9dc970003f7e71aa113145cb068 100644 (file)
--- a/v7/src/runtime/option.scm
+++ b/v7/src/runtime/option.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: option.scm,v 14.54 2007/05/01 04:55:22 cph Exp $
+$Id: option.scm,v 14.55 2007/05/21 17:33:31 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -50,8 +50,7 @@ USA.
            (fluid-let ((*options* '())
                        (*parent* #f))
              (fluid-let ((load/suppress-loading-message? #t))
-               (load-latest (merge-pathnames file
-                                             (library-directory-pathname ""))
+               (load-latest (system-library-pathname file #f)
                             (make-load-environment)
                             'DEFAULT
                             #f))
@@ -94,7 +93,8 @@ USA.
 
 (define (library-file? library-internal-path)
   (confirm-pathname
-   (merge-pathnames library-internal-path (library-directory-pathname ""))))
+   (merge-pathnames library-internal-path
+                   (system-library-directory-pathname))))
 
 (define (confirm-pathname pathname)
   (receive (pathname* loader)
@@ -122,7 +122,8 @@ USA.
                       (purify obj)
                       (scode-eval obj environment)))
                 (else
-                 (let* ((options (library-directory-pathname "options"))
+                 (let* ((options
+                         (system-library-directory-pathname "options" #t))
                         (pathname (merge-pathnames file options)))
                    (with-directory-rewriting-rule options runtime
                      (lambda ()
@@ -138,29 +139,17 @@ USA.
       (eval init-expression environment))))
 
 (define (declare-shared-library shared-library thunk)
-  (let ((thunk-valid?
-        (lambda (thunk)
-          (not (condition? (ignore-errors thunk))))))
-    (add-event-receiver!
-     event:after-restore
-     (lambda ()
-       (if (not (thunk-valid? thunk))
-          (fluid-let ((load/suppress-loading-message? #t))
-            (load
-             (merge-pathnames shared-library
-                              (library-directory-pathname "lib")))))))))
+  (add-event-receiver!
+   event:after-restore
+   (lambda ()
+     (if (condition? (ignore-errors thunk))
+        (fluid-let ((load/suppress-loading-message? #t))
+          (load
+           (merge-pathnames
+            shared-library
+            (system-library-directory-pathname "lib" #t))))))))
 
 (define (force* value)
   (cond ((procedure? value) (force* (value)))
        ((promise? value) (force* (force value)))
-       (else value)))
-
-(define (library-directory-pathname name)
-  (or (system-library-directory-pathname name)
-      (library-directory-pathname
-       (error:file-operation name
-                            "find"
-                            "directory"
-                            "no such directory in system library path"
-                            library-directory-pathname
-                            (list name)))))
\ No newline at end of file
+       (else value)))
\ No newline at end of file

diff --git a/v7/src/runtime/pathnm.scm b/v7/src/runtime/pathnm.scm
index b9e4622f9deb3b4c31d454877a7851f2b40b8666..2f16951db5c697622a2200c5a22dad2da02720b5 100644 (file)
--- a/v7/src/runtime/pathnm.scm
+++ b/v7/src/runtime/pathnm.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: pathnm.scm,v 14.51 2007/01/05 21:19:28 cph Exp $
+$Id: pathnm.scm,v 14.52 2007/05/21 17:33:32 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -591,45 +591,43 @@ these rules:
             local-host)))
     ((host-type/operation/init-file-pathname (host/type host)) host)))
 
-(define (system-library-pathname pathname)
-  (let ((try-directory
-        (lambda (directory)
-          (let ((pathname (merge-pathnames pathname directory)))
-            (and (file-exists? pathname)
-                 pathname))))
-       (loser
-        (lambda ()
-          (system-library-pathname
-           (->pathname
-            (error:file-operation pathname
-                                  "find"
-                                  "file"
-                                  "no such file in system library path"
-                                  system-library-pathname
-                                  (list pathname)))))))
-    (if (pathname-absolute? pathname)
-       (if (file-exists? pathname) pathname (loser))
-       (let loop ((directories library-directory-path))
-         (if (null? directories)
-             (loser)
-             (or (try-directory (car directories))
-                 (loop (cdr directories))))))))
+(define (system-library-pathname pathname #!optional required?)
+  (let ((pathname* (merge-pathnames pathname (%find-library-directory)))
+       (required? (if (default-object? required?) #t required?)))
+    (if (and required? (not (file-exists? pathname*)))
+       (system-library-pathname
+        (error:file-operation pathname*
+                              "find"
+                              "file"
+                              "no such file in system library path"
+                              system-library-pathname
+                              (list pathname required?)))
+       pathname*)))
+
+(define (system-library-directory-pathname #!optional pathname required?)
+  (if (if (default-object? pathname) #f pathname)
+      (let ((dir (system-library-pathname pathname #f)))
+       (cond ((file-directory? dir)
+              (pathname-as-directory dir))
+             ((if (default-object? required?) #f required?)
+              (system-library-directory-pathname
+               (error:file-operation
+                pathname
+                "find"
+                "directory"
+                "no such directory in system library path"
+                system-library-directory-pathname
+                (list pathname required?))
+               required?))
+             (else #f)))
+      (%find-library-directory)))
+
+(define (%find-library-directory)
+  (pathname-as-directory
+   (or (find-matching-item library-directory-path file-directory?)
+       (error "Can't find library directory."))))
 
 (define library-directory-path)
-
-(define (system-library-directory-pathname pathname)
-  (if (not pathname)
-      (let ((pathname
-            (list-search-positive library-directory-path file-directory?)))
-       (if (not pathname)
-           (error "can't find system library directory"))
-       (pathname-as-directory pathname))
-      (let loop ((directories library-directory-path))
-       (and (not (null? directories))
-            (let ((pathname (merge-pathnames pathname (car directories))))
-              (if (file-directory? pathname)
-                  (pathname-as-directory pathname)
-                  (loop (cdr directories))))))))
 \f
 (define known-host-types
   '((0 UNIX)