From: Chris Hanson Date: Tue, 5 Nov 1991 20:37:28 +0000 (+0000) Subject: New procedure PATHNAME-SIMPLIFY maps a pathname into an equivalent X-Git-Tag: 20090517-FFI~10072 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=4da2202109e25afdb3aa2acaa9a8e52024d08010;p=mit-scheme.git 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 b28ac5b14..4b603784e 100644 --- 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))) (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))) ;;;; 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 dd654800e..2ae709555 100644 --- 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 c5ee3e944..8192399ed 100644 --- 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)) ;;;; 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 6abef9f4e..815519741 100644 --- 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 12648d8ad..ea6f72078 100644 --- 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?