;;; Pathnames -*-Mode:LISP;Package:FS-*-
;;;  ** (c) Copyright 1980 Massachusetts Institute of Technology **

;;; Advertised function interfaces:
;;; PARSE-PATHNAME THING &OPTIONAL WITH-RESPECT-TO (DEFAULTS *DEFAULT-PATHNAME-DEFAULTS*)
;;;  Parses a string (or whatever) into a pathname.
;;; DEFAULT-PATHNAME &OPTIONAL DEFAULTS HOST DEFAULT-TYPE DEFAULT-VERSION
;;;  Returns the default for the given HOST from DEFAULTS.
;;; SET-DEFAULT-PATHNAME PATHNAME &OPTIONAL DEFAULTS
;;;  Sets the default for either the host of the pathname or the NIL default.
;;; MAKE-PATHNAME-DEFAULTS
;;;  Returns an alist that you can pass to the functions below that take a set of defaults.
;;;  Most things that take a set of defaults will also take a single pathname.
;;; MERGE-PATHNAME-DEFAULTS PATHNAME &OPTIONAL DEFAULTS DEFAULT-TYPE DEFAULT-VERSION
;;;  Fill in slots in PATHNAME from program defaults.  This is what most
;;;  programs interface to.
;;; MERGE-AND-SET-PATHNAME-DEFAULTS PATHNAME &OPTIONAL DEFAULTS DEFAULT-TYPE DEFAULT-VERSION
;;;  Does parse, merge, and updating of defaults.
;;; DESCRIBE-PATHNAME PATHNAME
;;;  Describes all files that look like pathname.  Also useful when you cannot remember what
;;;  directory a file is in.
;;; PATHNAME-PLIST PATHNAME

;;; Advertised messages on pathnames:
;;; :GET INDICATOR
;;; :PUTPROP PROP INDICATOR
;;; :REMPROP INDICATOR
;;; :DEVICE, :DIRECTORY, :NAME, :TYPE, :VERSION
;;; :NEW-DEVICE, :NEW-DIRECTORY, :NEW-NAME, :NEW-TYPE, :NEW-VERSION
;;; :NEW-STRUCTURED-DEVICE, :NEW-STRUCTURED-DIRECTORY, :NEW-STRUCTURED-NAME
;;; :NEW-PATHNAME &REST OPTIONS
;;; :DEFAULT-NAMESTRING STRING
;;; :GENERIC-PATHNAME
;;; :STRING-FOR-HOST, :STRING-FOR-PRINTING, :STRING-FOR-WHOLINE, :STRING-FOR-EDITOR
;;; :STRING-FOR-DIRED
;;; :INIT-FILE PROGRAM-NAME

;;; Advertised special variables:
;;; *KNOWN-TYPES* - list of types unimportant for the sake of generic pathnames.
;;; *DEFAULTS-ARE-PER-HOST* - user option.  If NIL, pathnames defaults are maintained all
;;;  together for all hosts.
;;;  *ITS-UNINTERESTING-TYPES* - types that do not deserve the FN2 slot.

;;; Other system types (pathname syntaxes) must implement at least the following messages:
;;; They can then be mixed with CHAOS-PATHNAME for use with the standard chaosnet file
;;; job protocol.
;;;  :STRING-FOR-HOST - returns a string that can be sent to the file computer that
;;;  specifying the file in question.
;;;  :PARSE-NAMESTRING - takes a string and returns multiple values for various components
;;;  present in the string.
;;; See ITS-PATHNAME-MIXIN and/or TOPS20-PATHNAME-MIXIN for additional details.

;;; To add another protocol, implement the messages of CHAOS-PATHNAME for generic file
;;; manipulation.  That flavor is defined in QFILE.

;;; Interaction with host objects:
;;; The HOST instance variable of a pathname is a host object, as
;;; outlined in AI: LISPM2; HOST >.
;;; *PATHNAME-HOST-LIST* is the set of all pathname hosts.  Some of
;;; these are actual hosts on the local network, such as MIT-AI, and
;;; others are logical hosts, such as SYS.  When parsing a string into a
;;; pathname, the specified host (the part of the string before the
;;; colon) is sent in the :PATHNAME-HOST-NAMEP message to each host in
;;; this list.  When that returns T, that host is used.
;;; The host is sent a :PATHNAME-FLAVOR message to determine the flavor of the
;;; pathname to instantiate.  (If the reply to :PATHNAME-FLAVOR returns multiple
;;; values, the second is an addition for the INIT-PLIST to use when instantiating.)
;;; Normally, when printing the host portion of a pathname, the host is
;;; sent a :NAME-AS-FILE-COMPUTER message.

;; The pathname hash table, pathnames, and cached strings are stored here to improve locality.
(DEFVAR PATHNAME-AREA (MAKE-AREA ':NAME 'PATHNAME-AREA
				 ':GC ':STATIC))

;;; This is a separate flavor so there can be dummy pathnames which just print and store
;;; properties.
(DEFFLAVOR EMPTY-PATHNAME () (SI:PROPERTY-LIST-MIXIN))

;;; PRINC of a pathname is just like PRINC of the :STRING-FOR-PRINTING
(DEFMETHOD (EMPTY-PATHNAME :PRINT-SELF) (STREAM IGNORE SLASHIFY-P)
  (IF SLASHIFY-P
      (SI:PRINTING-RANDOM-OBJECT (SELF STREAM :NO-POINTER)
	(PRINC (TYPEP SELF) STREAM)
	(FUNCALL STREAM ':TYO #\SP)
	(PRIN1 (FUNCALL-SELF ':STRING-FOR-PRINTING) STREAM))
      (FUNCALL STREAM ':STRING-OUT (FUNCALL-SELF ':STRING-FOR-PRINTING))))

(DEFMETHOD (EMPTY-PATHNAME :PLIST) ()
  SI:PROPERTY-LIST)

;;; This is for use by things like the editor which have structures that store file-like
;;; properties on non-pathname objects.
(DEFFLAVOR DUMMY-PATHNAME (NAME) (EMPTY-PATHNAME)
  :INITABLE-INSTANCE-VARIABLES)

(DEFMETHOD (DUMMY-PATHNAME :STRING-FOR-PRINTING) ()
  NAME)

(DEFMETHOD (DUMMY-PATHNAME :STRING-FOR-EDITOR) ()
  NAME)

(DEFMETHOD (DUMMY-PATHNAME :STRING-FOR-DIRED) ()
  NAME)

(DEFUN MAKE-DUMMY-PATHNAME (NAME &OPTIONAL PLIST)
  (MAKE-INSTANCE 'DUMMY-PATHNAME ':NAME NAME ':PROPERTY-LIST PLIST))

;;; This is the actual base flavor
(DEFFLAVOR PATHNAME
	(HOST
	 (DEVICE NIL)
	 (DIRECTORY NIL)
	 (NAME NIL)
	 (TYPE NIL)
	 (VERSION NIL)
	 (SI:PROPERTY-LIST NIL)			;Where files properties are stored
	 (STRING-FOR-PRINTING NIL)
	 )
	(EMPTY-PATHNAME)
  :ORDERED-INSTANCE-VARIABLES
  (:OUTSIDE-ACCESSIBLE-INSTANCE-VARIABLES HOST DEVICE DIRECTORY NAME TYPE VERSION
					  SI:PROPERTY-LIST)
  (:GETTABLE-INSTANCE-VARIABLES HOST DEVICE DIRECTORY NAME TYPE VERSION SI:PROPERTY-LIST)
  (:INITABLE-INSTANCE-VARIABLES HOST DEVICE DIRECTORY NAME TYPE VERSION SI:PROPERTY-LIST)
  (:REQUIRED-METHODS :PARSE-NAMESTRING))

(DEFMETHOD (PATHNAME :INIT) (IGNORE)
  (OR (BOUNDP 'HOST)
      (FERROR NIL "Host must be specified when initializing a pathname"))) 

;;; Caching of strings
(DEFWRAPPER (PATHNAME :STRING-FOR-PRINTING) (IGNORE . BODY)
  `(OR STRING-FOR-PRINTING
       (LET ((DEFAULT-CONS-AREA PATHNAME-AREA))
	 (SETQ STRING-FOR-PRINTING (PROGN . ,BODY)))))

(DEFMETHOD (PATHNAME :STRING-FOR-WHOLINE) ()
  (FUNCALL-SELF ':STRING-FOR-PRINTING))

(DEFMETHOD (PATHNAME :STRING-FOR-DIRED) ()
  (FUNCALL-SELF ':STRING-FOR-PRINTING))

(DEFMETHOD (PATHNAME :STRING-FOR-MINI) ()
  (FUNCALL-SELF ':STRING-FOR-PRINTING))

(DEFMETHOD (PATHNAME :STRING-FOR-DIRECTORY) ()
  (FUNCALL-SELF ':STRING-FOR-PRINTING))

(DEFFLAVOR MEANINGFUL-ROOT-MIXIN () ()
  (:INCLUDED-FLAVORS PATHNAME)
  (:REQUIRED-METHODS :DIRECTORY-PATHNAME-AS-FILE)
  (:DOCUMENTATION :MIXIX "For use with file systems where the root directory is treated
as an ordinary directory."))

;;; This is a pathname that corresponds to a real (as opposed to logical) host
(DEFFLAVOR HOST-PATHNAME
	((STRING-FOR-WHOLINE NIL)
	 (STRING-FOR-EDITOR NIL)
	 (STRING-FOR-DIRED NIL)
	 (STRING-FOR-DIRECTORY NIL)
	 )
	(PATHNAME))

(DEFWRAPPER (HOST-PATHNAME :STRING-FOR-WHOLINE) (IGNORE . BODY)
  `(OR STRING-FOR-WHOLINE
       (LET ((DEFAULT-CONS-AREA PATHNAME-AREA))
	 (SETQ STRING-FOR-WHOLINE (PROGN . ,BODY)))))

(DEFWRAPPER (HOST-PATHNAME :STRING-FOR-EDITOR) (IGNORE . BODY)
  `(OR STRING-FOR-EDITOR
       (LET ((DEFAULT-CONS-AREA PATHNAME-AREA))
	 (SETQ STRING-FOR-EDITOR (PROGN . ,BODY)))))

(DEFWRAPPER (HOST-PATHNAME :STRING-FOR-DIRED) (IGNORE . BODY)
  `(OR STRING-FOR-DIRED
       (LET ((DEFAULT-CONS-AREA PATHNAME-AREA))
	 (SETQ STRING-FOR-DIRED (PROGN . ,BODY)))))

(DEFWRAPPER (HOST-PATHNAME :STRING-FOR-DIRECTORY) (IGNORE . BODY)
  `(OR STRING-FOR-DIRECTORY
       (LET ((DEFAULT-CONS-AREA PATHNAME-AREA))
	 (SETQ STRING-FOR-DIRECTORY (PROGN . ,BODY)))))

;;; This is a pathname connected by some remote medium.  It might even be a local file
;;; system if that interfaces through a :STRING-FOR-HOST.
(DEFFLAVOR REMOTE-PATHNAME
	((STRING-FOR-HOST NIL)			;Caches
	 )
	(HOST-PATHNAME)
  (:REQUIRED-METHODS :STRING-FOR-HOST))

(DEFMETHOD (REMOTE-PATHNAME :STRING-FOR-PRINTING) ()
  (STRING-APPEND (FUNCALL HOST ':NAME-AS-FILE-COMPUTER) ": "
		 (FUNCALL-SELF ':STRING-FOR-HOST)))

(DEFMETHOD (REMOTE-PATHNAME :STRING-FOR-EDITOR) ()
  (STRING-APPEND (FUNCALL-SELF ':STRING-FOR-HOST) #\SP
		 (FUNCALL HOST ':NAME-AS-FILE-COMPUTER) #/:))

(DEFWRAPPER (REMOTE-PATHNAME :STRING-FOR-HOST) (IGNORE . BODY)
  `(OR STRING-FOR-HOST
       (LET ((DEFAULT-CONS-AREA PATHNAME-AREA))
	 (SETQ STRING-FOR-HOST (PROGN . ,BODY)))))

(DEFMETHOD (REMOTE-PATHNAME :STRING-FOR-MINI) ()
  (FUNCALL-SELF ':STRING-FOR-HOST))

(DEFMETHOD (REMOTE-PATHNAME :STRING-FOR-DIRECTORY) ()
  (FUNCALL-SELF ':STRING-FOR-HOST))

(DEFMETHOD (PATHNAME :NEW-DEVICE) (NEW-DEVICE)
  (FUNCALL-SELF ':NEW-PATHNAME ':DEVICE NEW-DEVICE))

(DEFMETHOD (PATHNAME :NEW-STRUCTURED-DEVICE) (NEW-DEVICE)
  (FUNCALL-SELF ':NEW-PATHNAME ':STRUCTURED-DEVICE NEW-DEVICE))

(DEFMETHOD (PATHNAME :NEW-DIRECTORY) (NEW-DIRECTORY)
  (FUNCALL-SELF ':NEW-PATHNAME ':DIRECTORY NEW-DIRECTORY))

(DEFMETHOD (PATHNAME :NEW-STRUCTURED-DIRECTORY) (NEW-DIRECTORY)
  (FUNCALL-SELF ':NEW-PATHNAME ':STRUCTURED-DIRECTORY NEW-DIRECTORY))

(DEFMETHOD (PATHNAME :NEW-NAME) (NEW-NAME)
  (FUNCALL-SELF ':NEW-PATHNAME ':NAME NEW-NAME))

(DEFMETHOD (PATHNAME :NEW-STRUCTURED-NAME) (NEW-NAME)
  (FUNCALL-SELF ':NEW-PATHNAME ':STRUCTURED-NAME NEW-NAME))

(DEFMETHOD (PATHNAME :NEW-TYPE) (NEW-TYPE)
  (FUNCALL-SELF ':NEW-PATHNAME ':TYPE NEW-TYPE))

(DEFMETHOD (PATHNAME :NEW-VERSION) (NEW-VERSION)
  (FUNCALL-SELF ':NEW-PATHNAME ':VERSION NEW-VERSION))

;;; These exist for the sake of ITS
(DEFMETHOD (PATHNAME :NEW-TYPE-AND-VERSION) (NEW-TYPE NEW-VERSION)
  (FUNCALL-SELF ':NEW-PATHNAME ':TYPE NEW-TYPE ':VERSION NEW-VERSION))

(DEFMETHOD (PATHNAME :TYPE-AND-VERSION) ()
  (VALUES TYPE VERSION))

(DEFMETHOD (PATHNAME :PATCH-FILE-PATHNAME) (NAM SAME-DIRECTORY-P PATOM TYP &REST ARGS)
  (SELECTQ TYP
    (:SYSTEM-DIRECTORY
     (FUNCALL-SELF ':NEW-PATHNAME ':NAME (IF SAME-DIRECTORY-P PATOM NAM)
		   ':TYPE (IF SAME-DIRECTORY-P "DIRECTORY" "PATCH-DIRECTORY")
		   ':VERSION ':NEWEST))
    (:VERSION-DIRECTORY
     (FUNCALL-SELF ':NEW-PATHNAME ':NAME (FORMAT NIL "~:[~A~*~;~*~A~]-~D"
						 SAME-DIRECTORY-P NAM
						 PATOM (CAR ARGS))
		   ':TYPE (IF SAME-DIRECTORY-P "DIRECTORY" "PATCH-DIRECTORY")
		   ':VERSION ':NEWEST))
    (:PATCH-FILE
     (FUNCALL-SELF ':NEW-PATHNAME ':NAME (FORMAT NIL "~:[~A~*~;~*~A~]-~D-~D"
						 SAME-DIRECTORY-P NAM PATOM
						 (CAR ARGS) (CADR ARGS))
		   ':TYPE (CADDR ARGS) ':VERSION ':NEWEST))))

(DEFMETHOD (HOST-PATHNAME :INIT-FILE) (PROGRAM-NAME)
  (FUNCALL-SELF ':NEW-PATHNAME ':NAME PROGRAM-NAME
			       ':TYPE "INIT"
			       ':VERSION ':NEWEST))

;;; Default is for users to have their own directories.
(DEFMETHOD (PATHNAME :HOMEDIR) ()
  (MAKE-PATHNAME ':HOST HOST ':DIRECTORY USER-ID))

;;; By default, a directory is stored as a file in the superior directory whose name gives
;;; the name of the component at this level.
(DEFMETHOD (PATHNAME :PATHNAME-AS-DIRECTORY) ()
  (FUNCALL-SELF ':NEW-PATHNAME ':STRUCTURED-DIRECTORY (APPEND (IF (LISTP DIRECTORY) DIRECTORY
								  (NCONS DIRECTORY))
							      (NCONS NAME))
		':NAME ':UNSPECIFIC ':TYPE ':UNSPECIFIC ':VERSION ':UNSPECIFIC))

(DEFVAR *KNOWN-TYPES* '("QFASL" "LISP" "TEXT" NIL :UNSPECIFIC)) 

(DEFMETHOD (PATHNAME :GENERIC-PATHNAME) ()
  (FUNCALL-SELF ':NEW-PATHNAME ':TYPE (IF (MEMBER TYPE *KNOWN-TYPES*) ':UNSPECIFIC TYPE)
			       ':VERSION ':UNSPECIFIC))

;;; Create a pathname, specifying components in external syntax form.
;;; Similar to sending a :NEW-PATHNAME message to an existing pathname,
;;; except that there is no pre-existing pathname, and defaulting comes
;;; only from the (specified or default) defaults.
(DEFUN MAKE-PATHNAME (&REST OPTIONS
		      &OPTIONAL &KEY
		      (DEFAULTS *DEFAULT-PATHNAME-DEFAULTS*)
		      (HOST (PATHNAME-HOST (DEFAULT-PATHNAME DEFAULTS NIL NIL NIL T)))
		      &ALLOW-OTHER-KEYS)
  (LEXPR-FUNCALL (DEFAULT-PATHNAME DEFAULTS HOST NIL NIL T)
		 ':NEW-PATHNAME OPTIONS))

;;; Make sure that a :NEW-PATHNAME which specifies a new host
;;; is processed by the flavor of pathname for that host.
(DEFWRAPPER (PATHNAME :NEW-PATHNAME) (OPTIONS . BODY)
  `(LET ((NEW-HOST (GET (LOCF OPTIONS) ':HOST)))
     (IF (AND NEW-HOST (NEQ HOST (SETQ NEW-HOST (GET-PATHNAME-HOST NEW-HOST))))
	 (LEXPR-FUNCALL (DEFAULT-PATHNAME NIL NEW-HOST NIL NIL T)
			':NEW-PATHNAME
			':DEVICE DEVICE
			(IF (LISTP DIRECTORY) ':STRUCTURED-DIRECTORY ':DIRECTORY)
			DIRECTORY
			(IF (LISTP NAME) ':STRUCTURED-NAME ':NAME) NAME
			':TYPE TYPE
			':VERSION VERSION
			OPTIONS)
	 . ,BODY)))

;;; This is the fundamental way of altering some of the components of a pathname.
;;; Specify an alternating list of components and values.
;;; Components allowed are :HOST, :DEVICE, :DIRECTORY, :NAME, :TYPE and :VERSION;
;;; also, you can specify :STRUCTURED-DEVICE, :STRUCTURED-DIRECTORY or :STRUCTURED-NAME.
;;; Those three are equivalent to specifying :DEVICE, :DIRECTORY or :NAME
;;; but the argument is in internal format.
;;; All the :NEW-x operations call this one (by default),
;;; and all the :PARSE-x operations (except :PARSE-NAMESTRING)
;;; are called only by MAKE-PATHNAME-1, which is called only from here.
(DEFMETHOD (PATHNAME :NEW-PATHNAME) (&REST OPTIONS &AUX (PLIST (LOCF OPTIONS)))
  (LEXPR-FUNCALL #'MAKE-PATHNAME-1
		 ':HOST (OR (GET PLIST ':HOST) HOST)
		 ':DEVICE DEVICE
		 (IF (LISTP DIRECTORY) ':STRUCTURED-DIRECTORY ':DIRECTORY)
		 DIRECTORY
		 (IF (LISTP NAME) ':STRUCTURED-NAME ':NAME) NAME
		 ':TYPE TYPE
		 ':VERSION VERSION
		 OPTIONS))

(DEFUN MAKE-PATHNAME-1 (&REST OPTIONS
		      &AUX NEW-DEVICE NEW-DIRECTORY NEW-NAME NEW-TYPE NEW-VERSION
			   DEFAULTS NEW-HOST ACTOR)
  (SETQ DEFAULTS (OR (GET (LOCF OPTIONS) ':DEFAULTS) *DEFAULT-PATHNAME-DEFAULTS*)
	NEW-HOST (OR (GET (LOCF OPTIONS) ':HOST)
		     (PATHNAME-HOST (DEFAULT-PATHNAME DEFAULTS NIL NIL NIL T))))
  (SETQ ACTOR (DEFAULT-PATHNAME DEFAULTS NEW-HOST NIL NIL T))
  (TV:DOPLIST (OPTIONS VAL KEY)
    (SELECTQ KEY
      (:DEFAULTS)
      (:HOST)
      (:DEVICE (SETQ NEW-DEVICE (FUNCALL ACTOR ':PARSE-DEVICE-SPEC VAL)))
      (:STRUCTURED-DEVICE (SETQ NEW-DEVICE (FUNCALL ACTOR ':PARSE-STRUCTURED-DEVICE-SPEC
						    VAL)))
      (:DIRECTORY (SETQ NEW-DIRECTORY (FUNCALL ACTOR ':PARSE-DIRECTORY-SPEC VAL)))
      (:STRUCTURED-DIRECTORY (SETQ NEW-DIRECTORY
				   (FUNCALL ACTOR ':PARSE-STRUCTURED-DIRECTORY-SPEC VAL)))
      (:NAME (SETQ NEW-NAME (FUNCALL ACTOR ':PARSE-NAME-SPEC VAL)))
      (:STRUCTURED-NAME (SETQ NEW-NAME (FUNCALL ACTOR ':PARSE-STRUCTURED-NAME-SPEC VAL)))
      (:TYPE (SETQ NEW-TYPE (FUNCALL ACTOR ':PARSE-COMPONENT-SPEC VAL)))
      (:VERSION (SETQ NEW-VERSION VAL))
      (OTHERWISE (FERROR NIL "~S is not a recognized option" KEY))))
  (MAKE-PATHNAME-INTERNAL (GET-PATHNAME-HOST NEW-HOST) NEW-DEVICE NEW-DIRECTORY NEW-NAME
			  NEW-TYPE NEW-VERSION))

(DEFUN PATHNAME-PASS-THROUGH-SPEC (IGNORE SPEC)
  (FUNCALL-SELF ':PARSE-COMPONENT-SPEC SPEC))

;;; Default is to leave the string alone
(DEFMETHOD (PATHNAME :PARSE-COMPONENT-SPEC) (SPEC)
  SPEC)

(DEFMETHOD (PATHNAME :PARSE-DEVICE-SPEC) PATHNAME-PASS-THROUGH-SPEC)

(DEFMETHOD (PATHNAME :PARSE-STRUCTURED-DEVICE-SPEC) (SPEC)
  (AND (LISTP SPEC) (SETQ SPEC (CAR SPEC)))
  (FUNCALL-SELF ':PARSE-DEVICE-SPEC SPEC))

(DEFMETHOD (PATHNAME :PARSE-DIRECTORY-SPEC) PATHNAME-PASS-THROUGH-SPEC)

(DEFMETHOD (PATHNAME :PARSE-STRUCTURED-DIRECTORY-SPEC) (SPEC)
  (AND (LISTP SPEC) (SETQ SPEC (CAR SPEC)))
  (FUNCALL-SELF ':PARSE-DIRECTORY-SPEC SPEC))

(DEFMETHOD (PATHNAME :PARSE-NAME-SPEC) PATHNAME-PASS-THROUGH-SPEC)

(DEFMETHOD (PATHNAME :PARSE-STRUCTURED-NAME-SPEC) (SPEC)
  (AND (LISTP SPEC) (SETQ SPEC (CAR SPEC)))
  (FUNCALL-SELF ':PARSE-NAME-SPEC SPEC))

(DEFMETHOD (PATHNAME :TRANSLATED-PATHNAME) () SELF)

(DEFMETHOD (PATHNAME :BACK-TRANSLATED-PATHNAME) (PATHNAME) PATHNAME)

;;; This is used to parse a string which may not have the host in it
(DEFMETHOD (PATHNAME :PARSE-TRUENAME) (STRING)
  (PARSE-PATHNAME STRING HOST))

(DEFUN PATHNAME-LESSP (PATHNAME-1 PATHNAME-2)
  (FUNCALL PATHNAME-1 ':SORT-LESSP PATHNAME-2))

(DEFMETHOD (PATHNAME :SORT-LESSP) (OTHER-PATHNAME)
  (DO ((FIELDS '(HOST DEVICE DIRECTORY NAME TYPE VERSION) (CDR FIELDS))
       (FIELD-1) (FIELD-2))
      ((NULL FIELDS) (STRING-LESSP SELF OTHER-PATHNAME))
    (SETQ FIELD-1 (SYMEVAL (CAR FIELDS))
	  FIELD-2 (SYMEVAL-IN-INSTANCE OTHER-PATHNAME (CAR FIELDS)))
    (COND ((EQUAL FIELD-1 FIELD-2))
	  ((SYMBOLP FIELD-1)
	   (RETURN (OR (NOT (SYMBOLP FIELD-2))
		       (STRING-LESSP FIELD-1 FIELD-2))))
	  ((SYMBOLP FIELD-2)
	   (RETURN NIL))
	  ((STRINGP FIELD-1)
	   (RETURN (OR (NOT (STRINGP FIELD-2))
		       (STRING-LESSP FIELD-1 FIELD-2))))
	  ((STRINGP FIELD-2)
	   (RETURN NIL))
	  ((NUMBERP FIELD-1)
	   (RETURN (OR (NOT (NUMBERP FIELD-2))
		       (< FIELD-1 FIELD-2))))
	  ((NUMBERP FIELD-2)
	   (RETURN NIL))
	  (T
	   (RETURN (ALPHALESSP FIELD-1 FIELD-2))))))

(DEFMETHOD (PATHNAME :FASD-FORM) ()
  `(MAKE-FASLOAD-PATHNAME ',(FUNCALL HOST ':NAME-AS-FILE-COMPUTER)
			  ',DEVICE ',DIRECTORY ',NAME ',TYPE ',VERSION))

(DEFUN MAKE-FASLOAD-PATHNAME (HOST DEVICE DIRECTORY NAME TYPE VERSION &AUX PATH-HOST PATH)
  ;; Don't bomb out if the file computer that compiled this file doesn't exist any more.
  ;; Just take the one the file is being loaded from.
  (SETQ PATH-HOST (COND ((GET-PATHNAME-HOST HOST))
			(SI:FDEFINE-FILE-PATHNAME
			 (PATHNAME-HOST SI:FDEFINE-FILE-PATHNAME))
			(T USER-LOGIN-MACHINE))
	PATH (MAKE-PATHNAME-INTERNAL PATH-HOST DEVICE DIRECTORY NAME TYPE VERSION))
  ;; Record the actual host for possible debugging.
  (AND (NEQ HOST PATH-HOST)
       (FUNCALL PATH ':PUTPROP HOST ':FASLOAD-HOST))
  PATH)

(DEFVAR *PATHNAME-HASH-TABLE*)

(DEFUN MAKE-PATHNAME-INTERNAL (&REST REST &AUX TEM PATHNAME)
  (DECLARE (ARGLIST HOST DEVICE DIRECTORY NAME TYPE VERSION))
  (MULTIPLE-VALUE (PATHNAME TEM)
      (GETHASH-EQUAL REST *PATHNAME-HASH-TABLE*))
  (IF TEM
      (VALUES PATHNAME T)
      (LET ((DEFAULT-CONS-AREA PATHNAME-AREA))
	(SETQ PATHNAME (APPLY #'MAKE-PATHNAME-INTERNAL-1 REST))
	(PUTHASH-EQUAL (COPYLIST REST) PATHNAME *PATHNAME-HASH-TABLE*)
	(VALUES PATHNAME NIL))))

(DEFUN MAKE-PATHNAME-INTERNAL-1 (HOST DEVICE DIRECTORY NAME TYPE VERSION)
  (MULTIPLE-VALUE-BIND (FLAVOR-NAME OPTIONS)
      (FUNCALL HOST ':PATHNAME-FLAVOR)
    (LEXPR-FUNCALL #'MAKE-INSTANCE 
		   FLAVOR-NAME
		   ':HOST HOST ':DEVICE DEVICE ':DIRECTORY DIRECTORY
		   ':NAME NAME ':TYPE TYPE ':VERSION VERSION
		   OPTIONS)))

;;; Turn anything into a pathname
;;; WITH-RESPECT-TO is the host to parse this on.  DEFAULTS is a set of defaults.
(DEFUN PARSE-PATHNAME (THING &OPTIONAL WITH-RESPECT-TO (DEFAULTS *DEFAULT-PATHNAME-DEFAULTS*))
  (AND WITH-RESPECT-TO
       (SETQ WITH-RESPECT-TO (GET-PATHNAME-HOST WITH-RESPECT-TO)))
  (COND ((TYPEP THING 'PATHNAME) THING)
	((LISTP THING)
	 (SETQ THING (CANONICALIZE-KLUDGEY-MACLISP-PATHNAME-STRING-LIST THING))
	 (LET (DEVICE DIRECTORY NAME TYPE VERSION HOST)
	   (COND ((LISTP (CAR THING))
		  (SETF `((,DEVICE ,DIRECTORY) ,NAME ,TYPE ,VERSION) THING))
		 ((NUMBERP (THIRD THING))
		  (SETF `(,NAME ,TYPE ,VERSION ,DEVICE ,DIRECTORY) THING))
		 (T
		  (SETF `(,NAME ,TYPE ,DEVICE ,DIRECTORY ,VERSION) THING)))
	   (SETQ HOST (COND ((GET-PATHNAME-HOST DEVICE))
			    (WITH-RESPECT-TO)
			    (T (PATHNAME-HOST (DEFAULT-PATHNAME DEFAULTS NIL NIL NIL T)))))
	   (AND WITH-RESPECT-TO
		(NEQ WITH-RESPECT-TO HOST)
		(FERROR NIL "Host ~A in ~A does not match ~A" HOST THING WITH-RESPECT-TO))
	   (MAKE-PATHNAME ':DEFAULTS DEFAULTS ':HOST HOST
			  ':DEVICE DEVICE ':DIRECTORY DIRECTORY ':NAME NAME
			  ':TYPE TYPE ':VERSION VERSION)))
	(T
	 (SETQ THING (STRING THING))
	 (MULTIPLE-VALUE-BIND (HOST-SPECIFIED START END)
	     (PARSE-PATHNAME-FIND-COLON THING)
	   ;; If the thing before the colon is really a host,
	   ;; and WITH-RESPECT-TO was specified, then they had better match
	   (AND WITH-RESPECT-TO
		HOST-SPECIFIED
		(NEQ WITH-RESPECT-TO HOST-SPECIFIED)
		;; Otherwise treat it as a device name
		(SETQ HOST-SPECIFIED NIL START 0 END NIL))
	   (LET ((HOST (OR HOST-SPECIFIED WITH-RESPECT-TO
			   (PATHNAME-HOST (DEFAULT-PATHNAME DEFAULTS NIL NIL NIL T)))))
	     (MULTIPLE-VALUE-BIND (DEVICE DIRECTORY NAME TYPE VERSION)
		 (FUNCALL (DEFAULT-PATHNAME DEFAULTS HOST NIL NIL T) ':PARSE-NAMESTRING
			  (NOT (NULL HOST-SPECIFIED)) THING START END)
	       (MAKE-PATHNAME-INTERNAL HOST DEVICE DIRECTORY NAME TYPE VERSION)))))))

(DEFUN CANONICALIZE-KLUDGEY-MACLISP-PATHNAME-STRING-LIST (X)
  (COND ((OR (NULL X) (NUMBERP X)) X)
	((LISTP X) (MAPCAR #'CANONICALIZE-KLUDGEY-MACLISP-PATHNAME-STRING-LIST X))
	(T (STRING X))))

(DEFUN PARSE-PATHNAME-FIND-COLON (STRING &AUX HOST-SPECIFIED (START 0)
							     (END (STRING-LENGTH STRING)))
  (DECLARE (RETURN-LIST HOST-SPECIFIED START END))
  (DO ((IDX START (1+ IDX))
       (HOST-START START)
       (ONLY-WHITESPACE-P T)
       (CHAR))
      (( IDX END))
    (COND ((= (SETQ CHAR (AREF STRING IDX)) #/:)
	   ;; The first atom ends with a colon, take the host from that, and
	   ;; parse from the end of that.
	   (SETQ HOST-SPECIFIED (SUBSTRING STRING HOST-START IDX)
		 START (1+ IDX))
	   (RETURN))
	  ((AND (= CHAR #\SP) ONLY-WHITESPACE-P)	;Skip leading spaces
	   (SETQ HOST-START (1+ IDX)))
	  (T
	   (SETQ ONLY-WHITESPACE-P NIL)
	   (OR (AND ( CHAR #/0) ( CHAR #/9))
	       (AND ( CHAR #/A) ( CHAR #/Z))
	       (AND ( CHAR #/a) ( CHAR #/z))
	       (= CHAR #/-)
	       ;; If we get to non-alphabetic or -numeric,
	       ;; then no interesting colon
	       (RETURN)))))
  (AND (NULL HOST-SPECIFIED)
       (PLUSP END) (= (AREF STRING (1- END)) #/:)
       (SETQ HOST-SPECIFIED (STRING-REVERSE-SEARCH-CHAR #\SP STRING (1- END)))
       ;; The last character is a colon, take the host from the last atom, and
       ;; parse from the beginning to the space before that.
       (PSETQ HOST-SPECIFIED (SUBSTRING STRING (1+ HOST-SPECIFIED) (1- END))
	      END HOST-SPECIFIED))
  ;; If what looked like the host really wasn't, forget it and reset the indices
  (AND HOST-SPECIFIED
       (NULL (SETQ HOST-SPECIFIED (GET-PATHNAME-HOST HOST-SPECIFIED)))
       (SETQ START 0
	     END NIL))			;This will be interpreted correctly
  (VALUES HOST-SPECIFIED START END))

;;; Fill in slots in PATHNAME from program defaults.  This is what most
;;; programs interface to.
(DEFUN MERGE-PATHNAME-DEFAULTS (PATHNAME &OPTIONAL (DEFAULTS *DEFAULT-PATHNAME-DEFAULTS*)
						   (DEFAULT-TYPE ':UNSPECIFIC)
						   (DEFAULT-VERSION ':NEWEST)
					 &AUX HOST DEFAULT NEW-DEVICE NEW-DIRECTORY
					 NEW-NAME NEW-TYPE NEW-VERSION)
  (SETQ PATHNAME (PARSE-PATHNAME PATHNAME NIL DEFAULTS))
  ;; Host always comes from pathname
  (SETQ HOST (PATHNAME-HOST PATHNAME))
  ;; Get default for this host
  (SETQ DEFAULT (DEFAULT-PATHNAME DEFAULTS HOST))
  ;; Merge the device, directory, and name
  (LET ((PDIR (PATHNAME-DIRECTORY PATHNAME))
	(DDIR (PATHNAME-DIRECTORY DEFAULT)))
    (SETQ NEW-DIRECTORY (COND ((NULL PDIR) DDIR)
			      ((AND (LISTP PDIR) (EQ (CAR PDIR) ':RELATIVE))
			       (MERGE-RELATIVE-DIRECTORY PDIR DDIR)))))
  (OR (PATHNAME-DEVICE PATHNAME)
      (SETQ NEW-DEVICE (PATHNAME-DEVICE DEFAULT)))
  (OR (PATHNAME-NAME PATHNAME)
      (SETQ NEW-NAME (PATHNAME-NAME DEFAULT)))
  ;; Merge the type and version if the name was NIL before the above merge
  (COND ((NULL (PATHNAME-NAME PATHNAME))
	 (OR (PATHNAME-TYPE PATHNAME)
	     (SETQ NEW-TYPE (PATHNAME-TYPE DEFAULT)))
	 (OR (PATHNAME-VERSION PATHNAME)
	     (SETQ NEW-VERSION (PATHNAME-VERSION DEFAULT)))))
  (OR (PATHNAME-TYPE PATHNAME) NEW-TYPE
      (SETQ NEW-TYPE DEFAULT-TYPE))
  (OR (PATHNAME-VERSION PATHNAME) NEW-VERSION
      (SETQ NEW-VERSION DEFAULT-VERSION))
  ;; Whatever the new fields are, give them to the pathname.
  (LET (NEW-FIELDS)
    (AND NEW-NAME
	 (SETQ NEW-FIELDS (LIST* (IF (LISTP NEW-NAME) ':STRUCTURED-NAME ':NAME)
				 NEW-NAME
				 NEW-FIELDS)))
    (AND NEW-DIRECTORY
	 (SETQ NEW-FIELDS (LIST* (IF (LISTP NEW-DIRECTORY) ':STRUCTURED-DIRECTORY ':DIRECTORY)
				 NEW-DIRECTORY
				 NEW-FIELDS)))
    (AND NEW-DEVICE
	 (SETQ NEW-FIELDS (LIST* (IF (LISTP NEW-DEVICE) ':STRUCTURED-DEVICE ':DEVICE)
				 NEW-DEVICE
				 NEW-FIELDS)))
    (AND NEW-TYPE
	 (SETQ NEW-FIELDS (LIST* ':TYPE
				 NEW-TYPE
				 NEW-FIELDS)))
    (AND NEW-VERSION
	 (SETQ NEW-FIELDS (LIST* ':VERSION
				 NEW-VERSION
				 NEW-FIELDS)))
    (LEXPR-FUNCALL PATHNAME ':NEW-PATHNAME NEW-FIELDS)))

;;; A relative directory is one whose CAR is :RELATIVE and whose CDR is a a list of
;;; strings and special symbols.  The symbol :UP means step up in the hierarchy.
;;; Strings are just added onto the end of the default.
;;; E.g. (:relative "foo") ("usr" "lispm") => ("usr" "lispm" "foo")
;;;	 (:relative :up "bar") ("usr" "lispm" "foo") => ("usr" "lispm" "bar")
(DEFUN MERGE-RELATIVE-DIRECTORY (RELATIVE DEFAULT &AUX DIRECTORY)
  (SETQ DIRECTORY (COND ((OR (NULL DEFAULT) (EQ DEFAULT ':ROOT)) NIL)
			((ATOM DEFAULT) (NCONS DEFAULT))
			(T (COPYLIST DEFAULT))))
  (DOLIST (REL (CDR RELATIVE))
    (IF (EQ REL ':UP)
	(IF (NULL DIRECTORY)
	    (FERROR NIL "There is no superior to the root")
	    (DO ((L DIRECTORY (CDR L))
		 (OL (LOCF DIRECTORY) L))
		((NULL (CDR L)) (RPLACD OL NIL))))
	(SETQ DIRECTORY (NCONC DIRECTORY (NCONS REL)))))
  (AND (NULL (CDR DIRECTORY))
       (SETQ DIRECTORY (CAR DIRECTORY)))
  DIRECTORY)

;;; Another handy user interface, fills in from defaults and updates them.  Useful when
;;; not prompting.
(DEFUN MERGE-AND-SET-PATHNAME-DEFAULTS (PATHNAME
					&OPTIONAL (DEFAULTS *DEFAULT-PATHNAME-DEFAULTS*)
						  (DEFAULT-TYPE ':UNSPECIFIC)
						  (DEFAULT-VERSION ':NEWEST))
  (SETQ PATHNAME (MERGE-PATHNAME-DEFAULTS PATHNAME DEFAULTS DEFAULT-TYPE DEFAULT-VERSION))
  (AND (LISTP DEFAULTS) (SET-DEFAULT-PATHNAME PATHNAME DEFAULTS))
  PATHNAME)

(DEFMETHOD (PATHNAME :DEFAULT-NAMESTRING) (NAMESTRING &OPTIONAL (DEFAULT-TYPE ':UNSPECIFIC)
								(DEFAULT-VERSION ':NEWEST))
  (MERGE-PATHNAME-DEFAULTS NAMESTRING SELF DEFAULT-TYPE DEFAULT-VERSION))

;;; The default is not to have completion at all
(DEFMETHOD (PATHNAME :COMPLETE-STRING) (STRING IGNORE)
  (VALUES (STRING-APPEND (FUNCALL HOST ':NAME-AS-FILE-COMPUTER) ": " STRING)
	  NIL))

(DEFMETHOD (PATHNAME :MULTIPLE-FILE-PLISTS) (FILES OPTIONS &AUX (CHARACTERS T))
  (LOOP FOR (IND OPT) ON OPTIONS BY 'CDDR
	DO (SELECTQ IND
	     (:CHARACTERS (SETQ CHARACTERS OPT))
	     (OTHERWISE (FERROR NIL "~S is not a known MULTIPLE-FILE-PLISTS option" IND))))
  (LOOP FOR FILE IN FILES
	AS STREAM = (OPEN FILE ':DIRECTION NIL ':ERROR NIL ':CHARACTERS CHARACTERS)
	COLLECT (CONS FILE (AND (NOT (STRINGP STREAM))
				(LET* ((LIST (FUNCALL STREAM ':PLIST))
				       (PLIST (LOCF LIST)))
				  (OR (GET PLIST ':TRUENAME)
				      (PUTPROP PLIST (FUNCALL STREAM ':TRUENAME) ':TRUENAME))
				  LIST)))))

(DEFMETHOD (PATHNAME :UNDELETE) (ERROR-P)
  (CHANGE-FILE-PROPERTIES SELF ERROR-P ':DELETED NIL))

(DEFUN DESCRIBE-PATHNAME (PATHNAME)
  (IF (TYPEP PATHNAME 'PATHNAME)
      (DESCRIBE-PATHNAME-1 PATHNAME)
      (SETQ PATHNAME (PARSE-PATHNAME PATHNAME))
      (LOCAL-DECLARE ((SPECIAL *HOST* *DEVICE* *DIRECTORY* *NAME* *TYPE* *VERSION*))
	(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)))
	  (MAPHASH-EQUAL #'(LAMBDA (KEY VAL)
			     (AND (OR (NULL *HOST*) (EQ *HOST* (FIRST KEY)))
				  (OR (NULL *DEVICE*) (EQUAL *DEVICE* (SECOND KEY)))
				  (OR (NULL *DIRECTORY*) (EQUAL *DIRECTORY* (THIRD KEY)))
				  (OR (NULL *NAME*) (EQUAL *NAME* (FOURTH KEY)))
				  (OR (NULL *TYPE*) (EQUAL *TYPE* (FIFTH KEY)))
				  (OR (NULL *VERSION*) (EQUAL *VERSION* (SIXTH KEY)))
				  (DESCRIBE-PATHNAME-1 VAL)))
			 *PATHNAME-HASH-TABLE*)))))

(DEFUN DESCRIBE-PATHNAME-1 (PATHNAME &AUX PLIST)
  (AND (SETQ PLIST (PATHNAME-PROPERTY-LIST PATHNAME))
       (LET ((LOADED-IDS (GET (LOCF PLIST) ':FILE-ID-PACKAGE-ALIST)))
	 (AND LOADED-IDS
	      (DO ((LOADED-IDS LOADED-IDS (CDR LOADED-IDS))
		   (FIRST-P T NIL)
		   (INFO) (TRUENAME) (CREATION-DATE))
		  ((NULL LOADED-IDS))
		(SETQ INFO (CADAR LOADED-IDS)
		      TRUENAME (CAR INFO)
		      CREATION-DATE (CDR INFO))
		(FORMAT T "~&The version ~:[~*~;of ~A ~]in package ~A ~:[is ~A, and ~;~*~]~
			     was created ~\TIME\~%"
			FIRST-P PATHNAME (CAAR LOADED-IDS) (EQ PATHNAME TRUENAME) TRUENAME
			CREATION-DATE)))
	 (DO ((PLIST PLIST (CDDR PLIST))
	      (FLAG NIL)
	      (IND) (PROP))
	     ((NULL PLIST))
	   (SETQ IND (CAR PLIST)
		 PROP (CADR PLIST))
	   (COND ((NEQ IND ':FILE-ID-PACKAGE-ALIST)
		  (COND ((NULL FLAG)
			 (FORMAT T "~&~A has the following ~:[other ~]properties:~%"
				 PATHNAME (NULL LOADED-IDS))
			 (SETQ FLAG T)))
		  (FORMAT T "~&~7X~S:~27T~S~%" IND PROP)))))))

(DEFUN PATHNAME-PLIST (PATHNAME)
  (PATHNAME-PROPERTY-LIST (MERGE-PATHNAME-DEFAULTS PATHNAME)))

(DEFUN INIT-FILE-PATHNAME (PROGRAM-NAME &OPTIONAL (HOST USER-LOGIN-MACHINE) FORCE-P)
  (FUNCALL (USER-HOMEDIR HOST FORCE-P) ':INIT-FILE (STRING PROGRAM-NAME)))

(DEFMETHOD (PATHNAME :TRUENAME) (&OPTIONAL (ERROR-P T))
  (WITH-OPEN-FILE (STREAM SELF '(:PROBE))
    (IF (STRINGP STREAM)
	(AND ERROR-P
	     (FILE-PROCESS-ERROR STREAM SELF NIL))
	(FUNCALL STREAM ':TRUENAME))))

;;; This isn't implemented as a separate file subprotocol, just use the directory
;;; This has bugs on the ITS file server, where non-existent file returns an
;;; empty list for the directory, and non-existent directory comes back as an
;;; asynchronous mark rather than a command error and hence is not subject to ERROR-P.
;;; Maybe someone will fix these someday.
(DEFMETHOD (PATHNAME :PROPERTIES) (ERROR-P)
  (LET ((DIR (FUNCALL-SELF ':DIRECTORY-LIST '(:NOERROR :DELETED))))
    (COND ((LISTP DIR) (VALUES (CADR DIR) (GET (CAR DIR) ':SETTABLE-PROPERTIES)))
	  ((NOT ERROR-P) DIR)
	  (T (FILE-PROCESS-ERROR DIR SELF NIL)))))

(DEFVAR *PATHNAME-HOST-LIST* NIL)

(DEFUN GET-PATHNAME-HOST (HOST-NAME)
  (COND ((AND (TYPEP HOST-NAME 'SI:BASIC-HOST)
	      (MEMQ HOST-NAME *PATHNAME-HOST-LIST*))
	 HOST-NAME)
	(T
	 (LOOP FOR HOST IN *PATHNAME-HOST-LIST*
	       WHEN (FUNCALL HOST ':PATHNAME-HOST-NAMEP HOST-NAME)
	       RETURN HOST))))

;;; These are the defaults you get if you don't get anything else.
(DEFVAR *DEFAULT-PATHNAME-DEFAULTS*)

;;; This is a user variable, it says whether defaults are maintained on a per-host basis, or
;;; one default for all hosts.
(DEFVAR *DEFAULTS-ARE-PER-HOST* NIL)

;;; Returns an alist that you can pass to the functions below that take a set of defaults.
(DEFUN MAKE-PATHNAME-DEFAULTS (&AUX LIST)
  (SETQ LIST (MAKE-LIST NIL (1+ (LENGTH *PATHNAME-HOST-LIST*))))
  (DO ((L2 LIST (CDR L2))
       (L1 *PATHNAME-HOST-LIST* (CDR L1)))
      ((NULL L2))
    (SETF (CAR L2) (NCONS (CAR L1))))
  LIST)

(DEFUN COPY-PATHNAME-DEFAULTS (DEFAULTS)
  (COPYALIST DEFAULTS))

;;; Returns the default for the given host from defaults.
;;; INTERNAL-P means this function is being called from inside the parsing function and
;;; cannot do any parsing itself, but must just return something to accept messages.
;;; DEFAULTS can also be an atom, which is used as a default.
(DEFUN DEFAULT-PATHNAME (&OPTIONAL DEFAULTS HOST DEFAULT-TYPE DEFAULT-VERSION INTERNAL-P
			 &AUX ELEM PATHNAME HOST-TO-USE)
  (OR DEFAULTS
      (SETQ DEFAULTS *DEFAULT-PATHNAME-DEFAULTS*))
  (AND HOST (SETQ HOST (GET-PATHNAME-HOST HOST)))
  (COND ((NLISTP DEFAULTS)
	 (SETQ PATHNAME (PARSE-PATHNAME DEFAULTS)))
	(T
	 (SETQ ELEM (COND ((NOT *DEFAULTS-ARE-PER-HOST*) (ASSQ NIL DEFAULTS))
			  (HOST (ASSQ HOST DEFAULTS))
			  (T (DOLIST (DEFAULT DEFAULTS)	;Last host mentioned
			       (AND (CDR DEFAULT) (RETURN DEFAULT))))))
	 ;; If none better found, take the one for the login machine
	 (OR (CDR ELEM)
	     (SETQ ELEM (OR (ASSQ USER-LOGIN-MACHINE DEFAULTS)
			    (NCONS USER-LOGIN-MACHINE))))
	 ;; If there isn't one already, build a pathname from the host of this one
	 (SETQ HOST-TO-USE (OR HOST (CAR ELEM) (PATHNAME-HOST (CDR ELEM))))
	 (COND ((SETQ PATHNAME (CDR ELEM)))
	       (INTERNAL-P
		(SETQ PATHNAME (MAKE-PATHNAME-INTERNAL HOST-TO-USE NIL NIL NIL NIL NIL)))
	       (T
		(SETQ PATHNAME (FUNCALL (USER-HOMEDIR HOST-TO-USE) ':NEW-PATHNAME
					':NAME "FOO" ':TYPE "LISP" ':VERSION ':NEWEST))
		(SETF (CDR ELEM) PATHNAME)))))
  ;; If default-type or default-version was given, or the host has changed,
  ;; merge those in.
  (AND (OR (AND HOST (NEQ HOST (PATHNAME-HOST PATHNAME))) DEFAULT-TYPE DEFAULT-VERSION)
       (IF INTERNAL-P
	   (AND HOST (SETQ PATHNAME (MAKE-PATHNAME-INTERNAL HOST NIL NIL NIL NIL NIL)))
	   (SETQ PATHNAME (FUNCALL PATHNAME ':NEW-PATHNAME
				   ':HOST (OR HOST (PATHNAME-HOST PATHNAME))
				   ':TYPE (OR DEFAULT-TYPE (PATHNAME-TYPE PATHNAME))
				   ':VERSION (OR DEFAULT-VERSION (PATHNAME-VERSION PATHNAME))
				   ))))
  PATHNAME)

;;; Sets the default for either the host of the pathname or the NIL default.
(DEFUN SET-DEFAULT-PATHNAME (PATHNAME &OPTIONAL (DEFAULTS *DEFAULT-PATHNAME-DEFAULTS*)
				      &AUX ELEM)
  (SETQ PATHNAME (PARSE-PATHNAME PATHNAME NIL DEFAULTS))
  (OR (SETQ ELEM (ASSQ (PATHNAME-HOST PATHNAME) DEFAULTS))
      (SETQ ELEM (NCONS (PATHNAME-HOST PATHNAME))))
  (SETF (CDR ELEM) PATHNAME)
  (PULL ELEM DEFAULTS)				;This is the default host
  (AND (NOT *DEFAULTS-ARE-PER-HOST*)
       (SETQ ELEM (ASSQ NIL DEFAULTS))
       (SETF (CDR ELEM) PATHNAME))
  PATHNAME)

;;; Move ITEM to the front of LIST destructively
(DEFUN PULL (ITEM LIST)
  (DO ((LS LIST (CDR LS))
       (IT ITEM))
      ((NULL LS)
       (SETQ LIST (NCONC LIST (NCONS IT))))
    (SETF (CAR LS) (PROG1 IT (SETQ IT (CAR LS))))
    (AND (EQ ITEM IT) (RETURN)))
  LIST)

;;;; ITS support
;;; An FN2 can be either a version, if it is all numbers, or a type otherwise.
(DEFFLAVOR ITS-PATHNAME-MIXIN () ()
  (:INCLUDED-FLAVORS PATHNAME))

(DEFMETHOD (ITS-PATHNAME-MIXIN :STRING-FOR-HOST) ()
  (FORMAT NIL "~A: ~A; ~A ~A" DEVICE (STRING-OR-WILD DIRECTORY)
	  (ITS-FN1-STRING) (ITS-FN2-STRING)))

(DEFMETHOD (ITS-PATHNAME-MIXIN :STRING-FOR-PRINTING) ()
  (FORMAT NIL "~A: ~:[~A;~:[ ~]~;~2*~]~@[~A~]~@[ ~A~]"
	  (ITS-DEVICE-STRING) (MEMQ DIRECTORY '(NIL :UNSPECIFIC)) 
	  (STRING-OR-WILD DIRECTORY)
	  (AND (MEMQ NAME '(NIL :UNSPECIFIC))
	       (MEMQ TYPE '(NIL :UNSPECIFIC))
	       (MEMQ VERSION '(NIL :UNSPECIFIC)))
	  (ITS-FN1-STRING) (ITS-FN2-STRING)))

(DEFMETHOD (ITS-PATHNAME-MIXIN :STRING-FOR-EDITOR) ()
  (FORMAT NIL "~A ~A ~:[~A: ~;~*~]~A; ~A:"
	  (ITS-FN1-STRING) (ITS-FN2-STRING)
	  (OR (MEMBER DEVICE '("DSK" NIL :UNSPECIFIC))
	      (EQUAL DEVICE (FUNCALL HOST ':NAME-AS-FILE-COMPUTER)))
	  DEVICE	  
	  (STRING-OR-WILD DIRECTORY)
	  (FUNCALL HOST ':NAME-AS-FILE-COMPUTER)))

(DEFMETHOD (ITS-PATHNAME-MIXIN :STRING-FOR-DIRECTORY) ()
  (FORMAT NIL "~:[~A: ~;~*~]~A;"
	  (MEMBER DEVICE '("DSK" NIL :UNSPECIFIC))
	  DEVICE
	  (STRING-OR-WILD DIRECTORY)))

(DEFMETHOD (ITS-PATHNAME-MIXIN :STRING-FOR-DIRED) ()
  (FORMAT NIL "~6A ~A" (ITS-FN1-STRING T) (ITS-FN2-STRING T)))

(DEFMETHOD (ITS-PATHNAME-MIXIN :FN1) ()
  (ITS-FN1-STRING T T))

(DEFMETHOD (ITS-PATHNAME-MIXIN :FN2) ()
  (ITS-FN2-STRING T))

;;; If the device is DSK, avoid printing it.
(DECLARE-FLAVOR-INSTANCE-VARIABLES (ITS-PATHNAME-MIXIN)
(DEFUN ITS-DEVICE-STRING (&AUX HOSTS)
  (SETQ HOSTS (FUNCALL HOST ':NAME-AS-FILE-COMPUTER))
  (IF (OR (MEMBER DEVICE '("DSK" NIL :UNSPECIFIC))
	  (EQUAL DEVICE HOSTS))
      HOSTS
      (STRING-APPEND HOSTS ": " DEVICE))))

;;; If name is structured, its first component is the FN1 and second is FN2
;;; If only FN2 is present, FN1 is placeholder ""
(DECLARE-FLAVOR-INSTANCE-VARIABLES (ITS-PATHNAME-MIXIN)
(DEFUN ITS-FN1-STRING (&OPTIONAL NO-QUOTE-P NO-PLACEHOLDER)
  (COND	((MEMQ NAME '(NIL :UNSPECIFIC))
	 (IF (OR NO-PLACEHOLDER
		 (AND (MEMQ TYPE '(NIL :UNSPECIFIC)) (MEMQ VERSION '(NIL :UNSPECIFIC))))
	     NIL ""))
	((LISTP NAME) (IF NO-QUOTE-P (CAR NAME)
			  (QUOTE-COMPONENT-STRING (CAR NAME))))
	(T (STRING-OR-WILD NAME NO-QUOTE-P)))))

(DEFUN STRING-OR-WILD (FIELD &OPTIONAL NO-QUOTE-P)
  (COND ((EQ FIELD ':WILD) "*")
	(NO-QUOTE-P (STRING FIELD))
	((QUOTE-COMPONENT-STRING FIELD))))

(DEFUN QUOTE-COMPONENT-STRING (STRING &AUX LENGTH)
  (SETQ STRING (STRING STRING)
	LENGTH (STRING-LENGTH STRING))
  (DO ((NSTRING NIL)
       (QUOTE-IDX 0 NQUOTE-IDX)
       (NQUOTE-IDX -1))
      (NIL)
    (SETQ NQUOTE-IDX
	  (DO ((I (1+ NQUOTE-IDX) (1+ I)))
	      (( I LENGTH))
	    (AND (FUNCALL-SELF ':CHARACTER-NEEDS-QUOTING-P (AREF STRING I))
		 (RETURN I))))
    (AND (OR NQUOTE-IDX NSTRING)
	 (SETQ NSTRING (IF NSTRING
			   (STRING-APPEND NSTRING
					  (FUNCALL-SELF ':QUOTE-CHARACTER)
					  (SUBSTRING STRING QUOTE-IDX NQUOTE-IDX))
			   (SUBSTRING STRING QUOTE-IDX NQUOTE-IDX))))
    (OR NQUOTE-IDX
	(RETURN (OR NSTRING STRING)))))

(DEFMETHOD (ITS-PATHNAME-MIXIN :QUOTE-CHARACTER) () #/)

(DEFMETHOD (ITS-PATHNAME-MIXIN :CHARACTER-NEEDS-QUOTING-P) (CH)
  (MEMQ CH '(#/; #/: #\SP)))

(DEFVAR *ITS-UNINTERESTING-TYPES* '("LISP" "TEXT" NIL :UNSPECIFIC))

(DECLARE-FLAVOR-INSTANCE-VARIABLES (ITS-PATHNAME-MIXIN)
(DEFUN ITS-FN2-STRING (&OPTIONAL NO-QUOTE-P)
  (COND ((AND (LISTP NAME) (CDR NAME))
	 (IF NO-QUOTE-P (CADR NAME) (QUOTE-COMPONENT-STRING (CADR NAME))))
	((AND (MEMQ TYPE '(NIL :UNSPECIFIC))
	      (MEMQ VERSION '(NIL :UNSPECIFIC)))
	 NIL)
	((EQ VERSION ':OLDEST) "<")
	((OR (EQ VERSION ':UNSPECIFIC) (NOT (MEMBER TYPE *ITS-UNINTERESTING-TYPES*)))
	 (STRING-OR-WILD TYPE NO-QUOTE-P))
	((EQ VERSION ':WILD) "*")
	((NOT (MEMQ VERSION '(NIL :UNSPECIFIC :NEWEST))) (FORMAT NIL "~D" VERSION))
	(T ">"))))

;;; For most components, just upcase the string
(DEFMETHOD (ITS-PATHNAME-MIXIN :PARSE-COMPONENT-SPEC) (SPEC)
  (COND ((LISTP SPEC) (MAPCAR #'(LAMBDA (X)
				  (FUNCALL-SELF ':PARSE-COMPONENT-SPEC X))
			      SPEC))
	((STRINGP SPEC) (SIX-SIXBIT-CHARACTERS SPEC))
	(T SPEC)))

(DEFMETHOD (ITS-PATHNAME-MIXIN :PARSE-STRUCTURED-NAME-SPEC) PATHNAME-PASS-THROUGH-SPEC)

;;; Parse an its pathname string.   and  are quoting characters.
(DEFMETHOD (ITS-PATHNAME-MIXIN :PARSE-NAMESTRING) (HOST-SPECIFIED NAMESTRING
					     &OPTIONAL (START 0) END)
  (OR END (SETQ END (STRING-LENGTH NAMESTRING)))
  (DO ((I START)
       (J START (1+ J))
       (CH) (TEM)
       (DEV (AND HOST-SPECIFIED "DSK"))
       (DIR) (FN1) (FN1P) (FN2)
       (TYPE) (VERSION))
      ((> J END)
       (COND ((NULL FN2))
	     ((SETQ TEM (NUMERIC-P FN2))
	      (SETQ VERSION TEM TYPE ':UNSPECIFIC))
	     ((EQUAL FN2 ">")
	      (SETQ VERSION ':NEWEST TYPE ':UNSPECIFIC))
	     ((EQUAL FN2 "<")
	      (SETQ VERSION ':OLDEST TYPE ':UNSPECIFIC))
	     ((MEMBER FN2 *ITS-UNINTERESTING-TYPES*)
	      (SETQ TYPE FN2 VERSION ':UNSPECIFIC))
	     (T
	      (SETQ TYPE FN2 VERSION ':NEWEST)))
       (VALUES DEV DIR FN1 TYPE VERSION))
    (SETQ CH (IF (= J END) #\SP (AREF NAMESTRING J)))
    (COND ((MEMQ CH '(#/ #/))
	   (SETQ J (1+ J)))
	  ((MEMQ CH '(#/: #/; #/ #\SP #\TAB))
	   (COND (( I J)
		  (SETQ TEM (SIX-SIXBIT-CHARACTERS NAMESTRING T I J))
		  (SELECTQ CH
		    (#/: (SETQ DEV TEM))
		    (#/; (SETQ DIR TEM))
		    (OTHERWISE
		     (COND (FN2)
			   (FN1P (SETQ FN2 TEM))
			   (T (SETQ FN1 TEM FN1P T)))))))
	   (IF (EQ CH #/) (SETQ FN1P T))
	   (SETQ I (1+ J))))))

;;; Truncate to six characters
(DEFUN SIX-SIXBIT-CHARACTERS (STRING &OPTIONAL QUOTE-P (START 0) (END (STRING-LENGTH STRING)))
  (DO ((I START (1+ I))
       (NCH 0) (CH)
       (NEED-COPY NIL))
      ((OR ( I END) (= NCH 6))
       (COND ((AND (= START 0) (= I (STRING-LENGTH STRING)) (NOT NEED-COPY))
	      STRING)				;To avoid consing
	     ((NOT NEED-COPY)
	      (SUBSTRING STRING START I))
	     (T
	      (DO ((NSTRING (MAKE-ARRAY NCH ':TYPE 'ART-STRING))
		   (J 0)
		   (K START (1+ K))
		   (CH))
		  (( K I) NSTRING)
		(SETQ CH (AREF STRING K))
		(COND ((NOT (AND QUOTE-P (MEMQ CH '(#/ #/))))
		       (SETQ CH (COND ((< CH 40) (+ CH 40))
				      ((< CH 140) CH)
				      (T (- CH 40))))
		       (ASET CH NSTRING J)
		       (SETQ J (1+ J))))))))
    (SETQ CH (AREF STRING I))
    (IF (AND QUOTE-P (MEMQ CH '(#/ #/)))
	(SETQ NEED-COPY T)
	(SETQ NCH (1+ NCH)))
    (OR (AND ( CH #\SP) ( CH #/_))		;Already legal SIXBIT
	(SETQ NEED-COPY T))))

;;; Return number if string is all digits, else NIL
(DEFUN NUMERIC-P (STRING &OPTIONAL PARTIAL-OK SIGN-OK)
  (DO ((I 0 (1+ I))
       (LEN (STRING-LENGTH STRING))
       (NUM NIL)
       (SIGN 1)
       (CH))
      (( I LEN)
       (AND NUM (* NUM SIGN)))
    (SETQ CH (AREF STRING I))
    (COND ((AND SIGN-OK
		(ZEROP I)
		(MEMQ CH '(#/+ #/-)))
	   (IF (EQ CH #/+)
	       (SETQ SIGN 1)
	       (SETQ SIGN -1)))
	  ((AND ( #/9 CH)
		( CH #/0))
	   (SETQ NUM (+ (- CH #/0) (IF NUM (* NUM 10.) 0))))
	  (PARTIAL-OK
	   (RETURN (AND NUM (* NUM SIGN)) I))
	  (T (RETURN NIL)))))

(DEFMETHOD (ITS-PATHNAME-MIXIN :INIT-FILE) (PROGRAM-NAME)
  (FUNCALL-SELF ':NEW-PATHNAME ':NAME USER-ID
			       ':TYPE PROGRAM-NAME
			       ':VERSION ':NEWEST))

;;; These are for things like the microcode files that need to compact both a name and a type
;;; into one pathname.
(DEFMETHOD (ITS-PATHNAME-MIXIN :NEW-TYPE-AND-VERSION) (NEW-TYPE NEW-VERSION)
  (FUNCALL-SELF ':NEW-PATHNAME ':TYPE (SIX-SIXBIT-CHARACTERS (FORMAT NIL "~D~A"
								     (\ NEW-VERSION 1000.)
								     NEW-TYPE))
			       ':VERSION ':NEWEST))

(DEFMETHOD (ITS-PATHNAME-MIXIN :TYPE-AND-VERSION) (&AUX TYP VERS I)
  (COND ((STRINGP TYPE)
	 (MULTIPLE-VALUE (VERS I) (NUMERIC-P TYPE T))
	 (AND I (SETQ TYP (SUBSTRING TYPE I)))
	 (VALUES TYP VERS))
	(T (VALUES TYPE TYPE))))

;;; Patch system interface, more kludges for only six character filenames
(DEFMETHOD (ITS-PATHNAME-MIXIN :PATCH-FILE-PATHNAME) (NAM SAME-DIRECTORY-P PATOM TYP
						      &REST ARGS)
  (SELECTQ TYP
    (:SYSTEM-DIRECTORY
     (FUNCALL-SELF ':NEW-PATHNAME ':NAME (IF SAME-DIRECTORY-P PATOM NAM)
		   ':TYPE "(PDIR)" ':VERSION ':NEWEST))
    (:VERSION-DIRECTORY
     (FUNCALL-SELF ':NEW-PATHNAME ':NAME (FORMAT NIL "~:[~A~3*~;~*~C~C~C~]~D"
						 SAME-DIRECTORY-P (SI:SYSTEM-SHORT-NAME NAM)
						 (AREF PATOM 0) (AREF PATOM 1) (AREF PATOM 2)
						 (\ (CAR ARGS) 1000.))
		   ':TYPE "(PDIR)" ':VERSION ':NEWEST))
    (:PATCH-FILE
     (FUNCALL-SELF ':NEW-PATHNAME ':NAME (FORMAT NIL "~:[~*~;~C~]~D.~D"
						 SAME-DIRECTORY-P PATOM
						 (\ (CAR ARGS) 100.)
						 (\ (CADR ARGS)
						    (IF SAME-DIRECTORY-P 100. 1000.)))
		   ':TYPE (CADDR ARGS) ':VERSION ':NEWEST))))
  
;;;; TOPS-20 support
(DEFFLAVOR TOPS20-PATHNAME-MIXIN () ()
  (:INCLUDED-FLAVORS PATHNAME))

(DEFMETHOD (TOPS20-PATHNAME-MIXIN :STRING-FOR-HOST) ()
  (LET ((DIR-DELIM (CAR (FUNCALL-SELF ':DIRECTORY-DELIMITERS))))
    (FORMAT NIL "~A:~C~A~C~A.~:[~A~;~*~]~@[~A~]"
	    (STRING-OR-WILD DEVICE)
	    (CAR DIR-DELIM) (TOPS20-DIRECTORY-NAME) (CDR DIR-DELIM)
	    (STRING-OR-WILD NAME)
	    (MEMQ TYPE '(NIL :UNSPECIFIC)) (FUNCALL-SELF ':CONVERT-TYPE-FOR-HOST TYPE)
	    (TOPS20-VERSION-STRING))))

(DEFMETHOD (TOPS20-PATHNAME-MIXIN :STRING-FOR-PRINTING) ()
  (LET ((DIR-DELIM (CAR (FUNCALL-SELF ':DIRECTORY-DELIMITERS))))
    (FORMAT NIL "~A:~:[~A:~;~*~]~@[~C~A~C~]~:[~A~;~*~]~:[.~A~;~*~]~@[~A~]"
	    (FUNCALL HOST ':NAME-AS-FILE-COMPUTER)
	    (MEMBER DEVICE (FUNCALL-SELF ':SUPPRESSED-DEVICE-NAMES)) (STRING-OR-WILD DEVICE)
	    (CAR DIR-DELIM) (TOPS20-DIRECTORY-NAME) (CDR DIR-DELIM)
	    (MEMQ NAME '(NIL :UNSPECIFIC)) (STRING-OR-WILD NAME)
	    (MEMQ TYPE '(NIL :UNSPECIFIC)) (FUNCALL-SELF ':CONVERT-TYPE-FOR-HOST TYPE)
	    (TOPS20-VERSION-STRING))))

(DEFMETHOD (TOPS20-PATHNAME-MIXIN :STRING-FOR-EDITOR) ()
  (LET ((DIR-DELIM (CAR (FUNCALL-SELF ':DIRECTORY-DELIMITERS))))
    (FORMAT NIL "~:[~A~;~*~].~:[~A~;~*~]~@[~A~] ~:[~A~;~*~]:~@[~C~A~C~] ~A:"
	    (MEMQ NAME '(NIL :UNSPECIFIC)) (STRING-OR-WILD NAME)
	    (MEMQ TYPE '(NIL :UNSPECIFIC)) (FUNCALL-SELF ':CONVERT-TYPE-FOR-HOST TYPE)
	    (TOPS20-VERSION-STRING)
	    (MEMQ DEVICE '(NIL :UNSPECIFIC)) (STRING-OR-WILD DEVICE)
	    (CAR DIR-DELIM) (TOPS20-DIRECTORY-NAME) (CDR DIR-DELIM)
	    (FUNCALL HOST ':NAME-AS-FILE-COMPUTER))))

(DEFMETHOD (TOPS20-PATHNAME-MIXIN :STRING-FOR-DIRED) ()
  (FORMAT NIL "~:[~A~;~*~].~:[~A~;~*~]~@[~A~]"
	  (MEMQ NAME '(NIL :UNSPECIFIC)) (STRING-OR-WILD NAME)
	  (MEMQ TYPE '(NIL :UNSPECIFIC)) (FUNCALL-SELF ':CONVERT-TYPE-FOR-HOST TYPE)
	  (TOPS20-VERSION-STRING)))

(DEFMETHOD (TOPS20-PATHNAME-MIXIN :STRING-FOR-DIRECTORY) ()
  (LET ((DIR-DELIM (CAR (FUNCALL-SELF ':DIRECTORY-DELIMITERS))))
    (FORMAT NIL "~:[~A:~;~*~]~@[~C~A~C>~]"
	  (MEMBER DEVICE (FUNCALL-SELF ':SUPPRESSED-DEVICES)) (STRING-OR-WILD DEVICE)
	  (CAR DIR-DELIM) (TOPS20-DIRECTORY-NAME) (CDR DIR-DELIM))))

(DECLARE-FLAVOR-INSTANCE-VARIABLES (TOPS20-PATHNAME-MIXIN)
(DEFUN TOPS20-DIRECTORY-NAME ()
  (COND ((MEMQ DIRECTORY '(NIL :UNSPECIFIED)) NIL)
	((NLISTP DIRECTORY) (STRING-OR-WILD DIRECTORY))
	(T (FORMAT NIL "~{~A~^.~}" DIRECTORY)))))

(DEFMETHOD (TOPS20-PATHNAME-MIXIN :CONVERT-TYPE-FOR-HOST) (TYPE)
  (STRING-OR-WILD TYPE))

(DEFMETHOD (TOPS20-PATHNAME-MIXIN :CONVERT-TYPE-FOR-LISPM) (TYPE) TYPE)

(DEFMETHOD (TOPS20-PATHNAME-MIXIN :VERSION-DELIMITER) () #/.)
(DEFMETHOD (TOPS20-PATHNAME-MIXIN :DIRECTORY-DELIMITERS) () '((#/< . #/>)))

(DECLARE-FLAVOR-INSTANCE-VARIABLES (TOPS20-PATHNAME-MIXIN)
(DEFUN TOPS20-VERSION-STRING ()
  (AND (NOT (MEMQ VERSION '(NIL :UNSPECIFIC :NEWEST)))
       (FORMAT NIL "~C~D"
	       (FUNCALL-SELF ':VERSION-DELIMITER)
	       (SELECTQ VERSION
		 (:OLDEST -2)
		 (:WILD "*")
		 (OTHERWISE VERSION))))))

(DEFMETHOD (TOPS20-PATHNAME-MIXIN :PARSE-COMPONENT-SPEC) (SPEC)
  (COND ((LISTP SPEC) (MAPCAR #'(LAMBDA (X)
				  (FUNCALL-SELF ':PARSE-COMPONENT-SPEC X))
			      SPEC))
	((STRINGP SPEC) (TOPS20-STRING-UNTIL-DELIM SPEC NIL 0 NIL T))
	(T SPEC)))  

(DEFMETHOD (TOPS20-PATHNAME-MIXIN :PARSE-STRUCTURED-DIRECTORY-SPEC) PATHNAME-PASS-THROUGH-SPEC)

;;; If spec has dots in it, then the directory is structured.
(DEFMETHOD (TOPS20-PATHNAME-MIXIN :PARSE-DIRECTORY-SPEC) (SPEC)
  (IF (STRINGP SPEC)
      (DO ((IDX 0) (DIR NIL)
	   (TEM) (DELIM))
	  (NIL)
	(MULTIPLE-VALUE (TEM IDX DELIM)
	  (TOPS20-STRING-UNTIL-DELIM SPEC '(#/.) IDX NIL T))
	(SETQ DIR (IF (AND (MINUSP DELIM) (NULL DIR))
		      TEM
		      (NCONC DIR (NCONS TEM))))
	(AND (MINUSP DELIM) (RETURN DIR)))
      SPEC))

(DEFMETHOD (TOPS20-PATHNAME-MIXIN :PRIMARY-DEVICE) () "PS")

(DEFMETHOD (TOPS20-PATHNAME-MIXIN :SUPPRESSED-DEVICE-NAMES) () '(NIL :UNSPECIFIC))

;;; Parse a tops-20 pathname string.
(DEFMETHOD (TOPS20-PATHNAME-MIXIN :PARSE-NAMESTRING) (HOST-SPECIFIED NAMESTRING
						&OPTIONAL (START 0) END)
  (OR END (SETQ END (STRING-LENGTH NAMESTRING)))
  (LET* ((DIR-DELIM-ALIST (FUNCALL-SELF ':DIRECTORY-DELIMITERS))
	 (ALL-DELIMS (NCONC (MAPCAR #'CAR DIR-DELIM-ALIST) '(#/: #/. #/; #\SP))))
    (DO ((IDX (OR (STRING-SEARCH-NOT-CHAR #\SP NAMESTRING START END) END))
	 (TEM) (TEM1) (DELIM)
	 (DIR-DELIM)
	 (DEV)
	 (DIR) (NAM) (TYP) (VERS))
	(( IDX END)
	 (VALUES (OR DEV (AND HOST-SPECIFIED (FUNCALL-SELF ':PRIMARY-DEVICE)))
		 DIR NAM TYP VERS))
      (COND ((SETQ DIR-DELIM (CDR (ASSOC (AREF NAMESTRING IDX) DIR-DELIM-ALIST)))
	     (AND DIR
		  (FERROR NIL "Directory occurs twice in ~A" NAMESTRING))
	     (SETQ IDX (1+ IDX))
	     (DO () (NIL)
	       (MULTIPLE-VALUE (TEM IDX DELIM)
		 (TOPS20-STRING-UNTIL-DELIM NAMESTRING (LIST #/. DIR-DELIM) IDX END))
	       (SETQ DIR (IF (AND (= DELIM DIR-DELIM) (NULL DIR))
			     TEM
			     (NCONC DIR (NCONS TEM))))
	       (AND (= DELIM DIR-DELIM) (RETURN))))
	    (T
	     (MULTIPLE-VALUE (TEM IDX DELIM)
	       (TOPS20-STRING-UNTIL-DELIM NAMESTRING ALL-DELIMS IDX END T T))
	     (COND ((ASSQ DELIM DIR-DELIM-ALIST)
		    (SETQ IDX (1- IDX)))
		   ((AND (= DELIM #/;) VERS)	;Attribute like protection
		    (SETQ IDX END)))
	     (COND ((= DELIM #/:)
		    (AND DEV
			 (FERROR NIL "Device occurs twice in ~A" NAMESTRING))
		    (SETQ DEV TEM))
		   ((NULL NAM) (SETQ NAM TEM))
		   ((NULL TYP) (SETQ TYP TEM))
		   ((NULL VERS)
		    (COND ((SETQ TEM1 (NUMERIC-P TEM))
			   (SETQ VERS TEM1))
			  ((STRING-EQUAL TEM "*")
			   (SETQ VERS ':WILD))
			  ((STRING-EQUAL TEM "-2")
			   (SETQ VERS ':OLDEST))
			  (T (FERROR NIL "Version must be numeric in ~A" NAMESTRING))))))))))

;;; Internal parsing function, read the next atom from string to one of delims
;;; EOS-OK means it is alright to fall off the end of the string, that is treated
;;; as a delimiter and -1 is returned for the third value.
(DEFUN TOPS20-STRING-UNTIL-DELIM (STRING DELIMS &OPTIONAL (START 0) END EOS-OK QUOTE-P
				  &AUX IDX DELIM (NCH 0) (NEED-COPY NIL))
  (DECLARE (RETURN-LIST SUBSTRING END DELIM))
  (OR END (SETQ END (STRING-LENGTH STRING)))
  (DO ((I START (1+ I))
       (CHAR))
      (( I END)
       (OR EOS-OK (FERROR NIL "Illegal end of string in ~A" STRING))
       (SETQ IDX END DELIM -1))
    (SETQ CHAR (AREF STRING I))
    (COND ((AND QUOTE-P (= CHAR #/))
	   ;; TOPS-20 quoting character
	   (AND ( (SETQ I (1+ I)) END)
		(FERROR NIL "End of string after quote character in ~A" STRING))
	   (SETQ NEED-COPY T
		 NCH (1+ NCH)))
	  ((MEMQ CHAR DELIMS)
	   (SETQ IDX I DELIM CHAR)
	   (RETURN))
	  (T
	   (SETQ NCH (1+ NCH))
	   (AND ( CHAR #/a) ( CHAR #/z)
		(SETQ NEED-COPY T)))))
  (VALUES (COND ((AND (= START 0) (= IDX (STRING-LENGTH STRING)) (NOT NEED-COPY))
		 STRING)			;Avoid consing
		((NOT NEED-COPY)
		 (SUBSTRING STRING START IDX))
		(T
		 (DO ((SUBSTRING (MAKE-ARRAY NCH ':TYPE 'ART-STRING))
		      (I 0)
		      (J START (1+ J))
		      (QUOTE-P NIL)
		      (CHAR))
		     (( J IDX)
		      SUBSTRING)
		   (SETQ CHAR (AREF STRING J))
		   (IF (AND (NOT QUOTE-P) (= CHAR #/))
		       (SETQ QUOTE-P T)
		       (IF QUOTE-P
			   (SETQ QUOTE-P NIL)
			   (SETQ CHAR (CHAR-UPCASE CHAR)))
		       (ASET (LOGAND CHAR 177) SUBSTRING I)
		       (SETQ I (1+ I))))))
	  (1+ IDX) DELIM))

(DEFMETHOD (TOPS20-PATHNAME-MIXIN :QUOTE-CHARACTER) () #/)

(DEFMETHOD (TOPS20-PATHNAME-MIXIN :CHARACTER-NEEDS-QUOTING-P) (CH)
  (NOT (OR (AND ( CH #/A) ( CH #/Z))
	   (AND ( CH #/0) ( CH #/9))
	   (MEMQ CH '(#/# #/$ #/_ #/-))
	   ;;This isn't exactly right
	   (MEMQ CH '(#/% #/*)))))

(DEFMETHOD (TOPS20-PATHNAME-MIXIN :DIRECTORY-PATHNAME-AS-FILE)
	   DEFAULT-DIRECTORY-PATHNAME-AS-FILE)

(DECLARE-FLAVOR-INSTANCE-VARIABLES (PATHNAME)
(DEFUN DEFAULT-DIRECTORY-PATHNAME-AS-FILE (IGNORE &AUX DIR NAM)
  (COND ((EQ DIRECTORY ':ROOT)
	 (FERROR NIL "There is no pathname for the root as a file"))
	((OR (ATOM DIRECTORY) (NULL (CDR DIRECTORY)))
	 (SETQ DIR ':ROOT
	       NAM (IF (LISTP DIRECTORY) (CAR DIRECTORY) DIRECTORY)))
	(T
	 (LET ((LAST (LAST DIRECTORY)))
	   (SETQ DIR (LDIFF DIRECTORY LAST)
		 NAM (CAR LAST)))))
  (FUNCALL-SELF ':NEW-PATHNAME ':DIRECTORY DIR ':NAME NAM
		':TYPE (FUNCALL-SELF ':DIRECTORY-FILE-TYPE))))

(DEFMETHOD (TOPS20-PATHNAME-MIXIN :DIRECTORY-FILE-TYPE) ()
  "DIRECTORY")

;;;; Tenex support
(DEFFLAVOR TENEX-PATHNAME-MIXIN () (TOPS20-PATHNAME-MIXIN))

(DEFMETHOD (TENEX-PATHNAME-MIXIN :VERSION-DELIMITER) () #/;)

(DEFMETHOD (TENEX-PATHNAME-MIXIN :PRIMARY-DEVICE) () "DSK")
(DEFMETHOD (TENEX-PATHNAME-MIXIN :SUPPRESSED-DEVICE-NAMES) () '(NIL :UNSPECIFIC "DSK"))

(DEFMETHOD (TENEX-PATHNAME-MIXIN :CHARACTER-NEEDS-QUOTING-P) (CH)
  (NOT (OR (AND ( CH #/A) ( CH #/Z))
	   (AND ( CH #/0) ( CH #/9))
	   (AND ( CH #/!) ( CH #/$))
	   (AND ( CH #/&) ( CH #/)))
	   (MEMQ CH '(#/+ #// #/= #/-))
	   (AND ( CH #/[) ( CH #/^))
	   (MEMQ CH '(#/% #/*)))))

;;;; VMS support
(DEFFLAVOR VMS-PATHNAME-MIXIN () (MEANINGFUL-ROOT-MIXIN TOPS20-PATHNAME-MIXIN)
  (:INCLUDED-FLAVORS PATHNAME))

;;; ALIST of normal file types as expected by software on the LISPM,
;;; and 3-character file types expected by the VAX.
(DEFVAR *VMS-FILE-TYPE-ALIST*
	'(("LISP" . "LSP")
	  ("TEXT" . "TXT")
	  ("MIDAS" . "MID")
	  ("QFASL" . "QFS")
	  ("PRESS" . "PRS")))

(DEFMETHOD (VMS-PATHNAME-MIXIN :VERSION-DELIMITER) () #/;)

;;; I'm not sure what the right thing is here.  Maybe SYS$SYSDISK?
;;; There also needs to be some hair such that directory names are
;;; suppressed when logical names are provided with directories.
;;; Perhaps the file job should throw away the directory component
;;; if a "device" includes a directory.  I'm going to have to think
;;; about this some more.  --RWK

(DEFMETHOD (VMS-PATHNAME-MIXIN :PRIMARY-DEVICE) () ':WILD)
(DEFMETHOD (VMS-PATHNAME-MIXIN :SUPPRESSED-DEVICE-NAMES) () '(NIL :UNSPECIFIC))

;;; Let the TOPS-20 parser do the work.  Then take the
;;; result, check it against the more limited VMS constraints, and
;;; cannonicalize file types to LISPM standard file types.

(DEFWRAPPER (VMS-PATHNAME-MIXIN :PARSE-NAMESTRING) (ARGLIST . BODY)
  `(PROGN (IF (STRING-SEARCH-CHAR #/ (NTH 1 ARGLIST))
	      (FERROR () "Illegal chararacter in ~A" (NTH 1 ARGLIST)))
	  (MULTIPLE-VALUE-BIND (DEV DIR NAM TYP VRS) (PROGN ,@BODY)
	    (VMS-DEVNAME-CHECK DEV)
	    (VMS-DIRNAME-CHECK DIR)
	    (IF (EQUAL DIR "000000")
		(SETQ DIR ':ROOT))
	    (VMS-FILENAME-COMPONENT-CHECK NAM 9)	;9 alphanumeric chars
	    (VMS-FILENAME-COMPONENT-CHECK TYP 3)	;3 alphanumeric chars
	    (VALUES DEV DIR NAM TYP VRS))))

;;; There are no quoting characters possible, sigh.
(DEFMETHOD (VMS-PATHNAME-MIXIN :QUOTE-CHAR) () ())
(DEFMETHOD (VMS-PATHNAME-MIXIN :CHARACTER-NEEDS-QUOTING-P) (IGNORE) ())
(DEFMETHOD (VMS-PATHNAME-MIXIN :DIRECTORY-DELIMITERS) ()
  '((#/[ . #/]) (#/< . #/>)))

;;; The VMS character set is absurdly limited.  devname:<dir.dir.dir>name.typ,
;;; where devname can be alphanumerics plus $ and _, and the rest can be alphanumerics.

(DEFVAR VMS-DEVNAME-CHARSET "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789$_")
(DEFVAR VMS-FILENAME-CHARSET "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789")

(DEFUN VMS-DEVNAME-CHECK (DEV)
  (IF (STRING-SEARCH-NOT-SET VMS-DEVNAME-CHARSET DEV)
      (FERROR () "/"~A/" -- illegal character in VMS device name" DEV))
  (IF (> (STRING-LENGTH DEV) 63)
      (FERROR () "/"~A/" -- VMS device name too long" DEV)))

(DEFUN VMS-FILENAME-COMPONENT-CHECK (NAM &OPTIONAL (SIZE 9))
  (IF (STRING-SEARCH-NOT-SET VMS-FILENAME-CHARSET NAM)
      (FERROR () "/"~A/" -- illegal character in VMS filename component" NAM))
  (IF (> (STRING-LENGTH NAM) SIZE)
      (FERROR () "/"~A/" -- VMS filename component too long" NAM)))

(DEFUN VMS-DIRNAME-CHECK (DIR)
  (IF (STRINGP DIR)
      (VMS-FILENAME-COMPONENT-CHECK DIR 9)
     (IF (> (LENGTH DIR) 8)
	 (FERROR () "/"~A/" -- Too many VMS directory levels" DIR))
     (DOLIST (COMPONENT DIR)
       (VMS-FILENAME-COMPONENT-CHECK COMPONENT 9))))

;;; Convert a standard LISPM file type name to a standard VMS file type name.

(DEFMETHOD (VMS-PATHNAME-MIXIN :CONVERT-TYPE-FOR-HOST) (TYPE)
  (STRING-OR-WILD (LET ((CONVERT (ASSOC TYPE *VMS-FILE-TYPE-ALIST*)))
		    (IF CONVERT (CDR CONVERT) TYPE))))

(DEFMETHOD (VMS-PATHNAME-MIXIN :CONVERT-TYPE-FOR-LISPM) (TYPE)
  (STRING-OR-WILD (LET ((CONVERT (RASSOC TYPE *VMS-FILE-TYPE-ALIST*)))
		    (IF CONVERT (CAR CONVERT) TYPE))))

(DEFMETHOD (VMS-PATHNAME-MIXIN :DIRECTORY-FILE-TYPE) ()
  "DIR")

;;;; Unix and Multics support
(DEFFLAVOR UNIX-PATHNAME-MIXIN () (MEANINGFUL-ROOT-MIXIN)
  (:INCLUDED-FLAVORS PATHNAME))

(DEFMETHOD (UNIX-PATHNAME-MIXIN :DIRECTORY-PATHNAME-AS-FILE) 
	   DEFAULT-DIRECTORY-PATHNAME-AS-FILE)

(DEFMETHOD (UNIX-PATHNAME-MIXIN :DIRECTORY-FILE-TYPE) ()
  ':UNSPECIFIC)

(DEFMETHOD (UNIX-PATHNAME-MIXIN :DIRECTORY-DELIMITER-CHARACTER) () #//)

(DEFMETHOD (UNIX-PATHNAME-MIXIN :DIRECTORY-UP-DELIMITER) () "..")

(DEFUN UNIX-FILENAME (NAME TYPE &AUX (NEW-TYPE (IF TYPE TYPE "'")))
  (IF (EQ NAME ':UNSPECIFIC) (SETQ NAME ""))
  (IF (EQ NAME ':WILD)
      (IF (MEMQ TYPE '(:WILD :UNSPECIFIC))
          "*"   ;Both wild, just *
          (STRING-APPEND "*." NEW-TYPE))
    (IF (AND (NULL NAME) (MEMQ TYPE '(NIL :UNSPECIFIC)))
        ""
      (OR NAME (SETQ NAME "'"))
      (COND ((EQ TYPE ':WILD)
             (FORMAT NIL "~A.*" NAME))
            ((EQ TYPE ':UNSPECIFIC)
             NAME)
            (T
             (STRING-APPEND NAME "." NEW-TYPE))))))

(DEFMETHOD (UNIX-PATHNAME-MIXIN :STRING-FOR-HOST) ()
  (FORMAT NIL "~@[~A~]~A" (UNIX-DIRECTORY-STRING) (UNIX-FILENAME NAME TYPE)))

(DEFMETHOD (UNIX-PATHNAME-MIXIN :STRING-FOR-EDITOR) ()
  (FORMAT NIL "~A ~A ~A:"
          (UNIX-FILENAME NAME TYPE) (UNIX-DIRECTORY-STRING)
          (FUNCALL HOST ':NAME-AS-FILE-COMPUTER)))

(DEFMETHOD (UNIX-PATHNAME-MIXIN :STRING-FOR-DIRED) ()
  (UNIX-FILENAME NAME TYPE))

(DECLARE-FLAVOR-INSTANCE-VARIABLES (UNIX-PATHNAME-MIXIN)
(DEFUN UNIX-DIRECTORY-STRING ()
  (IF (MEMQ DIRECTORY '(NIL :UNSPECIFIC)) NIL
      (LET ((DIRECT DIRECTORY)
	    (SUPPRESS-DELIM NIL))
	(STRING-APPEND (COND ((EQ DIRECT ':ROOT) "")
			     ((AND (LISTP DIRECT) (EQ (CAR DIRECT) ':RELATIVE))
			      (POP DIRECT)
			      "")
			     (T
			      (FUNCALL-SELF ':DIRECTORY-DELIMITER-CHARACTER)))
		       (COND ((EQ DIRECT ':ROOT) "")
			     ((ATOM DIRECT) (UNIX-DIRECTORY-COMPONENT DIRECT))
			     ((NULL (CDR DIRECT))
			      (LET (STRING)
				(MULTIPLE-VALUE (STRING SUPPRESS-DELIM)
				  (UNIX-DIRECTORY-COMPONENT (CAR DIRECT)))
				STRING))
			     (T (LOOP FOR SUBDIR IN DIRECT
				      WITH STRING = (MAKE-ARRAY 20. ':TYPE 'ART-STRING
								':LEADER-LIST '(0))
				      AS DELIM-P = NIL THEN T
				      DO (AND DELIM-P (NOT SUPPRESS-DELIM)
					      (ARRAY-PUSH-EXTEND
						STRING
						(FUNCALL-SELF
						  ':DIRECTORY-DELIMITER-CHARACTER)))
					 (LET (SUBSTR)
					   (MULTIPLE-VALUE (SUBSTR SUPPRESS-DELIM)
					     (UNIX-DIRECTORY-COMPONENT SUBDIR))
					   (SETQ STRING (STRING-NCONC STRING SUBSTR)))
				      FINALLY (RETURN STRING))))
		     (COND (SUPPRESS-DELIM "")
			   (T (FUNCALL-SELF ':DIRECTORY-DELIMITER-CHARACTER))))))))

(DEFUN UNIX-DIRECTORY-COMPONENT (STRING)
  (SELECTQ STRING
    (:WILD "*")
    (:UP (LET ((DELIM (FUNCALL-SELF ':DIRECTORY-UP-DELIMITER)))
	   (IF (STRINGP DELIM) DELIM (VALUES (STRING DELIM) T))))
    (OTHERWISE (STRING STRING))))

(DEFMETHOD (UNIX-PATHNAME-MIXIN :PARSE-NAMESTRING) (IGNORE NAMESTRING
                                                      &OPTIONAL (START 0) END
                                                      &AUX DIR NAM TYP (VER ':UNSPECIFIC)
                                                      DELIM-CHAR DIRSTART DIREND)
  (OR END (SETQ END (STRING-LENGTH NAMESTRING)))
  (SETQ START (OR (STRING-SEARCH-NOT-CHAR #\SP NAMESTRING START END) END))
  (SETQ END (1+ (OR (STRING-REVERSE-SEARCH-NOT-CHAR #\SP NAMESTRING END START)
                    (1- START))))
  (SETQ DELIM-CHAR (FUNCALL-SELF ':DIRECTORY-DELIMITER-CHARACTER))
  (LET (I)
    (IF (AND (SETQ I (STRING-SEARCH-CHAR #\SP NAMESTRING START END))
             (CHAR-EQUAL DELIM-CHAR (AREF NAMESTRING (1- END)))
             (NOT (STRING-SEARCH-CHAR DELIM-CHAR NAMESTRING START I)))
        (SETQ DIRSTART (STRING-SEARCH-NOT-CHAR #\SP NAMESTRING I END)
              DIREND END
              END I)
      (SETQ DIRSTART START
            DIREND (STRING-REVERSE-SEARCH-CHAR DELIM-CHAR NAMESTRING END START)
            START (IF DIREND (1+ DIREND) START))))
  ;; Now START..END are the indices around the name and type,
  ;; and DIRSTART..DIREND are the indices around the directory.
  (WHEN DIREND
    (SETQ DIR (LET ((RELATIVE-P T)
                    (DIRIDX DIRSTART)
                    (UP (FUNCALL-SELF ':DIRECTORY-UP-DELIMITER))
                    (NUP NIL)
                    (STRS NIL))
                (COND ((= (AREF NAMESTRING DIRIDX) DELIM-CHAR)
                       (SETQ RELATIVE-P NIL)
                       (SETQ DIRIDX (STRING-SEARCH-NOT-CHAR
                                      DELIM-CHAR NAMESTRING DIRIDX))))
                (AND DIRIDX (> DIREND DIRIDX)
                     (SETQ STRS (LOOP FOR IDX = DIRIDX THEN JDX
                                      AS JDX = (STRING-SEARCH-CHAR
                                                 DELIM-CHAR NAMESTRING IDX DIREND)
                                      COLLECT (SUBSTRING NAMESTRING IDX (OR JDX DIREND))
                                      WHILE
                                      (AND JDX
                                           (SETQ JDX
                                                 (STRING-SEARCH-NOT-CHAR
                                                   DELIM-CHAR NAMESTRING JDX DIREND))))))
                (AND (STRINGP UP)
                     (DO L STRS (CDR L) (NULL L)
                         (AND (STRING-EQUAL (CAR L) UP)
                              (SETF (CAR L) ':UP))))
                (AND NUP (SETQ STRS (NCONC NUP STRS)))
                (COND (RELATIVE-P (CONS ':RELATIVE STRS))
                      ((NULL STRS) ':ROOT)
                      ((NULL (CDR STRS)) (CAR STRS))
                      (T STRS)))))
  (SETQ TYP (STRING-REVERSE-SEARCH-CHAR #/. NAMESTRING END START))
  (IF (EQ TYP START) (SETQ TYP NIL))            ;Initial . is part of NAM
  (IF TYP (PSETQ END TYP
                 TYP (SUBSTRING NAMESTRING (1+ TYP) END)))
  (SETQ NAM (AND ( START END) (SUBSTRING NAMESTRING START END)))
  (COND ((EQUAL NAM "'") (SETQ NAM NIL))
        ((EQUAL NAM "*") (SETQ NAM ':WILD)))
  (COND ((NULL TYP) (SETQ TYP (AND NAM ':UNSPECIFIC)))
        ((EQUAL TYP "'") (SETQ TYP NIL))
        ((EQUAL TYP "*") (SETQ TYP ':WILD VER ':WILD)))
  ;; VER is :UNSPECIFIC unless TYP is :WILD, in which case VER is also :WILD.
  (VALUES ':UNSPECIFIC DIR NAM TYP VER))

;; Differs from the default method in that if the type is :WILD
;; we clobber the version to :WILD; otherwise we clobber the version to :UNSPECIFIC.
;(DEFMETHOD (UNIX-PATHNAME-MIXIN :NEW-PATHNAME) (&REST OPTIONS &AUX (PLIST (LOCF OPTIONS)) -TYPE-)
;  (SETQ -TYPE- (OR (GET PLIST ':TYPE) (PATHNAME-TYPE (OR (GET PLIST ':NAME) SELF))))
;  (LEXPR-FUNCALL #'MAKE-PATHNAME-1
;                 ':HOST (OR (GET PLIST ':HOST) HOST)
;                 ':DEVICE DEVICE
;                 (IF (LISTP DIRECTORY) ':STRUCTURED-DIRECTORY ':DIRECTORY)
;                 DIRECTORY
;                 (IF (LISTP NAME) ':STRUCTURED-NAME ':NAME) NAME
;                 ':TYPE (OR (GET PLIST ':TYPE) TYPE)
;                 ':VERSION (IF (EQ -TYPE- ':WILD) ':WILD ':UNSPECIFIC) 
;                 OPTIONS))

(DEFMETHOD (UNIX-PATHNAME-MIXIN :PARSE-DIRECTORY-SPEC) (SPEC)
  (COND ((STRINGP SPEC) (LIST (FUNCALL-SELF ':PARSE-COMPONENT-SPEC SPEC)))
	((EQ SPEC ':ROOT) SPEC)
        ((AND (LISTP SPEC)
              (LOOP FOR ELT IN SPEC
                    ALWAYS (OR (MEMQ ELT '(:UP :WILD :RELATIVE))
                               (STRINGP ELT)))
              (NOT (MEMQ ':RELATIVE (CDR SPEC))))
         (LOOP FOR ELT IN SPEC
               COLLECT (IF (SYMBOLP ELT) ELT
                         (FUNCALL-SELF ':PARSE-COMPONENT-SPEC ELT))))
        ((MEMQ SPEC '(NIL :UNSPECIFIC :WILD)) SPEC)
        (T (PATHNAME-DIRECTORY (USER-HOMEDIR HOST)))))

(DEFMETHOD (UNIX-PATHNAME-MIXIN :PARSE-STRUCTURED-DIRECTORY-SPEC) PATHNAME-PASS-THROUGH-SPEC)

(DEFFLAVOR MULTICS-PATHNAME-MIXIN () (UNIX-PATHNAME-MIXIN))

(DEFMETHOD (MULTICS-PATHNAME-MIXIN :DIRECTORY-DELIMITER-CHARACTER) () #/>)

(DEFMETHOD (MULTICS-PATHNAME-MIXIN :DIRECTORY-UP-DELIMITER) () #/<)

;;;; Logical pathnames
(DEFFLAVOR LOGICAL-PATHNAME () (PATHNAME))

(DEFMETHOD (LOGICAL-PATHNAME :STRING-FOR-PRINTING) ()
  (FORMAT NIL "~A: ~:[~A; ~;~*~]~@[~A~]~@[ ~A~]~@[ ~D~]"
	  (FUNCALL HOST ':NAME-AS-FILE-COMPUTER) (MEMQ DIRECTORY '(NIL :UNSPECIFIC))
	  (STRING-OR-WILD DIRECTORY)
	  (LOGICAL-NAME-STRING) (LOGICAL-TYPE-STRING) (LOGICAL-VERSION-STRING)))

(DEFF LOGICAL-NAME-STRING 'ITS-FN1-STRING)

(DECLARE-FLAVOR-INSTANCE-VARIABLES (LOGICAL-PATHNAME)
(DEFUN LOGICAL-TYPE-STRING (&OPTIONAL NO-PLACEHOLDER)
  (IF (MEMQ TYPE '(NIL :UNSPECIFIC))
      (AND (NOT (OR NO-PLACEHOLDER (MEMQ VERSION '(NIL :UNSPECIFIC)))) "")
      (STRING-OR-WILD TYPE))))

(DECLARE-FLAVOR-INSTANCE-VARIABLES (LOGICAL-PATHNAME)
;Contrary to its name, this can also return NIL and decimal integers as well as strings
(DEFUN LOGICAL-VERSION-STRING ()
  (SELECTQ VERSION
    ((NIL :UNSPECIFIC) NIL)
    (:NEWEST ">")
    (:OLDEST "<")
    (:WILD "*")
    (OTHERWISE VERSION))))

(DEFMETHOD (LOGICAL-PATHNAME :PARSE-NAMESTRING) (IGNORE NAMESTRING &OPTIONAL (START 0) END)
  (OR END (SETQ END (STRING-LENGTH NAMESTRING)))
  (DO ((I START)
       (J START (1+ J))
       (CH) (TEM)
       (DIR)
       (NAM) (NAMP)
       (TYP) (TYPP)
       (VERS))
      ((> J END)
       (VALUES ':UNSPECIFIC DIR NAM TYP VERS))
    (SETQ CH (IF (= J END) #\SP (AREF NAMESTRING J)))
    (COND ((= CH '#/)
	   (SETQ J (1+ J)))
	  ((MEMQ CH '(#/; #/ #\SP #\TAB))
	   (COND (( I J)
		  (SETQ TEM (UNQUOTE-LOGICAL-STRING NAMESTRING I J))
		  (SELECTQ CH
		    (#/; (SETQ DIR TEM))
		    (OTHERWISE
		     (COND (VERS)
			   (TYPP (SETQ VERS (COND ((STRING-EQUAL TEM ">") ':NEWEST)
						  ((STRING-EQUAL TEM "<") ':OLDEST)
						  ((STRING-EQUAL TEM "*") ':WILD)
						  ((NUMERIC-P TEM))
						  (T (FERROR NIL "Version not numeric")))))
			   (NAMP (SETQ TYP TEM TYPP T))
			   (T (SETQ NAM TEM NAMP T)))))))
	   (COND (( CH #/))
		 ((OR VERS TYPP))
		 (NAMP (SETQ TYPP T))
		 (T (SETQ NAMP T)))
	   (SETQ I (1+ J))))))

(DEFMETHOD (LOGICAL-PATHNAME :QUOTE-CHARACTER) () #/)

(DEFMETHOD (LOGICAL-PATHNAME :CHARACTER-NEEDS-QUOTING-P) (CH)
  (MEMQ CH '(#/; #/ #\SP #\TAB)))

(DEFUN UNQUOTE-LOGICAL-STRING (STRING &OPTIONAL (START 0) (END (STRING-LENGTH STRING)))
  (DO ((I START (1+ I))
       (NCH 0) (CH)
       (NEED-COPY NIL))
      (( I END)
       (COND ((AND (= START 0) (= I (STRING-LENGTH STRING)) (NOT NEED-COPY))
	      STRING)				;To avoid consing
	     ((NOT NEED-COPY)
	      (SUBSTRING STRING START I))
	     (T
	      (DO ((NSTRING (MAKE-ARRAY NCH ':TYPE 'ART-STRING))
		   (J 0)
		   (K START (1+ K))
		   (CH))
		  (( K I) NSTRING)
		(SETQ CH (AREF STRING K))
		(COND (( CH #/)
		       (ASET CH NSTRING J)
		       (SETQ J (1+ J))))))))
    (SETQ CH (AREF STRING I))
    (IF (= CH #/)
	(SETQ NEED-COPY T)
	(SETQ NCH (1+ NCH)))))

(DEFMETHOD (LOGICAL-PATHNAME :STRING-FOR-HOST) LOGICAL-PATHNAME-PASS-ON)
(DEFMETHOD (LOGICAL-PATHNAME :STRING-FOR-WHOLINE) LOGICAL-PATHNAME-PASS-ON)
(DEFMETHOD (LOGICAL-PATHNAME :STRING-FOR-EDITOR) LOGICAL-PATHNAME-PASS-ON)
(DEFMETHOD (LOGICAL-PATHNAME :CHANGE-PROPERTIES) LOGICAL-PATHNAME-PASS-ON)
(DEFMETHOD (LOGICAL-PATHNAME :OPEN) LOGICAL-PATHNAME-PASS-ON)
(DEFMETHOD (LOGICAL-PATHNAME :DELETE) LOGICAL-PATHNAME-PASS-ON)
(DEFMETHOD (LOGICAL-PATHNAME :RENAME) LOGICAL-PATHNAME-PASS-ON)
(DEFMETHOD (LOGICAL-PATHNAME :HOMEDIR) LOGICAL-PATHNAME-PASS-ON)
(DEFMETHOD (LOGICAL-PATHNAME :MULTIPLE-FILE-PLISTS) LOGICAL-PATHNAME-PASS-ON)
(DEFMETHOD (LOGICAL-PATHNAME :PARSE-TRUENAME) LOGICAL-PATHNAME-PASS-ON)
(DEFMETHOD (LOGICAL-PATHNAME :DIRECTORY-LIST) LOGICAL-PATHNAME-PASS-ON)
(DEFMETHOD (LOGICAL-PATHNAME :STRING-FOR-DIRED) LOGICAL-PATHNAME-PASS-ON)

;;; These need to be passed on since otherwise the information on how they were created
;;; will be lost.
(DEFMETHOD (LOGICAL-PATHNAME :PATCH-FILE-PATHNAME) LOGICAL-PATHNAME-PASS-ON)
(DEFMETHOD (LOGICAL-PATHNAME :NEW-TYPE-AND-VERSION) LOGICAL-PATHNAME-PASS-ON)

(DEFUN LOGICAL-PATHNAME-PASS-ON (&REST REST)
  (APPLY (FUNCALL-SELF ':TRANSLATED-PATHNAME) REST))

(DEFFLAVOR LOGICAL-HOST
	(NAME					;Logical device name
	 HOST					;Host that turns into
	 DEFAULT-DEVICE				;When not otherwise specified
	 TRANSLATIONS)				;The actual translations
	(SI:BASIC-HOST)
  (:SETTABLE-INSTANCE-VARIABLES))

(DEFMETHOD (LOGICAL-HOST :PATHNAME-FLAVOR) () 'LOGICAL-PATHNAME)

(DEFSTRUCT (LOGICAL-PATHNAME-TRANSLATION :LIST (:CONC-NAME TRANSLATION-))
  LOGICAL-DIRECTORY
  PHYSICAL-DEVICE
  PHYSICAL-DIRECTORY)

;;; When asked for a generic pathname, make sure the the translated version is made
;;; to exist so that the plist will be shared and it will get package properties and
;;; so on.  Otherwise, no one might ever have need to translate the generic pathname.
(DEFWRAPPER (LOGICAL-PATHNAME :GENERIC-PATHNAME) (IGNORE . BODY)
  `(LET ((RESULT (PROGN . ,BODY)))
     (FUNCALL RESULT ':TRANSLATED-PATHNAME)
     RESULT))

(DEFMETHOD (LOGICAL-PATHNAME :TRANSLATED-PATHNAME) (&AUX TRANS NEW-HOST DEV DIR PATH)
  (SETQ NEW-HOST (FUNCALL HOST ':HOST))
  (IF (SETQ TRANS (ASSOC DIRECTORY (FUNCALL HOST ':TRANSLATIONS)))
      (SETQ DEV (TRANSLATION-PHYSICAL-DEVICE TRANS)
	    DIR (TRANSLATION-PHYSICAL-DIRECTORY TRANS))
      (SETQ DEV (FUNCALL HOST ':DEFAULT-DEVICE)
	    DIR DIRECTORY))
  (SETQ PATH (MAKE-PATHNAME ':HOST NEW-HOST ':DEVICE DEV ':DIRECTORY DIR
			    ':NAME NAME ':TYPE TYPE ':VERSION VERSION))
  ;; Logical pathnames must always share their property list with the physical versions.
  (LET* ((OLD-PROPS (PATHNAME-PROPERTY-LIST PATH))
	 (NEW-PLIST (LOCF (PATHNAME-PROPERTY-LIST SELF))))
    (%P-STORE-TAG-AND-POINTER (LOCF (PATHNAME-PROPERTY-LIST PATH))
			      DTP-ONE-Q-FORWARD NEW-PLIST)
    (LOOP FOR (IND VAL) ON OLD-PROPS BY 'CDDR
	  UNLESS (GET NEW-PLIST IND)
	    DO (PUTPROP NEW-PLIST VAL IND)))
  PATH)

(DEFMETHOD (LOGICAL-PATHNAME :BACK-TRANSLATED-PATHNAME) (PATHNAME &AUX DEV DIR)
  (SETQ DEV (FUNCALL PATHNAME ':DEVICE)
	DIR (FUNCALL PATHNAME ':DIRECTORY))
  (DOLIST (TRANS (FUNCALL HOST ':TRANSLATIONS))
    (AND (EQUAL (TRANSLATION-PHYSICAL-DEVICE TRANS) DEV)
	 (EQUAL (TRANSLATION-PHYSICAL-DIRECTORY TRANS) DIR)
	 (RETURN (SETQ DEV ':UNSPECIFIC
		       DIR (TRANSLATION-LOGICAL-DIRECTORY TRANS)))))
  (FUNCALL PATHNAME ':NEW-PATHNAME ':HOST HOST ':DEVICE DEV ':DIRECTORY DIR))

(DEFUN ADD-LOGICAL-PATHNAME-HOST (LOGICAL-HOST PHYSICAL-HOST TRANSLATIONS &AUX LOG DEFDEV)
  (OR (SETQ LOG (GET-PATHNAME-HOST LOGICAL-HOST))
      (PUSH (SETQ LOG (MAKE-INSTANCE 'LOGICAL-HOST ':NAME LOGICAL-HOST))
	    *PATHNAME-HOST-LIST*))
  (SETQ PHYSICAL-HOST (GET-PATHNAME-HOST PHYSICAL-HOST))
  (FUNCALL LOG ':SET-HOST PHYSICAL-HOST)
  (FUNCALL LOG ':SET-TRANSLATIONS
	   (LOOP FOR (LOGICAL-DIRECTORY PHYSICAL-DIRECTORY) IN TRANSLATIONS
		 WITH HOST = (DEFAULT-PATHNAME NIL PHYSICAL-HOST NIL NIL T)
		 AND DEVICE AND DIRECTORY
		 DO (MULTIPLE-VALUE (DEVICE DIRECTORY)
		      (FUNCALL HOST ':PARSE-NAMESTRING T PHYSICAL-DIRECTORY))
		 WHEN (MEMQ DIRECTORY '(NIL :UNSPECIFIC))
		 DO (FERROR NIL
  "No directory specified in ~A, you probably forgot some delimiter characters."
			    PHYSICAL-DIRECTORY)
		 WHEN (NULL DEFDEV)
		 DO (SETQ DEFDEV DEVICE)
		 COLLECT (MAKE-LOGICAL-PATHNAME-TRANSLATION
			   LOGICAL-DIRECTORY LOGICAL-DIRECTORY
			   PHYSICAL-DEVICE DEVICE
			   PHYSICAL-DIRECTORY DIRECTORY)))
  (FUNCALL LOG ':SET-DEFAULT-DEVICE DEFDEV))

(DEFUN CHANGE-LOGICAL-PATHNAME-HOST (LOGICAL-HOST PHYSICAL-HOST &AUX LOG)
  ;; Get the host instances for the logical and physical hosts.  They are both
  ;; pathname hosts, except that in the case of the physical host we may not
  ;; have learned that yet.
  (OR (SETQ LOG (GET-PATHNAME-HOST LOGICAL-HOST))
      (FERROR NIL "~A is not the name of a logical host" LOGICAL-HOST))
  (SETQ PHYSICAL-HOST (OR (GET-PATHNAME-HOST PHYSICAL-HOST) (SI:PARSE-HOST PHYSICAL-HOST)))
  (FUNCALL LOG ':SET-HOST PHYSICAL-HOST)
  ;; Here is a bit of a kludge for SI:SET-SITE.  If the physical host is not defined yet,
  ;; add it now.
  (OR (MEMQ PHYSICAL-HOST *PATHNAME-HOST-LIST*)
      (PUSH PHYSICAL-HOST *PATHNAME-HOST-LIST*))
  ;; Arrange once again for physical pathnames to share generic property lists with
  ;; logical ones
  (LOCAL-DECLARE ((SPECIAL *LOGICAL-HOST*))
    (LET ((*LOGICAL-HOST* LOG))
      (MAPHASH-EQUAL #'(LAMBDA (KEY VAL)
			 (AND (EQ (FIRST KEY) *LOGICAL-HOST*)
			      (FUNCALL VAL ':TRANSLATED-PATHNAME)))
		     *PATHNAME-HASH-TABLE*))))

(DEFUN CHANGE-LOGICAL-PATHNAME-DIRECTORY (LOGICAL-HOST LOGICAL-DIRECTORY PHYSICAL-DIRECTORY
					  &AUX LOG PHYSICAL-HOST DEF DEVICE DIRECTORY TRAN)
  (OR (SETQ LOG (GET-PATHNAME-HOST LOGICAL-HOST ))
      (FERROR NIL "~A is not the name of a logical host" LOGICAL-HOST))
  (SETQ PHYSICAL-HOST (FUNCALL LOG ':HOST)
	DEF (DEFAULT-PATHNAME NIL PHYSICAL-HOST NIL NIL T))
  (MULTIPLE-VALUE (DEVICE DIRECTORY)
    (FUNCALL DEF ':PARSE-NAMESTRING T PHYSICAL-DIRECTORY))
  (AND (MEMQ DIRECTORY '(NIL :UNSPECIFIC))
       (FERROR NIL
  "No directory specified in ~A, you probably forgot some delimiter characters."
	       PHYSICAL-DIRECTORY))
  (IF (NULL (SETQ TRAN (ASSOC LOGICAL-DIRECTORY (FUNCALL LOG ':TRANSLATIONS))))
      (PUSH (MAKE-LOGICAL-PATHNAME-TRANSLATION
	      LOGICAL-DIRECTORY LOGICAL-DIRECTORY
	      PHYSICAL-DEVICE DEVICE
	      PHYSICAL-DIRECTORY DIRECTORY)
	    (FUNCALL LOG ':TRANSLATIONS))
      (SETF (TRANSLATION-PHYSICAL-DEVICE TRAN) DEVICE)
      (SETF (TRANSLATION-PHYSICAL-DIRECTORY TRAN) DIRECTORY)))

;;;; Kludges for bootstrapping from a world without flavors loaded.
(LOCAL-DECLARE ((SPECIAL SYS-PATHNAME))
(DEFUN CANONICALIZE-COLD-LOAD-PATHNAMES (&AUX SYS-PATHNAME)
  ;; Get someone who can do the translations
  (SETQ SYS-PATHNAME (DEFAULT-PATHNAME NIL "SYS" NIL NIL T))
  ;; Make pathnames for all files initially loaded, and setup their properties
  (DOLIST (ELEM SI:*COLD-LOADED-FILE-PROPERTY-LISTS*)
    (LET* ((PATHNAME (FUNCALL SYS-PATHNAME ':BACK-TRANSLATED-PATHNAME
			      (MERGE-PATHNAME-DEFAULTS (CAR ELEM))))
	   (GENERIC-PATHNAME (FUNCALL PATHNAME ':GENERIC-PATHNAME)))
      (DO L (CDR ELEM) (CDDR L) (NULL L)
	(LET ((PROP (INTERN (CAR L) ""))	;Lossage in cold load generator
	      (VAL (CADR L)))
	  ;;Cold load generator does not know how to put in instances, it makes
	  ;;strings instead.  Also, during MINI loading, calls to MAKE-PATHNAME-INTERNAL
	  ;;are saved just as lists.  Note: we do not back translate this pathname, so
	  ;;that we really remember the machine it was compiled on.
	  (COND ((EQ PROP ':QFASL-SOURCE-FILE-UNIQUE-ID)
		 (COND ((STRINGP VAL)
			(SETQ VAL (MERGE-PATHNAME-DEFAULTS VAL)))
		       ((LISTP VAL)
			;; Symbols like UNSPECIFIC may be in the wrong package
			(SETF (CAR VAL) (GET-PATHNAME-HOST (CAR VAL)))
			(DO L (CDR VAL) (CDR L) (NULL L)
			    (AND (SYMBOLP (CAR L))
				 (SETF (CAR L) (INTERN (GET-PNAME (CAR L)) ""))))
			(SETQ VAL (APPLY #'MAKE-PATHNAME-INTERNAL VAL)))))
		((EQ PROP ':FILE-ID-PACKAGE-ALIST)
		 ;; Kludge, built before there are packages
		 (SETF (CAAR VAL) (PKG-FIND-PACKAGE (OR (CAAR VAL)
							SI:PKG-SYSTEM-INTERNALS-PACKAGE)))
		 ;; And before there are truenames
		 (LET ((INFO (CADAR VAL)))
		     (AND (STRINGP (CAR INFO))
			(RPLACA INFO (MERGE-PATHNAME-DEFAULTS (CAR INFO)))))))

	  (FUNCALL GENERIC-PATHNAME ':PUTPROP VAL PROP)))))
  ;; Replace all strings saved on symbols with pathnames
  (MAPATOMS-ALL #'(LAMBDA (SYMBOL &AUX NAME)
		    (AND (SETQ NAME (GET SYMBOL ':SOURCE-FILE-NAME))
			 (NOT (TYPEP NAME 'PATHNAME))
			 (PUTPROP SYMBOL (CANONICALIZE-SOURCE-FILE-NAME-PROPERTY NAME)
				  ':SOURCE-FILE-NAME))
		    (AND (SETQ NAME (GET SYMBOL 'SPECIAL))
			 (STRINGP NAME)
			 (PUTPROP SYMBOL (CANONICALIZE-SOURCE-FILE-NAME-PROPERTY-1 NAME)
				  'SPECIAL))
		    (AND (GET SYMBOL 'SI:INITIALIZATION-LIST)
			 (DOLIST (INIT (SYMEVAL SYMBOL))
			   (AND (SI:INIT-SOURCE-FILE INIT)
				(SETF (SI:INIT-SOURCE-FILE INIT)
				      (CANONICALIZE-SOURCE-FILE-NAME-PROPERTY-1
					(SI:INIT-SOURCE-FILE INIT))))))))
  ;; Store source file names from the cold load
  (SETQ SI:FUNCTION-SPEC-HASH-TABLE (MAKE-EQUAL-HASH-TABLE))
  (DOLIST (ELEM SI:COLD-LOAD-FUNCTION-PROPERTY-LISTS)
    (SI:FUNCTION-SPEC-PUTPROP (FIRST ELEM)
			      (IF (EQ (SECOND ELEM) ':SOURCE-FILE-NAME)
				  (CANONICALIZE-SOURCE-FILE-NAME-PROPERTY (THIRD ELEM))
				  (THIRD ELEM))
			      (SECOND ELEM)))
  (DOLIST (FLAVOR SI:*ALL-FLAVOR-NAMES*)
    (LET ((FL (GET FLAVOR 'SI:FLAVOR)))
      (LOOP FOR METH IN (SI:FLAVOR-METHOD-TABLE FL)
	    DO (LOOP FOR METH1 IN (CDDDR METH)
		     AS PL = (CADDR METH1)
		     AS X = (GETL (LOCF PL) '(:SOURCE-FILE-NAME))
		     WHEN X
		     DO (SETF (CADR X) (CANONICALIZE-SOURCE-FILE-NAME-PROPERTY (CADR X)))))
      (LET ((PROP (GETL (LOCF (SI:FLAVOR-PLIST FL)) '(:COMPILE-FLAVOR-METHODS))))
	(AND PROP (STRINGP (CADR PROP))
	     (SETF (CADR PROP) (CANONICALIZE-SOURCE-FILE-NAME-PROPERTY-1 (CADR PROP)))))))
  )
);LOCAL-DECLARE

(DEFUN CANONICALIZE-SOURCE-FILE-NAME-PROPERTY (PROPERTY)
  (IF (ATOM PROPERTY)
      (CANONICALIZE-SOURCE-FILE-NAME-PROPERTY-1 PROPERTY)
      (DOLIST (TYPE PROPERTY)
	(DO L (CDR TYPE) (CDR L) (NULL L)
	  (RPLACA L (CANONICALIZE-SOURCE-FILE-NAME-PROPERTY-1 (CAR L)))))
      PROPERTY))

(DEFUN CANONICALIZE-SOURCE-FILE-NAME-PROPERTY-1 (NAME)
  (DECLARE (SPECIAL SYS-PATHNAME))
  (FUNCALL (FUNCALL SYS-PATHNAME ':BACK-TRANSLATED-PATHNAME (MERGE-PATHNAME-DEFAULTS NAME))
	   ':GENERIC-PATHNAME))

;;; Called when the time parser comes in, canonicalize times made before then
(DEFUN CANONICALIZE-COLD-LOADED-TIMES ()
  (MAPHASH-EQUAL #'(LAMBDA (IGNORE VAL &AUX ALIST)
		     (AND (SETQ ALIST (GET (LOCF (PATHNAME-PROPERTY-LIST VAL))
					   ':FILE-ID-PACKAGE-ALIST))
			  (DOLIST (ID ALIST)
			    (LET ((INFO (CADR ID)))
			      (AND (STRINGP (CDR INFO))
				   (RPLACD INFO
					   (PARSE-DIRECTORY-DATE-PROPERTY (CDR INFO) 0)))))))
		 *PATHNAME-HASH-TABLE*))

;;;; Global interface functions, and random file stuff

;;; This variable is to make DIRED have a guess at what is losing, it should work better
;;; somehow.
(DEFVAR LAST-FILE-OPENED NIL)

;;; For Maclisp compatibility, the OPEN function accepts an option name
;;; or a list of options (a single arg), as an alternative to
;;; keywords and values.  These option names can be in any package.

;;; Possible keywords and values include the following:
;;; Keyword	     Possible Values	Default		Comment
;;; :DIRECTION		:INPUT		:INPUT
;;;			:OUTPUT
;;;			NIL				This is a probe opening,
;;;							no data is transfered.
;;; :CHARACTERS		boolean		T		T if file is textual data.
;;;			:DEFAULT
;;; :ERROR		boolean		T		An error is signaled if T.
;;; :BYTE-SIZE		NIL		NIL		16 for binary files.
;;;							System-dependent fixed value for
;;;							text files.
;;;			:DEFAULT			Whatever size the file says it is.
;;;			fixnum
;;; :INHIBIT-LINKS	boolean		NIL
;;; :DELETED		boolean		NIL
;;; :TEMPORARY		boolean		NIL
;;; :PRESERVE-DATES	boolean		NIL		Do not update reference or
;;;							modification dates.
;;; :FLAVOR		NIL		NIL		Normal file
;;;			:DIRECTORY			Directory file
;;;			:LINK
;;; :LINK-TO		pathname			Creates a link when used with
;;;							:LINK flavor.
;;; :ESTIMATED-SIZE	NIL		NIL
;;;			fixnum (number of bytes)
;;; :NEW-FILE		boolean		T iff output	T means ok to create new file.
;;; :NEW-VERSION	boolean		NEW-FILE	NIL says version = NEWEST
;;;							finds newest existing version.
;;; :OLD-FILE		:ERROR		(NOT NEW-FILE)	Generate an error when overwriting.
;;;			T or :REWRITE			Use the old file.
;;;			:APPEND				Use it, but append if output.
;;;			NIL or :REPLACE			Overwrite the file when closed.
;;;			:RENAME				Rename old file
;;;			:RENAME-AND-DELETE		Same, but delete when closed.
;;;			:NEW-VERSION			If version is a number and there
;;;							is an old file, create new version.
;;; :PHYSICAL-VOLUME	NIL		NIL
;;;			string				Where to put file.
;;; :LOGICAL-VOLUME	NIL		NIL		In some systems the pathname can
;;;			string				specify this.
;;; :INCREMENTAL-UPDATE	boolean		NIL		Attempt to save recoverable data
;;;							more often.

(DEFUN OPEN (FILENAME &REST KEYWORD-ARGS)
  (FORCE-USER-TO-LOGIN)
  (SETQ FILENAME (MERGE-PATHNAME-DEFAULTS FILENAME))
  (SETQ LAST-FILE-OPENED FILENAME)
  (IF (NULL (CDR KEYWORD-ARGS))			;Old syntax
      (DO ((KEYL (IF (AND (CAR KEYWORD-ARGS) (SYMBOLP (CAR KEYWORD-ARGS)))
		     (LIST (CAR KEYWORD-ARGS))
		     (CAR KEYWORD-ARGS))
		 (CDR KEYL))
	   (KEY)
	   (CHARACTERS T)
	   (DIRECTION ':INPUT)
	   (BYTE-SIZE NIL)
	   (ERROR-P T)
	   (ERROR-P-SPECD NIL)
	   (DELETED-P NIL)
	   (TEMPORARY-P NIL)
	   ;; These two are really only useful for machines that do not natively store
	   ;; 8-bit characters.
	   (RAW-P NIL)
	   (SUPER-IMAGE-P NIL)
	   )
	  ((NULL KEYL)
	   (LET (KWDARGS)
	     (SETQ KWDARGS `(:CHARACTERS ,CHARACTERS :DIRECTION ,DIRECTION))
	     (AND BYTE-SIZE
		  (SETQ KWDARGS `(:BYTE-SIZE ,BYTE-SIZE . ,KWDARGS)))
	     (AND ERROR-P-SPECD
		  (SETQ KWDARGS `(:ERROR ,ERROR-P . ,KWDARGS)))
	     (AND DELETED-P
		  (SETQ KWDARGS `(:DELETED ,DELETED-P . ,KWDARGS)))
	     (AND TEMPORARY-P
		  (SETQ KWDARGS `(:TEMPORARY ,TEMPORARY-P . ,KWDARGS)))
	     (AND SUPER-IMAGE-P
		  (SETQ KWDARGS `(:SUPER-IMAGE ,SUPER-IMAGE-P . ,KWDARGS)))
	     (AND RAW-P
		  (SETQ KWDARGS `(:RAW ,RAW-P . ,KWDARGS)))
	     (LEXPR-FUNCALL FILENAME ':OPEN FILENAME KWDARGS)))
	(SETQ KEY (CAR KEYL))
	(SELECTOR KEY STRING-EQUAL
	  ((':IN ':READ) (SETQ DIRECTION ':INPUT))
	  ((':OUT ':WRITE ':PRINT) (SETQ DIRECTION ':OUTPUT))
	  ((':BINARY ':FIXNUM) (SETQ CHARACTERS NIL))
	  ((':CHARACTER ':ASCII) (SETQ CHARACTERS T))
	  ((':BYTE-SIZE) (SETQ KEYL (CDR KEYL)
			       BYTE-SIZE (CAR KEYL)))
	  ((':PROBE) (SETQ DIRECTION NIL
			   CHARACTERS NIL
			   ERROR-P-SPECD T
			   ERROR-P NIL))
	  ((':NOERROR) (SETQ ERROR-P NIL ERROR-P-SPECD T))
	  ((':ERROR) (SETQ ERROR-P T ERROR-P-SPECD T))
	  ((':RAW) (SETQ RAW-P T))
	  ((':SUPER-IMAGE) (SETQ SUPER-IMAGE-P T))
	  ((':DELETED) (SETQ DELETED-P T))
	  ((':TEMPORARY) (SETQ TEMPORARY-P T))
	  ((':BLOCK ':SINGLE) )		;Ignored for compatility with Maclisp
	  (OTHERWISE (FERROR NIL "~S is not a known OPEN option" KEY))))
      (LEXPR-FUNCALL FILENAME ':OPEN FILENAME KEYWORD-ARGS)))

(DEFUN CLOSE (STREAM &OPTIONAL ABORTP)
  (FUNCALL STREAM ':CLOSE ABORTP))

(DEFUN RENAMEF (STRING-OR-STREAM NEW-NAME &OPTIONAL (ERROR-P T))
  (AND (OR (STRINGP STRING-OR-STREAM)
	   (TYPEP STRING-OR-STREAM 'PATHNAME))		;Not a stream
       (SETQ STRING-OR-STREAM (MERGE-PATHNAME-DEFAULTS STRING-OR-STREAM)))
  (SETQ NEW-NAME (MERGE-PATHNAME-DEFAULTS NEW-NAME (AND (TYPEP STRING-OR-STREAM 'PATHNAME)
							STRING-OR-STREAM)))
  (FUNCALL STRING-OR-STREAM ':RENAME NEW-NAME ERROR-P))

(DEFUN DELETEF (STRING-OR-STREAM &OPTIONAL (ERROR-P T))
  (AND (OR (STRINGP STRING-OR-STREAM)
	   (TYPEP STRING-OR-STREAM 'PATHNAME))		;Not a stream
       (SETQ STRING-OR-STREAM (MERGE-PATHNAME-DEFAULTS STRING-OR-STREAM)))
  (FUNCALL STRING-OR-STREAM ':DELETE ERROR-P))

(DEFUN UNDELETEF (STRING-OR-STREAM &OPTIONAL (ERROR-P T))
  (AND (OR (STRINGP STRING-OR-STREAM)
	   (TYPEP STRING-OR-STREAM 'PATHNAME))		;Not a stream
       (SETQ STRING-OR-STREAM (MERGE-PATHNAME-DEFAULTS STRING-OR-STREAM)))
  (FUNCALL STRING-OR-STREAM ':UNDELETE ERROR-P))

;;; Returns NIL or the truename
(DEFUN PROBEF (FILE)
  (LET ((STREAM-OR-ERROR-MESSAGE (OPEN FILE '(:PROBE))))
    (COND ((STRINGP STREAM-OR-ERROR-MESSAGE) NIL)
	  (T (PROG1 (FUNCALL STREAM-OR-ERROR-MESSAGE ':TRUENAME)
		    (FUNCALL STREAM-OR-ERROR-MESSAGE ':CLOSE)))))) ;In case this did something

(DEFUN VIEWF (FILE &OPTIONAL (OUTPUT-STREAM STANDARD-OUTPUT) LEADER)
  (WITH-OPEN-FILE (FILE-STREAM FILE '(:READ :NOERROR))
    (IF (STRINGP FILE-STREAM)
	FILE-STREAM
	(FUNCALL OUTPUT-STREAM ':FRESH-LINE)
	(STREAM-COPY-UNTIL-EOF FILE-STREAM OUTPUT-STREAM LEADER))))

(DEFVAR USER-HOMEDIRS NIL)
(DEFVAR USER-PERSONAL-NAME "")		        ;Full name, last name first
(DEFVAR USER-PERSONAL-NAME-FIRST-NAME-FIRST "") ;Full name, first name first
(DEFVAR USER-GROUP-AFFILIATION #/-)
(DEFVAR USER-LOGIN-MACHINE SI:ASSOCIATED-MACHINE)

(DEFUN USER-HOMEDIR (&OPTIONAL (HOST USER-LOGIN-MACHINE) RESET-P)
  (SETQ HOST (GET-PATHNAME-HOST HOST))
  (AND (TYPEP HOST 'LOGICAL-HOST) (SETQ HOST (FUNCALL HOST ':HOST)))	;Just in case
  (FORCE-USER-TO-LOGIN HOST)
  (AND RESET-P (SETQ USER-LOGIN-MACHINE HOST))
  (FUNCALL (DEFAULT-PATHNAME NIL HOST NIL NIL T) ':HOMEDIR))

(DEFUN FORCE-USER-TO-LOGIN (&OPTIONAL (HOST SI:ASSOCIATED-MACHINE)
			    &AUX INPUT USER DONT-READ-INIT IDX IDX2)
  (COND ((OR (NULL USER-ID) (STRING-EQUAL USER-ID ""))
	 (FUNCALL QUERY-IO ':BEEP)
	 (FORMAT QUERY-IO
		 "~&Please log in.  Type username or username@host (host defaults to ~A)
To avoid loading your init file, follow by <space>T : "
		 HOST)
	 (SETQ INPUT (STRING-TRIM '(#\SP #\TAB) (READLINE QUERY-IO)))
	 (AND (SETQ IDX (STRING-SEARCH-CHAR #/@ INPUT))
	      (SETQ USER (SUBSTRING INPUT 0 IDX)))
	 (AND (SETQ IDX2 (STRING-SEARCH-SET '(#\SP #\TAB) INPUT (OR IDX 0)))
	      (SETQ DONT-READ-INIT (READ-FROM-STRING INPUT T IDX2)))
	 (IF IDX
	     (SETQ HOST (SUBSTRING INPUT (1+ IDX) IDX2))
	     (SETQ USER (SUBSTRING INPUT 0 IDX2)))
	 (OR (STRING-EQUAL USER "")
	     (LOGIN USER HOST (NOT DONT-READ-INIT))))))

;;; Setup a user-id for the specified host.  Knows about ITS specially, as they
;;; are one big happy family...
(DEFVAR USER-UNAMES NIL)
(DEFUN FILE-HOST-USER-ID (UID HOST)
  (AND (EQ (FUNCALL HOST ':SYSTEM-TYPE) ':ITS)
       ;; All ITS' are the same
       (SETQ HOST 'ITS
	     UID (SUBSTRING UID 0 (MIN (STRING-LENGTH UID) 6))))
  (LET ((AE (ASSQ HOST USER-UNAMES)))
       (IF AE
	   (RPLACD AE UID)
	   (PUSH (CONS HOST UID) USER-UNAMES))))

(ADD-INITIALIZATION "File Host User ID" '(FILE-HOST-USER-ID USER-ID SI:HOST) '(LOGIN))
(ADD-INITIALIZATION "Reset File Host User ID" '(SETQ USER-UNAMES NIL) '(LOGOUT))

(DEFUN FILE-GET-PASSWORD (UID HOST &AUX WINDOW)
  ;; This is mainly for the sake of the editor
  (SETQ WINDOW (AND (MEMQ ':SELECT (FUNCALL QUERY-IO ':WHICH-OPERATIONS))
		    TV:SELECTED-WINDOW))
  (UNWIND-PROTECT
    (PROG ((LINE (MAKE-ARRAY NIL 'ART-STRING 30 NIL '(0)))
	   (CHAR) (TEMP))
       (AND WINDOW (FUNCALL QUERY-IO ':SELECT))
       RESTART
	  (SETQ UID (OR (CDR (ASSQ HOST USER-UNAMES)) UID))
	  (FORMAT QUERY-IO "~&Current login name is ~A for host ~A.
Type either password or loginname<space>password: " UID HOST)
       L  (SETQ CHAR (FUNCALL QUERY-IO ':TYI))
	  (COND ((= CHAR #\RUBOUT)
		 (OR (PLUSP (SETQ TEMP (ARRAY-LEADER LINE 0)))
		     (GO FLUSH))
		 (STORE-ARRAY-LEADER (1- TEMP) LINE 0))
		((= CHAR #\CLEAR) (GO FLUSH))
		((= CHAR #\SPACE)
		 (SETQ UID LINE
		       LINE (MAKE-ARRAY 30 ':TYPE 'ART-STRING ':LEADER-LIST '(0)))
		 (FORMAT QUERY-IO "~A " UID))
		((= CHAR #\CR)
		 (FILE-HOST-USER-ID UID HOST)
		 (AND (MEMQ ':MAKE-COMPLETE (FUNCALL QUERY-IO ':WHICH-OPERATIONS))
		      (FUNCALL QUERY-IO ':MAKE-COMPLETE))
		 (RETURN UID LINE))
		(T (ARRAY-PUSH-EXTEND LINE CHAR)))
	  (GO L)
       FLUSH
	  (PRINC " XXX" QUERY-IO)
	  (GO RESTART))
    (AND WINDOW (FUNCALL WINDOW ':SELECT))))

;;; Used by MAKE-SYSTEM for fast INFO access
(DEFUN MULTIPLE-FILE-PLISTS (FILENAMES &REST OPTIONS &AUX HOST-FILE-LIST)
  (DOLIST (FILENAME FILENAMES)
    (SETQ FILENAME (MERGE-PATHNAME-DEFAULTS FILENAME))
    (DO ((HOST (FUNCALL FILENAME ':HOST))
	 (LIST HOST-FILE-LIST (CDR LIST)))
	((NULL LIST)
	 (PUSH (NCONS FILENAME) HOST-FILE-LIST))
      (COND ((EQ HOST (FUNCALL (CAAR HOST-FILE-LIST) ':HOST))
	     (PUSH FILENAME (CAR LIST))
	     (RETURN)))))
  (LOOP FOR LIST IN (NREVERSE HOST-FILE-LIST)
	NCONC (FUNCALL (CAR LIST) ':MULTIPLE-FILE-PLISTS (NREVERSE LIST) OPTIONS)))

;;; Old name for compatibility
(DEFUN MULTIPLE-FILE-PROPERTY-LISTS (BINARY-P FILENAMES)
  (MULTIPLE-FILE-PLISTS FILENAMES ':CHARACTERS (NOT BINARY-P)))

;;; Errors for which it is more useful to fix things up from the error handler than
;;; try with a new pathname.
(DEFVAR DONT-ASK-FOR-NEW-PATHNAME-ERROR-CODES '("DRF" "DVF" "IOC" "NER" "WLK"))

;;; An error string is as follows:
;;;  FHN<SP>ERROR<SP>Error-code<SP>Error-severity<SP>Error-description
;;; The error code is a three letter code that uniquely determines the error.  In general,
;;; this code will be ignored, but some codes may be of interest.  FNF is file not found,
;;; and NER is not enough resources.  The severity is either F (Fatal) or R (Restartable).
;;; If an error is Fatal, it can not be continued from, even if it is an asynchronous
;;; error.  If an error is Restartable, sending a CONTINUE command for the appropriate
;;; file handle will cause the file job to proceed where it left off.  In general, before
;;; the error is continued from, the error condition should be corrected, or the error
;;; will happen again immediately.
;;; The string that is passed in is expected to be "temporary" (contained in a chaos packet,
;;; for example).  Therefore, if an error handler gets called and it wants to save some
;;; of the strings, it must copy the ones it wishes to save.
;;; If the 3rd arg is NIL, this function won't return.  If T it will
;;; return if the user has said to proceed.  The caller should retry the operation
;;; or ignore the error as appropriate.
;;; If ASK-FOR-NEW-PATHNAME is specified, instead of signalling an error
;;; a new pathname will be requested from the user, defaulted from ASK-FOR-NEW-PATHNAME,
;;; and returned to the caller.  This can still be overridden by the channel's
;;; exception handler.  Also if error-code is in DONT-ASK-FOR-NEW-PATHNAME-ERROR-CODES
;;; this is bypassed, however the value returned to the caller is still a pathname
;;; of course.
;;; In all other cases the values returned to the caller are the 3-letter abbreviation
;;; for the error, the severity letter, the message string, and the error-handler function
;;; of the channel (usually NIL).

;;; This function is pretty chaos specific.  Hopefully that will improve when the error system
;;; is revamped.  The next function is even worse.
(DEFPROP FILE-PROCESS-ERROR T :ERROR-REPORTER)	;Make EH not select as current frame

(DEFUN FILE-PROCESS-ERROR (STRING PATHNAME-OR-STREAM PROCEEDABLE
			   &OPTIONAL (JUST-RETURN NIL) (ASK-FOR-NEW-PATHNAME NIL)
				     (MERGE-DEFAULT-TYPE ':UNSPECIFIC)
				     (MERGE-DEFAULT-VERSION ':NEWEST)
			   &AUX S-P ERROR-CODE ERROR-SEVERITY ERROR-STRING WHO-FOR)
  (DECLARE (RETURN-LIST ERROR-CODE ERROR-SEVERITY ERROR-STRING))
  (PROG ()
    (COND ((TYPEP PATHNAME-OR-STREAM 'PATHNAME)
	   (SETQ WHO-FOR (STRING PATHNAME-OR-STREAM)))
	  ((TYPEP PATHNAME-OR-STREAM 'SI:FILE-STREAM-MIXIN)
	   (SETQ WHO-FOR (STRING (FUNCALL PATHNAME-OR-STREAM ':PATHNAME))))
	  (T (SETQ WHO-FOR PATHNAME-OR-STREAM)))
    (SETQ S-P (FILE-CHECK-COMMAND "ERROR" STRING))
    (SETQ ERROR-CODE (SUBSTRING STRING S-P (SETQ S-P (STRING-SEARCH-CHAR #\SP STRING S-P))))
    (SETQ S-P (1+ S-P))
    (SETQ ERROR-SEVERITY
	  (SUBSTRING STRING S-P (SETQ S-P (STRING-SEARCH-CHAR #\SP STRING S-P))))
    (SETQ ERROR-STRING (NSUBSTRING STRING (1+ S-P) (STRING-LENGTH STRING)))
    (AND WHO-FOR
	 (SETQ ERROR-STRING (STRING-APPEND ERROR-STRING " for " WHO-FOR)))
    (COND (JUST-RETURN)
          ((AND ASK-FOR-NEW-PATHNAME
		(NOT (MEMBER ERROR-CODE DONT-ASK-FOR-NEW-PATHNAME-ERROR-CODES)))
	   ;;Probably this should use FQUERY and signal the FILE-ERROR condition first...
	   (FUNCALL QUERY-IO ':FRESH-LINE)
	   (FORMAT QUERY-IO "File error ~A (Severity ~A), ~A"
			    ERROR-CODE ERROR-SEVERITY ERROR-STRING)
	   (FORMAT QUERY-IO "~%Use what pathname instead? (default ~A) " ASK-FOR-NEW-PATHNAME)
	   (FUNCALL QUERY-IO ':CLEAR-INPUT)
	   (RETURN (MERGE-PATHNAME-DEFAULTS (READLINE QUERY-IO) ASK-FOR-NEW-PATHNAME
					    MERGE-DEFAULT-TYPE MERGE-DEFAULT-VERSION)))
	  (T (CERROR PROCEEDABLE NIL ':FILE-ERROR "File error ~A (Severity ~A), ~A~@[
Type Resume to retry.~]"
		     ERROR-CODE ERROR-SEVERITY ERROR-STRING PROCEEDABLE)))
    (AND ASK-FOR-NEW-PATHNAME		;Caller is expecting a pathname back
	 (RETURN ASK-FOR-NEW-PATHNAME))
    (RETURN ERROR-CODE ERROR-SEVERITY ERROR-STRING)))

(DEFUN FILE-CHECK-COMMAND (COMMAND RETURNED-STRING &OPTIONAL (Y-OR-N-P NIL)
                                                   &AUX START END)
  (SETQ START (1+ (STRING-SEARCH-CHAR #\SP RETURNED-STRING)))
  (SETQ END (OR (STRING-SEARCH-SET '(#\SP #\CR) RETURNED-STRING START)
                (STRING-LENGTH RETURNED-STRING)))
  (COND ((STRING-EQUAL RETURNED-STRING COMMAND START 0 END)
	 (1+ END)) ;Index of character after the delimiting space
        (Y-OR-N-P NIL)
        (T (FERROR 'FILE-CONNECTION-TROUBLE
                   "Incorrect command name ~S in acknowledge from file computer"
                   (NSUBSTRING RETURNED-STRING START END)))))

(DEFUN (:FILE-ERROR EH:PROCEED) (IGNORE IGNORE)
  (FORMAT T "~&Retrying file operation.~%"))

;;;; Directory stuff

;;; This is the only function user interface to the directory listing
;;; stuff.  It returns a list of lists, one for each file.  The format
;;; of these lists is (PATHNAME . PLIST).  The currently defined indicators
;;; for PLIST are:
;;; :ACCOUNT <string>
;;; :AUTHOR <string>
;;; :BLOCK-SIZE <number>
;;; :BYTE-SIZE <number>
;;; :CREATION-DATE <universal-date>
;;; :DELETED <boolean>
;;; :DONT-DELETE <boolean>
;;; :DONT-DUMP <boolean>
;;; :DONT-REAP <boolean>
;;; :DUMPED <boolean>
;;; :GENERATION-RETENTION-COUNT <number>
;;; :LENGTH-IN-BLOCKS <number>
;;; :LENGTH-IN-BYTES <number>
;;; :LINK-TO <string>
;;; :OFFLINE <boolean>
;;; :PHYSICAL-VOLUME <string>
;;; :PROTECTION <string>
;;; :READER <string>
;;; :REFERENCE-DATE <universal-date>
;;; :TEMPORARY <boolean>

;;; A pathname of NIL is treated specially and gives properties for all
;;; the files listed.  The indicators for this "pathname" are:
;;; :SETTABLE-PROPERTIES <list-of-indicators>
;;; :BLOCK-SIZE  <number>
;;; :PHYSICAL-VOLUME-FREE-BLOCKS alist of (<string> . <number>)
;;; :DISK-SPACE-DESCRIPTION <string>

;;; The currently defined OPTIONS are:
;;; :NOERROR - as with OPEN.
;;; :DELETED - also (rather than exclusively) list deleted files.
;;; :NO-EXTRA-INFO - only include enough information for listing directory as in DIRED.
(DEFUN DIRECTORY-LIST (FILENAME &REST OPTIONS)
  (FORCE-USER-TO-LOGIN)
  (SETQ FILENAME (MERGE-PATHNAME-DEFAULTS FILENAME))
  (FUNCALL FILENAME ':DIRECTORY-LIST OPTIONS))

;;; These are the understood indicators
;;; Format is ((PARSER-FROM-STRING PRINTER TYPE-FOR-CHOOSE-VARIABLE-VALUES) . INDICATORS)
(DEFVAR *KNOWN-DIRECTORY-PROPERTIES*
  '(((PARSE-DIRECTORY-BOOLEAN-PROPERTY PRIN1 :BOOLEAN)
     . (:DELETED :DONT-DELETE :DONT-DUMP :DONT-REAP
	:NOT-BACKED-UP :OFFLINE :TEMPORARY :CHARACTERS
	;; Supported by LM
	:QFASLP :PDP10 :MAY-BE-REAPED))
    ((SUBSTRING PRINC :STRING) . (:ACCOUNT :AUTHOR :LINK-TO :PHYSICAL-VOLUME :PROTECTION
				  :READER))
    ((ZWEI:PARSE-NUMBER PRINT-DECIMAL-PROPERTY :NUMBER)
     . (:BLOCK-SIZE :BYTE-SIZE :GENERATION-RETENTION-COUNT :LENGTH-IN-BLOCKS
	:LENGTH-IN-BYTES :DEFAULT-GENERATION-RETENTION-COUNT))
    ((PARSE-DIRECTORY-DATE-PROPERTY TIME:PRINT-UNIVERSAL-TIME :DATE)
     . (:CREATION-DATE :MODIFICATION-DATE))
    ((PARSE-DIRECTORY-DATE-PROPERTY TV:PRINT-UNIVERSAL-TIME-OR-NEVER :DATE-OR-NEVER)
     . ( :REFERENCE-DATE :INCREMENTAL-DUMP-DATE :COMPLETE-DUMP-DATE :DATE-LAST-EXPUNGED))
    ((PARSE-SETTABLE-PROPERTIES) . (:SETTABLE-PROPERTIES))
    ((PARSE-DIRECTORY-FREE-SPACE) . (:PHYSICAL-VOLUME-FREE-BLOCKS))
    ((TIME:PARSE-INTERVAL-OR-NEVER TIME:PRINT-INTERVAL-OR-NEVER :TIME-INTERVAL-OR-NEVER)
	 . (:AUTO-EXPUNGE-INTERVAL))
    ))

;;; Really nice printing for ZWEI's Change File Properties
(DEFPROP :DONT-DELETE "Don't Delete" ZWEI:PRETTY-NAME)
(DEFPROP :DONT-REAP "Don't Reap" ZWEI:PRETTY-NAME)

;;; Nifty, handy function for adding new ones
(DEFUN PUSH-DIRECTORY-PROPERTY-ON-TYPE (TYPE PROP)
  (LET ((X (OR (DOLIST (E *KNOWN-DIRECTORY-PROPERTIES*)
		 (IF (EQ (CAAR E) TYPE) (RETURN E)))
	       (FERROR NIL "Unknown property type: ~A" TYPE))))
    (OR (MEMQ TYPE (CDR X))
	(PUSH PROP (CDR X)))))

;;; Default way is through an input stream
(DEFMETHOD (PATHNAME :DIRECTORY-LIST) (OPTIONS)
  (WITH-OPEN-STREAM (STREAM (FUNCALL-SELF ':DIRECTORY-STREAM OPTIONS))
    (IF (STRINGP STREAM)
	STREAM
	(DO ((LINE) (EOF)
	     (LIST NIL)
	     (SUBLIST NIL)
	     (LEN) (I) (IND) (PROP) (FUN))
	    (NIL)
	  (MULTIPLE-VALUE (LINE EOF)
	    (FUNCALL STREAM ':LINE-IN))
	  (IF EOF
	      (IF (MEMQ ':SORTED OPTIONS)
		  (LET ((NULL-ELEM (ASSQ 'NIL LIST)))
		    (AND NULL-ELEM (SETQ LIST (DELQ NULL-ELEM LIST)))
		    (SETQ LIST (SORTCAR LIST #'PATHNAME-LESSP))
		    (AND NULL-ELEM (PUSH NULL-ELEM LIST))
		    (RETURN LIST))
		  (RETURN (NREVERSE LIST))))
	  (SETQ LEN (ARRAY-ACTIVE-LENGTH LINE))
	  (COND ((NULL SUBLIST)
		 (SETQ SUBLIST (NCONS (AND (NOT (ZEROP LEN))
					   (FS:MERGE-PATHNAME-DEFAULTS LINE SELF)))))
		((ZEROP LEN)
		 (PUSH (NREVERSE SUBLIST) LIST)
		 (SETQ SUBLIST NIL))
		(T
		 (SETQ I (%STRING-SEARCH-CHAR #\SP LINE 0 LEN))
		 (DO-NAMED TOP
			   ((L *KNOWN-DIRECTORY-PROPERTIES* (CDR L)))
			   ((NULL L)
			    (SETQ IND (INTERN (SUBSTRING LINE 0 I) "")
				  FUN #'SUBSTRING))
		   (DO M (CDAR L) (CDR M) (NULL M)
		       (COND ((%STRING-EQUAL LINE 0 (GET-PNAME (CAR M)) 0 I)
			      (SETQ IND (CAR M)
				    FUN (CAAAR L))
			      (RETURN-FROM TOP)))))
		 (SETQ PROP (OR (NULL I) (FUNCALL FUN LINE (1+ I))))
		 (SETQ SUBLIST (CONS PROP (CONS IND SUBLIST)))))))))

;;; Fast date parser for simple case of MM/DD/YY HH:MM:SS
(DEFUN PARSE-DIRECTORY-DATE-PROPERTY (STRING START &OPTIONAL END &AUX FLAG)
  (OR END (SETQ END (ARRAY-ACTIVE-LENGTH STRING)))
  (IF (AND (OR (= END (+ START 8))
	       (SETQ FLAG (= END (+ START 17.))))
	   (= (AREF STRING (+ START 2)) #//)
	   (= (AREF STRING (+ START 5)) #//)
	   (OR (NULL FLAG)
	       (AND (= (AREF STRING (+ START 8)) #\SP)
		    (= (AREF STRING (+ START 11.)) #/:)
		    (= (AREF STRING (+ START 14.)) #/:))))
      (LET (DAY MONTH YEAR HOURS MINUTES SECONDS)
	(SETQ MONTH (PARSE-DIRECTORY-DATE-PROPERTY-1 STRING START)
	      DAY (PARSE-DIRECTORY-DATE-PROPERTY-1 STRING (+ START 3))
	      YEAR (PARSE-DIRECTORY-DATE-PROPERTY-1 STRING (+ START 6)))
	(IF FLAG
	    (SETQ HOURS (PARSE-DIRECTORY-DATE-PROPERTY-1 STRING (+ START 9))
		  MINUTES (PARSE-DIRECTORY-DATE-PROPERTY-1 STRING (+ START 12.))
		  SECONDS (PARSE-DIRECTORY-DATE-PROPERTY-1 STRING (+ START 15.)))
	    (SETQ HOURS 0 MINUTES 0 SECONDS 0))
	;; The file job is wont to give dates of the form 00/00/00 for things made by
	;; DSKDMP, e.g..  Avoid errors later.
	(AND (PLUSP MONTH)
	     (TIME:ENCODE-UNIVERSAL-TIME SECONDS MINUTES HOURS DAY MONTH YEAR)))
      ;;Not in simple format, escape to full parser
      (LET ((DATE (TIME:PARSE-UNIVERSAL-TIME STRING START END)))
	(AND (NUMBERP DATE) DATE))))

(DEFUN PARSE-DIRECTORY-DATE-PROPERTY-1 (STRING START)
  (+ (* (- (AREF STRING START) #/0) 10.)
     (- (AREF STRING (1+ START)) #/0)))

(DEFUN PARSE-DIRECTORY-BOOLEAN-PROPERTY (STRING START)
  (READ-FROM-STRING STRING NIL START))

(DEFUN PARSE-SETTABLE-PROPERTIES (STRING START &AUX LIST)
  (DO ((I START (1+ J))
       (J))
      (NIL)
    (SETQ J (STRING-SEARCH-CHAR #\SP STRING I))
    (PUSH (INTERN (STRING-UPCASE (SUBSTRING STRING I J)) "") LIST)
    (OR J (RETURN)))
  (NREVERSE LIST))

(DEFUN PARSE-DIRECTORY-FREE-SPACE (STRING START &AUX LIST)
  (DO ((I START (1+ I))
       (J)
       (VOL))
      (NIL)
    (OR (SETQ J (STRING-SEARCH-CHAR #/: STRING I))
	(RETURN))
    (SETQ VOL (SUBSTRING STRING I J))
    (SETQ I (STRING-SEARCH-CHAR #/, STRING (SETQ J (1+ J))))
    (PUSH (CONS VOL (ZWEI:PARSE-NUMBER STRING J I)) LIST)
    (OR I (RETURN)))
  (NREVERSE LIST))

(DEFUN PRINT-DECIMAL-PROPERTY (PROP STREAM)
  (LET ((BASE 10.) (*NOPOINT T))
    (PRIN1 PROP STREAM)))

;;; List all directories w.r.t. the pathname.  The only option currently defined
;;; is :NOERROR, which causes the function to return a string rather than an error.
;;; A successful return returns a plist, as in :DIRECTORY-LIST, of pathnames with
;;; one for each directory.  Currently the only non-nil fields in these pathnames
;;; are host, directory, and device, but this may be changed later on by some options.
;;; Also, there are no properties defined yet.

;;; First argument may be a host name for convenience
(DEFUN ALL-DIRECTORIES (&OPTIONAL (PATHNAME USER-LOGIN-MACHINE) &REST OPTIONS &AUX TEM)
  (FORCE-USER-TO-LOGIN)
  (IF (SETQ TEM (GET-PATHNAME-HOST PATHNAME))
      (SETQ PATHNAME (FUNCALL (DEFAULT-PATHNAME NIL TEM) ':NEW-DIRECTORY ':WILD))
      (SETQ PATHNAME (MERGE-PATHNAME-DEFAULTS PATHNAME)))
  (FUNCALL PATHNAME ':ALL-DIRECTORIES OPTIONS))

;;; Default is to complain that it can't be done.
(DEFMETHOD (PATHNAME :ALL-DIRECTORIES) (OPTIONS)
  (IF (MEMQ ':NOERROR OPTIONS)
      " ERROR FOO F Can't list all directories."
      (FERROR NIL " ERROR FOO F Can't list all directories.")))

(DEFMETHOD (MEANINGFUL-ROOT-MIXIN :ALL-DIRECTORIES) (OPTIONS)
  (LOOP FOR FILE IN (CDR (LEXPR-FUNCALL #'DIRECTORY-LIST
					(FUNCALL-SELF ':NEW-PATHNAME
						      ':DIRECTORY ':ROOT ':NAME DIRECTORY
						      ':TYPE ':WILD ':VERSION ':WILD)
					OPTIONS))
	WHEN (GET FILE ':DIRECTORY)
	COLLECT (NCONS (FUNCALL (CAR FILE) ':PATHNAME-AS-DIRECTORY))))

;;; Attempt to complete a pathname string STRING.  DEFAULTS, TYPE and VERSION are as
;;; for MERGE-PATHNAME-DEFAULTS.  Currently recognized options are:
;;; :DELETED - recognize deleted files.
;;; :READ - file is to be used for input.
;;; :WRITE - file is to be used for output.
;;; :OLD - only pre-existing files are allowed.
;;; :NEW-OK - non-existant files are allowed.
;;; Values of SUCCESS are:
;;; :OLD - there is an old file by this name
;;; :NEW - this is a new file, but some completion has been accomplished.
;;; NIL - no completion was possible with the given string and/or defaults.
(DEFUN COMPLETE-PATHNAME (DEFAULTS STRING TYPE VERSION &REST OPTIONS &AUX PATHNAME)
  (DECLARE (RETURN-LIST STRING SUCCESS))
  (FORCE-USER-TO-LOGIN)
  (MULTIPLE-VALUE-BIND (HOST START END)
      (PARSE-PATHNAME-FIND-COLON STRING)
    (AND HOST (SETQ START (OR (STRING-SEARCH-NOT-CHAR #\SP STRING START END) END)
		    STRING (SUBSTRING STRING START END)))
    (SETQ PATHNAME (DEFAULT-PATHNAME DEFAULTS HOST TYPE VERSION)))
  (FUNCALL PATHNAME ':COMPLETE-STRING STRING OPTIONS))

;;; Alter properties as returned by DIRECTORY-LIST.  PROPERTIES is a
;;; PLIST with the same indicators as returned by that.
(DEFUN CHANGE-FILE-PROPERTIES (PATHNAME ERROR-P &REST PROPERTIES)
  (FORCE-USER-TO-LOGIN)
  (SETQ PATHNAME (MERGE-PATHNAME-DEFAULTS PATHNAME))
  (LEXPR-FUNCALL PATHNAME ':CHANGE-PROPERTIES ERROR-P PROPERTIES))

(DEFF CHANGE-PATHNAME-PROPERTIES 'CHANGE-FILE-PROPERTIES)  ;Obsolete old name

;;; Find the properties, like those returned by DIRECTORY-LIST, of a single file.
;;; Returns a plist whose car is the truename and whose cdr is the properties.
(DEFUN FILE-PROPERTIES (PATHNAME &OPTIONAL (ERROR-P T))
  (DECLARE (RETURN-LIST PROPERTIES SETTABLE-PROPERTIES))
  (FORCE-USER-TO-LOGIN)
  (SETQ PATHNAME (MERGE-PATHNAME-DEFAULTS PATHNAME))
  (FUNCALL PATHNAME ':PROPERTIES ERROR-P))

(DEFUN EXPUNGE-DIRECTORY (PATHNAME &REST OPTIONS)
  (LEXPR-FUNCALL (MERGE-PATHNAME-DEFAULTS PATHNAME NIL ':WILD ':WILD) ':EXPUNGE OPTIONS))

;;;; Handle File property lists
(DEFVAR LOAD-PATHNAME-DEFAULTS)

;;; If no :MODE property is in the file's -*- line, and the file type is on this
;;; list, then the corresponding :MODE property is put on the file's plist.
;;; This helps losers who don't have -*- lines get the right mode on TWENEX, etc.
(DEFVAR *FILE-TYPE-MODE-ALIST*
	'(("LISP" . :LISP)
	  ("LSP" . :LISP)
	  ("TEXT" . :TEXT)
	  ("TXT" . :TEXT)
	  ("MIDAS" . :MIDAS)
	  ("MID" . :MIDAS)
	  ("PL1" . :PL1)))

;;; New faster parser, uses :READ-INPUT-BUFFER, returns the new property list.
;;; Sometimes works for multiple-line plists, depending on whether the stream
;;; supports :FILE-PLIST or whether the entire -*- stuff fits into the first buffer.
;;; Beware of making streams do :LINE-INs on files which aren't really ASCII.
;;; :LINE-IN can lose rather badly on such files.
;;; PATHNAME may be NIL if you don't want any properties put on any pathname.
(DEFF READ-SYNTAX-PLIST 'FILE-READ-PROPERTY-LIST)

(DEFUN FILE-READ-PROPERTY-LIST (PATHNAME STREAM &AUX WO PLIST MODE)
  (SETQ WO (FUNCALL STREAM ':WHICH-OPERATIONS))
  (COND ((MEMQ ':SYNTAX-PLIST WO)
	 (SETQ PLIST (FUNCALL STREAM ':SYNTAX-PLIST)))
	((AND (MEMQ ':READ-INPUT-BUFFER WO)
	      (MULTIPLE-VALUE-BIND (BUFFER START END)
		  (FUNCALL STREAM ':READ-INPUT-BUFFER)
		(AND BUFFER (SETQ PLIST (FILE-PARSE-PROPERTY-LIST BUFFER START END)))
		PLIST)))			;Try :LINE-IN if this fails
	(T (DO ((LINE) (EOF)) (NIL)
	     (MULTIPLE-VALUE (LINE EOF) (FUNCALL STREAM ':LINE-IN NIL))
	     (COND ((STRING-SEARCH "-*-" LINE)
		    (SETQ PLIST (FILE-PARSE-PROPERTY-LIST LINE))
		    (FUNCALL STREAM ':SET-POINTER 0)
		    (RETURN NIL))
		   ((OR EOF (STRING-SEARCH-NOT-SET '(#\SP #\TAB) LINE))
		    (FUNCALL STREAM ':SET-POINTER 0)
		    (RETURN NIL))))))
  (AND (NOT (GET (LOCF PLIST) ':MODE))
       (MEMQ ':PATHNAME WO)
       (SETQ MODE (CDR (ASSOC (FUNCALL (FUNCALL STREAM ':PATHNAME) ':TYPE)
			      *FILE-TYPE-MODE-ALIST*)))
       (PUTPROP (LOCF PLIST) MODE ':MODE))
  (AND PATHNAME
       (DO ((L PLIST (CDDR L)))
	   ((NULL L))
	 (FUNCALL PATHNAME ':PUTPROP (SECOND L) (FIRST L))))
  PLIST)

;;; This takes a string which probably has a property list in it, and returns the plist.
;;; If it has any trouble parsing, returns whatever plist it could find.
(DEFUN FILE-PARSE-PROPERTY-LIST (STRING &OPTIONAL (START 0) (END (ARRAY-ACTIVE-LENGTH STRING))
				 &AUX PLIST (IBASE 10.) (PACKAGE SI:PKG-USER-PACKAGE))
  (CATCH-ERROR
    (AND STRING
	 (ARRAYP STRING)
	 (= (ARRAY-ELEMENT-SIZE STRING) 8)
	 ;; Narrow down to first non-blank line.
	 (SETQ START (STRING-SEARCH-NOT-SET '(#\SP #\TAB #\CR) STRING START END))
	 (SETQ END (OR (%STRING-SEARCH-CHAR #\CR STRING START END)
		       (ARRAY-ACTIVE-LENGTH STRING))
	       ;; Narrow down to the stuff between the -*-'s
	       START (STRING-SEARCH "-*-" STRING START END))
	 (SETQ END (STRING-SEARCH "-*-" STRING (SETQ START (+ START 3)) END))
	 ;; Now parse it.
	 (IF (NOT (%STRING-SEARCH-CHAR #/: STRING START END))
	     (SETQ PLIST (LIST ':MODE (READ-FROM-SUBSTRING STRING START END)))
	     (DO ((S START (1+ SEMI-IDX))
		  (COLON-IDX) (SEMI-IDX) (SYM) (ELEMENT NIL NIL) (DONE))
		 (NIL)
	       (OR (SETQ SEMI-IDX (%STRING-SEARCH-CHAR #/; STRING S END))
		   (SETQ DONE T SEMI-IDX END))
	       (OR (SETQ COLON-IDX (%STRING-SEARCH-CHAR #/: STRING S SEMI-IDX))
		   (RETURN NIL))
	       (OR (SETQ SYM (READ-FROM-SUBSTRING STRING S COLON-IDX))
		   (RETURN NIL))
	       (IF (%STRING-SEARCH-CHAR #/, STRING (SETQ S (1+ COLON-IDX)) SEMI-IDX)
		   (DO ((COMMA-IDX) (ELEMENT-DONE))
		       (NIL)
		     (OR (SETQ COMMA-IDX (%STRING-SEARCH-CHAR #/, STRING S SEMI-IDX))
			 (SETQ ELEMENT-DONE T COMMA-IDX SEMI-IDX))
		     (SETQ ELEMENT
			   (NCONC ELEMENT
				  (NCONS (READ-FROM-SUBSTRING STRING S COMMA-IDX))))
		     (AND ELEMENT-DONE (RETURN NIL))
		     (SETQ S (1+ COMMA-IDX)))
		   (SETQ ELEMENT (READ-FROM-SUBSTRING STRING S SEMI-IDX)))
	       (SETQ PLIST (NCONC PLIST (LIST* SYM ELEMENT NIL)))	;Nicer CDR-CODEs
	       (AND DONE (RETURN NIL)))))
    NIL)
  PLIST)

(DEFUN READ-FROM-SUBSTRING (STRING &OPTIONAL (START 0) (END (ARRAY-ACTIVE-LENGTH STRING)))
  (WITH-INPUT-FROM-STRING (S STRING START END)
    (READ S)))

;;; Use this to get "into" the environment specified by the file.
(DEFUN FILE-PROPERTY-BINDINGS (PATHNAME)
  "Returns two values, a list of special variables and a list of values to bind them to."
  (DO ((PL (IF (LOCATIVEP PATHNAME) (CAR PATHNAME) (FUNCALL PATHNAME ':PLIST))
	   (CDDR PL))
       (VARS NIL)
       (VALS NIL)
       (TEM))
      ((NULL PL) (RETURN VARS VALS))
    (AND (SETQ TEM (GET (CAR PL) 'FILE-PROPERTY-BINDINGS))
	 (MULTIPLE-VALUE-BIND (VARS1 VALS1)
	     (FUNCALL TEM PATHNAME (CAR PL) (CADR PL))
	   (SETQ VARS (NCONC VARS1 VARS)
		 VALS (NCONC VALS1 VALS))))))

(DEFUN (:PACKAGE FILE-PROPERTY-BINDINGS) (IGNORE IGNORE PKG)
  (VALUES (NCONS 'PACKAGE) (NCONS (PKG-FIND-PACKAGE PKG ':ASK))))

(DEFUN (:BASE FILE-PROPERTY-BINDINGS) (FILE IGNORE BSE)
  (OR (AND (TYPEP BSE 'FIXNUM) (> BSE 1) (< BSE 37.))
      (FERROR NIL "File ~A has an illegal -*- BASE:~S -*-" FILE BSE))  
  (VALUES (LIST 'BASE 'IBASE) (LIST BSE BSE)))

;;; So that functions can tell if they are being loaded out of, or compiled in, a patch file
(DEFVAR THIS-IS-A-PATCH-FILE NIL)
(DEFUN (:PATCH-FILE FILE-PROPERTY-BINDINGS) (IGNORE IGNORE VAL)
  (VALUES (NCONS 'THIS-IS-A-PATCH-FILE) (NCONS VAL)))

;;; This returns the -*- properties for a ascii file, the qfasl properties for a qfasl file
(DEFF PATHNAME-SYNTAX-PLIST 'FILE-PROPERTY-LIST)

(DEFUN FILE-PROPERTY-LIST (PATHNAME)
  (WITH-OPEN-FILE (STREAM PATHNAME ':CHARACTERS ':DEFAULT)
    (COND ((FUNCALL STREAM ':SEND-IF-HANDLES ':FILE-PLIST))
	  ((FUNCALL STREAM ':CHARACTERS)
	   (FILE-READ-PROPERTY-LIST NIL STREAM))
	  (T
	   (SI:QFASL-STREAM-PROPERTY-LIST STREAM)))))

;;; Find and close all files
(DEFUN CLOSE-ALL-FILES ()
  (NCONC (AND (BOUNDP 'TV:WHO-LINE-FILE-STATE-SHEET)
	      TV:WHO-LINE-FILE-STATE-SHEET
	      (DO ((F (FUNCALL TV:WHO-LINE-FILE-STATE-SHEET ':OPEN-STREAMS)
		      (CDR F))
		   (THINGS-CLOSED NIL))
		  ((NULL F)
		   (FUNCALL TV:WHO-LINE-FILE-STATE-SHEET ':DELETE-ALL-STREAMS)
		   (NREVERSE THINGS-CLOSED))
		(FORMAT ERROR-OUTPUT "~%Closing ~S" (CAR F))
		(PUSH (CAR F) THINGS-CLOSED)
		(FUNCALL (CAR F) ':CLOSE ':ABORT)))
	 (LOOP FOR HOST IN *PATHNAME-HOST-LIST*
	       NCONC (FUNCALL HOST ':CLOSE-ALL-FILES))))

(DEFUN ALL-OPEN-FILES ()
  (SI:ELIMINATE-DUPLICATES (APPEND (FUNCALL TV:WHO-LINE-FILE-STATE-SHEET ':OPEN-STREAMS)
				   (LOOP FOR HOST IN *PATHNAME-HOST-LIST*
					 APPEND (FUNCALL HOST ':OPEN-STREAMS)))))

;;;; Initializations

(COMPILE-FLAVOR-METHODS DUMMY-PATHNAME LOGICAL-PATHNAME LOGICAL-HOST)

(DEFUN PATHNAME-INITIALIZE ()
  (SETQ *PATHNAME-HASH-TABLE* (MAKE-EQUAL-HASH-TABLE ':SIZE 3000. ':AREA PATHNAME-AREA))
  (SETQ *DEFAULT-PATHNAME-DEFAULTS* (MAKE-PATHNAME-DEFAULTS))
  (SETQ LOAD-PATHNAME-DEFAULTS (MAKE-PATHNAME-DEFAULTS))
  )

(ADD-INITIALIZATION "PATHNAME-INITIALIZE" '(PATHNAME-INITIALIZE) '(ONCE))

;;; This would be an initialization, except that this file is loaded too early.
(DEFUN DEFINE-SYS-LOGICAL-DEVICE ()
  (ADD-LOGICAL-PATHNAME-HOST
    "SYS" (SI:GET-SITE-OPTION ':SYS-HOST)
    (SI:GET-SITE-OPTION ':SYS-DIRECTORY-TRANSLATIONS)))