Update to new GUARDED-SYSTEM-LOADER.

diff --git a/v7/src/etc/optiondb.scm b/v7/src/etc/optiondb.scm
index 62a104f8cdd425c0baeea91faaa4185de95ef08e..c3e0122a8196c0c04f11aaa9eee872c2c41aed30 100644 (file)
--- a/v7/src/etc/optiondb.scm
+++ b/v7/src/etc/optiondb.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: optiondb.scm,v 1.3 2000/12/07 21:56:29 cph Exp $
+$Id: optiondb.scm,v 1.4 2000/12/23 06:01:15 cph Exp $
 
 Copyright (c) 2000 Massachusetts Institute of Technology
 
@@ -20,55 +20,72 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 |#
 
 (define (guarded-system-loader package-name place #!optional filename)
-  (let ((directory
-        (let ((here (directory-pathname (current-load-pathname))))
-          (let ((directory
-                 (pathname-new-directory here
-                                         (append (pathname-directory here)
-                                                 (list 'UP place)))))
-            (if (file-directory? directory)
-                directory
-                (merge-pathnames place here))))))
+  (let ((dirs
+        (list (directory-pathname (current-load-pathname))
+              (or (get-environment-variable "MITSCHEME_INF_DIRECTORY")
+                  "/scheme/v7/linux")))
+       (files
+        (if (default-object? filename)
+            (list "make" "load")
+            (list filename)))
+       (test
+        (lambda (name)
+          (or (file-exists? name)
+              (there-exists? load/default-types
+                (lambda (type)
+                  (file-exists?
+                   (pathname-new-type name (car type)))))))))
     (lambda ()
       (if (not (name->package package-name))
-         (with-working-directory-pathname directory
-           (lambda ()
-             (load
-              (let ((test
-                     (lambda (name)
-                       (or (file-exists? name)
-                           (there-exists? load/default-types
-                             (lambda (type)
-                               (file-exists?
-                                (pathname-new-type name (car type)))))))))
-                (cond ((not (default-object? filename)) filename)
-                      ((test "make") "make")
-                      ((test "load") "load")
-                      (else (error "Can't find loader.")))))))))))
+         (let dir-loop ((dirs dirs))
+           (if (pair? dirs)
+               (let ((directory
+                      (merge-pathnames place
+                                       (pathname-as-directory (car dirs)))))
+                 (if (file-directory? directory)
+                     (let file-loop ((files files))
+                       (if (pair? files)
+                           (if (test
+                                (merge-pathnames
+                                 (car files)
+                                 (pathname-as-directory directory)))
+                               (with-working-directory-pathname directory
+                                 (lambda ()
+                                   (load (car files))))
+                               (file-loop (cdr files)))
+                           (dir-loop (cdr dirs))))
+                     (dir-loop (cdr dirs))))
+               (error "Unable to find package directory:" place)))))))
+\f
+(define-load-option 'SF
+  (guarded-system-loader '(scode-optimizer) "sf"))
 
 (define-load-option 'CREF
   (guarded-system-loader '(cross-reference) "cref"))
 
+(define-load-option 'EDWIN
+  (guarded-system-loader '(edwin) "edwin"))
+
 (define-load-option 'COMPILER
   (lambda () (load-option 'SF))
   (guarded-system-loader '(compiler) "compiler"))
 
-(define-load-option 'EDWIN
-  (guarded-system-loader '(edwin) "edwin"))
+(define-load-option 'STUDENT
+  (guarded-system-loader '(student) "6001"))
 
-(define-load-option 'IMAIL
-  (guarded-system-loader '(edwin imail) "imail"))
+(define-load-option 'SOS
+  (guarded-system-loader '(runtime object-system) "sos"))
 
 (define-load-option 'RCS
   (guarded-system-loader '(rcs) "rcs"))
 
-(define-load-option 'SF
-  (guarded-system-loader '(scode-optimizer) "sf"))
+(define-load-option 'IMAIL
+  (guarded-system-loader '(edwin imail) "imail"))
 
-(define-load-option 'STUDENT
-  (guarded-system-loader '(student) "6001"))
+(define-load-option 'PC-SAMPLE
+  (guarded-system-loader '(pc-sample) "pcsample"))
 
-(define-load-option 'SOS
-  (guarded-system-loader '(runtime object-system) "sos"))
+(define-load-option 'SWAT
+  (guarded-system-loader '(swat) "swat"))
 
 (further-load-options standard-load-options)
\ No newline at end of file