From: Matt Birkholz <matt@birchwood-abbey.net>
Date: Thu, 20 Sep 2018 07:37:22 +0000 (-0700)
Subject: Add (further-load-options #t): continue with the next optiondb.
X-Git-Tag: mit-scheme-pucked-9.2.18~7^2~1
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=dc1509a71b0dcb373336d33d98b31d381ba3fb15;p=mit-scheme.git

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 981e4a2b8..a43011bb1 100644
--- a/src/runtime/option.scm
+++ b/src/runtime/option.scm
@@ -30,7 +30,8 @@ USA.
 (declare (usual-integrations))
 
 (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)))
 
 (define (dummy-option-loader)
   unspecific)
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 781f883b2..f255a1f51 100644
--- 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!)))