From: Chris Hanson Date: Mon, 19 Dec 1994 21:10:45 +0000 (+0000) Subject: Fix code to do directory simplification better. Eliminate some more X-Git-Tag: 20090517-FFI~6854 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=de9f3c36e09cf3a067fe84680a88fec0961164a3;p=mit-scheme.git Fix code to do directory simplification better. Eliminate some more unnecessary restrictions. --- diff --git a/v7/src/runtime/dospth.scm b/v7/src/runtime/dospth.scm index 89b1398fa..6876e6c99 100644 --- a/v7/src/runtime/dospth.scm +++ b/v7/src/runtime/dospth.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: dospth.scm,v 1.19 1994/11/28 05:43:49 cph Exp $ +$Id: dospth.scm,v 1.20 1994/12/19 21:10:45 cph Exp $ Copyright (c) 1992-94 Massachusetts Institute of Technology @@ -80,65 +80,68 @@ MIT in each case. |# ;;;; Pathname Parser (define (dos/parse-namestring string host) - (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)))) - (call-with-values - (lambda () - (parse-name (car (last-pair components)))) - (lambda (name type) - (%make-pathname host - device - (let ((components (except-last-pair components))) - (and (not (null? components)) - (simplify-directory - (if (string=? "" (car components)) - (cons 'ABSOLUTE - (map parse-directory-component - (cdr components))) - (cons 'RELATIVE - (map parse-directory-component - components)))))) - name - type - 'UNSPECIFIC)))))))) - -(define (expand-directory-prefixes string) - (if (or (string-null? string) - (not *expand-directory-prefixes?*)) - (list string) - (case (string-ref string 0) - ((#\$) - (let ((value (get-environment-variable (string-tail string 1)))) - (if (not value) - (list string) - (string-components value 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))))) + (call-with-values + (lambda () + (parse-device-and-path + (expand-directory-prefixes + (string-components (string-downcase string) + sub-directory-delimiters)))) + (lambda (device components) + (call-with-values (lambda () (parse-name (car (last-pair components)))) + (lambda (name type) + (%make-pathname host + device + (let ((components (except-last-pair components))) + (and (not (null? components)) + (simplify-directory + (if (string=? "" (car components)) + (cons 'ABSOLUTE + (map parse-directory-component + (cdr components))) + (cons 'RELATIVE + (map parse-directory-component + components)))))) + name + type + 'UNSPECIFIC)))))) + +(define (expand-directory-prefixes components) + (let ((string (car components))) + (if (or (string-null? string) + (not *expand-directory-prefixes?*)) + components + (case (string-ref string 0) + ((#\$) + (let ((value (get-environment-variable (string-tail string 1)))) + (if (not value) + components + (append (string-components value sub-directory-delimiters) + (cdr components))))) + ((#\~) + (append + (string-components (->namestring + (directory-pathname-as-file + (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) + (cdr components))) + (else components))))) (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)) + (values (string-head string colon) (cons (string-tail string (+ colon 1)) (cdr components))))))) (define (simplify-directory directory) - (if (and (eq? (car directory) 'RELATIVE) (null? (cdr directory))) - #f - directory)) + (cond ((and (eq? (car directory) 'RELATIVE) (null? (cdr directory))) #f) + ((equal? '(ABSOLUTE UP) directory) '(ABSOLUTE)) + (else directory))) (define (parse-directory-component component) (if (string=? ".." component) @@ -186,7 +189,7 @@ MIT in each case. |# (define (unparse-device device) (if (or (not device) (eq? device 'UNSPECIFIC)) "" - device)) + (string-append device ":"))) (define (unparse-directory directory) (cond ((or (not directory) (eq? directory 'UNSPECIFIC)) @@ -225,13 +228,6 @@ MIT in each case. |# ;;;; Pathname Constructors (define (dos/make-pathname host device directory name type version) - (define (check-directory-components components) - (for-all? components - (lambda (element) - (if (string? element) - (not (string-null? element)) - (eq? element 'UP))))) - (%make-pathname host (cond ((string? device) device) @@ -242,16 +238,12 @@ MIT in each case. |# directory) ((and (list? directory) (not (null? directory)) - (case (car directory) - ((RELATIVE) - (check-directory-components (cdr directory))) - ((ABSOLUTE) - ;; This should handle share network drives (\\machine\...) - (let ((rest (cdr directory))) - (or (null? rest) - (and (string? (car rest)) - (check-directory-components (cdr rest)))))) - (else #f))) + (memq (car directory) '(RELATIVE ABSOLUTE)) + (for-all? (cdr directory) + (lambda (element) + (if (string? element) + (not (string-null? element)) + (eq? element 'UP))))) (simplify-directory directory)) (else (error:wrong-type-argument directory "pathname directory" @@ -275,12 +267,13 @@ MIT in each case. |# (%make-pathname (%pathname-host pathname) (%pathname-device pathname) - (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))))) + (simplify-directory + (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)))))) #f #f 'UNSPECIFIC) @@ -335,31 +328,31 @@ MIT in each case. |# pathname))) (define (dos/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)) + (let ((directory (pathname-directory pathname))) + (or (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*))) + (if (eq? 'OS/2 microcode-id/operating-system) + pathname* + (and ((ucode-primitive file-eq? 2) + (->namestring pathname) + (->namestring pathname*)) + pathname*)))))) + pathname))) (define (dos/end-of-line-string pathname) (hook/dos/end-of-line-string pathname))