Fixed directory rewriting.

diff --git a/v7/src/runtime/infutl.scm b/v7/src/runtime/infutl.scm
index 5c6b82a47fb03c37016728edd1084fef8b086114..e33df9f43dcae5ef9a25c4cacc064e07c7608da8 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.39 1992/05/28 18:58:44 mhwu Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/infutl.scm,v 1.40 1992/05/28 22:41:02 mhwu Exp $
 
 Copyright (c) 1988-91 Massachusetts Institute of Technology
 
@@ -228,24 +228,23 @@ MIT in each case. |#
 
 (define (process-binf-filename binf-filename com-pathname)
   (and binf-filename
-       (->namestring
-       (rewrite-directory
-        (let ((binf-pathname (merge-pathnames binf-filename))
-              (com-pathname (merge-pathnames com-pathname)))
-          (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))))))
+       (rewrite-directory
+       (let ((binf-pathname (merge-pathnames binf-filename))
+             (com-pathname (merge-pathnames com-pathname)))
+         (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 (merge-pathnames match)))
+  (let ((match (pathname-as-directory (merge-pathnames match))))
     (let ((rule
           (list-search-positive directory-rewriting-rules
             (lambda (rule)
@@ -264,16 +263,20 @@ MIT in each case. |#
           (lambda (rule)
             (directory-prefix? (pathname-directory pathname)
                                (pathname-directory (car rule)))))))
-    (if rule
-       (let ((replacement-directory (merge-pathnames (cdr rule))))
-         (pathname-new-device
-          (pathname-new-directory
+    (->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-directory 
            pathname
-           (append (pathname-directory replacement-directory)
-                   (list-tail (pathname-directory pathname)
-                              (length (pathname-directory (car rule))))))
-          (pathname-device replacement-directory)))
-       pathname)))
+           `(relative ,replacement ,@remaining-directories)))
+        pathanme))))
 
 (define (directory-prefix? x y)
   (and (pair? x)
@@ -381,17 +384,15 @@ MIT in each case. |#
         false)))
 
 (define (read-bsm-file name)
-  (let ((filename (process-bsym-filename name)))
-    (if (file-exists? filename)
-       (fasload-loader filename)
-       (let ((pathname (merge-pathnames filename)))
-         (find-alternate-file-type pathname
-                                   `(("bsm" . ,fasload-loader)
-                                     ("bcs" . ,compressed-loader)))))))
+  (let ((pathname (merge-pathnames (process-bsym-filename name))))
+    (if (file-exists? pathname)
+       (fasload-loader pathname)
+       (find-alternate-file-type pathname
+                                 `(("bsm" . ,fasload-loader)
+                                   ("bcs" . ,compressed-loader))))))
 
 (define (process-bsym-filename name)
-  (->namestring
-   (rewrite-directory (merge-pathnames name))))
+  (rewrite-directory (merge-pathnames name)))
 
 \f;;; The conversion hack.
 

diff --git a/v7/src/runtime/site.scm.dos b/v7/src/runtime/site.scm.dos
index ebbb9817849d528682c9e357ce80756843b072df..f7fb94f5b4523384abddc5cfe1b1bee642d8d3dd 100644 (file)
--- a/v7/src/runtime/site.scm.dos
+++ b/v7/src/runtime/site.scm.dos
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/site.scm.dos,v 1.4 1992/05/28 18:46:41 mhwu Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/site.scm.dos,v 1.5 1992/05/28 22:43:20 mhwu Exp $
 
 Copyright (c) 1988-1992 Massachusetts Institute of Technology
 
@@ -49,10 +49,8 @@ MIT in each case. |#
               (->environment '(runtime compiler-info)))))
   (for-each
    (lambda (path)
-     (add-directory-rewriting-rule! path "$mitscheme_inf_directory/"))
-   '("/scheme/")))
-
-(set-environment-variable! "mitscheme_inf_directory" "c:/scheme") ; default
+     (add-directory-rewriting-rule! path "$mitscheme_inf_directory"))
+   '("/scheme")))
 
 ;;; Dos specific:
 ;;; Timer hook to get interrupt keys

diff --git a/v7/src/runtime/site.scm.unix b/v7/src/runtime/site.scm.unix
index ca2cfb36bfa9e7bb664fc59d66c0914c25b35241..f02b608a3a9d0b57bffed03690a8075d1f08cda7 100644 (file)
--- a/v7/src/runtime/site.scm.unix
+++ b/v7/src/runtime/site.scm.unix
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/site.scm.unix,v 1.8 1992/03/03 23:24:39 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/site.scm.unix,v 1.9 1992/05/28 22:42:48 mhwu Exp $
 
 Copyright (c) 1988-1992 Massachusetts Institute of Technology
 
@@ -60,15 +60,14 @@ MIT in each case. |#
               (->environment '(runtime compiler-info)))))
   (for-each
    (lambda (path)
-     (add-directory-rewriting-rule! path "/usr/local/lib/mit-scheme/SRC/"))
-   '("/scheme/300/"
-     "/altdorf/scheme/300/"
-     "/nfs/altdorf/root/scheme/300/"
-     "/scheme/800/"
-     "/altdorf/scheme/800"
-     "/nfs/altdorf/root/scheme/800/"
-     "/scheme/700/"
+     (add-directory-rewriting-rule! path "/usr/local/lib/mit-scheme/SRC"))
+   '("/scheme/300"
+     "/altdorf/scheme/300"
+     "/nfs/altdorf/root/scheme/300"
+     "/scheme/700"
      "/altdorf/scheme/700"
-     "/nfs/altdorf/root/scheme/700/"
-     "/scheme/SONY/"
-     "/nfs/altdorf/root/scheme/SONY/")))
\ No newline at end of file
+     "/nfs/altdorf/root/scheme/700"
+     "/scheme/SONY"
+     "/nfs/altdorf/root/scheme/SONY"
+     )
+   ))

diff --git a/v8/src/runtime/infutl.scm b/v8/src/runtime/infutl.scm
index bde72617fc8d19374cad820f8f784e18ce5aaf31..ca461c737aa191a61a3053368e51c3d4f34e9b78 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.39 1992/05/28 18:58:44 mhwu Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/infutl.scm,v 1.40 1992/05/28 22:41:02 mhwu Exp $
 
 Copyright (c) 1988-91 Massachusetts Institute of Technology
 
@@ -228,24 +228,23 @@ MIT in each case. |#
 
 (define (process-binf-filename binf-filename com-pathname)
   (and binf-filename
-       (->namestring
-       (rewrite-directory
-        (let ((binf-pathname (merge-pathnames binf-filename))
-              (com-pathname (merge-pathnames com-pathname)))
-          (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))))))
+       (rewrite-directory
+       (let ((binf-pathname (merge-pathnames binf-filename))
+             (com-pathname (merge-pathnames com-pathname)))
+         (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 (merge-pathnames match)))
+  (let ((match (pathname-as-directory (merge-pathnames match))))
     (let ((rule
           (list-search-positive directory-rewriting-rules
             (lambda (rule)
@@ -264,16 +263,20 @@ MIT in each case. |#
           (lambda (rule)
             (directory-prefix? (pathname-directory pathname)
                                (pathname-directory (car rule)))))))
-    (if rule
-       (let ((replacement-directory (merge-pathnames (cdr rule))))
-         (pathname-new-device
-          (pathname-new-directory
+    (->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-directory 
            pathname
-           (append (pathname-directory replacement-directory)
-                   (list-tail (pathname-directory pathname)
-                              (length (pathname-directory (car rule))))))
-          (pathname-device replacement-directory)))
-       pathname)))
+           `(relative ,replacement ,@remaining-directories)))
+        pathanme))))
 
 (define (directory-prefix? x y)
   (and (pair? x)
@@ -381,17 +384,15 @@ MIT in each case. |#
         false)))
 
 (define (read-bsm-file name)
-  (let ((filename (process-bsym-filename name)))
-    (if (file-exists? filename)
-       (fasload-loader filename)
-       (let ((pathname (merge-pathnames filename)))
-         (find-alternate-file-type pathname
-                                   `(("bsm" . ,fasload-loader)
-                                     ("bcs" . ,compressed-loader)))))))
+  (let ((pathname (merge-pathnames (process-bsym-filename name))))
+    (if (file-exists? pathname)
+       (fasload-loader pathname)
+       (find-alternate-file-type pathname
+                                 `(("bsm" . ,fasload-loader)
+                                   ("bcs" . ,compressed-loader))))))
 
 (define (process-bsym-filename name)
-  (->namestring
-   (rewrite-directory (merge-pathnames name))))
+  (rewrite-directory (merge-pathnames name)))
 
 \f;;; The conversion hack.