From 88bd879a5811e4243c939ec1c66c8e9e43e5756b Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 28 Nov 1994 05:45:12 +0000 Subject: [PATCH] Eliminate "canonicalization" from pathname abstraction; this doesn't belong here. Change pathname abstraction so that DOS, NT, and OS/2 can share an single pathname implementation. --- v7/src/runtime/dospth.scm | 181 +++++++++++++++----------------------- v7/src/runtime/make.scm | 3 +- v7/src/runtime/pathnm.scm | 157 ++++++++++++++++----------------- v7/src/runtime/unxpth.scm | 10 +-- v8/src/runtime/make.scm | 3 +- 5 files changed, 151 insertions(+), 203 deletions(-) diff --git a/v7/src/runtime/dospth.scm b/v7/src/runtime/dospth.scm index 9ed69eb42..89b1398fa 100644 --- a/v7/src/runtime/dospth.scm +++ b/v7/src/runtime/dospth.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: dospth.scm,v 1.18 1993/01/12 23:09:04 gjr Exp $ +$Id: dospth.scm,v 1.19 1994/11/28 05:43:49 cph Exp $ -Copyright (c) 1992-1993 Massachusetts Institute of Technology +Copyright (c) 1992-94 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -36,7 +36,7 @@ MIT in each case. |# ;;; package: (runtime pathname dos) (declare (usual-integrations)) - + (define hook/dos/end-of-line-string) (define hook/dos/end-of-file-marker/input) (define hook/dos/end-of-file-marker/output) @@ -67,28 +67,30 @@ MIT in each case. |# dos/init-file-pathname dos/pathname-simplify dos/end-of-line-string - dos/canonicalize dos/end-of-file-marker/input dos/end-of-file-marker/output)) (define (initialize-package!) (set! hook/dos/end-of-line-string default/dos/end-of-line-string) (set! hook/dos/end-of-file-marker/input default/dos/end-of-file-marker/input) - (set! hook/dos/end-of-file-marker/output default/dos/end-of-file-marker/output) + (set! hook/dos/end-of-file-marker/output + default/dos/end-of-file-marker/output) (add-pathname-host-type! 'DOS make-dos-host-type)) ;;;; Pathname Parser (define (dos/parse-namestring string host) - ;; The DOS file system is case-insensitive, and the canonical case - ;; is upper, but it is too inconvenient to type. - (let ((components (string-components (string-downcase string) - sub-directory-delimiters))) - (with-namestring-device-and-path - (expand-directory-prefixes (car components)) + (let ((components + (string-components (string-downcase string) + sub-directory-delimiters))) + (call-with-values + (lambda () + (parse-device-and-path (expand-directory-prefixes (car components)))) (lambda (device directory-components) (let ((components (append directory-components (cdr components)))) - (parse-name (car (last-pair components)) + (call-with-values + (lambda () + (parse-name (car (last-pair components)))) (lambda (name type) (%make-pathname host device @@ -106,115 +108,72 @@ MIT in each case. |# type 'UNSPECIFIC)))))))) -(define (with-namestring-device-and-path components receiver) - (let ((string (car components))) - (let ((colon (string-find-next-char string #\:))) - (if (not colon) - (receiver false components) - (receiver (substring string 0 (1+ colon)) - (cons - (substring string (1+ colon) - (string-length string)) - (cdr components))))))) - -(define (simplify-directory directory) - (if (and (eq? (car directory) 'RELATIVE) (null? (cdr directory))) - false - directory)) - -(define (parse-directory-component component) - (if (string=? ".." component) - 'UP - (let ((len (string-length component))) - (cond ((substring-find-previous-char component 0 len #\.) - ;; Handle screwy directories with dots in their names. - (parse-name component unparse-name)) - ((> len 8) - (substring component 0 8)) - (else - component))))) - (define (expand-directory-prefixes string) (if (or (string-null? string) (not *expand-directory-prefixes?*)) (list string) (case (string-ref string 0) ((#\$) - (let* ((name (string-tail string 1)) - (value (get-environment-variable name))) + (let ((value (get-environment-variable (string-tail string 1)))) (if (not value) (list string) (string-components value sub-directory-delimiters)))) ((#\~) - (let ((user-name (substring string 1 (string-length string)))) - (string-components - (if (string-null? user-name) - (dos/current-home-directory) - (dos/user-home-directory user-name)) - sub-directory-delimiters))) + (string-components (let ((user-name (string-tail string 1))) + (if (string-null? user-name) + (dos/current-home-directory) + (dos/user-home-directory user-name))) + sub-directory-delimiters)) (else (list string))))) +(define (parse-device-and-path components) + (let ((string (car components))) + (let ((colon (string-find-next-char string #\:))) + (if (not colon) + (values #f components) + (values (string-head string (+ colon 1)) + (cons (string-tail string (+ colon 1)) + (cdr components))))))) + +(define (simplify-directory directory) + (if (and (eq? (car directory) 'RELATIVE) (null? (cdr directory))) + #f + directory)) + +(define (parse-directory-component component) + (if (string=? ".." component) + 'UP + component)) + (define (string-components string delimiters) (substring-components string 0 (string-length string) delimiters)) (define (substring-components string start end delimiters) (let loop ((start start)) - (let ((index (substring-find-next-char-in-set string start - end delimiters))) + (let ((index + (substring-find-next-char-in-set string start end delimiters))) (if index (cons (substring string start index) (loop (+ index 1))) (list (substring string start end)))))) -(define (parse-name string receiver) - (let ((receiver - (lambda (first second) - (receiver (if (and (string? first) - (> (string-length first) 8)) - (substring first 0 8) - first) - (if (and (string? second) - (> (string-length second) 3)) - (substring second 0 3) - second))))) - (let ((end (string-length string))) - (let ((dot (substring-find-previous-char string 0 end #\.))) - (if (or (not dot) - (= dot 0) - (= dot (- end 1)) - (char=? #\. (string-ref string (- dot 1)))) - (receiver (cond ((= end 0) false) - ((string=? "*" string) 'WILD) - (else string)) - false) - (receiver (extract string 0 dot) - (extract string (+ dot 1) end))))))) +(define (parse-name string) + (let ((dot (string-find-previous-char string #\.)) + (end (string-length string))) + (if (or (not dot) + (= dot 0) + (= dot (- end 1)) + (char=? #\. (string-ref string (- dot 1)))) + (values (cond ((= end 0) #f) + ((string=? "*" string) 'WILD) + (else string)) + #f) + (values (extract string 0 dot) + (extract string (+ dot 1) end))))) (define (extract string start end) (if (substring=? string start end "*" 0 1) 'WILD (substring string start end))) - -(define (dos/canonicalize pathname) - (define (valid? field length) - (or (not (string? field)) - (<= (string-length field) length))) - - (define (canonicalize-field field length) - (if (valid? field length) - field - (substring field 0 length))) - - ;; This should really canonicalize the directory as well. - (let ((name (%pathname-name pathname)) - (type (%pathname-type pathname))) - (if (and (valid? name 8) (valid? type 3)) - pathname - (%make-pathname (%pathname-host pathname) - (%pathname-device pathname) - (%pathname-directory pathname) - (canonicalize-field name 8) - (canonicalize-field type 3) - (%pathname-version pathname))))) ;;;; Pathname Unparser @@ -292,8 +251,7 @@ MIT in each case. |# (or (null? rest) (and (string? (car rest)) (check-directory-components (cdr rest)))))) - (else - false))) + (else #f))) (simplify-directory directory)) (else (error:wrong-type-argument directory "pathname directory" @@ -308,9 +266,8 @@ MIT in each case. |# (error:wrong-type-argument type "pathname type" 'MAKE-PATHNAME)) (if (memq version '(#F UNSPECIFIC WILD NEWEST)) 'UNSPECIFIC - (error:wrong-type-argument version "pathname version" - 'MAKE-PATHNAME)))) - + (error:wrong-type-argument version "pathname version" 'MAKE-PATHNAME)))) + (define (dos/pathname-as-directory pathname) (let ((name (%pathname-name pathname)) (type (%pathname-type pathname))) @@ -321,14 +278,11 @@ MIT in each case. |# (let ((directory (%pathname-directory pathname)) (component (parse-directory-component (unparse-name name type)))) - (cond ((not (pair? directory)) - (list 'RELATIVE component)) - ((equal? component ".") - directory) - (else - (append directory (list component))))) - false - false + (cond ((not (pair? directory)) (list 'RELATIVE component)) + ((equal? component ".") directory) + (else (append directory (list component))))) + #f + #f 'UNSPECIFIC) pathname))) @@ -343,9 +297,12 @@ MIT in each case. |# (%pathname-device pathname) directory "" - false + #f 'UNSPECIFIC) - (parse-name (unparse-directory-component (car (last-pair directory))) + (call-with-values + (lambda () + (parse-name + (unparse-directory-component (car (last-pair directory))))) (lambda (name type) (%make-pathname (%pathname-host pathname) (%pathname-device pathname) @@ -361,7 +318,7 @@ MIT in each case. |# (eq? 'WILD (%pathname-type pathname)))) (define (dos/pathname->truename pathname) - (if (eq? true (file-exists? pathname)) + (if (eq? #t (file-exists? pathname)) pathname (dos/pathname->truename (error:file-operation pathname "find" "file" "file does not exist" @@ -426,4 +383,4 @@ MIT in each case. |# (define (default/dos/end-of-file-marker/output pathname) pathname ; ignored - false) \ No newline at end of file + #f) \ No newline at end of file diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm index 9fd8062b5..efa7ac0fc 100644 --- a/v7/src/runtime/make.scm +++ b/v7/src/runtime/make.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: make.scm,v 14.51 1994/01/08 21:02:52 gjr Exp $ +$Id: make.scm,v 14.52 1994/11/28 05:44:14 cph Exp $ Copyright (c) 1988-1994 Massachusetts Institute of Technology @@ -435,7 +435,6 @@ MIT in each case. |# ;; Typically only one of them is loaded. (RUNTIME PATHNAME UNIX) (RUNTIME PATHNAME DOS) - (RUNTIME PATHNAME NT) (RUNTIME PATHNAME) (RUNTIME WORKING-DIRECTORY) (RUNTIME LOAD) diff --git a/v7/src/runtime/pathnm.scm b/v7/src/runtime/pathnm.scm index 4761a8324..88f8f62e6 100644 --- a/v7/src/runtime/pathnm.scm +++ b/v7/src/runtime/pathnm.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: pathnm.scm,v 14.27 1993/10/21 14:52:38 cph Exp $ +$Id: pathnm.scm,v 14.28 1994/11/28 05:44:35 cph Exp $ -Copyright (c) 1988-1993 Massachusetts Institute of Technology +Copyright (c) 1988-94 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -231,33 +231,30 @@ these rules: (define (pathname-new-directory pathname directory) (let ((pathname (->pathname pathname))) - ((host-operation/pathname-canonicalize (%pathname-host pathname)) - (%make-pathname (%pathname-host pathname) - (%pathname-device pathname) - directory - (%pathname-name pathname) - (%pathname-type pathname) - (%pathname-version pathname))))) + (%make-pathname (%pathname-host pathname) + (%pathname-device pathname) + directory + (%pathname-name pathname) + (%pathname-type pathname) + (%pathname-version pathname)))) (define (pathname-new-name pathname name) (let ((pathname (->pathname pathname))) - ((host-operation/pathname-canonicalize (%pathname-host pathname)) - (%make-pathname (%pathname-host pathname) - (%pathname-device pathname) - (%pathname-directory pathname) - name - (%pathname-type pathname) - (%pathname-version pathname))))) + (%make-pathname (%pathname-host pathname) + (%pathname-device pathname) + (%pathname-directory pathname) + name + (%pathname-type pathname) + (%pathname-version pathname)))) (define (pathname-new-type pathname type) (let ((pathname (->pathname pathname))) - ((host-operation/pathname-canonicalize (%pathname-host pathname)) - (%make-pathname (%pathname-host pathname) - (%pathname-device pathname) - (%pathname-directory pathname) - (%pathname-name pathname) - type - (%pathname-version pathname))))) + (%make-pathname (%pathname-host pathname) + (%pathname-device pathname) + (%pathname-directory pathname) + (%pathname-name pathname) + type + (%pathname-version pathname)))) (define (pathname-new-version pathname version) (let ((pathname (->pathname pathname))) @@ -460,7 +457,6 @@ these rules: (operation/init-file-pathname false read-only true) (operation/pathname-simplify false read-only true) (operation/end-of-line-string false read-only true) - (operation/pathname-canonicalize false read-only true) (operation/end-of-file-marker/input false read-only true) (operation/end-of-file-marker/output false read-only true)) @@ -519,9 +515,6 @@ these rules: (define (host-operation/end-of-line-string host) (host-type/operation/end-of-line-string (host/type host))) -(define (host-operation/pathname-canonicalize host) - (host-type/operation/pathname-canonicalize (host/type host))) - (define (host-operation/end-of-file-marker/input host) (host-type/operation/end-of-file-marker/input (host/type host))) @@ -589,65 +582,71 @@ these rules: (loop (cdr directories)))))))) (define known-host-types - '((UNIX . 0) - (DOS . 1) - (VMS . 2) - (NT . 3))) - -(define (make-unimplemented-host-type index) - (let* ((name (let loop ((types known-host-types)) - (cond ((null? types) - 'UNKNOWN) - ((= index (cdar types)) - (caar types)) - (else - (loop (cdr types)))))) - (fail (lambda all - (error "(runtime pathname): Unimplemented host type" - name all)))) - (make-host-type index name - fail fail fail fail fail - fail fail fail fail fail - fail fail fail fail))) + '((0 UNIX) + (1 DOS NT OS/2) + (2 VMS))) + +(define (host-name->index name) + (let loop ((entries known-host-types)) + (if (null? entries) + (error "Unknown host type:" name)) + (if (memq name (cdar entries)) + (caar entries) + (loop (cdr entries))))) + +(define (host-index->name index) + (let ((entry (assv index known-host-types))) + (and entry + (cadr entry)))) (define available-host-types '()) +(define (host-name->type name) + (host-index->type (host-name->index name))) + +(define (host-index->type index) + (let ((entry (assv index available-host-types))) + (if (not entry) + (error "Missing host type for index:" index)) + (cdr entry))) + (define (add-pathname-host-type! name constructor) - (let ((host-type (constructor - (let ((place (assq name known-host-types))) - (if (not place) - (error "add-host-type!: Unknown host type" - name) - (cdr place))))) - (place (assq name available-host-types))) - (if place - (set-cdr! place host-type) - (set! available-host-types - (cons (cons name host-type) - available-host-types))) - unspecific)) + (let ((index (host-name->index name))) + (let ((host-type (constructor index)) + (place (assv index available-host-types))) + (if place + (set-cdr! place host-type) + (begin + (set! available-host-types + (cons (cons index host-type) + available-host-types)) + unspecific))))) + +(define (make-unimplemented-host-type index) + (let ((name (or (host-index->name index) 'UNKNOWN))) + (let ((fail + (lambda arguments + (error "Unimplemented host type:" name arguments)))) + (make-host-type index name + fail fail fail fail fail + fail fail fail fail fail + fail fail fail)))) (define (reset-package!) - (let* ((host-type - (cdr - (let ((os-type (intern (microcode-identification-item - 'OS-NAME-STRING)))) - (or (assq os-type available-host-types) - (error "(runtime pathname) reset-package!: Unknown OS type" - os-type))))) - (len (length known-host-types)) - (vec (make-vector len false))) - (do ((types available-host-types (cdr types))) - ((null? types)) - (let ((type (cdar types))) - (vector-set! vec (host-type/index type) type))) - (do ((i 0 (1+ i))) - ((>= i len)) - (if (not (vector-ref vec i)) - (vector-set! vec i (make-unimplemented-host-type i)))) - (set! host-types vec) - (set! local-host (make-host host-type false))) + (let ((host-type + (host-name->type + (intern (microcode-identification-item 'OS-NAME-STRING)))) + (n-types (+ (apply max (map car known-host-types)) 1))) + (let ((types (make-vector n-types #f))) + (for-each (lambda (type) (vector-set! types (car type) (cdr type))) + available-host-types) + (do ((index 0 (+ index 1))) + ((= index n-types)) + (if (not (vector-ref types index)) + (vector-set! types index (make-unimplemented-host-type index)))) + (set! host-types types) + (set! local-host (make-host host-type #f)))) (set! *default-pathname-defaults* (make-pathname local-host false false false false false)) (set! library-directory-path diff --git a/v7/src/runtime/unxpth.scm b/v7/src/runtime/unxpth.scm index 1047ecd6b..a3468e758 100644 --- a/v7/src/runtime/unxpth.scm +++ b/v7/src/runtime/unxpth.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: unxpth.scm,v 14.15 1993/01/13 09:53:15 cph Exp $ +$Id: unxpth.scm,v 14.16 1994/11/28 05:45:12 cph Exp $ -Copyright (c) 1988-1993 Massachusetts Institute of Technology +Copyright (c) 1988-94 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -51,17 +51,11 @@ MIT in each case. |# unix/init-file-pathname unix/pathname-simplify unix/end-of-line-string - unix/canonicalize unix/end-of-file-marker/input unix/end-of-file-marker/output)) (define (initialize-package!) (add-pathname-host-type! 'UNIX make-unix-host-type)) - -(define (unix/canonicalize pathname) - ;; No name truncation -- this is not really true: - ;; 14 chars for SYSV, 255 for BSD. - pathname) ;;;; Pathname Parser diff --git a/v8/src/runtime/make.scm b/v8/src/runtime/make.scm index 9fd8062b5..efa7ac0fc 100644 --- a/v8/src/runtime/make.scm +++ b/v8/src/runtime/make.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: make.scm,v 14.51 1994/01/08 21:02:52 gjr Exp $ +$Id: make.scm,v 14.52 1994/11/28 05:44:14 cph Exp $ Copyright (c) 1988-1994 Massachusetts Institute of Technology @@ -435,7 +435,6 @@ MIT in each case. |# ;; Typically only one of them is loaded. (RUNTIME PATHNAME UNIX) (RUNTIME PATHNAME DOS) - (RUNTIME PATHNAME NT) (RUNTIME PATHNAME) (RUNTIME WORKING-DIRECTORY) (RUNTIME LOAD) -- 2.25.1