#| -*-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
;;; package: (runtime pathname dos)
(declare (usual-integrations))
-
+\f
(define hook/dos/end-of-line-string)
(define hook/dos/end-of-file-marker/input)
(define hook/dos/end-of-file-marker/output)
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))
\f
;;;; 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
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))
-\f
-(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))
+\f
(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)))))
\f
;;;; Pathname Unparser
(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"
(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))))
+\f
(define (dos/pathname-as-directory pathname)
(let ((name (%pathname-name pathname))
(type (%pathname-type 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)))))
- false
- false
+ (cond ((not (pair? directory)) (list 'RELATIVE component))
+ ((equal? component ".") directory)
+ (else (append directory (list component)))))
+ #f
+ #f
'UNSPECIFIC)
pathname)))
(%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)
(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"
(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
#| -*-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
(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)))
(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))
(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)))
(loop (cdr directories))))))))
\f
(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
projects / mit-scheme.git / commitdiff