Common Lisp pathname abstraction.
Incompatible changes:
* ->PATHNAME no longer accepts a symbol as an argument. Only strings
and pathnames are valid.
* Procedures eliminated:
CANONICALIZE-INPUT-FILENAME
CANONICALIZE-INPUT-PATHNAME
CANONICALIZE-OUTPUT-FILENAME
CANONICALIZE-OUTPUT-PATHNAME
CANONICALIZE-OVERWRITE-FILENAME
CANONICALIZE-OVERWRITE-PATHNAME
HOME-DIRECTORY-PATHNAME
INIT-FILE-TRUENAME
PATHNAME->ABSOLUTE-PATHNAME
PATHNAME->INPUT-TRUENAME
PATHNAME->OUTPUT-TRUENAME
PATHNAME->OVERWRITE-TRUENAME
PATHNAME->STRING
PATHNAME-COMPONENTS
PATHNAME-DEFAULT-HOST
PATHNAME-DIRECTORY-PATH
PATHNAME-DIRECTORY-STRING
PATHNAME-NAME-PATH
PATHNAME-NAME-STRING
PATHNAME-NEW-HOST
PATHNAME-RELATIVE?
STRING->PATHNAME
SYMBOL->PATHNAME
The file "old-path.scm" contains emulations for all of these
procedures, except PATHNAME-DEFAULT-HOST, PATHNAME-NEW-HOST, and
SYMBOL->PATHNAME.
* UNIX/FILE-ACCESS has been renamed to FILE-ACCESS. UNIX/FILE-ACCESS
still exists as a synonym, but is obsolete.
* PATHNAME-DEFAULT no longer accepts a HOST argument.
* DELETE-FILE no longer returns a useful value. Attempting to delete
a non-existent file signals an error.
* Various "loading" and "dumping" messages now use ENOUGH-NAMESTRING
to eliminate redundant part of the filename being printed.
* MAKE-PATHNAME checks its arguments for consistency, and signals an
error for illegal arguments.
* Representation of pathname directories changed to match Common
Lisp. Directory is now either #F or a list of symbols and strings
with first element either 'ABSOLUTE or 'RELATIVE.
* Unix pathnames now set DEVICE and VERSION to 'UNSPECIFIC.
'UNSPECIFIC now means that the field is not used by the operating
system.
* Parsing rules for unix filenames changed: the file type is the part
of the name after the last dot, if any. If the dot occurs at the
beginning or end of the filename, then it doesn't count -- in that
case there is no type. Thus, names like "." and ".." have no type.
Enhancements:
* New procedures and variables. Most are defined as in Common Lisp.
*DEFAULT-PATHNAME-DEFAULTS*
->NAMESTRING
->TRUENAME
DIRECTORY-NAMESTRING
DIRECTORY-PATHNAME
DIRECTORY-PATHNAME-AS-FILE
ENOUGH-NAMESTRING
ENOUGH-PATHNAME
FILE-ACCESS
FILE-ATTRIBUTES-DIRECT (same as FILE-ATTRIBUTES)
FILE-MODIFICATION-TIME-DIRECT
FILE-MODIFICATION-TIME-INDIRECT (same as FILE-MODIFICATION-TIME)
FILE-NAMESTRING
FILE-PATHNAME
FILE-READABLE?
HOST-NAMESTRING
PATHNAME-WILD?
PATHNAME=?
* All pathname procedures now do an implicit ->PATHNAME on their
"pathname" and "defaults" arguments.
* MERGE-PATHNAMES second argument is now optional, and defaults to
*DEFAULT-PATHNAME-DEFAULTS*. It accepts a third optional argument,
DEFAULT-VERSION, which defaults to 'NEWEST. The merging algorithm
has been changed to match Common Lisp.
* *DEFAULT-PATHNAME-DEFAULTS* is updated by
SET-WORKING-DIRECTORY-PATHNAME! and CD as long as it is EQ? to the
working directory.
* EQUAL? guaranteed to work on pathnames.
Miscellaneous:
* Old Starbase graphics eliminated.
* Files "unk*.scm" and "vms*.scm" removed. They will need to be
rewritten if this support is desired in the future.
syntax-table/system-internal)
("uerror" (runtime microcode-errors)
syntax-table/system-internal)
- ("unkcwd" (runtime working-directory)
- syntax-table/system-internal)
- ("unkdir" (runtime directory)
- syntax-table/system-internal)
- ("unkpar" (runtime pathname-parser)
- syntax-table/system-internal)
- ("unkpth" ()
- syntax-table/system-internal)
- ("unkunp" (runtime pathname-unparser)
- syntax-table/system-internal)
("unpars" (runtime unparser)
syntax-table/system-internal)
("unsyn" (runtime unsyntaxer)
syntax-table/system-internal)
("unxdir" (runtime directory)
syntax-table/system-internal)
- ("unxpar" (runtime pathname-parser)
- syntax-table/system-internal)
("unxprm" ()
syntax-table/system-internal)
- ("unxpth" ()
- syntax-table/system-internal)
- ("unxunp" (runtime pathname-unparser)
+ ("unxpth" (runtime pathname unix)
syntax-table/system-internal)
("uproc" (runtime procedure)
syntax-table/system-internal)
syntax-table/system-internal)
("version" (runtime)
syntax-table/system-internal)
- ("vmscwd" (runtime working-directory)
- syntax-table/system-internal)
- ("vmspar" (runtime pathname-parser)
- syntax-table/system-internal)
- ("vmspth" ()
- syntax-table/system-internal)
- ("vmsunp" (runtime pathname-unparser)
- syntax-table/system-internal)
("where" (runtime environment-inspector)
syntax-table/system-internal)
("wind" (runtime state-space)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/emacs.scm,v 14.8 1991/03/06 23:03:24 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/emacs.scm,v 14.9 1991/11/04 20:28:37 cph Exp $
Copyright (c) 1988-91 Massachusetts Institute of Technology
(eq? console-output-port (cmdl/output-port cmdl))))
(define (emacs/set-working-directory-pathname! pathname)
- (transmit-signal-with-argument #\w (pathname->string pathname)))
+ (transmit-signal-with-argument #\w (->namestring pathname)))
(define (emacs/clean-input/flush-typeahead character)
character
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/equals.scm,v 14.3 1991/01/31 07:08:51 hal Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/equals.scm,v 14.4 1991/11/04 20:28:41 cph Exp $
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988-91 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(define (equal? x y)
(or (eq? x y)
(if (object-type? (object-type x) y)
- (cond ((number? y)
- (and (= x y)
- (boolean=? (exact? x) (exact? y))))
+ (cond ((object-type? (ucode-type cell) y)
+ (equal? (cell-contents x) (cell-contents y)))
((object-type? (ucode-type list) y)
(and (equal? (car x) (car y))
(equal? (cdr x) (cdr y))))
+ ((object-type? (ucode-type character-string) y)
+ (string=? x y))
+ ((object-type? (ucode-type vector-1b) y)
+ (bit-string=? x y))
+ ((number? y)
+ (and (= x y)
+ (boolean=? (exact? x) (exact? y))))
+ ((pathname? x)
+ (and (pathname? y)
+ (pathname=? x y)))
((object-type? (ucode-type vector) y)
(let ((size (vector-length x)))
(and (= size (vector-length y))
(and (equal? (vector-ref x index)
(vector-ref y index))
(loop (1+ index))))))))
- ((object-type? (ucode-type cell) y)
- (equal? (cell-contents x) (cell-contents y)))
- ((object-type? (ucode-type character-string) y)
- (string=? x y))
- ((object-type? (ucode-type vector-1b) y)
- (bit-string=? x y))
(else false))
(and (number? x)
(number? y)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/error.scm,v 14.27 1991/10/29 14:31:40 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/error.scm,v 14.28 1991/11/04 20:28:45 cph Exp $
Copyright (c) 1988-91 Massachusetts Institute of Technology
(write-string " " port)
(write-string noun port)
(write-string " " port)
- (write (let ((filename (access-condition condition 'FILENAME)))
- (if (pathname? filename)
- (pathname->string filename)
- filename))
+ (write (->namestring (access-condition condition 'FILENAME))
port)
(write-string " because: " port)
(let ((reason (access-condition condition 'REASON)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/global.scm,v 14.32 1991/09/02 03:55:52 sybok Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/global.scm,v 14.33 1991/11/04 20:29:00 cph Exp $
Copyright (c) 1988-91 Massachusetts Institute of Technology
object)
(define (fasdump object filename)
- (let ((filename (canonicalize-output-filename filename))
+ (let ((filename (->namestring (merge-pathnames filename)))
(port (cmdl/output-port (nearest-cmdl))))
(newline port)
(write-string "Dumping " port)
- (write filename port)
+ (write (enough-namestring filename) port)
(if (not ((ucode-primitive primitive-fasdump) object filename false))
- (error "FASDUMP: Object is too large to be dumped" object))
- (write-string " -- done" port))
- unspecific)
+ (error "FASDUMP: Object is too large to be dumped:" object))
+ (write-string " -- done" port)))
\f
(define (undefined-value? object)
;; Note: the unparser takes advantage of the fact that objects
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/infutl.scm,v 1.21 1991/04/15 20:47:29 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/infutl.scm,v 1.22 1991/11/04 20:29:04 cph Exp $
Copyright (c) 1988-91 Massachusetts Institute of Technology
(define (process-binf-filename binf-filename com-pathname)
(and binf-filename
- (pathname->string
+ (->namestring
(rewrite-directory
- (let ((binf-pathname
- (pathname->absolute-pathname
- (->pathname binf-filename))))
+ (let ((binf-pathname (merge-pathnames binf-filename))
+ (com-pathname (merge-pathnames com-pathname)))
(if (and (equal? (pathname-name binf-pathname)
(pathname-name com-pathname))
(not (equal? (pathname-type binf-pathname)
'())
(define (add-directory-rewriting-rule! match replace)
- (let ((match (pathname->absolute-pathname (->pathname match)))
- (replace (pathname->absolute-pathname (->pathname replace))))
+ (let ((match (merge-pathnames match))
+ (replace (merge-pathnames replace)))
(let ((rule
(list-search-positive directory-rewriting-rules
(lambda (rule)
pathname)))
(define (directory-prefix? x y)
- (or (null? y)
- (and (not (null? x))
- (equal? (car x) (car y))
- (directory-prefix? (cdr x) (cdr y)))))
+ (and (pair? x)
+ (pair? y)
+ (eq? (car x) (car y))
+ (let loop ((x (cdr x)) (y (cdr y)))
+ (or (null? y)
+ (and (not (null? x))
+ (equal? (car x) (car y))
+ (loop (cdr x) (cdr y)))))))
\f
(define-integrable (dbg-block/layout-first-offset block)
(let ((layout (dbg-block/layout block)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/intrpt.scm,v 14.6 1991/02/15 18:05:58 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/intrpt.scm,v 14.7 1991/11/04 20:29:09 cph Exp $
Copyright (c) 1988-91 Massachusetts Institute of Technology
condition
(muffle-warning))
(lambda ()
- (if (not (disk-save (merge-pathnames (string->pathname "scheme_suspend")
- (home-directory-pathname))
+ (if (not (disk-save (merge-pathnames "scheme_suspend"
+ (user-homedir-pathname))
true))
(%exit)))))))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/io.scm,v 14.27 1991/10/26 16:20:48 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/io.scm,v 14.28 1991/11/04 20:29:14 cph Exp $
Copyright (c) 1988-91 Massachusetts Institute of Technology
(define (pty-master-hangup channel)
((ucode-primitive pty-master-hangup 1) (channel-descriptor channel)))
\f
-;;;; File Copying
-
-(define (copy-file from to)
- (file-copy (canonicalize-input-filename from)
- (canonicalize-output-filename to)))
-
-(define (file-copy input-filename output-filename)
- (let ((input-channel false)
- (output-channel false))
- (dynamic-wind
- (lambda ()
- (set! input-channel (file-open-input-channel input-filename))
- (set! output-channel
- (begin
- ((ucode-primitive file-remove-link 1) output-filename)
- (file-open-output-channel output-filename)))
- unspecific)
- (lambda ()
- (let ((source-length (file-length input-channel))
- (buffer-length 8192))
- (if (zero? source-length)
- 0
- (let* ((buffer (make-string buffer-length))
- (transfer
- (lambda (length)
- (let ((n-read
- (channel-read-block input-channel
- buffer
- 0
- length)))
- (if (positive? n-read)
- (channel-write-block output-channel
- buffer
- 0
- n-read))
- n-read))))
- (let loop ((source-length source-length))
- (if (< source-length buffer-length)
- (transfer source-length)
- (let ((n-read (transfer buffer-length)))
- (if (= n-read buffer-length)
- (+ (loop (- source-length buffer-length))
- buffer-length)
- n-read))))))))
- (lambda ()
- (if output-channel (channel-close output-channel))
- (if input-channel (channel-close input-channel))))))
-\f
;;;; Buffered Output
(define-structure (output-buffer
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/load.scm,v 14.29 1991/10/29 14:31:49 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/load.scm,v 14.30 1991/11/04 20:29:20 cph Exp $
Copyright (c) 1988-91 Massachusetts Institute of Technology
(declare (usual-integrations))
\f
(define (initialize-package!)
- (set! hook/process-command-line default/process-command-line)
(set! load-noisily? false)
(set! load/loading? false)
(set! load/suppress-loading-message? false)
(set! load/default-types '("com" "bin" "scm"))
(set! load/default-find-pathname-with-type search-types-in-order)
(set! fasload/default-types '("com" "bin"))
- (add-event-receiver! event:after-restart
- (lambda ()
- (process-command-line))))
+ (set! hook/process-command-line default/process-command-line)
+ (add-event-receiver! event:after-restart process-command-line))
(define load-noisily?)
(define load/loading?)
(define fasload/default-types)
(define (read-file filename)
- (call-with-input-file
- (pathname-default-version (->pathname filename) 'NEWEST)
+ (call-with-input-file (pathname-default-version filename 'NEWEST)
(lambda (port)
(stream->list (read-stream port)))))
(define (fasload filename #!optional suppress-loading-message?)
- (fasload/internal
- (find-true-pathname (->pathname filename) fasload/default-types)
- (if (default-object? suppress-loading-message?)
- load/suppress-loading-message?
- suppress-loading-message?)))
+ (fasload/internal (find-pathname filename fasload/default-types)
+ (if (default-object? suppress-loading-message?)
+ load/suppress-loading-message?
+ suppress-loading-message?)))
-(define (fasload/internal true-pathname suppress-loading-message?)
+(define (fasload/internal pathname suppress-loading-message?)
(let ((value
- (let ((true-filename (pathname->string true-pathname)))
- (loading-message suppress-loading-message? true-filename
- (lambda ()
- ((ucode-primitive binary-fasload) true-filename))))))
- (fasload/update-debugging-info! value true-pathname)
+ (loading-message suppress-loading-message? pathname
+ (lambda ()
+ ((ucode-primitive binary-fasload) (->namestring pathname))))))
+ (fasload/update-debugging-info! value pathname)
value))
(define (load-noisily filename #!optional environment syntax-table purify?)
(if (default-object? purify?) default-object purify?))))
(define (load-init-file)
- (let ((truename (init-file-truename)))
- (if truename
- (load truename user-initial-environment)))
+ (let ((pathname (init-file-pathname)))
+ (if pathname
+ (load pathname user-initial-environment)))
unspecific)
-(define (loading-message suppress-loading-message? true-filename do-it)
+(define (loading-message suppress-loading-message? pathname do-it)
(if suppress-loading-message?
(do-it)
(let ((port (cmdl/output-port (nearest-cmdl))))
(newline port)
(write-string "Loading " port)
- (write true-filename port)
+ (write (enough-namestring pathname) port)
(let ((value (do-it)))
(write-string " -- done" port)
value))))
(let ((kernel
(lambda (filename last-file?)
(let ((value
- (let ((pathname (->pathname filename)))
- (load/internal
- pathname
- (find-true-pathname pathname
- load/default-types)
- environment
- syntax-table
- purify?
- load-noisily?))))
+ (load/internal
+ (find-pathname filename load/default-types)
+ environment
+ syntax-table
+ purify?
+ load-noisily?)))
(cond (last-file? value)
(load-noisily? (write-line value)))))))
(let ((value
(define default-object
"default-object")
-
+\f
(define (load-latest . args)
(fluid-let ((load/default-find-pathname-with-type find-latest-file))
(apply load args)))
(define (fasload-latest . args)
(fluid-let ((load/default-find-pathname-with-type find-latest-file))
(apply fasload args)))
-\f
-(define (find-true-pathname pathname default-types)
- (or (pathname->input-truename pathname)
- (let ((pathname (pathname-default-version pathname 'NEWEST)))
- (if (pathname-type pathname)
- (pathname->input-truename pathname)
- (load/default-find-pathname-with-type pathname default-types)))
- (find-true-pathname
- (->pathname
- (error:file-operation pathname
- "find"
- "file"
- "file does not exist"
- find-true-pathname
- (list pathname default-types)))
- default-types)))
+
+(define (find-pathname filename default-types)
+ (let ((pathname (merge-pathnames filename)))
+ (if (file-exists? pathname)
+ pathname
+ (or (and (not (pathname-type pathname))
+ (load/default-find-pathname-with-type pathname default-types))
+ (find-pathname
+ (error:file-operation filename
+ "find"
+ "file"
+ "file does not exist"
+ find-pathname
+ (list filename default-types))
+ default-types)))))
(define (search-types-in-order pathname default-types)
(let loop ((types default-types))
(and (not (null? types))
- (or (pathname->input-truename
- (pathname-new-type pathname (car types)))
- (loop (cdr types))))))
+ (let ((pathname (pathname-new-type pathname (car types))))
+ (if (file-exists? pathname)
+ pathname
+ (loop (cdr types)))))))
(define (find-latest-file pathname default-types)
(let loop
((types default-types)
(latest-pathname false)
- (latest-modification-time 0))
+ (latest-time 0))
(if (not (pair? types))
latest-pathname
- (let ((truename
- (pathname->input-truename
- (pathname-new-type pathname (car types))))
+ (let ((pathname (pathname-new-type pathname (car types)))
(skip
(lambda ()
- (loop (cdr types) latest-pathname latest-modification-time))))
- (if (not truename)
- (skip)
- (let ((modification-time (file-modification-time truename)))
- (if (> modification-time latest-modification-time)
- (loop (cdr types) truename modification-time)
- (skip))))))))
+ (loop (cdr types) latest-pathname latest-time))))
+ (let ((time (file-modification-time-indirect pathname)))
+ (if (and time (> time latest-time))
+ (loop (cdr types) pathname time)
+ (skip)))))))
\f
-(define (load/internal pathname true-pathname environment syntax-table
- purify? load-noisily?)
- (let* ((port (open-input-file/internal pathname true-pathname))
+(define (load/internal pathname environment syntax-table purify? load-noisily?)
+ (let* ((port (open-input-file pathname))
(fasl-marker (peek-char port)))
(if (and (not (eof-object? fasl-marker))
(= 250 (char->ascii fasl-marker)))
(close-input-port port)
(extended-scode-eval
(let ((scode
- (fasload/internal true-pathname
- load/suppress-loading-message?)))
+ (fasload/internal pathname load/suppress-loading-message?)))
(if purify? (purify (load/purification-root scode)))
scode)
(if (eq? environment default-object)
(write-stream (value-stream)
(lambda (value)
(hook/repl-write (nearest-repl) value)))
- (loading-message load/suppress-loading-message?
- (pathname->string true-pathname)
- (lambda ()
- (write-stream (value-stream)
- (lambda (value)
- value
- false)))))))))
+ (loading-message load/suppress-loading-message? pathname
+ (lambda ()
+ (write-stream (value-stream)
+ (lambda (value) value false)))))))))
(define (load/purification-root scode)
(or (and (comment? scode)
value))
unspecific))
\f
-(define-primitives
- (get-unused-command-line 0))
-
(define (process-command-line)
- (hook/process-command-line
- (and (implemented-primitive-procedure? get-unused-command-line)
- (get-unused-command-line))))
+ (hook/process-command-line ((ucode-primitive get-unused-command-line 0))))
(define hook/process-command-line)
-
(define (default/process-command-line unused-command-line)
(if unused-command-line
(letrec ((unused-command-line-length (vector-length unused-command-line))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/make.scm,v 14.29 1991/05/06 03:19:35 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/make.scm,v 14.30 1991/11/04 20:29:26 cph Exp $
Copyright (c) 1988-91 Massachusetts Institute of Technology
(RUNTIME OUTPUT-PORT)
(RUNTIME PATHNAME)
(RUNTIME WORKING-DIRECTORY)
- (RUNTIME DIRECTORY)
(RUNTIME LOAD)
;; Syntax
(RUNTIME PARSER)
(->environment '(RUNTIME LOAD)))))
(map (lambda (entry)
(let ((object (cdr entry)))
- (fasload/update-debugging-info!
- object
- (pathname->absolute-pathname (->pathname (car entry))))
+ (fasload/update-debugging-info! object (car entry))
(load/purification-root object)))
fasload-purification-queue)))))
(set! fasload-purification-queue)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/option.scm,v 14.11 1991/03/06 18:39:26 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/option.scm,v 14.12 1991/11/04 20:29:31 cph Exp $
Copyright (c) 1988-91 Massachusetts Institute of Technology
(define (load-option name)
(let ((entry (assq name options))
- (directory
- (system-library-directory-pathname (string->pathname "options"))))
+ (directory (system-library-directory-pathname "options")))
(if (not entry)
(error "Unknown option name" name))
(if (not (memq name loaded-options))
(let ((environment
(package/environment (find-package (car descriptor)))))
(for-each (lambda (filename)
- (load (merge-pathnames (string->pathname filename)
- directory)
+ (load (merge-pathnames filename directory)
environment
syntax-table/system-internal
true))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/packag.scm,v 14.9 1989/08/11 02:59:22 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/packag.scm,v 14.10 1991/11/04 20:29:35 cph Exp $
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988-91 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(define (package/system-loader filename options load-interpreted?)
(let ((pathname (->pathname filename)))
- (with-working-directory-pathname (pathname-directory-path pathname)
+ (with-working-directory-pathname (directory-pathname pathname)
(lambda ()
(fluid-let ((load/default-types
(if (if (eq? load-interpreted? 'QUERY)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pathnm.scm,v 14.15 1991/10/29 14:31:56 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pathnm.scm,v 14.16 1991/11/04 20:29:39 cph Exp $
Copyright (c) 1988-91 Massachusetts Institute of Technology
;;; package: (runtime pathname)
(declare (usual-integrations))
-\f#|
-A pathname component is normally one of:
+\f
+#|
-* A string, which is the literal component.
+When examining pathname components, programs must be prepared to
+encounter any of the following situations:
-* 'WILD, meaning that the component is wildcarded. Such components
-may have special meaning to certain directory operations.
+* The host can be a host object.
-* #F, meaning that the component was not supplied. This has special
-meaning to `merge-pathnames', in which such components are
-substituted.
+* Any component except the host can be #F, which means the component
+ has not been specified.
-* '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'.
+* Any component except the can be 'UNSPECIFIC, which means the
+ component has no meaning in this particular pathname.
-A pathname consists of 5 components, not all necessarily meaningful,
-as follows:
+* The device, name, and type can be non-null strings.
-* The DEVICE is usually a physical device, as in the Twenex `ps:'.
+* The directory can be a non-empty list of non-null strings and
+ symbols, whose first element is either 'ABSOLUTE or 'RELATIVE.
-* The DIRECTORY is a list of components. If the first component 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 version can be any symbol or any positive exact integer. The
+ symbol 'NEWEST refers to the largest version number that already
+ exists in the file system when reading, overwriting, appending,
+ superseding, or directory-listing an existing file; it refers to the
+ smallest version number greater than any existing version number
+ when creating a new file.
-* The NAME is the proper name part of the filename.
+When examining wildcard components of a wildcard pathname, programs
+must be prepared to encounter any of the following additional values
+in any component (except the host) or any element of a list that is
+the directory component:
-* The TYPE usually indicates something about the contents of the file.
-Certain system procedures will default the type to standard type
-strings.
+* The symbol 'WILD, which matches anything.
-* The VERSION is special. Unlike an ordinary component, it is never a
-string, but may be either a positive integer, 'NEWEST, '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.
+* A string containing implementation-dependent special wildcard
+ characters.
-This file requires the following procedures and variables which define
-the conventions for the particular file system in use:
+* Any object, representing an implementation-dependent wildcard
+ pattern.
-(symbol->pathname symbol)
-(pathname-parse string (lambda (device directory name type version)))
-(pathname-unparse device directory name type version)
-(pathname-unparse-name name type version)
-(pathname-as-directory pathname)
-(pathname-newest pathname)
-working-directory-package
-(access reset! working-directory-package)
-init-file-pathname
-(home-directory-pathname)
-(working-directory-pathname)
-(set-working-directory-pathname! name)
+When constructing a pathname from components, programs must follow
+these rules:
-See the files unkpth.scm, vmspth.scm, or unxpth.scm for examples.|#
-\f
-;;;; Basic Pathnames
+* Any component may be #F. Specifying #F for the host results in
+ using a default host rather than an actual #F value.
+
+* The host may be a host object.
+
+* The device, name, and type may be strings. There are
+ implementation-dependent limits on the number and type of characters
+ in these strings. A plausible assumption is that letters (of a
+ single case) and digits are acceptable to most file system.
+
+* The directory may be a list of strings and symbols whose first
+ element is either 'ABSOLUTE or 'RELATIVE. There are
+ implementation-dependent limits on the length and contents of the
+ list.
+
+* The version may be 'NEWEST.
+
+* Any component may be taken from the corresponding component of
+ another pathname. When the two pathnames are for different file
+ systems, an appropriate translation occurs. If no meaningful
+ translation is possible, an error is signalled.
+* When constructing a wildcard pathname, the name, type, or version
+ may be 'WILD, which matches anything.
+
+|#
+\f
(define-structure (pathname
(named (string->symbol "#[(runtime pathname)pathname]"))
- (copier pathname-copy)
+ (constructor %make-pathname)
+ (conc-name %pathname-)
(print-procedure
(unparser/standard-method 'PATHNAME
(lambda (state pathname)
- (unparse-object state (pathname->string pathname))))))
+ (unparse-object state (->namestring pathname))))))
(host false read-only true)
(device false read-only true)
(directory false read-only true)
(type false read-only true)
(version false read-only true))
-(define (pathname-components pathname receiver)
- (receiver (pathname-host pathname)
- (pathname-device pathname)
- (pathname-directory pathname)
- (pathname-name pathname)
- (pathname-type pathname)
- (pathname-version pathname)))
+(define (->pathname object)
+ (pathname-arg object false '->PATHNAME))
+
+(define (pathname-arg object defaults operator)
+ (cond ((pathname? object) object)
+ ((string? object) (parse-namestring object false defaults))
+ (else (error:wrong-type-argument object "pathname" operator))))
+
+(define (make-pathname host device directory name type version)
+ (let ((host (if host (guarantee-host host 'MAKE-PATHNAME) local-host)))
+ ((host-operation/make-pathname host)
+ host device directory name type version)))
+
+(define (pathname-host pathname)
+ (%pathname-host (->pathname pathname)))
+
+(define (pathname-device pathname)
+ (%pathname-device (->pathname pathname)))
+
+(define (pathname-directory pathname)
+ (%pathname-directory (->pathname pathname)))
+
+(define (pathname-name pathname)
+ (%pathname-name (->pathname pathname)))
+
+(define (pathname-type pathname)
+ (%pathname-type (->pathname pathname)))
+
+(define (pathname-version pathname)
+ (%pathname-version (->pathname pathname)))
+
+(define (pathname=? x y)
+ (let ((x (->pathname x))
+ (y (->pathname y)))
+ (and (eq? (%pathname-host x) (%pathname-host y))
+ (equal? (%pathname-device x) (%pathname-device y))
+ (equal? (%pathname-directory x) (%pathname-directory y))
+ (equal? (%pathname-name x) (%pathname-name y))
+ (equal? (%pathname-type x) (%pathname-type y))
+ (equal? (%pathname-version x) (%pathname-version y)))))
(define (pathname-absolute? pathname)
(let ((directory (pathname-directory pathname)))
(and (pair? directory)
- (eq? (car directory) 'ROOT))))
-
-(define (pathname-relative? pathname pathname*)
- (and (equal? (pathname-host pathname)
- (pathname-host pathname*))
- (equal? (pathname-device pathname)
- (pathname-device pathname*))
- (let loop
- ((directory (pathname-directory pathname))
- (directory* (pathname-directory pathname*)))
- (if (null? directory*)
- (make-pathname false
- false
- directory
- (pathname-name pathname)
- (pathname-type pathname)
- (pathname-version pathname))
- (and (not (null? directory))
- (equal? (car directory) (car directory*))
- (loop (cdr directory) (cdr directory*)))))))
-
-(define (pathname-directory-path pathname)
- (make-pathname (pathname-host pathname)
- (pathname-device pathname)
- (pathname-directory pathname)
- false
- false
- false))
-
-(define (pathname-name-path pathname)
- (make-pathname false
- false
- false
- (pathname-name pathname)
- (pathname-type pathname)
- (pathname-version pathname)))
+ (eq? (car directory) 'ABSOLUTE))))
+
+(define (pathname-wild? pathname)
+ (let ((pathname (->pathname pathname)))
+ ((host-operation/pathname-wild? (%pathname-host pathname)) pathname)))
\f
-(define (pathname-new-host pathname host)
- (make-pathname host
- (pathname-device pathname)
- (pathname-directory pathname)
- (pathname-name pathname)
- (pathname-type pathname)
- (pathname-version pathname)))
+(define (directory-pathname pathname)
+ (let ((pathname (->pathname pathname)))
+ (%make-pathname (%pathname-host pathname)
+ (%pathname-device pathname)
+ (%pathname-directory pathname)
+ false
+ false
+ false)))
+
+(define (file-pathname pathname)
+ (let ((pathname (->pathname pathname)))
+ (%make-pathname (%pathname-host pathname)
+ false
+ false
+ (%pathname-name pathname)
+ (%pathname-type pathname)
+ (%pathname-version pathname))))
+
+(define (pathname-as-directory pathname)
+ (let ((pathname (->pathname pathname)))
+ ((host-operation/pathname-as-directory (%pathname-host pathname))
+ pathname)))
+
+(define (directory-pathname-as-file pathname)
+ (let ((pathname (->pathname pathname)))
+ ((host-operation/directory-pathname-as-file (%pathname-host pathname))
+ pathname)))
(define (pathname-new-device pathname device)
- (make-pathname (pathname-host pathname)
- device
- (pathname-directory pathname)
- (pathname-name pathname)
- (pathname-type pathname)
- (pathname-version pathname)))
+ (let ((pathname (->pathname pathname)))
+ (%make-pathname (%pathname-host pathname)
+ device
+ (%pathname-directory pathname)
+ (%pathname-name pathname)
+ (%pathname-type pathname)
+ (%pathname-version pathname))))
(define (pathname-new-directory pathname directory)
- (make-pathname (pathname-host pathname)
- (pathname-device pathname)
- directory
- (pathname-name pathname)
- (pathname-type pathname)
- (pathname-version pathname)))
+ (let ((pathname (->pathname 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)
- (make-pathname (pathname-host pathname)
- (pathname-device pathname)
- (pathname-directory pathname)
- name
- (pathname-type pathname)
- (pathname-version pathname)))
+ (let ((pathname (->pathname 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)
- (make-pathname (pathname-host pathname)
- (pathname-device pathname)
- (pathname-directory pathname)
- (pathname-name pathname)
- type
- (pathname-version pathname)))
+ (let ((pathname (->pathname 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)
- (make-pathname (pathname-host pathname)
- (pathname-device pathname)
- (pathname-directory pathname)
- (pathname-name pathname)
- (pathname-type pathname)
- version))
+ (let ((pathname (->pathname pathname)))
+ (%make-pathname (%pathname-host pathname)
+ (%pathname-device pathname)
+ (%pathname-directory pathname)
+ (%pathname-name pathname)
+ (%pathname-type pathname)
+ version)))
\f
-(define (pathname-default-host pathname host)
- (if (pathname-host pathname)
- pathname
- (pathname-new-host pathname host)))
-
(define (pathname-default-device pathname device)
- (if (pathname-device pathname)
- pathname
- (pathname-new-device pathname device)))
+ (let ((pathname (->pathname pathname)))
+ (if (%pathname-device pathname)
+ pathname
+ (pathname-new-device pathname device))))
(define (pathname-default-directory pathname directory)
- (if (pathname-directory pathname)
- pathname
- (pathname-new-directory pathname directory)))
+ (let ((pathname (->pathname pathname)))
+ (if (%pathname-directory pathname)
+ pathname
+ (pathname-new-directory pathname directory))))
(define (pathname-default-name pathname name)
- (if (pathname-name pathname)
- pathname
- (pathname-new-name pathname name)))
+ (let ((pathname (->pathname pathname)))
+ (if (%pathname-name pathname)
+ pathname
+ (pathname-new-name pathname name))))
(define (pathname-default-type pathname type)
- (if (pathname-type pathname)
- pathname
- (pathname-new-type pathname type)))
+ (let ((pathname (->pathname pathname)))
+ (if (%pathname-type pathname)
+ pathname
+ (pathname-new-type pathname type))))
(define (pathname-default-version pathname version)
- (if (pathname-version pathname)
- pathname
- (pathname-new-version pathname version)))
-
-(define (pathname-default pathname host device directory name type version)
- (make-pathname (or (pathname-host pathname) host)
- (or (pathname-device pathname) device)
- (or (pathname-directory pathname) directory)
- (or (pathname-name pathname) name)
- (or (pathname-type pathname) type)
- (or (pathname-version pathname) version)))
+ (let ((pathname (->pathname pathname)))
+ (if (%pathname-version pathname)
+ pathname
+ (pathname-new-version pathname version))))
+
+(define (pathname-default pathname device directory name type version)
+ (let ((pathname (->pathname pathname)))
+ (%make-pathname (%pathname-host pathname)
+ (or (%pathname-device pathname) device)
+ (or (%pathname-directory pathname) directory)
+ (or (%pathname-name pathname) name)
+ (or (%pathname-type pathname) type)
+ (or (%pathname-version pathname) version))))
\f
;;;; Pathname Syntax
-(define (->pathname object)
- (cond ((pathname? object) object)
- ((string? object) (string->pathname object))
- ((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)
- (pathname-unparse (pathname-host pathname)
- (pathname-device pathname)
- (pathname-directory pathname)
- (pathname-name pathname)
- (pathname-type pathname)
- (pathname-version pathname)))
-
-(define (pathname-directory-string pathname)
- (pathname-unparse (pathname-host pathname)
- (pathname-device pathname)
- (pathname-directory pathname)
- false
- false
- false))
-
-(define (pathname-name-string pathname)
- (pathname-unparse false
- false
- false
- (pathname-name pathname)
- (pathname-type pathname)
- (pathname-version pathname)))
+(define (parse-namestring namestring #!optional host defaults)
+ (let ((host
+ (if (and (not (default-object? host)) host)
+ (begin
+ (if (not (host? host))
+ (error:wrong-type-argument host "host" 'PARSE-NAMESTRING))
+ host)
+ (pathname-host
+ (if (and (not (default-object? defaults)) defaults)
+ defaults
+ *default-pathname-defaults*)))))
+ (cond ((string? namestring)
+ ((host-operation/parse-namestring host) namestring host))
+ ((pathname? namestring)
+ (if (not (eq? host (pathname-host namestring)))
+ (error:bad-range-argument namestring 'PARSE-NAMESTRING))
+ namestring)
+ (else
+ (error:wrong-type-argument namestring "namestring"
+ 'PARSE-NAMESTRING)))))
+
+(define (->namestring pathname)
+ (let ((pathname (->pathname pathname)))
+ (string-append (host-namestring pathname)
+ (pathname->namestring pathname))))
+
+(define (file-namestring pathname)
+ (pathname->namestring (file-pathname pathname)))
+
+(define (directory-namestring pathname)
+ (pathname->namestring (directory-pathname pathname)))
+
+(define (host-namestring pathname)
+ (let ((host (host/name (pathname-host pathname))))
+ (if host
+ (string-append host "::")
+ "")))
+
+(define (enough-namestring pathname #!optional defaults)
+ (let ((defaults (and (not (default-object? defaults)) defaults)))
+ (let ((pathname (enough-pathname pathname defaults)))
+ (let ((namestring (pathname->namestring pathname)))
+ (if (eq? (%pathname-host pathname) (%pathname-host defaults))
+ namestring
+ (string-append (host-namestring pathname) namestring))))))
+
+(define (pathname->namestring pathname)
+ ((host-operation/pathname->namestring (%pathname-host pathname)) pathname))
\f
;;;; Pathname Merging
-(define (pathname->absolute-pathname pathname)
- (merge-pathnames pathname (working-directory-pathname)))
-
-(define (merge-pathnames pathname default)
- (make-pathname
- (or (pathname-host pathname) (pathname-host default))
- (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 directory)
- (if (or (null? directory)
- (not (list? directory)))
- directory
- (let ((head (car directory))
- (tail (delq 'SELF (cdr directory))))
- (if (eq? head 'ROOT)
- (cons 'ROOT (simplify-tail (simplify-root-tail tail)))
- (simplify-tail (cons head tail))))))
-
-(define (simplify-root-tail directory)
- (if (and (not (null? directory))
- (eq? (car directory) 'UP))
- (simplify-root-tail (cdr directory))
- directory))
-
-(define (simplify-tail directory)
- (reverse!
- (let loop ((elements (reverse 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)))))))
-\f
-;;;; Truenames
-
-(define (canonicalize-input-filename filename)
- (pathname->string (canonicalize-input-pathname filename)))
-
-(define (canonicalize-input-pathname filename)
- (let ((pathname (->pathname filename)))
- (or (pathname->input-truename pathname)
- (canonicalize-input-pathname
- (error:file-operation pathname
- "find"
- "file"
- "file does not exist"
- canonicalize-input-pathname
- (list filename))))))
-
-(define (pathname->input-truename pathname)
- (let ((pathname (pathname->absolute-pathname pathname))
- (truename-exists?
- (lambda (pathname)
- (and ((ucode-primitive file-exists? 1) (pathname->string pathname))
- pathname))))
- (cond ((not (eq? 'NEWEST (pathname-version pathname)))
- (truename-exists? pathname))
- ((not pathname-newest)
- (truename-exists? (pathname-new-version pathname false)))
- (else
- (pathname-newest pathname)))))
-
-(define (canonicalize-output-filename filename)
- (pathname->string (canonicalize-output-pathname filename)))
-
-(define-integrable (canonicalize-output-pathname filename)
- (pathname->output-truename (->pathname filename)))
-
-(define (pathname->output-truename pathname)
- (let ((pathname (pathname->absolute-pathname pathname)))
- (if (eq? 'NEWEST (pathname-version pathname))
- (pathname-new-version
- pathname
- (and pathname-newest
- (let ((greatest (pathname-newest pathname)))
- (if greatest
- (let ((version (pathname-version greatest)))
- (and version
- (1+ version)))
- 1))))
- pathname)))
-
-(define (canonicalize-overwrite-filename filename)
- (pathname->string (canonicalize-overwrite-pathname filename)))
-
-(define-integrable (canonicalize-overwrite-pathname filename)
- (pathname->overwrite-truename (->pathname filename)))
-
-(define (pathname->overwrite-truename pathname)
- (let ((pathname (pathname->absolute-pathname pathname)))
- (cond ((not (eq? 'NEWEST (pathname-version pathname)))
- pathname)
- ((not pathname-newest)
- (pathname-new-version pathname false))
- ((pathname-newest pathname))
- (else
- (pathname-new-version pathname 1)))))
-
-(define (file-exists? filename)
- (let ((pathname (pathname->absolute-pathname (->pathname filename)))
- (pathname-exists?
- (lambda (pathname)
- ((ucode-primitive file-exists? 1) (pathname->string pathname)))))
- (cond ((not (eq? 'NEWEST (pathname-version pathname)))
- (pathname-exists? pathname))
- ((not pathname-newest)
- (pathname-exists? (pathname-new-version pathname false)))
- (else
- (pathname-newest pathname)))))
+(define *default-pathname-defaults*)
+
+(define (merge-pathnames pathname #!optional defaults default-version)
+ (let* ((defaults
+ (if (and (not (default-object? defaults)) defaults)
+ (->pathname defaults)
+ *default-pathname-defaults*))
+ (pathname (pathname-arg pathname defaults 'MERGE-PATHNAMES)))
+ (make-pathname
+ (or (%pathname-host pathname) (%pathname-host defaults))
+ (or (%pathname-device pathname)
+ (and (%pathname-host pathname)
+ (eq? (%pathname-host pathname) (%pathname-host defaults))
+ (%pathname-device defaults)))
+ (let ((directory (%pathname-directory pathname))
+ (default (%pathname-directory defaults)))
+ (cond ((not directory)
+ default)
+ ((and (pair? directory)
+ (eq? (car directory) 'RELATIVE)
+ (pair? default))
+ (append default (cdr directory)))
+ (else
+ directory)))
+ (or (%pathname-name pathname) (%pathname-name defaults))
+ (or (%pathname-type pathname) (%pathname-type defaults))
+ (or (%pathname-version pathname)
+ (and (not (%pathname-name pathname)) (%pathname-version defaults))
+ (if (default-object? default-version)
+ 'NEWEST
+ default-version)))))
+
+(define (enough-pathname pathname #!optional defaults)
+ (let* ((defaults
+ (if (and (not (default-object? defaults)) defaults)
+ (->pathname defaults)
+ *default-pathname-defaults*))
+ (pathname (pathname-arg pathname defaults 'ENOUGH-PATHNAME)))
+ (let ((usual
+ (lambda (component default)
+ (and (or (symbol? component)
+ (not (equal? component default)))
+ component))))
+ (make-pathname
+ (and (or (symbol? (%pathname-host pathname))
+ (not (eq? (%pathname-host pathname)
+ (%pathname-host defaults))))
+ (%pathname-host pathname))
+ (let ((device (%pathname-device pathname)))
+ (and (or (symbol? device)
+ (not (equal? device (%pathname-device defaults)))
+ (not (eq? (%pathname-host pathname)
+ (%pathname-host defaults))))
+ device))
+ (let ((directory (%pathname-directory pathname))
+ (default (%pathname-directory defaults)))
+ (if (or (not directory)
+ (symbol? directory)
+ (not (eq? (car directory) (car default))))
+ directory
+ (let loop
+ ((components (cdr directory)) (components* (cdr default)))
+ (cond ((null? components*)
+ (cons 'RELATIVE components))
+ ((and (not (null? components))
+ (equal? (car components) (car components*)))
+ (loop (cdr components) (cdr components*)))
+ (else
+ directory)))))
+ (usual (%pathname-name pathname) (%pathname-name defaults))
+ (usual (%pathname-type pathname) (%pathname-type defaults))
+ (let ((version (%pathname-version pathname)))
+ (and (or (symbol? version)
+ (not (equal? version (%pathname-version defaults)))
+ (%pathname-name pathname))
+ version))))))
\f
-(define (init-file-truename)
- (let ((pathname (init-file-pathname)))
- (and pathname
- (or (pathname->input-truename
- (merge-pathnames pathname (working-directory-pathname)))
- (pathname->input-truename
- (merge-pathnames pathname (home-directory-pathname)))))))
-
-(define (initialize-package!)
- (reset-library-directory-path!)
- (add-event-receiver! event:after-restore reset-library-directory-path!))
+;;;; Host Abstraction
+;;; A lot of hair to make pathnames fasdumpable.
-(define (reset-library-directory-path!)
- (set! library-directory-path
- (if (implemented-primitive-procedure? microcode-library-path)
- (map (lambda (filename)
- (pathname-as-directory (string->pathname filename)))
- (vector->list (microcode-library-path)))
- (list
- (pathname-directory-path
- (string->pathname (microcode-tables-filename))))))
- unspecific)
-
-(define-primitives
- (microcode-library-path 0)
- (microcode-tables-filename 0))
+(define host-types)
+(define local-host)
-(define library-directory-path)
+(define-structure (host-type
+ (constructor %make-host-type)
+ (conc-name host-type/))
+ (name false read-only true)
+ (operation/parse-namestring false read-only true)
+ (operation/pathname->namestring false read-only true)
+ (operation/make-pathname false read-only true)
+ (operation/pathname-wild? false read-only true)
+ (operation/pathname-as-directory false read-only true)
+ (operation/directory-pathname-as-file false read-only true)
+ (operation/pathname->truename false read-only true)
+ (operation/user-homedir-pathname false read-only true)
+ (operation/init-file-pathname false read-only true))
+
+(define (make-host-type name . operations)
+ (let ((type (apply %make-host-type name operations)))
+ (let loop ((types host-types))
+ (cond ((null? types)
+ (set! host-types (cons type host-types)))
+ ((eq? name (host-type/name (car types)))
+ (set-car! types type))
+ (else
+ (loop (cdr types)))))
+ type))
+
+(define-structure (host
+ (named (string->symbol "#[(runtime pathname)host]"))
+ (constructor %make-host)
+ (conc-name host/))
+ (type-name false read-only true)
+ (name false read-only true))
+
+(define (make-host type name)
+ (%make-host (host-type/name type) name))
+
+(define (host/type host)
+ (let ((name (host/type-name host)))
+ (let loop ((types host-types))
+ (cond ((null? types) (error "Unknown host type:" host))
+ ((eq? name (host/type-name (car types))) (car types))
+ (else (loop (cdr types)))))))
+
+(define (guarantee-host host operation)
+ (if (not (host? host))
+ (error:wrong-type-argument host "host" operation))
+ host)
+
+(define (host-operation/parse-namestring host)
+ (host-type/operation/parse-namestring (host/type host)))
+
+(define (host-operation/pathname->namestring host)
+ (host-type/operation/pathname->namestring (host/type host)))
+
+(define (host-operation/make-pathname host)
+ (host-type/operation/make-pathname (host/type host)))
+
+(define (host-operation/pathname-wild? host)
+ (host-type/operation/pathname-wild? (host/type host)))
+
+(define (host-operation/pathname-as-directory host)
+ (host-type/operation/pathname-as-directory (host/type host)))
+
+(define (host-operation/directory-pathname-as-file host)
+ (host-type/operation/directory-pathname-as-file (host/type host)))
+
+(define (host-operation/pathname->truename host)
+ (host-type/operation/pathname->truename (host/type host)))
+
+(define (host-operation/user-homedir-pathname host)
+ (host-type/operation/user-homedir-pathname (host/type host)))
+
+(define (host-operation/init-file-pathname host)
+ (host-type/operation/init-file-pathname (host/type host)))
+\f
+;;;; File System Stuff
+
+(define (->truename pathname)
+ (let ((pathname (merge-pathnames pathname)))
+ ((host-operation/pathname->truename (%pathname-host pathname)) pathname)))
+
+(define (user-homedir-pathname #!optional host)
+ (let ((host
+ (if (and (not (default-object? host)) host)
+ (guarantee-host host 'USER-HOMEDIR-PATHNAME)
+ local-host)))
+ ((host-operation/user-homedir-pathname host) host)))
+
+(define (init-file-pathname #!optional host)
+ (let ((host
+ (if (and (not (default-object? host)) host)
+ (guarantee-host host 'INIT-FILE-PATHNAME)
+ local-host)))
+ ((host-operation/init-file-pathname host) host)))
(define (system-library-pathname pathname)
- (if (and (pathname-absolute? pathname)
- (pathname->input-truename pathname))
- pathname
- (let loop ((directories library-directory-path))
- (if (null? directories)
- (system-library-pathname
- (->pathname
- (error:file-operation pathname
- "find"
- "file"
- "no such file in system library path"
- system-library-pathname
- (list pathname))))
- (or (pathname->input-truename
- (merge-pathnames pathname (car directories)))
- (loop (cdr directories)))))))
+ (let ((try-directory
+ (lambda (directory)
+ (let ((pathname (merge-pathnames pathname directory)))
+ (and (file-exists? pathname)
+ pathname))))
+ (loser
+ (lambda ()
+ (system-library-pathname
+ (->pathname
+ (error:file-operation pathname
+ "find"
+ "file"
+ "no such file in system library path"
+ system-library-pathname
+ (list pathname)))))))
+ (if (pathname-absolute? pathname)
+ (if (file-exists? pathname) pathname (loser))
+ (let loop ((directories library-directory-path))
+ (if (null? directories)
+ (loser)
+ (or (try-directory (car directories))
+ (loop (cdr directories))))))))
(define (system-library-directory-pathname pathname)
(if (not pathname)
(let ((pathname (merge-pathnames pathname (car directories))))
(if (file-directory? pathname)
(pathname-as-directory pathname)
- (loop (cdr directories))))))))
\ No newline at end of file
+ (loop (cdr directories))))))))
+
+(define library-directory-path)
+
+(define (initialize-package!)
+ (reset-package!)
+ (add-event-receiver! event:after-restore reset-package!))
+
+(define (reset-package!)
+ (set! host-types '())
+ (set! local-host (make-host (make-unix-host-type) false))
+ (set! *default-pathname-defaults*
+ (make-pathname local-host false false false false false))
+ (set! library-directory-path
+ (map pathname-as-directory
+ (vector->list ((ucode-primitive microcode-library-path 0)))))
+ unspecific)
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.124 1991/10/29 14:32:03 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.125 1991/11/04 20:29:45 cph Exp $
Copyright (c) 1988-91 Massachusetts Institute of Technology
;;((quick-sort) "qsort")
(else))
(file-case os-type
- ((unix) "unxpth" "unxprm")
- ;;((vms) "vmspth")
- ;;(else "unkpth")
+ ((unix) "unxprm")
(else)))
(define-package (package)
(else))
(parent ())
(export ()
- directory-read)
- (initialization (initialize-package!)))
+ directory-read))
(define-package (runtime emacs-interface)
(files "emacs")
(parent ())
(export ()
open-input-file)
- (export (runtime load)
- open-input-file/internal)
(initialization (initialize-package!)))
(define-package (runtime file-output)
(files "pathnm")
(parent ())
(export ()
+ *default-pathname-defaults*
+ ->namestring
->pathname
- canonicalize-input-filename
- canonicalize-input-pathname
- canonicalize-output-filename
- canonicalize-output-pathname
- canonicalize-overwrite-filename
- canonicalize-overwrite-pathname
- file-exists?
- init-file-truename
+ ->truename
+ directory-namestring
+ directory-pathname
+ directory-pathname-as-file
+ enough-namestring
+ enough-pathname
+ file-namestring
+ file-pathname
+ host-namestring
+ host?
+ init-file-pathname
+ local-host
make-pathname
merge-pathnames
- pathname->absolute-pathname
- pathname->input-truename
- pathname->output-truename
- pathname->string
+ parse-namestring
pathname-absolute?
- pathname-components
- pathname-copy
+ pathname-as-directory
pathname-default
pathname-default-device
pathname-default-directory
- pathname-default-host
pathname-default-name
pathname-default-type
pathname-default-version
pathname-device
pathname-directory
- pathname-directory-path
- pathname-directory-string
pathname-host
pathname-name
- pathname-name-path
- pathname-name-string
pathname-new-device
pathname-new-directory
- pathname-new-host
pathname-new-name
pathname-new-type
pathname-new-version
- pathname-relative?
pathname-type
pathname-version
+ pathname-wild?
+ pathname=?
pathname?
- string->pathname
system-library-directory-pathname
- system-library-pathname)
- (export (runtime pathname-parser)
- simplify-directory)
+ system-library-pathname
+ user-homedir-pathname)
(initialization (initialize-package!)))
-(define-package (runtime pathname-parser)
- (file-case os-type
- ((unix) "unxpar")
- ;;((vms) "vmspar")
- ;;(else "unkpar")
- (else))
- (parent (runtime pathname))
- (export ()
- pathname-as-directory)
- (export (runtime pathname)
- parse-pathname))
-
-(define-package (runtime pathname-unparser)
- (file-case os-type
- ((unix) "unxunp")
- ;;((vms) "vmsunp")
- ;;(else "unkunp")
- (else))
+(define-package (runtime pathname unix)
+ (files "unxpth")
(parent (runtime pathname))
(export (runtime pathname)
- pathname-unparse
- pathname-unparse-name))
+ make-unix-host-type))
(define-package (runtime population)
(files "poplat")
channel-write-string-block
channel?
close-all-open-files
- copy-file
file-length
file-open-append-channel
file-open-input-channel
starbase-graphics-device-type)
(initialization (initialize-package!)))
-(define-package (runtime old-starbase-graphics)
- (file-case options
- ((load) "Sgraph")
- (else))
- (parent ())
- (export ()
- clear-graphics
- clear-point
- draw-line-to
- draw-point
- graphics-available?
- graphics-text
- init-graphics
- position-pen
- print-graphics
- print-graphics-inverse
- set-graphics-drawing-mode
- set-graphics-line-style
- with-graphics-drawing-mode
- with-graphics-line-style
- x-graphics-available?
- x-graphics-initialize)
- (initialization (initialize-package!)))
-
(define-package (runtime state-space)
(files "wind")
(parent ())
(initialization (initialize-package!)))
(define-package (runtime working-directory)
- (file-case os-type
- ((unix) "unxcwd")
- ;;((vms) "vmscwd")
- ;;(else "unkcwd")
- (else))
(files "wrkdir")
(parent ())
(export ()
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/savres.scm,v 14.21 1991/07/12 18:00:42 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/savres.scm,v 14.22 1991/11/04 20:29:54 cph Exp $
Copyright (c) 1988-91 Massachusetts Institute of Technology
filename
(lambda ()
(set! time-world-saved time)
- (if (string? identify)
- unspecific
- false))
+ (if (string? identify) unspecific false))
(lambda ()
(set! time-world-saved time)
(reset-gc-after-restore!)
(else
(event-distributor/invoke! event:after-restart)
true)))))))
-\f
+
(define (disk-save/kernel filename after-suspend after-restore)
((without-interrupts
(lambda ()
(lambda (continuation)
(let ((fixed-objects (get-fixed-objects-vector))
(dynamic-state (current-dynamic-state))
- (filename (canonicalize-output-filename filename)))
+ (filename (->namestring (merge-pathnames filename))))
(fluid-let ()
((ucode-primitive call-with-current-continuation)
(lambda (restart)
(gc-flip)
- (do ()
- (((ucode-primitive dump-band) restart filename))
+ (do () (((ucode-primitive dump-band) restart filename))
(with-simple-restart 'RETRY "Try again."
(lambda ()
(error "Disk save failed:" filename))))
(continuation after-suspend)))
((ucode-primitive set-fixed-objects-vector!) fixed-objects)
(set-current-dynamic-state! dynamic-state)
- ;; This instruction is a noop, so I flushed it -- cph.
- ;; (enable-interrupts! interrupt-mask/none)
(read-microcode-tables!)
after-restore))))))))
(if ((ucode-primitive dump-world 1) filename)
after-restore
after-suspend)))))
-
+\f
(define (disk-restore #!optional filename)
;; Force order of events -- no need to run event:before-exit if
;; there's an error here.
(let ((filename
- (pathname->string
+ (->namestring
(if (default-object? filename)
- (canonicalize-input-pathname
+ (merge-pathnames
(let ((filename ((ucode-primitive reload-band-name))))
(if (not filename)
(error "no default band name available"))
filename))
- (let ((pathname (->pathname filename)))
- (or (pathname->input-truename pathname)
+ (let ((pathname (->pathname filename))
+ (try
+ (lambda (pathname)
+ (let ((pathname (merge-pathnames pathname)))
+ (and (file-exists? pathname)
+ pathname)))))
+ (or (try pathname)
(if (pathname-type pathname)
(system-library-pathname pathname)
(let ((pathname (pathname-new-type pathname "com")))
- (or (pathname->input-truename pathname)
+ (or (try pathname)
(system-library-pathname pathname))))))))))
(event-distributor/invoke! event:before-exit)
((ucode-primitive load-band) filename)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/sfile.scm,v 14.7 1991/10/29 14:32:11 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/sfile.scm,v 14.8 1991/11/04 20:29:58 cph Exp $
Copyright (c) 1988-91 Massachusetts Institute of Technology
;;; package: ()
(declare (usual-integrations))
+\f
+(define (file-exists? filename)
+ ((ucode-primitive file-exists? 1) (->namestring (merge-pathnames filename))))
(define (rename-file from to)
- ((ucode-primitive file-rename) (canonicalize-input-filename from)
- (canonicalize-output-filename to)))
+ ((ucode-primitive file-rename) (->namestring (merge-pathnames from))
+ (->namestring (merge-pathnames to))))
(define (delete-file filename)
- (let ((truename (pathname->input-truename (->pathname filename))))
- (and truename
- (begin
- ((ucode-primitive file-remove) (pathname->string truename))
- true))))
\ No newline at end of file
+ ((ucode-primitive file-remove) (->namestring (merge-pathnames filename))))
+
+(define (copy-file from to)
+ (let ((input-filename (->namestring (merge-pathnames from)))
+ (output-filename (->namestring (merge-pathnames to))))
+ (let ((input-channel false)
+ (output-channel false))
+ (dynamic-wind
+ (lambda ()
+ (set! input-channel (file-open-input-channel input-filename))
+ (set! output-channel
+ (begin
+ ((ucode-primitive file-remove-link 1) output-filename)
+ (file-open-output-channel output-filename)))
+ unspecific)
+ (lambda ()
+ (let ((source-length (file-length input-channel))
+ (buffer-length 8192))
+ (if (zero? source-length)
+ 0
+ (let* ((buffer (make-string buffer-length))
+ (transfer
+ (lambda (length)
+ (let ((n-read
+ (channel-read-block input-channel
+ buffer
+ 0
+ length)))
+ (if (positive? n-read)
+ (channel-write-block output-channel
+ buffer
+ 0
+ n-read))
+ n-read))))
+ (let loop ((source-length source-length))
+ (if (< source-length buffer-length)
+ (transfer source-length)
+ (let ((n-read (transfer buffer-length)))
+ (if (= n-read buffer-length)
+ (+ (loop (- source-length buffer-length))
+ buffer-length)
+ n-read))))))))
+ (lambda ()
+ (if output-channel (channel-close output-channel))
+ (if input-channel (channel-close input-channel)))))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/starbase.scm,v 1.4 1990/01/22 23:36:36 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/starbase.scm,v 1.5 1991/11/04 20:30:02 cph Exp $
-Copyright (c) 1989, 1990 Massachusetts Institute of Technology
+Copyright (c) 1989-91 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(define (operation/write-image-file device filename invert?)
(starbase-write-image-file (starbase-device/descriptor device)
- (canonicalize-output-filename filename)
+ (->namestring (merge-pathnames filename))
invert?))
(define (operation/text-height device)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/system.scm,v 14.7 1989/10/26 06:47:10 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/system.scm,v 14.8 1991/11/04 20:30:06 cph Exp $
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988-91 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(prompt-for-confirmation "Load compiled")
compiled?))))
(set-system/files! system
- (map (lambda (file) (pathname->string (car file)))
- files))
+ (map (lambda (file) (->namestring (car file))) files))
(for-each (lambda (file scode)
(newline) (write-string "Eval ")
- (write (pathname->string (car file)))
+ (write (->namestring (car file)))
(scode-eval scode (cdr file)))
files
(let loop ((files (map car files)))
(receiver (cons (car list) head) tail)))))
(define (format-files-list files-lists compiled?)
- (mapcan (lambda (files-list)
- (map (lambda (filename)
- (let ((pathname (->pathname filename)))
- (cons (if (and (not compiled?)
- (equal? "com" (pathname-type pathname)))
- (pathname-new-type pathname "bin")
- pathname)
- (car files-list))))
- (cdr files-list)))
- files-lists))
\ No newline at end of file
+ (append-map! (lambda (files-list)
+ (map (lambda (filename)
+ (let ((pathname (->pathname filename)))
+ (cons (if (and (not compiled?)
+ (equal? "com"
+ (pathname-type pathname)))
+ (pathname-new-type pathname "bin")
+ pathname)
+ (car files-list))))
+ (cdr files-list)))
+ files-lists))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unxdir.scm,v 14.7 1991/07/19 04:42:26 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unxdir.scm,v 14.8 1991/11/04 20:30:16 cph Exp $
Copyright (c) 1988-91 Massachusetts Institute of Technology
(define (directory-read-nosort pattern)
(let ((pattern
- (let ((pattern (pathname->absolute-pathname (->pathname pattern))))
- (if (or (pathname-name pattern)
- (pathname-type pattern)
- (pathname-version pattern))
- pattern
- (make-pathname (pathname-host pattern)
- (pathname-device pattern)
- (pathname-directory pattern)
- 'WILD 'WILD 'WILD)))))
- (let ((directory-path (pathname-directory-path pattern)))
- (let ((pathnames (generate-directory-pathnames directory-path)))
- (cond ((and (eq? 'WILD (pathname-name pattern))
- (eq? 'WILD (pathname-type pattern))
- (eq? 'WILD (pathname-version pattern)))
- pathnames)
- ((not (eq? (pathname-version pattern) 'NEWEST))
- (list-transform-positive pathnames
- (lambda (instance)
- (and (match-component (pathname-name pattern)
- (pathname-name instance))
- (match-component (pathname-type pattern)
- (pathname-type instance))
- (match-component (pathname-version pattern)
- (pathname-version instance))))))
- (else
- (extract-greatest-versions
- (list-transform-positive pathnames
- (lambda (instance)
- (and (match-component (pathname-name pattern)
- (pathname-name instance))
- (match-component (pathname-type pattern)
- (pathname-type instance))))))))))))
+ (let ((pattern (merge-pathnames pattern)))
+ (let ((name (pathname-name pattern))
+ (type (pathname-type pattern)))
+ (if (or name type)
+ pattern
+ (make-pathname (pathname-host pattern)
+ (pathname-device pattern)
+ (pathname-directory pattern)
+ 'WILD
+ 'WILD
+ (pathname-version pattern)))))))
+ (let ((directory-path (directory-pathname pattern)))
+ (map (lambda (pathname)
+ (merge-pathnames pathname directory-path))
+ (let ((pathnames
+ (map ->pathname
+ (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)
(dynamic-wind
(lambda () unspecific)
(lambda ()
- (let loop
- ((name
- ((ucode-primitive open-directory 1) (pathname->string pathname)))
- (result '()))
- (if name
- (loop ((ucode-primitive directory-read 0))
- (cons (merge-pathnames (string->pathname name) pathname)
- result))
- result)))
+ ((ucode-primitive directory-open-noread 1) (->namestring pathname))
+ (let loop ((result '()))
+ (let ((name ((ucode-primitive directory-read 0))))
+ (if name
+ (loop (cons name result))
+ result))))
(ucode-primitive directory-close 0)))
-(define (extract-greatest-versions pathnames)
- (let ((name-alist '()))
- (for-each (lambda (pathname)
- (let ((name (pathname-name pathname))
- (type (pathname-type pathname)))
- (let ((name-entry (associate-on-name name name-alist)))
- (if (not name-entry)
- (set! name-alist
- (cons (list name (cons type pathname))
- name-alist))
- (let ((type-entry
- (associate-on-type type (cdr name-entry))))
- (cond ((not type-entry)
- (set-cdr! name-entry
- (cons (cons type pathname)
- (cdr name-entry))))
- ((version<? (pathname-version (cdr type-entry))
- (pathname-version pathname))
- (set-cdr! type-entry pathname))))))))
- pathnames)
- (mapcan (lambda (name-entry)
- (map cdr (cdr name-entry)))
- name-alist)))
-\f
(define (match-component pattern instance)
(or (eq? pattern 'WILD)
(equal? pattern instance)))
(define (pathname<? x y)
- (or (string<? (pathname-name x) (pathname-name y))
- (and (string=? (pathname-name x) (pathname-name y))
- (or (type<? (pathname-type x) (pathname-type y))
- (and (equal? (pathname-type x) (pathname-type y))
- (version<? (pathname-version x) (pathname-version y)))))))
-
-(define (initialize-package!)
- (set! associate-on-name (association-procedure string=? car))
- (set! type<? (component<? string<?))
- (set! version<? (component<? <)))
-
-(define associate-on-name)
-
-(define-integrable (associate-on-type type types)
- (assoc type types))
-
-(define ((component<? <) x y)
- (cond ((not x) y)
- ((eq? 'UNSPECIFIC x) (and y (not (eq? 'UNSPECIFIC y))))
- (else (and y (not (eq? 'UNSPECIFIC y)) (< x y)))))
-
-(define type<?)
-(define version<?)
\ No newline at end of file
+ (or (component<? (pathname-name x) (pathname-name y))
+ (and (equal? (pathname-name x) (pathname-name y))
+ (component<? (pathname-type x) (pathname-type y)))))
+
+(define (component<? x y)
+ (and y
+ (or (not x)
+ (and (string? y)
+ (or (not (string? x))
+ (string<? x y))))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unxprm.scm,v 1.15 1991/10/29 14:32:22 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unxprm.scm,v 1.16 1991/11/04 20:30:21 cph Exp $
Copyright (c) 1988-91 Massachusetts Institute of Technology
\f
(define (file-directory? filename)
((ucode-primitive file-directory?)
- (pathname->string (pathname->absolute-pathname (->pathname filename)))))
+ (->namestring (merge-pathnames filename))))
(define (file-symbolic-link? filename)
- ((ucode-primitive file-symlink?)
- (pathname->string (pathname->absolute-pathname (->pathname filename)))))
+ ((ucode-primitive file-symlink?) (->namestring (merge-pathnames filename))))
(define (file-modes filename)
- ((ucode-primitive file-modes)
- (pathname->string (pathname->absolute-pathname (->pathname filename)))))
+ ((ucode-primitive file-modes) (->namestring (merge-pathnames filename))))
(define-integrable (set-file-modes! filename modes)
- ((ucode-primitive set-file-modes!) (canonicalize-input-filename filename)
+ ((ucode-primitive set-file-modes!) (->namestring (merge-pathnames filename))
modes))
-(define (unix/file-access filename amode)
- ((ucode-primitive file-access)
- (pathname->string (pathname->absolute-pathname (->pathname filename)))
- amode))
+(define (file-access filename amode)
+ ((ucode-primitive file-access) (->namestring (merge-pathnames filename))
+ amode))
+
+;; upwards compatability
+(define unix/file-access file-access)
+
+(define (file-readable? filename)
+ (file-access filename 4))
(define (file-writable? filename)
- (let ((pathname (pathname->absolute-pathname (->pathname filename))))
- (let ((filename (pathname->string pathname)))
+ (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)
- (pathname-directory-string pathname)
- 2))))))
+ ((ucode-primitive file-access) (directory-namestring pathname)
+ 2))))))
-(define (file-attributes filename)
+(define (file-attributes-direct filename)
((ucode-primitive file-attributes)
- (pathname->string (pathname->absolute-pathname (->pathname filename)))))
+ (->namestring (merge-pathnames filename))))
(define (file-attributes-indirect filename)
((ucode-primitive file-attributes-indirect)
- (pathname->string (pathname->absolute-pathname (->pathname filename)))))
+ (->namestring (merge-pathnames filename))))
+
+(define file-attributes
+ file-attributes-direct)
(define-structure (file-attributes
(type vector)
(mode-string false read-only true)
(inode-number false read-only true))
-(define (file-modification-time filename)
+(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)
- (pathname->string (pathname->absolute-pathname (->pathname filename)))))
+ (->namestring (merge-pathnames filename))))
+
+(define file-modification-time
+ file-modification-time-indirect)
\f
(define-integrable get-environment-variable
(ucode-primitive get-environment-variable))
(ucode-primitive system))
(define (file-touch filename)
- (let ((filename
- (pathname->string
- (let ((pathname (pathname->absolute-pathname (->pathname filename))))
- (if (let ((version (pathname-version pathname)))
- (or (not version)
- (exact-integer? version)))
- pathname
- (or (pathname->input-truename pathname)
- (pathname-new-version pathname false)))))))
- (let ((result ((ucode-primitive file-touch) filename)))
- (if (string? result)
- (error:file-operation filename
- "touch"
- "file"
- result
- (ucode-primitive file-touch)
- (list filename)))
- result)))
+ ((ucode-primitive file-touch) (->namestring (merge-pathnames filename))))
(define (make-directory name)
((ucode-primitive directory-make)
- (pathname->string
- (pathname-as-directory
- (pathname->absolute-pathname (->pathname name))))))
\ No newline at end of file
+ (->namestring (pathname-as-directory (merge-pathnames name)))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unxpth.scm,v 14.6 1991/05/09 03:22:03 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unxpth.scm,v 14.7 1991/11/04 20:30:27 cph Exp $
Copyright (c) 1988-91 Massachusetts Institute of Technology
promotional, or sales literature without prior written consent from
MIT in each case. |#
-;;;; Miscellaneous Pathnames -- Unix
-;;; package: ()
+;;;; Unix Pathnames
+;;; package: (runtime pathname unix)
(declare (usual-integrations))
-(define (symbol->pathname symbol)
- (string->pathname (string-downcase (symbol->string symbol))))
+(define (make-unix-host-type)
+ (make-host-type 'UNIX
+ unix/parse-namestring
+ unix/pathname->namestring
+ unix/make-pathname
+ unix/pathname-wild?
+ unix/pathname-as-directory
+ unix/directory-pathname-as-file
+ unix/pathname->truename
+ unix/user-homedir-pathname
+ unix/init-file-pathname))
+\f
+;;;; Pathname Parser
-(define (home-directory-pathname)
- (pathname-as-directory (string->pathname (unix/current-home-directory))))
+(define (unix/parse-namestring string host)
+ (let ((end (string-length string)))
+ (let ((components
+ (let ((components (substring-components string 0 end #\/)))
+ (append (expand-directory-prefixes (car components))
+ (cdr components)))))
+ (parse-name (car (last-pair components))
+ (lambda (name type)
+ (%make-pathname host
+ 'UNSPECIFIC
+ (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 (init-file-pathname)
- (string->pathname ".scheme.init"))
+(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
+ component))
-(define pathname-newest
- false)
\ No newline at end of file
+(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 #\/))))
+ ((#\~)
+ (let ((user-name (substring string 1 (string-length string))))
+ (string-components
+ (if (string-null? user-name)
+ (unix/current-home-directory)
+ (unix/user-home-directory user-name))
+ #\/)))
+ (else (list string)))))
+
+(define (string-components string delimiter)
+ (substring-components string 0 (string-length string) delimiter))
+
+(define (substring-components string start end delimiter)
+ (let loop ((start start))
+ (let ((index (substring-find-next-char string start end delimiter)))
+ (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)))
+\f
+;;;; Pathname Unparser
+
+(define (unix/pathname->namestring pathname)
+ (string-append (unparse-directory (%pathname-directory pathname))
+ (unparse-name (%pathname-name pathname)
+ (%pathname-type pathname))))
+
+(define (unparse-directory directory)
+ (cond ((not directory)
+ "")
+ ((pair? directory)
+ (string-append
+ (if (eq? (car directory) 'ABSOLUTE) "/" "")
+ (let loop ((directory (cdr directory)))
+ (if (null? directory)
+ ""
+ (string-append (unparse-directory-component (car directory))
+ "/"
+ (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))))
+\f
+;;;; Pathname Constructors
+
+(define (unix/make-pathname host device directory name type version)
+ (%make-pathname
+ host
+ (if (memq device '(#F UNSPECIFIC))
+ 'UNSPECIFIC
+ (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 (unix/pathname-as-directory pathname)
+ (let ((name (%pathname-name pathname))
+ (type (%pathname-type pathname)))
+ (if (or name type)
+ (%make-pathname
+ (%pathname-host pathname)
+ 'UNSPECIFIC
+ (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 (unix/directory-pathname-as-file pathname)
+ (let ((directory (%pathname-directory pathname)))
+ (if (not (and (pair? directory) (pair? (cdr directory))))
+ (error:bad-range-argument pathname 'DIRECTORY-PATHNAME-AS-FILE))
+ (parse-name (unparse-directory-component (car (last-pair directory)))
+ (lambda (name type)
+ (%make-pathname (%pathname-host pathname)
+ 'UNSPECIFIC
+ (simplify-directory (except-last-pair directory))
+ name
+ type
+ 'UNSPECIFIC)))))
+\f
+;;;; Miscellaneous
+
+(define (unix/pathname-wild? pathname)
+ (or (eq? 'WILD (%pathname-name pathname))
+ (eq? 'WILD (%pathname-type pathname))))
+
+(define (unix/pathname->truename pathname)
+ (if (eq? true (file-exists? pathname))
+ pathname
+ (unix/pathname->truename
+ (error:file-operation pathname "find" "file" "file does not exist"
+ unix/pathname->truename (list pathname)))))
+
+(define (unix/user-homedir-pathname host)
+ (and (eq? host local-host)
+ (pathname-as-directory (unix/current-home-directory))))
+
+(define (unix/init-file-pathname host)
+ (let ((pathname
+ (merge-pathnames ".scheme.init" (unix/user-homedir-pathname host))))
+ (and (file-exists? pathname)
+ pathname)))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.140 1991/09/18 20:05:55 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.141 1991/11/04 20:30:34 cph Exp $
Copyright (c) 1988-91 Massachusetts Institute of Technology
'()))
(add-system! microcode-system)
(add-event-receiver! event:after-restore snarf-microcode-version!)
- (add-identification! "Runtime" 14 140))
+ (add-identification! "Runtime" 14 141))
(define microcode-system)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/wrkdir.scm,v 14.2 1988/06/13 12:00:56 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/wrkdir.scm,v 14.3 1991/11/04 20:30:42 cph Exp $
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988-91 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(declare (usual-integrations))
\f
+(define (initialize-package!)
+ (reset!)
+ (add-event-receiver! event:after-restore reset!))
+
+(define (reset!)
+ (let ((pathname
+ (simplify-directory
+ (pathname-as-directory
+ ((ucode-primitive working-directory-pathname))))))
+ (set! *working-directory-pathname* pathname)
+ (set! *default-pathname-defaults* pathname))
+ (set! hook/set-working-directory-pathname!
+ default/set-working-directory-pathname!)
+ unspecific)
+
+(define *working-directory-pathname*)
+
+(define (working-directory-pathname)
+ *working-directory-pathname*)
+
+(define (set-working-directory-pathname! name)
+ (let ((pathname
+ (pathname-as-directory
+ (merge-pathnames name *working-directory-pathname*))))
+ (if (not (file-directory? pathname))
+ (error "Not a valid directory:" pathname))
+ (let ((pathname (simplify-directory pathname)))
+ (if (eq? *default-pathname-defaults* *working-directory-pathname*)
+ (set! *default-pathname-defaults* pathname))
+ (set! *working-directory-pathname* pathname)
+ ((ucode-primitive set-working-directory-pathname! 1)
+ (->namestring pathname))
+ (hook/set-working-directory-pathname! pathname)
+ pathname)))
+
+(define hook/set-working-directory-pathname!)
+(define (default/set-working-directory-pathname! pathname)
+ pathname
+ false)
+
(define (with-working-directory-pathname name thunk)
(let ((old-pathname))
(dynamic-wind (lambda ()
(set! name (working-directory-pathname))
(set-working-directory-pathname! old-pathname)))))
-(define (hook/set-working-directory-pathname! pathname)
- pathname
- false)
\ No newline at end of file
+(define (simplify-directory 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
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/global.scm,v 14.32 1991/09/02 03:55:52 sybok Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/global.scm,v 14.33 1991/11/04 20:29:00 cph Exp $
Copyright (c) 1988-91 Massachusetts Institute of Technology
object)
(define (fasdump object filename)
- (let ((filename (canonicalize-output-filename filename))
+ (let ((filename (->namestring (merge-pathnames filename)))
(port (cmdl/output-port (nearest-cmdl))))
(newline port)
(write-string "Dumping " port)
- (write filename port)
+ (write (enough-namestring filename) port)
(if (not ((ucode-primitive primitive-fasdump) object filename false))
- (error "FASDUMP: Object is too large to be dumped" object))
- (write-string " -- done" port))
- unspecific)
+ (error "FASDUMP: Object is too large to be dumped:" object))
+ (write-string " -- done" port)))
\f
(define (undefined-value? object)
;; Note: the unparser takes advantage of the fact that objects
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/infutl.scm,v 1.21 1991/04/15 20:47:29 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/infutl.scm,v 1.22 1991/11/04 20:29:04 cph Exp $
Copyright (c) 1988-91 Massachusetts Institute of Technology
(define (process-binf-filename binf-filename com-pathname)
(and binf-filename
- (pathname->string
+ (->namestring
(rewrite-directory
- (let ((binf-pathname
- (pathname->absolute-pathname
- (->pathname binf-filename))))
+ (let ((binf-pathname (merge-pathnames binf-filename))
+ (com-pathname (merge-pathnames com-pathname)))
(if (and (equal? (pathname-name binf-pathname)
(pathname-name com-pathname))
(not (equal? (pathname-type binf-pathname)
'())
(define (add-directory-rewriting-rule! match replace)
- (let ((match (pathname->absolute-pathname (->pathname match)))
- (replace (pathname->absolute-pathname (->pathname replace))))
+ (let ((match (merge-pathnames match))
+ (replace (merge-pathnames replace)))
(let ((rule
(list-search-positive directory-rewriting-rules
(lambda (rule)
pathname)))
(define (directory-prefix? x y)
- (or (null? y)
- (and (not (null? x))
- (equal? (car x) (car y))
- (directory-prefix? (cdr x) (cdr y)))))
+ (and (pair? x)
+ (pair? y)
+ (eq? (car x) (car y))
+ (let loop ((x (cdr x)) (y (cdr y)))
+ (or (null? y)
+ (and (not (null? x))
+ (equal? (car x) (car y))
+ (loop (cdr x) (cdr y)))))))
\f
(define-integrable (dbg-block/layout-first-offset block)
(let ((layout (dbg-block/layout block)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/load.scm,v 14.29 1991/10/29 14:31:49 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/load.scm,v 14.30 1991/11/04 20:29:20 cph Exp $
Copyright (c) 1988-91 Massachusetts Institute of Technology
(declare (usual-integrations))
\f
(define (initialize-package!)
- (set! hook/process-command-line default/process-command-line)
(set! load-noisily? false)
(set! load/loading? false)
(set! load/suppress-loading-message? false)
(set! load/default-types '("com" "bin" "scm"))
(set! load/default-find-pathname-with-type search-types-in-order)
(set! fasload/default-types '("com" "bin"))
- (add-event-receiver! event:after-restart
- (lambda ()
- (process-command-line))))
+ (set! hook/process-command-line default/process-command-line)
+ (add-event-receiver! event:after-restart process-command-line))
(define load-noisily?)
(define load/loading?)
(define fasload/default-types)
(define (read-file filename)
- (call-with-input-file
- (pathname-default-version (->pathname filename) 'NEWEST)
+ (call-with-input-file (pathname-default-version filename 'NEWEST)
(lambda (port)
(stream->list (read-stream port)))))
(define (fasload filename #!optional suppress-loading-message?)
- (fasload/internal
- (find-true-pathname (->pathname filename) fasload/default-types)
- (if (default-object? suppress-loading-message?)
- load/suppress-loading-message?
- suppress-loading-message?)))
+ (fasload/internal (find-pathname filename fasload/default-types)
+ (if (default-object? suppress-loading-message?)
+ load/suppress-loading-message?
+ suppress-loading-message?)))
-(define (fasload/internal true-pathname suppress-loading-message?)
+(define (fasload/internal pathname suppress-loading-message?)
(let ((value
- (let ((true-filename (pathname->string true-pathname)))
- (loading-message suppress-loading-message? true-filename
- (lambda ()
- ((ucode-primitive binary-fasload) true-filename))))))
- (fasload/update-debugging-info! value true-pathname)
+ (loading-message suppress-loading-message? pathname
+ (lambda ()
+ ((ucode-primitive binary-fasload) (->namestring pathname))))))
+ (fasload/update-debugging-info! value pathname)
value))
(define (load-noisily filename #!optional environment syntax-table purify?)
(if (default-object? purify?) default-object purify?))))
(define (load-init-file)
- (let ((truename (init-file-truename)))
- (if truename
- (load truename user-initial-environment)))
+ (let ((pathname (init-file-pathname)))
+ (if pathname
+ (load pathname user-initial-environment)))
unspecific)
-(define (loading-message suppress-loading-message? true-filename do-it)
+(define (loading-message suppress-loading-message? pathname do-it)
(if suppress-loading-message?
(do-it)
(let ((port (cmdl/output-port (nearest-cmdl))))
(newline port)
(write-string "Loading " port)
- (write true-filename port)
+ (write (enough-namestring pathname) port)
(let ((value (do-it)))
(write-string " -- done" port)
value))))
(let ((kernel
(lambda (filename last-file?)
(let ((value
- (let ((pathname (->pathname filename)))
- (load/internal
- pathname
- (find-true-pathname pathname
- load/default-types)
- environment
- syntax-table
- purify?
- load-noisily?))))
+ (load/internal
+ (find-pathname filename load/default-types)
+ environment
+ syntax-table
+ purify?
+ load-noisily?)))
(cond (last-file? value)
(load-noisily? (write-line value)))))))
(let ((value
(define default-object
"default-object")
-
+\f
(define (load-latest . args)
(fluid-let ((load/default-find-pathname-with-type find-latest-file))
(apply load args)))
(define (fasload-latest . args)
(fluid-let ((load/default-find-pathname-with-type find-latest-file))
(apply fasload args)))
-\f
-(define (find-true-pathname pathname default-types)
- (or (pathname->input-truename pathname)
- (let ((pathname (pathname-default-version pathname 'NEWEST)))
- (if (pathname-type pathname)
- (pathname->input-truename pathname)
- (load/default-find-pathname-with-type pathname default-types)))
- (find-true-pathname
- (->pathname
- (error:file-operation pathname
- "find"
- "file"
- "file does not exist"
- find-true-pathname
- (list pathname default-types)))
- default-types)))
+
+(define (find-pathname filename default-types)
+ (let ((pathname (merge-pathnames filename)))
+ (if (file-exists? pathname)
+ pathname
+ (or (and (not (pathname-type pathname))
+ (load/default-find-pathname-with-type pathname default-types))
+ (find-pathname
+ (error:file-operation filename
+ "find"
+ "file"
+ "file does not exist"
+ find-pathname
+ (list filename default-types))
+ default-types)))))
(define (search-types-in-order pathname default-types)
(let loop ((types default-types))
(and (not (null? types))
- (or (pathname->input-truename
- (pathname-new-type pathname (car types)))
- (loop (cdr types))))))
+ (let ((pathname (pathname-new-type pathname (car types))))
+ (if (file-exists? pathname)
+ pathname
+ (loop (cdr types)))))))
(define (find-latest-file pathname default-types)
(let loop
((types default-types)
(latest-pathname false)
- (latest-modification-time 0))
+ (latest-time 0))
(if (not (pair? types))
latest-pathname
- (let ((truename
- (pathname->input-truename
- (pathname-new-type pathname (car types))))
+ (let ((pathname (pathname-new-type pathname (car types)))
(skip
(lambda ()
- (loop (cdr types) latest-pathname latest-modification-time))))
- (if (not truename)
- (skip)
- (let ((modification-time (file-modification-time truename)))
- (if (> modification-time latest-modification-time)
- (loop (cdr types) truename modification-time)
- (skip))))))))
+ (loop (cdr types) latest-pathname latest-time))))
+ (let ((time (file-modification-time-indirect pathname)))
+ (if (and time (> time latest-time))
+ (loop (cdr types) pathname time)
+ (skip)))))))
\f
-(define (load/internal pathname true-pathname environment syntax-table
- purify? load-noisily?)
- (let* ((port (open-input-file/internal pathname true-pathname))
+(define (load/internal pathname environment syntax-table purify? load-noisily?)
+ (let* ((port (open-input-file pathname))
(fasl-marker (peek-char port)))
(if (and (not (eof-object? fasl-marker))
(= 250 (char->ascii fasl-marker)))
(close-input-port port)
(extended-scode-eval
(let ((scode
- (fasload/internal true-pathname
- load/suppress-loading-message?)))
+ (fasload/internal pathname load/suppress-loading-message?)))
(if purify? (purify (load/purification-root scode)))
scode)
(if (eq? environment default-object)
(write-stream (value-stream)
(lambda (value)
(hook/repl-write (nearest-repl) value)))
- (loading-message load/suppress-loading-message?
- (pathname->string true-pathname)
- (lambda ()
- (write-stream (value-stream)
- (lambda (value)
- value
- false)))))))))
+ (loading-message load/suppress-loading-message? pathname
+ (lambda ()
+ (write-stream (value-stream)
+ (lambda (value) value false)))))))))
(define (load/purification-root scode)
(or (and (comment? scode)
value))
unspecific))
\f
-(define-primitives
- (get-unused-command-line 0))
-
(define (process-command-line)
- (hook/process-command-line
- (and (implemented-primitive-procedure? get-unused-command-line)
- (get-unused-command-line))))
+ (hook/process-command-line ((ucode-primitive get-unused-command-line 0))))
(define hook/process-command-line)
-
(define (default/process-command-line unused-command-line)
(if unused-command-line
(letrec ((unused-command-line-length (vector-length unused-command-line))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/make.scm,v 14.29 1991/05/06 03:19:35 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/make.scm,v 14.30 1991/11/04 20:29:26 cph Exp $
Copyright (c) 1988-91 Massachusetts Institute of Technology
(RUNTIME OUTPUT-PORT)
(RUNTIME PATHNAME)
(RUNTIME WORKING-DIRECTORY)
- (RUNTIME DIRECTORY)
(RUNTIME LOAD)
;; Syntax
(RUNTIME PARSER)
(->environment '(RUNTIME LOAD)))))
(map (lambda (entry)
(let ((object (cdr entry)))
- (fasload/update-debugging-info!
- object
- (pathname->absolute-pathname (->pathname (car entry))))
+ (fasload/update-debugging-info! object (car entry))
(load/purification-root object)))
fasload-purification-queue)))))
(set! fasload-purification-queue)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.124 1991/10/29 14:32:03 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.125 1991/11/04 20:29:45 cph Exp $
Copyright (c) 1988-91 Massachusetts Institute of Technology
;;((quick-sort) "qsort")
(else))
(file-case os-type
- ((unix) "unxpth" "unxprm")
- ;;((vms) "vmspth")
- ;;(else "unkpth")
+ ((unix) "unxprm")
(else)))
(define-package (package)
(else))
(parent ())
(export ()
- directory-read)
- (initialization (initialize-package!)))
+ directory-read))
(define-package (runtime emacs-interface)
(files "emacs")
(parent ())
(export ()
open-input-file)
- (export (runtime load)
- open-input-file/internal)
(initialization (initialize-package!)))
(define-package (runtime file-output)
(files "pathnm")
(parent ())
(export ()
+ *default-pathname-defaults*
+ ->namestring
->pathname
- canonicalize-input-filename
- canonicalize-input-pathname
- canonicalize-output-filename
- canonicalize-output-pathname
- canonicalize-overwrite-filename
- canonicalize-overwrite-pathname
- file-exists?
- init-file-truename
+ ->truename
+ directory-namestring
+ directory-pathname
+ directory-pathname-as-file
+ enough-namestring
+ enough-pathname
+ file-namestring
+ file-pathname
+ host-namestring
+ host?
+ init-file-pathname
+ local-host
make-pathname
merge-pathnames
- pathname->absolute-pathname
- pathname->input-truename
- pathname->output-truename
- pathname->string
+ parse-namestring
pathname-absolute?
- pathname-components
- pathname-copy
+ pathname-as-directory
pathname-default
pathname-default-device
pathname-default-directory
- pathname-default-host
pathname-default-name
pathname-default-type
pathname-default-version
pathname-device
pathname-directory
- pathname-directory-path
- pathname-directory-string
pathname-host
pathname-name
- pathname-name-path
- pathname-name-string
pathname-new-device
pathname-new-directory
- pathname-new-host
pathname-new-name
pathname-new-type
pathname-new-version
- pathname-relative?
pathname-type
pathname-version
+ pathname-wild?
+ pathname=?
pathname?
- string->pathname
system-library-directory-pathname
- system-library-pathname)
- (export (runtime pathname-parser)
- simplify-directory)
+ system-library-pathname
+ user-homedir-pathname)
(initialization (initialize-package!)))
-(define-package (runtime pathname-parser)
- (file-case os-type
- ((unix) "unxpar")
- ;;((vms) "vmspar")
- ;;(else "unkpar")
- (else))
- (parent (runtime pathname))
- (export ()
- pathname-as-directory)
- (export (runtime pathname)
- parse-pathname))
-
-(define-package (runtime pathname-unparser)
- (file-case os-type
- ((unix) "unxunp")
- ;;((vms) "vmsunp")
- ;;(else "unkunp")
- (else))
+(define-package (runtime pathname unix)
+ (files "unxpth")
(parent (runtime pathname))
(export (runtime pathname)
- pathname-unparse
- pathname-unparse-name))
+ make-unix-host-type))
(define-package (runtime population)
(files "poplat")
channel-write-string-block
channel?
close-all-open-files
- copy-file
file-length
file-open-append-channel
file-open-input-channel
starbase-graphics-device-type)
(initialization (initialize-package!)))
-(define-package (runtime old-starbase-graphics)
- (file-case options
- ((load) "Sgraph")
- (else))
- (parent ())
- (export ()
- clear-graphics
- clear-point
- draw-line-to
- draw-point
- graphics-available?
- graphics-text
- init-graphics
- position-pen
- print-graphics
- print-graphics-inverse
- set-graphics-drawing-mode
- set-graphics-line-style
- with-graphics-drawing-mode
- with-graphics-line-style
- x-graphics-available?
- x-graphics-initialize)
- (initialization (initialize-package!)))
-
(define-package (runtime state-space)
(files "wind")
(parent ())
(initialization (initialize-package!)))
(define-package (runtime working-directory)
- (file-case os-type
- ((unix) "unxcwd")
- ;;((vms) "vmscwd")
- ;;(else "unkcwd")
- (else))
(files "wrkdir")
(parent ())
(export ()
projects / mit-scheme.git / commitdiff