From: Guillermo J. Rozas Date: Sat, 11 Apr 1992 23:48:57 +0000 (+0000) Subject: Initial revision X-Git-Tag: 20090517-FFI~9498 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=7320d5f5ac0a0b7c6412fe41bbcee691ec2d29db;p=mit-scheme.git Initial revision --- diff --git a/v7/src/runtime/dosdir.scm b/v7/src/runtime/dosdir.scm new file mode 100644 index 000000000..9fe33bf94 --- /dev/null +++ b/v7/src/runtime/dosdir.scm @@ -0,0 +1,98 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/dosdir.scm,v 1.1 1992/04/11 23:48:50 jinx Exp $ + +Copyright (c) 1992 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Directory Operations -- DOS (copy of unxdir version 14.9) +;;; package: (runtime directory) + +(declare (usual-integrations)) + +(define (directory-read pattern #!optional sort?) + (if (if (default-object? sort?) true sort?) + (sort (directory-read-nosort pattern) pathnamepathname + (generate-directory-pathnames directory-path)))) + (if (and (eq? (pathname-name pattern) 'WILD) + (eq? (pathname-type pattern) 'WILD)) + pathnames + (list-transform-positive pathnames + (lambda (instance) + (and (match-component (pathname-name pattern) + (pathname-name instance)) + (match-component (pathname-type pattern) + (pathname-type instance))))))))))) + +(define (generate-directory-pathnames pathname) + (let ((channel (directory-channel-open (->namestring pathname)))) + (let loop ((result '())) + (let ((name (directory-channel-read channel))) + (if name + (loop (cons name result)) + (begin + (directory-channel-close channel) + result)))))) + +(define (match-component pattern instance) + (or (eq? pattern 'WILD) + (equal? pattern instance))) + +(define (pathnamenamestring (merge-pathnames filename)))) + +(define (file-symbolic-link? filename) + ((ucode-primitive file-symlink?) (->namestring (merge-pathnames filename)))) + +(define (file-modes filename) + ((ucode-primitive file-modes) (->namestring (merge-pathnames filename)))) + +(define-integrable (set-file-modes! filename modes) + ((ucode-primitive set-file-modes!) (->namestring (merge-pathnames filename)) + modes)) + +(define (file-access filename amode) + ((ucode-primitive file-access) (->namestring (merge-pathnames filename)) + amode)) + +;; upwards compatability +(define dos/file-access file-access) + +(define (file-readable? filename) + (file-access filename 4)) + +(define (file-writable? filename) + (let ((pathname (merge-pathnames filename))) + (let ((filename (->namestring pathname))) + (or ((ucode-primitive file-access) filename 2) + (and (not ((ucode-primitive file-exists?) filename)) + ((ucode-primitive file-access) (directory-namestring pathname) + 2)))))) + +(define (file-attributes-direct filename) + ((ucode-primitive file-attributes) + (->namestring (merge-pathnames filename)))) + +(define (file-attributes-indirect filename) + ((ucode-primitive file-attributes-indirect) + (->namestring (merge-pathnames filename)))) + +(define file-attributes + file-attributes-direct) + +(define-structure (file-attributes + (type vector) + (constructor false) + (conc-name file-attributes/)) + (type false read-only true) + (n-links false read-only true) + (uid false read-only true) + (gid false read-only true) + (access-time false read-only true) + (modification-time false read-only true) + (change-time false read-only true) + (length false read-only true) + (mode-string false read-only true) + (inode-number false read-only true)) + +(define (file-modification-time-direct filename) + ((ucode-primitive file-mod-time 1) + (->namestring (merge-pathnames filename)))) + +(define (file-modification-time-indirect filename) + ((ucode-primitive file-mod-time-indirect 1) + (->namestring (merge-pathnames filename)))) + +(define file-modification-time + file-modification-time-indirect) + +(define-integrable get-environment-variable + (ucode-primitive get-environment-variable)) + +(define (dos/user-home-directory user-name) + (let ((directory ((ucode-primitive get-user-home-directory) user-name))) + (if (not directory) + (error "Can't find user's home directory:" user-name)) + directory)) + +(define (dos/current-home-directory) + (or (get-environment-variable "HOME") + (dos/user-home-directory (dos/current-user-name)))) + +(define-integrable dos/current-user-name + (ucode-primitive current-user-name)) + +(define-integrable dos/current-uid + (ucode-primitive current-uid)) + +(define-integrable dos/current-gid + (ucode-primitive current-gid)) + +(define-integrable dos/current-file-time + (ucode-primitive current-file-time)) + +(define-integrable dos/file-time->string + (ucode-primitive file-time->string)) + +(define (dos/uid->string uid) + (or ((ucode-primitive uid->string) uid) + (number->string uid 10))) + +(define (dos/gid->string gid) + (or ((ucode-primitive gid->string) gid) + (number->string gid 10))) + +(define-integrable dos/system + (ucode-primitive system)) + +(define (file-touch filename) + ((ucode-primitive file-touch) (->namestring (merge-pathnames filename)))) + +(define (make-directory name) + ((ucode-primitive directory-make) + (->namestring (pathname-as-directory (merge-pathnames name))))) \ No newline at end of file diff --git a/v7/src/runtime/dospth.scm b/v7/src/runtime/dospth.scm new file mode 100644 index 000000000..3ad5a4505 --- /dev/null +++ b/v7/src/runtime/dospth.scm @@ -0,0 +1,340 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/dospth.scm,v 1.1 1992/04/11 23:48:44 jinx Exp $ + +Copyright (c) 1992 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; Dos Pathnames (based on unxpth version 14.9) +;;; package: (runtime pathname dos) + +(declare (usual-integrations)) + +(define sub-directory-delimiters + ;; Allow forward slashes as well as backward slashes so that + ;; - improperly-written scripts (e.g. compiler/comp.sf) will work + ;; - laziness when typing file names since the backward slash + ;; must be quoted by another. + (char-set #\\ #\/)) + +(define sub-directory-delimiter-string + "\\") + +(define init-file-name "scheme.ini") + +(define (make-dos-host-type index) + (make-host-type index + 'DOS + dos/parse-namestring + dos/pathname->namestring + dos/make-pathname + dos/pathname-wild? + dos/pathname-as-directory + dos/directory-pathname-as-file + dos/pathname->truename + dos/user-homedir-pathname + dos/init-file-pathname + dos/pathname-simplify)) + +(define (initialize-package!) + (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. + (with-namestring-device-and-path (string-downcase string) + (lambda (device string) + (let ((components + (let ((components (string-components string + sub-directory-delimiters))) + (append (expand-directory-prefixes (car components)) + (cdr components))))) + (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 (with-namestring-device-and-path string receiver) + (let ((colon (string-find-next-char string #\:))) + (cond ((not colon) + (receiver 'UNSPECIFIC string)) + ((not (= colon 1)) + (error "dos/parse-namestring: Invalid drive name" string)) + (else + (receiver (substring string 0 (1+ colon)) + (substring string (1+ colon) + (string-length string))))))) + +(define (simplify-directory directory) + (if (and (eq? (car directory) 'RELATIVE) (null? (cdr directory))) + false + directory)) + +(define (parse-directory-component component) + (if (string=? ".." component) + 'UP + component)) + +(define (expand-directory-prefixes string) + (if (string-null? string) + (list string) + (case (string-ref string 0) + ((#\$) + (let ((name (string-tail string 1))) + (let ((value (get-environment-variable name))) + (if (not value) + (error "Unbound environment variable:" name)) + (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))) + (else (list string))))) + +(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))) + (if index + (cons (substring string start index) (loop (+ index 1))) + (list (substring string start end)))))) + +(define (parse-name string receiver) + (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 (extract string start end) + (if (substring=? string start end "*" 0 1) + 'WILD + (substring string start end))) + +;;;; Pathname Unparser + +(define (dos/pathname->namestring pathname) + (string-append (unparse-device (%pathname-device pathname)) + (unparse-directory (%pathname-directory pathname)) + (unparse-name (%pathname-name pathname) + (%pathname-type pathname)))) + +(define (unparse-device device) + (if (eq? device 'UNSPECIFIC) "" device)) + +(define (unparse-directory directory) + (cond ((not directory) + "") + ((pair? directory) + (string-append + (if (eq? (car directory) 'ABSOLUTE) + sub-directory-delimiter-string + "") + (let loop ((directory (cdr directory))) + (if (null? directory) + "" + (string-append (unparse-directory-component (car directory)) + sub-directory-delimiter-string + (loop (cdr directory))))))) + (else + (error "Illegal pathname directory:" directory)))) + +(define (unparse-directory-component component) + (cond ((eq? component 'UP) "..") + ((string? component) component) + (else (error "Illegal pathname directory component:" component)))) + +(define (unparse-name name type) + (let ((name (or (unparse-component name) "")) + (type (unparse-component type))) + (if type + (string-append name "." type) + name))) + +(define (unparse-component component) + (cond ((or (not component) (string? component)) component) + ((eq? component 'WILD) "*") + (else (error "Illegal pathname component:" component)))) + +;;;; Pathname Constructors + +(define (dos/make-pathname host device directory name type version) + (%make-pathname + host + (cond ((string? device) device) + ((memq device '(#F UNSPECIFIC)) 'UNSPECIFIC) + (else + (error:wrong-type-argument device "pathname device" 'MAKE-PATHNAME))) + (cond ((not directory) + directory) + ((and (list? directory) + (not (null? directory)) + (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" + 'MAKE-PATHNAME))) + (if (or (memq name '(#F WILD)) + (and (string? name) (not (string-null? name)))) + name + (error:wrong-type-argument name "pathname name" 'MAKE-PATHNAME)) + (if (or (memq type '(#F WILD)) + (and (string? type) (not (string-null? type)))) + type + (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)))) + +(define (dos/pathname-as-directory pathname) + (let ((name (%pathname-name pathname)) + (type (%pathname-type pathname))) + (if (or name type) + (%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))))) + false + false + 'UNSPECIFIC) + pathname))) + +(define (dos/directory-pathname-as-file pathname) + (let ((directory (%pathname-directory pathname))) + (if (not (and (pair? directory) + (or (eq? 'ABSOLUTE (car directory)) + (pair? (cdr directory))))) + (error:bad-range-argument pathname 'DIRECTORY-PATHNAME-AS-FILE)) + (if (null? (cdr directory)) + (%make-pathname (%pathname-host pathname) + (%pathname-device pathname) + directory + "" + false + 'UNSPECIFIC) + (parse-name (unparse-directory-component (car (last-pair directory))) + (lambda (name type) + (%make-pathname (%pathname-host pathname) + (%pathname-device pathname) + (simplify-directory (except-last-pair directory)) + name + type + 'UNSPECIFIC)))))) + +;;;; Miscellaneous + +(define (dos/pathname-wild? pathname) + (or (eq? 'WILD (%pathname-name pathname)) + (eq? 'WILD (%pathname-type pathname)))) + +(define (dos/pathname->truename pathname) + (if (eq? true (file-exists? pathname)) + pathname + (dos/pathname->truename + (error:file-operation pathname "find" "file" "file does not exist" + dos/pathname->truename (list pathname))))) + +(define (dos/user-homedir-pathname host) + (and (eq? host local-host) + (pathname-as-directory (dos/current-home-directory)))) + +(define (dos/init-file-pathname host) + (let ((pathname + (merge-pathnames init-file-name (dos/user-homedir-pathname host)))) + (and (file-exists? pathname) + 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)) \ No newline at end of file