From d37a1e9daca804ccef8363a70ddf5cf77484d052 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 18 Jul 1987 03:02:54 +0000
Subject: [PATCH] Reimplement pathname parsing stuff for new VMS parser.
---
v7/src/runtime/pathnm.scm | 109 +++++++++-------
v7/src/runtime/unxpth.scm | 256 +++++++++++++++++++++-----------------
2 files changed, 207 insertions(+), 158 deletions(-)
diff --git a/v7/src/runtime/pathnm.scm b/v7/src/runtime/pathnm.scm
index ec558658f..51e76777b 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 13.42 1987/03/12 02:16:14 jinx Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pathnm.scm,v 13.43 1987/07/18 03:02:54 cph Rel $
;;;
;;; Copyright (c) 1987 Massachusetts Institute of Technology
;;;
@@ -49,22 +49,24 @@
;;; components may have special meaning to certain directory
;;; operations.
-;;; * 'UNSPECIFIC, meaning that the component was supplied, but null.
-;;; This means about the same thing as "". (maybe it should be
-;;; eliminated in favor of that?)
-
;;; * #F, meaning that the component was not supplied. This has
;;; special meaning to `merge-pathnames', in which such components are
;;; substituted.
+;;; * 'UNSPECIFIC, which means the same thing as #F except that it is
+;;; never defaulted by `merge-pathnames'. Normally there is no way to
+;;; specify such a component value with `string->pathname'.
+
;;; A pathname consists of 5 components, not all necessarily
;;; meaningful, as follows:
;;; * The DEVICE is usually a physical device, as in the Twenex `ps:'.
;;; * The DIRECTORY is a list of components. If the first component
-;;; is the null string, then the directory path is absolute.
-;;; Otherwise it is relative.
+;;; is 'ROOT, then the directory path is absolute. Otherwise it is
+;;; relative. Two special components allowed only in directories are
+;;; the symbols 'SELF and 'UP which are equivalent to Unix' "." and
+;;; ".." respectively.
;;; * The NAME is the proper name part of the filename.
@@ -74,25 +76,24 @@
;;; * The VERSION is special. Unlike an ordinary component, it is
;;; never a string, but may be either a positive integer, 'NEWEST,
-;;; 'WILD, 'UNSPECIFIC, or #F. Many system procedures will default
+;;; 'UNSPECIFIC, 'WILD, or #F. Many system procedures will default
;;; the version to 'NEWEST, which means to search the directory for
;;; the highest version numbered file.
;;; This file requires the following procedures and variables which
;;; define the conventions for the particular file system in use:
-;;;
;;; (symbol->pathname symbol)
-;;; (string->pathname string)
+;;; (pathname-parse string (lambda (device directory name type version)))
;;; (pathname-unparse device directory name type version)
;;; (pathname-unparse-name name type version)
-;;; (simplify-directory directory)
+;;; (pathname-as-directory pathname)
;;; working-directory-package
;;; (access reset! working-directory-package)
;;; init-file-pathname
;;; (home-directory-pathname)
;;; (working-directory-pathname)
;;; (set-working-directory-pathname! name)
-;;;
+
;;; See the files unkpth.scm, vmspth.scm, or unxpth.scm for examples.
;;;; Basic Pathnames
@@ -102,7 +103,7 @@
(eq? (environment-procedure object) make-pathname)))
(define (make-pathname device directory name type version)
- (define string #F)
+ (define string false)
(define (:print-self)
(unparse-with-brackets
@@ -145,9 +146,8 @@
(define (pathname-absolute? pathname)
(let ((directory (pathname-directory pathname)))
- (and (not (null? directory))
- (string-null? (car directory)))))
-
+ (and (pair? directory)
+ (eq? (car directory) 'ROOT))))
(define (pathname-new-device pathname device)
(pathname-components pathname
(lambda (old-device directory name type version)
@@ -176,22 +176,22 @@
(define (pathname-directory-path pathname)
(pathname-components pathname
(lambda (device directory name type version)
- (make-pathname device directory #F #F #F))))
+ (make-pathname device directory false false false))))
(define (pathname-directory-string pathname)
(pathname-components pathname
(lambda (device directory name type version)
- (pathname-unparse device directory #F #F #F))))
+ (pathname-unparse device directory false false false))))
(define (pathname-name-path pathname)
(pathname-components pathname
(lambda (device directory name type version)
- (make-pathname #F #F name type version))))
+ (make-pathname false false name type version))))
(define (pathname-name-string pathname)
(pathname-components pathname
(lambda (device directory name type version)
- (pathname-unparse #F #F name type version))))
+ (pathname-unparse false false name type version))))
;;;; Parse and unparse.
@@ -203,6 +203,9 @@
((symbol? object) (symbol->pathname object))
(else (error "Unable to coerce into pathname" object))))
+(define (string->pathname string)
+ (parse-pathname string make-pathname))
+
(define (pathname->string pathname)
(or (access string pathname)
(let ((string (pathname-components pathname pathname-unparse)))
@@ -221,27 +224,49 @@
;;;; Merging pathnames
(define (merge-pathnames pathname default)
- (make-pathname (or (pathname-device pathname) (pathname-device default))
- (simplify-directory
- (let ((directory (pathname-directory pathname)))
- (cond ((null? directory) (pathname-directory default))
- ((string-null? (car directory)) directory)
- (else
- (append (pathname-directory default) directory)))))
- (or (pathname-name pathname) (pathname-name default))
- (or (pathname-type pathname) (pathname-type default))
- (or (pathname-version pathname) (pathname-version default))))
-
-(define (pathname-as-directory pathname)
- (let ((file (pathname-unparse-name (pathname-name pathname)
- (pathname-type pathname)
- (pathname-version pathname))))
- (if (string-null? file)
- pathname
- (make-pathname (pathname-device pathname)
- (append (pathname-directory pathname)
- (list file))
- #F #F #F))))
+ (make-pathname
+ (or (pathname-device pathname) (pathname-device default))
+ (simplify-directory
+ (let ((directory (pathname-directory pathname))
+ (default (pathname-directory default)))
+ (cond ((null? directory) default)
+ ((or (eq? directory 'UNSPECIFIC)
+ (null? default)
+ (eq? default 'UNSPECIFIC))
+ directory)
+ ((pair? directory)
+ (cond ((eq? (car directory) 'ROOT) directory)
+ ((pair? default) (append default directory))
+ (else (error "Illegal pathname directory" default))))
+ (else (error "Illegal pathname directory" directory)))))
+ (or (pathname-name pathname) (pathname-name default))
+ (or (pathname-type pathname) (pathname-type default))
+ (or (pathname-version pathname) (pathname-version default))))
+
+(define simplify-directory)
+(let ()
+
+(set! simplify-directory
+ (named-lambda (simplify-directory directory)
+ (cond ((not (pair? directory)) directory)
+ ((eq? (car directory) 'ROOT)
+ (cons 'ROOT (simplify-tail (simplify-root-tail (cdr directory)))))
+ (else (simplify-tail directory)))))
+
+(define (simplify-root-tail directory)
+ (if (and (pair? directory)
+ (memq (car directory) '(SELF UP)))
+ (simplify-root-tail (cdr directory))
+ directory))
+
+(define (simplify-tail directory)
+ (cond ((not (pair? directory)) directory)
+ ((eq? (car directory) 'SELF) (simplify-tail (cdr directory)))
+ ((not (pair? (cdr directory))) directory)
+ ((eq? (cadr directory) 'UP) (simplify-tail (cddr directory)))
+ (else (cons (car directory) (simplify-tail (cdr directory))))))
+
+)
(define (pathname->absolute-pathname pathname)
- (merge-pathnames pathname (working-directory-pathname)))
+ (merge-pathnames pathname (working-directory-pathname)))
\ No newline at end of file
diff --git a/v7/src/runtime/unxpth.scm b/v7/src/runtime/unxpth.scm
index baaf66601..bed17eff3 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 1.2 1987/03/17 18:54:38 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unxpth.scm,v 1.3 1987/07/18 03:02:08 cph Exp $
;;;
;;; Copyright (c) 1987 Massachusetts Institute of Technology
;;;
@@ -56,64 +56,88 @@
(define (symbol->pathname symbol)
(string->pathname (string-downcase (symbol->string symbol))))
-(define string->pathname)
+(define parse-pathname)
+(define pathname-as-directory)
(define home-directory-pathname)
(let ()
-(set! string->pathname
- (named-lambda (string->pathname string)
- (parse-pathname string make-pathname)))
-
-(define (parse-pathname string receiver)
- (let ((components (divide-into-components (string-trim string))))
- (if (null? components)
- (receiver #F #F #F #F #F)
- (let ((components
- (append (expand-directory-prefixes (car components))
- (cdr components))))
- (parse-name (car (last-pair components))
- (lambda (name type version)
- (receiver #F
- (map (lambda (component)
- (if (string=? "*" component)
- 'WILD
- component))
- (except-last-pair components))
- name type version)))))))
-
-(define (divide-into-components string)
- (let ((end (string-length string)))
- (define (loop start)
- (let ((index (substring-find-next-char string start end #\/)))
- (if index
- (cons (substring string start index)
- (loop (1+ index)))
- (list (substring string start end)))))
- (loop 0)))
+(set! parse-pathname
+ (named-lambda (parse-pathname string receiver)
+ (let ((end (string-length string)))
+ (parse-device string 0 end
+ (lambda (device start)
+ (let ((components
+ (let ((components
+ (substring-components string start end #\/)))
+ (append (expand-directory-prefixes (car components))
+ (cdr components)))))
+ (parse-name (car (last-pair components))
+ (lambda (name type version)
+ (receiver device
+ (parse-directory-components
+ (except-last-pair components))
+ name type version)))))))))
+
+(define (parse-directory-components components)
+ (if (null? components)
+ '()
+ (cons (if (string-null? (car components))
+ 'ROOT
+ (parse-directory-component (car components)))
+ (map parse-directory-component (cdr components)))))
+
+(set! pathname-as-directory
+ (named-lambda (pathname-as-directory pathname)
+ (make-pathname
+ (pathname-device pathname)
+ (let ((directory (pathname-directory pathname)))
+ (let ((file (pathname-unparse-name (pathname-name pathname)
+ (pathname-type pathname)
+ (pathname-version pathname))))
+ (if (string-null? file)
+ directory
+ (let ((file-components (list (parse-directory-component file))))
+ (cond ((or (null? directory) (eq? directory 'UNSPECIFIC))
+ file-components)
+ ((pair? directory)
+ (append directory file-components))
+ (else (error "Illegal pathname directory" directory)))))))
+ false false false)))
+(define (parse-device string start end receiver)
+ (let ((index (substring-find-next-char string start end #\:)))
+ (if index
+ (receiver (substring string start index) (1+ index))
+ (receiver false start))))
+
+(define (parse-directory-component component)
+ (cond ((string=? "*" component) 'WILD)
+ ((string=? "." component) 'SELF)
+ ((string=? ".." component) 'UP)
+ (else component)))
+
(define (expand-directory-prefixes string)
(if (string-null? string)
(list string)
(case (string-ref string 0)
((#\$)
- (divide-into-components
+ (string-components
(get-environment-variable
- (substring string 1 (string-length string)))))
+ (substring string 1 (string-length string)))
+ #\/))
((#\~)
(let ((user-name (substring string 1 (string-length string))))
- (divide-into-components
+ (string-components
(if (string-null? user-name)
(get-environment-variable "HOME")
- (get-user-home-directory user-name)))))
+ (get-user-home-directory user-name))
+ #\/)))
(else (list string)))))
(set! home-directory-pathname
(lambda ()
- (make-pathname #F
- (divide-into-components (get-environment-variable "HOME"))
- #F
- #F
- #F)))
+ (pathname-as-directory
+ (string->pathname (get-environment-variable "HOME")))))
(define get-environment-variable
(let ((primitive (make-primitive-procedure 'GET-ENVIRONMENT-VARIABLE)))
@@ -126,15 +150,6 @@
(lambda (user-name)
(or (primitive user-name)
(error "User has no home directory" user-name)))))
-
-(define (digits->number digits weight accumulator)
- (if (null? digits)
- accumulator
- (let ((value (char->digit (car digits) 10)))
- (and value
- (digits->number (cdr digits)
- (* weight 10)
- (+ (* weight value) accumulator))))))
(define (parse-name string receiver)
(let ((start 0)
@@ -146,7 +161,7 @@
(substring-find-previous-char string start end #\.))
(define (parse-version start)
- (cond ((= start end) 'UNSPECIFIC)
+ (cond ((= start end) "")
((substring=? string start end "*" 0 1) 'WILD)
((substring-find-next-char string start end #\*)
(substring string start end))
@@ -159,13 +174,13 @@
(substring string start end))))))
(if (= start end)
- (receiver #F #F #F)
+ (receiver false false false)
(let ((index (find-next-dot start)))
(if index
(let ((start* (1+ index))
(name (wildify string start index)))
(if (= start* end)
- (receiver name 'UNSPECIFIC 'UNSPECIFIC)
+ (receiver name "" "")
(or (let ((index (find-next-dot start*)))
(and index
(let ((version (parse-version (1+ index))))
@@ -176,14 +191,35 @@
(let ((index (find-previous-dot start)))
(receiver (wildify string start index)
(wildify string (1+ index) end)
- #F)))))
- (receiver (wildify string start end) #F #F))))))
-
+ false)))))
+ (receiver (wildify string start end) false false))))))
+
(define (wildify string start end)
(if (substring=? string start end "*" 0 1)
'WILD
(substring string start end)))
+(define (string-components string delimiter)
+ (substring-components string start end delimiter))
+
+(define (substring-components string start end delimiter)
+ (define (loop start)
+ (let ((index (substring-find-next-char string start end delimiter)))
+ (if index
+ (cons (substring string start index)
+ (loop (1+ index)))
+ (list (substring string start end)))))
+ (loop start))
+
+(define (digits->number digits weight accumulator)
+ (if (null? digits)
+ accumulator
+ (let ((value (char->digit (car digits) 10)))
+ (and value
+ (digits->number (cdr digits)
+ (* weight 10)
+ (+ (* weight value) accumulator))))))
+
;;; end LET.
)
@@ -195,59 +231,60 @@
(set! pathname-unparse
(named-lambda (pathname-unparse device directory name type version)
- (unparse-device
- device
- (unparse-directory directory
- (pathname-unparse-name name type version)))))
-
-(define (unparse-device device rest)
- (let ((device-string (unparse-component device)))
- (if device-string
- (string-append device-string ":" rest)
- rest)))
-
-(define (unparse-directory directory rest)
- (cond ((null? directory) rest)
+ (string-append (let ((device-string (unparse-component device)))
+ (if device-string
+ (string-append device-string ":")
+ ""))
+ (unparse-directory directory)
+ (pathname-unparse-name name type version))))
+
+(define (unparse-directory directory)
+ (define (loop directory)
+ (if (null? directory)
+ ""
+ (string-append (unparse-directory-component (car directory))
+ "/"
+ (loop (cdr directory)))))
+ (cond ((null? directory) "")
((pair? directory)
- (let loop ((directory directory))
- (let ((directory-string (unparse-component (car directory)))
- (rest (if (null? (cdr directory))
- rest
- (loop (cdr directory)))))
- (if directory-string
- (string-append directory-string "/" rest)
- rest))))
- (else
- (error "Unrecognizable directory" directory))))
+ (string-append (if (eq? (car directory) 'ROOT)
+ ""
+ (unparse-directory-component (car directory)))
+ "/"
+ (loop (cdr directory))))
+ (else (error "Illegal pathname directory" directory))))
+
+(define (unparse-directory-component component)
+ (cond ((eq? component 'WILD) "*")
+ ((eq? component 'SELF) ".")
+ ((eq? component 'UP) "..")
+ ((string? component) component)
+ (else (error "Illegal pathname directory component" component))))
(set! pathname-unparse-name
(named-lambda (pathname-unparse-name name type version)
- (let ((name-string (unparse-component name))
- (type-string (unparse-component type))
- (version-string (unparse-version version)))
- (cond ((not name-string) "")
- ((not type-string) name-string)
- ((eq? type-string 'UNSPECIFIC) (string-append name-string "."))
- ((not version-string) (string-append name-string "." type-string))
- ((eq? version-string 'UNSPECIFIC)
- (string-append name-string "." type-string "."))
- (else
- (string-append name-string "." type-string "."
- version-string))))))
-
-(define (unparse-version version)
- (if (eq? version 'NEWEST)
- "0"
- (unparse-component version)))
+ (let ((name (unparse-component name))
+ (type (unparse-component type))
+ (version (unparse-version version)))
+ (cond ((not name) "")
+ ((not type) name)
+ ((not version) (string-append name "." type))
+ (else (string-append name "." type "." version))))))
(define (unparse-component component)
- (cond ((not component) #F)
- ((eq? component 'UNSPECIFIC) component)
+ (cond ((or (not component) (string? component)) component)
+ ((eq? component 'UNSPECIFIC) false)
((eq? component 'WILD) "*")
- ((string? component) component)
- ((and (integer? component) (> component 0))
- (list->string (number->digits component '())))
- (else (error "Unknown component" component))))
+ (else (error "Illegal pathname component" component))))
+
+(define (unparse-version version)
+ (cond ((or (not version) (string? version)) version)
+ ((eq? version 'UNSPECIFIC) false)
+ ((eq? version 'WILD) "*")
+ ((eq? version 'NEWEST) "0")
+ ((and (integer? version) (> version 0))
+ (list->string (number->digits version '())))
+ (else (error "Illegal pathname version" version))))
(define (number->digits number accumulator)
(if (zero? number)
@@ -260,19 +297,6 @@
;;; end LET.
)
-;;;; Utility for merge pathnames
-
-(define (simplify-directory directory)
- (cond ((null? directory) directory)
- ((string=? (car directory) ".")
- (simplify-directory (cdr directory)))
- ((null? (cdr directory)) directory)
- ((string=? (cadr directory) "..")
- (simplify-directory (cddr directory)))
- (else
- (cons (car directory)
- (simplify-directory (cdr directory))))))
-
;;;; Working Directory
(define working-directory-pathname)
@@ -311,4 +335,4 @@
))
(define init-file-pathname
- (make-pathname #F #F ".scheme" "init" #F))
\ No newline at end of file
+ (string->pathname ".scheme.init"))
\ No newline at end of file
--
2.25.1