;;;Stuff to do / left over / removed from CL-PATHNAMES --Keith 24-oct-88

;;; 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 	   --- see below for a discourse on pathname properties
;;; :PUTPROP PROP INDICATOR
;;; :REMPROP INDICATOR
;;; :DEVICE, :DIRECTORY, :NAME, :TYPE, :VERSION
;;; :NEW-DEVICE, :NEW-DIRECTORY, :NEW-NAME, :NEW-TYPE, :NEW-VERSION
;;; :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.
;;; *ALWAYS-MERGE-TYPE-AND-VERSION* - user option.  If T, gives TENEX style defaulting
;;;  of pathnames.  Default is NIL.

;;; Other system types (pathname syntaxes) must implement at least the following messages:
;;; They can then be mixed with CHAOS-PATHNAME for use with the QFILE 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 SYS: SYS2; HOST
;;; *PATHNAME-HOST-LIST* is the set of all logical pathname hosts.
;;; *PATHNAME-HOST-LIST* is the set of all physical pathname hosts.
;;; 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.

;;;TRUENAMEs  refer exactly to a single instance of a single file on a single filecomputer.

;;;LOGICAL-HOSTS are provided in an attempt to improve portability of source
;;; file systems to various file computers.  The general idea is we gain by
;;; refering to SYS: SYS; instead of AI: LISPM; .  The mapping between logical hosts
;;; and physical hosts is usally controlled by site options; however that need not
;;; necessarily be true.  However, if this mapping is changed in a running system,
;;; it must be realized that the consequence is that already loaded files will, in
;;; some sense, be assumed to have "come" from the new place.  Being more abstract
;;; objects than physical hosts, logical hosts are preferred when contructing
;;; generic pathnames (see below).

;;;LOGICAL-PATHNAMES are pathnames whose host is a LOGICAL-HOST.

;;;GENERIC-PATHNAMES
;;;  A generic-pathname is a single pathname common to a logical group of files,
;;;  where a logical group consists of all versions and forms (LISP, QFASL, etc.) of a file.
;;;  Generic-pathnames are used for
;;;  storing properties about the logical group.  For example, the mode-line properties
;;;  and information about what packages the file has been loaded into are stored on
;;;  the generic pathname.  The generic pathname is obtained
;;;  by sending a :GENERIC-PATHNAME message to a PATHNAME.
;;;  The following properties are held on GENERIC-PATHNAMES:
;;;   :FILE-ID-PACKAGE-ALIST  Alist keyed on package.  Remembers which forms of
;;;      this file have been loaded into which packages.  Association is (currently)
;;;      a two list (<file-id> <access-pathname>).   
;;;	    <file-id> is a dotted pair (<TRUENAME> . <creation-time>)
;;;	    <access-pathname>  is the acceess pathname used for the load.  It can be
;;;			SYS: SYS; MLAP QFASL > or AI: LISPM; MLAP QFASL, etc.

;;;    A generic pathname normally has a type of unspecific, but not always.  Consider
;;;  FOO.LISP, FOO.QFASL, FOO.DOC and FOO.PRESS.  Being as this is the lisp machine
;;;  (and we have to worry about ITS), the generic pathname for FOO.LISP and FOO.QFASL
;;;  is defined to be FOO.unspecific.  However, we also provide a mechanism to deal with
;;;  cases where certain types of files on certain hosts represent separate logical
;;;  "groups" (.DOC and .PRESS for example).  This consists of sending the host a
;;;  a :GENERIC-BASE-TYPE <type> message when computing a generic pathname.  So we
;;;  might get back "DOC" in the case of .DOC and .PRESS rather than the usual UNSPECIFIC.
;;;  The default :GENERIC-BASE-TYPE method of BASIC-HOST looks at *GENERIC-BASE-TYPE-ALIST*
;;;  for a few types which are assumed to map into non :UNSPECIFIC generic base types
;;;  if not otherwise specified by the host.

;;;  Hosts of generic pathnames.
;;;   Generic pathnames are defined to be BACKTRANSLATED with respect to logical hosts.
;;;  Backtranslating means translating from physical (host device directory) to (currently)
;;;  equivalent logical ones, if possible.
;;;  Thus, one obtains SYS: SYS; from AI: LISPM;.  This is consistant with the
;;;  general idea of generic pathnames, which is to refer to "the object" with as
;;;  high an abstraction as possible.  When moving bands to different sites, this
;;;  causes the right thing to happen as much as in any other scheme.  A consequence
;;;  of making generic pathnames be backtranslated is that ALL files on the
;;;  translated from directories will have logical hosts in the generic pathnames.
;;;  If random miscellaneous files are also stored in directories which are logically
;;;  mapped, questionably intended results could be obtained in some cases.
;;;  However, no great disasters will occur, and it should be kept in mind that
;;;  relatively "clean" bands are shipped between sites, which should have only
;;;  referenced system files.

;;;  When computing a generic pathname, the :GENERIC-BASE-TYPE message is first 
;;;  sent to the actual host (if that happens to be available).  Then the
;;;  (host, directory) pair is backtranslated (possibly obtaining a logical host).
;;;  Then, if the BASE-TYPE is still :UNSPECIFIC, another :GENERIC-BASE-TYPE message
;;;  is tried.

;;;  Names of generic pathnames.
;;;   No conversion of NAME is ever done on generic pathnames.  If you are using logical
;;;  hosts (to attempt to improve portability) you should avoid complex file names
;;;  for the same reason.

;(DEFUN FILE-S$NAMESTRING (OBJECT)
;  "Convert OBJECT to a s$pathname; return a s$namestring specifying just name, type and version."
;  (SEND (PATHNAME OBJECT) :STRING-FOR-DIRED))

;(DEFUN DIRECTORY-S$NAMESTRING (OBJECT)
;  "Convert OBJECT to a pathname; return a s$namestring specifying just device and directory."
;  (SEND (S$PATHNAME OBJECT) :STRING-FOR-DIRECTORY))

;(DEFUN HOST-S$NAMESTRING (OBJECT)
;  "Convert OBJECT to a s$pathname; return a s$namestring with just OBJECT's host name and a colon."
;  (STRING-APPEND (SEND (S$PATHNAME OBJECT) :HOST) ":"))

;(DEFUN ENOUGH-S$NAMESTRING (OBJECT &OPTIONAL (DEFAULTS *DEFAULT-S$PATHNAME-DEFAULTS*))
;  "Return enough s$namestring to produce whatever OBJECT produced
;when merged with DEFAULTS using MERGE-S$PATHNAMES.
;OBJECT is converted to a s$pathname, and that is made into a string
;from which components may be omitted if their values are the same as
;what would result from defaulting whatever is left with the specified defaults."
;  (LET* ((S$PATHNAME (S$PATHNAME OBJECT))
;	 (DEFHOST (DEFAULT-HOST DEFAULTS))
;	 (DP (DEFAULT-S$PATHNAME DEFAULTS (S$PATHNAME-HOST S$PATHNAME)))
;	 (NEED-NAME (NOT (EQUAL (S$PATHNAME-RAW-NAME S$PATHNAME) (S$PATHNAME-RAW-NAME DP))))
;	 (NEED-TYPE (NOT (EQUAL (S$PATHNAME-RAW-TYPE S$PATHNAME) (S$PATHNAME-RAW-TYPE DP))))
;	 (NEED-VERSION (NEQ (S$PATHNAME-RAW-VERSION S$PATHNAME) (S$PATHNAME-RAW-VERSION DP)))
;	 (STRING
;	   (SEND 
;	     (SEND S$PATHNAME :NEW-S$PATHNAME
;		   (IF (EQUAL (S$PATHNAME-RAW-DIRECTORY S$PATHNAME) (S$PATHNAME-RAW-DIRECTORY DP))
;		       :DIRECTORY)
;		   NIL
;		   (IF (EQUAL (S$PATHNAME-RAW-DEVICE S$PATHNAME) (S$PATHNAME-RAW-DEVICE DP))
;		       :DEVICE)
;		   NIL
;		   (IF (EQ (S$PATHNAME-VERSION S$PATHNAME) :NEWEST)
;		       :VERSION)
;		   :NEWEST)
;	     (IF (OR NEED-NAME NEED-TYPE NEED-VERSION)
;		 :STRING-FOR-PRINTING
;	       :STRING-FOR-DIRECTORY))))
;    (IF (OR NEED-NAME NEED-TYPE NEED-VERSION)
;	(IF (EQ (S$PATHNAME-HOST S$PATHNAME) DEFHOST)
;	    (STRING-LEFT-TRIM #/SP (SUBSTRING-AFTER-CHAR #/: STRING))
;	  STRING)
;      (IF (EQ (S$PATHNAME-HOST S$PATHNAME) DEFHOST)
;	  STRING
;	(STRING-APPEND (SEND (S$PATHNAME-HOST S$PATHNAME) :NAME-AS-FILE-COMPUTER)
;		       ": " STRING)))))

;(DEFFLAVOR S$PATHNAME-ERROR () (ERROR))

;(DEFMETHOD (S$PATHNAME-ERROR :CASE :PROCEED-ASKING-USER :NEW-S$PATHNAME)
;	   (CONTINUATION READ-OBJECT-FUNCTION)
;  (FUNCALL CONTINUATION :NEW-S$PATHNAME
;	   (FUNCALL READ-OBJECT-FUNCTION
;		    `(:S$PATHNAME :DEFAULTS (()))
;		    "s$pathname to use instead: ")))

;(COMPILE-FLAVOR-METHODS S$PATHNAME-ERROR)

;;;; PRINC of a s$pathname is just like PRINC of the :STRING-FOR-PRINTING
;;;; PRIN1 prints inside a # ...  so it can be read back.
;(DEFMETHOD (S$PATHNAME :PRINT-SELF) (STREAM IGNORE SLASHIFY-P)
;  (COND (SLASHIFY-P
;	 (PRINC "#" STREAM)
;	 (PRIN1 (TYPE-OF SELF) STREAM)
;	 (TYO #/SP STREAM)
;	 (PRIN1 (SEND SELF :STRING-FOR-PRINTING) STREAM)
;	 (TYO #/ STREAM))
;	(T (SEND STREAM :STRING-OUT (SEND SELF :STRING-FOR-PRINTING)))))

;;And this is what is called to read back a PRIN1'd s$pathname.
;(DEFMETHOD (S$PATHNAME :READ-INSTANCE) (IGNORE STREAM)
;  (PARSE-S$PATHNAME (CLI:READ STREAM T NIL T)))

;(DEFMETHOD (S$PATHNAME :PLIST) ()
;  SI:PROPERTY-LIST)

;;For bootstrapping.
;(DEFMETHOD (S$PATHNAME :PARSE-TYPE-SPEC) S$PATHNAME-PASS-THROUGH-SPEC)

;(DEFVAR CANONICAL-TYPES NIL
;  "Value is alternating list of canonical types (keywords) and their definitions.
;Each definition is an alist of elements of the form
;  (system-type surface-types...)
;where NIL as a system type applies to any system type not specifically mentioned.")

;;Here for bootstrapping.
;(DEFMETHOD (S$PATHNAME :CANONICAL-TYPE) ()
;  (LET ((-TYPE- (SEND SELF :TYPE))
;	(SYSTEM-TYPE (or (send host :send-if-handles :file-system-type)
;			 (send host :system-type)))	;this is for logical hosts
;	(ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON T))
;    (LOOP FOR (CANONICAL-TYPE DEFN) ON CANONICAL-TYPES BY 'CDDR
;	  AS PER-SYSTEM = (OR (ASSQ SYSTEM-TYPE DEFN) (ASSQ NIL DEFN))
;	  DO
;	  (IF (SYS:MEMBER-EQUAL -TYPE- (CDR PER-SYSTEM))
;	      (RETURN
;		(values
;		  CANONICAL-TYPE
;		  (UNLESS (EQUAL -TYPE- (CADR PER-SYSTEM)) -TYPE-))))
;	  FINALLY (RETURN -TYPE-))))

;(DEFMETHOD (S$PATHNAME :RAW-DEVICE) () DEVICE)
;(DEFMETHOD (S$PATHNAME :RAW-DIRECTORY) () DIRECTORY)
;(DEFMETHOD (S$PATHNAME :RAW-NAME) () NAME)
;(DEFMETHOD (S$PATHNAME :RAW-TYPE) () TYPE)

;(DEFUN DESCRIBE-S$PATHNAME (S$PATHNAME)
;  (IF (TYPEP S$PATHNAME 'S$PATHNAME)
;      (DESCRIBE-S$PATHNAME-1 S$PATHNAME)
;    (SETQ S$PATHNAME (PARSE-S$PATHNAME S$PATHNAME))
;    (LET ((HOST (S$PATHNAME-HOST S$PATHNAME))
;	  (DEVICE (S$PATHNAME-DEVICE S$PATHNAME))
;	  (DIRECTORY (S$PATHNAME-DIRECTORY S$PATHNAME))
;	  (NAME (S$PATHNAME-NAME S$PATHNAME))
;	  (TYPE (S$PATHNAME-TYPE S$PATHNAME))
;	  (VERSION (S$PATHNAME-VERSION S$PATHNAME)))
;      (MAPHASH #'(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-S$PATHNAME-1 VAL)))
;	       *S$PATHNAME-HASH-TABLE*))))

;(DEFUN DESCRIBE-S$PATHNAME-1 (S$PATHNAME &AUX PLIST)
;  (AND (SETQ PLIST (S$PATHNAME-PROPERTY-LIST S$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) (S$TRUENAME) (CREATION-DATE))
;		  ((NULL LOADED-IDS))
;		(SETQ INFO (CADAR LOADED-IDS)
;		      S$TRUENAME (CAR INFO)
;		      CREATION-DATE (CDR INFO))
;		(FORMAT T "~&The version ~:[~*~;of ~A ~]in package ~A ~:[is ~A, and ~;~*~]~
;			     was created ~\TIME\~%"
;			FIRST-P S$PATHNAME (CAAR LOADED-IDS) (EQ S$PATHNAME S$TRUENAME) S$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:~%"
;				 S$PATHNAME (NULL LOADED-IDS))
;			 (SETQ FLAG T)))
;		  (FORMAT T "~&~7@T~S:~27T~S~%" IND PROP)))))))

;(DEFMETHOD (S$PATHNAME :INIT) (IGNORE)
;  (OR (VARIABLE-BOUNDP HOST)
;      (FERROR NIL "Host must be specified when initializing a s$pathname"))) 

;;;; Caching of strings
;(DEFMACRO CACHE-IN-VARIABLE (VARIABLE . BODY)
;  `(OR ,VARIABLE
;       (SETQ ,VARIABLE (PROGN . ,BODY)
;	     ,VARIABLE (COPY-INTO-S$PATHNAME-AREA ,VARIABLE))))

;(DEFWRAPPER (S$PATHNAME :STRING-FOR-PRINTING) (IGNORE . BODY)
;  `(CACHE-IN-VARIABLE STRING-FOR-PRINTING . ,BODY))

;(DEFMETHOD (S$PATHNAME :STRING-FOR-WHOLINE) (&OPTIONAL IGNORE)
;  (SEND SELF :STRING-FOR-PRINTING))

;(DEFMETHOD (S$PATHNAME :STRING-FOR-DIRED) ()
;  (SEND SELF :STRING-FOR-PRINTING))

;(DEFMETHOD (S$PATHNAME :STRING-FOR-MINI) ()
;  (SEND SELF :STRING-FOR-PRINTING))

;(DEFMETHOD (S$PATHNAME :STRING-FOR-DIRECTORY) ()
;  (SEND SELF :STRING-FOR-PRINTING))

;(DEFMETHOD (S$PATHNAME :WILD-P) ()
;  (OR (EQ DEVICE :WILD) (EQ DIRECTORY :WILD) (EQ NAME :WILD)
;      (EQ TYPE :WILD) (EQ VERSION :WILD)))

;(DEFMETHOD (S$PATHNAME :DEVICE-WILD-P) ()
;  (EQ DEVICE :WILD))

;(DEFMETHOD (S$PATHNAME :DIRECTORY-WILD-P) ()
;  (EQ DIRECTORY :WILD))

;(DEFMETHOD (S$PATHNAME :NAME-WILD-P) ()
;  (EQ NAME :WILD))

;(DEFMETHOD (S$PATHNAME :TYPE-WILD-P) ()
;  (EQ TYPE :WILD))

;(DEFMETHOD (S$PATHNAME :VERSION-WILD-P) ()
;  (EQ VERSION :WILD))

;(DEFMETHOD (S$PATHNAME :WILDCARD-MAP) (OPERATION PLISTP DIR-LIST-OPTIONS &REST ARGS)
;  (IF (SEND SELF :WILD-P)
;      (LET ((DLIST (APPLY 'DIRECTORY-LIST SELF DIR-LIST-OPTIONS))
;	    (RESULTS '()))
;	(IF (ERRORP DLIST)
;	    DLIST
;	    (OR (DOLIST (DLIST-ENTRY (CDR DLIST))
;		  (IF (NOT (GET DLIST-ENTRY :DIRECTORY))	;Subdirectories aren't files!
;		      (LET ((RESULT (APPLY OPERATION
;					   (IF PLISTP DLIST-ENTRY (CAR DLIST-ENTRY))
;					   ARGS)))
;			(IF (ERRORP RESULT)
;			    (RETURN RESULT)
;			    (PUSH RESULT RESULTS)))))
;		(NREVERSE RESULTS))))
;      (LET ((RESULT
;	      (IF (AND PLISTP (NEQ PLISTP ':MAYBE))
;		  (LET ((DLIST-ENTRY
;			  (FILE-PROPERTIES SELF
;					   (NOT (MEMQ ':NOERROR DIR-LIST-OPTIONS)))))
;		    (IF (ERRORP DLIST-ENTRY)
;			DLIST-ENTRY
;			(APPLY OPERATION DLIST-ENTRY ARGS)))
;		  (APPLY OPERATION SELF ARGS))))
;	(IF (ERRORP RESULT)
;	    RESULT
;	    (LIST RESULT)))))

;(DEFMETHOD (S$PATHNAME :SUPPRESSED-DEVICE-NAMES) () '(NIL :UNSPECIFIC))

;(DEFMETHOD (S$PATHNAME :PRIMARY-DEVICE) () (SEND HOST :PRIMARY-DEVICE))

;;T if files of this host are can be undeleted.
;(DEFMETHOD (S$PATHNAME :UNDELETABLE-P) () NIL)

;;T if a s$namestring with no file type, on this system, reads in as :UNSPECIFIC.
;;This implies that LOAD should treat :UNSPECIFIC in the type
;;as possibly a request for a default, or possibly a specification
;;of a file whose name includes no type.
;(DEFMETHOD (S$PATHNAME :UNSPECIFIC-TYPE-IS-DEFAULT) () NIL)

;;;; This is the flavor that interfaces to the acess stuff
;(DEFFLAVOR HOST-S$PATHNAME
;	((STRING-FOR-EDITOR NIL)
;	 (STRING-FOR-DIRED NIL)
;	 (STRING-FOR-HOST NIL)
;	 (STRING-FOR-DIRECTORY NIL))
;	(S$PATHNAME)
;  (:REQUIRED-METHODS :STRING-FOR-HOST))

;(DEFWRAPPER (HOST-S$PATHNAME :STRING-FOR-EDITOR) (IGNORE . BODY)
;  `(CACHE-IN-VARIABLE STRING-FOR-EDITOR . ,BODY))

;(DEFWRAPPER (HOST-S$PATHNAME :STRING-FOR-DIRED) (IGNORE . BODY)
;  `(CACHE-IN-VARIABLE STRING-FOR-DIRED . ,BODY))

;(DEFWRAPPER (HOST-S$PATHNAME :STRING-FOR-DIRECTORY) (IGNORE . BODY)
;  `(CACHE-IN-VARIABLE STRING-FOR-DIRECTORY . ,BODY))

;(DEFMETHOD (HOST-S$PATHNAME :STRING-FOR-PRINTING) ()
;  (STRING-APPEND (SEND HOST :NAME-AS-FILE-COMPUTER) ": "
;		 (SEND SELF :STRING-FOR-HOST)))

;(DEFMETHOD (HOST-S$PATHNAME :STRING-FOR-EDITOR) ()
;  (STRING-APPEND (SEND SELF :STRING-FOR-HOST) #/SP
;		 (SEND HOST :NAME-AS-FILE-COMPUTER) #/:))

;(DEFWRAPPER (HOST-S$PATHNAME :STRING-FOR-HOST) (IGNORE . BODY)
;  `(CACHE-IN-VARIABLE STRING-FOR-HOST . ,BODY))

;(DEFMETHOD (HOST-S$PATHNAME :STRING-FOR-MINI) ()
;  (SEND SELF :STRING-FOR-HOST))

;(DEFMETHOD (HOST-S$PATHNAME :STRING-FOR-DIRECTORY) ()
;  (SEND SELF :STRING-FOR-HOST))

;(DEFMETHOD (HOST-S$PATHNAME :DIRECTORY-STREAM-DEFAULT-PARSER) ()
;  (SEND HOST :ACCESS-OPERATION :DEFAULT-DIRECTORY-STREAM-PARSER))

;(DEFMETHOD (HOST-S$PATHNAME :OPEN) (S$PATHNAME &REST OPTIONS)
;  (LEXPR-SEND HOST :ACCESS-OPERATION :OPEN SELF S$PATHNAME OPTIONS))

;(DEFMETHOD (HOST-S$PATHNAME :RENAME) (NEW-S$PATHNAME &OPTIONAL (ERROR-P T))
;  (SEND HOST :ACCESS-OPERATION :RENAME SELF NEW-S$PATHNAME ERROR-P))

;(DEFMETHOD (HOST-S$PATHNAME :DELETE) (&OPTIONAL (ERROR-P T))
;  (SEND HOST :ACCESS-OPERATION :DELETE SELF ERROR-P))

;(DEFMETHOD (HOST-S$PATHNAME :DELETE-MULTIPLE-FILES) (ERROR-P FILES)
;  (SEND HOST :ACCESS-OPERATION :DELETE-MULTIPLE-FILES ERROR-P FILES))

;(DEFMETHOD (HOST-S$PATHNAME :UNDELETE-MULTIPLE-FILES) (ERROR-P FILES)
;  (SEND HOST :ACCESS-OPERATION :UNDELETE-MULTIPLE-FILES ERROR-P FILES))

;(DEFMETHOD (HOST-S$PATHNAME :COMPLETE-STRING) (STRING OPTIONS)
;  (SEND HOST :ACCESS-OPERATION :COMPLETE-STRING SELF STRING OPTIONS))

;(DEFMETHOD (HOST-S$PATHNAME :CHANGE-PROPERTIES) (ERROR-P &REST PROPERTIES)
;  (LEXPR-SEND HOST :ACCESS-OPERATION :CHANGE-PROPERTIES SELF ERROR-P PROPERTIES))

;(DEFMETHOD (HOST-S$PATHNAME :DIRECTORY-STREAM) (OPTIONS)
;  (SEND HOST :ACCESS-OPERATION :DIRECTORY-STREAM SELF OPTIONS))

;(DEFMETHOD (HOST-S$PATHNAME :DIRECTORY-LIST) (OPTIONS)
;  (SEND HOST :ACCESS-OPERATION :DIRECTORY-LIST SELF OPTIONS))

;(DEFMETHOD (HOST-S$PATHNAME :DIRECTORY-LIST-STREAM) (OPTIONS)
;  (SEND HOST :ACCESS-OPERATION :DIRECTORY-LIST-STREAM SELF OPTIONS))

;(DEFMETHOD (HOST-S$PATHNAME :HOMEDIR) (&OPTIONAL USER)
;  (SEND HOST :ACCESS-OPERATION :HOMEDIR USER))

;(DEFMETHOD (HOST-S$PATHNAME :CREATE-LINK) (LINK-TO &KEY (ERROR T))
;  (SEND HOST :ACCESS-OPERATION :CREATE-LINK SELF LINK-TO ERROR))

;(DEFMETHOD (HOST-S$PATHNAME :EXPUNGE) (&KEY &OPTIONAL (ERROR T))
;  (SEND HOST :ACCESS-OPERATION :EXPUNGE SELF ERROR))

;(DEFMETHOD (HOST-S$PATHNAME :REMOTE-CONNECT) (&OPTIONAL &KEY (ERROR T) ACCESS-MODE)
;  (SEND HOST :ACCESS-OPERATION :REMOTE-CONNECT SELF ERROR ACCESS-MODE))

;(DEFMETHOD (HOST-S$PATHNAME :CREATE-DIRECTORY) (&KEY &OPTIONAL (ERROR T))
;  (SEND HOST :ACCESS-OPERATION :CREATE-DIRECTORY SELF ERROR))

;(DEFMETHOD (HOST-S$PATHNAME :MULTIPLE-FILE-PLISTS) (FILES OPTIONS)
;  (SEND HOST :ACCESS-OPERATION :MULTIPLE-FILE-PLISTS FILES OPTIONS))

;;;; Perhaps this would be a reasonable default for the way all hosts should work?
;(DEFMETHOD (HOST-S$PATHNAME :ALL-DIRECTORIES) (OPTIONS)
;  (LET ((DIRS (SEND SELF :DIRECTORY-LIST (CONS :DIRECTORIES-ONLY OPTIONS))))
;    (IF (ERRORP DIRS) DIRS
;      (SETQ DIRS (CDR DIRS))
;      (DOLIST (X DIRS)
;	(RPLACA X (SEND (CAR X) :NEW-S$PATHNAME :NAME :UNSPECIFIC :TYPE :UNSPECIFIC
;			:VERSION :UNSPECIFIC)))
;      DIRS)))

;
;;;; 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 (S$PATHNAME :S$PATHNAME-AS-DIRECTORY) ()
;  (SEND SELF :NEW-S$PATHNAME
;	     :RAW-DIRECTORY (cond ((null name) directory)  ;TOPS-20 sometimes sends back a directory-form
;		;s$pathname where a file-form s$pathname was expected, causing this.  
;		;Also, this cause c-u m-x dired ai:*; to win.  In any case, appending a 
;		;NIL into the directory list isnt going to get us anywhere.
;				  ((EQ DIRECTORY :ROOT)
;				   NAME)
;				  (t (APPEND (IF (CONSP DIRECTORY) DIRECTORY
;					       (NCONS DIRECTORY))
;					     (NCONS NAME))))
;	     :NAME :UNSPECIFIC
;	     :TYPE :UNSPECIFIC
;	     :VERSION :UNSPECIFIC))

;(DEFMETHOD (S$PATHNAME :GENERIC-S$PATHNAME) ()
;  (LET* ((TYP (SEND SELF :CANONICAL-TYPE))
;	 (NEW-TYPE (SEND HOST :GENERIC-BASE-TYPE TYP))
;	 (DEV (SEND SELF :DEVICE))
;	 DEV1)
;    (AND (MEMQ DEV (SEND SELF :SUPPRESSED-DEVICE-NAMES))
;	 (SETQ DEV1 (SEND HOST :PRIMARY-DEVICE)))
;    (LET ((STAGE1
;	    (SEND SELF :NEW-S$PATHNAME :DEVICE (OR DEV1 DEV)
;		  		     :DIRECTORY (SEND SELF :DIRECTORY)
;				     :NAME (SEND SELF :NAME)
;				     :TYPE NEW-TYPE
;				     :VERSION :UNSPECIFIC)))
;      ;; Now try backtranslating into a logical s$pathname.
;      ;; If there is no suitable one, we return STAGE1.
;      (DOLIST (H *LOGICAL-S$PATHNAME-HOST-LIST*
;		 STAGE1)
;	(WHEN (AND (TYPEP H 'LOGICAL-HOST) (EQ HOST (SEND H :PHYSICAL-HOST)))
;	  (LET ((BTPN (SEND (SEND H :SAMPLE-S$PATHNAME) :BACK-TRANSLATED-S$PATHNAME STAGE1)))
;	    (WHEN BTPN
;	      (IF (EQ NEW-TYPE :UNSPECIFIC)
;		  (RETURN (SEND BTPN :NEW-S$PATHNAME :TYPE (SEND H :GENERIC-BASE-TYPE
;							       (SEND BTPN :CANONICAL-TYPE))))
;		(RETURN BTPN)))))))))

;(DEFMETHOD (S$PATHNAME :SOURCE-S$PATHNAME) ()
;  (GENERIC-S$PATHNAME-SOURCE-S$PATHNAME (SEND SELF :GENERIC-S$PATHNAME)))

;(DEFUN GENERIC-S$PATHNAME-SOURCE-S$PATHNAME (S$PATHNAME)
;  "Given the generic s$pathname S$PATHNAME, return a s$pathname for the source file.
;We use the actual source file name as recorded, if possible."
;  (LET ((QFASL-SOURCE (SEND S$PATHNAME :GET :QFASL-SOURCE-FILE-UNIQUE-ID))
;	(LOADED-FILE (CAADAR (SEND S$PATHNAME :GET :FILE-ID-PACKAGE-ALIST))))
;    (MULTIPLE-VALUE-BIND (CTYPE OTYPE)
;	(COND (QFASL-SOURCE
;	       (IF (CONSP QFASL-SOURCE)		;dont bomb if list frobs somehow 
;		   ;left from cold load.
;		   (SETQ QFASL-SOURCE
;			 (S$PATHNAME-FROM-COLD-LOAD-PATHLIST QFASL-SOURCE)))
;	       (SEND QFASL-SOURCE :CANONICAL-TYPE))
;	      ((AND LOADED-FILE
;		    (NOT (EQUAL (SEND LOADED-FILE :TYPE) "QFASL")))
;	       (SEND LOADED-FILE :CANONICAL-TYPE))
;	      (T (SEND (SEND S$PATHNAME :HOST) :GENERIC-SOURCE-TYPE
;		       (SEND S$PATHNAME :CANONICAL-TYPE))))
;      (SEND S$PATHNAME :NEW-S$PATHNAME :VERSION :NEWEST
;	    ;; The replacement of :UNSPECIFIC by :LISP
;	    ;; is for files that were last compiled on ITS or FC.
;	    :CANONICAL-TYPE (IF (EQ CTYPE :UNSPECIFIC) :LISP CTYPE)
;	    :ORIGINAL-TYPE OTYPE))))

;(DEFMETHOD (S$PATHNAME :TRANSLATED-S$PATHNAME) () SELF)

;(DEFMETHOD (S$PATHNAME :BACK-TRANSLATED-S$PATHNAME) (S$PATHNAME) S$PATHNAME)

;;;; This is used to parse a string which may not have the host in it
;(DEFMETHOD (S$PATHNAME :PARSE-S$TRUENAME) (STRING)
;  (PARSE-S$PATHNAME STRING HOST))
;
;(DEFUN DECODE-CANONICAL-TYPE (CANONICAL-TYPE SYSTEM-TYPE)
;  (LET ((PROP (GETF CANONICAL-TYPES CANONICAL-TYPE)))
;    (IF (NULL PROP)
;	CANONICAL-TYPE
;      (LET ((PER-SYSTEM (OR (ASSQ SYSTEM-TYPE PROP) (ASSQ NIL PROP))))
;	(VALUES (CADR PER-SYSTEM) (CDR PER-SYSTEM))))))

;(DEFMACRO DEFINE-CANONICAL-TYPE (CANONICAL-TYPE DEFAULT-SURFACE-TYPE &BODY SYSTEM-SURFACE-TYPES)
;  "Defines a keyword CANONICAL-TYPE as a canonical type.
;DEFAULT-SURFACE-TYPE is the string that it corresponds to.
;SYSTEM-SURFACE-TYPES overrides that default for specific kinds of file systems.
;Each element of it is a list whose CAR is a file-system keyword
;/(:ITS, :UNIX, etc). and whose remaining elements are surface strings,
;all of which correspond to this canonical type.
;The first surface string in each list is the preferred one for that system."
;  `(DEFINE-CANONICAL-TYPE-1 ',CANONICAL-TYPE ',DEFAULT-SURFACE-TYPE ',SYSTEM-SURFACE-TYPES))

;(DEFUN DEFINE-CANONICAL-TYPE-1 (CTYPE DSTY SSTYS)
;  (LET ((ALIST (LIST (LIST NIL DSTY))))
;    (DOLIST (ELT SSTYS)
;      (IF (SYMBOLP (CAR ELT))
;	  (PUSH ELT ALIST)
;	(DOLIST (SYSTEM (CAR ELT))
;	  (PUSH (CONS SYSTEM (CDR ELT)) ALIST))))
;    (IF (GET (LOCF CANONICAL-TYPES) CTYPE)
;	(PUTPROP (LOCF CANONICAL-TYPES) ALIST CTYPE)
;      (SETF (CDR (OR (LAST CANONICAL-TYPES)
;		     (LOCF CANONICAL-TYPES)))
;	    (LIST* CTYPE ALIST NIL)))))

;(DEFINE-CANONICAL-TYPE :LISP "LISP"
;  ((:TOPS-20 :TENEX) "LISP" "LSP")
;  (:UNIX "L" "LISP")
;  (:VMS "LSP"))

;(DEFINE-CANONICAL-TYPE :QFASL "QFASL"
;  (:UNIX "QF")
;  (:VMS "QFS"))

;;;dog-meat (DEFINE-CANONICAL-TYPE :KFASL "KFASL")	;compiled files for FALCON.

;(DEFINE-CANONICAL-TYPE :FBIN "FBIN")	;compiled files for the FALCON.

;(DEFINE-CANONICAL-TYPE :FDEF "FDEF")	;cross-compilation environments for the FALCON.

;(DEFINE-CANONICAL-TYPE :MIDAS "MIDAS"
;  ((:TOPS-20 :TENEX) "MID" "MIDAS")
;  (:UNIX "MD")
;  (:VMS "MID"))

;(DEFINE-CANONICAL-TYPE :MAC "MAC")
;(DEFINE-CANONICAL-TYPE :TASM "TASM")

;(DEFINE-CANONICAL-TYPE :PALX "PALX")

;(DEFINE-CANONICAL-TYPE :TEXT "TEXT"
;  ((:TOPS-20 :TENEX) "TEXT" "TXT")
;  (:UNIX "TX")
;  (:VMS "TXT"))

;(define-canonical-type :botex "BOTEX"
;  (:vms "TEX"))

;(DEFINE-CANONICAL-TYPE :DOC "DOC")
;(DEFINE-CANONICAL-TYPE :MSS "MSS")
;(DEFINE-CANONICAL-TYPE :TEX "TEX")

;(DEFINE-CANONICAL-TYPE :PRESS "PRESS"
;  (:UNIX "PR")
;  (:VMS "PRS"))

;(DEFINE-CANONICAL-TYPE :IMPRESS "IMPRESS")
;(DEFINE-CANONICAL-TYPE :DVI "DVI")

;(DEFINE-CANONICAL-TYPE :PATCH-DIRECTORY "PATCH-DIRECTORY"
;  (:ITS "(PDIR)")
;  (:UNIX "PD")
;  (:VMS "PDR")
;  (:LMFS "PDIR"))

;(DEFINE-CANONICAL-TYPE :LOGICAL-S$PATHNAME-TRANSLATIONS "TRANSLATIONS"
;  (:ITS "LOGTRN")
;  (:UNIX "LT" "LOGTRAN")
;  (:VMS "LTR"))

;(DEFINE-CANONICAL-TYPE :QWABL "QWABL"
;  (:UNIX "QW")
;  (:VMS "QWB"))

;(DEFINE-CANONICAL-TYPE :BABYL "BABYL"
;  (:UNIX "BB")
;  (:VMS "BAB"))

;(DEFINE-CANONICAL-TYPE :XMAIL "XMAIL"
;  (:UNIX "XM")
;  (:VMS "XML"))

;(DEFINE-CANONICAL-TYPE :MAIL "MAIL"
;  (:UNIX "MA")
;  (:VMS "MAI"))

;(DEFINE-CANONICAL-TYPE :INIT "INIT"
;  (:UNIX "IN")
;  (:VMS "INI"))

;(DEFINE-CANONICAL-TYPE :UNFASL "UNFASL"
;  (:UNIX "UF")
;  (:VMS "UNF"))

;(DEFINE-CANONICAL-TYPE :OUTPUT "OUTPUT"
;  (:UNIX "OT")
;  (:VMS "OUT"))

;(DEFINE-CANONICAL-TYPE :WIDTHS "WIDTHS"
;  (:UNIX "WD")
;  (:VMS "WID"))

;(DEFINE-CANONICAL-TYPE :PL1 "PL1")
;(DEFINE-CANONICAL-TYPE :CLU "CLU")
;(DEFINE-CANONICAL-TYPE :C "C")

;(define-canonical-type :scheme "SCHEME"
;  (:unix "SCM")
;  (:vms "SCM"))

;(define-canonical-type :t "T")

;(DEFMETHOD (S$PATHNAME :SYSTEM-TYPE) ()
;  (SEND HOST :SYSTEM-TYPE))

;(DEFUN FIND-FILE-WITH-TYPE (FILE CANONICAL-TYPE)
;  "Try to open a file with some type that matches CANONICAL-TYPE.
;All other components come from FILE, a s$pathname or string, or are defaulted.
;Return the file's s$truename if successful, NIL if file-not-found.
;Any other error condition is not handled."
;  (CONDITION-CASE (STREAM)
;      (SEND (MERGE-S$PATHNAME-DEFAULTS FILE) :OPEN-CANONICAL-TYPE CANONICAL-TYPE NIL
;	    :DIRECTION NIL)
;    (FILE-NOT-FOUND NIL)
;    (:NO-ERROR (PROG1 (SEND STREAM :S$TRUENAME) (CLOSE STREAM)))))

;(DEFMETHOD (S$PATHNAME :TYPES-FOR-CANONICAL-TYPE) (CANONICAL-TYPE)
;  (MULTIPLE-VALUE-BIND (NIL TEM)
;      (DECODE-CANONICAL-TYPE CANONICAL-TYPE (SEND HOST :SYSTEM-TYPE))
;    TEM))

;(DEFMETHOD (S$PATHNAME :OPEN-CANONICAL-DEFAULT-TYPE) (CANONICAL-TYPE &REST ARGS)
;  (IF TYPE
;      (LEXPR-SEND SELF :OPEN SELF ARGS)
;    (LEXPR-SEND SELF :OPEN-CANONICAL-TYPE CANONICAL-TYPE SELF ARGS)))

;(DEFMETHOD (S$PATHNAME :OPEN-CANONICAL-TYPE)
;	   (CANONICAL-TYPE PRETRANSLATED-S$PATHNAME &REST ARGS
;	    &KEY (ERROR T) &ALLOW-OTHER-KEYS)
;  (LET ((SURFACE-TYPES (SEND SELF :TYPES-FOR-CANONICAL-TYPE CANONICAL-TYPE)))
;    (DO ((TYPES SURFACE-TYPES (CDR TYPES)))
;	((NULL TYPES)
;	 (LET ((CONDITION
;		 ;; If no file found, signal with the preferred surface type.
;		 (MAKE-CONDITION 'FILE-NOT-FOUND "File not found for ~A."
;				 (SEND SELF :NEW-TYPE CANONICAL-TYPE)
;				 :OPEN)))
;	   (IF ERROR (SIGNAL-CONDITION CONDITION) CONDITION)))
;      (CONDITION-CASE (RESULT)
;	  (LEXPR-SEND (SEND SELF :NEW-S$PATHNAME :TYPE (CAR TYPES)) :OPEN
;		      (SEND (OR PRETRANSLATED-S$PATHNAME SELF) :NEW-S$PATHNAME
;			    :TYPE (IF (EQ TYPES SURFACE-TYPES)
;				       CANONICAL-TYPE
;				     (CAR TYPES)))
;		      :ERROR T
;		      ARGS)
;	(FILE-NOT-FOUND NIL)
;	(:NO-ERROR (RETURN RESULT))))))
;
;;;; Creation of s$pathnames, normal user interface.

;;;These two methods are right for file systems where upper case is normally used.
;(DEFMETHOD (S$PATHNAME :NEW-SUGGESTED-NAME) (NEW-NAME)
;  (SEND SELF :NEW-S$PATHNAME :NAME (STRING-UPCASE NEW-NAME)))

;(DEFMETHOD (S$PATHNAME :NEW-SUGGESTED-DIRECTORY) (NEW-DIRECTORY)
;  (SEND SELF :NEW-S$PATHNAME :DIRECTORY (STRING-UPCASE NEW-DIRECTORY)))

;(DEFMETHOD (S$PATHNAME :NEW-DEVICE) (NEW-DEVICE)
;  (SEND SELF :NEW-S$PATHNAME :DEVICE NEW-DEVICE))

;(DEFMETHOD (S$PATHNAME :NEW-DIRECTORY) (NEW-DIRECTORY)
;  (SEND SELF :NEW-S$PATHNAME :DIRECTORY NEW-DIRECTORY))

;(DEFMETHOD (S$PATHNAME :NEW-NAME) (NEW-NAME)
;  (SEND SELF :NEW-S$PATHNAME :NAME NEW-NAME))

;(DEFMETHOD (S$PATHNAME :NEW-TYPE) (NEW-TYPE)
;  (SEND SELF :NEW-S$PATHNAME :TYPE NEW-TYPE))

;(DEFMETHOD (S$PATHNAME :NEW-VERSION) (NEW-VERSION)
;  (SEND SELF :NEW-S$PATHNAME :VERSION NEW-VERSION))

;(DEFMETHOD (S$PATHNAME :NEW-RAW-DEVICE) (NEW-DEVICE)
;  (SEND SELF :NEW-S$PATHNAME :RAW-DEVICE NEW-DEVICE))

;(DEFMETHOD (S$PATHNAME :NEW-RAW-DIRECTORY) (NEW-DIRECTORY)
;  (SEND SELF :NEW-S$PATHNAME :RAW-DIRECTORY NEW-DIRECTORY))

;(DEFMETHOD (S$PATHNAME :NEW-RAW-NAME) (NEW-NAME)
;  (SEND SELF :NEW-S$PATHNAME :RAW-NAME NEW-NAME))

;(DEFMETHOD (S$PATHNAME :NEW-RAW-TYPE) (NEW-TYPE)
;  (SEND SELF :NEW-S$PATHNAME :RAW-TYPE NEW-TYPE))

;(DEFMETHOD (S$PATHNAME :NEW-CANONICAL-TYPE) (CANONICAL-TYPE &OPTIONAL ORIGINAL-TYPE)
;  (SEND SELF :NEW-S$PATHNAME :CANONICAL-TYPE CANONICAL-TYPE :ORIGINAL-TYPE ORIGINAL-TYPE))

;;;; These exist for the sake of ITS
;(DEFMETHOD (S$PATHNAME :NEW-TYPE-AND-VERSION) (NEW-TYPE NEW-VERSION)
;  (SEND SELF :NEW-S$PATHNAME :TYPE NEW-TYPE :VERSION NEW-VERSION))

;(DEFMETHOD (S$PATHNAME :TYPE-AND-VERSION) ()
;  (VALUES TYPE VERSION))

;(DEFMETHOD (S$PATHNAME :PATCH-FILE-S$PATHNAME) (NAM SAME-DIRECTORY-P PATOM TYP &REST ARGS)
;  (LET ((PATOM (STRING-UPCASE (IF SAME-DIRECTORY-P PATOM NAM))))
;    (SELECTQ TYP
;      (:SYSTEM-DIRECTORY
;       (SEND SELF :NEW-S$PATHNAME :NAME PATOM
;		  :TYPE (IF SAME-DIRECTORY-P "DIRECTORY" :PATCH-DIRECTORY)
;		  :VERSION :NEWEST))
;      (:VERSION-DIRECTORY
;       (SEND SELF :NEW-S$PATHNAME :NAME (FORMAT NIL "~A-~D" PATOM (CAR ARGS))
;		  :TYPE (IF SAME-DIRECTORY-P "DIRECTORY" :PATCH-DIRECTORY)
;		  :VERSION :NEWEST))
;      (:PATCH-FILE
;       (SEND SELF :NEW-S$PATHNAME
;	          :NAME (FORMAT NIL "~A-~D-~D" PATOM (CAR ARGS) (CADR ARGS))
;		  :TYPE (CADDR ARGS)
;		  :VERSION :NEWEST)))))

;(DEFUN INIT-FILE-S$PATHNAME (PROGRAM-NAME &OPTIONAL (HOST USER-LOGIN-MACHINE))
;  "Return the s$pathname for PROGRAM-NAME's init file, on host HOST.
;FORCE-P means don't get an error if HOST cannot be contacted; guess instead."
;  (SEND (USER-HOMEDIR HOST NIL USER-ID) :INIT-FILE (STRING PROGRAM-NAME)))

;(DEFMETHOD (HOST-S$PATHNAME :INIT-FILE) (PROGRAM-NAME)
;  (SEND SELF :NEW-S$PATHNAME :NAME PROGRAM-NAME
;			   :TYPE :INIT
;			   :VERSION :NEWEST))

;(DEFUN COMPUTE-HOMEDIR-FROM-USER-ID (USER HOST)
;  "Return the best homedir name for user-id as we can, without a file server."
;  ;; This might want to depend on the host's system type;
;  ;; perhaps using an operation defined by host type mixins.
;  (IGNORE HOST)
;  USER)
						
;(DEFMETHOD (S$PATHNAME :QUIET-HOMEDIR) (&OPTIONAL (USER USER-ID))
;  (SEND (MAKE-S$PATHNAME :HOST HOST
;		       :DEVICE (SEND SELF :PRIMARY-DEVICE))
;	:NEW-SUGGESTED-DIRECTORY (COMPUTE-HOMEDIR-FROM-USER-ID USER HOST)))

;;;; Make a guess for the home directory if we don't have it.  Don't ask the host.
;;(DEFMETHOD (S$PATHNAME :QUIET-HOMEDIR) ()
;;  (SEND (MAKE-S$PATHNAME :HOST HOST :DEVICE (SEND SELF :PRIMARY-DEVICE))
;;	:NEW-SUGGESTED-DIRECTORY USER-ID))
;
;(DEFUN MAKE-S$PATHNAME (&REST OPTIONS
;		      &KEY (DEFAULTS T)
;			   (HOST (IF (EQ DEFAULTS T)
;				     (DEFAULT-HOST *DEFAULT-S$PATHNAME-DEFAULTS*)
;				   (DEFAULT-HOST DEFAULTS)))
;		      &ALLOW-OTHER-KEYS)
;  "Create a s$pathname, specifying components as keyword arguments.
;If DEFAULTS is a s$pathname or a defaults list, the s$pathname is defaulted from it.
;If DEFAULTS is T (the default), the host is defaulted from
;*DEFAULT-S$PATHNAME-DEFAULTS* and the other components are not defaulted at all."
;  (DECLARE (ARGLIST &KEY (DEFAULTS T)
;		    	 HOST DEVICE RAW-DEVICE DIRECTORY RAW-DIRECTORY
;			 NAME RAW-NAME TYPE RAW-TYPE VERSION
;			 CANONICAL-TYPE ORIGINAL-TYPE))
;  (IF (NOT (SYMBOLP DEFAULTS))
;      (MERGE-S$PATHNAME-DEFAULTS
;	(LEXPR-SEND (SAMPLE-S$PATHNAME HOST) :NEW-S$PATHNAME OPTIONS)
;	DEFAULTS)
;    (LEXPR-SEND (SAMPLE-S$PATHNAME HOST) :NEW-S$PATHNAME OPTIONS)))

;(DEFUN SAMPLE-S$PATHNAME (HOST)
;  "Return a s$pathname for HOST with all other components NIL."
;  (send (get-s$pathname-host host) :sample-s$pathname))

;;;; Because some s$pathname flavors can change, we've got to uncache the old sample s$pathname if
;;;; it has changed.
;(DEFUN FIX-SAMPLE-S$PATHNAMES-SITE ()
;  (DOLIST (HOST *S$PATHNAME-HOST-LIST*)
;    (WHEN (GET (SEND HOST :S$PATHNAME-FLAVOR) 'S$PATHNAME-FLAVOR-CHANGES)
;      (send host :send-if-handles :reset-sample-s$pathname))))

;(ADD-INITIALIZATION "Reset Sample s$pathnames" '(FIX-SAMPLE-S$PATHNAMES-SITE) '(:SITE-OPTION))

;;;; Make sure that a :NEW-S$PATHNAME which specifies a new host
;;;; is processed by the flavor of s$pathname for that host.
;(DEFWRAPPER (S$PATHNAME :NEW-S$PATHNAME) (OPTIONS . BODY)
;  `(LET ((NEW-HOST (GETF OPTIONS :HOST))
;	 (NEW-S$PATHNAME-HOST NIL))
;     (IF (AND NEW-HOST
;	      (SETQ NEW-S$PATHNAME-HOST (GET-S$PATHNAME-HOST NEW-HOST))
;	      (NEQ HOST NEW-S$PATHNAME-HOST))
;	 (LEXPR-SEND (SAMPLE-S$PATHNAME NEW-S$PATHNAME-HOST)
;		     :NEW-S$PATHNAME
;		     :STARTING-S$PATHNAME (OR (GET (LOCF OPTIONS) :STARTING-S$PATHNAME)
;					     SELF)
;		     OPTIONS)
;	 . ,BODY)))

;;;; This is the fundamental way of altering some of the components of a s$pathname.
;;;; Specify an alternating list of components and values.
;;;; Components allowed are :HOST, :DEVICE, :DIRECTORY, :NAME, :TYPE and :VERSION;
;;;; All the :NEW-x operations call this one (by default),
;;;; and all the :PARSE-x operations (except :PARSE-S$NAMESTRING)
;;;; are called only by MAKE-S$PATHNAME-1, which is called only from here.

;;;; STARTING-S$PATHNAME is specified if we are doing the work on behalf of that s$pathname
;;;; because it was told to change hosts, and we are a s$pathname of the correct new host.
;(DEFMETHOD (S$PATHNAME :NEW-S$PATHNAME) (&REST OPTIONS
;				     &KEY STARTING-S$PATHNAME
;				     &ALLOW-OTHER-KEYS)
;  (APPLY #'MAKE-S$PATHNAME-1
;	 :STARTING-S$PATHNAME (OR STARTING-S$PATHNAME SELF)
;	 :PARSING-S$PATHNAME SELF
;	 OPTIONS))

;;;; MAKE-S$PATHNAME is equivalent to this if the standard :NEW-S$PATHNAME method is in use.
;;;; MAKE-S$PATHNAME could do this directly, except that would take away
;;;; the ability for some s$pathname flavor to replace this entirely.
;(DEFUN MAKE-S$PATHNAME-1 (&REST OPTIONS &KEY &ALLOW-OTHER-KEYS
;			STARTING-S$PATHNAME &OPTIONAL (PARSING-S$PATHNAME STARTING-S$PATHNAME)
;			&OPTIONAL (HOST NIL HOST-P) (VERSION NIL VERSION-P)
;			(ORIGINAL-TYPE NIL ORIGINAL-TYPE-P)
;			&AUX DEVICE-P DIRECTORY-P NAME-P TYPE-P
;			DEVICE DIRECTORY NAME TYPE CANONICAL-TYPE)
;  (LOOP FOR (KEYWORD VALUE) ON OPTIONS BY 'CDDR
;	DO
;	(SELECTQ KEYWORD
;	  (:NAME (UNLESS NAME-P (SETQ NAME VALUE NAME-P T)))
;	  (:RAW-NAME (UNLESS NAME-P (SETQ NAME VALUE NAME-P :RAW)))
;	  (:DIRECTORY (UNLESS DIRECTORY-P (SETQ DIRECTORY VALUE DIRECTORY-P T)))
;	  (:RAW-DIRECTORY (UNLESS DIRECTORY-P (SETQ DIRECTORY VALUE DIRECTORY-P :RAW)))
;	  (:DEVICE (UNLESS DEVICE-P (SETQ DEVICE VALUE DEVICE-P T)))
;	  (:RAW-DEVICE (UNLESS DEVICE-P (SETQ DEVICE VALUE DEVICE-P :RAW)))
;	  (:TYPE (UNLESS TYPE-P
;		   (IF (AND (SYMBOLP VALUE) (NOT (MEMQ VALUE '(NIL :UNSPECIFIC))))
;		       (SETQ CANONICAL-TYPE VALUE TYPE-P :CANONICAL)
;		     (SETQ TYPE VALUE TYPE-P T))))
;	  (:RAW-TYPE (UNLESS TYPE-P (SETQ TYPE VALUE TYPE-P :RAW)))
;	  (:CANONICAL-TYPE
;	   (UNLESS TYPE-P (SETQ CANONICAL-TYPE VALUE TYPE-P :CANONICAL)))
;	  ;; All keywords that do NOT require special decoding must go here.
;	  ((:HOST :VERSION :STARTING-S$PATHNAME :PARSING-S$PATHNAME
;	    :ORIGINAL-TYPE :DEFAULTS NIL)
;	   NIL)
;	  (T (FERROR NIL "Unknown keyword ~S to MAKE-S$PATHNAME or :NEW-S$PATHNAME." KEYWORD))))
;  (UNLESS HOST-P
;    (SETQ HOST (S$PATHNAME-HOST STARTING-S$PATHNAME)))
;  (SETQ HOST (GET-S$PATHNAME-HOST HOST))
;  ;; Turn a specified canonical type into a string (in standard case).
;  (WHEN (EQ TYPE-P :CANONICAL)
;    (MULTIPLE-VALUE-BIND (PREFERRED ALL)
;	(DECODE-CANONICAL-TYPE CANONICAL-TYPE (SEND HOST :SYSTEM-TYPE))
;      (UNLESS ORIGINAL-TYPE-P
;	(SETQ ORIGINAL-TYPE (S$PATHNAME-TYPE STARTING-S$PATHNAME)))
;      (SETQ TYPE (IF (SYS:MEMBER-EQUAL ORIGINAL-TYPE ALL)
;		     ORIGINAL-TYPE
;		     PREFERRED))))
;  (COND ((EQ (S$PATHNAME-HOST STARTING-S$PATHNAME) HOST)
;	 (UNLESS DEVICE-P
;	   (SETQ DEVICE (S$PATHNAME-RAW-DEVICE STARTING-S$PATHNAME) DEVICE-P :RAW))
;	 (UNLESS DIRECTORY-P
;	   (SETQ DIRECTORY (S$PATHNAME-RAW-DIRECTORY STARTING-S$PATHNAME) DIRECTORY-P :RAW))
;	 (UNLESS NAME-P
;	   (SETQ NAME (S$PATHNAME-RAW-NAME STARTING-S$PATHNAME) NAME-P :RAW))
;	 (UNLESS TYPE-P
;	   (SETQ TYPE (S$PATHNAME-RAW-TYPE STARTING-S$PATHNAME) TYPE-P :RAW)))
;	;; Hosts don't match; must convert to standard syntax and reparse.
;	(T
;	 (UNLESS DEVICE-P
;	   (SETQ DEVICE (S$PATHNAME-DEVICE STARTING-S$PATHNAME)))
;	 (UNLESS DIRECTORY-P
;	   (SETQ DIRECTORY (S$PATHNAME-DIRECTORY STARTING-S$PATHNAME)))
;	 (UNLESS NAME-P
;	   (SETQ NAME (S$PATHNAME-NAME STARTING-S$PATHNAME)))
;	 (UNLESS TYPE-P
;	   (SETQ TYPE (S$PATHNAME-TYPE STARTING-S$PATHNAME)))))
;  (UNLESS VERSION-P
;    (SETQ VERSION (S$PATHNAME-RAW-VERSION STARTING-S$PATHNAME)))
;  ;; The new fields are parsed only once to save time, consing, and possible errors
;  ;; due to incompatible fields in different types of s$pathnames.
;  (WHEN (NEQ DEVICE-P :RAW)
;    (SETQ DEVICE (SEND PARSING-S$PATHNAME :PARSE-DEVICE-SPEC DEVICE)))
;  (WHEN (NEQ DIRECTORY-P :RAW)
;    (SETQ DIRECTORY (SEND PARSING-S$PATHNAME :PARSE-DIRECTORY-SPEC DIRECTORY)))
;  (WHEN (NEQ NAME-P :RAW)
;    (SETQ NAME (SEND PARSING-S$PATHNAME :PARSE-NAME-SPEC NAME)))
;  (WHEN (NEQ TYPE-P :RAW)
;    (SETQ TYPE (SEND PARSING-S$PATHNAME :PARSE-TYPE-SPEC TYPE)))
;  (SETQ VERSION (SEND PARSING-S$PATHNAME :PARSE-VERSION-SPEC VERSION))
;  (MAKE-S$PATHNAME-INTERNAL HOST DEVICE DIRECTORY NAME TYPE VERSION))

;(DEFSUBST FAST-NEW-S$PATHNAME (S$PATHNAME NEW-DEVICE NEW-DIRECTORY NEW-NAME NEW-TYPE NEW-VERSION)
;  "Modify those fields of S$PATHNAME that are supplied as non-NIL arguments."
;  (SEND S$PATHNAME :NEW-S$PATHNAME
;	(AND NEW-DEVICE :DEVICE) NEW-DEVICE
;	(AND NEW-DIRECTORY :DIRECTORY) NEW-DIRECTORY
;	(AND NEW-NAME :NAME) NEW-NAME
;	(AND NEW-TYPE :TYPE) NEW-TYPE
;	(AND NEW-VERSION :VERSION) NEW-VERSION))
;
;(DEFUN S$PATHNAME-PASS-THROUGH-SPEC (IGNORE SPEC)
;  (SEND SELF :PARSE-COMPONENT-SPEC SPEC))

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

;;;; These operations should in general convert an interchange component	to a raw one
;;;; and also turn any invalid component into something valid.

;(DEFMETHOD (S$PATHNAME :PARSE-DEVICE-SPEC) (SPEC)
;  (COND ((STRINGP SPEC) (SEND SELF :PARSE-COMPONENT-SPEC SPEC))
;	((AND (CONSP SPEC)
;	      (STRINGP (CAR SPEC))
;	      (NULL (CDR SPEC)))
;	 (SEND SELF :PARSE-COMPONENT-SPEC (CAR SPEC)))
;	((MEMQ SPEC '(NIL :UNSPECIFIC :WILD)) SPEC)
;	(T (S$PATHNAME-DEVICE (QUIET-USER-HOMEDIR HOST)))))
	
;(DEFMETHOD (S$PATHNAME :PARSE-DIRECTORY-SPEC) (SPEC)
;  (COND ((STRINGP SPEC) (SEND SELF :PARSE-COMPONENT-SPEC SPEC))
;	((AND (CONSP SPEC)
;	      (STRINGP (CAR SPEC))
;	      (NULL (CDR SPEC)))
;	 (SEND SELF :PARSE-COMPONENT-SPEC (CAR SPEC)))
;	((MEMQ SPEC '(NIL :UNSPECIFIC :WILD)) SPEC)
;	(T (S$PATHNAME-DIRECTORY (QUIET-USER-HOMEDIR HOST)))))

;(DEFMETHOD (S$PATHNAME :PARSE-NAME-SPEC) (SPEC)
;  (COND ((STRINGP SPEC) (SEND SELF :PARSE-COMPONENT-SPEC SPEC))
;	((AND (CONSP SPEC)
;	      (STRINGP (CAR SPEC))
;	      (NULL (CDR SPEC)))
;	 (SEND SELF :PARSE-COMPONENT-SPEC (CAR SPEC)))
;	((MEMQ SPEC '(NIL :UNSPECIFIC :WILD)) SPEC)
;	(T "FOO")))

;(DEFMETHOD (S$PATHNAME :PARSE-TYPE-SPEC) (SPEC)
;  (COND ((STRINGP SPEC) (SEND SELF :PARSE-COMPONENT-SPEC SPEC))
;	((MEMQ SPEC '(NIL :UNSPECIFIC :WILD)) SPEC)
;	(T (DECODE-CANONICAL-TYPE :LISP (SEND HOST :SYSTEM-TYPE)))))

;;; Copied from LAD: RELEASE-3.IO.FILE; PATHNM.LISP#570 on 2-Oct-86 05:41:42
;;;; Since there are no "interchange" versions,
;;;; this is only to convert invalid ones to valid ones.
;(DEFMETHOD (S$PATHNAME :PARSE-VERSION-SPEC) (SPEC)
;  (IF (OR (AND (FIXNUMP SPEC) (> SPEC 0))
;	  (MEMQ SPEC '(NIL :UNSPECIFIC :WILD :NEWEST :OLDEST)))
;      SPEC
;      :NEWEST))

;(DEFFLAVOR S$PATHNAME-NORMALLY-LOWERCASE-MIXIN () ()
;  (:REQUIRED-FLAVORS S$PATHNAME))

;(DEFUN CONVERT-SOLID-CASE (OBJECT)
;  (COND ((STRINGP OBJECT)
;	 (LET (SOME-LC SOME-UC)
;	   (DOTIMES (I (LENGTH OBJECT))
;	     (LET ((CH (AREF OBJECT I)))
;	       (IF (UPPER-CASE-P CH) (SETQ SOME-UC T))
;	       (IF (LOWER-CASE-P CH) (SETQ SOME-LC T))))
;	   (IF (NEQ SOME-UC SOME-LC)
;	       (IF SOME-UC (STRING-DOWNCASE OBJECT) (STRING-UPCASE OBJECT))
;	     OBJECT)))
;	((CONSP OBJECT)
;	 (MAPCAR #'CONVERT-SOLID-CASE OBJECT))
;	(T OBJECT)))

;(DEFMETHOD (S$PATHNAME-NORMALLY-LOWERCASE-MIXIN :TRANSLATION-CASE-CONVERTER) ()
;  'CONVERT-SOLID-CASE)

;(DEFMETHOD (S$PATHNAME-NORMALLY-LOWERCASE-MIXIN :PARSE-COMPONENT-SPEC) (SPEC)
;  (CONVERT-SOLID-CASE SPEC))

;(DEFMETHOD (S$PATHNAME-NORMALLY-LOWERCASE-MIXIN :NAME) ()
;  (CONVERT-SOLID-CASE NAME))

;(DEFMETHOD (S$PATHNAME-NORMALLY-LOWERCASE-MIXIN :DEVICE) ()
;  (CONVERT-SOLID-CASE DEVICE))

;(DEFMETHOD (S$PATHNAME-NORMALLY-LOWERCASE-MIXIN :DIRECTORY) ()
;  (CONVERT-SOLID-CASE DIRECTORY))

;(DEFMETHOD (S$PATHNAME-NORMALLY-LOWERCASE-MIXIN :TYPE) ()
;  (CONVERT-SOLID-CASE TYPE))

;;;; These two are right for systems where mixed case is normally used.
;(DEFMETHOD (S$PATHNAME-NORMALLY-LOWERCASE-MIXIN :NEW-SUGGESTED-NAME) (NEW-NAME)
;  (SEND SELF :NEW-S$PATHNAME :NAME NEW-NAME))

;(DEFMETHOD (S$PATHNAME-NORMALLY-LOWERCASE-MIXIN :NEW-SUGGESTED-DIRECTORY) (NEW-DIRECTORY)
;  (SEND SELF :NEW-S$PATHNAME :DIRECTORY NEW-DIRECTORY))
;
;;;;; Creation of s$pathnames, low level.

;(DEFVAR *S$PATHNAME-HASH-TABLE* :UNBOUND
;  "This is the EQUAL-hash-table used for uniquizing s$pathnames.")

;;;; *S$PATHNAME-HASH-TABLE* is not address-dependent anymore.  KHS 850805.
;;(ADD-INITIALIZATION 'REHASH-S$PATHNAME-HASH-TABLE
;;		    '(GETHASH NIL *S$PATHNAME-HASH-TABLE*)
;;		    '(AFTER-FULL-GC))
;;; Copied from LAD: RELEASE-3.IO.FILE; PATHNM.LISP#570 on 2-Oct-86 05:41:43
;(defun purge-s$pathname-hash-table (&aux (count 0))
;  (maphash #'(lambda (key &rest ignore)
;	       (unless (typecase (car key)
;			 (logical-s$pathname (memq (car key) *logical-s$pathname-host-list*))
;			 (t (memq (car key) *s$pathname-host-list*)))
;		 (incf count)
;		 (format t "~&Removing a s$pathname for host /"~a/".")
;		 (remhash key *s$pathname-hash-table*)))
;	   *s$pathname-hash-table*))


;(DEFUN MAKE-S$PATHNAME-INTERNAL (&REST REST &AUX S$PATHNAME FLAVOR-NAME OPTIONS)
;  "Create a s$pathname from components specified positionally, with no defaulting.
;All components are raw."
;  (DECLARE (ARGLIST HOST DEVICE DIRECTORY NAME TYPE VERSION)
;	   (VALUES S$PATHNAME FOUND-IN-HASH-TABLE-P))
;  (LET ((ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON T))
;    (SETQ S$PATHNAME
;	  (GETHASH REST *S$PATHNAME-HASH-TABLE*)))
;  (IF (GET (TYPE-OF S$PATHNAME) 'S$PATHNAME-FLAVOR-CHANGES)
;      (MULTIPLE-VALUE (FLAVOR-NAME OPTIONS)
;	(SEND (CAR REST) :S$PATHNAME-FLAVOR)))
;  (IF (AND S$PATHNAME (OR (NULL FLAVOR-NAME) (EQ (TYPE-OF S$PATHNAME) FLAVOR-NAME)))
;      (VALUES S$PATHNAME T)
;    (LET ((OS$PATHNAME S$PATHNAME))
;      (SETQ REST (COPY-INTO-S$PATHNAME-AREA REST))
;      (OR FLAVOR-NAME
;	  (MULTIPLE-VALUE (FLAVOR-NAME OPTIONS)
;	    (SEND (CAR REST) :S$PATHNAME-FLAVOR)))
;      (SETQ S$PATHNAME (APPLY 'MAKE-S$PATHNAME-INSTANCE
;			    FLAVOR-NAME
;			    :HOST (FIRST REST)
;			    :DEVICE (SECOND REST)
;			    :DIRECTORY (THIRD REST)
;			    :NAME (FOURTH REST)
;			    :TYPE (FIFTH REST)
;			    :VERSION (SIXTH REST)
;			    OPTIONS))
;      (IF OS$PATHNAME (SEND S$PATHNAME :SETPLIST (SEND OS$PATHNAME :PLIST)))
;      (PUTHASH REST S$PATHNAME *S$PATHNAME-HASH-TABLE*)
;      (VALUES S$PATHNAME NIL))))

;(DEFUN MAKE-S$PATHNAME-INSTANCE (FLAVOR-NAME &REST OPTIONS)
;  (INSTANTIATE-FLAVOR FLAVOR-NAME (LOCF OPTIONS) T NIL S$PATHNAME-AREA))

;(DEFUN COPY-INTO-S$PATHNAME-AREA (OBJ)
;  "Return a copy of OBJ in S$PATHNAME-AREA.
;All levels of lists and string in OBJ are copied
;unless they are already in S$PATHNAME-AREA."
;  (IF (OR (FIXNUMP OBJ) (TYPEP OBJ 'SHORT-FLOAT) (= (%AREA-NUMBER OBJ) S$PATHNAME-AREA))
;      OBJ
;    (COND ((CONSP OBJ)
;	   (SETQ OBJ (COPYLIST OBJ S$PATHNAME-AREA))
;	   (DO ((O OBJ (CDR O))) (NIL)
;	     (SETF (CAR O) (COPY-INTO-S$PATHNAME-AREA (CAR O)))
;	     (WHEN (ATOM (CDR O))
;	       (AND (CDR O)
;		    (SETF (CDR O) (COPY-INTO-S$PATHNAME-AREA (CDR O))))
;	       (RETURN OBJ))))
;	  ((STRINGP OBJ)
;	   (LET ((DEFAULT-CONS-AREA S$PATHNAME-AREA))
;	     (STRING-APPEND OBJ)))
;	  (T OBJ))))

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

;(DEFUN MAKE-FASLOAD-S$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.
;  (AND (SETQ PATH-HOST (GET-S$PATHNAME-HOST HOST T))
;       (SETQ HOST PATH-HOST))
;  (OR PATH-HOST (SETQ PATH-HOST (IF SI:FDEFINE-FILE-S$PATHNAME
;				    (S$PATHNAME-HOST SI:FDEFINE-FILE-S$PATHNAME)
;				    USER-LOGIN-MACHINE)))
;  (SETQ PATH (MAKE-S$PATHNAME-INTERNAL PATH-HOST DEVICE DIRECTORY NAME TYPE VERSION))
;  ;; Record the actual host for possible debugging.
;  (AND (NEQ HOST PATH-HOST)
;       (SEND PATH :PUTPROP HOST :FASLOAD-HOST))
;  PATH)
;
;;;;; Comparison of s$pathnames.

;(DEFUN S$PATHNAME-EQUAL (S$PATHNAME1 S$PATHNAME2)
;  "T if the two s$pathnames match by components.
;The same as EQ for most flavors of s$pathname, but not for all.
;In this normal case, we must swap in the first arg but not the second."
;  (SEND S$PATHNAME1 :EQUAL S$PATHNAME2))

;(DEFMETHOD (S$PATHNAME :EQUAL) (OTHER-S$PATHNAME)
;  (EQ OTHER-S$PATHNAME SELF))

;(DEFUN S$PATHNAME-LESSP (S$PATHNAME-1 S$PATHNAME-2)
;  "Standard comparison of s$pathnames, for sorting directory listings."
;  (SEND S$PATHNAME-1 :SORT-LESSP S$PATHNAME-2))

;;;; Redefine this if your standard components and raw ones
;;;; fail to match in a way that affects sorting (not just case)
;(DEFMETHOD (S$PATHNAME :SORT-COMPONENTS) ()
;  (VALUES HOST DEVICE DIRECTORY NAME TYPE VERSION))

;;;;; Redefine this too, to use your standard components.
;(DEFMETHOD (S$PATHNAME :SORT-LESSP) (OTHER-S$PATHNAME &AUX TEM)
;  (MULTIPLE-VALUE-BIND (OHOST ODEVICE ODIRECTORY ONAME OTYPE OVERSION)
;      (SEND OTHER-S$PATHNAME :SORT-COMPONENTS)
;    (AND (ZEROP (SETQ TEM (S$PATHNAME-COMPONENT-COMPARE HOST OHOST)))
;	 (ZEROP (SETQ TEM (S$PATHNAME-COMPONENT-COMPARE DEVICE ODEVICE)))
;	 (ZEROP (SETQ TEM (S$PATHNAME-COMPONENT-COMPARE DIRECTORY ODIRECTORY)))
;	 (ZEROP (SETQ TEM (S$PATHNAME-COMPONENT-COMPARE NAME ONAME)))
;	 (ZEROP (SETQ TEM (S$PATHNAME-COMPONENT-COMPARE TYPE OTYPE)))
;	 (SETQ TEM (S$PATHNAME-COMPONENT-COMPARE VERSION OVERSION)))
;    (MINUSP TEM)))

;(DEFUN S$PATHNAME-COMPONENT-COMPARE (X Y)
;  (COND ((EQUAL X Y) 0)
;	((SYMBOLP X)
;	 (IF (SYMBOLP Y)
;	     (S$PATHNAME-KEYWORD-COMPARE X Y)
;	     -1))
;	((SYMBOLP Y) 1)
;	((STRINGP X)
;	 (IF (STRINGP Y)
;	     (STRING-COMPARE X Y)
;	     -1))
;	((STRINGP Y) 1)
;	((NUMBERP X)
;	 (IF (NUMBERP Y)
;	     (- X Y)
;	     -1))
;	((NUMBERP Y) 1)
;	((ALPHALESSP X Y) -1)
;	(T 1)))

;(DEFUN S$PATHNAME-KEYWORD-COMPARE (X Y)
;  (COND ((EQ X :NEWEST)
;	 (COND ((EQ Y :NEWEST) 0)
;	       (T 1)))
;	((EQ Y :NEWEST)
;	 (COND ((EQ X :NEWEST) 0)
;	       (T -1)))
;	(T (STRING-COMPARE X Y))))
;
;(DEFUN DEFAULT-HOST (DEFAULTS &AUX ELEM)
;  "Return the default host to use from defaults-list or s$pathname DEFAULTS."
;  (OR DEFAULTS (SETQ DEFAULTS *DEFAULT-S$PATHNAME-DEFAULTS*))
;  (COND ((AND DEFAULTS (ATOM DEFAULTS))
;	 (S$PATHNAME-RAW-HOST (PARSE-S$PATHNAME DEFAULTS)))
;	(T
;	 (SETQ ELEM (COND ((NOT *DEFAULTS-ARE-PER-HOST*) (ASSQ NIL 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 s$pathname from the host of this one
;	 (OR (CAR ELEM) (S$PATHNAME-HOST (CDR ELEM))))))

;;;; 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-S$PATHNAME (&OPTIONAL DEFAULTS HOST DEFAULT-TYPE DEFAULT-VERSION INTERNAL-P
;			 &AUX ELEM S$PATHNAME HOST-TO-USE CTYPE OTYPE)
;  (AND HOST (SETQ HOST (GET-S$PATHNAME-HOST HOST)))
;  ;; Defaults '(NIL) '((NIL)) have been seen prior to login.
;  (WHEN (OR (NULL DEFAULTS) (EQUAL DEFAULTS '(NIL)) (EQUAL DEFAULTS '((NIL))))
;    (SETQ DEFAULTS *DEFAULT-S$PATHNAME-DEFAULTS*))
;  (COND ((AND DEFAULTS (ATOM DEFAULTS))
;	 (SETQ S$PATHNAME (PARSE-S$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)
;			    (IF (NULL USER-LOGIN-MACHINE)
;				(NCONS SI:ASSOCIATED-MACHINE)
;			      (NCONS USER-LOGIN-MACHINE)))))
;	 ;; If there isn't one already, build a s$pathname from the host of this one
;	 (SETQ HOST-TO-USE (OR HOST (CAR ELEM) (S$PATHNAME-HOST (CDR ELEM))))
;	 (COND ((SETQ S$PATHNAME (CDR ELEM)))
;	       (INTERNAL-P
;		(SETQ S$PATHNAME (MAKE-S$PATHNAME-INTERNAL HOST-TO-USE NIL NIL NIL NIL NIL)))
;	       (T
;		(SETQ S$PATHNAME (SEND (USER-HOMEDIR HOST-TO-USE) :NEW-S$PATHNAME
;				     :NAME "FOO" :TYPE *NAME-SPECIFIED-DEFAULT-TYPE*
;				     :VERSION :NEWEST))
;		(SETF (CDR ELEM) S$PATHNAME)))))
;  ;; If default-type or default-version was given, or the host has changed,
;  ;; merge those in.
;  (AND (OR (AND HOST (NEQ HOST (S$PATHNAME-HOST S$PATHNAME))) DEFAULT-TYPE DEFAULT-VERSION)
;       (SETQ HOST (OR HOST (S$PATHNAME-HOST S$PATHNAME)))
;       (IF INTERNAL-P
;	   (AND HOST (SETQ S$PATHNAME (MAKE-S$PATHNAME-INTERNAL HOST NIL NIL NIL NIL NIL)))
;	 (SETF (VALUES CTYPE OTYPE) (SEND S$PATHNAME :CANONICAL-TYPE))
;	 (SETQ S$PATHNAME (SEND (MAKE-S$PATHNAME :HOST HOST :DEFAULTS NIL)
;			      :NEW-S$PATHNAME
;			      :DIRECTORY (S$PATHNAME-DIRECTORY S$PATHNAME)
;			      :DEVICE (S$PATHNAME-DEVICE S$PATHNAME)
;			      :HOST (OR HOST (S$PATHNAME-HOST S$PATHNAME))
;			      :NAME (S$PATHNAME-NAME S$PATHNAME)
;			      :CANONICAL-TYPE CTYPE
;			      :ORIGINAL-TYPE OTYPE
;			      :VERSION (OR DEFAULT-VERSION (S$PATHNAME-VERSION S$PATHNAME))
;			      ))))
;  S$PATHNAME)

;(DEFMETHOD (S$PATHNAME :NEW-DEFAULT-S$PATHNAME) (&REST OPTIONS)
;  (LEXPR-SEND SELF :NEW-S$PATHNAME OPTIONS))

;;(COMMENT
;;;; Generate a default filename.  Most just merge in the name, etc.
;;;; Used only from the preceding function.
;;(DEFMETHOD (S$PATHNAME :NEW-DEFAULT-S$PATHNAME) (&REST OPTIONS)
;;  (LET* ((COPY (APPEND OPTIONS NIL))
;;	 (PLIST (LOCF COPY))
;;	 (DEVNAME (GET PLIST :DEVICE))
;;	 (DIRNAME (GET PLIST :DIRECTORY))
;;	 (FILENAME (GET PLIST :NAME))
;;	 (FILETYPE (GET PLIST :TYPE))
;;	 (FILEVERSION (GET PLIST :VERSION)))
;;    (PUTPROP PLIST (SEND SELF :VALID-DEVICE DEVNAME) :DEVICE)
;;    (PUTPROP PLIST (SEND SELF :VALID-DIRECTORY DIRNAME) :DIRECTORY)
;;    (PUTPROP PLIST (SEND SELF :VALID-NAME FILENAME) :NAME)
;;    (PUTPROP PLIST (SEND SELF :VALID-TYPE FILETYPE) :TYPE)
;;    (PUTPROP PLIST (SEND SELF :VALID-VERSION FILEVERSION) :VERSION)
;;    (LEXPR-SEND SELF :NEW-S$PATHNAME COPY)))

;;;; The following are used only from
;;;; :NEW-DEFAULT-S$PATHNAME's old definition (no longer from BALDIR).

;;(DEFMETHOD (S$PATHNAME :VALID-DEVICE) (DEVNAME)
;;  (COND ((SEND SELF :VALID-DEVICE-P DEVNAME)
;;	 DEVNAME)
;;	((AND (CONSP DEVNAME) (NULL (CDR DEVNAME)))
;;	 (SEND SELF :VALID-DEVICE (CAR DEVNAME)))
;;	(T
;;	 (S$PATHNAME-DEVICE (QUIET-USER-HOMEDIR HOST)))))

;;(DEFMETHOD (S$PATHNAME :VALID-DEVICE-P) (DEVNAME)
;;  (OR (STRINGP DEVNAME)
;;      (MEMQ DEVNAME '(NIL :WILD :UNSPECIFIC))))

;;(DEFMETHOD (S$PATHNAME :VALID-DIRECTORY) (DIRNAME)
;;  (COND ((SEND SELF :VALID-DIRECTORY-P DIRNAME)
;;	 DIRNAME)
;;	((AND (CONSP DIRNAME) (NULL (CDR DIRNAME)))
;;	 (SEND SELF :VALID-DIRECTORY (CAR DIRNAME)))
;;	(T
;;	 (S$PATHNAME-DIRECTORY (QUIET-USER-HOMEDIR HOST)))))

;;(DEFMETHOD (S$PATHNAME :VALID-DIRECTORY-P) (DIRNAME)
;;  (OR (STRINGP DIRNAME) (MEMQ DIRNAME '(NIL :WILD :UNSPECIFIC))))

;;(DEFMETHOD (S$PATHNAME :VALID-NAME) (NAM)
;;  (COND ((SEND SELF :VALID-NAME-P NAM)
;;	 NAM)
;;	((AND (CONSP NAM) (NULL (CDR NAM)))
;;	 (SEND SELF :VALID-NAME (CAR NAM)))
;;	(T "FOO")))

;;(DEFMETHOD (S$PATHNAME :VALID-NAME-P) (NAM)
;;  (OR (STRINGP NAM) (MEMQ NAM '(NIL :WILD :UNSPECIFIC))))

;;(DEFMETHOD (S$PATHNAME :VALID-TYPE) (TYP)
;;  (IF (SEND SELF :VALID-TYPE-P TYP)
;;      TYP
;;    :LISP))

;;(DEFMETHOD (S$PATHNAME :VALID-TYPE-P) (TYP)
;;  (OR (STRINGP TYP) (MEMQ TYP '(NIL :WILD :UNSPECIFIC))))

;;(DEFMETHOD (S$PATHNAME :VALID-VERSION-P) (VRS)
;;  (OR (AND (FIXNUMP VRS) (> VRS 0))
;;      (MEMQ VRS '(NIL :UNSPECIFIC :WILD :NEWEST))))

;;(DEFMETHOD (S$PATHNAME :VALID-VERSION) (VRS)
;;  (IF (SEND SELF :VALID-VERSION-P VRS) VRS :NEWEST))

;;) ;end comment
;
;(DEFVAR PARSE-S$PATHNAME-FLAG NIL)

;(DEFSIGNAL S$PATHNAME-PARSE-ERROR (S$PATHNAME-ERROR S$PATHNAME-PARSE-ERROR)
;	   (PARSE-END-INDEX REPORT-STRING REPORT-ARGS)
;  "Any error that makes it impossible to parse a string into a s$pathname.")

;(DEFPROP S$PATHNAME-ERROR T :ERROR-REPORTER)
;(DEFUN S$PATHNAME-ERROR (INDEX LOSING-STRING REPORT-STRING &REST ARGS)
;  (IF PARSE-S$PATHNAME-FLAG
;      (THROW 'PARSE-S$PATHNAME INDEX)
;    (FERROR 'S$PATHNAME-PARSE-ERROR
;	    "~?~%~VT
~%   /"~A/"~%" 
;	    REPORT-STRING ARGS
;	    (- INDEX
;	       1
;	       (OR (STRING-REVERSE-SEARCH-CHAR #/NEWLINE LOSING-STRING INDEX) -4))
;	    LOSING-STRING)))

;(DEFUN PARSE-S$NAMESTRING (THING &OPTIONAL WITH-RESPECT-TO
;			 		 (DEFAULTS *DEFAULT-S$PATHNAME-DEFAULTS*)
;					 &KEY (START 0) END JUNK-ALLOWED)
;  "Parse THING into a s$pathname and return it.
;The same as FS:PARSE-S$PATHNAME except that that function's args are all positional."
;  (PARSE-S$PATHNAME THING WITH-RESPECT-TO DEFAULTS START END JUNK-ALLOWED))

;(DEFUN PARSE-S$PATHNAME (THING &OPTIONAL WITH-RESPECT-TO (DEFAULTS *DEFAULT-S$PATHNAME-DEFAULTS*)
;		       (START 0) END JUNK-ALLOWED)
;  "Parse THING into a s$pathname and return it.
;THING can be a s$pathname already (it is just passed back),
; a string or symbol, or a Maclisp-style namelist.
;WITH-RESPECT-TO can be NIL or a host or host-name;
; if it is not NIL, the s$pathname is parsed for that host
; and it is an error if the s$pathname specifies a different host.
;If WITH-RESPECT-TO is NIL, then DEFAULTS is used to get the host
; if none is specified.  DEFAULTS may be a host object in this case.
;START and END are indices specifying a substring of THING to be parsed.
; They default to 0 for START and NIL (meaning end of THING) for END.
;If JUNK-ALLOWED is non-NIL, parsing stops without error if
; the syntax is invalid, and this function returns NIL.
;The second value is the index in THING at which parsing stopped.
; If JUNK-ALLOWED is T and there was invalid syntax,
; this is the index of the invalid character."
;  (DECLARE (VALUES PARSED-S$PATHNAME PARSE-END-INDEX))
;  (AND WITH-RESPECT-TO
;       (SETQ WITH-RESPECT-TO (GET-S$PATHNAME-HOST WITH-RESPECT-TO)))
;  (CONDITION-RESUME '((S$PATHNAME-ERROR) :NEW-S$PATHNAME T ("Proceed, supplying a new s$pathname.")
;		      PARSE-S$PATHNAME-THROW-NEW-S$PATHNAME)
;    (LET ((PARSE-S$PATHNAME-FLAG JUNK-ALLOWED))
;      (CATCH-CONTINUATION 'PARSE-S$PATHNAME
;	  #'(LAMBDA (INDEX-OR-S$PATHNAME) 
;	      (IF (NUMBERP INDEX-OR-S$PATHNAME)
;		  (VALUES NIL (MIN (OR END (LENGTH THING)) INDEX-OR-S$PATHNAME))
;		(VALUES INDEX-OR-S$PATHNAME START)))
;	  NIL
;	(COND ((TYPEP THING 'S$PATHNAME)
;	       (AND WITH-RESPECT-TO (NEQ WITH-RESPECT-TO (S$PATHNAME-HOST THING))
;		    (FERROR 'S$PATHNAME-PARSE-ERROR
;			    "Host ~A in ~A does not match ~A"
;			    (S$PATHNAME-HOST THING) THING WITH-RESPECT-TO))
;	       (VALUES THING START))
;	      ((CONSP THING)
;	       (SETQ THING (CANONICALIZE-KLUDGEY-MACLISP-S$PATHNAME-STRING-LIST THING))
;	       (LET (DEVICE DIRECTORY NAME TYPE VERSION HOST)
;		 (COND ((CONSP (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-S$PATHNAME-HOST DEVICE T))
;				  (WITH-RESPECT-TO)
;				  ((TYPEP DEFAULTS 'SI:BASIC-HOST) DEFAULTS)
;				  (T (DEFAULT-HOST DEFAULTS))))
;		 (AND WITH-RESPECT-TO
;		      (NEQ WITH-RESPECT-TO HOST)
;		      (FERROR 'S$PATHNAME-PARSE-ERROR
;			      "Host ~A in ~A does not match ~A" HOST THING WITH-RESPECT-TO))
;		 (VALUES (MAKE-S$PATHNAME :HOST HOST
;					:DEVICE DEVICE :DIRECTORY DIRECTORY :NAME NAME
;					:TYPE TYPE :VERSION VERSION)
;			 START)))
;	      (T
;	       (SETQ THING (STRING THING))
;	       (MULTIPLE-VALUE-BIND (HOST-SPECIFIED START END)
;		   (PARSE-S$PATHNAME-FIND-COLON THING START END)
;		 ;; 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
;			  (COND ((AND HOST-SPECIFIED (GET-S$PATHNAME-HOST HOST-SPECIFIED T)))
;				(WITH-RESPECT-TO)
;				((TYPEP DEFAULTS 'SI:BASIC-HOST) DEFAULTS)
;				(T (DEFAULT-HOST DEFAULTS)))))
;		   (MULTIPLE-VALUE-BIND (DEVICE DIRECTORY NAME TYPE VERSION PARSE-END)
;		       (SEND (SAMPLE-S$PATHNAME HOST) :PARSE-S$NAMESTRING
;			     (NOT (NULL HOST-SPECIFIED)) THING START END)
;		     (VALUES
;		       ;; If device is :NO-INTERN then immeditely return 2nd value, DIRECTORY.
;		       ;; this provides a way to bypass as much of this lossage as possible
;		       ;; in cases where it doesnt make sense.
;		       (COND ((EQ DEVICE :NO-INTERN)
;			      DIRECTORY)
;			     (T
;			      ;; Otherwise we assume we got the raw forms of everything.
;			      (MAKE-S$PATHNAME-INTERNAL
;				HOST DEVICE DIRECTORY NAME TYPE VERSION)))
;		       PARSE-END))))))))))

;(DEFUN PARSE-S$PATHNAME-THROW-NEW-S$PATHNAME (IGNORE S$PATHNAME)
;  (*THROW 'PARSE-S$PATHNAME S$PATHNAME))
  
;(DEFUN CANONICALIZE-KLUDGEY-MACLISP-S$PATHNAME-STRING-LIST (X)
;  (COND ((OR (NULL X) (NUMBERP X)) X)
;	((CONSP X) (MAPCAR #'CANONICALIZE-KLUDGEY-MACLISP-S$PATHNAME-STRING-LIST X))
;	(T (STRING X))))

;;; Copied from LAD: RELEASE-3.IO.FILE; PATHNM.LISP#570 on 2-Oct-86 05:41:46
;(DEFUN PARSE-S$PATHNAME-FIND-COLON (STRING &OPTIONAL (ORIGINAL-START 0) END
;				  &AUX HOST-SPECIFIED (START ORIGINAL-START))
;  (DECLARE (VALUES HOST-SPECIFIED START END))
;  (UNLESS END (SETQ END (LENGTH STRING)))
;  (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 (ALPHANUMERICP CHAR)
;	       (= CHAR #/.)
;	       (= CHAR #/-)
;	       ;; If we get to non-alphabetic or -numeric,
;	       ;; then no interesting colon
;	       (RETURN NIL)))))
;  (COND ((AND HOST-SPECIFIED
;	      (< START END)
;	      (= (AREF STRING START) #/:))
;	 ;; TWO COLONS IN A ROW, E.G. FOOBAR::, WHICH IS THE DECNET
;	 ;; UNAMBIGUOUS HOST SPECIFICATION.
;	 (GET-S$PATHNAME-HOST HOST-SPECIFIED)
;	 (INCF START))
;	('ELSE
;	 (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 it's just a colon with only whitespace before it,
;  ;; believe there is no host name, but don't count the colon as part of the
;  ;; per-host s$pathname.
;  (AND (EQUAL HOST-SPECIFIED "")
;       (SETQ HOST-SPECIFIED NIL))
;  ;; If what looked like the host really wasn't, forget it and reset the indices
;  (AND HOST-SPECIFIED
;       (NULL (SETQ HOST-SPECIFIED (GET-S$PATHNAME-HOST HOST-SPECIFIED T)))
;       (SETQ START ORIGINAL-START
;	     END NIL))			;This will be interpreted correctly
;  (VALUES HOST-SPECIFIED START END))

;(DEFSIGNAL UNKNOWN-S$PATHNAME-HOST (S$PATHNAME-ERROR UNKNOWN-S$PATHNAME-HOST)
;	   (NAME)
;  "Used when GET-S$PATHNAME-HOST does not recognize the host name.")

;(DEFUN GET-S$PATHNAME-HOST (HOST-NAME &OPTIONAL NO-ERROR-P
;			  (UNKNOWN-OK (VARIABLE-BOUNDP CHAOS:MY-ADDRESS)))
;  "Parse a host for use in a s$pathname.
;HOST-NAME can be a host object or a host name.
;If NO-ERROR-P is non-NIL, we return NIL if given an undefined host name."
;  (FLET ((GET-HOST-FROM-LIST (LIST)
;	   (IF (MEMQ HOST-NAME LIST)
;	       HOST-NAME
;	     (LET ((HOST NIL))
;	       (DOLIST (X LIST HOST)
;		 ;; We prefer an exact match: This is a hack for LMFILE to share LM27 (FC/FS)
;		 (WHEN (SEND X :S$PATHNAME-HOST-NAMEP HOST-NAME)
;		   (IF (STRING-EQUAL HOST-NAME (SEND X :NAME-AS-FILE-COMPUTER))
;		       (RETURN X)
;		     (SETQ HOST X)))))))) ; Non-exact match
;    ;; And said MLY unto the Lusers ``Let logical hosts shadow physical hosts.''
;    (COND ((GET-HOST-FROM-LIST *LOGICAL-S$PATHNAME-HOST-LIST*))
;	  ((GET-HOST-FROM-LIST *S$PATHNAME-HOST-LIST*))
;	  ;; Don't let SI:PARSE-HOST check for an unknown host here when making SYS.
;	  ((LET ((HOST (SI:PARSE-HOST HOST-NAME T UNKNOWN-OK)))
;	     (WHEN (AND HOST (SEND HOST :SEND-IF-HANDLES :FILE-HOST-P))
;	       (PUSHNEW HOST *S$PATHNAME-HOST-LIST* :TEST 'EQ)
;	       HOST)))
;	  (NO-ERROR-P NIL)
;	  (T (FERROR 'UNKNOWN-S$PATHNAME-HOST
;		     "~S is not the name of a known file host" HOST-NAME)))))
;
;;;;; Defaults alists

;(DEFVAR *DEFAULT-S$PATHNAME-DEFAULTS* :UNBOUND
;  "These are the defaults MERGE-S$PATHNAME-DEFAULTS uses if none are specified.")

;(DEFVAR CLI:*DEFAULT-S$PATHNAME-DEFAULTS* :UNBOUND
;  "These are the defaults s$pathname defaults as far as Common Lisp programs know them.
;The value of this variable is a s$pathname.
;The value cell is kludgily shared with a cell of the alist
;stored in GLOBAL:*DEFAULT-S$PATHNAME-DEFAULTS*.")

;(DEFCONST *DEFAULTS-ARE-PER-HOST* NIL
;  "Non-NIL means each default-list should keep a separate default file name for each host.
;NIL means defaults are independent of host.")

;;;; Returns an alist that you can pass to the functions below that take a set of defaults.
;(DEFUN MAKE-S$PATHNAME-DEFAULTS (&AUX LIST HOSTS)
;  "Create an empty defaults-list for use with MERGE-S$PATHNAME-DEFAULTS."
;  (SETQ HOSTS (APPEND *LOGICAL-S$PATHNAME-HOST-LIST* *S$PATHNAME-HOST-LIST*))
;  (SETQ LIST (MAKE-LIST (1+ (LENGTH HOSTS))))
;  (DO ((L2 LIST (CDR L2))
;       (L1 HOSTS (CDR L1)))
;      ((NULL L2))
;    (SETF (CAR L2) (NCONS (CAR L1))))
;  LIST)

;(DEFUN COPY-S$PATHNAME-DEFAULTS (DEFAULTS)
;  "Copy a defaults-list, returning a new defaults-list."
;  (COPYALIST DEFAULTS))

;(DEFUN SET-DEFAULT-S$PATHNAME (S$PATHNAME &OPTIONAL DEFAULTS &AUX ELEM)
;  "Alter the defaults in the defaults-list DEFAULTS from S$PATHNAME.
;DEFAULTS defaults to *DEFAULT-S$PATHNAME-DEFAULTS*."
;  (SETQ DEFAULTS (OR DEFAULTS *DEFAULT-S$PATHNAME-DEFAULTS*))
;  (SETQ S$PATHNAME (PARSE-S$PATHNAME S$PATHNAME NIL DEFAULTS))
;  (OR (SETQ ELEM (ASSQ (S$PATHNAME-HOST S$PATHNAME) DEFAULTS))
;      (SETQ ELEM (NCONS (S$PATHNAME-HOST S$PATHNAME))))
;  (SETF (CDR ELEM) S$PATHNAME)
;  (PULL ELEM DEFAULTS)				;This is the default host
;  (AND (NOT *DEFAULTS-ARE-PER-HOST*)
;       (SETQ ELEM (ASSQ NIL DEFAULTS))
;       (SETF (CDR ELEM) S$PATHNAME))
;  S$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)
;
;;;;; Merging of defaults

;;;; Setting this to T gives TENEX style s$pathname defaulting.
;(DEFCONST *ALWAYS-MERGE-TYPE-AND-VERSION* NIL
;  "T means that merging s$pathnames should use the default type or version
;if the specified s$pathname does not contain one
;even if the specified s$pathname does contain a name component.")

;(DEFCONST *NAME-SPECIFIED-DEFAULT-TYPE* :LISP
;  "This is the default type component to use in MERGE-S$PATHNAME-DEFAULTS
;if the specified s$pathname contains a name but no type.")

;;(DEFVAR HOST-WORKING-DIRECTORY-ALIST NIL
;;  "Alist of elements (host-object working-directory-s$pathname).")

;;; this is totally worthless
;(DEFUN SET-HOST-WORKING-DIRECTORY (HOST S$PATHNAME)
;  "Set the working device//directory for HOST to that in S$PATHNAME.
;When a s$pathname containing device component DSK is defaulted,
;its device is replaced by the working device, and its directory
;defaulted (if not explicitly specified) to the working directory."
;  (LET* ((HOST1 (GET-S$PATHNAME-HOST HOST))
;	 (DIR (PARSE-S$PATHNAME S$PATHNAME HOST1)))
;    (SEND HOST1 :SET :GET 'WORKING-DIRECTORY DIR)))

;(defun merge-s$pathnames (s$pathname &optional defaults (default-version :newest))
;  "Default components that are NIL in S$PATHNAME, and return the defaulted s$pathname.
;DEFAULTS is a s$pathname or a defaults-list to get defaults from.
;If S$PATHNAME specifies a name component, the DEFAULT-VERSION is used in place of
; the default version derived from DEFAULTS.
;Otherwise, the version is defaulted from the corresponding component from DEFAULTS."
;  (setq s$pathname (parse-s$pathname s$pathname nil defaults))
;  (if (s$pathname-name s$pathname)
;      (merge-s$pathname-components s$pathname defaults :default-version default-version)
;    (merge-s$pathname-components s$pathname defaults)))

;(defun merge-s$pathname-components
;       (s$pathname &optional defaults
;		 &key (default-version nil default-version-specified-p)
;		      (default-type nil default-type-specified-p)
;		      (default-name nil default-name-specified-p)
;		      always-merge-name always-merge-type always-merge-version
;		 &aux default new-device new-directory new-name new-type new-version
;		      new-otype merge-name-p merge-type-p merge-version-p)
;  "Default components that are NIL in S$PATHNAME, and return the defaulted s$pathname.
;DEFAULTS is a s$pathname or a defaults-list to get defaults from.
;If supplied, DEFAULT-NAME, DEFAULT-TYPE and DEFAULT-VERSION are used as the defaults for
;their components if those components are not supplied by S$PATHNAME.
;Otherwise, these components are defaulted from DEFAULTS in the usual manner.
;ALWAYS-MERGE-xxx mean that the the xxx components should *always* be merged in
;/(from either DEFAULT-xxx or from DEFAULTS) even if the relevant component is already
;specified by S$PATHNAME."
;  (setq s$pathname (parse-s$pathname s$pathname nil defaults))
;  (if (null defaults) (setq defaults *default-s$pathname-defaults*))
;  (if (not (typep s$pathname 's$pathname))
;      s$pathname					;Some funny thing.  No defaulting possible.
;    (setq default (if (atom defaults)
;		      (parse-s$pathname defaults nil s$pathname)
;		      (default-s$pathname defaults (s$pathname-host s$pathname) nil nil t)))
;    ;; Merge the and device and directory in vanilla fashion
;    (when (null (s$pathname-device s$pathname))
;      (setq new-device (s$pathname-device default)))
;    (let ((pdir (s$pathname-directory s$pathname))
;	  (ddir (s$pathname-directory default)))
;      (cond ((null pdir)
;	     (setq new-directory ddir))
;	    ((eq (car-safe pdir) :relative)
;	     (setq new-directory
;		   (merge-relative-directory pdir ddir)))))
;    ;; merge name, type and version hirsutely
;    (when (or (null (s$pathname-name s$pathname))
;	      always-merge-name)
;      (setq new-name (if default-name-specified-p
;			 default-name
;			 (s$pathname-name default))
;	    merge-name-p t))
;    (when (or (null (s$pathname-type s$pathname))
;	      always-merge-type)
;      (setq merge-type-p t)
;      (if default-type-specified-p
;	  (setq new-type default-type)
;	  (multiple-value-setq (new-type new-otype) (send default :canonical-type))))
;    (when (or (null (s$pathname-version s$pathname))
;	      always-merge-version)
;      (setq new-version (if default-version-specified-p
;			    default-version
;			    (s$pathname-version default))
;	    merge-version-p t))
;    (send s$pathname :new-s$pathname
;		   (if new-device :device) new-device
;		   (if new-directory :directory) new-directory
;		   (if merge-name-p :name) new-name
;		   (if merge-type-p :type) new-type
;		   (if new-otype :original-type) new-otype
;		   (if merge-version-p :version) new-version)))

;;;; What a crock.
;;;; Fill in slots in S$PATHNAME from program defaults.  This is what most
;;;; programs interface to.
;(DEFUN MERGE-S$PATHNAME-DEFAULTS (S$PATHNAME
;				&OPTIONAL DEFAULTS
;					  (DEFAULT-TYPE *NAME-SPECIFIED-DEFAULT-TYPE*)
;					  (DEFAULT-VERSION :NEWEST)
;					  ALWAYS-MERGE-TYPE
;				&AUX HOST DEFAULT SECONDARY-DEFAULT
;				     NEW-DEVICE NEW-DIRECTORY NEW-NAME NEW-TYPE NEW-VERSION
;				     NEW-OTYPE)
;  "If I were you I wouldn't use this function:
;  Try MERGE-S$PATHNAMES and FS:MERGE-S$PATHNAME-COMPONENTS instead.

;Default components that are NIL in S$PATHNAME, and return the defaulted s$pathname.
;DEFAULTS is a s$pathname or a defaults-list to get defaults from.
;DEFAULT-TYPE and DEFAULT-VERSION are used as the defaults for
;the type and version components, iff a name was specified
;and FS:*ALWAYS-MERGE-TYPE-AND-VERSION* is NIL.
;Otherwise, the type and version are obtained from DEFAULTS,
;and DEFAULT-TYPE and DEFAULT-VERSION are not used.
;If ALWAYS-MERGE-TYPE is non-NIL, that forces the type component
;to be merged like the name, directory, etc. but has no effect on the version."
;  (SETQ S$PATHNAME (PARSE-S$PATHNAME S$PATHNAME NIL DEFAULTS))
;  (IF (NULL DEFAULTS)
;      (SETQ DEFAULTS *DEFAULT-S$PATHNAME-DEFAULTS*))
;  (COND ((NOT (TYPEP S$PATHNAME 'S$PATHNAME))
;	 S$PATHNAME)				;Some funny thing.  No defaulting possible.
;	(T
;	 ;; Host always comes from s$pathname
;	 (SETQ HOST (S$PATHNAME-HOST S$PATHNAME))
;	 ;; Setup default s$pathnames.  If a s$pathname is supplied as the defaults,
;	 ;; then two levels of defaulting are needed, otherwise only one.
;	 (IF (ATOM DEFAULTS)			;if not defaults.
;	     (SETQ DEFAULT (PARSE-S$PATHNAME DEFAULTS NIL S$PATHNAME)
;		   DEFAULTS *DEFAULT-S$PATHNAME-DEFAULTS*
;		   SECONDARY-DEFAULT (DEFAULT-S$PATHNAME DEFAULTS HOST)
;		   )
;	     (SETQ DEFAULT (DEFAULT-S$PATHNAME DEFAULTS HOST)
;		   SECONDARY-DEFAULT NIL)
;		   )
;	 ;; Device name DSK means the working directory and associated device if any.
;	 (COND ((EQUAL (S$PATHNAME-DEVICE S$PATHNAME) "DSK")
;		(LET ((WDIR (OR (GET HOST 'WORKING-DIRECTORY) (USER-HOMEDIR HOST))))
;		  (SETQ NEW-DEVICE
;			(OR (SEND WDIR :DEVICE)
;			    (SEND HOST :PRIMARY-DEVICE)))
;		  (IF (AND (NULL (S$PATHNAME-DIRECTORY S$PATHNAME))
;			   ;; Don't do this when explicit directory supplied.
;			   (NULL (S$PATHNAME-DIRECTORY DEFAULT))
;			   (OR (NULL SECONDARY-DEFAULT)
;			       (NULL (S$PATHNAME-DIRECTORY SECONDARY-DEFAULT))))
;		      (SETQ NEW-DIRECTORY
;			    (SEND WDIR :DIRECTORY))))))
;	 ;; Merge the device, directory, and name
;	 (IF (NULL (S$PATHNAME-DEVICE S$PATHNAME))
;	     (SETQ NEW-DEVICE
;		   (OR (S$PATHNAME-DEVICE DEFAULT)
;		       (AND (NOT (NULL SECONDARY-DEFAULT))
;			    (S$PATHNAME-DEVICE SECONDARY-DEFAULT))
;		       )))
;	 (UNLESS NEW-DIRECTORY
;	   (LET ((PDIR (S$PATHNAME-DIRECTORY S$PATHNAME))
;		 (DDIR (OR (S$PATHNAME-DIRECTORY DEFAULT)
;			   (AND (NOT (NULL SECONDARY-DEFAULT))
;				(S$PATHNAME-DIRECTORY SECONDARY-DEFAULT))
;			   )))
;	     (COND ((NULL PDIR)
;		    (SETQ NEW-DIRECTORY DDIR))
;		   ((EQ (CAR-SAFE PDIR) :RELATIVE)
;		    (SETQ NEW-DIRECTORY
;			  (MERGE-RELATIVE-DIRECTORY PDIR DDIR))))))
;	 (IF (NULL (S$PATHNAME-NAME S$PATHNAME))
;	     (SETQ NEW-NAME
;		   (OR (S$PATHNAME-NAME DEFAULT)
;		       (AND (NOT (NULL SECONDARY-DEFAULT))
;			    (S$PATHNAME-NAME SECONDARY-DEFAULT))
;		       ;; Never let the name of the resulting s$pathname be NIL.
;		       "FOO")))
		       
;	 ;; Merge the type and version if the name was NIL before the above merge,
;	 ;; or if the user says to always do so.
;	 (IF (NULL (S$PATHNAME-TYPE S$PATHNAME))
;	     (IF (OR (NULL (S$PATHNAME-NAME S$PATHNAME))
;		     ALWAYS-MERGE-TYPE
;		     *ALWAYS-MERGE-TYPE-AND-VERSION*)
;		 (PROGN
;		   (SETF (VALUES NEW-TYPE NEW-OTYPE)
;			 (SEND DEFAULT :CANONICAL-TYPE))
;		   (UNLESS NEW-TYPE
;		     (SETQ NEW-TYPE
;			   (OR (AND (NOT (NULL SECONDARY-DEFAULT))
;				    (S$PATHNAME-TYPE SECONDARY-DEFAULT))
;			       ;; Never let the type of the resulting s$pathname be NIL.
;			       DEFAULT-TYPE)))
;	       )
;	       (SETQ NEW-TYPE DEFAULT-TYPE)))
;	 (IF (NULL (S$PATHNAME-VERSION S$PATHNAME))
;	     (IF (OR (NULL (S$PATHNAME-NAME S$PATHNAME))
;		     *ALWAYS-MERGE-TYPE-AND-VERSION*)
;		 (SETQ NEW-VERSION
;		       (OR (S$PATHNAME-VERSION DEFAULT)
;			   (AND (NOT (NULL SECONDARY-DEFAULT))
;				(S$PATHNAME-VERSION SECONDARY-DEFAULT))
;			   ;; Never let the version of the resulting s$pathname be NIL.
;			   DEFAULT-VERSION))
;	       (SETQ NEW-VERSION DEFAULT-VERSION)))
;	 (SEND S$PATHNAME :NEW-S$PATHNAME
;	       		(IF NEW-DEVICE :DEVICE) NEW-DEVICE
;			(IF NEW-DIRECTORY :DIRECTORY) NEW-DIRECTORY
;			(IF NEW-NAME :NAME) NEW-NAME
;			(IF NEW-TYPE :TYPE) NEW-TYPE
;			(IF NEW-OTYPE :ORIGINAL-TYPE) NEW-OTYPE
;			(IF NEW-VERSION :VERSION) NEW-VERSION))))

;;;; 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 'S$PATHNAME-PARSE-ERROR "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 crock.
;;;; Another handy user interface, fills in from defaults and updates them.  Useful when
;;;; not prompting.
;(DEFUN MERGE-AND-SET-S$PATHNAME-DEFAULTS (S$PATHNAME
;					&OPTIONAL (DEFAULTS *DEFAULT-S$PATHNAME-DEFAULTS*)
;						  (DEFAULT-TYPE *NAME-SPECIFIED-DEFAULT-TYPE*)
;						  (DEFAULT-VERSION :NEWEST))
;  "Default S$PATHNAME like MERGE-S$PATHNAME-DEFAULTS, but then set the defaults.
;If DEFAULTS is a defaults-list (rather than a s$pathname), the specified
;s$pathname sets the defaults."
;  (SETQ S$PATHNAME (MERGE-S$PATHNAME-DEFAULTS S$PATHNAME DEFAULTS DEFAULT-TYPE DEFAULT-VERSION))
;  (AND (CONSP DEFAULTS) (SET-DEFAULT-S$PATHNAME S$PATHNAME DEFAULTS))
;  S$PATHNAME)

;;;; Used only from zwei:com-old-list-files
;(DEFMETHOD (S$PATHNAME :DEFAULT-S$NAMESTRING) (S$NAMESTRING &OPTIONAL (DEFAULT-TYPE :UNSPECIFIC)
;								(DEFAULT-VERSION :NEWEST))
;  (MERGE-S$PATHNAME-DEFAULTS S$NAMESTRING SELF DEFAULT-TYPE DEFAULT-VERSION))
;
;;;;; Wildcard mapping operations.
;;; Copied from LAD: RELEASE-3.IO.FILE; PATHNM.LISP#570 on 2-Oct-86 05:41:50
;(DEFVAR *DEFAULT-S$PATHNAME-COMPONENT-MATCH* #'STRING=)


;;; Copied from LAD: RELEASE-3.IO.FILE; PATHNM.LISP#570 on 2-Oct-86 05:41:51
;(DEFUN S$PATHNAME-COMPONENT-MATCH (PATTERN SAMPLE WILD-ANY WILD-ONE
;				 &OPTIONAL RETURN-SPECS-FLAG (STRING= *DEFAULT-S$PATHNAME-COMPONENT-MATCH*)
;				 &AUX SPECS)
;  ;; If RETURN-SPECS-FLAG, we return a list of the chars or strings
;  ;; that matched the wildcards, in the order they appeared,
;  ;; or T if no wildcards but the pattern does match.
;  (IF (AND (CONSP PATTERN) (NULL (CDR PATTERN))) (SETQ PATTERN (CAR PATTERN)))
;  (IF (AND (CONSP SAMPLE) (NULL (CDR SAMPLE))) (SETQ SAMPLE (CAR SAMPLE)))
;  (COND ((AND (EQ PATTERN :WILD)
;	      (ATOM SAMPLE))
;	 (IF RETURN-SPECS-FLAG
;	     (IF (CONSP SAMPLE) SAMPLE (LIST SAMPLE))
;	   T))
;	((SYMBOLP PATTERN) (EQ PATTERN SAMPLE))
;	((NUMBERP PATTERN) (EQ PATTERN SAMPLE))
;	((CHARACTERP PATTERN) (= PATTERN SAMPLE))
;	((CONSP PATTERN)
;	 (AND (CONSP SAMPLE)
;	      (= (LENGTH PATTERN) (LENGTH SAMPLE))
;	      (LOOP FOR P IN PATTERN
;		    FOR S IN SAMPLE
;		    DO
;		    (LET ((TEM
;			    (S$PATHNAME-COMPONENT-MATCH P S WILD-ANY WILD-ONE
;						      RETURN-SPECS-FLAG STRING=)))
;		      (IF (NULL TEM) (RETURN NIL))
;		      (UNLESS (EQ TEM T)
;			(SETQ SPECS (APPEND SPECS TEM))))
;		    FINALLY (RETURN (OR SPECS T)))))
;	((NOT (STRINGP SAMPLE)) NIL)
;	(T
;	 (DO ((P-PTR 0)
;	      (P-NEXT)
;	      (P-CHAR WILD-ONE)
;	      (S-PTR -1)
;	      (SET (LIST WILD-ANY WILD-ONE)))
;	     (())
;	   (SETQ P-NEXT (STRING-SEARCH-SET SET PATTERN P-PTR NIL T))
;	   (COND ((= P-CHAR WILD-ONE)
;		  (AND RETURN-SPECS-FLAG ( S-PTR 0)
;		       (PUSH (AREF SAMPLE S-PTR) SPECS))
;		  (SETQ S-PTR
;			(AND (FUNCALL STRING= SAMPLE PATTERN
;				      :START1 (1+ S-PTR)
;				      :START2 P-PTR
;				      :END1 (+ 1 S-PTR
;						 (- (OR P-NEXT (LENGTH PATTERN)) P-PTR))
;				      :END2 P-NEXT)
;			     (1+ S-PTR))))
;		 ((NULL P-NEXT)
;		  ;; Stuff at end following a star =>
;		  ;;  win if tail of rest of string matches that stuff.
;		  (LET ((OLD-S-PTR S-PTR))
;		    (SETQ S-PTR (STRING-REVERSE-SEARCH PATTERN SAMPLE NIL S-PTR P-PTR NIL T))
;		    (WHEN RETURN-SPECS-FLAG
;		      (PUSH (SUBSTRING SAMPLE OLD-S-PTR S-PTR) SPECS))))
;		 (T
;		  (LET ((OLD-S-PTR S-PTR))
;		    (SETQ S-PTR (STRING-SEARCH PATTERN SAMPLE S-PTR NIL P-PTR P-NEXT T))
;		    (WHEN RETURN-SPECS-FLAG
;		      (PUSH (SUBSTRING SAMPLE OLD-S-PTR S-PTR) SPECS)))))
;	   (UNLESS S-PTR (RETURN NIL))
;	   (INCF S-PTR (- (OR P-NEXT (LENGTH PATTERN)) P-PTR))
;	   (UNLESS P-NEXT (RETURN (AND (= S-PTR (LENGTH SAMPLE)) (OR (NREVERSE SPECS) T))))
;	   (SETQ P-CHAR (AREF PATTERN P-NEXT))
;	   (SETQ P-PTR (1+ P-NEXT))))))

;(DEFMETHOD (S$PATHNAME :S$PATHNAME-MATCH) (S$PATHNAME &OPTIONAL (MATCH-HOST T))
;  (MULTIPLE-VALUE-BIND (W* W1)
;      (SEND SELF :INTERNAL-WILD-CHARACTERS)
;    (AND (OR (NOT MATCH-HOST)
;	     (EQ HOST (S$PATHNAME-HOST S$PATHNAME)))
;	 (S$PATHNAME-COMPONENT-MATCH DEVICE (S$PATHNAME-DEVICE S$PATHNAME) W* W1)
;	 (S$PATHNAME-COMPONENT-MATCH DIRECTORY (S$PATHNAME-DIRECTORY S$PATHNAME) W* W1)
;	 (S$PATHNAME-COMPONENT-MATCH NAME (S$PATHNAME-NAME S$PATHNAME) W* W1)
;	 (S$PATHNAME-COMPONENT-MATCH TYPE (S$PATHNAME-TYPE S$PATHNAME) W* W1)
;	 (S$PATHNAME-COMPONENT-MATCH VERSION (S$PATHNAME-VERSION S$PATHNAME) W* W1))))

;(DEFMETHOD (S$PATHNAME :S$PATHNAME-MATCH-SPECS) (S$PATHNAME)
;  (MULTIPLE-VALUE-BIND (W* W1)
;      (SEND SELF :INTERNAL-WILD-CHARACTERS)
;    (VALUES
;      (S$PATHNAME-COMPONENT-MATCH DEVICE (S$PATHNAME-DEVICE S$PATHNAME) W* W1 T)
;      (S$PATHNAME-COMPONENT-MATCH DIRECTORY (S$PATHNAME-DIRECTORY S$PATHNAME) W* W1 T)
;      (S$PATHNAME-COMPONENT-MATCH NAME (S$PATHNAME-NAME S$PATHNAME) W* W1 T)
;      (S$PATHNAME-COMPONENT-MATCH TYPE (S$PATHNAME-TYPE S$PATHNAME) W* W1 T))))
;
;;;; Wildcard translation

;;; Copied from LAD: RELEASE-3.IO.FILE; PATHNM.LISP#570 on 2-Oct-86 05:41:52
;;;; Return a s$pathname component made from TARGET-PATTERN
;;;; by replacing each wildcard with an element of SPECS
;(DEFUN S$PATHNAME-TRANSLATE-WILD-COMPONENT
;       (TARGET-PATTERN DATA SPECS WILD-ANY WILD-ONE &OPTIONAL REVERSIBLE-P)
;  (COND ((EQ TARGET-PATTERN :WILD)
;	 (IF (AND (CONSP SPECS) REVERSIBLE-P)
;	     (CAR SPECS)
;	   DATA))
;	((OR (NUMBERP TARGET-PATTERN)
;	     (SYMBOLP TARGET-PATTERN)
;	     (EQ SPECS T))
;	 TARGET-PATTERN)
;	((CONSP TARGET-PATTERN)
;	 (LOOP FOR ELT IN TARGET-PATTERN
;	       COLLECT
;	       (IF (EQ ELT :WILD)
;		   (POP SPECS)
;		 (MULTIPLE-VALUE-BIND (NEW-ELT SPECS-LEFT)
;		     (S$PATHNAME-TRANSLATE-COMPONENT-FROM-SPECS
;		       ELT SPECS WILD-ANY WILD-ONE)
;		   (SETQ SPECS SPECS-LEFT)
;		   NEW-ELT))))
;	(T (S$PATHNAME-TRANSLATE-COMPONENT-FROM-SPECS
;	     TARGET-PATTERN SPECS WILD-ANY WILD-ONE))))

;(DEFUN S$PATHNAME-TRANSLATE-COMPONENT-FROM-SPECS (PATTERN SPECS WILD-ANY WILD-ONE)
;  (DECLARE (VALUES TRANSLATED-COMPONENT SPECS-LEFT))
;  (IF (EQ PATTERN :WILD) (SETQ PATTERN (STRING WILD-ANY)))
;  (LET ((TARGET-INDICES (S$PATHNAME-WILD-CHAR-INDICES PATTERN WILD-ANY WILD-ONE)))
;    (DO ((TIS TARGET-INDICES (CDR TIS))
;	 (RESULT (MAKE-STRING 24. :FILL-POINTER 0))
;	 (SPECS-LEFT SPECS)
;	 TI
;	 (PREV-TI -1 TI))
;	(())
;      (SETQ TI (CAR TIS))
;      (UNLESS (MINUSP PREV-TI)
;	(STRING-NCONC RESULT
;		      (OR (POP SPECS-LEFT) "")))
;      (STRING-NCONC RESULT
;		    (SUBSTRING PATTERN (1+ PREV-TI) TI))
;      (UNLESS TI (RETURN (values RESULT SPECS-LEFT))))))

;(DEFUN S$PATHNAME-WILD-CHAR-INDICES (STRING &REST SET)
;  (IF (NOT (STRINGP STRING)) NIL
;    (DO ((I (LENGTH STRING)) VALUES)
;	(())
;      (SETQ I (STRING-REVERSE-SEARCH-SET SET STRING I))
;      (UNLESS I (RETURN VALUES))
;      (PUSH I VALUES))))

;(DEFMETHOD (S$PATHNAME :TRANSLATE-WILD-S$PATHNAME) 
;	   (TARGET-PATTERN DATA-S$PATHNAME &OPTIONAL REVERSIBLE-P)
;  (SEND TARGET-PATTERN :TARGET-TRANSLATE-WILD-S$PATHNAME SELF DATA-S$PATHNAME REVERSIBLE-P))

;(DEFMETHOD (S$PATHNAME :TARGET-TRANSLATE-WILD-S$PATHNAME)
;	   (SOURCE-PATTERN DATA-S$PATHNAME &OPTIONAL REVERSIBLE-P)
;  (MULTIPLE-VALUE-BIND (W* W1)
;      (SEND SELF :INTERNAL-WILD-CHARACTERS)
;    (LET ((CASE-CONVERTER
;	    (SEND SELF :TRANSLATION-CASE-CONVERTER)))
;      (MULTIPLE-VALUE-BIND (DEV-SPECS DIR-SPECS NAME-SPECS TYPE-SPECS)
;	  (SEND SOURCE-PATTERN :S$PATHNAME-MATCH-SPECS DATA-S$PATHNAME)
;	(MAKE-S$PATHNAME :HOST HOST
;		       :RAW-DEVICE (S$PATHNAME-TRANSLATE-WILD-COMPONENT
;				      DEVICE
;				      (FUNCALL CASE-CONVERTER
;					       (S$PATHNAME-DEVICE DATA-S$PATHNAME))
;				      (FUNCALL CASE-CONVERTER DEV-SPECS)
;				      W* W1 REVERSIBLE-P)
;		       :RAW-DIRECTORY (S$PATHNAME-TRANSLATE-WILD-COMPONENT
;					 DIRECTORY
;					 (FUNCALL CASE-CONVERTER
;						  (S$PATHNAME-DIRECTORY DATA-S$PATHNAME))
;					 (FUNCALL CASE-CONVERTER DIR-SPECS)
;					 W* W1 REVERSIBLE-P)
;		       :RAW-NAME (S$PATHNAME-TRANSLATE-WILD-COMPONENT
;				    NAME
;				    (FUNCALL CASE-CONVERTER
;					     (S$PATHNAME-NAME DATA-S$PATHNAME))
;				    (FUNCALL CASE-CONVERTER NAME-SPECS)
;				    W* W1 REVERSIBLE-P)
;		       (IF (AND (EQ TYPE :WILD)
;				(OR (NOT REVERSIBLE-P)
;				    (EQ (S$PATHNAME-TYPE SOURCE-PATTERN) :WILD)))
;			   :TYPE :RAW-TYPE)
;				  (IF (AND (EQ TYPE :WILD)
;					   (OR (NOT REVERSIBLE-P)
;					       (EQ (S$PATHNAME-TYPE SOURCE-PATTERN) :WILD)))
;				      (SEND DATA-S$PATHNAME :CANONICAL-TYPE)
;				    (S$PATHNAME-TRANSLATE-WILD-COMPONENT
;				      TYPE
;				      (FUNCALL CASE-CONVERTER
;					       (S$PATHNAME-TYPE DATA-S$PATHNAME))	
;				      (FUNCALL CASE-CONVERTER TYPE-SPECS)
;				      W* W1 REVERSIBLE-P))
;		       :VERSION (IF (EQ VERSION :WILD) (S$PATHNAME-VERSION DATA-S$PATHNAME)
;			 VERSION))))))

;;;; Returns function that converts interchange case into this flavor's raw case.
;(DEFMETHOD (S$PATHNAME :TRANSLATION-CASE-CONVERTER) ()
;  #'(LAMBDA (X) X))

;;;; Returns two values, the wild-any char for this flavor and the wild-one char.
;(DEFMETHOD (S$PATHNAME :INTERNAL-WILD-CHARACTERS) ()
;  (VALUES #/* -1))
;
;;;;; Operations that refer to the file.

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

;(DEFMETHOD (S$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 (ERRORP STREAM))
;				(LET* ((LIST (SEND STREAM :PLIST))
;				       (PLIST (LOCF LIST)))
;				  (OR (GET PLIST :S$TRUENAME)
;				      (PUTPROP PLIST (SEND STREAM :S$TRUENAME) :S$TRUENAME))
;				  LIST)))))

;(DEFMETHOD (S$PATHNAME :UNDELETE) (&OPTIONAL (ERROR-P T))
;  (CHANGE-FILE-PROPERTIES SELF ERROR-P :DELETED NIL))

;(DEFMETHOD (S$PATHNAME :S$TRUENAME) (&OPTIONAL (ERROR-P T))
;  (WITH-OPEN-FILE (STREAM SELF :ERROR ERROR-P)
;    (IF (ERRORP STREAM) STREAM
;      (SEND STREAM :S$TRUENAME))))

;;;; This isn't implemented as a separate file subprotocol, just use the directory
;(DEFMETHOD (S$PATHNAME :PROPERTIES) (&OPTIONAL (ERROR-P T))
;  (FILE-OPERATION-RETRY
;    (LET ((DIR (SEND SELF :DIRECTORY-LIST
;		          (IF ERROR-P '(:DELETED)
;			    '(:NOERROR :DELETED)))))
;      (COND ((CONSP DIR)
;	     (IF (CADR DIR)
;		 (VALUES (CADR DIR) (GET (CAR DIR) :SETTABLE-PROPERTIES))
;	       ;; It is possible for a nonexistent file to give no error
;	       ;; but just return an empty directory.
;	       (FILE-PROCESS-ERROR 'FILE-NOT-FOUND "File not found" SELF
;				   NIL (NOT ERROR-P) :PROPERTIES)))
;	    (T DIR)))))
;
;;;; Should these flavors go away completely?
;;;; Or is there something that Unix, Multics, T(w)enex and Lispm file systems
;;;; have in common which could reasonably be put here?

;(DEFFLAVOR HIERARCHICAL-DIRECTORY-MIXIN () ()
;  (:REQUIRED-FLAVORS S$PATHNAME))

;;(comment
;;(DEFMETHOD (HIERARCHICAL-DIRECTORY-MIXIN :VALID-DIRECTORY) (DIRNAME)
;;  (IF (ATOM DIRNAME)
;;      (COND ((MEMQ DIRNAME '(NIL :WILD :UNSPECIFIC))
;;	     DIRNAME)
;;	    ((STRINGP DIRNAME)
;;	     DIRNAME)
;;	    (T
;;	     (SEND SELF :DEFAULT-DIRECTORY)))
;;    (SEND SELF :CHECK-SUBDIRECTORIES DIRNAME 0)))

;;(DEFMETHOD (HIERARCHICAL-DIRECTORY-MIXIN :VALID-DIRECTORY-P) (DIRNAME)
;;  (OR (NULL DIRNAME)
;;      (STRINGP DIRNAME)
;;      (AND (CONSP DIRNAME)
;;	   (SEND SELF :VALID-SUBDIRECTORY-P DIRNAME 0))))

;;(DEFMETHOD (HIERARCHICAL-DIRECTORY-MIXIN :VALID-SUBDIRECTORY-P) (DIRNAME-LIST LEVEL)
;;  (OR (NULL DIRNAME-LIST)
;;      (AND (CONSP DIRNAME-LIST)
;;	   (SEND SELF :VALID-DIRECTORY-COMPONENT-P (CAR DIRNAME-LIST) LEVEL)
;;	   (SEND SELF :VALID-SUBDIRECTORY-P (CDR DIRNAME-LIST) (1+ LEVEL)))))

;;(DEFMETHOD (HIERARCHICAL-DIRECTORY-MIXIN :VALID-DIRECTORY-COMPONENT-P) (DIRNAME IGNORE)
;;  (OR (STRINGP DIRNAME) (MEMQ DIRNAME '(:WILD :UNSPECIFIC))))

;;(DEFMETHOD (HIERARCHICAL-DIRECTORY-MIXIN :DEFAULT-DIRECTORY) ()
;;  (SEND (QUIET-USER-HOMEDIR HOST) :DIRECTORY))

;;(DEFMETHOD (HIERARCHICAL-DIRECTORY-MIXIN :CHECK-SUBDIRECTORIES) (DIRNAMES LEVEL)
;;  (IF (NULL DIRNAMES) NIL
;;      (CONS (IF (SEND SELF :VALID-DIRECTORY-COMPONENT-P (CAR DIRNAMES) LEVEL)
;;		(CAR DIRNAMES))
;;	    (SEND SELF :CHECK-SUBDIRECTORIES (CDR DIRNAMES) (1+ LEVEL)))))
;;);end comment

;(DEFFLAVOR MEANINGFUL-ROOT-MIXIN () ()
;  (:REQUIRED-FLAVORS S$PATHNAME)
;  (:REQUIRED-METHODS :DIRECTORY-S$PATHNAME-AS-FILE)
;  (:METHOD-COMBINATION (:DAEMON-WITH-OR :BASE-FLAVOR-LAST :VALID-DIRECTORY-COMPONENT-P))
;  (:DOCUMENTATION :MIXIN "For use with file systems where the root directory is treated
;as an ordinary directory."))

;;(comment
;;(DEFMETHOD (MEANINGFUL-ROOT-MIXIN :OR :VALID-DIRECTORY-COMPONENT-P) (DIRNAME IGNORE)
;;  (MEMQ DIRNAME '(:ROOT :RELATIVE :UP)))
;;);end comment
;
;;;; brand S
;(DEFF DESCRIBE-PHYSICAL-HOST 'SI:DESCRIBE-HOST)

;
;;;;; s$pathname system initialization

;(DEFUN S$PATHNAME-INITIALIZE ()
;  (SETQ *S$PATHNAME-HASH-TABLE* (MAKE-EQUAL-HASH-TABLE :SIZE 3000. :AREA S$PATHNAME-AREA))
;  (SETQ *DEFAULT-S$PATHNAME-DEFAULTS* (MAKE-S$PATHNAME-DEFAULTS))
;  (SETQ CLI:*DEFAULT-S$PATHNAME-DEFAULTS*
;	(SI:CDR-LOCATION-FORCE (ASSQ NIL *DEFAULT-S$PATHNAME-DEFAULTS*)))
;  (%P-STORE-DATA-TYPE (LOCF CLI:*DEFAULT-S$PATHNAME-DEFAULTS*) DTP-EXTERNAL-VALUE-CELL-POINTER)
;  (SETQ LOAD-S$PATHNAME-DEFAULTS (MAKE-S$PATHNAME-DEFAULTS)))

;(ADD-INITIALIZATION "S$PATHNAME-INITIALIZE" '(S$PATHNAME-INITIALIZE) '(ONCE))

;;(DEFVAR S$PATHNAME-PLISTS-LINEARIZED-ONCE NIL)

;;(DEFUN LINEARIZE-S$PATHNAME-PLISTS ()
;;  (IF S$PATHNAME-PLISTS-LINEARIZED-ONCE
;;      ;; If already been recopied, just reference all of them so they are
;;      ;; all copied into newspace together.
;;      (MAPHASH #'(LAMBDA (IGNORE FILE &REST IGNORE)
;;		   (REFERENCE-ALL (SEND FILE :PLIST)))
;;	       FS:*S$PATHNAME-HASH-TABLE*)
;;    (SETQ S$PATHNAME-PLISTS-LINEARIZED-ONCE T)
;;    (MAPHASH #'(LAMBDA (IGNORE FILE &REST IGNORE)
;;		 (SEND FILE :SET-PROPERTY-LIST (COPYTREE (SEND FILE :PLIST))))
;;	     FS:*S$PATHNAME-HASH-TABLE*)))

;;(DEFUN REFERENCE-ALL (OBJECT)
;;  (UNLESS (ATOM OBJECT)
;;    (DO ((TAIL OBJECT (CDR TAIL)))
;;	((ATOM TAIL))
;;      (UNLESS (ATOM (CAR TAIL))
;;	(REFERENCE-ALL (CAR TAIL))))))

;;(ADD-INITIALIZATION "s$pathname plists" '(LINEARIZE-S$PATHNAME-PLISTS) '(AFTER-FULL-GC))