Add mechanism to allow normalization of directory prefixes. Add

"site" file mechanism to cold load to allow this to be performed in a
site-specific manner.

diff --git a/v7/src/runtime/infutl.scm b/v7/src/runtime/infutl.scm
index 2775a9199c1b2c5fe0887a42b563db2c3c891bc8..17877f2e218302441739567258a75e34d9f7bad1 100644 (file)
--- a/v7/src/runtime/infutl.scm
+++ b/v7/src/runtime/infutl.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/infutl.scm,v 1.5 1988/12/30 23:30:00 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/infutl.scm,v 1.6 1988/12/31 05:52:51 cph Exp $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -113,7 +113,7 @@ MIT in each case. |#
     (let ((dbg-info
           (compiled-code-block/dbg-info block
                                         (if (default-object? demand-load?)
-                                            false
+                                            true
                                             demand-load?))))
       (and dbg-info
           (discriminate-compiled-entry entry
@@ -170,38 +170,79 @@ MIT in each case. |#
                     ((< key* key) (loop (1+ midpoint) end))
                     (else item))))))))\f
 (define (fasload/update-debugging-info! value com-pathname)
-  (let ((process-filename
-        (lambda (binf-filename)
-          (let ((binf-pathname (string->pathname binf-filename)))
-            (if (and (equal? (pathname-name binf-pathname)
-                             (pathname-name com-pathname))
-                     (not (equal? (pathname-type binf-pathname)
-                                  (pathname-type com-pathname)))
-                     (equal? (pathname-version binf-pathname)
-                             (pathname-version com-pathname)))
-                (pathname->string
-                 (pathname-new-type com-pathname
-                                    (pathname-type binf-pathname)))
-                binf-filename)))))
-    (let ((process-entry
-          (lambda (entry)
-            (let ((block (compiled-code-address->block entry)))
-              (let ((info (compiled-code-block/debugging-info block)))
-                (cond ((string? info)
-                       (set-compiled-code-block/debugging-info!
-                        block
-                        (process-filename info)))
-                      ((and (pair? info) (string? (car info)))
-                       (set-car! info (process-filename (car info))))))))))
-      (cond ((compiled-code-address? value)
-            (process-entry value))
-           ((comment? value)
-            (let ((text (comment-text value)))
-              (if (dbg-info-vector? text)
-                  (for-each
-                   process-entry
-                   (vector->list (dbg-info-vector/items text))))))))))
+  (let ((process-entry
+        (lambda (entry)
+          (let ((block (compiled-code-address->block entry)))
+            (let ((info (compiled-code-block/debugging-info block)))
+              (cond ((string? info)
+                     (set-compiled-code-block/debugging-info!
+                      block
+                      (process-binf-filename info com-pathname)))
+                    ((and (pair? info) (string? (car info)))
+                     (set-car! info
+                               (process-binf-filename (car info)
+                                                      com-pathname)))))))))
+    (cond ((compiled-code-address? value)
+          (process-entry value))
+         ((comment? value)
+          (let ((text (comment-text value)))
+            (if (dbg-info-vector? text)
+                (for-each
+                 process-entry
+                 (vector->list (dbg-info-vector/items text)))))))))
+(define (process-binf-filename binf-filename com-pathname)
+  (pathname->string
+   (rewrite-directory
+    (let ((binf-pathname
+          (pathname->absolute-pathname
+           (->pathname binf-filename))))
+      (if (and (equal? (pathname-name binf-pathname)
+                      (pathname-name com-pathname))
+              (not (equal? (pathname-type binf-pathname)
+                           (pathname-type com-pathname)))
+              (equal? (pathname-version binf-pathname)
+                      (pathname-version com-pathname)))
+         (pathname-new-type com-pathname
+                            (pathname-type binf-pathname))       binf-pathname)))))
+
+(define directory-rewriting-rules
+  '())
+
+(define (add-directory-rewriting-rule! match replace)
+  (let ((match (pathname->absolute-pathname (->pathname match)))
+       (replace (pathname->absolute-pathname (->pathname replace))))
+    (let ((rule
+          (list-search-positive directory-rewriting-rules
+            (lambda (rule)
+              (equal? (pathname-directory (car rule))
+                      (pathname-directory match))))))
+      (if rule
+         (set-cdr! rule replace)
+         (set! directory-rewriting-rules
+               (cons (cons match replace)
+                     directory-rewriting-rules)))))
+  unspecific)
 
+(define (rewrite-directory pathname)
+  (let ((rule
+        (list-search-positive directory-rewriting-rules
+          (lambda (rule)
+            (directory-prefix? (pathname-directory pathname)
+                               (pathname-directory (car rule)))))))
+    (if rule
+       (pathname-new-directory
+        pathname
+        (append (pathname-directory (cdr rule))
+                (list-tail (pathname-directory pathname)
+                           (length (pathname-directory (car rule))))))
+       pathname)))
+
+(define (directory-prefix? x y)
+  (or (null? y)
+      (and (not (null? x))
+          (equal? (car x) (car y))
+          (directory-prefix? (cdr x) (cdr y)))))
+\f
 (define (dbg-block/dynamic-link-index block)
   (vector-find-next-element (dbg-block/layout block)
                            dbg-block-name/dynamic-link))

diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm
index fffe4ad324ce906b7c9c97f1b54cbe5386cd979d..8563169781781bd979cab2df7b65c29d6b31e701 100644 (file)
--- a/v7/src/runtime/make.scm
+++ b/v7/src/runtime/make.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/make.scm,v 14.6 1988/12/30 23:30:07 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/make.scm,v 14.7 1988/12/31 05:52:59 cph Exp $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -376,12 +376,21 @@ MIT in each case. |#
    (RUNTIME EMACS-INTERFACE)
    ))
 \f
+(let ((pathname (->pathname "site")))
+  (let ((type
+        (list-search-positive load/default-types
+          (lambda (type)
+            (file-exists? (pathname-new-type type))))))
+    (if type
+       (load (pathname-new-type pathname type) '()))))
+
 (let ((fasload/update-debugging-info!
        (access fasload/update-debugging-info!
               (->environment '(RUNTIME COMPILER-INFO)))))
   (for-each (lambda (entry)
-             (fasload/update-debugging-info! (cdr entry)
-                                             (->pathname (car entry))))
+             (fasload/update-debugging-info!
+              (cdr entry)
+              (pathname->absolute-pathname (->pathname (car entry)))))
            fasload-saved-values))
 
 )

diff --git a/v8/src/runtime/infutl.scm b/v8/src/runtime/infutl.scm
index 8633e2bdd5cf3320b48db87c3eb8f791e8967471..de0eeee7fe0d433d5944721849c07a78a20fb5c0 100644 (file)
--- a/v8/src/runtime/infutl.scm
+++ b/v8/src/runtime/infutl.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/infutl.scm,v 1.5 1988/12/30 23:30:00 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/infutl.scm,v 1.6 1988/12/31 05:52:51 cph Exp $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -113,7 +113,7 @@ MIT in each case. |#
     (let ((dbg-info
           (compiled-code-block/dbg-info block
                                         (if (default-object? demand-load?)
-                                            false
+                                            true
                                             demand-load?))))
       (and dbg-info
           (discriminate-compiled-entry entry
@@ -170,38 +170,79 @@ MIT in each case. |#
                     ((< key* key) (loop (1+ midpoint) end))
                     (else item))))))))\f
 (define (fasload/update-debugging-info! value com-pathname)
-  (let ((process-filename
-        (lambda (binf-filename)
-          (let ((binf-pathname (string->pathname binf-filename)))
-            (if (and (equal? (pathname-name binf-pathname)
-                             (pathname-name com-pathname))
-                     (not (equal? (pathname-type binf-pathname)
-                                  (pathname-type com-pathname)))
-                     (equal? (pathname-version binf-pathname)
-                             (pathname-version com-pathname)))
-                (pathname->string
-                 (pathname-new-type com-pathname
-                                    (pathname-type binf-pathname)))
-                binf-filename)))))
-    (let ((process-entry
-          (lambda (entry)
-            (let ((block (compiled-code-address->block entry)))
-              (let ((info (compiled-code-block/debugging-info block)))
-                (cond ((string? info)
-                       (set-compiled-code-block/debugging-info!
-                        block
-                        (process-filename info)))
-                      ((and (pair? info) (string? (car info)))
-                       (set-car! info (process-filename (car info))))))))))
-      (cond ((compiled-code-address? value)
-            (process-entry value))
-           ((comment? value)
-            (let ((text (comment-text value)))
-              (if (dbg-info-vector? text)
-                  (for-each
-                   process-entry
-                   (vector->list (dbg-info-vector/items text))))))))))
+  (let ((process-entry
+        (lambda (entry)
+          (let ((block (compiled-code-address->block entry)))
+            (let ((info (compiled-code-block/debugging-info block)))
+              (cond ((string? info)
+                     (set-compiled-code-block/debugging-info!
+                      block
+                      (process-binf-filename info com-pathname)))
+                    ((and (pair? info) (string? (car info)))
+                     (set-car! info
+                               (process-binf-filename (car info)
+                                                      com-pathname)))))))))
+    (cond ((compiled-code-address? value)
+          (process-entry value))
+         ((comment? value)
+          (let ((text (comment-text value)))
+            (if (dbg-info-vector? text)
+                (for-each
+                 process-entry
+                 (vector->list (dbg-info-vector/items text)))))))))
+(define (process-binf-filename binf-filename com-pathname)
+  (pathname->string
+   (rewrite-directory
+    (let ((binf-pathname
+          (pathname->absolute-pathname
+           (->pathname binf-filename))))
+      (if (and (equal? (pathname-name binf-pathname)
+                      (pathname-name com-pathname))
+              (not (equal? (pathname-type binf-pathname)
+                           (pathname-type com-pathname)))
+              (equal? (pathname-version binf-pathname)
+                      (pathname-version com-pathname)))
+         (pathname-new-type com-pathname
+                            (pathname-type binf-pathname))       binf-pathname)))))
+
+(define directory-rewriting-rules
+  '())
+
+(define (add-directory-rewriting-rule! match replace)
+  (let ((match (pathname->absolute-pathname (->pathname match)))
+       (replace (pathname->absolute-pathname (->pathname replace))))
+    (let ((rule
+          (list-search-positive directory-rewriting-rules
+            (lambda (rule)
+              (equal? (pathname-directory (car rule))
+                      (pathname-directory match))))))
+      (if rule
+         (set-cdr! rule replace)
+         (set! directory-rewriting-rules
+               (cons (cons match replace)
+                     directory-rewriting-rules)))))
+  unspecific)
 
+(define (rewrite-directory pathname)
+  (let ((rule
+        (list-search-positive directory-rewriting-rules
+          (lambda (rule)
+            (directory-prefix? (pathname-directory pathname)
+                               (pathname-directory (car rule)))))))
+    (if rule
+       (pathname-new-directory
+        pathname
+        (append (pathname-directory (cdr rule))
+                (list-tail (pathname-directory pathname)
+                           (length (pathname-directory (car rule))))))
+       pathname)))
+
+(define (directory-prefix? x y)
+  (or (null? y)
+      (and (not (null? x))
+          (equal? (car x) (car y))
+          (directory-prefix? (cdr x) (cdr y)))))
+\f
 (define (dbg-block/dynamic-link-index block)
   (vector-find-next-element (dbg-block/layout block)
                            dbg-block-name/dynamic-link))

diff --git a/v8/src/runtime/make.scm b/v8/src/runtime/make.scm
index a6004bd17645691afba21696fd3827632689036f..e194ee80ec8a7e348c9e3f8f2f3858dd75fd6afb 100644 (file)
--- a/v8/src/runtime/make.scm
+++ b/v8/src/runtime/make.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/make.scm,v 14.6 1988/12/30 23:30:07 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/make.scm,v 14.7 1988/12/31 05:52:59 cph Exp $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -376,12 +376,21 @@ MIT in each case. |#
    (RUNTIME EMACS-INTERFACE)
    ))
 \f
+(let ((pathname (->pathname "site")))
+  (let ((type
+        (list-search-positive load/default-types
+          (lambda (type)
+            (file-exists? (pathname-new-type type))))))
+    (if type
+       (load (pathname-new-type pathname type) '()))))
+
 (let ((fasload/update-debugging-info!
        (access fasload/update-debugging-info!
               (->environment '(RUNTIME COMPILER-INFO)))))
   (for-each (lambda (entry)
-             (fasload/update-debugging-info! (cdr entry)
-                                             (->pathname (car entry))))
+             (fasload/update-debugging-info!
+              (cdr entry)
+              (pathname->absolute-pathname (->pathname (car entry)))))
            fasload-saved-values))
 
 )