From 2b5d44794461986a4789dc24498458d93b6e674a Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Thu, 22 Feb 1990 11:53:35 +0000 Subject: [PATCH] Back-merged my type fixes into the working code version as of this date. --- code/filesys.lisp | 363 +++++++++++++--------------------------------- 1 file changed, 99 insertions(+), 264 deletions(-) diff --git a/code/filesys.lisp b/code/filesys.lisp index c317b9613..49e97c122 100644 --- a/code/filesys.lisp +++ b/code/filesys.lisp @@ -13,7 +13,9 @@ ;;; Written by Jim Large and Rob MacLachlan ;;; ;;; ********************************************************************** -(in-package 'lisp) + +(in-package "LISP") + (export '(pathname pathnamep *default-pathname-defaults* truename parse-namestring merge-pathnames make-pathname pathname-host pathname-device pathname-directory @@ -28,7 +30,7 @@ (in-package "EXTENSIONS") (export '(print-directory complete-file ambiguous-files default-directory file-writable)) -(in-package 'lisp) +(in-package "LISP") ;;; Pathname structure @@ -134,270 +136,103 @@ -;;;; FSM Compiler - -(eval-when (compile eval) -;;; These macros are used in 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))))) - -;;; fsm-emit expands into a form which pushes FLAG onto *deflex-tokens* and -;;; then pushes a string containing the ACCUMULATED characters -(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))) - -;;; fsm-dotfix expands into a form which replaces the last EMITTED flag with -;;; FLAG, and the last EMITTED token with its self + "." + the ACCUMULATED -;;; characters. -(defmacro fsm-dotfix (flag) - `(let ((prev-token (vector-pop *deflex-tokens*))) - (setf (aref *deflex-tokens* (1- (fill-pointer *deflex-tokens*))) ,flag) - (vector-push (concatenate 'simple-string - prev-token - "." - (subseq buffer 0 buffer-index)) - *deflex-tokens*) - (setq buffer-index 0))) - - -(defun deflex-arc (arc) - (do ((set (nth 0 arc)) - (new-state (nth 2 arc)) - (actions (nth 3 arc) (if (member (car actions) '(EMIT DOTFIX)) - (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))) - (DOTFIX `(fsm-dotfix ,(nth 1 actions))) - (t (error "Illegal action ~s" (car actions)))) - action-forms))) - ((null actions) - `(when ,(cond ((eq set ':end) `(eq current-char ,set)) - ((eq set T) T) - (t - `(and (not (eq current-char :end)) - ,(if (characterp set) - `(char= current-char ,set) - `(find current-char - (the simple-string ,set)))))) - ,@(nreverse action-forms) - (go ,new-state))))) - - -(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))))) - -(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) - (fixnum start end)) - (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))))))) - -); eval-when (compile eval) - - -(defvar *deflex-buffer* (make-string 100)) -(defvar *deflex-tokens* (make-array 20 :adjustable t :fill-pointer 0)) - - - -;;;; FSM for lexing pathnames. - -(defconstant ses-name-char - "#@$-+*%0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz~") - -(defconstant fs-whitespace ;whitespace in filenames - " -") +;;;; PARSE-NAMESTRING and PATHNAME. -;;; 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)) +;;; SPLIT-FILENAME -- internal ;;; -;;; 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) or :absolute. -;;; Subsequent tokens are of type :directory-name, :file-name, :extension, or -;;; the string being a pathname component. -;;; -(deflex ses-file-spec - ;;S1 waits for the first non whitespace character - (S1 (fs-whitespace --> S1 (SCAN)) - (#\- --> JAM) ;- illegal as start of file name - (#\/ --> S3 (EMIT :absolute SCAN));/ starts an absolute pathname - (#\\ --> S2a (ACCUMULATE SCAN)) ;\ quotes char in name or logname - (#\. --> S5 (EMIT :file-name SCAN)) ;. maybe ends file name - (ses-name-char --> S2 (ACCUMULATE SCAN)) ;first char in a name or logname - (:end --> WIN) ; Null filename is legal. - ) - - ;;S2 accumulates chars in a file name, logical name, or directory name. - (S2 (#\: --> S3 (EMIT :logical-name SCAN)) ;: ends log-name, starts next name - (#\/ --> S3 (EMIT :directory-name SCAN));/ ends directory name,starts next - (#\\ --> S2a (ACCUMULATE SCAN)) ;\ quotes char in name - (#\. --> S5 (EMIT :file-name SCAN)) ;. maybe ends file name - (:end --> WIN (EMIT :file-name)) - (ses-name-char --> S2 (ACCUMULATE SCAN)) - (fs-whitespace --> S9 (EMIT :file-name SCAN)) - (T --> JAM (EMIT :file-name)) - ) - - ;;S2a waits for any char following a \ found in S2 - (S2a (:END --> JAM) - (T --> S2 (ACCUMULATE SCAN))) - - ;;S3 accumulates chars in a file name or directory name - (S3 (#\/ --> JAM) - (T --> S3b)) - (S3b (#\/ --> S3 (EMIT :directory-name SCAN));/ ends directory name,starts next - (#\. --> S4 (EMIT :file-name SCAN)) ;. maybe ends file name - (#\\ --> S3a (ACCUMULATE SCAN)) ;\ quotes char in name - (:end --> WIN (EMIT :file-name)) - (ses-name-char --> S3b (ACCUMULATE SCAN)) - (fs-whitespace --> S9 (EMIT :file-name SCAN)) - (T --> JAM (EMIT :file-name)) - ) - - ;;S3a waits for any char following a \ found in S3 - (S3a (:end --> JAM) - (T --> S3b (ACCUMULATE SCAN))) - - ;;S4 waits for chars in a name following a dot. If it encounters the end of - ;; the pathname, then the chars are the extension. Otherwise, the chars are - ;; really part of the last token, so we mash them back on with dotfix. - (S4 (#\/ --> S3 (DOTFIX :directory-name SCAN)) - (#\\ --> S4a (ACCUMULATE SCAN)) - (#\. --> S4 (DOTFIX :file-name SCAN)) - (:end --> WIN (EMIT :extension)) - (fs-whitespace --> S9 (EMIT :extension SCAN)) - (ses-name-char --> S4 (ACCUMULATE SCAN)) - (T --> JAM (EMIT :extension)) - ) - - ;;S4a waits for any char following a \ found in S4 - (S4a (:end --> JAM) - (T --> S4 (ACCUMULATE SCAN))) - - ;;S5 is the same as S4 but name may also be logical name - (S5 (#\/ --> S3 (DOTFIX :directory-name SCAN)) - (#\: --> S3 (DOTFIX :logical-name SCAN)) - (#\\ --> S5a (ACCUMULATE SCAN)) - (#\. --> S5 (DOTFIX :file-name SCAN)) - (:end --> WIN (EMIT :extension)) - (fs-whitespace --> S9 (EMIT :extension SCAN)) - (ses-name-char --> S5 (ACCUMULATE SCAN)) - (T --> JAM (EMIT :extension)) - ) - - ;;S5a waits for any char following a \ found in S5 - (S5a (:end --> JAM) - (T --> S5 (ACCUMULATE SCAN))) - - ;;S9 eats trailing whitespace. - (S9 (fs-whitespace --> S9 (SCAN)) - (:end --> WIN) - (t --> JAM)) - ) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; ses-tokens->pathname converts the contents of *deflex-tokens* into a pathname +;;; Splits the filename into the name and type. If someone wants to change +;;; this yet again, just change this. ;;; -(defun ses-tokens->pathname () - (do ((end (fill-pointer *deflex-tokens*)) - (result (make-pathname)) - (dirlist ()) - (token-val ()) - (ix 0 (+ ix 2)) - (default t)) - ((>= ix end) - (setf (%pathname-directory result) - (cond (dirlist - (when default (setf (%pathname-device result) "Default")) - (coerce (the list (nreverse dirlist)) 'simple-vector)) - (default nil) - (t '#()))) - result) - (declare (list dirlist) - (fixnum ix end)) - (setq token-val (aref *deflex-tokens* (1+ ix))) - (case (aref *deflex-tokens* ix) - (:ABSOLUTE - (setf (%pathname-device result) :ABSOLUTE) - (setq default nil)) - (:LOGICAL-NAME - (setf (%pathname-device result) token-val) - (setq default nil)) - (:DIRECTORY-NAME (push token-val dirlist)) - (:FILE-NAME - (unless (zerop (length (the simple-string token-val))) - (setf (%pathname-name result) token-val))) - (:EXTENSION (setf (%pathname-type result) token-val))))) - +(defun split-filename (filename) + (declare (simple-string filename)) + (let ((posn (position #\. filename :from-end t))) + (cond ((null posn) + (values filename nil)) + ((or (zerop posn) (= posn (1- (length filename)))) + (values filename "")) + (t + (values (subseq filename 0 posn) + (subseq filename (1+ posn))))))) - -;;;; PARSE-NAMESTRING and PATHNAME. +;;; DO-FILENAME-PARSE -- internal +;;; +;;; Split string into a logical name, a vector of directories, a file name and +;;; a file type. +;;; +(defun do-filename-parse (string &optional (start 0) end) + (declare (simple-string string)) + (let ((end (or end (length string)))) + (let* ((directories nil) + (filename nil) + (absolutep (and (> end start) (eql (schar string start) #\/))) + (logical-name + (cond (absolutep + (setf start (position #\/ string :start start :end end + :test-not #'char=)) + :absolute) + ((find #\: string + :start start + :end (or (position #\/ string :start start :end end) + end)) + (let ((posn (position #\: string :start start))) + (prog1 + (subseq string start posn) + (setf start (1+ posn)))))))) + (loop + (unless (and start (> end start)) + (return)) + (let ((next-slash (position #\/ string :start start :end end))) + (cond (next-slash + (push (subseq string start next-slash) directories) + (setf start + (position #\/ string :start next-slash :end end + :test-not #'char=))) + (t + (setf filename (subseq string start end)) + (return))))) + (multiple-value-bind (name type) + (if filename (split-filename filename)) + (values (cond (logical-name logical-name) + (directories "Default")) + (if (or logical-name directories) + (coerce (nreverse directories) 'vector)) + name + type))))) + +(defun parse-namestring (thing &optional host + (defaults *default-pathname-defaults*) + &key (start 0) end junk-allowed) + "Convert THING (string, symbol, pathname, or stream) into a pathname." + (declare (ignore junk-allowed)) + (let* ((host (or host (pathname-host defaults))) + (pathname + (etypecase thing + ((or string symbol) + (let ((string (coerce (string thing) 'simple-string))) + (multiple-value-bind (device directories name type) + (do-filename-parse string start end) + (unless end (setf end (length string))) + (make-pathname :host host + :device device + :directory directories + :name name + :type type)))) + (pathname + (setf end start) + thing) + (stream + (setf end start) + (pathname (file-name thing)))))) + (unless (or (null host) + (null (pathname-host pathname)) + (string-equal host (pathname-host pathname))) + (cerror "Ignore it." + "Host mismatch in ~S: ~S isn't ~S" + 'parse-namestring + (pathname-host pathname) + host)) + (values pathname end))) -(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." - (declare (ignore host defaults)) - (let* ((thing (typecase thing - (string (coerce thing 'simple-string)) - (pathname (return-from parse-namestring (values thing start))) - (stream (file-name thing)) - (symbol (symbol-name thing)) - (t (error "This thing is a bad thing for parse-namestring: ~S" - thing)))) - (end (or end (length thing)))) - (declare (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)))) (defun pathname (thing) "Turns thing into a pathname. Thing may be a string, symbol, stream, or @@ -509,7 +344,7 @@ (when name (setq result (concatenate 'simple-string result (the simple-string name)))) - (when type + (when (and type (not (zerop (length type)))) (setq result (concatenate 'simple-string result "." (the simple-string type)))) result)) @@ -528,7 +363,7 @@ (when name (setq result (concatenate 'simple-string result (the simple-string name)))) - (when type + (when (and type (not (zerop (length type)))) (setq result (concatenate 'simple-string result "." (the simple-string type)))) result)) @@ -543,7 +378,7 @@ (type (%pathname-type pathname)) (result (or name ""))) (declare (simple-string result)) - (if type + (if (and type (not (zerop (length type)))) (concatenate 'simple-string result "." type) result))) -- GitLab