Rewrite debugging-info directory on option files; they are sometimes

loaded while building the system but must refer to debugging info in
it's installed location.

diff --git a/v7/src/runtime/option.scm b/v7/src/runtime/option.scm
index b00a1d7bd45147b59a6611b5a4934a8c21acb7a1..2626857a18fa8fd301218bbff11d0ae9e1aefb48 100644 (file)
--- a/v7/src/runtime/option.scm
+++ b/v7/src/runtime/option.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: option.scm,v 14.36 1999/01/02 06:11:34 cph Exp $
+$Id: option.scm,v 14.37 2001/03/16 20:17:48 cph Exp $
 
-Copyright (c) 1988-1999 Massachusetts Institute of Technology
+Copyright (c) 1988-2001 Massachusetts Institute of Technology
 
 This program is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published by
@@ -16,7 +16,8 @@ General Public License for more details.
 
 You should have received a copy of the GNU General Public License
 along with this program; if not, write to the Free Software
-Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
 |#
 
 ;;;; Option Loader
@@ -24,40 +25,14 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 
 (declare (usual-integrations))
 \f
-(define *initial-options-file* #F)
-
-(define (initial-load-options)
-  (or *initial-options-file*
-      (get-environment-variable "MITSCHEME_LOAD_OPTIONS")
-      (local-load-options)))
-
-(define (local-load-options)
-  (or (library-file? "optiondb")
-      (standard-load-options)))
-
-(define (standard-load-options)
-  (or (library-file? "options/optiondb")
-      (error "Cannot locate a load-option database")
-      "optiondb"))
-
-(define (define-load-option name . loaders)
-  (set! *options* (cons (cons name loaders) *options*))
-  unspecific)
-
-(define (further-load-options place)
-  (set! *parent* place)
-  unspecific)
-
 (define (load-option name #!optional no-error?)
   (let ((no-error? (and (not (default-object? no-error?)) no-error?)))
 
     (define (find-option)
       (cond ((assq name *options*) => load-entry)
-           ((force* *parent*)     => search-parent)
-           ((not no-error?)
-            (error "Unknown option name:" name)
-            #F)
-           (else  #F)))
+           ((force* *parent*) => search-parent)
+           ((not no-error?) (error "Unknown option name:" name))
+           (else #f)))
 
     (define (load-entry entry)
       (for-each (lambda (thunk) (thunk)) (cdr entry))
@@ -66,78 +41,89 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 
     (define (search-parent file)
       (fluid-let ((*options* '())
-                 (*parent*  #F))
-       (fluid-let ((load/suppress-loading-message? #T))
+                 (*parent* #f))
+       (fluid-let ((load/suppress-loading-message? #t))
          (load-latest (merge-pathnames file (library-directory-pathname ""))
                       (make-load-environment)
                       system-global-syntax-table
-                      #F))
+                      #f))
        (find-option)))
 
     (define (make-load-environment)
       (eval '(LET () (THE-ENVIRONMENT)) system-global-environment))
 
     (fluid-let ((*parser-canonicalize-symbols?* #t))
-      (if (not (memq name loaded-options))
-         (find-option)
-         name))))
+      (if (memq name loaded-options)
+         name
+         (find-option)))))
 
-(define loaded-options  '())
-(define *options* '())                 ; Current options.
-(define *parent*  initial-load-options)        ; A thunk or a pathname/string or #F.
-\f
-(define (library-file? library-internal-path)
-  (let* ((library    (library-directory-pathname ""))
-        (pathname   (merge-pathnames library-internal-path library)))
-    (let loop ((file-types load/default-types))
-      (if (null? file-types)
-         #F
-         (let ((full-pathname (pathname-new-type pathname (caar file-types))))
-           (if (file-exists? full-pathname)
-               pathname;; not full-pathname to allow load-latest
-               (loop (cdr file-types))))))))
+(define (define-load-option name . loaders)
+  (set! *options* (cons (cons name loaders) *options*))
+  unspecific)
 
-(define (force* value)
-  (cond        ((procedure? value)  (force* (value)))
-       ((promise? value)    (force* (force value)))
-       (else value)))
+(define (further-load-options place)
+  (set! *parent* place)
+  unspecific)
+
+(define (initial-load-options)
+  (or *initial-options-file*
+      (get-environment-variable "MITSCHEME_LOAD_OPTIONS")
+      (local-load-options)))
+
+(define (local-load-options)
+  (or (library-file? "optiondb")
+      (standard-load-options)))
 
+(define (standard-load-options)
+  (or (library-file? "options/optiondb")
+      (error "Cannot locate a load-option database")
+      "optiondb"))
+
+(define (library-file? library-internal-path)
+  (let* ((library (library-directory-pathname ""))
+        (pathname (merge-pathnames library-internal-path library)))
+    (let loop ((file-types load/default-types))
+      (and (not (null? file-types))
+          (let ((full-pathname
+                 (pathname-new-type pathname (caar file-types))))
+            (if (file-exists? full-pathname)
+                ;; not full-pathname to allow load-latest
+                pathname               
+                (loop (cdr file-types))))))))
+
+(define loaded-options '())
+(define *options* '())                 ; Current options.
+(define *parent* initial-load-options) ; A thunk or a pathname/string or #f.
+(define *initial-options-file* #f)
+\f
 (define (standard-option-loader package-name init-expression . files)
   (lambda ()
-    (let ((environment     (package/environment (find-package package-name)))
-         (library-options (delay (library-directory-pathname "options"))))
-      (for-each
-         (lambda (file)
-           (let ((file  (force* file)))
-             (cond 
-              (((ucode-primitive initialize-c-compiled-block 1)
-                (string-append "runtime_" file))
-               => (lambda (obj)
-                    (purify obj)
-                    (scode-eval obj environment)))
-              (else
-               (let ((path  (merge-pathnames file (force library-options))))
-                 (with-working-directory-pathname
-                  (directory-pathname path)
-                  (lambda ()
-                    (load path
-                          environment
-                          syntax-table/system-internal
-                          true))))))))
-       files)
+    (let ((environment (package/environment (find-package package-name)))
+         (runtime (pathname-as-directory "runtime")))
+      (for-each (lambda (file)
+                 (let ((file (force* file)))
+                   (cond 
+                    (((ucode-primitive initialize-c-compiled-block 1)
+                      (string-append "runtime_" file))
+                     => (lambda (obj)
+                          (purify obj)
+                          (scode-eval obj environment)))
+                    (else
+                     (let* ((options (library-directory-pathname "options"))
+                            (pathname (merge-pathnames file options)))
+                       (with-directory-rewriting-rule options runtime
+                         (lambda ()
+                           (with-working-directory-pathname
+                               (directory-pathname pathname)
+                             (lambda ()
+                               (load pathname
+                                     environment
+                                     syntax-table/system-internal
+                                     #t))))))))))
+               files)
       (flush-purification-queue!)
       (eval init-expression environment))))
 
-(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)))))
-
 (define (declare-shared-library shared-library thunk)
   (let ((thunk-valid?
         (lambda (thunk)
@@ -146,7 +132,22 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
      event:after-restore
      (lambda ()
        (if (not (thunk-valid? thunk))
-          (fluid-let ((load/suppress-loading-message? true))
-            (load (merge-pathnames
-                   (library-directory-pathname "shared")
-                   shared-library))))))))
\ No newline at end of file
+          (fluid-let ((load/suppress-loading-message? #t))
+            (load
+             (merge-pathnames shared-library
+                              (library-directory-pathname "shared")))))))))
+
+(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

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 821b3c8b9d32f7696b2cf3e7e370086254262bda..3a5b40c70044fb20ceab68f299f525ff337113bb 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.363 2001/03/15 21:14:17 cph Exp $
+$Id: runtime.pkg,v 14.364 2001/03/16 20:17:51 cph Exp $
 
 Copyright (c) 1988-2001 Massachusetts Institute of Technology
 
@@ -410,6 +410,8 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
          compiled-entry/filename-and-index)
   (export (runtime compress)
          uncompress-internal)
+  (export (runtime options)
+         with-directory-rewriting-rule)
   (initialization (initialize-package!)))
 
 (define-package (runtime console-i/o-port)