;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; Spice Lisp is currently incomplete and under active development.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;;
;;; Ugly pathname functions for Spice Lisp.
;;; these functions are part of the standard Spice Lisp environment.
;;;
;;; Written by Jim Large
;;;
;;; **********************************************************************
;;; Pathname structure
;;; *Default-Pathname-defaults* has all values unspecified except for the
;;; host. All pathnames must have a host. "DEFAULT" is the default device
;;; for spice.
(defvar *default-pathname-defaults* ())
(defvar *make-pathname-default-pathname* ())
(defun filesys-init ()
(setq *default-pathname-defaults*
(%make-pathname "Spice" nil nil nil nil nil))
(setq *make-pathname-default-pathname* *default-pathname-defaults*))
;;; The pathname type is defined with a defstruct.
;;; This declaration implicitly defines the common lisp functions
;;; pathname-host, pathname-device ... pathname-version.
(defstruct (pathname
(:conc-name %pathname-)
(:print-function %print-pathname)
(:constructor
%make-pathname (host device directory name type version))
(:predicate pathnamep))
host
device
directory
name
type
version)
(defun %print-pathname (s stream d)
(declare (ignore d))
(format stream "#.(pathname ~S)" (namestring s)))
(defun make-pathname (&key (defaults *make-pathname-default-pathname*)
(host (%pathname-host defaults))
(device (%pathname-device defaults))
(directory (%pathname-directory defaults))
(name (%pathname-name defaults))
(type (%pathname-type defaults))
(version (%pathname-version defaults)))
"Create a pathname from :host, :device, :directory, :name, :type and :version.
If any field is ommitted, it is obtained from :defaults as though by
merge-pathname-defaults."
(when (stringp directory)
(setq directory (%pathname-directory (parse-namestring directory))))
(%make-pathname host device directory name type version))
;;; These can not be done by the accessors because the pathname arg may be
;;; a string or a symbol or etc.
(defun pathname-host (pathname)
"Returns the host slot of pathname. Pathname may be a string, symbol, or stream."
(setq pathname (pathname pathname))
(%pathname-host pathname))
(defun pathname-device (pathname)
"Returns the device slot of pathname. Pathname may be a string, symbol, or stream."
(setq pathname (pathname pathname))
(%pathname-device pathname))
(defun pathname-directory (pathname)
"Returns the directory slot of pathname. Pathname may be a string, symbol, or stream."
(setq pathname (pathname pathname))
(%pathname-directory pathname))
(defun pathname-name (pathname)
"Returns the name slot of pathname. Pathname may be a string, symbol, or stream."
(setq pathname (pathname pathname))
(%pathname-name pathname))
(defun pathname-type (pathname)
"Returns the type slot of pathname. Pathname may be a string, symbol, or stream."
(setq pathname (pathname pathname))
(%pathname-type pathname))
(defun pathname-version (pathname)
"Returns the version slot of pathname. Pathname may be a string, symbol, or stream."
(setq pathname (pathname pathname))
(%pathname-version pathname))
;;;; FSM Compiler
;;; These two macros are called by the code emitted by deflex. They refer
;;; to local vars in the defined function.
(defmacro fsm-scan ()
'(progn
(incf pointer)
(setq current-char (if (>= pointer end)
:end
(char string pointer)))))
(defmacro fsm-emit (flag)
`(progn
(vector-push-extend ,flag *deflex-tokens*)
(vector-push-extend (subseq buffer 0 buffer-index) *deflex-tokens*)
(setq buffer-index 0)))
(defvar *deflex-buffer* (make-string 100))
(defvar *deflex-tokens* (make-array 20 :adjustable t :fill-pointer 0))
(eval-when (compile eval)
(defun deflex-arc (arc)
(do ((set (nth 0 arc))
(new-state (nth 2 arc))
(actions (nth 3 arc) (if (eq (car actions) 'emit)
(cddr actions)
(cdr actions)))
(action-forms
()
(cons (case (car actions)
(accumulate '(progn
(setf (schar buffer buffer-index) current-char)
(incf buffer-index)))
(scan '(fsm-scan))
(emit `(fsm-emit ,(nth 1 actions)))
(t (error "Illegal action ~s" (car actions))))
action-forms)))
((null actions)
`(when ,(cond ((characterp set) `(char= current-char ,set))
((eq set ':end) `(eq current-char ,set))
((eq set T) T)
(T `(find current-char (the simple-string ,set))))
,@(nreverse action-forms)
(go ,new-state)))))
)
(eval-when (compile eval)
(defun deflex-state (state)
(do ((state-name (car state))
(arc-list (cdr state) (cdr arc-list))
(form-list () (cons (deflex-arc (car arc-list)) form-list)))
((null arc-list)
`(,state-name
,@(nreverse form-list)
(go JAM)))))
)
(eval-when (compile eval)
(defmacro deflex (name &rest states)
(do ((states states (cdr states))
(body-forms () (append body-forms (deflex-state (car states)))))
((null states)
`(defun ,(concat-pnames 'lex- name)
(string &optional (start 0) (end (length string)))
(declare (simple-string string))
(setf (fill-pointer *deflex-tokens*) 0)
(prog ((current-char (if (> end start)
(char string start) :end))
(pointer start)
(buffer *deflex-buffer*)
(buffer-index 0))
(declare (simple-string buffer))
,@body-forms
WIN (return (values T pointer))
JAM (return (values NIL pointer)))))
))
)
;;; Functions for parsing Sesame file specs
(defconstant ses-name-char
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789←-$.*%"
"The set of non special characters in a sesame file name")
(defconstant ses-name-digit "0123456789")
(defconstant fs-whitespace ;whitespace in filenames
"
")
;;; Lex-ses-file-spec separates a sesame file name into its components
;;;
;;; STRING -- the string containing the file spec.
;;; &optional
;;; START -- the first character to look at (defaults to 0)
;;; END -- 1+ the last character to look at (defaluts to (length STRING))
;;;
;;; Returns multiple values.
;;; 1st -- () for failure or a list of tokens.
;;; 2nd -- the index of the character that stopped the parse
;;;
;;; Tokens are represented by a keyword and a string in
;;; *deflex-tokens*. The first token is of type :logical-name (string
;;; is log name), :relative, :colon or :absolute. Subsequent tokens
;;; are of type :name, and the string is a pathname component. The
;;; last token may be either :numeric-version (string of digits),
;;; :wild-version (anything else), or :no-version. The last :name
;;; token is the file name. It may be a :no-name token instead in
;;; which case, the name was not specified.
;;;
(deflex ses-file-spec
;;S1 waits for the first non whitespace character
(S1 (fs-whitespace --> S1 (SCAN))
(#\: --> S1a (EMIT :colon SCAN))
(#\< --> S1b (SCAN))
(#\> --> S1a (EMIT :absolute SCAN))
(#\' --> S5 (EMIT :relative ACCUMULATE SCAN))
(#\; --> S7 (EMIT :relative EMIT :no-name SCAN))
(:end --> WIN (EMIT :relative EMIT :no-name EMIT :no-version))
(ses-name-char --> S4 (EMIT :relative ACCUMULATE SCAN)))
;;S1a waits for first char of pathname component after > or :
(S1a (#\' --> S5 (ACCUMULATE SCAN))
(#\; --> S7 (EMIT :no-name SCAN))
(:end --> WIN (EMIT :no-name EMIT :no-version))
(ses-name-char --> S4 (ACCUMULATE SCAN))
(fs-whitespace --> S10 (EMIT :no-name EMIT :no-version SCAN)))
;;S1b waits for first char of logical name after <
(S1b (#\' --> S3 (ACCUMULATE SCAN))
(ses-name-char --> S2 (ACCUMULATE SCAN)))
;;S2 waits for a logical name can only end on >
(S2 (#\' --> S3 (ACCUMULATE SCAN))
(#\> --> S6 (EMIT :logical-name SCAN))
(ses-name-char --> S2 (ACCUMULATE SCAN)))
;;S3 waits for 'td char in logical name.
(S3 (:end --> JAM)
(T --> S2 (ACCUMULATE SCAN)))
;;S4 waits for a pathname component
(S4 (#\> --> S6 (EMIT :name SCAN))
(#\; --> S7 (EMIT :name SCAN))
(#\' --> S5 (ACCUMULATE SCAN))
(ses-name-char --> S4 (ACCUMULATE SCAN))
(:end --> WIN (EMIT :name EMIT :no-version))
(fs-whitespace --> S10 (EMIT :name EMIT :no-version SCAN)))
;;S5 waits for 'td char of pathname component
(S5 (:end --> JAM)
(T --> S4 (ACCUMULATE SCAN)))
;;S6 waits for start of next pathname component after > :end allowed
(S6 (#\' --> S5 (ACCUMULATE SCAN))
(#\; --> S7 (EMIT :no-name SCAN))
(ses-name-char --> S4 (ACCUMULATE SCAN))
(:end --> WIN (EMIT :no-name EMIT :no-version))
(fs-whitespace --> S10 (EMIT :no-name EMIT :no-version SCAN)))
;;S7 waits for start of version part of file name
(S7 (ses-name-digit --> S8 (ACCUMULATE SCAN))
(ses-name-char --> S9 (ACCUMULATE SCAN))
(:end --> WIN (EMIT :no-version))
(fs-whitespace --> S10 (EMIT :no-version SCAN)))
;;S8 waits for digits in a numeric file version
(S8 (ses-name-digit --> S8 (ACCUMULATE SCAN))
(:end --> WIN (EMIT :numeric-version))
(fs-whitespace --> S10 (EMIT :numeric-version SCAN)))
;;S9 waits for name chars in a wild version
(S9 (ses-name-char --> S9 (ACCUMULATE SCAN))
(:end --> WIN (EMIT :wild-version))
(fs-whitespace --> S10 (EMIT :wild-version SCAN)))
;;S10 Eats trailing whitespace.
(S10 (fs-whitespace --> S10 (SCAN))
(:end --> WIN)
(T --> JAM)))
;;; ses-tokens->pathname converts the contents of *deflex-tokens* into a
;;; pathname. If *deflex-tokens* is zero-length then nil is returned.
;;;
(defun ses-tokens->pathname ()
(let* ((tokens *deflex-tokens*)
(length (length tokens))
(index 2)
device directory name type version)
(when (zerop length)
(return-from ses-tokens->pathname nil))
;;
;; Do the device.
(setq device
(case (aref tokens 0)
(:absolute :absolute)
(:logical-name (aref tokens 1))
(:colon "Dev")
(:relative nil)))
;;
;; Make the directories. There are always three less than the number
;; of tokens, since there is a lead token and two trailers.
(let ((num (- (ash length -1) 3)))
(unless (zerop num)
(setq directory (make-array num))
(dotimes (i num)
(incf index)
(setf (svref directory i) (aref tokens index))
(incf index))))
;;
;; If there is no name there is no type. If there is a name, then
;; the part after the last dot is the type.
(unless (eq (aref tokens index) :no-name)
(let* ((all (aref tokens (1+ index)))
(last-dot (position #\. all :from-end T))
(end (length all)))
(declare (simple-string all))
(cond (last-dot
(setq name (subseq all 0 last-dot))
(setq type (subseq all (1+ last-dot) end)))
(t
(setq name all)))))
(incf index 2)
;;
;; Do the version.
(let ((key (aref tokens index))
(string (aref tokens (1+ index))))
(setq version
(case key
(:no-version ())
(:numeric-version (parse-integer string))
(:wild-version
(cond ((string-equal string "NEW") :newest)
((string-equal string "HIGH") :newest)
((string-equal string "LOW") :oldest)
((string-equal string "ALL") :wild)
((string-equal string "*") :wild))))))
(%make-pathname "Spice" device directory name type version)))
;;; Parse-Namestring -- Public
;;;
;;; Just lex the thing and flame out if it can't be done.
;;;
(defun parse-namestring (thing &optional host
(defaults *default-pathname-defaults*)
&key (start 0) end (junk-allowed nil))
"Parses a string representation of a pathname into a pathname. For
details on the other silly arguments see the manual."
(unless host (setq host (%pathname-host defaults)))
(typecase thing
(string (setq thing (coerce thing 'simple-string)))
(pathname (return-from parse-namestring (values thing start)))
(file-stream (setq thing (file-stream-filename thing)))
(symbol (setq thing (symbol-name thing)))
(t
(error "This thing is a bad thing for parse-namestring: ~S" thing)))
(unless end (setq end (length (the simple-string thing))))
(multiple-value-bind (won next-field)
(lex-ses-file-spec thing start end)
(unless (or won junk-allowed)
(error "There's junk in this thing that you gave to parse-namestring:~%~
~4T\"~A\"~%~0,1,V,'.@A" thing (+ next-field 5) #\↑))
(values (ses-tokens->pathname) next-field)))
;;; Pathname -- Public
;;;
;;; Call parse-namestring, doo dah, doo dah...
;;;
(defun pathname (thing)
"Turns Thing into a pathname. Thing may be a string, symbol, stream,
or pathname."
(values (parse-namestring thing)))
;;; Merge-Pathnames -- Public
;;;
;;; Returns a new pathname whose fields are the same as the fields in PATHNAME
;;; except that () fields are filled in from defaults. Type and Version field
;;; are only done if name field has to be done (see manual for explanation).
;;;
(defun merge-pathnames (pathname &optional
(defaults *default-pathname-defaults*)
default-version)
"Fills in unspecified slots of Pathname from Defaults (defaults to
*default-pathname-defaults*). If the version remains unspecified,
gets it from Default-Version."
;;
;; finish hairy argument defaulting
(setq pathname (pathname pathname))
(setq defaults (pathname defaults))
(when (%pathname-version defaults)
(setq default-version (%pathname-version defaults)))
;;
;; make a new pathname
(let ((host (%pathname-host pathname))
(device (%pathname-device pathname))
(directory (%pathname-directory pathname))
(name (%pathname-name pathname))
(type (%pathname-type pathname))
(version (%pathname-version pathname)))
(%make-pathname
(or host (%pathname-host defaults))
(or device (%pathname-device defaults))
(or directory (%pathname-directory defaults))
(or name (%pathname-name defaults))
(or type (%pathname-type defaults))
(if (or name version) version default-version))))
;;; Namestring & Friends
;;; %Dirstring -- Internal
;;;
;;; %Dirstring converts a vector of the form #("foo" "bar" ... "baz") into a
;;; string of the form "foo>bar> ... >baz>"
;;;
(defun %dirstring (dirlist)
(concatenate 'string (reduce #'(lambda (a b)
(concatenate 'string a ">" b))
dirlist)
">"))
(defun %version-string (version)
(if (integerp version)
(write-to-string version :prinradix nil :base 10)
(case version
(:wild "All")
(:newest "New")
(:oldest "Low")
(t (error "Strange version ~s." version)))))
(defun %device-string (device)
(cond ((eq device :absolute) ">")
(device (concatenate 'simple-string "<"
(the simple-string device) ">"))
(T "")))
(defun namestring (pathname)
"Returns the full form of PATHNAME as a string."
(setq pathname (pathname pathname))
(let* ((directory (%pathname-directory pathname))
(name (%pathname-name pathname))
(type (%pathname-type pathname))
(version (%pathname-version pathname))
(result (%device-string (%pathname-device pathname))))
(declare (simple-string result))
(when directory
(setq result (concatenate 'simple-string result
(the simple-string (%dirstring directory)))))
(when name
(setq result (concatenate 'simple-string result
(the simple-string name))))
(when type
(setq result (concatenate 'simple-string result "."
(the simple-string type))))
(when version
(setq result (concatenate 'simple-string result ";"
(the simple-string (%version-string version)))))
result))
(defun %ses-namestring (pathname)
"Returns the full form of PATHNAME as a string, nuking any version,
since sesamoid chokes when a version is specified."
(setq pathname (pathname pathname))
(let* ((directory (%pathname-directory pathname))
(name (%pathname-name pathname))
(type (%pathname-type pathname))
(result (%device-string (%pathname-device pathname))))
(declare (simple-string result))
(when directory
(setq result (concatenate 'simple-string result
(the simple-string (%dirstring directory)))))
(when name
(setq result (concatenate 'simple-string result
(the simple-string name))))
(when type
(setq result (concatenate 'simple-string result "."
(the simple-string type))))
result))
;;; %SES-GET-USEFUL-NAME is used to get the filename without the logical
;;; prefix (if there is one).
(defun %ses-get-useful-name (pathname)
"Returns the full form of PATHNAME as a string, nuking any version, and logical
name."
(setq pathname (pathname pathname))
(let* ((directory (%pathname-directory pathname))
(name (%pathname-name pathname))
(type (%pathname-type pathname))
(result ""))
(declare (simple-string result))
(when directory
(setq result (concatenate 'simple-string result
(the simple-string (%dirstring directory)))))
(when name
(setq result (concatenate 'simple-string result
(the simple-string name))))
(when type
(setq result (concatenate 'simple-string result "."
(the simple-string type))))
result))
(defun file-namestring (pathname)
"Returns the name, type, and version of PATHNAME as a string."
(setq pathname (pathname pathname))
(let* ((name (%pathname-name pathname))
(type (%pathname-type pathname))
(version (%pathname-version pathname))
(result (or name "")))
(declare (simple-string result))
(when type
(setq result (concatenate 'simple-string result "."
(the simple-string type))))
(when version
(setq result (concatenate 'simple-string result ";"
(the simple-string (%version-string version)))))
result))
(defun directory-namestring (pathname)
"Returns the device & directory parts of PATHNAME as a string."
(setq pathname (pathname pathname))
(let* ((directory (%pathname-directory pathname))
(result (%device-string (%pathname-device pathname))))
(declare (simple-string result))
(when directory
(setq result (concatenate 'simple-string result
(the simple-string (%dirstring directory)))))
result))
(defun host-namestring (pathname)
"Returns the host part of PATHNAME as a string."
(setq pathname (pathname pathname))
(%pathname-host pathname))
;;; Enough-Namestring
(defun enough-namestring (pathname &optional
(defaults *default-pathname-defaults*))
"Returns a string which uniquely identifies PATHNAME w.r.t. DEFAULTS."
(setq pathname (pathname pathname))
(setq defaults (pathname defaults))
(let* ((device (%pathname-device pathname))
(directory (%pathname-directory pathname))
(name (%pathname-name pathname))
(type (%pathname-type pathname))
(version (%pathname-version pathname))
(result ""))
(declare (simple-string result))
(when (and device (string-not-equal device (%pathname-device defaults)))
(setq result (%device-string device)))
(when (and directory
(not (equalp directory (%pathname-directory defaults))))
(setq result (concatenate 'simple-string result
(the simple-string (%dirstring directory)))))
(when (and name (string-not-equal name (%pathname-name defaults)))
(setq result (concatenate 'simple-string result
(the simple-string name))))
(when (and type (string-not-equal type (%pathname-type defaults)))
(setq result (concatenate 'simple-string result "."
(the simple-string type))))
(when (and version (not (eql version (%pathname-version defaults))))
(setq result (concatenate 'simple-string result ";"
(the simple-string (%version-string version)))))
result))
;;;; TRUENAME and other stuff that deals with the real world.
;;; Truename -- Public
;;;
;;; Another silly file function trivially different from another function.
;;;
(defun truename (pathname)
"Return the pathname for the actual file described by the pathname
An error is signalled if no such file exists."
(let ((result (probe-file pathname)))
(unless result
(error "The file ~S does not exist." (namestring pathname)))
result))
;;;; ### Beginning of bogus stuff:
;;;
;;; When the environment manager stuff is cleaned up this can be also...
;;; Probe-File -- Public
;;;
;;; This isn't very right, but I don't have time to fix it now.
;;; We ought to handle dots and do logical names right, for some
;;; value of right. We ought to error if the return code is anything
;;; other than name-not-found for an absolute pathname.
;;;
(defun probe-file (pathname)
(setq pathname (pathname pathname))
(let ((log-name (%pathname-device pathname)))
(unless log-name (setq log-name "DEFAULT"))
(if (eq log-name :absolute)
(multiple-value-bind
(rc file-name) (sub-test-name (%ses-namestring pathname))
(if (= rc rc-success) (parse-namestring file-name)
nil))
(multiple-value-bind
(rc file-name) (find-path-name (%ses-get-useful-name pathname) log-name)
(if (= rc rc-success) (parse-namestring file-name)
nil)))))
;;; Predict-name
;;;
;;; Predict-Name is a function used by Open to get an absolute pathname
;;; for a file being opened. Returns the truename of the file and
;;; whether it really exists or not.
;;;
(defun predict-name (file-name for-input)
(let* ((pathname (pathname file-name))
(device (%pathname-device pathname))
(truename (probe-file pathname)))
(cond ((eq device :absolute)
(values (%ses-namestring pathname) (not (null truename))))
((and for-input truename)
(values (%ses-namestring truename) t))
(device
(let* ((search-list (resolve-search-list device t))
(result (concatenate 'simple-string
(car search-list)
(%ses-get-useful-name pathname))))
(values result (= (sub-test-name result) rc-success))))
(t
(let* ((search-list (resolve-search-list "default" t))
(result (concatenate 'simple-string
(car search-list)
(%ses-get-useful-name pathname))))
(values result (= (sub-test-name result) rc-success)))))))
;;; User-Homedir-Pathname
;;;
;;; We can't find a user name in accent yet, so just return <DEFAULT>
;;;
(defun user-homedir-pathname (&optional host)
"Returns the home directory of the logged in user as a pathname."
(declare (ignore host))
(make-pathname :device "default"))