Add (further-load-options #t): continue with the next optiondb.

This is intended for test optiondbs or optiondbs in user directories
prepended to the system library-directory-path.

diff --git a/src/runtime/option.scm b/src/runtime/option.scm
index 981e4a2b8a91d8c8d94458cbe8afc0fe4a6e66f1..a43011bb1277182095a1e4b895babe063635cdd7 100644 (file)
--- a/src/runtime/option.scm
+++ b/src/runtime/option.scm
@@ -30,7 +30,8 @@ USA.
 (declare (usual-integrations))
 \f
 (define (load-option name #!optional no-error?)
-  (let ((no-error? (and (not (default-object? no-error?)) no-error?)))
+  (let ((no-error? (and (not (default-object? no-error?)) no-error?))
+       (path library-directory-path))
 
     (define (find-option options parent)
       (cond ((assq name options) => load-entry)
@@ -50,12 +51,31 @@ USA.
                           (*parent* #f)
                           (param:suppress-loading-message? #t))
              (load pathname (simple-top-level-environment #t))
-             (values (*options*) (*parent*))))
+             (values (*options*)
+                     (let ((parent (*parent*)))
+                       (if (eq? #t parent)
+                           (next-optiondb)
+                           parent)))))
        find-option))
 
+    (define (next-optiondb)
+      (and (pair? path)
+          (let ((p (merge-pathnames "optiondb" (car path))))
+            (set! path (cdr path))
+            (if (file-loadable? p)
+                p
+                (next-optiondb)))))
+
+    (define (initial-load-options)
+      (or *initial-options-file*
+         (let ((s (get-environment-variable "MITSCHEME_LOAD_OPTIONS")))
+           (and s (confirm-pathname
+                   (merge-pathnames s (user-homedir-pathname)))))
+         (next-optiondb)))
+
     (if (memq name loaded-options)
        name
-       (find-option (*options*) (*parent*)))))
+       (find-option (*options*) initial-load-options))))
 
 (define (option-loaded? name)
   (not (eq? #f (memq name loaded-options))))
@@ -68,13 +88,6 @@ USA.
   (*parent* place)
   unspecific)
 
-(define (initial-load-options)
-  (or *initial-options-file*
-      (let ((s (get-environment-variable "MITSCHEME_LOAD_OPTIONS")))
-       (and s
-            (confirm-pathname (merge-pathnames s (user-homedir-pathname)))))
-      (local-load-options)))
-
 (define (local-load-options)
   (or (library-file? "optiondb")
       (standard-load-options)))
@@ -101,7 +114,7 @@ USA.
 
 (define (initialize-package!)
   (set! *options* (make-settable-parameter '()))
-  (set! *parent* (make-settable-parameter initial-load-options)))
+  (set! *parent* (make-settable-parameter #f)))
 \f
 (define (dummy-option-loader)
   unspecific)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 781f883b2d52209526d52698152675804f0f6094..f255a1f515ee94323ce65137673964e8a0e29405 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3501,6 +3501,8 @@ USA.
   (export (runtime compiler-info)
          %make-host
          %make-pathname)
+  (export (runtime options)
+         library-directory-path)
   (export (runtime load)
          library-directory-path)
   (initialization (initialize-package!)))