;;; **********************************************************************
;;; 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"))