Implement new mechanism to allow the system to specify its

debugging-info files as relative pathnames that are resolved at lookup
time rather than at the time the .com files are loaded.

diff --git a/v7/src/runtime/infutl.scm b/v7/src/runtime/infutl.scm
index 02ccc9d4e14736442c5bc9bf0af3365991cfa337..b8e8b6effe05ecd00ccfacaedcedc39a9656c56e 100644 (file)
--- a/v7/src/runtime/infutl.scm
+++ b/v7/src/runtime/infutl.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: infutl.scm,v 1.48 1993/11/09 04:31:38 cph Exp $
+$Id: infutl.scm,v 1.49 1993/11/18 00:47:13 cph Exp $
 
-Copyright (c) 1988-1993 Massachusetts Institute of Technology
+Copyright (c) 1988-93 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -94,8 +94,8 @@ MIT in each case. |#
        (else
         false)))
 
-(define (read-binf-file filename)
-  (let ((pathname (merge-pathnames filename)))
+(define (read-binf-file pathname)
+  (let ((pathname (canonicalize-debug-info-pathname pathname)))
     (if (file-exists? pathname)
        (fasload-loader (->namestring pathname))
        (find-alternate-file-type pathname
@@ -189,11 +189,11 @@ MIT in each case. |#
 
 (define (compiled-code-block/filename block)
   (let loop ((info (compiled-code-block/debugging-info block)))
-    (cond ((string? info) (values info false))
+    (cond ((string? info) (values (canonicalize-debug-info-filename info) #f))
          ((not (pair? info)) (values false false))
          ((dbg-info? (car info)) (loop (cdr info)))
          ((string? (car info))
-          (values (car info)
+          (values (canonicalize-debug-info-filename (car info))
                   (and (exact-nonnegative-integer? (cdr info))
                        (cdr info))))
          (else (values false false)))))
@@ -261,6 +261,13 @@ MIT in each case. |#
 (define directory-rewriting-rules
   '())
 
+(define (with-directory-rewriting-rule match replace thunk)
+  (fluid-let ((directory-rewriting-rules
+              (cons (cons (pathname-as-directory (merge-pathnames match))
+                          replace)
+                    directory-rewriting-rules)))
+    (thunk)))
+
 (define (add-directory-rewriting-rule! match replace)
   (let ((match (pathname-as-directory (merge-pathnames match))))
     (let ((rule
@@ -283,19 +290,12 @@ MIT in each case. |#
                                (pathname-directory (car rule)))))))
     (->namestring
      (if rule
-        (let ((replacement (cdr rule))
-              (remaining-directories
-               (list-tail (pathname-directory pathname)
-                          (length (pathname-directory (car rule))))))
-          ;; Moby kludge: we are going to fool the pathname abstraction
-          ;; into giving us a namestring that might contain uncanonicalized
-          ;; characters in them.  This will break if the pathname abstraction
-          ;; cares at all.
-          (pathname-new-device
-           (pathname-new-directory 
-            pathname
-            `(relative ,replacement ,@remaining-directories))
-           false))
+        (merge-pathnames
+         (pathname-new-directory
+          pathname
+          (list-tail (pathname-directory pathname)
+                     (length (pathname-directory (car rule)))))
+         (cdr rule))
         pathname))))
 
 (define (directory-prefix? x y)
@@ -307,6 +307,20 @@ MIT in each case. |#
             (and (not (null? x))
                  (equal? (car x) (car y))
                  (loop (cdr x) (cdr y)))))))
+
+(define (canonicalize-debug-info-filename filename)
+  (->namestring (canonicalize-debug-info-pathname filename)))
+
+(define (canonicalize-debug-info-pathname pathname)
+  (if (pathname-absolute? pathname)
+      pathname
+      (merge-pathnames
+       pathname
+       (let ((value
+             (get-environment-variable "MITSCHEME_INF_DIRECTORY")))
+        (if value
+            (pathname-as-directory value)
+            (system-library-directory-pathname "SRC"))))))
 \f
 (define-integrable (dbg-block/layout-first-offset block)
   (let ((layout (dbg-block/layout block)))
@@ -405,7 +419,9 @@ MIT in each case. |#
 
 (define (read-bsm-file name)
   (let ((pathname
-        (let ((pathname (merge-pathnames (process-bsym-filename name))))
+        (let ((pathname
+               (canonicalize-debug-info-pathname
+                (rewrite-directory (merge-pathnames name)))))
           (if (file-exists? pathname)
               pathname
               (let loop ((types '("bsm" "bcs")))
@@ -419,10 +435,6 @@ MIT in each case. |#
         (if (equal? "bcs" (pathname-type pathname))
             ((compressed-loader "bsm") pathname)
             (fasload-loader pathname)))))
-
-(define (process-bsym-filename name)
-  (rewrite-directory (merge-pathnames name)))
-
 \f
 ;;;; Splitting of info structures
 

diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm
index 3729e6994395ba2afc6464935ba29f18625a1a6d..142fad482db6a937fce7b69df9de31c656bac3c1 100644 (file)
--- a/v7/src/runtime/make.scm
+++ b/v7/src/runtime/make.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: make.scm,v 14.49 1993/09/19 22:38:02 adams Exp $
+$Id: make.scm,v 14.50 1993/11/18 00:47:19 cph Exp $
 
-Copyright (c) 1988-1993 Massachusetts Institute of Technology
+Copyright (c) 1988-93 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -481,17 +481,22 @@ MIT in each case. |#
 
 (let ((roots
        (list->vector
-       (let ((fasload/update-debugging-info!
-              (access fasload/update-debugging-info!
-                      (->environment '(RUNTIME COMPILER-INFO))))
-             (load/purification-root
-              (access load/purification-root
-                      (->environment '(RUNTIME LOAD)))))
-         (map (lambda (entry)
-                (let ((object (cdr entry)))
-                  (fasload/update-debugging-info! object (car entry))
-                  (load/purification-root object)))
-              fasload-purification-queue)))))
+       ((access with-directory-rewriting-rule
+                (->environment '(RUNTIME COMPILER-INFO)))
+        (working-directory-pathname)
+        (pathname-as-directory "runtime")
+        (lambda ()
+          (let ((fasload/update-debugging-info!
+                 (access fasload/update-debugging-info!
+                         (->environment '(RUNTIME COMPILER-INFO))))
+                (load/purification-root
+                 (access load/purification-root
+                         (->environment '(RUNTIME LOAD)))))
+            (map (lambda (entry)
+                   (let ((object (cdr entry)))
+                     (fasload/update-debugging-info! object (car entry))
+                     (load/purification-root object)))
+                 fasload-purification-queue)))))))
   (set! (access gc-boot-loading? (->environment '(RUNTIME GARBAGE-COLLECTOR)))
        false)
   (set! fasload-purification-queue)
@@ -507,4 +512,4 @@ MIT in each case. |#
 
 (package/add-child! system-global-package 'USER user-initial-environment)
 (start-thread-timer)
-(initial-top-level-repl)
+(initial-top-level-repl)
\ No newline at end of file

diff --git a/v7/src/runtime/site.scm.dos b/v7/src/runtime/site.scm.dos
index 8198484dc9551be1e685618d736c5f68c0c11123..6b1a434aaad70aa559e8dfc130b1d3e5213a0df3 100644 (file)
--- a/v7/src/runtime/site.scm.dos
+++ b/v7/src/runtime/site.scm.dos
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: site.scm.dos,v 1.12 1993/09/07 21:59:02 gjr Exp $
+$Id: site.scm.dos,v 1.13 1993/11/18 00:47:30 cph Exp $
 
-Copyright (c) 1992 Massachusetts Institute of Technology
+Copyright (c) 1992-93 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -35,28 +35,17 @@ MIT in each case. |#
 ;;;; Switzerland site specific stuff
 
 (declare (usual-integrations))
-\f
+
 ;;; Local hacks
 
 (define (call/cc . args)
   (warn "call/cc: Invoking the C compiler:" args)
   (warn "Segmentation fault (core dumped)"))
 
-;;; Normalization of various directory structures.
-
-(let ((add-directory-rewriting-rule!
-       (access add-directory-rewriting-rule!
-              (->environment '(runtime compiler-info)))))
-  (for-each
-   (lambda (path)
-     (add-directory-rewriting-rule! path "$MITSCHEME_INF_DIRECTORY"))
-   '("/scheme")))
-
 (set-environment-variable-default! "MITSCHEME_INF_DIRECTORY" "\\scheme")
 (set-environment-variable-default!
  "TERM"
  (lambda ()
    (if (string-ci=? microcode-id/operating-system-name "NT")
        "ansi.sys"
-       "ibm_pc_bios")))
-                                  
\ No newline at end of file
+       "ibm_pc_bios")))
\ No newline at end of file

diff --git a/v7/src/runtime/site.scm.unix b/v7/src/runtime/site.scm.unix
index 0722deee333c692f405f2e308ad02877b821bac4..d16babe0bfceeb6bdacbd38e826dafc8d28b3c6c 100644 (file)
--- a/v7/src/runtime/site.scm.unix
+++ b/v7/src/runtime/site.scm.unix
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: site.scm.unix,v 1.13 1993/11/13 03:52:54 gjr Exp $
+$Id: site.scm.unix,v 1.14 1993/11/18 00:47:36 cph Exp $
 
 Copyright (c) 1988-93 Massachusetts Institute of Technology
 
@@ -71,20 +71,4 @@ MIT in each case. |#
      (lambda ()
        (set! inside ((ucode-primitive working-directory-pathname 0)))
        ((ucode-primitive set-working-directory-pathname! 1) outside)
-       (start-thread-timer)))))
-
-;;; Normalization of various directory structures.
-
-(let ((add-directory-rewriting-rule!
-       (access add-directory-rewriting-rule!
-              (->environment '(runtime compiler-info)))))
-  (for-each
-   (lambda (path)
-     (add-directory-rewriting-rule! path "/usr/local/lib/mit-scheme/SRC"))
-   '("/scheme/300"
-     "/nfs/martigny/scheme/300"
-     "/scheme/700"
-     "/nfs/martigny/scheme/700"
-     "/usr/local/scheme/nws3250"
-     "/scheme/nws3250"
-     "/nfs/martigny/scheme/nws3250")))
\ No newline at end of file
+       (start-thread-timer)))))
\ No newline at end of file

diff --git a/v8/src/runtime/infutl.scm b/v8/src/runtime/infutl.scm
index 02ccc9d4e14736442c5bc9bf0af3365991cfa337..b8e8b6effe05ecd00ccfacaedcedc39a9656c56e 100644 (file)
--- a/v8/src/runtime/infutl.scm
+++ b/v8/src/runtime/infutl.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: infutl.scm,v 1.48 1993/11/09 04:31:38 cph Exp $
+$Id: infutl.scm,v 1.49 1993/11/18 00:47:13 cph Exp $
 
-Copyright (c) 1988-1993 Massachusetts Institute of Technology
+Copyright (c) 1988-93 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -94,8 +94,8 @@ MIT in each case. |#
        (else
         false)))
 
-(define (read-binf-file filename)
-  (let ((pathname (merge-pathnames filename)))
+(define (read-binf-file pathname)
+  (let ((pathname (canonicalize-debug-info-pathname pathname)))
     (if (file-exists? pathname)
        (fasload-loader (->namestring pathname))
        (find-alternate-file-type pathname
@@ -189,11 +189,11 @@ MIT in each case. |#
 
 (define (compiled-code-block/filename block)
   (let loop ((info (compiled-code-block/debugging-info block)))
-    (cond ((string? info) (values info false))
+    (cond ((string? info) (values (canonicalize-debug-info-filename info) #f))
          ((not (pair? info)) (values false false))
          ((dbg-info? (car info)) (loop (cdr info)))
          ((string? (car info))
-          (values (car info)
+          (values (canonicalize-debug-info-filename (car info))
                   (and (exact-nonnegative-integer? (cdr info))
                        (cdr info))))
          (else (values false false)))))
@@ -261,6 +261,13 @@ MIT in each case. |#
 (define directory-rewriting-rules
   '())
 
+(define (with-directory-rewriting-rule match replace thunk)
+  (fluid-let ((directory-rewriting-rules
+              (cons (cons (pathname-as-directory (merge-pathnames match))
+                          replace)
+                    directory-rewriting-rules)))
+    (thunk)))
+
 (define (add-directory-rewriting-rule! match replace)
   (let ((match (pathname-as-directory (merge-pathnames match))))
     (let ((rule
@@ -283,19 +290,12 @@ MIT in each case. |#
                                (pathname-directory (car rule)))))))
     (->namestring
      (if rule
-        (let ((replacement (cdr rule))
-              (remaining-directories
-               (list-tail (pathname-directory pathname)
-                          (length (pathname-directory (car rule))))))
-          ;; Moby kludge: we are going to fool the pathname abstraction
-          ;; into giving us a namestring that might contain uncanonicalized
-          ;; characters in them.  This will break if the pathname abstraction
-          ;; cares at all.
-          (pathname-new-device
-           (pathname-new-directory 
-            pathname
-            `(relative ,replacement ,@remaining-directories))
-           false))
+        (merge-pathnames
+         (pathname-new-directory
+          pathname
+          (list-tail (pathname-directory pathname)
+                     (length (pathname-directory (car rule)))))
+         (cdr rule))
         pathname))))
 
 (define (directory-prefix? x y)
@@ -307,6 +307,20 @@ MIT in each case. |#
             (and (not (null? x))
                  (equal? (car x) (car y))
                  (loop (cdr x) (cdr y)))))))
+
+(define (canonicalize-debug-info-filename filename)
+  (->namestring (canonicalize-debug-info-pathname filename)))
+
+(define (canonicalize-debug-info-pathname pathname)
+  (if (pathname-absolute? pathname)
+      pathname
+      (merge-pathnames
+       pathname
+       (let ((value
+             (get-environment-variable "MITSCHEME_INF_DIRECTORY")))
+        (if value
+            (pathname-as-directory value)
+            (system-library-directory-pathname "SRC"))))))
 \f
 (define-integrable (dbg-block/layout-first-offset block)
   (let ((layout (dbg-block/layout block)))
@@ -405,7 +419,9 @@ MIT in each case. |#
 
 (define (read-bsm-file name)
   (let ((pathname
-        (let ((pathname (merge-pathnames (process-bsym-filename name))))
+        (let ((pathname
+               (canonicalize-debug-info-pathname
+                (rewrite-directory (merge-pathnames name)))))
           (if (file-exists? pathname)
               pathname
               (let loop ((types '("bsm" "bcs")))
@@ -419,10 +435,6 @@ MIT in each case. |#
         (if (equal? "bcs" (pathname-type pathname))
             ((compressed-loader "bsm") pathname)
             (fasload-loader pathname)))))
-
-(define (process-bsym-filename name)
-  (rewrite-directory (merge-pathnames name)))
-
 \f
 ;;;; Splitting of info structures
 

diff --git a/v8/src/runtime/make.scm b/v8/src/runtime/make.scm
index 3729e6994395ba2afc6464935ba29f18625a1a6d..142fad482db6a937fce7b69df9de31c656bac3c1 100644 (file)
--- a/v8/src/runtime/make.scm
+++ b/v8/src/runtime/make.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: make.scm,v 14.49 1993/09/19 22:38:02 adams Exp $
+$Id: make.scm,v 14.50 1993/11/18 00:47:19 cph Exp $
 
-Copyright (c) 1988-1993 Massachusetts Institute of Technology
+Copyright (c) 1988-93 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -481,17 +481,22 @@ MIT in each case. |#
 
 (let ((roots
        (list->vector
-       (let ((fasload/update-debugging-info!
-              (access fasload/update-debugging-info!
-                      (->environment '(RUNTIME COMPILER-INFO))))
-             (load/purification-root
-              (access load/purification-root
-                      (->environment '(RUNTIME LOAD)))))
-         (map (lambda (entry)
-                (let ((object (cdr entry)))
-                  (fasload/update-debugging-info! object (car entry))
-                  (load/purification-root object)))
-              fasload-purification-queue)))))
+       ((access with-directory-rewriting-rule
+                (->environment '(RUNTIME COMPILER-INFO)))
+        (working-directory-pathname)
+        (pathname-as-directory "runtime")
+        (lambda ()
+          (let ((fasload/update-debugging-info!
+                 (access fasload/update-debugging-info!
+                         (->environment '(RUNTIME COMPILER-INFO))))
+                (load/purification-root
+                 (access load/purification-root
+                         (->environment '(RUNTIME LOAD)))))
+            (map (lambda (entry)
+                   (let ((object (cdr entry)))
+                     (fasload/update-debugging-info! object (car entry))
+                     (load/purification-root object)))
+                 fasload-purification-queue)))))))
   (set! (access gc-boot-loading? (->environment '(RUNTIME GARBAGE-COLLECTOR)))
        false)
   (set! fasload-purification-queue)
@@ -507,4 +512,4 @@ MIT in each case. |#
 
 (package/add-child! system-global-package 'USER user-initial-environment)
 (start-thread-timer)
-(initial-top-level-repl)
+(initial-top-level-repl)
\ No newline at end of file