New procedure PATHNAME-SIMPLIFY maps a pathname into an equivalent

simpler pathname in a host-dependent fashion.  Unix provides one
simplification: ".." directories are removed when doing so does not
change the meaning of the pathname.

Additionally, treatment of pathname hosts changed to improve
performance, and to fix problems with fasdumping of pathname objects.
Current implementation permits pathnames to be fasdumped and then
fasloaded without changing their behavior.

diff --git a/v7/src/runtime/pathnm.scm b/v7/src/runtime/pathnm.scm
index b28ac5b14c0eadddef77bee6d278b95d502fd121..4b603784e5727ba821b06a5dd3e21fd6cd142ff9 100644 (file)
--- a/v7/src/runtime/pathnm.scm
+++ b/v7/src/runtime/pathnm.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pathnm.scm,v 14.17 1991/11/05 02:43:09 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pathnm.scm,v 14.18 1991/11/05 20:37:02 cph Exp $
 
 Copyright (c) 1988-91 Massachusetts Institute of Technology
 
@@ -154,7 +154,7 @@ these rules:
 (define (pathname=? x y)
   (let ((x (->pathname x))
        (y (->pathname y)))
-    (and (eq? (%pathname-host x) (%pathname-host y))
+    (and (host=? (%pathname-host x) (%pathname-host y))
         (equal? (%pathname-device x) (%pathname-device y))
         (equal? (%pathname-directory x) (%pathname-directory y))
         (equal? (%pathname-name x) (%pathname-name y))
@@ -169,6 +169,10 @@ these rules:
 (define (pathname-wild? pathname)
   (let ((pathname (->pathname pathname)))
     ((host-operation/pathname-wild? (%pathname-host pathname)) pathname)))
+
+(define (pathname-simplify pathname)
+  (let ((pathname (->pathname pathname)))
+    ((host-operation/pathname-simplify (%pathname-host pathname)) pathname)))
 \f
 (define (directory-pathname pathname)
   (let ((pathname (->pathname pathname)))
@@ -298,7 +302,7 @@ these rules:
     (cond ((string? namestring)
           ((host-operation/parse-namestring host) namestring host))
          ((pathname? namestring)
-          (if (not (eq? host (pathname-host namestring)))
+          (if (not (host=? host (pathname-host namestring)))
               (error:bad-range-argument namestring 'PARSE-NAMESTRING))
           namestring)
          (else
@@ -329,7 +333,7 @@ these rules:
              *default-pathname-defaults*)))
     (let ((pathname (enough-pathname pathname defaults)))
       (let ((namestring (pathname->namestring pathname)))
-       (if (eq? (%pathname-host pathname) (%pathname-host defaults))
+       (if (host=? (%pathname-host pathname) (%pathname-host defaults))
            namestring
            (string-append (host-namestring pathname) namestring))))))
 
@@ -350,7 +354,7 @@ these rules:
      (or (%pathname-host pathname) (%pathname-host defaults))
      (or (%pathname-device pathname)
         (and (%pathname-host pathname)
-             (eq? (%pathname-host pathname) (%pathname-host defaults))
+             (host=? (%pathname-host pathname) (%pathname-host defaults))
              (%pathname-device defaults)))
      (let ((directory (%pathname-directory pathname))
           (default (%pathname-directory defaults)))
@@ -383,14 +387,14 @@ these rules:
                  component))))
       (make-pathname
        (and (or (symbol? (%pathname-host pathname))
-               (not (eq? (%pathname-host pathname)
-                         (%pathname-host defaults))))
+               (not (host=? (%pathname-host pathname)
+                            (%pathname-host defaults))))
            (%pathname-host pathname))
        (let ((device (%pathname-device pathname)))
         (and (or (symbol? device)
                  (not (equal? device (%pathname-device defaults)))
-                 (not (eq? (%pathname-host pathname)
-                           (%pathname-host defaults))))
+                 (not (host=? (%pathname-host pathname)
+                              (%pathname-host defaults))))
              device))
        (let ((directory (%pathname-directory pathname))
             (default (%pathname-directory defaults)))
@@ -421,9 +425,8 @@ these rules:
 (define host-types)
 (define local-host)
 
-(define-structure (host-type
-                  (constructor %make-host-type)
-                  (conc-name host-type/))
+(define-structure (host-type (conc-name host-type/))
+  (index false read-only true)
   (name false read-only true)
   (operation/parse-namestring false read-only true)
   (operation/pathname->namestring false read-only true)
@@ -433,35 +436,25 @@ these rules:
   (operation/directory-pathname-as-file false read-only true)
   (operation/pathname->truename false read-only true)
   (operation/user-homedir-pathname false read-only true)
-  (operation/init-file-pathname false read-only true))
-
-(define (make-host-type name . operations)
-  (let ((type (apply %make-host-type name operations)))
-    (let loop ((types host-types))
-      (cond ((null? types)
-            (set! host-types (cons type host-types)))
-           ((eq? name (host-type/name (car types)))
-            (set-car! types type))
-           (else
-            (loop (cdr types)))))
-    type))
+  (operation/init-file-pathname false read-only true)
+  (operation/pathname-simplify false read-only true))
 
 (define-structure (host
                   (named (string->symbol "#[(runtime pathname)host]"))
                   (constructor %make-host)
                   (conc-name host/))
-  (type-name false read-only true)
+  (type-index false read-only true)
   (name false read-only true))
 
 (define (make-host type name)
-  (%make-host (host-type/name type) name))
+  (%make-host (host-type/index type) name))
 
 (define (host/type host)
-  (let ((name (host/type-name host)))
-    (let loop ((types host-types))
-      (cond ((null? types) (error "Unknown host type:" host))
-           ((eq? name (host/type-name (car types))) (car types))
-           (else (loop (cdr types)))))))
+  (vector-ref host-types (host/type-index host)))
+
+(define (host=? x y)
+  (and (= (host/type-index x) (host/type-index y))
+       (equal? (host/name x) (host/name y))))
 
 (define (guarantee-host host operation)
   (if (not (host? host))
@@ -494,6 +487,9 @@ these rules:
 
 (define (host-operation/init-file-pathname host)
   (host-type/operation/init-file-pathname (host/type host)))
+
+(define (host-operation/pathname-simplify host)
+  (host-type/operation/pathname-simplify (host/type host)))
 \f
 ;;;; File System Stuff
 
@@ -560,8 +556,9 @@ these rules:
   (add-event-receiver! event:after-restore reset-package!))
 
 (define (reset-package!)
-  (set! host-types '())
-  (set! local-host (make-host (make-unix-host-type) false))
+  (let ((unix-host-type (make-unix-host-type 0)))
+    (set! host-types (vector unix-host-type))
+    (set! local-host (make-host unix-host-type false)))
   (set! *default-pathname-defaults*
        (make-pathname local-host false false false false false))
   (set! library-directory-path

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index dd654800e8044ff03839f0103109ddd8c3ca40a4..2ae7095551e604b7ff98c03cf5a2cae0d02953f7 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.125 1991/11/04 20:29:45 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.126 1991/11/05 20:37:11 cph Exp $
 
 Copyright (c) 1988-91 Massachusetts Institute of Technology
 
@@ -1389,6 +1389,7 @@ MIT in each case. |#
          file-namestring
          file-pathname
          host-namestring
+         host=?
          host?
          init-file-pathname
          local-host
@@ -1412,6 +1413,7 @@ MIT in each case. |#
          pathname-new-name
          pathname-new-type
          pathname-new-version
+         pathname-simplify
          pathname-type
          pathname-version
          pathname-wild?

diff --git a/v7/src/runtime/unxpth.scm b/v7/src/runtime/unxpth.scm
index c5ee3e944bee46ce872e27f2e9f590b3c4da910e..8192399edccb77436ce30aaf4792d2cf79f01d6f 100644 (file)
--- a/v7/src/runtime/unxpth.scm
+++ b/v7/src/runtime/unxpth.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unxpth.scm,v 14.7 1991/11/04 20:30:27 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unxpth.scm,v 14.8 1991/11/05 20:37:21 cph Exp $
 
 Copyright (c) 1988-91 Massachusetts Institute of Technology
 
@@ -37,8 +37,9 @@ MIT in each case. |#
 
 (declare (usual-integrations))
 
-(define (make-unix-host-type)
-  (make-host-type 'UNIX
+(define (make-unix-host-type index)
+  (make-host-type index
+                 'UNIX
                  unix/parse-namestring
                  unix/pathname->namestring
                  unix/make-pathname
@@ -47,7 +48,8 @@ MIT in each case. |#
                  unix/directory-pathname-as-file
                  unix/pathname->truename
                  unix/user-homedir-pathname
-                 unix/init-file-pathname))
+                 unix/init-file-pathname
+                 unix/pathname-simplify))
 \f
 ;;;; Pathname Parser
 
@@ -261,4 +263,31 @@ MIT in each case. |#
   (let ((pathname
         (merge-pathnames ".scheme.init" (unix/user-homedir-pathname host))))
     (and (file-exists? pathname)
-        pathname)))
\ No newline at end of file
+        pathname)))
+
+(define (unix/pathname-simplify pathname)
+  (or (and (implemented-primitive-procedure? (ucode-primitive file-eq? 2))
+          (let ((directory (pathname-directory pathname)))
+            (and (pair? directory)
+                 (let ((directory*
+                        (cons (car directory)
+                              (reverse!
+                               (let loop
+                                   ((elements (reverse (cdr directory))))
+                                 (if (null? elements)
+                                     '()
+                                      (let ((head (car elements))
+                                            (tail (loop (cdr elements))))
+                                        (if (and (eq? head 'UP)
+                                                 (not (null? tail))
+                                                 (not (eq? (car tail) 'UP)))
+                                            (cdr tail)
+                                            (cons head tail)))))))))
+                   (and (not (equal? directory directory*))
+                        (let ((pathname*
+                               (pathname-new-directory pathname directory*)))
+                          (and ((ucode-primitive file-eq? 2)
+                                (->namestring pathname)
+                                (->namestring pathname*))
+                               pathname*)))))))
+      pathname))
\ No newline at end of file

diff --git a/v7/src/runtime/wrkdir.scm b/v7/src/runtime/wrkdir.scm
index 6abef9f4ea9e5fbdfe57d1d57a01a82b0d399bdb..8155197417018be12f2a70601513fda339007d4a 100644 (file)
--- a/v7/src/runtime/wrkdir.scm
+++ b/v7/src/runtime/wrkdir.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/wrkdir.scm,v 14.3 1991/11/04 20:30:42 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/wrkdir.scm,v 14.4 1991/11/05 20:37:28 cph Exp $
 
 Copyright (c) 1988-91 Massachusetts Institute of Technology
 
@@ -43,7 +43,7 @@ MIT in each case. |#
 
 (define (reset!)
   (let ((pathname
-        (simplify-directory
+        (pathname-simplify
          (pathname-as-directory
           ((ucode-primitive working-directory-pathname))))))
     (set! *working-directory-pathname* pathname)
@@ -63,7 +63,7 @@ MIT in each case. |#
          (merge-pathnames name *working-directory-pathname*))))
     (if (not (file-directory? pathname))
        (error "Not a valid directory:" pathname))
-    (let ((pathname (simplify-directory pathname)))
+    (let ((pathname (pathname-simplify pathname)))
       (if (eq? *default-pathname-defaults* *working-directory-pathname*)
          (set! *default-pathname-defaults* pathname))
       (set! *working-directory-pathname* pathname)
@@ -85,31 +85,4 @@ MIT in each case. |#
                  thunk
                  (lambda ()
                    (set! name (working-directory-pathname))
-                   (set-working-directory-pathname! old-pathname)))))
-
-(define (simplify-directory pathname)
-  (or (and (implemented-primitive-procedure? (ucode-primitive file-eq? 2))
-          (let ((directory (pathname-directory pathname)))
-            (and (pair? directory)
-                 (let ((directory*
-                        (cons (car directory)
-                              (reverse!
-                               (let loop
-                                   ((elements (reverse (cdr directory))))
-                                 (if (null? elements)
-                                     '()
-                                      (let ((head (car elements))
-                                            (tail (loop (cdr elements))))
-                                        (if (and (eq? head 'UP)
-                                                 (not (null? tail))
-                                                 (not (eq? (car tail) 'UP)))
-                                            (cdr tail)
-                                            (cons head tail)))))))))
-                   (and (not (equal? directory directory*))
-                        (let ((pathname*
-                               (pathname-new-directory pathname directory*)))
-                          (and ((ucode-primitive file-eq? 2)
-                                (->namestring pathname)
-                                (->namestring pathname*))
-                               pathname*)))))))
-      pathname))
\ No newline at end of file
+                   (set-working-directory-pathname! old-pathname)))))
\ No newline at end of file

diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg
index 12648d8ad523f8bf75bf798dd20c72ca883a150d..ea6f720783d56c3c294eb008aa3067f9c1646006 100644 (file)
--- a/v8/src/runtime/runtime.pkg
+++ b/v8/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.125 1991/11/04 20:29:45 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.126 1991/11/05 20:37:11 cph Exp $
 
 Copyright (c) 1988-91 Massachusetts Institute of Technology
 
@@ -1389,6 +1389,7 @@ MIT in each case. |#
          file-namestring
          file-pathname
          host-namestring
+         host=?
          host?
          init-file-pathname
          local-host
@@ -1412,6 +1413,7 @@ MIT in each case. |#
          pathname-new-name
          pathname-new-type
          pathname-new-version
+         pathname-simplify
          pathname-type
          pathname-version
          pathname-wild?