From: Henry M. Wu <edu/mit/csail/zurich/mhwu>
Date: Thu, 28 May 1992 22:43:20 +0000 (+0000)
Subject: Fixed directory rewriting.
X-Git-Tag: 20090517-FFI~9318
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=b987e5ad83fadd422f569c58b7d6e0fcb89f49d7;p=mit-scheme.git

Fixed directory rewriting.
---

diff --git a/v7/src/runtime/infutl.scm b/v7/src/runtime/infutl.scm
index 5c6b82a47..e33df9f43 100644
--- 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)))
 
 ;;; The conversion hack.
 
diff --git a/v7/src/runtime/site.scm.dos b/v7/src/runtime/site.scm.dos
index ebbb98178..f7fb94f5b 100644
--- 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 ca2cfb36b..f02b608a3 100644
--- 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 bde72617f..ca461c737 100644
--- 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)))
 
 ;;; The conversion hack.