LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760031859. :SYSTEM-TYPE :LOGICAL :VERSION 16. :TYPE "LISP" :NAME "PARSE" :DIRECTORY ("REL3-SOURCE" "PATHNAME") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-SOURCE\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :VERSION-LIMIT 0. :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2758742075. :AUTHOR "REL3" :LENGTH-IN-BYTES 56682. :LENGTH-IN-BLOCKS 56. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                             ;;-*-Mode:Common-LISP;Package:FILE-SYSTEM; Base:10.; COLD-LOAD:T  -*-;;;                           RESTRICTED RIGHTS LEGEND;;;Use, duplication, or disclosure by the Government is subject to;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in;;;Technical Data and Computer Software clause at 52.227-7013.;;;                     TEXAS INSTRUMENTS INCORPORATED.;;;                              P.O. BOX 2909;;;                           AUSTIN, TEXAS 78769;;;                                 MS 2151;;; Copyright (C) 1985,1987 Texas Instruments Incorporated. All rights reserved.;;;  ** (c) Copyright 1980 Massachusetts Institute of Technology **;;; REVISION ;;;03.10.87 MBCRead-pathname-instance fixed to use Read with RECURSIVEP, ;;;renamed and hacked FS:MAKE-UNNAMED-HOST to MAKE-FAKE-NAMED-HOST,;;;added HOST & SYSTEM-TYPE options to PATHNAME-STRING-TO-OBJECT.;;;03.09.87 MBCVERIFY-LIST-OF-DIRECTORIES-1 instead of GET-LIST-OF-DIRECTORIES.;;;02.27.87 MBC    GET-LIST-OF-DIRECTORIES-1 looks out for pathnames whose;;;:DIRECTORY-PATHNAME-AS-FILE won't work, (requires UNIX mod).;;;02.16.87 MBC    GET-LIST-OF-DIRECTORIES-1 changed to not try to probe :ROOT.;;;02.16.87 MBC    Fix MERGE-PATHNAME-DEFAULTS to return types as :UNSPECIFIC if required.;;;02.11.87 MBCIf called with DEFAULT-TYPE of NIL force to non-NIL default.;;;02.11.87 MBC Make READ-PATHNAME-INSTANCE verify that host from namestring;;;is of the same System-Type as the pathname flavor, otherwise;;;create an Unknown-Host.  Fixes restore of tape made from a host;;;whose name exists at two sites but is a different type at restore site.;;;02.10.87 MBCTruename now uses open to merge string components.;;;01.28.87 MBCParsing takes advantage of host error handler. ;;;01.26.87 MBC    Signal a Directory-Not-Found error from :wildcard-map's helper fnc,;;;GET-LIST-OF-DIRECTORIES-1 when not :Directory-Wild-P.;;;01.22.87 MBCSupport changing of quoted-string if parsing a pathname again;;;with different one, inside Make-Pathname-Internal.;;; 01.15.87 MBCTGC mods: Make PATHNAME-AREA :dynamic, increase the hash table's;;;initial size, and re-write LINEARIZE-PATHNAME-PLISTS.  For -ab.;;;Also make pathname-object-to-string put out keyword list, not ;;;a string representing the object.  -MBC;;;;;; Advertised function interfaces:;;; PARSE-PATHNAME THING &OPTIONAL WITH-RESPECT-TO (DEFAULTS *DEFAULT-PATHNAME-DEFAULTS*);;;  Parses a string (or whatever) into a pathname.;;; DEFAULT-PATHNAME &OPTIONAL DEFAULTS HOST DEFAULT-TYPE DEFAULT-VERSION;;;  Returns the default for the given HOST from DEFAULTS.;;; SET-DEFAULT-PATHNAME PATHNAME &OPTIONAL DEFAULTS;;;  Sets the default for either the host of the pathname or the NIL default.;;; MAKE-PATHNAME-DEFAULTS;;;  Returns an alist that you can pass to the functions below that take a set of defaults.;;;  Most things that take a set of defaults will also take a single pathname.;;; MERGE-PATHNAME-DEFAULTS PATHNAME &OPTIONAL DEFAULTS DEFAULT-TYPE DEFAULT-VERSION;;;  Fill in slots in PATHNAME from program defaults.  This is what most;;;  programs interface to.;;; MERGE-AND-SET-PATHNAME-DEFAULTS PATHNAME &OPTIONAL DEFAULTS DEFAULT-TYPE DEFAULT-VERSION;;;  Does parse, merge, and updating of defaults.;;; DESCRIBE-PATHNAME PATHNAME;;;  Describes all files that look like pathname.  Also useful when you cannot remember what;;;  directory a file is in.;;; PATHNAME-PLIST PATHNAME;;; Advertised messages on pathnames:;;; :GET INDICATOR    --- 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 AI: LISPM2; HOST >.;;; *PATHNAME-HOST-LIST* is the set of all pathname hosts.  Some of;;; these are actual hosts on the local network, such as MIT-AI, and;;; others are logical hosts, such as SYS.  When parsing a string into a;;; pathname, the specified host (the part of the string before the;;; colon) is sent in the :PATHNAME-HOST-NAMEP message to each host in;;; this list.  When that returns T, that host is used.;;; The host is sent a :PATHNAME-FLAVOR message to determine the flavor of the;;; pathname to instantiate.  (If the reply to :PATHNAME-FLAVOR returns multiple;;; values, the second is an addition for the INIT-PLIST to use when instantiating.);;; Normally, when printing the host portion of a pathname, the host is;;; sent a :NAME-AS-FILE-COMPUTER message.;;;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.;;;  If a generic pathname is a logical pathname, then its device is always :UNSPECIFIC.;;; I (RMS) do not understand the following, which was written by RG, and;;; I suspect it isn't even hypothetically true any more:;;;  Devices in generic pathnames are a real pain.  If left :UNSPECIFIC they could cause;;;  identical appearing generic pathnames to not be EQ, resulting in loss of PLISTs.;;;  If specified, particularily in LOGICAL-PATHNAMES (see below), they can cause loss;;;  of portability since a different device spec might be necessary to cause the right;;;  thing to happen at another site.  The solution is first to make the GENERIC-PATHNAME;;;  as specific as possible by replacing any NIL or UNSPECIFIC device with the;;;  result of a :DEFAULT-DEVICE message to the host.  Then do the;;;  BACKTRANSLATE-HOST-DIRECTORY operation.  Then we if HOST is a LOGICAL-HOST,;;;  we wish this band-image to be portable with respect to file computers.;;;  Thus we want to treat the device as part;;;  of the host, not part of the generic pathname.  If DEVICE is NIL, UNSPECIFIC,;;;  or the default device for the logical host, we need do nothing special beyond;;;  standardizing by setting DEVICE to UNSPECIFIC.   Otherwise, we would really like to;;;  add an instance variable holding DEVICE to the particular sub-instance of HOST.;;;  Ie, it would SHARE the instance variables and behavior of HOST while having this one;;;  extra one off to the side.  Unfortunately, flavors dont allow us to do this;;;  for quite fundamental reasons.  We cant simply flush DEVICE, since then ;;;  the GENERIC-PATHNAME will not be adequate to access the base file.  The following;;;  kludge sort of gets around the problem.  We store on the GENERIC-PATHNAMEs property;;;  list a LOGICAL-DEVICE-TRANSLATION-KEY property, which is the position of the desired;;;  device in a NON-DEFAULT-DEVICE list associated with the LOGICAL-HOST.  Since we;;;  do not expect very many distinct devices associated with a host, this list should;;;  be quite short.;;;   -- however -- for the time being this hair is not implemented --;;;  it will just be an error condition if we would need one of these funny host objects.;;;;;;  REVISED:;;;    Two new functions added; Read-Pathname-Instance  and Make-Unnamed-Host to allow;;;    :READ-INSTANCE methods to create UNKNOWN-MULTICS or UNKNOWN-Lmfs etc.  11-12-85 MBC(DEFUN PATHNAME (OBJECT)  "Convert OBJECT to a pathname.If it's a pathname, it is unchanged.If it's a stream, the :PATHNAME operation is invoked.If it's a string or symbol, it is parsed."  (CHECK-ARG OBJECT     (OR (TYPEP OBJECT 'PATHNAME) (STREAMP OBJECT) (SYMBOLP OBJECT) (STRINGP OBJECT))     "a symbol, string, stream or pathname")  (IF (TYPEP OBJECT 'PATHNAME)    OBJECT    (IF (STREAMP OBJECT)      (SEND OBJECT :PATHNAME)      (PARSE-PATHNAME OBJECT))))(DEFUN PATHNAMEP (OBJECT)  "T if OBJECT is a pathname."  (TYPEP OBJECT 'PATHNAME))(DEFUN TRUENAME (OBJECT)  "Convert OBJECT to a pathname, then return the truename of the file it refers to."  (IF (STREAMP OBJECT)      (SEND OBJECT :TRUENAME)      (with-open-file (s OBJECT :direction nil :error t);2.10.87 MBC(send s :TRUENAME))));;; Put out pathname components as a keyword list in a string so;;; the pathname can be re-created, except it'll ALWAYS have a ;;; device of NIL and be a pathname of the local machine.(defun pathname-object-to-string (pathname);so rel3 will write stuff that's "MORE GENERIC"  (with-lisp-mode :COMMON-LISP    (with-output-to-string (s)       (princ "( " s)      (princ ":DIRECTORY " S)      (prin1 (send pathname :directory) s) (send s :tyo #\SPACE)      (princ ":NAME " S)      (prin1 (send pathname :name) s) (send s :tyo #\SPACE)      (princ ":TYPE " S)      (prin1 (send pathname :type) s) (send s :tyo #\SPACE)      (princ ":VERSION " S)      (prin1 (send pathname :version) s)      (send s :tyo #\)))))(DEFUN READ-PATHNAME-INSTANCE (STREAM SYSTEM-TYPE &OPTIONAL ignore);lmfs special fixed???  (LET* ((PATHNAME-STRING (READ STREAM T NIL T));Common-Lisp fix 3.10.87 (START (POSITION #\: PATHNAME-STRING :TEST #'CHAR=)) (HOST-STRING (SUBSEQ PATHNAME-STRING 0 START)) (NAME-STRING (SUBSEQ PATHNAME-STRING (1+ START))))    (IF (let* ((host-1  (FS:GET-PATHNAME-HOST HOST-STRING T))       (system-type-1 (and host-1 (send host-1 :system-type))))  (eq system-type system-type-1));2.11.87 MBC (PARSE-PATHNAME PATHNAME-STRING)(IF (EQ SYSTEM-TYPE :LOGICAL)    (READ-PATHNAME-OF-UNKNOWN-LOGICAL-HOST HOST-STRING NAME-STRING)    (PARSE-PATHNAME      NAME-STRING      (FS:MAKE-FAKE-NAMED-HOST SYSTEM-TYPE host-string))))));3.10.87;;; Make a host if one of the correct system-type & name does not already exist.;;; Let the name be deterministic so we don't create new ones when called with;;; the same arguments.   Namespace should keep this host local.(DEFUN MAKE-FAKE-NAMED-HOST (SYSTEM-TYPE host);3.10.87  (let* ((host-name (name:split-name host));chop off domain (name (string-upcase(if host-name (string-append (string system-type) "-" host-name)    (string system-type)))))    (NET:MAKE-UNNAMED-HOST SYSTEM-TYPE (list name   ;; be unique about names with system-type     '(1)))));arbitrary number(defun pathname-string-to-object (string &optional HOST (system-type :LISPM))  (let ((value (with-lisp-mode :COMMON-LISP (READ-FROM-STRING string))))    (if (consp value);New list form(let* ((host-1 (and host (FS:GET-PATHNAME-HOST HOST T)))       (system-type-1 (and host-1 (send host-1 :system-type)))       (value-1 (cons :host (cons (if (eq system-type system-type-1)      host;use known host if system types match      (FS:MAKE-FAKE-NAMED-HOST SYSTEM-TYPE host));else new one  value))))  (apply #'make-pathname value-1))value)));Old flavor/object form(DEFUN READ-PATHNAME-OF-UNKNOWN-LOGICAL-HOST (HOST-STRING NAME-STRING)  (IF (GET-PATHNAME-HOST HOST-STRING T)      (PARSE-PATHNAME NAME-STRING HOST-STRING)      (LET (PROCEED-TYPE NEW-ARG)(MULTIPLE-VALUE-SETQ  (PROCEED-TYPE NEW-ARG)  (SIGNAL 'UNKNOWN-LOGICAL-HOST "UNKNOWN LOGICAL HOST ~A,~:*IN PATHNAME, ~A:~A."  HOST-STRING NAME-STRING))(READ-PATHNAME-OF-UNKNOWN-LOGICAL-HOST  (IF (EQ PROCEED-TYPE :NEW-HOST) NEW-ARG HOST-STRING)  NAME-STRING))))(DEFUN NAMESTRING (OBJECT)  "Convert OBJECT to a pathname and then that into a namestring."  (SEND (PATHNAME OBJECT) :STRING-FOR-PRINTING))(DEFUN FILE-NAMESTRING (OBJECT)  "Convert OBJECT to a pathname; return a namestring specifying just name, type and version."  (SEND (PATHNAME OBJECT) :STRING-FOR-DIRED))(DEFUN DIRECTORY-NAMESTRING (OBJECT)  "Convert OBJECT to a pathname; return a namestring specifying just device and directory."  (SEND (PATHNAME OBJECT) :STRING-FOR-DIRECTORY))(DEFUN HOST-NAMESTRING (OBJECT)  "Convert OBJECT to a pathname; return a namestring with just OBJECT's host name and a colon."  (STRING-APPEND (SEND (PATHNAME OBJECT) :HOST) ":"));;; Defaults alists;;(DEFSIGNAL UNKNOWN-PATHNAME-HOST (PATHNAME-ERROR UNKNOWN-PATHNAME-HOST) (NAME);;   "Used when GET-PATHNAME-HOST does not recognize the host name.")  (DEFVAR *DEFAULT-PATHNAME-DEFAULTS* :UNBOUND   "These are the defaults MERGE-PATHNAME-DEFAULTS uses if none are specified.")  (DEFPARAMETER *DEFAULTS-ARE-PER-HOST* ()   "Non-NIL means each default-list should keep a separate default file name for each host.NIL means defaults are independent of host.")  (DEFUN ENOUGH-NAMESTRING (OBJECT &OPTIONAL (DEFAULTS *DEFAULT-PATHNAME-DEFAULTS*))  "Return enough namestring to produce whatever OBJECT produced when merged with DEFAULTS.OBJECT is converted to a pathname, and that is made into a stringfrom which components may be omitted if their values are the same aswhat would result from defaulting whatever is left with the specified defaults."  (DECLARE (SPECIAL *DEFAULT-PATHNAME-DEFAULTS*))  (LET* ((PATHNAME (PATHNAME OBJECT)) (DEFHOST (DEFAULT-HOST DEFAULTS)) (DP (DEFAULT-PATHNAME DEFAULTS (PATHNAME-HOST PATHNAME))) (NEED-NAME (NOT (EQUAL (PATHNAME-RAW-NAME PATHNAME) (PATHNAME-RAW-NAME DP)))) (NEED-TYPE (NOT (EQUAL (PATHNAME-RAW-TYPE PATHNAME) (PATHNAME-RAW-TYPE DP)))) (NEED-VERSION (NEQ (PATHNAME-RAW-VERSION PATHNAME) (PATHNAME-RAW-VERSION DP))) (STRING  (SEND   (SEND PATHNAME :NEW-PATHNAME :DIRECTORY      (IF (EQUAL (PATHNAME-RAW-DIRECTORY PATHNAME) (PATHNAME-RAW-DIRECTORY DP)):UNSPECIFIC(IF (PATHNAME-RAW-DIRECTORY PATHNAME)  (PATHNAME-RAW-DIRECTORY PATHNAME)  :UNSPECIFIC))      (IF (EQUAL (PATHNAME-RAW-DEVICE PATHNAME) (PATHNAME-RAW-DEVICE DP)):DEVICE)      () (IF (EQ (PATHNAME-VERSION 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 (PATHNAME-HOST PATHNAME) DEFHOST)(STRING-LEFT-TRIM #\SPACE (SUBSTRING-AFTER-CHAR #\: STRING))STRING)      (IF (EQ (PATHNAME-HOST PATHNAME) DEFHOST)STRING(STRING-APPEND (SEND (PATHNAME-HOST PATHNAME) :NAME-AS-FILE-COMPUTER) ": " STRING)))))  ;;;;;; Replace get-list-of-directories with this simple verify, since get-.. never;;; returned anything significant anyways. 3.9.87(defun verify-list-of-directories (pathname)  (MULTIPLE-VALUE-BIND (GOOD WILD)      (SEND PATHNAME :PARSE-DIRECTORY-WILD-SPECS (SEND PATHNAME :DIRECTORY))    (unless WILD      (unless (eq (car good) :root);Root is Never WILD, but don't probe it.(unless (send pathname :PROBE-DIRECTORY);3.9.87 MBC  (ferror 'fs:directory-not-found "Directory not found"  pathname))))    (VALUES (LIST PATHNAME) NIL)));;;;(DEFUN GET-LIST-OF-DIRECTORIES-1 (PATHNAME);;;;  (MULTIPLE-VALUE-BIND (GOOD WILD);;;;      (SEND PATHNAME :PARSE-DIRECTORY-WILD-SPECS (SEND PATHNAME :DIRECTORY));;;;    (IF WILD;;;;(LET ((DLIST;;;;(APPLY #'DIRECTORY-LIST (SEND PATHNAME :NEW-PATHNAME :DIRECTORY GOOD) '(:NOERROR)));;;;      (RESULTS (QUOTE NIL)));;;;  (UNLESS (ERRORP DLIST);;;;    (OR;;;;      (DOLIST (DLIST-ENTRY (CDR DLIST));;;;(IF (GET DLIST-ENTRY :DIRECTORY);;;;    (LET* ((TARGET-PATHNAME;;;;     (SEND PATHNAME :NEW-PATHNAME :DIRECTORY;;;;   (IF (MEMBER GOOD '(NIL :ROOT) :TEST #'EQ);;;;       (CAR WILD);;;;       (APPEND (IF (CONSP GOOD);;;;   GOOD;;;;   (CONS GOOD ()));;;;       (CONS (CAR WILD) ())))));;;;   (SOURCE-PATHNAME (SEND (CAR DLIST-ENTRY) :PATHNAME-AS-DIRECTORY));;;;   (RESULT;;;;     (SEND TARGET-PATHNAME :TRANSLATE-WILD-PATHNAME TARGET-PATHNAME;;;;   SOURCE-PATHNAME)));;;;      (IF (ERRORP RESULT);;;;  (RETURN RESULT);;;;  (WHEN (SEND RESULT :PATHNAME-MATCH-NO-DEVICE SOURCE-PATHNAME ());;;;    (PUSH RESULT RESULTS))))));;;;      (VALUES (NREVERSE RESULTS) (CDR WILD)))));;;;(unless (eq (car good) :root);Root is Never WILD, but don't probe it!! 2.16.87;;;;  (unless;Don't pass back non-existant directories !!!   1.26.87 MBC;;;;    (multiple-value-bind (directory-pathname not-valid);;;;(send pathname :DIRECTORY-PATHNAME-AS-FILE);;;;      (if not-valid;;;;  T;no error check capability, so default to OK 2.27.87;;;;  (probe-file directory-pathname))));;;;  (ferror 'fs:directory-not-found "Directory ~a not found"  pathname));;;;(VALUES (LIST PATHNAME)NIL))))  ;;;;(DEFUN GET-LIST-OF-DIRECTORIES (PATHNAME);;;;  (LET (WORKING-LIST;;;;REMAINING-SPECS;;;;NEW-RESULTS;;;;MORE-RESULTS;;;;NEW-DIRECTORY);;;;    (MULTIPLE-VALUE-SETQ (WORKING-LIST REMAINING-SPECS);;;;      (GET-LIST-OF-DIRECTORIES-1 PATHNAME));;;;    (COND;;;;      ((SEND PATHNAME :COMPONENT-CONTAINS-WILD REMAINING-SPECS);;;;       (DOLIST (NEW-PATHNAME WORKING-LIST);;;; (SETQ NEW-DIRECTORY (SEND NEW-PATHNAME :DIRECTORY));;;; (WHEN (AND (ATOM NEW-DIRECTORY) REMAINING-SPECS);;;;   (SETQ NEW-DIRECTORY (CONS NEW-DIRECTORY ())));;;; (SETQ MORE-RESULTS;;;;       (GET-LIST-OF-DIRECTORIES;;;;(SEND NEW-PATHNAME :NEW-PATHNAME :DIRECTORY;;;;   (IF REMAINING-SPECS;;;;     (APPEND NEW-DIRECTORY REMAINING-SPECS);;;;     NEW-DIRECTORY))));;;; (WHEN MORE-RESULTS;;;;   (DOLIST (ONE-MORE MORE-RESULTS);;;;     (PUSH ONE-MORE NEW-RESULTS))));;;;       NEW-RESULTS);;;;      (T;;;;       (DOLIST (NEW-PATHNAME WORKING-LIST);;;; (SETQ NEW-DIRECTORY (SEND NEW-PATHNAME :DIRECTORY));;;; (WHEN (AND (ATOM NEW-DIRECTORY) REMAINING-SPECS);;;;   (SETQ NEW-DIRECTORY (CONS NEW-DIRECTORY ())));;;; (SETQ MORE-RESULTS;;;;       (SEND NEW-PATHNAME :NEW-PATHNAME :DIRECTORY;;;;  (IF REMAINING-SPECS;;;;    (APPEND NEW-DIRECTORY REMAINING-SPECS);;;;    NEW-DIRECTORY)));;;; (PUSH MORE-RESULTS NEW-RESULTS));;;;       NEW-RESULTS))))   ;;; By default, a directory is stored as a file in the superior directory whose name gives;;; the name of the component at this level.(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 pathname or string, or are defaulted.Return the file's truename if successful, NIL if file-not-found.Any other error condition is not handled."  (CONDITION-CASE (STREAM)     (SEND (MERGE-PATHNAME-DEFAULTS FILE) :OPEN-CANONICAL-TYPE CANONICAL-TYPE () :DIRECTION ())     (FILE-NOT-FOUND NIL) (:NO-ERROR (PROG1       (SEND STREAM :TRUENAME)       (CLOSE STREAM)))))(DEFUN INIT-FILE-PATHNAME (PROGRAM-NAME &OPTIONAL (HOST USER-LOGIN-MACHINE) FORCE-P)  "Return the 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."  (FUNCALL (USER-HOMEDIR HOST () USER-ID FORCE-P) :INIT-FILE (STRING PROGRAM-NAME)))(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)(DEFUN MAKE-PATHNAME (&REST OPTIONS &OPTIONAL &KEY (DEFAULTS T)  (HOST (IF (EQ DEFAULTS T)  (DEFAULT-HOST *DEFAULT-PATHNAME-DEFAULTS*)  (DEFAULT-HOST DEFAULTS)))  &ALLOW-OTHER-KEYS)  "Create a pathname, specifying components as keyword arguments.If DEFAULTS is a pathname or a defaults list, the pathname is defaulted from it.If DEFAULTS is T (the default), the host is defaulted from*DEFAULT-PATHNAME-DEFAULTS* and the other components are not defaulted at all."  (DECLARE (SPECIAL *DEFAULT-PATHNAME-DEFAULTS*))  (DECLARE   (ARGLIST &KEY &OPTIONAL (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-PATHNAME-DEFAULTS (APPLY (SAMPLE-PATHNAME HOST) :NEW-PATHNAME OPTIONS) DEFAULTS)    (APPLY (SAMPLE-PATHNAME HOST) :NEW-PATHNAME OPTIONS)));;;(DEFVAR HOST-SAMPLE-PATHNAMES () "Alist of host object vs a sample-pathname for that host.")  (DEFUN SAMPLE-PATHNAME (HOST)  "Return a pathname for HOST with all other components NIL."  (send (GET-PATHNAME-HOST HOST) :SAMPLE-PATHNAME));;; Creation of pathnames, low level.(DEFUN PATHNAME-HASH-EQUAL (KEY1 KEY2)  (MAPC    #'(LAMBDA (S1 S2)(WHEN (NOT (EQ (TYPE-OF S1) (TYPE-OF S2)))  (RETURN-FROM PATHNAME-HASH-EQUAL ()))(TYPECASE S1  (STRING (WHEN (NOT   (%STRING-EQUAL S1 0 S2 0 NIL); %string-equal is equivalent to this slower, Common-Lisp correct code below.  ;   (if  sys:alphabetic-case-affects-string-comparison; (string= s1 s2); (string-equal s1 s2))  )    (RETURN-FROM PATHNAME-HASH-EQUAL ())))  (CONS   (WHEN (OR (NOT (= (LENGTH S1) (LENGTH S2))) (NOT (PATHNAME-HASH-EQUAL S1 S2)))     (RETURN-FROM PATHNAME-HASH-EQUAL ())))  (OTHERWISE (WHEN (NOT (EQUAL S1 S2))       (RETURN-FROM PATHNAME-HASH-EQUAL ())))))    KEY1 KEY2)  T)(DEFVAR *PATHNAME-HASH-TABLE* :UNBOUND   "This is the EQUAL-hash-table used for uniquizing pathnames.")(add-initialization "Reset Pathname Print Names" '(maphash #'(lambda (key pathname)       (declare (ignore key))       (send pathname :send-if-handles :reset-print-names))   fs:*pathname-hash-table*)    :before-cold)(add-initialization "Reset Pathname Print Names" '(maphash #'(lambda (key pathname)       (declare (ignore key))       (send pathname :send-if-handles :reset-print-names))   fs:*pathname-hash-table*)    :full-gc);; -ab TGC;;(add-initialization "GC Pathname Area" '(si:clean-up-static-area fs:pathname-area) :full-gc);;(ADD-INITIALIZATION 'REHASH-PATHNAME-HASH-TABLE '(GETHASH () *PATHNAME-HASH-TABLE*);;    '(AFTER-FULL-GC))  ;; The pathname hash table, pathnames, and cached strings are stored here to improve locality.;; Individual :STRING-FOR-mumble methods can save a string copy by explicitly;; consing the string in PATHNAME-AREA, but this is not necessary.;;;;; Move ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON out 1 level, add FLAVOR-NAME to the hash KEY,;;; and don't copy PATHNAME's :PLIST to the result of APPLY.  11.17.86 MBC for BJ(DEFUN MAKE-PATHNAME-INTERNAL (QUOTED-STRING &REST KEY)  "Create a pathname from components specified positionally, with no defaulting. All components are raw."    (DECLARE (ARGLIST QUOTED-STRING HOST DEVICE DIRECTORY NAME TYPE VERSION)   (VALUES PATHNAME FOUND-IN-HASH-TABLE-P))    (LET* ((HOST-OBJECT (FIRST KEY)) (HOST-NAME (SEND HOST-OBJECT :FULLY-QUALIFIED-NAME)) (ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON (SEND HOST-OBJECT :CASE-SENSITIVE-WHEN-HASHING)) PATHNAME FLAVOR-NAME OPTIONS)        ;; Right now there is now way to pass back options. Do we need them? *BJ*    (MULTIPLE-VALUE-SETQ (FLAVOR-NAME OPTIONS) (SEND HOST-OBJECT :PATHNAME-FLAVOR))        ;; Hash hosts on the string name instead of the host object.    (SETF (FIRST KEY) HOST-NAME)        ;; Hash on pathname-flavor also to distinguish between system types.    (push flavor-name key)        (SETQ PATHNAME (GETHASH KEY *PATHNAME-HASH-TABLE*))         (if pathname;1.22.87 MBC;THIS should only happen for vms pathnames;If the same pathname is parsed with a new;quoted string and its different from the old(LET ((OLD-QUOTED-STRING (SEND PATHNAME :RAW-QUOTED-STRING)))  (WHEN (NOT (STRING= QUOTED-STRING OLD-QUOTED-STRING));always NIL NIL for other than VMS?    (SETQ QUOTED-STRING (COPY-INTO-PATHNAME-AREA QUOTED-STRING));NOT ALL PATHNAMES    (SEND PATHNAME :SEND-IF-HANDLES :SET-QUOTED-STRING QUOTED-STRING));HANDLE THIS!!!!  (VALUES PATHNAME T))(SETQ key (COPY-INTO-PATHNAME-AREA key)      QUOTED-STRING (COPY-INTO-PATHNAME-AREA QUOTED-STRING))(SETQ PATHNAME      (APPLY #'MAKE-PATHNAME-INSTANCE FLAVOR-NAME     :HOST HOST-OBJECT     :DEVICE (third key)     :DIRECTORY (fourth key)     :NAME (fifth key)     :TYPE (sixth key)     :VERSION (nth 6 key)     :QUOTED-STRING QUOTED-STRING     OPTIONS))(PUTHASH key PATHNAME *PATHNAME-HASH-TABLE*)(VALUES PATHNAME ()))));;;(DEFUN MAKE-PATHNAME-INTERNAL (QUOTED-STRING &REST KEY);;;  "Create a pathname from components specified positionally, with no defaulting. All components are raw."  ;;;  (DECLARE (ARGLIST HOST DEVICE DIRECTORY NAME TYPE VERSION);;;   (VALUES PATHNAME FOUND-IN-HASH-TABLE-P))  ;;;  (LET* ((HOST-OBJECT (FIRST KEY));;; (HOST-NAME (SEND HOST-OBJECT :FULLY-QUALIFIED-NAME));;; (CASE-SENSITIVE (SEND HOST-OBJECT :CASE-SENSITIVE-WHEN-HASHING));;; PATHNAME;;; FLAVOR-NAME;;; OPTIONS);;;    (MULTIPLE-VALUE-SETQ (FLAVOR-NAME OPTIONS) (SEND HOST-OBJECT :PATHNAME-FLAVOR));;;    ;; Hash hosts on the string name instead of the host object.;;;    (SETF (FIRST KEY) HOST-NAME)    ;;;    (LET ((ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON CASE-SENSITIVE));;;      (SETQ PATHNAME (GETHASH KEY *PATHNAME-HASH-TABLE*)))    ;;;    (IF (AND PATHNAME;;;     (EQ (TYPE-OF PATHNAME) FLAVOR-NAME);;;     (NOT (GET (TYPE-OF PATHNAME) 'PATHNAME-FLAVOR-CHANGES)));;;(VALUES PATHNAME T);;;(LET ((OPATHNAME PATHNAME));;;  (SETQ KEY (COPY-INTO-PATHNAME-AREA KEY);;;QUOTED-STRING (COPY-INTO-PATHNAME-AREA QUOTED-STRING))  ;;;  (SETQ PATHNAME;;;(APPLY #'MAKE-PATHNAME-INSTANCE FLAVOR-NAME;;;       :HOST HOST-OBJECT;;;       :DEVICE (SECOND KEY);;;       :DIRECTORY (THIRD KEY);;;       :NAME (FOURTH KEY);;;       :TYPE (FIFTH KEY);;;       :VERSION (SIXTH KEY);;;       :QUOTED-STRING QUOTED-STRING;;;       OPTIONS))  ;;;  (IF OPATHNAME;;;      (FUNCALL PATHNAME :SETPLIST (FUNCALL OPATHNAME :PLIST)))  ;;;  (LET ((ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON CASE-SENSITIVE));;;    (PUTHASH KEY PATHNAME *PATHNAME-HASH-TABLE*))  ;;;  (VALUES PATHNAME ())))))  END of 11.17.86 MBC for BJ;; -ab TGC(DEFVAR PATHNAME-AREA (MAKE-AREA :NAME 'PATHNAME-AREA :GC :dynamic))  (DEFUN COPY-INTO-PATHNAME-AREA (OBJ)  "Return a copy of OBJ in PATHNAME-AREA.All levels of lists and string in OBJ are copiedunless they are already in PATHNAME-AREA."  (IF (OR (FIXNUMP OBJ) (= (%AREA-NUMBER OBJ) PATHNAME-AREA))    OBJ    (COND      ((CONSP OBJ) (SETQ OBJ (COPY-LIST OBJ PATHNAME-AREA))       (DO ((O OBJ (CDR O)))   (NIL) (SETF (CAR O) (COPY-INTO-PATHNAME-AREA (CAR O))) (COND   ((ATOM (CDR O)) (AND (CDR O) (SETF (CDR O) (COPY-INTO-PATHNAME-AREA (CDR O))))    (RETURN OBJ)))))      ((STRINGP OBJ) (LET ((DEFAULT-CONS-AREA PATHNAME-AREA))       (STRING-APPEND OBJ)))      (T OBJ))))(DEFUN MAKE-FASLOAD-PATHNAME (HOST DEVICE DIRECTORY NAME TYPE VERSION &AUX PATH-HOST PATH) ;; Don't bomb out if the file computer that compiled this file doesn't exist any more. ;; Just take the one the file is being loaded from.  (AND (SETQ PATH-HOST (GET-PATHNAME-HOST HOST T)) (SETQ HOST PATH-HOST))  (OR PATH-HOST     (SETQ PATH-HOST   (IF FDEFINE-FILE-PATHNAME     (PATHNAME-HOST FDEFINE-FILE-PATHNAME)     USER-LOGIN-MACHINE)))  (SETQ PATH (MAKE-PATHNAME-INTERNAL () PATH-HOST DEVICE DIRECTORY NAME TYPE VERSION))  ;; Record the actual host for possible debugging.  (AND (NEQ HOST PATH-HOST) (FUNCALL PATH :PUTPROP HOST :FASLOAD-HOST))  PATH);;; Comparison of pathnames.(DEFUN PATHNAME-EQUAL (PATHNAME1 PATHNAME2)  "T if the two pathnames match by components.The same as EQ for most flavors of pathname, but not for all.In this normal case, we must swap in the first arg but not the second."  (SEND PATHNAME1 :EQUAL PATHNAME2))  (DEFUN PATHNAME-LESSP (PATHNAME-1 PATHNAME-2)  "Standard comparison of pathnames, for sorting directory listings."  (FUNCALL PATHNAME-1 :SORT-LESSP PATHNAME-2))  ;Redefine this if your standard components and raw ones;fail to match in a way that affects sorting (not just case)(DEFUN DEFAULT-HOST (DEFAULTS &AUX ELEM)  "Return the default host to use from defaults-list or pathname DEFAULTS."  (DECLARE (SPECIAL *DEFAULT-PATHNAME-DEFAULTS*))  (OR DEFAULTS (SETQ DEFAULTS *DEFAULT-PATHNAME-DEFAULTS*))  (COND    ((AND DEFAULTS (ATOM DEFAULTS))     (PATHNAME-RAW-HOST (IF (TYPEP DEFAULTS 'PATHNAME)  DEFAULTS  (PARSE-PATHNAME DEFAULTS))))    (T     (SETQ ELEM   (COND     ((NOT *DEFAULTS-ARE-PER-HOST*) (ASSOC () DEFAULTS :TEST #'EQ))     (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 (ASSOC USER-LOGIN-MACHINE DEFAULTS :TEST #'EQ) (CONS USER-LOGIN-MACHINE ()))))     ;; If there isn't one already, build a pathname from the host of this one     (OR (CAR ELEM) (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-PATHNAME (&OPTIONAL DEFAULTS HOST DEFAULT-TYPE DEFAULT-VERSION INTERNAL-P &AUX ELEM PATHNAME HOST-TO-USE CTYPE OTYPE)  (AND HOST (SETQ HOST (GET-PATHNAME-HOST HOST)))  (OR DEFAULTS (SETQ DEFAULTS *DEFAULT-PATHNAME-DEFAULTS*))  (COND    ((AND DEFAULTS (not (LISTP DEFAULTS)));MBC 7-31-86     (SETQ PATHNAME (IF (TYPEP DEFAULTS 'PATHNAME)DEFAULTS(PARSE-PATHNAME DEFAULTS))))    (T     (SETQ ELEM   (COND     ((NOT *DEFAULTS-ARE-PER-HOST*) (ASSOC () DEFAULTS :TEST #'EQ))     (HOST (ASSOC HOST DEFAULTS :TEST #'EQ))     (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 (ASSOC USER-LOGIN-MACHINE DEFAULTS :TEST #'EQ) (CONS USER-LOGIN-MACHINE ()))))     ;; If there isn't one already, build a pathname from the host of this one     (SETQ HOST-TO-USE (OR HOST (CAR ELEM) (PATHNAME-HOST (CDR ELEM))))     (COND       ((SETQ PATHNAME (CDR ELEM)))       (INTERNAL-P (SETQ PATHNAME (MAKE-PATHNAME-INTERNAL () HOST-TO-USE () () () () ())))       (T(SETQ PATHNAME      (SEND (USER-HOMEDIR HOST-TO-USE) :NEW-PATHNAME    :NAME "FOO"    :TYPE *NAME-SPECIFIED-DEFAULT-TYPE*    :VERSION :NEWEST))(SETF (CDR ELEM) PATHNAME)))))  ;; If default-type or default-version was given, or the host has changed,  ;; merge those in.  (AND    (OR (AND HOST (NEQ HOST (PATHNAME-HOST PATHNAME)))DEFAULT-TYPEDEFAULT-VERSION)    (SETQ HOST (OR HOST (PATHNAME-HOST PATHNAME)))    (IF INTERNAL-P(AND HOST (SETQ PATHNAME (MAKE-PATHNAME-INTERNAL () HOST () () () () ())))(PROGN  (SETF (VALUES CTYPE OTYPE) (SEND PATHNAME :CANONICAL-TYPE))  (SETQ PATHNAME(SEND (MAKE-PATHNAME :HOST HOST     :DEFAULTS ())      :NEW-PATHNAME      :DIRECTORY (PATHNAME-DIRECTORY PATHNAME)      :DEVICE (PATHNAME-DEVICE PATHNAME)      :HOST (OR HOST (PATHNAME-HOST PATHNAME))      :NAME (PATHNAME-NAME PATHNAME)      :CANONICAL-TYPE (OR DEFAULT-TYPE CTYPE OTYPE)      :VERSION (OR DEFAULT-VERSION (PATHNAME-VERSION PATHNAME)))))))  PATHNAME)   (DEFUN PARSE-NAMESTRING (THING &OPTIONAL WITH-RESPECT-TO (DEFAULTS *DEFAULT-PATHNAME-DEFAULTS*) &KEY (START 0.) END  JUNK-ALLOWED)  "Parse THING into a pathname and return it.The same as FS:PARSE-PATHNAME except that that function's args are all positional."  (DECLARE (SPECIAL *DEFAULT-PATHNAME-DEFAULTS*))  (PARSE-PATHNAME THING WITH-RESPECT-TO DEFAULTS START END JUNK-ALLOWED));;; Revised PARSE-PATHNAME & PARSE-PATHNAME-FIND-COLON by MBC 1.28.87;;; ;;; 1. When WITH-RESPECT-TO and host in THING are not equal ---> we ferror;;; 2. Unless WITH-RESPECT-TO always do get-pathname-host with error signalling enabled.;;;Wins by useing host proceed options.  This allows recovery of unknown domain.;;; 3. Fix (one of the) Condition binds to be a Condition-Bind-If to avoid dirty;;;catch and re-signal of Pathname-Parse-Error.;;;(DEFUN PARSE-PATHNAME-FIND-COLON (STRING &OPTIONAL (ORIGINAL-START 0.) END NO-ERROR  &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 (SUBSEQ STRING HOST-START IDX) START (1+ IDX)) (RETURN))  ((AND (= CHAR #\SPACE) ONLY-WHITESPACE-P);Skip leading spaces   (SETQ HOST-START (1+ IDX)))  (T (SETQ ONLY-WHITESPACE-P ()))))  (AND (NULL HOST-SPECIFIED) (PLUSP END) (= (AREF STRING (1- END)) #\:)       (SETQ HOST-SPECIFIED     (POSITION #\SPACE (THE STRING (STRING STRING)) :FROM-END T :END (1- END) :TEST       #'CHAR-EQUAL))       ;; 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 (SUBSEQ 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 pathname.  (AND (EQUAL HOST-SPECIFIED "") (SETQ HOST-SPECIFIED ()))  ;; If what looked like the host really wasn't, forget it and reset the indices  (AND HOST-SPECIFIED (NULL (SETQ HOST-SPECIFIED (GET-PATHNAME-HOST HOST-SPECIFIED no-error)));MBC 1.28.87       (SETQ START ORIGINAL-START END ()))  (VALUES HOST-SPECIFIED START END))(DEFUN PARSE-PATHNAME (THING &OPTIONAL       WITH-RESPECT-TO (DEFAULTS *DEFAULT-PATHNAME-DEFAULTS*) (START 0.) END JUNK-ALLOWED)  "Parse THING into a pathname and return it.THING can be a 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 pathname is parsed for that host and it is an error if the 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 (SPECIAL *DEFAULT-PATHNAME-DEFAULTS*))  (DECLARE (VALUES PARSED-PATHNAME PARSE-END-INDEX))  (WHEN (STREAMP THING)    (SETQ THING (SEND THING :PATHNAME)))  (WHEN (STREAMP DEFAULTS)    (SETQ DEFAULTS (SEND DEFAULTS :PATHNAME)))  (AND WITH-RESPECT-TO (SETQ WITH-RESPECT-TO (GET-PATHNAME-HOST WITH-RESPECT-TO)))  (CONDITION-RESUME   '((PATHNAME-ERROR) :NEW-PATHNAME T ("Proceed, supplying a new pathname.")     PARSE-PATHNAME-THROW-NEW-PATHNAME)   (LET (host-specified (PARSE-PATHNAME-FLAG JUNK-ALLOWED))     (CATCH-CONTINUATION 'PARSE-PATHNAME#'(LAMBDA (INDEX-OR-PATHNAME)    (IF (NUMBERP INDEX-OR-PATHNAME)      (VALUES () (MIN (OR END (LENGTH THING)) INDEX-OR-PATHNAME))      (VALUES INDEX-OR-PATHNAME START)))()(COND  ((TYPEP THING 'PATHNAME)   (AND WITH-RESPECT-TO (NEQ WITH-RESPECT-TO (PATHNAME-HOST THING))      (IF PARSE-PATHNAME-FLAG(VALUES () 0.)(FERROR 'PATHNAME-PARSE-ERROR "Host ~A in ~A does not match ~A"(PATHNAME-HOST THING) THING WITH-RESPECT-TO)))   (VALUES THING START))  ((CONSP THING) (SETQ THING (CANONICALIZE-KLUDGEY-MACLISP-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-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)(IF PARSE-PATHNAME-FLAG  (VALUES () 0.)  (FERROR 'PATHNAME-PARSE-ERROR "Host ~A in ~A does not match ~A" HOST THING  WITH-RESPECT-TO)))     (VALUES      (MAKE-PATHNAME :HOST HOST :DEVICE DEVICE :DIRECTORY DIRECTORY :NAME NAME :TYPE     TYPE :VERSION VERSION)      START)))  ((AND (FBOUNDP 'MAGTAPE-FILEHANDLE); We've  got to make sure the mt: package exists      (MAGTAPE-FILEHANDLE THING)) THING);       else we die during builds.  (T (SETQ THING (STRING THING))     (if with-respect-to (progn;look w/o errors   (MULTIPLE-VALUE-setq (HOST-SPECIFIED START END)     (PARSE-PATHNAME-FIND-COLON THING START END T));MBC 1.28.87   (if (AND HOST-SPECIFIED    (NEQ WITH-RESPECT-TO HOST-SPECIFIED))       (FERROR 'PATHNAME-PARSE-ERROR "Host ~A in ~A does not match ~A"(PATHNAME-HOST THING) THING WITH-RESPECT-TO))) (MULTIPLE-VALUE-setq (HOST-SPECIFIED START END)   (PARSE-PATHNAME-FIND-COLON THING START END NIL)));MBC 1.28.87       ;; If the thing before the colon is really a host,       ;; and WITH-RESPECT-TO was specified, then they had better match              (LET* ((HOST(COND  ((GET-PATHNAME-HOST HOST-SPECIFIED T))  (WITH-RESPECT-TO)  ((TYPEP DEFAULTS 'SI:BASIC-HOST) DEFAULTS)  (T (DEFAULT-HOST DEFAULTS))))) (CONDITION-CASE-if;New handler - MBC 1.28.87   parse-pathname-flag;cond form   (ERROR-OBJECT);variables;body     (MULTIPLE-VALUE-BIND (DEVICE DIRECTORY NAME TYPE VERSION PARSE-END QUOTED-STRING)       (FUNCALL (SAMPLE-PATHNAME HOST) :PARSE-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-PATHNAME-INTERNAL QUOTED-STRING HOST DEVICE DIRECTORY NAME TYPE  VERSION)))       PARSE-END))      (PATHNAME-PARSE-ERROR;clause      (IF (ZEROP (SEND ERROR-OBJECT :PARSE-END-INDEX))  (VALUES () 0.)  (IF (NULL (SEND ERROR-OBJECT :PARSE-END-INDEX))      (signal ERROR-OBJECT)      (MULTIPLE-VALUE-BIND (DEVICE DIRECTORY NAME TYPE VERSION PARSE-END QUOTED-STRING)  (FUNCALL (SAMPLE-PATHNAME HOST) :PARSE-NAMESTRING   (NOT (NULL HOST-SPECIFIED)) THING START   (SEND ERROR-OBJECT :PARSE-END-INDEX))(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-PATHNAME-INTERNAL QUOTED-STRING HOST DEVICE DIRECTORY NAME     TYPE VERSION)))  PARSE-END)))))))))))))(DEFUN PARSE-PATHNAME-THROW-NEW-PATHNAME (IGNORE PATHNAME)  (THROW 'PARSE-PATHNAME PATHNAME))(DEFUN CANONICALIZE-KLUDGEY-MACLISP-PATHNAME-STRING-LIST (X)  (COND    ((OR (NULL X) (NUMBERP X)) X)    ((CONSP X) (MAPCAR #'CANONICALIZE-KLUDGEY-MACLISP-PATHNAME-STRING-LIST X))    (T (STRING X))));;; Returns an alist that you can pass to the functions below that take a set of defaults.;(DEFUN MAKE-PATHNAME-DEFAULTS (&AUX LIST);  "Create an empty defaults-list for use with MERGE-PATHNAME-DEFAULTS.";  (SETQ LIST (MAKE-LIST (1+ (LENGTH *PATHNAME-HOST-LIST*))));  (DO ((L2 LIST (CDR L2));       (L1 *PATHNAME-HOST-LIST* (CDR L1)));      ((NULL L2));    (SETF (CAR L2) (CONS (CAR L1) ())));  LIST);; Return AN EMPTY ALIST. *BJ*(DEFUN MAKE-PATHNAME-DEFAULTS ()  "Create an empty defaults-list for use with MERGE-PATHNAME-DEFAULTS."  (list (LIST nil)))(DEFUN COPY-PATHNAME-DEFAULTS (DEFAULTS)  "Copy a defaults-list, returning a new defaults-list."  (COPY-ALIST DEFAULTS))(DEFUN SET-DEFAULT-PATHNAME (PATHNAME &OPTIONAL DEFAULTS &AUX ELEM)  "Alter the defaults in the defaults-list DEFAULTS from PATHNAME.DEFAULTS defaults to *DEFAULT-PATHNAME-DEFAULTS*."  (DECLARE (SPECIAL *DEFAULT-PATHNAME-DEFAULTS*))  (SETQ DEFAULTS (OR DEFAULTS *DEFAULT-PATHNAME-DEFAULTS*))  (SETQ PATHNAME (PARSE-PATHNAME PATHNAME () DEFAULTS))  (OR (SETQ ELEM (ASSOC (PATHNAME-HOST PATHNAME) DEFAULTS :TEST #'EQ))     (SETQ ELEM (CONS (PATHNAME-HOST PATHNAME) ())))  (SETF (CDR ELEM) PATHNAME)  (PULL ELEM DEFAULTS);This is the default host  (AND (NOT *DEFAULTS-ARE-PER-HOST*) (SETQ ELEM (ASSOC () DEFAULTS :TEST #'EQ))     (SETF (CDR ELEM) PATHNAME))  PATHNAME)  ;;; Move ITEM to the front of LIST destructively(DEFUN PULL (ITEM LIST)  (DO ((LS LIST (CDR LS))       (IT ITEM))      ((NULL LS)       (SETQ LIST (NCONC LIST (CONS 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 pathname defaulting.(DEFPARAMETER *ALWAYS-MERGE-TYPE-AND-VERSION* ()   "T means that merging pathnames should use the default type or versionif the specified pathname does not contain oneeven if the specified pathname does contain a name component.")  (DEFPARAMETER *NAME-SPECIFIED-DEFAULT-TYPE* :LISP   "This is the default type component to use in MERGE-PATHNAME-DEFAULTSif the specified pathname contains a name but no type.")  ;Setting a working directory specifies what device and directory "DSK" should mean.(DEFVAR HOST-WORKING-DIRECTORY-ALIST ()   "Alist of elements (host-object working-directory-pathname).")  (DEFUN SET-HOST-WORKING-DIRECTORY (HOST PATHNAME)  "Set the working device/directory for HOST to that in PATHNAME.When a pathname containing device component DSK is defaulted,its device is replaced by the working device, and its directorydefaulted (if not explicitly specified) to the working directory."  (LET* ((HOST1 (GET-PATHNAME-HOST HOST)) (DIR (PARSE-PATHNAME PATHNAME HOST1)) (ELT  (OR (ASSOC HOST1 HOST-WORKING-DIRECTORY-ALIST :TEST #'EQ)     (CAR (PUSH (LIST HOST1 ()) HOST-WORKING-DIRECTORY-ALIST)))))    (SETF (SECOND ELT) DIR)))  (DEFUN MERGE-PATHNAMES (PATHNAME &OPTIONAL DEFAULTS (DEFAULT-VERSION :NEWEST))  "Default components that are NIL in PATHNAME, and return the defaulted pathname.DEFAULTS is a pathname or a defaults-list to get defaults from.DEFAULT-VERSION is used as the default for the version componentiff a name was specified in PATHNAME and FS:*ALWAYS-MERGE-TYPE-AND-VERSION* is NIL."  (MERGE-PATHNAME-DEFAULTS PATHNAME DEFAULTS () DEFAULT-VERSION T))  ;;; Fill in slots in PATHNAME from program defaults.  This is what most;;; programs interface to.(DEFUN MERGE-PATHNAME-DEFAULTS (PATHNAME &OPTIONAL DEFAULTS (DEFAULT-TYPE *NAME-SPECIFIED-DEFAULT-TYPE*)(DEFAULT-VERSION :NEWEST) ALWAYS-MERGE-TYPE &AUX HOST DEFAULT SECONDARY-DEFAULTNEW-DEVICE NEW-DIRECTORY NEW-NAME NEW-TYPE NEW-VERSION NEW-OTYPE)  "Default components that are NIL in PATHNAME, and return the defaulted pathname.DEFAULTS is a pathname or a defaults-list to get defaults from.DEFAULT-TYPE and DEFAULT-VERSION are used as the defaults forthe type and version components, iff a name was specifiedand 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 componentto be merged like the name, directory, etc. but has no effect on the version."  (DECLARE (SPECIAL *DEFAULT-PATHNAME-DEFAULTS*))  (WHEN (STREAMP PATHNAME)    (SETQ PATHNAME (SEND PATHNAME :PATHNAME)))  (WHEN (STREAMP DEFAULTS)    (SETQ DEFAULTS (SEND DEFAULTS :PATHNAME)))  (SETQ PATHNAME (PARSE-PATHNAME PATHNAME () DEFAULTS))  (IF (NULL DEFAULTS)      (SETQ DEFAULTS *DEFAULT-PATHNAME-DEFAULTS*))  (COND    ((NOT (TYPEP PATHNAME 'PATHNAME)) PATHNAME);Some funny thing.  No defaulting possible.    (T     ;; Host always comes from pathname     (SETQ HOST (PATHNAME-HOST PATHNAME))     ;; Setup default pathnames.  If a 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-PATHNAME DEFAULTS () PATHNAME)       DEFAULTS *DEFAULT-PATHNAME-DEFAULTS*       SECONDARY-DEFAULT (DEFAULT-PATHNAME DEFAULTS HOST)) (SETQ DEFAULT (DEFAULT-PATHNAME DEFAULTS HOST)       SECONDARY-DEFAULT ()))     (unless default-type;caller passed in NIL, but we'll override!!       (if (or ALWAYS-MERGE-TYPE *ALWAYS-MERGE-TYPE-AND-VERSION*);2.11.87 MBC   (setf default-type *NAME-SPECIFIED-DEFAULT-TYPE*)))     ;; Device name DSK means the working directory and associated device if any.     (COND       ((EQUAL (PATHNAME-DEVICE PATHNAME) "DSK")(LET ((WDIR(OR (CADR (ASSOC HOST HOST-WORKING-DIRECTORY-ALIST :TEST #'EQ))    (USER-HOMEDIR HOST))))  (SETQ NEW-DEVICE (OR (FUNCALL WDIR :DEVICE) (FUNCALL HOST :PRIMARY-DEVICE)))  (IF (AND (NULL (PATHNAME-DIRECTORY PATHNAME))   ;; Don't do this when explicit directory supplied.   (NULL (PATHNAME-DIRECTORY DEFAULT))   (OR (NULL SECONDARY-DEFAULT) (NULL (PATHNAME-DIRECTORY SECONDARY-DEFAULT))))      (SETQ NEW-DIRECTORY (FUNCALL WDIR :DIRECTORY))))))     ;; Merge the device, directory, and name     (IF (NULL (PATHNAME-DEVICE PATHNAME)) (SETQ NEW-DEVICE       (OR (PATHNAME-DEVICE DEFAULT)   (AND (NOT (NULL SECONDARY-DEFAULT)) (PATHNAME-DEVICE SECONDARY-DEFAULT))   (SEND PATHNAME :PRIMARY-DEVICE))))     (UNLESS NEW-DIRECTORY       (LET ((PDIR (PATHNAME-DIRECTORY PATHNAME))     (DDIR       (OR (PATHNAME-DIRECTORY DEFAULT)   (AND (NOT (NULL SECONDARY-DEFAULT)) (PATHNAME-DIRECTORY SECONDARY-DEFAULT))))) (COND   ((NULL PDIR) (SETQ NEW-DIRECTORY DDIR))   ((AND (CONSP PDIR) (EQ (CAR PDIR) :RELATIVE))    (SETQ NEW-DIRECTORY (MERGE-RELATIVE-DIRECTORY PDIR DDIR))))))     (IF (NULL (PATHNAME-NAME PATHNAME)) (SETQ NEW-NAME       (OR (PATHNAME-NAME DEFAULT)   (AND (NOT (NULL SECONDARY-DEFAULT)) (PATHNAME-NAME SECONDARY-DEFAULT))   ;; Never let the name of the resulting 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 (PATHNAME-TYPE PATHNAME)) (IF (OR (NULL (PATHNAME-NAME PATHNAME)) ALWAYS-MERGE-TYPE *ALWAYS-MERGE-TYPE-AND-VERSION*)     (PROGN       (SETF (VALUES NEW-TYPE NEW-OTYPE) (SEND DEFAULT :CANONICAL-TYPE))       (UNLESS NEW-TYPE;Don't treat :UNSPECIFIC special.  2.16.87 MBC (SETQ NEW-TYPE       (OR (AND (NOT (NULL SECONDARY-DEFAULT)) (PATHNAME-TYPE SECONDARY-DEFAULT))   ;; Never let the type of the resulting pathname be NIL.   DEFAULT-TYPE))))     (SETQ NEW-TYPE DEFAULT-TYPE)))          (when (NULL (PATHNAME-VERSION PATHNAME))       (IF (OR (NULL (PATHNAME-NAME PATHNAME)) *ALWAYS-MERGE-TYPE-AND-VERSION*)   (SETQ NEW-VERSION (OR (PATHNAME-VERSION DEFAULT)     (AND (NOT (NULL SECONDARY-DEFAULT)) (PATHNAME-VERSION SECONDARY-DEFAULT))     ;; Never let the version of the resulting pathname be NIL.     DEFAULT-VERSION))   (SETQ NEW-VERSION DEFAULT-VERSION)))     (SEND PATHNAME   :NEW-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) (CONS DEFAULT ()))  (T (COPY-LIST DEFAULT))))  (DOLIST (REL (CDR RELATIVE))    (IF (EQ REL :UP)      (IF (NULL DIRECTORY)(FERROR 'PATHNAME-PARSE-ERROR "There is no superior to the root")(DO ((L DIRECTORY (CDR L))     (OL (LOCF DIRECTORY) L))    ((NULL (CDR L))     (RPLACD OL ()))))      (SETQ DIRECTORY (NCONC DIRECTORY (CONS REL ())))))  DIRECTORY)  ;;; Another handy user interface, fills in from defaults and updates them.  Useful when;;; not prompting.(DEFUN MERGE-AND-SET-PATHNAME-DEFAULTS (PATHNAME &OPTIONAL (DEFAULTS *DEFAULT-PATHNAME-DEFAULTS*)   (DEFAULT-TYPE *NAME-SPECIFIED-DEFAULT-TYPE*) (DEFAULT-VERSION :NEWEST))  "Default PATHNAME like MERGE-PATHNAME-DEFAULTS, but then set the defaults.If DEFAULTS is a defaults-list (rather than a pathname), the specifiedpathname sets the defaults."  (DECLARE (SPECIAL *DEFAULT-PATHNAME-DEFAULTS*))  (SETQ PATHNAME (MERGE-PATHNAME-DEFAULTS PATHNAME DEFAULTS DEFAULT-TYPE DEFAULT-VERSION))  (AND (CONSP DEFAULTS) (SET-DEFAULT-PATHNAME PATHNAME DEFAULTS))  PATHNAME)  (DEFF DESCRIBE-PHYSICAL-HOST #'SI::DESCRIBE-HOST)  ;; -ab TGC;; Pathname system initialization(DEFUN PATHNAME-INITIALIZE ()  (DECLARE (SPECIAL *DEFAULT-PATHNAME-DEFAULTS*))  (SETQ *PATHNAME-HASH-TABLE*(MAKE-HASH-TABLE :COMPARE-FUNCTION 'PATHNAME-HASH-EQUAL :HASH-FUNCTION 'SI::EQUAL-HASH :SIZE 12000. :REHASH-SIZE 6000. :REHASH-THRESHOLD 0.8 :AREA PATHNAME-AREA))  (SETQ *DEFAULT-PATHNAME-DEFAULTS* (MAKE-PATHNAME-DEFAULTS))  (SETQ LOAD-PATHNAME-DEFAULTS (MAKE-PATHNAME-DEFAULTS)))(ADD-INITIALIZATION "PATHNAME-INITIALIZE" '(PATHNAME-INITIALIZE) '(ONCE))(DEFUN LINEARIZE-PATHNAME-PLISTS ()  (MAPHASH       #'(LAMBDA (IGNORE FILE &REST IGNORE)   (SEND FILE :SET-PROPERTY-LIST (COPY-TREE (SEND FILE :PLIST))))       *PATHNAME-HASH-TABLE*));;(DEFUN LINEARIZE-PATHNAME-PLISTS ();;  (IF 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)));;     *PATHNAME-HASH-TABLE*);;    (PROGN;;      (SETQ PATHNAME-PLISTS-LINEARIZED-ONCE T);;      (MAPHASH;;       #'(LAMBDA (IGNORE FILE &REST IGNORE);;   (SEND FILE :SET-PROPERTY-LIST (COPY-TREE (SEND FILE :PLIST))));;       *PATHNAME-HASH-TABLE*))));;(DEFVAR PATHNAME-PLISTS-LINEARIZED-ONCE ());;(DEFUN REFERENCE-ALL (OBJECT);;  (UNLESS (ATOM OBJECT);;    (DO ((TAIL OBJECT (CDR TAIL)));;((ATOM TAIL));;      (UNLESS (ATOM (CAR TAIL));;(REFERENCE-ALL (CAR TAIL))))))  (ADD-INITIALIZATION "Pathname plists" '(LINEARIZE-PATHNAME-PLISTS) '(FULL-GC))  ;; end -ab TGCvalue :other)      (setf value nil)))  (list (format nil "~s" value) value))))    (when initial-value      (setf initial-value-string (format nil "~s" initial-value)))    (setf return-value  (completing-read-from-mini-buffer    prompt value-list ok-to-give-new-value-p initial-value-string))    (cond ((name:key-compare initial-value-string return-value)   (setf return-value initial-value))  ((and (listp return-value)(member return-value value-list :test 'name:key-compare))   (setf return-value (second return-value)))  ((name:key-compare return-value "nil")   (setf return-value nil))  ((name:key-compare return-value "")   (se