(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)

(FILECREATED "25-Oct-91 16:21:24" {DSK}<usr>local>lde>lispcore>sources>CMLPATHNAME.;3
 56939  

      changes to%:  (FNS %%PRINT-PATHNAME %%PRINT-LP)

      previous date%: " 3-Sep-91 15:54:13" {DSK}<usr>local>lde>lispcore>sources>CMLPATHNAME.;2)


(* ; "
Copyright (c) 1986, 1987, 1988, 1990, 1991 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT CMLPATHNAMECOMS)

(RPAQQ CMLPATHNAMECOMS ((* ;; "Common Lisp pathname functions") (PROP FILETYPE CMLPATHNAME) (COMS (* ;; "useful macros") (FUNCTIONS %%MAKE-LP %%MERGE-DIRECTORY-LISTS %%WILD-NAME %%COMPONENT-STRING %%UNPACKFILE1)) (STRUCTURES PATHNAME DIRECTORY-COMPONENT CL:LOGICAL-PATHNAME) (DECLARE%: DONTCOPY EVAL@COMPILE (RECORDS PATHNAMECASE)) (FNS %%PARSE-DIRECTORY-PATH %%PRINT-LP %%PRINT-PATHNAME CL:MAKE-PATHNAME %%PRINT-DIRECTORY-COMPONENT) (FUNCTIONS CL:PATHNAME-HOST CL:PATHNAME-DEVICE CL:PATHNAME-DIRECTORY CL:PATHNAME-NAME CL:PATHNAME-TYPE CL:PATHNAME-VERSION) (FNS PATHNAME CL:MERGE-PATHNAMES FILE-NAME CL:HOST-NAMESTRING CL:ENOUGH-NAMESTRING %%NUMERIC-STRING-P) (FUNCTIONS CL:NAMESTRING CL:PARSE-NAMESTRING PARSE-NAMESTRING1 CL:TRUENAME) (FUNCTIONS %%MAKE-PATHNAME) (FUNCTIONS %%PATHNAME-EQUAL %%DIRECTORY-COMPONENT-EQUAL) (FUNCTIONS %%INITIALIZE-DEFAULT-PATHNAME) (VARIABLES *DEFAULT-PATHNAME-DEFAULTS* CL::*LOGICAL-PATHNAME-TRANSLATION-TABLE* CL::LOGICAL-WORD-BITTABLE \HOSTTOPATHNAMECASE) (COMS (* ;; "Interlisp-D compatibility") (FUNCTIONS INTERLISP-NAMESTRING UNPACKPATHNAME.STRING)) (FUNCTIONS CL:FILE-NAMESTRING CL:DIRECTORY-NAMESTRING) (COMS (* ;; "Backward compatibility with old directory-components (superceded by CLtL2 list-structured components)") (FUNCTIONS %%CONVERT-DIRECTORY-COMPONENT)) (COMS (* ;; "Funky pattern matcher for logical pathname support") (FUNCTIONS CL::MATCH&MAP CL::MM1 CL::MATCH-DIRECTORY-LISTS CL::MDL1) (* ;; "Direct logical pathname support") (DEFINE-TYPES CL::LOGICAL-HOSTS) (FUNCTIONS CL::DEF-LOGICAL-HOST CL::UNDEFINE-LOGICAL-HOST) (FUNCTIONS CL:LOGICAL-PATHNAME-TRANSLATIONS CL::UNDOABLY-SETF-LOGICAL-PATHNAME-TRANSLATIONS) (SETFS CL:LOGICAL-PATHNAME-TRANSLATIONS) (PROP :UNDOABLE-SETF-INVERSE CL:LOGICAL-PATHNAME-TRANSLATIONS) (FUNCTIONS CL::LOGICAL-HOST-P CL::MUNG-PATHNAME-ELT CL:LOGICAL-PATHNAME CL:PATHNAME-MATCH-P CL:TRANSLATE-LOGICAL-PATHNAME CL:TRANSLATE-PATHNAME CL:LOAD-LOGICAL-PATHNAME-TRANSLATIONS CL:WILD-PATHNAME-P) (FUNCTIONS LOOKUP-PATHNAMECASE REGISTER-PATHNAMECASE UNREGISTER-PATHNAMECASE) (FNS UNPACKLOGICALNAME.STRING)) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (%%INITIALIZE-DEFAULT-PATHNAME))) (FNS FLIP-MONOCASE FLIP-MONOCASE-STRING) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA CL:ENOUGH-NAMESTRING CL:HOST-NAMESTRING FILE-NAME CL:MERGE-PATHNAMES PATHNAME %%PRINT-DIRECTORY-COMPONENT CL:MAKE-PATHNAME %%PRINT-PATHNAME %%PRINT-LP)))))



(* ;; "Common Lisp pathname functions")



(PUTPROPS CMLPATHNAME FILETYPE CL:COMPILE-FILE)



(* ;; "useful macros")



(CL:DEFUN %%MAKE-LP (HOST DEVICE DIRECTORY NAME TYPE VERSION) (%%%%MAKE-LP :HOST HOST :DEVICE :UNSPECIFIC :DIRECTORY DIRECTORY :NAME NAME :TYPE TYPE :VERSION VERSION))

(CL:DEFUN %%MERGE-DIRECTORY-LISTS (DIRLIST DEFAULTS) (* ;; "DIRLIST is a CLtL2-style directory list, DEFAULTS may or may not be; they need to be merged") (COND ((OR (EQUAL DEFAULTS (QUOTE (:ABSOLUTE :WILD-INFERIORS))) (EQUAL DEFAULTS (QUOTE (:ABSOLUTE :WILD)))) DIRLIST) ((AND (EQ (CAR DIRLIST) :RELATIVE) (CL:CONSP DEFAULTS)) (APPEND DEFAULTS (CDR DIRLIST))) (DIRLIST) (DEFAULTS)))

(DEFMACRO %%WILD-NAME (STRING) (BQUOTE (LET ((S (\, STRING))) (CL:IF (STRING-EQUAL S "*") :WILD (CL:IF (STRING-EQUAL S "") NIL S)))))

(DEFMACRO %%COMPONENT-STRING (COMPONENT) (BQUOTE (MKSTRING (OR (\, COMPONENT) ""))))

(DEFMACRO %%UNPACKFILE1 (NAM ST END FILE PACKFLG ONEFIELDFLG VAL) (BQUOTE (if (NOT (\, ONEFIELDFLG)) then (SETQ (\, VAL) (CONS (COND ((\, PACKFLG) (SUBATOM (\, FILE) (\, ST) (\, END))) (T (OR (SUBSTRING (\, FILE) (\, ST) (\, END)) ""))) (CONS (\, NAM) (\, VAL)))) elseif (EQMEMB (\, NAM) (\, ONEFIELDFLG)) then (RETURN (COND ((\, PACKFLG) (SUBATOM (\, FILE) (\, ST) (\, END))) (T (OR (SUBSTRING (\, FILE) (\, ST) (\, END)) "")))))))

(CL:DEFSTRUCT (PATHNAME (:CONC-NAME %%PATHNAME-) (:PRINT-FUNCTION %%PRINT-PATHNAME) (:CONSTRUCTOR %%%%MAKE-PATHNAME) (:PREDICATE CL:PATHNAMEP)) HOST DEVICE DIRECTORY NAME TYPE VERSION)

(CL:DEFSTRUCT (DIRECTORY-COMPONENT (:CONC-NAME %%DIRECTORY-COMPONENT-) (:PRINT-FUNCTION %%PRINT-DIRECTORY-COMPONENT) (:CONSTRUCTOR %%MAKE-DIRECTORY-COMPONENT) (:PREDICATE %%DIRECTORY-COMPONENT-P)) TYPE PATH)

(CL:DEFSTRUCT (CL:LOGICAL-PATHNAME (:SYSTEM-INCLUDE PATHNAME) (:PRINT-FUNCTION %%PRINT-LP) (:CONSTRUCTOR %%%%MAKE-LP) (:PREDICATE CL::LOGICAL-PATHNAME-P)))
(DECLARE%: DONTCOPY EVAL@COMPILE 
(DECLARE%: EVAL@COMPILE

(RECORD PATHNAMECASE
 (HOST-NAME STRING-COMPARE LOCAL-TO-COMMON COMMON-TO-LOCAL))
)
)
(DEFINEQ

(%%PARSE-DIRECTORY-PATH

(LAMBDA (PS) (* ; "Edited 17-Jun-91 09:19 by jrb:") (* ;; "Seperates a directory string into a list of its component directory strings with the CLtL2-apropos atoms inserted") (IF (STRINGP PS) THEN (LET ((REM (SUBSTRING PS 1)) TAIL POINT PIECE) (CL:FLET ((MUNG-PIECE (P) (COND ((CL:STRING= P "*") :WILD) ((CL:STRING= P "**") :WILD-INFERIORS) ((CL:STRING= P "..") :BACK) (T P)))) (while (SETQ POINT (STRPOSL (CONSTANT (MAKEBITTABLE (QUOTE (/ > ;)))) REM)) do (SETQ PIECE (SUBSTRING REM 1 (CL:1- POINT))) (push TAIL (MUNG-PIECE PIECE)) (SETQ REM (SUBSTRING REM (CL:1+ POINT) NIL REM)) finally (CL:WHEN REM (push TAIL (MUNG-PIECE REM))))) (CL:NREVERSE TAIL)) else PS))
)

(%%PRINT-LP

(CL:LAMBDA (S STREAM D) (DECLARE (IGNORE D)) (* ; "Edited 25-Oct-91 16:08 by jrb:") (CL:WHEN (AND CL:*PRINT-READABLY* (NOT CL:*READ-EVAL*)) (CL::CHECK-READABLY S "its print-method when *READ-EVAL* is NIL")) (CL:FORMAT STREAM "#.(LOGICAL-PATHNAME ~S)" (CL:NAMESTRING S)))
)

(%%PRINT-PATHNAME

(CL:LAMBDA (S STREAM D) (* ; "Edited 25-Oct-91 15:49 by jrb:") (DECLARE (IGNORE D)) (CL:FORMAT STREAM "~:[~;#P~]~S" *PRINT-ESCAPE* (CL:NAMESTRING S)))
)

(CL:MAKE-PATHNAME

(CL:LAMBDA (&KEY DEFAULTS (HOST NIL HOSTP) (DEVICE NIL DEVICEP) (DIRECTORY NIL DIRECTORYP) (NAME NIL NAMEP) (TYPE NIL TYPEP) (VERSION NIL VERSIONP) (CASE :LOCAL) (CL::LOGICAL NIL)) (* ; "Edited  3-Aug-91 15:25 by jrb:") (* ;; "Create a pathname from host, device, directory, name, type and version.  If any field is omitted, it is obtained from defaults as though by merge-pathnames.") (* ;; "Under Medley, as of CLtL2, the following are the legal inputs and resulting contents of pathname slots:") (* ;; "Host: NIL|:UNSPECIFIC|string => NIL|:UNSPECIFIC|string") (* ;; "Device: NIL|:UNSPECIFIC|string => NIL|:UNSPECIFIC|string") (* ;; "Directory: NIL|string|:WILD|:UNSPECIFIC|CLtL2-style list => NIL|:UNSPECIFIC|CLtL2-style list") (* ;; "    (DIRECTORY-COMPONENT objects are recognized and converted to lists)") (* ;; "Name: NIL|string|:WILD|:UNSPECIFIC => NIL|string|:WILD|:UNSPECIFIC") (* ;; "Type: NIL|string|:WILD|:UNSPECIFIC => NIL|string|:WILD|:UNSPECIFIC") (* ;; "Version: NIL|positive-integer|:WILD|:NEWEST|:UNSPECIFIC => NIL|positive-integer|:WILD|:NEWEST|:UNSPECIFIC") (CL:FLET ((CL::PARSE-DIRECTORY-STRING (CL::DS) (LET ((CL::DL (%%PARSE-DIRECTORY-PATH CL::DS))) (CASE (CL:CHAR CL::DS (CL:1- (CL:LENGTH CL::DS))) ((#\> #\/) (* ;; "MAKE-PATHNAME does not accept :SUBDIRECTORY argument.  Thus a subdirectory and a relative directory is indicated with the trail directory delimiter.") (COND (DEFAULTS (%%MERGE-DIRECTORY-LISTS (CONS :RELATIVE CL::DL) (%%PATHNAME-DIRECTORY DEFAULTS))) (T (CONS :RELATIVE CL::DL)))) (T (CONS :ABSOLUTE CL::DL)))))) (CL:WHEN DEFAULTS (CL:SETQ DEFAULTS (PATHNAME DEFAULTS)) (CL:UNLESS HOSTP (SETQ HOST (%%PATHNAME-HOST DEFAULTS))) (CL:UNLESS DEVICEP (SETQ DEVICE (%%PATHNAME-DEVICE DEFAULTS))) (CL:UNLESS DIRECTORYP (SETQ DIRECTORY (%%PATHNAME-DIRECTORY DEFAULTS))) (CL:UNLESS NAMEP (SETQ NAME (%%PATHNAME-NAME DEFAULTS))) (CL:UNLESS TYPEP (SETQ TYPE (%%PATHNAME-TYPE DEFAULTS))) (CL:UNLESS VERSIONP (SETQ VERSION (%%PATHNAME-VERSION DEFAULTS)))) (CL:UNLESS (OR HOSTP HOST) (SETQ HOST (%%PATHNAME-HOST *DEFAULT-PATHNAME-DEFAULTS*))) (* ;; "Handle the :COMMON CASE here") (CL:WHEN (EQ CASE :COMMON) (LET ((COMMON-TO-LOCAL (fetch (PATHNAMECASE COMMON-TO-LOCAL) of (LOOKUP-PATHNAMECASE HOST)))) (CL:WHEN (AND HOSTP (CL:STRINGP HOST)) (SETQ HOST (CL:FUNCALL COMMON-TO-LOCAL HOST))) (CL:WHEN (AND DEVICEP (CL:STRINGP DEVICE)) (SETQ DEVICE (CL:FUNCALL COMMON-TO-LOCAL DEVICE))) (CL:WHEN DIRECTORYP (CL:WHEN (CL:STRINGP DIRECTORY) (CL:SETQ DIRECTORY (CL::PARSE-DIRECTORY-STRING DIRECTORY))) (CL:WHEN (LISTP DIRECTORY) (SETQ DIRECTORY (MAPCAR DIRECTORY (CL:FUNCTION (LAMBDA (X) (CL:IF (CL:STRINGP X) (CL:FUNCALL COMMON-TO-LOCAL X) X))))))) (CL:WHEN (AND NAMEP (CL:STRINGP NAME)) (SETQ NAME (CL:FUNCALL COMMON-TO-LOCAL NAME))) (CL:WHEN (AND TYPEP (CL:STRINGP TYPE)) (SETQ TYPE (CL:FUNCALL COMMON-TO-LOCAL TYPE))))) (CL:FUNCALL (CL:IF (OR CL::LOGICAL (AND (NOT *CLTL2-PEDANTIC*) (CL::LOGICAL-HOST-P HOST))) (QUOTE %%MAKE-LP) (QUOTE %%MAKE-PATHNAME)) (CL:IF (STRINGP HOST) (COERCE HOST (QUOTE CL:SIMPLE-STRING)) HOST) (CL:IF (STRINGP DEVICE) (COERCE DEVICE (QUOTE CL:SIMPLE-STRING)) DEVICE) (CL:IF DIRECTORY (PROGN (* ;; "Hopefully from now on, the only things users should find in PATHNAME-DIRECTORY are:") (* ;; "NIL") (* ;; ":UNSPECIFIC") (* ;; "A CLtL2-style list (CAR of :ABSOLUTE or :RELATIVE, followed by elements in the path)") (CL:WHEN (CL:SYMBOLP DIRECTORY) (SETQ DIRECTORY (SELECTQ DIRECTORY (:WILD (QUOTE (:ABSOLUTE :WILD-INFERIORS))) (:UNSPECIFIC DIRECTORY) (CL:IF *CLTL2-PEDANTIC* (ERROR "Symbol as :DIRECTORY component" DIRECTORY) (STRING DIRECTORY))))) (CL:TYPECASE DIRECTORY (LIST (CL:IF DEFAULTS (%%MERGE-DIRECTORY-LISTS DIRECTORY (%%PATHNAME-DIRECTORY DEFAULTS)) DIRECTORY)) (DIRECTORY-COMPONENT (%%CONVERT-DIRECTORY-COMPONENT DIRECTORY)) (STRING (CL:WHEN (CL:PLUSP (CL:LENGTH DIRECTORY)) (CONS (CASE (CL:CHAR DIRECTORY (CL:1- (CL:LENGTH DIRECTORY))) ((#\/ #\>) :RELATIVE) (CL:OTHERWISE :ABSOLUTE)) (%%PARSE-DIRECTORY-PATH DIRECTORY)))) (T DIRECTORY))) DIRECTORY) (CL:IF (STRINGP NAME) (COERCE NAME (QUOTE CL:SIMPLE-STRING)) NAME) (CL:IF (STRINGP TYPE) (COERCE TYPE (QUOTE CL:SIMPLE-STRING)) TYPE) VERSION)))
)

(%%PRINT-DIRECTORY-COMPONENT

(LISP:LAMBDA (S STREAM D) (DECLARE (IGNORE D)) (* ; "Edited  7-Mar-90 17:59 by nm") (* %| "(CL:FORMAT STREAM %"#.(~S ~S)%" (QUOTE DIRECTORY-COMPONENT) (CASE (%%%%DIRECTORY-COMPONENT-TYPE S) ((:SUBDIRECTORY :RELATIVE) (CL:CONCATENATE (QUOTE STRING) (%%%%DIRECTORY-COMPONENT-PATH S) %">%")) (T (CL:CONCATENATE (QUOTE STRING) (CL:FIRST \FILENAME.SYNTAX) (%%%%DIRECTORY-COMPONENT-PATH S) (CL:SECOND \FILENAME.SYNTAX)))))") (LET ((PATH (%%DIRECTORY-COMPONENT-PATH S))) (LISP:FORMAT STREAM "~A" (CASE (%%DIRECTORY-COMPONENT-TYPE S) ((:SUBDIRECTORY :RELATIVE) (LISP:CONCATENATE (QUOTE STRING) PATH ">")) (T (LISP:IF (EQ PATH :WILD) (LISP:CONCATENATE (QUOTE STRING) (LISP:FIRST \FILENAME.SYNTAX) "*" (LISP:SECOND \FILENAME.SYNTAX)) (LISP:CONCATENATE (QUOTE STRING) (LISP:FIRST \FILENAME.SYNTAX) PATH (LISP:SECOND \FILENAME.SYNTAX))))))))
)
)

(CL:DEFUN CL:PATHNAME-HOST (PATHNAME &KEY CASE) (* ;; "takes a stream, string, symbol, or pathname as arg, and returns the host slot of it; if CASE is :COMMON, hoses it through the LOCAL-TO-COMMON conversion function first") (LET ((CL::PN (PATHNAME PATHNAME))) (CL:IF (AND (EQ CASE :COMMON) (CL:STRINGP (%%PATHNAME-HOST CL::PN))) (CL:FUNCALL (fetch (PATHNAMECASE LOCAL-TO-COMMON) of (LOOKUP-PATHNAMECASE (%%PATHNAME-HOST CL::PN))) (%%PATHNAME-HOST CL::PN)) (%%PATHNAME-HOST CL::PN))))

(CL:DEFUN CL:PATHNAME-DEVICE (PATHNAME &KEY CASE) (* ;; "takes a stream, string, symbol, or pathname as arg, and returns the device slot of it") (LET ((CL::PN (PATHNAME PATHNAME))) (CL:IF (AND (EQ CASE :COMMON) (CL:STRINGP (%%PATHNAME-DEVICE CL::PN))) (CL:FUNCALL (fetch (PATHNAMECASE LOCAL-TO-COMMON) of (LOOKUP-PATHNAMECASE (%%PATHNAME-HOST CL::PN))) (%%PATHNAME-DEVICE CL::PN)) (%%PATHNAME-DEVICE CL::PN))))

(CL:DEFUN CL:PATHNAME-DIRECTORY (PATHNAME &KEY CASE) (* ;; "takes a stream, string, symbol, or pathname as arg, and returns the directory slot of it") (LET* ((CL::PN (PATHNAME PATHNAME)) (CL::PD (%%PATHNAME-DIRECTORY CL::PN))) (CL:IF (AND (EQ CASE :COMMON) (CL:CONSP CL::PD)) (LET ((CL::PF (fetch (PATHNAMECASE LOCAL-TO-COMMON) of (LOOKUP-PATHNAMECASE (%%PATHNAME-HOST CL::PN))))) (CL:MAPCAR (CL:FUNCTION (CL:LAMBDA (CL::X) (CL:IF (CL:STRINGP CL::X) (CL:FUNCALL CL::PF CL::X) CL::X))) CL::PD)) CL::PD)))

(CL:DEFUN CL:PATHNAME-NAME (PATHNAME &KEY CASE) (* ;; "takes a stream, string, symbol, or pathname as arg, and returns the name slot of it") (LET ((CL::PN (PATHNAME PATHNAME))) (CL:IF (AND (EQ CASE :COMMON) (CL:STRINGP (%%PATHNAME-NAME CL::PN))) (CL:FUNCALL (fetch (PATHNAMECASE LOCAL-TO-COMMON) of (LOOKUP-PATHNAMECASE (%%PATHNAME-HOST CL::PN))) (%%PATHNAME-NAME CL::PN)) (%%PATHNAME-NAME CL::PN))))

(CL:DEFUN CL:PATHNAME-TYPE (PATHNAME &KEY CASE) (* ;; "takes a stream, string, symbol, or pathname as arg, and returns the type slot of it") (LET ((CL::PN (PATHNAME PATHNAME))) (CL:IF (AND (EQ CASE :COMMON) (CL:STRINGP (%%PATHNAME-TYPE CL::PN))) (CL:FUNCALL (fetch (PATHNAMECASE LOCAL-TO-COMMON) of (LOOKUP-PATHNAMECASE (%%PATHNAME-HOST CL::PN))) (%%PATHNAME-TYPE CL::PN)) (%%PATHNAME-TYPE CL::PN))))

(CL:DEFUN CL:PATHNAME-VERSION (PATHNAME) (* ;; "takes a stream, string, symbol, or pathname as arg, and returns the version slot of it") (%%PATHNAME-VERSION (PATHNAME PATHNAME)))
(DEFINEQ

(PATHNAME

(LISP:LAMBDA (THING) (* hdj " 2-Apr-86 11:01") (* ;; "Turns Thing into a pathname.  Thing may be a string, symbol, stream, or pathname.") (LISP:VALUES (LISP:PARSE-NAMESTRING THING)))
)

(CL:MERGE-PATHNAMES

(CL:LAMBDA (PATHNAME &OPTIONAL (DEFAULTS *DEFAULT-PATHNAME-DEFAULTS*) (DEFAULT-VERSION :NEWEST LISP::VERSION-SPECIFIED-P)) (* ; "Edited  3-Jun-91 20:56 by jrb:") (* ;;; "Merge-Pathnames -- Public Returns a new pathname whose fields are the same as the fields in PATHNAME except that NIL fields are filled in from defaults.  Type and Version field are only done if name field has to be done (see manual for explanation). Fills in unspecified slots of Pathname from Defaults (defaults to *default-pathname-defaults*).  If the version remains unspecified, gets it from Default-Version.") (LET* ((PATH (PATHNAME PATHNAME)) (DEFAULT-PATH (PATHNAME DEFAULTS)) (HOST (OR (%%PATHNAME-HOST PATH) (%%PATHNAME-HOST DEFAULT-PATH))) (NAME (%%PATHNAME-NAME PATH)) (DEVICE (%%PATHNAME-DEVICE PATH)) (DIR (%%PATHNAME-DIRECTORY PATH)) (DEFAULT-DIR (%%PATHNAME-DIRECTORY DEFAULT-PATH)) DIREND DEFAULT-TYPE) (%%MAKE-PATHNAME HOST (OR DEVICE (%%PATHNAME-DEVICE DEFAULT-PATH)) (OR (AND DIR DEFAULT-DIR (IF (CL:CONSP DIR) THEN (%%MERGE-DIRECTORY-LISTS DIR DEFAULT-DIR))) DIR DEFAULT-DIR) (OR NAME (%%PATHNAME-NAME DEFAULT-PATH)) (OR (%%PATHNAME-TYPE PATH) (%%PATHNAME-TYPE DEFAULT-PATH)) (OR (%%PATHNAME-VERSION PATH) (CL:IF NAME (CL:IF LISP::VERSION-SPECIFIED-P DEFAULT-VERSION :NEWEST) (OR (%%PATHNAME-VERSION DEFAULT-PATH) (CL:IF LISP::VERSION-SPECIFIED-P DEFAULT-VERSION :NEWEST)))))))
)

(FILE-NAME

(LISP:LAMBDA (FILE) (* hdj " 9-Oct-86 15:12") (LET ((NAME (FULLNAME FILE))) (if (STREAMP NAME) then "" else (MKSTRING NAME))))
)

(LISP:HOST-NAMESTRING

(LISP:LAMBDA (PATHNAME) (* hdj "11-Jun-86 11:29") (* ;; "Returns the host part of PATHNAME as a string.") (%%COMPONENT-STRING (%%PATHNAME-HOST (PATHNAME PATHNAME))))
)

(CL:ENOUGH-NAMESTRING

(CL:LAMBDA (PATHNAME &OPTIONAL (DEFAULTS *DEFAULT-PATHNAME-DEFAULTS*)) (* ; "Edited  2-Aug-91 09:21 by jrb:") (* ;; "Enough-Namestring returns a string which uniquely identifies PATHNAME w.r.t.  DEFAULTS.") (CL:FLET ((CL::MUNG-SLOT (CL::X) (* ; "Map :UNSPECIFIC to NIL for printing") (CL:IF (EQ CL::X :UNSPECIFIC) NIL CL::X))) (LET* ((*PRINT-BASE* 10) (PATH (PATHNAME PATHNAME)) (DEFAULT-PATHNAME (PATHNAME DEFAULTS)) (HOST (CL::MUNG-SLOT (%%PATHNAME-HOST PATH))) (DEVICE (CL::MUNG-SLOT (%%PATHNAME-DEVICE PATH))) (DIRECTORY (CL::MUNG-SLOT (%%PATHNAME-DIRECTORY PATH))) (NAME (CL::MUNG-SLOT (%%PATHNAME-NAME PATH))) (TYPE (CL::MUNG-SLOT (%%PATHNAME-TYPE PATH))) (VERSION (CL::MUNG-SLOT (%%PATHNAME-VERSION PATH))) (RESULT "") (CL::HOST-HEAD "{") (CL::HOST-TAIL "}") (CL::DIR-HEAD (CL:FIRST \FILENAME.SYNTAX)) (CL::DIR-TAIL (CL:SECOND \FILENAME.SYNTAX)) (CL::VER-HEAD (CL:THIRD \FILENAME.SYNTAX))) (CL:WHEN (CL::LOGICAL-PATHNAME-P PATH) (CL:UNLESS (CL::LOGICAL-PATHNAME-P DEFAULT-PATHNAME) (CL:ERROR "Can't merge ~s with ~s" PATH DEFAULT-PATHNAME)) (CL:SETQ CL::HOST-HEAD "" CL::HOST-TAIL ":" CL::DIR-HEAD ";" CL::DIR-TAIL ";" CL::VER-HEAD ".")) (CL:FLET ((CL::MUNG-DIR-LIST (CL::X) (LIST (CL::MUNG-PATHNAME-ELT CL::X) CL::DIR-TAIL))) (CL:WHEN (AND HOST (CL:STRING-NOT-EQUAL HOST (%%COMPONENT-STRING (CL::MUNG-SLOT (%%PATHNAME-HOST DEFAULT-PATHNAME))))) (SETQ RESULT (CL:CONCATENATE (QUOTE CL:SIMPLE-STRING) CL::HOST-HEAD (CL:PRINC-TO-STRING HOST) CL::HOST-TAIL))) (CL:WHEN (AND DEVICE (CL:STRING-NOT-EQUAL DEVICE (%%COMPONENT-STRING (CL::MUNG-SLOT (%%PATHNAME-DEVICE DEFAULT-PATHNAME))))) (SETQ RESULT (CL:CONCATENATE (QUOTE CL:SIMPLE-STRING) RESULT (CL:PRINC-TO-STRING DEVICE) ":"))) (CL:WHEN (AND DIRECTORY (NOT (CL:EQUAL DIRECTORY (CL::MUNG-SLOT (%%PATHNAME-DIRECTORY DEFAULT-PATHNAME))))) (CL:SETQ RESULT (CL:CONCATENATE (QUOTE CL:SIMPLE-STRING) RESULT (CONCATLIST (CASE (CL:FIRST DIRECTORY) (:RELATIVE (CL:MAPCAN (CL:FUNCTION CL::MUNG-DIR-LIST) (CDR DIRECTORY))) (:ABSOLUTE (CL:IF (AND (EQ (CL:SECOND DIRECTORY) :WILD-INFERIORS) (NULL (CDDR DIRECTORY))) NIL (CONS CL::DIR-HEAD (CL:MAPCAN (CL:FUNCTION CL::MUNG-DIR-LIST) (CDR DIRECTORY)))))))))) (CL:WHEN (AND NAME (CL:STRING-NOT-EQUAL NAME (%%COMPONENT-STRING (CL::MUNG-SLOT (%%PATHNAME-NAME DEFAULT-PATHNAME))))) (CL:SETQ RESULT (CL:CONCATENATE (QUOTE CL:SIMPLE-STRING) RESULT (CL:PRINC-TO-STRING NAME)))) (CL:WHEN (AND TYPE (CL:STRING-NOT-EQUAL TYPE (%%COMPONENT-STRING (CL::MUNG-SLOT (%%PATHNAME-TYPE DEFAULT-PATHNAME))))) (SETQ RESULT (CL:CONCATENATE (QUOTE CL:SIMPLE-STRING) RESULT "." (CL:PRINC-TO-STRING TYPE)))) (CL:WHEN (AND VERSION (CL:STRING-NOT-EQUAL (CL:PRINC-TO-STRING VERSION) (CL::MUNG-SLOT (%%PATHNAME-VERSION DEFAULT-PATHNAME)))) (SETQ RESULT (CL:CONCATENATE (QUOTE CL:SIMPLE-STRING) RESULT (CASE VERSION (:WILD (CL:CONCATENATE (QUOTE CL:SIMPLE-STRING) CL::VER-HEAD "*")) ((:NEWEST NIL) "") (CL:OTHERWISE (CL:CONCATENATE (QUOTE CL:SIMPLE-STRING) CL::VER-HEAD (CL:PRINC-TO-STRING VERSION))))))) RESULT))))
)

(%%NUMERIC-STRING-P

(LAMBDA (STRING) (* hdj "28-Jul-86 12:25") (AND (LISP:STRINGP STRING) (for CHAR instring STRING do (if (OR (ILESSP CHAR (CHARCODE 0)) (IGREATERP CHAR (CHARCODE 9))) then (RETURN NIL)) finally (RETURN T))))
)
)

(CL:DEFUN CL:NAMESTRING (PATHNAME) (* ;;; "Returns the full form of PATHNAME as a string.") (CL:WHEN (AND (STREAMP PATHNAME) (NOT (fetch (STREAM NAMEDP) of PATHNAME))) (* ; "unnamed streams have the empty string as name.") (CL:RETURN-FROM CL:NAMESTRING "")) (CL:FLET ((CL::MUNG-SLOT (CL::X) (* ; "Map :UNSPECIFIC to NIL for printing") (CL:IF (EQ CL::X :UNSPECIFIC) NIL CL::X)) (CL::MPE (CL::X) (LIST (CL::MUNG-PATHNAME-ELT CL::X) (CL:SECOND \FILENAME.SYNTAX)))) (LET* ((PATHNAME (PATHNAME PATHNAME)) (CL::HOST (CL::MUNG-SLOT (%%PATHNAME-HOST PATHNAME))) (CL::DEVICE (CL::MUNG-SLOT (%%PATHNAME-DEVICE PATHNAME))) (CL:DIRECTORY (CL::MUNG-SLOT (%%PATHNAME-DIRECTORY PATHNAME))) (CL::NAME (CL::MUNG-SLOT (%%PATHNAME-NAME PATHNAME))) (TYPE (CL::MUNG-SLOT (%%PATHNAME-TYPE PATHNAME))) (CL::VERSION (CL::MUNG-SLOT (%%PATHNAME-VERSION PATHNAME))) (CL::HOST-HEAD "{") (CL::HOST-TAIL "}") (CL::DIR-HEAD (CL:FIRST \FILENAME.SYNTAX)) (CL::DIR-TAIL (CL:SECOND \FILENAME.SYNTAX)) (CL::VER-HEAD (CL:THIRD \FILENAME.SYNTAX))) (CL:FLET ((CL::MPE (CL::X) (LIST (CL::MUNG-PATHNAME-ELT CL::X) CL::DIR-TAIL))) (CL:WHEN (CL::LOGICAL-PATHNAME-P PATHNAME) (CL:SETQ CL::HOST-HEAD "" CL::HOST-TAIL ":" CL::DIR-HEAD ";" CL::DIR-TAIL ";" CL::VER-HEAD (AND CL::VERSION "."))) (CONCATLIST (NCONC (CL:WHEN CL::HOST (LIST CL::HOST-HEAD (CL:IF (EQ CL::HOST :WILD) "*" CL::HOST) CL::HOST-TAIL)) (CL:WHEN CL::DEVICE (LIST (CL:IF (EQ :WILD CL::DEVICE) "*" CL::DEVICE) ":")) (CL:WHEN CL:DIRECTORY (CL:ECASE (CL:FIRST CL:DIRECTORY) (:RELATIVE (CL:MAPCAN (CL:FUNCTION CL::MPE) (CDR CL:DIRECTORY))) (:ABSOLUTE (CL:IF (AND (EQ (CL:SECOND CL:DIRECTORY) :WILD-INFERIORS) (NULL (CDDR CL:DIRECTORY))) NIL (CONS CL::DIR-HEAD (CL:MAPCAN (CL:FUNCTION CL::MPE) (CDR CL:DIRECTORY))))))) (CL:WHEN CL::NAME (LIST (CL:IF (EQ CL::NAME :WILD) "*" CL::NAME))) (CL:WHEN TYPE (LIST "." (CL:IF (EQ TYPE :WILD) "*" TYPE))) (CL:WHEN (AND CL::VERSION (OR (NOT (EQ CL::VERSION (QUOTE :NEWEST))) CL::NAME TYPE)) (COND ((AND (EQ \MACHINETYPE \MAIKO) (STREQUAL "UNIX" (U-CASE (MKSTRING CL::HOST)))) (* ; "{UNIX} device on Maiko breaks the Interlisp-D original file naming convention.  The trail semicolonn is regarded as a part of the file name rather than a %"highest versioned%" file!   Thus, if :newest, we have to elimit the semicolon.") (CASE CL::VERSION ((:WILD) (LIST CL::VER-HEAD) "*") ((:NEWEST) (LIST "")) (T (LIST CL::VER-HEAD CL::VERSION)))) (T (LIST CL::VER-HEAD (CASE CL::VERSION ((:WILD) "*") ((:NEWEST) (CL:IF (CL::LOGICAL-PATHNAME-P PATHNAME) CL::VERSION "")) (T CL::VERSION))))))))))))

(CL:DEFUN CL:PARSE-NAMESTRING (THING &OPTIONAL HOST DEFAULTS &KEY (START 0) END (JUNK-ALLOWED NIL) (CL::LOGICAL NIL)) (* ;;; "Parses a string representation of a pathname into a pathname.  For details on the other silly arguments see the manual.  NOTE that this version ignores JUNK-ALLOWED (because UNPACKFILENAME a.k.a. PARSE-NAMESTRING1 will parse anything)") (DECLARE (IGNORE JUNK-ALLOWED)) (CL:ETYPECASE THING (STRING NIL) (PATHNAME (CL:RETURN-FROM CL:PARSE-NAMESTRING (CL:VALUES THING START))) (STREAM (CL:IF (XCL:SYNONYM-STREAM-P THING) (CL:RETURN-FROM CL:PARSE-NAMESTRING (CL:PARSE-NAMESTRING (CL:SYMBOL-VALUE (CL:SYNONYM-STREAM-SYMBOL THING)))) (SETQ THING (FILE-NAME THING)))) (CL:SYMBOL (CL:WHEN *CLTL2-PEDANTIC* (XCL::SYMBOL-AS-PATHNAME THING (QUOTE CL:PARSE-NAMESTRING))) (SETQ THING (CL:SYMBOL-NAME THING)))) (CL:UNLESS END (SETQ END (CL:LENGTH THING))) (* ;; "The defaulting code below is a little odd; if :LOGICAL is specified T, we do NOT default the host from *DEFAULT-PATHNAME-DEFAULTS* unless it is a LOGICAL-PATHNAME") (CL:UNLESS HOST (CL:SETQ HOST (OR (AND DEFAULTS (%%PATHNAME-HOST DEFAULTS)) (AND (OR (NOT CL::LOGICAL) (CL::LOGICAL-PATHNAME-P *DEFAULT-PATHNAME-DEFAULTS*)) (%%PATHNAME-HOST *DEFAULT-PATHNAME-DEFAULTS*))))) (CL:UNLESS CL::LOGICAL (CL:SETQ CL::LOGICAL (OR (CL::LOGICAL-HOST-P HOST) (CL::LOGICAL-PATHNAME-P DEFAULTS)))) (LET* ((PATH-STRING (SUBSTRING THING (+ 1 START) END)) (PATH-LIST (CL:IF CL::LOGICAL (UNPACKLOGICALNAME.STRING (U-CASE PATH-STRING) (U-CASE HOST)) (UNPACKFILENAME.STRING PATH-STRING NIL NIL NIL NIL T)))) (CL:VALUES (CL:MAKE-PATHNAME :HOST (%%WILD-NAME (LISTGET PATH-LIST (QUOTE HOST))) :DEVICE (%%WILD-NAME (LISTGET PATH-LIST (QUOTE DEVICE))) :DIRECTORY (LET ((CL:DIRECTORY (LISTGET PATH-LIST (QUOTE DIRECTORY))) (LISP::SUBDIRECTORY (LISTGET PATH-LIST (QUOTE SUBDIRECTORY))) (LISP::RELATIVEDIRECTORY (LISTGET PATH-LIST (QUOTE RELATIVEDIRECTORY)))) (COND (CL:DIRECTORY (CONS :ABSOLUTE (%%PARSE-DIRECTORY-PATH CL:DIRECTORY))) (LISP::SUBDIRECTORY (CONS :RELATIVE (%%PARSE-DIRECTORY-PATH LISP::SUBDIRECTORY))) (LISP::RELATIVEDIRECTORY (CONS :RELATIVE (%%PARSE-DIRECTORY-PATH LISP::RELATIVEDIRECTORY))) (T NIL))) :NAME (%%WILD-NAME (LISTGET PATH-LIST (QUOTE NAME))) :TYPE (%%WILD-NAME (LISTGET PATH-LIST (QUOTE EXTENSION))) :VERSION (LET ((VERSION (LISTGET PATH-LIST (QUOTE VERSION)))) (CL:IF (CL:EQUAL VERSION "") :NEWEST (CL:IF (CL:EQUAL VERSION "*") :WILD (MKATOM VERSION)))) :LOGICAL CL::LOGICAL) END)))

(CL:DEFUN PARSE-NAMESTRING1 (FILE) (* ;;; "Given a string or atom representation of a file name, unpack it into its component parts") (* ;;; "crudely hacked from UNPACKFILENAME.STRING") (PROG ((POS 1) TEM TEM2 BEYONDNAME BEYONDEXT VAL CODE HOSTP SUBDIREND PACKFLG DIRFLG ONEFIELDFLG) (COND ((NULL FILE) (RETURN (CONS (SUB1 POS) NIL))) ((OR (LITATOM FILE) (CL:STRINGP FILE) (NUMBERP FILE))) ((type? STREAM FILE) (* ; "For streams, use full name.  If anonymous, fake it") (SETQ FILE (OR (ffetch FULLFILENAME of FILE) (RETURN (CONS (SUB1 POS) (LIST (QUOTE NAME) FILE)))))) (T (\ILLEGAL.ARG FILE))) (COND ((SELCHARQ (NTHCHARCODE FILE 1) ({ (* ; "normal use in Interlisp-D") (SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE }) FILE 2) 0)))) (%[ (* ; "some Xerox and Arpanet systems use `[' for host") (SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE "]") FILE 2) 0)))) (%( (* ; "this is the standard for Xerox product file servers") (SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE ")") FILE 2) 0)))) NIL) (%%UNPACKFILE1 (QUOTE HOST) 2 TEM FILE PACKFLG ONEFIELDFLG VAL) (COND ((EQ TEM -1) (RETURN (CONS (SUB1 POS) (DREVERSE VAL))))) (SETQ POS (IPLUS TEM 2)) (SETQ HOSTP T))) (COND ((SETQ TEM (LASTCHPOS (CHARCODE %:) FILE POS)) (SETQ TEM (SUB1 TEM)) (%%UNPACKFILE1 (QUOTE DEVICE) POS TEM FILE PACKFLG ONEFIELDFLG VAL) (SETQ POS (PLUS TEM 2)) (SETQ HOSTP T))) (COND ((EQ DIRFLG (QUOTE RETURN)) (LET ((TYPE (QUOTE DIRECTORY)) (START (SELCHARQ (NTHCHARCODE FILE POS) (NIL (RETURN (CONS (SUB1 POS) (DREVERSE VAL)))) ((/ <) (ADD1 POS)) POS)) END) (SETQ END (SELCHARQ (NTHCHARCODE FILE -1) ((/ >) (COND ((AND (EQ START POS) (NOT HOSTP)) (* ; "Didn't start with a directory delimiter, but it ends with one, so this must be a subdirectory") (SETQ TYPE (QUOTE SUBDIRECTORY)))) -2) (PROGN -1))) (%%UNPACKFILE1 TYPE START END FILE PACKFLG ONEFIELDFLG VAL)) (RETURN (CONS (SUB1 POS) (DREVERSE VAL)))) ((SELCHARQ (NTHCHARCODE FILE POS) (/ (* ; "unix and the `xerox standard' use / for delimiter") (SETQ TEM (LASTCHPOS (CHARCODE /) FILE (ADD1 POS)))) ((< >) (* ; "Interlisp-D and most other Xerox systems, and Tops-20/Tenex use <>.  Jericho uses >>") (SETQ TEM (LASTCHPOS (CHARCODE >) FILE (ADD1 POS)))) NIL) (%%UNPACKFILE1 (QUOTE DIRECTORY) (ADD1 POS) (SUB1 TEM) FILE PACKFLG ONEFIELDFLG VAL) (SETQ POS (ADD1 TEM)) (SETQ HOSTP T))) (OR (SETQ CODE (NTHCHARCODE FILE (SETQ TEM POS))) (RETURN (CONS (SUB1 POS) (DREVERSE VAL)))) NAMELP (SELCHARQ CODE ((%. ! ; NIL) (* ; "NAME and SUBDIRECTORY fields definitely terminated by now") (COND ((AND (EQ CODE (CHARCODE %.)) (NOT BEYONDNAME) (SETQ TEM2 (STRPOS "." FILE (ADD1 TEM))) (SETQ TEM2 (NTHCHAR FILE (ADD1 TEM2))) (NOT (FIXP TEM2))) (* ;; "If there's another dot followed by something other than a numeric extension, then ignore this dot, since we'll get another chance") (GO NEXTCHAR))) (COND (SUBDIREND (%%UNPACKFILE1 (QUOTE SUBDIRECTORY) POS (SUB1 SUBDIREND) FILE PACKFLG ONEFIELDFLG VAL) (SETQ POS (ADD1 SUBDIREND)) (SETQ SUBDIREND) (COND ((AND (NULL CODE) (EQ POS TEM)) (* ; "Nothing follows the subdirectory;  null name is NOT implied") (RETURN (CONS (SUB1 POS) (DREVERSE VAL))))))) (%%UNPACKFILE1 (COND ((NOT BEYONDNAME) (COND ((NEQ CODE (CHARCODE %.)) (SETQQ BEYONDEXT ;))) (SETQQ BEYONDNAME NAME)) ((NOT BEYONDEXT) (SETQ BEYONDEXT (COND ((NEQ CODE (CHARCODE %.)) (QUOTE ;)) (T T))) (QUOTE TYPE)) (T (SELCHARQ (AND (EQ BEYONDEXT (QUOTE ;)) (NTHCHARCODE FILE POS)) (P (QUOTE PROTECTION)) (A (add POS 1) (QUOTE ACCOUNT)) ((T S) (QUOTE TEMPORARY)) (QUOTE VERSION)))) POS (SUB1 TEM) FILE PACKFLG ONEFIELDFLG VAL) (COND ((NULL CODE) (* ; "End of string") (RETURN (CONS (SUB1 POS) (DREVERSE VAL))))) (SETQ POS (ADD1 TEM))) (%' (* ; "Quoter") (add TEM 1)) ((/ >) (* ; "Subdirectory terminating character") (COND ((AND (NOT HOSTP) (NOT BEYONDNAME) DIRFLG) (* ; "Ok to treat this as a subdirectory") (SETQ SUBDIREND TEM)))) NIL) NEXTCHAR (SETQ CODE (NTHCHARCODE FILE (add TEM 1))) (GO NAMELP)))

(CL:DEFUN CL:TRUENAME (PATHNAME) (* ;;; "Return the pathname for the actual file described by the pathname.  An error is signaled if no such file exists.  PATHNAME can be a pathname, string, symbol, or stream.  Synonym streams are followed to their sources") (if (STREAMP PATHNAME) then (COND ((XCL:SYNONYM-STREAM-P PATHNAME) (CL:RETURN-FROM CL:TRUENAME (CL:TRUENAME (CL:SYMBOL-VALUE (CL:SYNONYM-STREAM-SYMBOL PATHNAME))))) ((NOT (fetch (STREAM NAMEDP) of PATHNAME)) (* ; "let's catch this case, rather than have the message 'The file %"%" does not exist' appear.") (CL:ERROR "The stream ~S has no corresponding named file." PATHNAME)))) (LET ((RESULT (CL:PROBE-FILE PATHNAME))) (CL:UNLESS RESULT (CL:ERROR "The file ~S does not exist." (CL:NAMESTRING PATHNAME))) RESULT))

(CL:DEFUN %%MAKE-PATHNAME (HOST DEVICE DIRECTORY NAME TYPE VERSION) (%%%%MAKE-PATHNAME :HOST HOST :DEVICE DEVICE :DIRECTORY DIRECTORY :NAME NAME :TYPE TYPE :VERSION VERSION))

(CL:DEFUN %%PATHNAME-EQUAL (PATHNAME1 PATHNAME2) (* ;; "RASH assumption below: HOST name comparison is ALWAYS case-insensitive") (AND (STRING-EQUAL (%%PATHNAME-HOST PATHNAME1) (%%PATHNAME-HOST PATHNAME2)) (LET ((STRING-COMPARE (OR (FETCH (PATHNAMECASE STRING-COMPARE) OF (LOOKUP-PATHNAMECASE (%%PATHNAME-HOST PATHNAME1))) (QUOTE EQUAL)))) (AND (CL:FUNCALL STRING-COMPARE (%%PATHNAME-DEVICE PATHNAME1) (%%PATHNAME-DEVICE PATHNAME2)) (CL:FUNCALL STRING-COMPARE (%%PATHNAME-NAME PATHNAME1) (%%PATHNAME-NAME PATHNAME2)) (CL:FUNCALL STRING-COMPARE (%%PATHNAME-TYPE PATHNAME1) (%%PATHNAME-TYPE PATHNAME2)) (OR (EQUAL (%%PATHNAME-VERSION PATHNAME1) (%%PATHNAME-VERSION PATHNAME2)) (AND (OR (STRINGP (%%PATHNAME-VERSION PATHNAME1)) (CL:SYMBOLP (%%PATHNAME-VERSION PATHNAME1))) (OR (STRINGP (%%PATHNAME-VERSION PATHNAME2)) (CL:SYMBOLP (%%PATHNAME-VERSION PATHNAME2))) (CL:FUNCALL STRING-COMPARE (%%PATHNAME-VERSION PATHNAME1) (%%PATHNAME-VERSION PATHNAME2)))) (OR (AND (LISTP (%%PATHNAME-DIRECTORY PATHNAME1)) (LISTP (%%PATHNAME-DIRECTORY PATHNAME2)) (CL:EVERY STRING-COMPARE (%%PATHNAME-DIRECTORY PATHNAME1) (%%PATHNAME-DIRECTORY PATHNAME2))) (EQUAL (%%PATHNAME-DIRECTORY PATHNAME1) (%%PATHNAME-DIRECTORY PATHNAME2)))))))

(CL:DEFUN %%DIRECTORY-COMPONENT-EQUAL (COMPONENT1 COMPONENT2) (CL:IF (AND (%%DIRECTORY-COMPONENT-P COMPONENT1) (%%DIRECTORY-COMPONENT-P COMPONENT2)) (AND (CL:EQUAL (%%DIRECTORY-COMPONENT-TYPE COMPONENT1) (%%DIRECTORY-COMPONENT-TYPE COMPONENT2)) (CL:EQUAL (%%DIRECTORY-COMPONENT-PATH COMPONENT1) (%%DIRECTORY-COMPONENT-PATH COMPONENT2))) (CL:EQUAL COMPONENT1 COMPONENT2)))

(CL:DEFUN %%INITIALIZE-DEFAULT-PATHNAME NIL (* ;; "This mess used to have *DEFAULT-PATHNAME-DEFAULTS* declared as a GLOBALVAR.  The problem with that was that the BYTECOMPILER leaves the GLOBALVAR declaration in the environment as a side effect, which screws anything compiled afterwards.  *SIGH*... ") (DECLARE (GLOBALVARS \CONNECTED.DIRECTORY)) (if (NOT (BOUNDP (QUOTE \CONNECTED.DIRECTORY))) then (SETQ \CONNECTED.DIRECTORY (QUOTE {DSK}))) (SETTOPVAL (QUOTE *DEFAULT-PATHNAME-DEFAULTS*) (CL:PARSE-NAMESTRING \CONNECTED.DIRECTORY (FILENAMEFIELD \CONNECTED.DIRECTORY (QUOTE HOST)))) (CL:SETF (%%PATHNAME-VERSION (GETTOPVAL (QUOTE *DEFAULT-PATHNAME-DEFAULTS*))) :NEWEST) (GETTOPVAL (QUOTE *DEFAULT-PATHNAME-DEFAULTS*)))

(CL:DEFVAR *DEFAULT-PATHNAME-DEFAULTS*)

(CL:DEFVAR CL::*LOGICAL-PATHNAME-TRANSLATION-TABLE* (CL:MAKE-HASH-TABLE :TEST (CL:FUNCTION CL:EQUAL)))

(CL:DEFCONSTANT CL::LOGICAL-WORD-BITTABLE (MAKEBITTABLE (MAPCAR (QUOTE (A B C D E F G H I J K L M N O P Q R S T U V W X Y Z 0 1 2 3 4 5 6 7 8 9 - *)) (CL:FUNCTION CHARCODE)) T))

(CL:DEFVAR \HOSTTOPATHNAMECASE (* ;; "Assoc list relating hosts and their case preferences") (LIST (create PATHNAMECASE HOST-NAME _ (QUOTE DSK) STRING-COMPARE _ (QUOTE STRING-EQUAL) LOCAL-TO-COMMON _ (QUOTE FLIP-MONOCASE) COMMON-TO-LOCAL _ (QUOTE FLIP-MONOCASE)) (create PATHNAMECASE HOST-NAME _ (QUOTE CORE) STRING-COMPARE _ (QUOTE STRING-EQUAL) LOCAL-TO-COMMON _ (QUOTE FLIP-MONOCASE) COMMON-TO-LOCAL _ (QUOTE FLIP-MONOCASE)) (create PATHNAMECASE HOST-NAME _ (QUOTE UNIX) STRING-COMPARE _ (QUOTE CL:STRING=) LOCAL-TO-COMMON _ (QUOTE FLIP-MONOCASE) COMMON-TO-LOCAL _ (QUOTE FLIP-MONOCASE)) (create PATHNAMECASE HOST-NAME _ (QUOTE FLOPPY) STRING-COMPARE _ (QUOTE STRING-EQUAL) LOCAL-TO-COMMON _ (QUOTE FLIP-MONOCASE) COMMON-TO-LOCAL _ (QUOTE FLIP-MONOCASE))))



(* ;; "Interlisp-D compatibility")



(CL:DEFUN INTERLISP-NAMESTRING (PATHNAME) (* ;;; "Returns the full form of PATHNAME as an Interlisp string.") (MKSTRING (CL:NAMESTRING PATHNAME)))

(CL:DEFUN UNPACKPATHNAME.STRING (FILE &OPTIONAL ONEFIELDFLG DIRFLG ATOMFLG) (* ;; "Simulate the action of UNPACKFILENAME.STRING on a pathname") (* ;; "") (DECLARE (IGNORE DIRFLG)) (if ONEFIELDFLG then (AND (CL:CONSP ONEFIELDFLG) (SETQ ONEFIELDFLG (CAR (CL:INTERSECTION ONEFIELDFLG (QUOTE (HOST DEVICE DIRECTORY NAME EXTENSION VERSION)))))) (LET ((RESULT (CASE ONEFIELDFLG (HOST (CL:PATHNAME-HOST FILE)) (DEVICE (CL:PATHNAME-DEVICE FILE)) (DIRECTORY (CL:PATHNAME-DIRECTORY FILE)) (NAME (CL:PATHNAME-NAME FILE)) (EXTENSION (CL:PATHNAME-TYPE FILE)) (VERSION (CL:PATHNAME-VERSION FILE)) (CL:OTHERWISE NIL)))) (if ATOMFLG then (MKATOM RESULT) else RESULT)) else (LET ((COMPONENT)) (APPEND (if (SETQ COMPONENT (CL:PATHNAME-HOST FILE)) then (LIST (QUOTE HOST) (if ATOMFLG then (MKATOM COMPONENT) else COMPONENT) COMPONENT)) (if (SETQ COMPONENT (CL:PATHNAME-DEVICE FILE)) then (LIST (QUOTE DEVICE) (if ATOMFLG then (MKATOM COMPONENT) else COMPONENT))) (if (SETQ COMPONENT (CL:PATHNAME-DIRECTORY FILE)) then (LIST (QUOTE DIRECTORY) (if ATOMFLG then (MKATOM COMPONENT) else COMPONENT))) (if (SETQ COMPONENT (CL:PATHNAME-NAME FILE)) then (LIST (QUOTE NAME) (if ATOMFLG then (MKATOM COMPONENT) else COMPONENT))) (if (SETQ COMPONENT (CL:PATHNAME-TYPE FILE)) then (LIST (QUOTE EXTENSION) (if ATOMFLG then (MKATOM COMPONENT) else COMPONENT))) (if (SETQ COMPONENT (CL:PATHNAME-VERSION FILE)) then (LIST (QUOTE VERSION) (if ATOMFLG then (MKATOM COMPONENT) else (MKSTRING COMPONENT))))))))

(CL:DEFUN CL:FILE-NAMESTRING (PATHNAME) (LET* ((*PRINT-BASE* 10) (*PRINT-RADIX* NIL) (PATH (PATHNAME PATHNAME)) (NAME (CL::MUNG-PATHNAME-ELT (%%PATHNAME-NAME PATH))) (TYPE (CL::MUNG-PATHNAME-ELT (%%PATHNAME-TYPE PATH))) (RESULT (CL:CONCATENATE (QUOTE CL:SIMPLE-STRING) (MKSTRING (%%COMPONENT-STRING NAME)) "." (MKSTRING (%%COMPONENT-STRING TYPE)))) (VERSION (%%PATHNAME-VERSION PATH)) (CL::LOGICAL? (CL::LOGICAL-PATHNAME-P PATH))) (CL:WHEN (AND VERSION (NOT (EQ VERSION :UNSPECIFIC))) (SETQ RESULT (CL:CONCATENATE (QUOTE CL:SIMPLE-STRING) RESULT (CL:IF CL::LOGICAL? "." (CL:THIRD \FILENAME.SYNTAX)) (CASE VERSION (:WILD "*") (:NEWEST (CL:IF CL::LOGICAL? "NEWEST")) (CL:OTHERWISE (CL:PRINC-TO-STRING VERSION)))))) RESULT))

(CL:DEFUN CL:DIRECTORY-NAMESTRING (PATHNAME) (* ;; "Returns the directory part of PATHNAME as a string.") (LET ((CL::DL (CL:PATHNAME-DIRECTORY PATHNAME))) (CASE CL::DL ((:UNSPECIFIC NIL) "") (CL:OTHERWISE (LET ((CL::SEPERATOR (CL:IF (CL::LOGICAL-PATHNAME-P PATHNAME) ";" (CL:SECOND \FILENAME.SYNTAX)))) (CL:LABELS ((CL::CRUNCH-ELEMENTS (CL::L) (CL:IF (NULL (CDR CL::L)) (CL::MUNG-PATHNAME-ELT (CAR CL::L)) (CL:CONCATENATE (QUOTE STRING) (CL::MUNG-PATHNAME-ELT (CAR CL::L)) CL::SEPERATOR (CL::CRUNCH-ELEMENTS (CDR CL::L)))))) (CL:CONCATENATE (QUOTE STRING) (CL::CRUNCH-ELEMENTS (CDR CL::DL)) (AND (EQ (CAR CL::DL) :RELATIVE) CL::SEPERATOR))))))))



(* ;; 
"Backward compatibility with old directory-components (superceded by CLtL2 list-structured components)"
)



(CL:DEFUN %%CONVERT-DIRECTORY-COMPONENT (DC) (* ;; "Takes a DIRECTORY-COMPONENT and returns a CLtL2-style structured directory list") (SELECTQ (%%DIRECTORY-COMPONENT-TYPE DC) (:RELATIVE (LET ((PDP (%%PARSE-DIRECTORY-PATH (%%DIRECTORY-COMPONENT-PATH DC)))) (IF (LISTP PDP) THEN (CONS :RELATIVE PDP) ELSE (LIST :RELATIVE PDP)))) (:DIRECTORY (LET ((PDP (%%PARSE-DIRECTORY-PATH (%%DIRECTORY-COMPONENT-PATH DC)))) (IF (LISTP PDP) THEN (CONS :ABSOLUTE PDP) ELSE (LIST :ABSOLUTE PDP)))) (ERROR "Funky directory-component type" (%%DIRECTORY-COMPONENT-TYPE DC))))



(* ;; "Funky pattern matcher for logical pathname support")



(CL:DEFUN CL::MATCH&MAP (CL::PAT CL::STR) (* ;; "PAT and STR are strings; PAT contains one or more * wildcards.The result, *MAP* is a list of (startchar . endchar) pairs of the pieces of STR that match the wildcards in PAT. (< endchar startchar) means that wildcard matched the null string") (LET ((CL::*MAP* NIL)) (DECLARE (CL:SPECIAL CL::*MAP*)) (AND (CL::MM1 CL::PAT 0 CL::STR 0) CL::*MAP*)))

(CL:DEFUN CL::MM1 (CL::PAT CL::PP CL::STR CL::SP) (COND ((AND (>= CL::PP (CL:LENGTH CL::PAT)) (>= CL::SP (CL:LENGTH CL::STR)))) ((OR (>= CL::PP (CL:LENGTH CL::PAT)) (>= CL::SP (CL:LENGTH CL::STR))) NIL) ((EQL (CL:CHAR CL::PAT CL::PP) #\*) (LET ((CL::STAREND CL::SP) (CL::PP+1 (CL:1+ CL::PP)) CL::MATCHED?) (CL:IF (EQ CL::PP+1 (CL:LENGTH CL::PAT)) (CL:SETQ CL::MATCHED? T CL::STAREND (CL:LENGTH CL::STR)) (WHILE (AND (< CL::STAREND (CL:LENGTH CL::STR)) (NULL (CL:SETQ CL::MATCHED? (CL::MM1 CL::PAT CL::PP+1 CL::STR CL::STAREND)))) DO (CL:INCF CL::STAREND))) (CL:IF CL::MATCHED? (CL:PUSH (CONS CL::SP CL::STAREND) CL::*MAP*)))) ((AND (EQL (CL:CHAR CL::PAT CL::PP) (CL:CHAR CL::STR CL::SP)) (CL::MM1 CL::PAT (CL:1+ CL::PP) CL::STR (CL:1+ CL::SP))))))

(CL:DEFUN CL::MATCH-DIRECTORY-LISTS (CL::P CL::W) (CL:IF (AND (OR (CL:EQUAL CL::W (QUOTE (:ABSOLUTE :WILD-INFERIORS))) (CL:EQUAL CL::W (QUOTE (:RELATIVE :WILD-INFERIORS)))) (EQ (CAR CL::P) (CAR CL::W))) (CL:VALUES T (LIST (CONS 1 (CL:LENGTH CL::P)))) (LET ((CL::*MAP* NIL)) (DECLARE (CL:SPECIAL CL::*MAP*)) (CL:IF (CL::MDL1 CL::P 0 CL::W) (CL:VALUES T CL::*MAP*)))))

(CL:DEFUN CL::MDL1 (CL::P CL::PL CL::W) (COND ((AND (NULL CL::P) (NULL CL::W))) ((OR (NULL CL::P) (NULL CL::W)) NIL) ((EQ (CAR CL::W) :WILD) (AND (CL::MDL1 (CDR CL::P) (CL:1+ CL::PL) (CDR CL::W)) (CL:PUSH (CONS CL::PL (CL:1+ CL::PL)) CL::*MAP*))) ((CL:EQUAL (CAR CL::P) (CAR CL::W)) (CL::MDL1 (CDR CL::P) (CL:1+ CL::PL) (CDR CL::W))) ((EQ (CAR CL::W) :WILD-INFERIORS) (LET ((CL::PS CL::PL) CL::MATCHED) (CL:IF (NULL (CDR CL::W)) (CL:PUSH (CONS CL::PL (+ CL::PL (CL:LENGTH CL::P))) CL::*MAP*) (PROGN (WHILE (AND CL::P (NULL (CL:SETQ CL::MATCHED (CL::MDL1 CL::P CL::PL (CDR CL::W))))) DO (CL:INCF CL::PL) (CL:POP CL::P)) (CL:IF CL::MATCHED (CL:PUSH (CONS CL::PS CL::PL) CL::*MAP*)))))) ((AND (CL:STRINGP (CAR CL::P)) (CL:STRINGP (CAR CL::W))) (LET ((CL::MM (CL::MATCH&MAP (CAR CL::W) (CAR CL::P)))) (CL:WHEN (AND CL::MM (CL::MDL1 (CDR CL::P) (CL:1+ CL::PL) (CDR CL::W))) (CL:PUSH (CONS CL::PL CL::MM) CL::*MAP*))))))



(* ;; "Direct logical pathname support")



(DEF-DEFINE-TYPE CL::LOGICAL-HOSTS "Logical hosts" :UNDEFINER CL::UNDEFINE-LOGICAL-HOST)

(DEFDEFINER CL::DEF-LOGICAL-HOST CL::LOGICAL-HOSTS (CL::HOST &REST CL::TRANSFORMS) (BQUOTE (CL:SETF (CL:LOGICAL-PATHNAME-TRANSLATIONS (\, CL::HOST)) (QUOTE (\, CL::TRANSFORMS)))))

(CL:DEFUN CL::UNDEFINE-LOGICAL-HOST (CL::HOST) (CL:SETF (CL:LOGICAL-PATHNAME-TRANSLATIONS CL::HOST) NIL))

(CL:DEFUN CL:LOGICAL-PATHNAME-TRANSLATIONS (CL::HOST) (COND ((AND (CL:STRINGP CL::HOST) (CL:GETHASH (U-CASE CL::HOST) CL::*LOGICAL-PATHNAME-TRANSLATION-TABLE*))) (T (CL:ERROR "Not a logical host:~s" CL::HOST))))

(CL:DEFUN CL::UNDOABLY-SETF-LOGICAL-PATHNAME-TRANSLATIONS (CL::HOST CL::TRANSLATIONS) (UNDOABLY-SETF (CL:GETHASH (U-CASE CL::HOST) CL::*LOGICAL-PATHNAME-TRANSLATION-TABLE*) CL::TRANSLATIONS))

(CL:DEFSETF CL:LOGICAL-PATHNAME-TRANSLATIONS (CL::HOST) (CL::TRANSLATIONS) (BQUOTE (CL:SETF (CL:GETHASH (U-CASE (\, CL::HOST)) CL::*LOGICAL-PATHNAME-TRANSLATION-TABLE*) (\, CL::TRANSLATIONS))))

(PUTPROPS CL:LOGICAL-PATHNAME-TRANSLATIONS :UNDOABLE-SETF-INVERSE CL::UNDOABLY-SETF-LOGICAL-PATHNAME-TRANSLATIONS)

(CL:DEFUN CL::LOGICAL-HOST-P (CL::HOST) (AND (CL:GETHASH (U-CASE CL::HOST) CL::*LOGICAL-PATHNAME-TRANSLATION-TABLE*) T))

(CL:DEFUN CL::MUNG-PATHNAME-ELT (CL::X) (CASE CL::X (:WILD "*") (:WILD-INFERIORS "**") (:BACK "..") (:UNSPECIFIC NIL) (T CL::X)))

(CL:DEFUN CL:LOGICAL-PATHNAME (PATHNAME) (CL:FLET ((CL::LOGICAL-PATHNAME-STREAM-P (CL::S) (CL::LOGICAL-PATHNAME-P (PATHNAME CL::S)))) (CL:ETYPECASE PATHNAME (CL:LOGICAL-PATHNAME PATHNAME) ((AND STREAM (SATISFIES CL::LOGICAL-PATHNAME-STREAM-P)) (PATHNAME PATHNAME)) ((OR CL:SYMBOL STRING) (CL:WHEN (CL:SYMBOLP PATHNAME) (CL:WHEN (OR *CLTL2-PEDANTIC* (NULL PATHNAME)) (XCL::SYMBOL-AS-PATHNAME PATHNAME (QUOTE CL:LOGICAL-PATHNAME))) (CL:SETQ PATHNAME (CL:SYMBOL-NAME PATHNAME))) (CL:PARSE-NAMESTRING PATHNAME NIL NIL :LOGICAL T)))))

(CL:DEFUN CL:PATHNAME-MATCH-P (PATHNAME CL::WILDNAME) (* ;; "Minor extension; if a match fails, return (VALUES NIL :keyword) where :keyword points to the slot that failed.  The messy nested IF below allows the mulitple-values to return") (CL:SETQ PATHNAME (PATHNAME PATHNAME)) (CL:SETQ CL::WILDNAME (PATHNAME CL::WILDNAME)) (LET ((CL::UPCASE? T)) (CL:FLET ((CL::MATCH-SIMPLE-SLOTS (CL::P CL::W) (COND ((NULL CL::W)) ((EQ CL::W :WILD)) ((EQ CL::W :UNSPECIFIC) (EQ CL::P :UNSPECIFIC)) ((CL:EQUAL CL::W CL::P)) ((CL:STRINGP CL::W) (AND (CL:STRINGP CL::P) (OR (AND CL::UPCASE? (STRING-EQUAL CL::P CL::W)) (CL::MATCH&MAP (CL:IF CL::UPCASE? (U-CASE-STRINGS CL::W) CL::W) (CL:IF CL::UPCASE? (U-CASE-STRINGS CL::P) CL::P)))))))) (CL:IF (CL::MATCH-SIMPLE-SLOTS (%%PATHNAME-HOST PATHNAME) (%%PATHNAME-HOST CL::WILDNAME)) (PROGN (CL:SETQ CL::UPCASE? (EQ (QUOTE STRING-EQUAL) (FETCH (PATHNAMECASE STRING-COMPARE) OF (LOOKUP-PATHNAMECASE (CL:PATHNAME-HOST PATHNAME))))) (CL:IF (CL::MATCH-SIMPLE-SLOTS (%%PATHNAME-DEVICE PATHNAME) (%%PATHNAME-DEVICE CL::WILDNAME)) (CL:IF (CL::MATCH-SIMPLE-SLOTS (%%PATHNAME-NAME PATHNAME) (%%PATHNAME-NAME CL::WILDNAME)) (CL:IF (CL::MATCH-SIMPLE-SLOTS (%%PATHNAME-TYPE PATHNAME) (%%PATHNAME-TYPE CL::WILDNAME)) (CL:IF (CL::MATCH-SIMPLE-SLOTS (%%PATHNAME-VERSION PATHNAME) (%%PATHNAME-VERSION CL::WILDNAME) :VERSION) (LET ((CL::P (%%PATHNAME-DIRECTORY PATHNAME)) (CL::W (%%PATHNAME-DIRECTORY CL::WILDNAME))) (COND ((NULL CL::W)) ((AND (EQ CL::W :UNSPECIFIC) (EQ CL::P :UNSPECIFIC))) ((AND (CL:LISTP CL::P) (CL:LISTP CL::W) (CL::MATCH-DIRECTORY-LISTS (CL:IF CL::UPCASE? (U-CASE-STRINGS CL::P) CL::P) (CL:IF CL::UPCASE? (U-CASE-STRINGS CL::W) CL::W)))) (T (CL:VALUES NIL :DIRECTORY)))) (CL:VALUES NIL :VERSION)) (CL:VALUES NIL :TYPE)) (CL:VALUES NIL :NAME)) (CL:VALUES NIL :DEVICE))) (CL:VALUES NIL :HOST)))))

(CL:DEFUN CL:TRANSLATE-LOGICAL-PATHNAME (PATHNAME &KEY &ALLOW-OTHER-KEYS) (CL:ETYPECASE PATHNAME (PATHNAME) (STREAM (CL:SETQ PATHNAME (PATHNAME PATHNAME))) ((OR CL:SYMBOL STRING) (CL:WHEN (CL:SYMBOLP PATHNAME) (CL:WHEN (OR *CLTL2-PEDANTIC* (NULL PATHNAME)) (XCL::SYMBOL-AS-PATHNAME PATHNAME (QUOTE CL:TRANSLATE-LOGICAL-PATHNAME))) (CL:SETQ PATHNAME (CL:SYMBOL-NAME PATHNAME))) (* ;; "Minor hackish extension here.  If PATHNAME is a string and it begins with %"mumble:%" where mumble is a known logical hostname, try parsing it as a logical pathname string") (CL:SETQ PATHNAME (U-CASE PATHNAME)) (LET* ((CL::COLONLOC (STRPOSL CL::LOGICAL-WORD-BITTABLE PATHNAME)) (CL::HOSTNAME (AND CL::COLONLOC (CL:EQUAL (SUBSTRING PATHNAME CL::COLONLOC CL::COLONLOC) ":") (SUBSTRING PATHNAME 1 (CL:1- CL::COLONLOC))))) (CL:SETQ PATHNAME (CL:IF (CL::LOGICAL-HOST-P CL::HOSTNAME) (CL:PARSE-NAMESTRING PATHNAME CL::HOSTNAME) (PATHNAME PATHNAME)))))) (WHILE (CL::LOGICAL-PATHNAME-P PATHNAME) DO (FOR CL::TR IN (CL:LOGICAL-PATHNAME-TRANSLATIONS (CL:PATHNAME-HOST PATHNAME)) BIND CL::LPN WHEN (CL:PATHNAME-MATCH-P PATHNAME (CL:SETQ CL::LPN (CL:LOGICAL-PATHNAME (CAR CL::TR)))) DO (CL:SETQ PATHNAME (CL:TRANSLATE-PATHNAME PATHNAME CL::LPN (CADR CL::TR))) (RETURN NIL) FINALLY (CL:ERROR "~S doesn't match any LOGICAL-PATHNAME-TRANSLATIONS" PATHNAME))) PATHNAME)

(CL:DEFUN CL:TRANSLATE-PATHNAME (CL::SOURCE CL::FROM-WILDNAME CL::TO-WILDNAME) (CL:SETQ CL::SOURCE (PATHNAME CL::SOURCE) CL::FROM-WILDNAME (PATHNAME CL::FROM-WILDNAME)) (CL:UNLESS (CL:PATHNAME-MATCH-P CL::SOURCE CL::FROM-WILDNAME) (CL:ERROR "~S doesn't match ~S in TRANSLATE-PATHNAME" CL::SOURCE CL::FROM-WILDNAME)) (CL:SETQ CL::TO-WILDNAME (PATHNAME CL::TO-WILDNAME)) (* ;; "NOTE: this mess currently does nothing about case mangling; this must be handled somewhere") (* ;; "This mess translates according to the suggested implementation in CLtL2: corresponding parts of pathnames are merged seperately and directory components are merged by order,not by correspondence of subdirectory entry") (* ;; "Example: (TRANSLATE-PATHNAME %"/foo/bar/baz%" %"/foo/*a*/*%" %"/a/*/*/c*%") => #P%"/a/b/r/cbaz%"") (* ;; "Two fairly obvious restrictions on the above are imposed:") (* ;; "A :WILD-INFERIORS matching multiple directory levels will not be used to fill in a :WILD or a * wildcard") (* ;; "Anything matching NIL will not fill in a :WILD or a :WILD-INFERIORS") (CL:LABELS ((CL::MERGE-FROM-MAP (CL:MAP CL::S CL::TW) (* ;; "Some sort of funky loop here walking down the map and picking chunks out of s and gluing them into tw") (LET ((CL::TS 0) CL::TP (CL::RESULT "")) (WHILE (AND CL:MAP (CL:SETQ CL::TP (CL:POSITION #\* CL::TW :START CL::TS))) DO (DESTRUCTURING-BIND (CL::SS . CL::SE) (CL:POP CL:MAP) (CL:IF (<= CL::SS CL::SE) (CL:SETQ CL::RESULT (CL:CONCATENATE (QUOTE STRING) CL::RESULT (AND (< CL::TS CL::TP) (CL:SUBSEQ CL::TW CL::TS CL::TP)) (CL:SUBSEQ CL::S CL::SS CL::SE)))) (CL:SETQ CL::TS (CL:1+ CL::TP)))) (CL:IF (< CL::TS (CL:LENGTH CL::TW)) (CL:SETQ CL::RESULT (CL:CONCATENATE (QUOTE STRING) CL::RESULT (CL:SUBSEQ CL::TW CL::TS)))) (CL:VALUES CL::RESULT CL:MAP))) (CL::MERGE-STRINGY-SLOT (CL::S CL::FW CL::TW) (COND ((OR (NULL CL::TW) (EQ CL::TW :WILD)) CL::S) ((AND (CL:STRINGP CL::TW) (STRPOS "*" CL::TW)) (CL:IF (CL:STRINGP CL::S) (LET ((CL:MAP (COND ((OR (EQ CL::FW :WILD) (AND (CL:STRINGP CL::FW) (CL:STRING= CL::S CL::FW))) (BQUOTE ((0 \, (CL:LENGTH CL::S))))) ((STRPOS "*" CL::FW) (CL::MATCH&MAP CL::FW CL::S))))) (CL:IF (NULL CL:MAP) (CL:ERROR "From-wildname piece and source piece don't match" CL::FW CL::S) (CL::MERGE-FROM-MAP CL:MAP CL::S CL::TW))) (CL:ERROR "Can't take anything from ~s to translate" CL::S))) (T CL::TW)))) (CL:MACROLET ((CL::CALL-WITH-THREE (CL::FETCHER) (BQUOTE (CL::MERGE-STRINGY-SLOT ((\, CL::FETCHER) CL::SOURCE) ((\, CL::FETCHER) CL::FROM-WILDNAME) ((\, CL::FETCHER) CL::TO-WILDNAME))))) (CL:MAKE-PATHNAME :HOST (CL::CALL-WITH-THREE CL:PATHNAME-HOST) :DEVICE (CL::CALL-WITH-THREE CL:PATHNAME-DEVICE) :NAME (CL::CALL-WITH-THREE CL:PATHNAME-NAME) :TYPE (CL::CALL-WITH-THREE CL:PATHNAME-TYPE) :VERSION (CL::CALL-WITH-THREE CL:PATHNAME-VERSION) :DIRECTORY (LET ((CL::S (CL:PATHNAME-DIRECTORY CL::SOURCE)) (CL::FW (CL:PATHNAME-DIRECTORY CL::FROM-WILDNAME)) (CL::TW (CL:PATHNAME-DIRECTORY CL::TO-WILDNAME)) CL::PIECES CL::RESULT) (COND ((OR (NULL CL::TW) (CL:EQUAL CL::TW (QUOTE (:ABSOLUTE :WILD-INFERIORS)))) CL::S) ((OR (NOT (CL:LISTP CL::TW)) (CL:EVERY (CL:FUNCTION (CL:LAMBDA (CL::X) (AND (NOT (EQ CL::X :WILD)) (NOT (EQ CL::X :WILD-INFERIORS)) (OR (NOT (CL:STRINGP CL::X)) (NOT (STRPOS "*" CL::X)))))) (CDR CL::TW))) CL::TW) (T (CL:UNLESS (CL:CONSP CL::S) (CL:ERROR "Can't take anything from ~s to translate" CL::S)) (CL:WHEN (OR (NOT (CL:CONSP CL::FW)) (EQ CL::FW (QUOTE (:ABSOLUTE :WILD-INFERIORS)))) (CL:ERROR "Can't map this mess: ~s" CL::FW)) (* ;; "Well, we seem to have a sane set of directories; let's try and make some sense of them") (CL:FLET ((CL::POP-A-PIECE NIL (CL:WHEN (NULL CL::PIECES) (CL:ERROR "Ran out of wildcards in TRANSLATE-PATHNAME")) (DESTRUCTURING-BIND (CL:ELT . CL:MAP) (CAR CL::PIECES) (COND ((CL:NUMBERP CL:MAP) (CL:POP CL::PIECES) (COND ((EQ CL:ELT CL:MAP) NIL) ((EQ CL:ELT (CL:1- CL:MAP)) (CL:ELT CL::S CL:ELT)) (T (CL:SUBSEQ CL::S CL:ELT CL:MAP)))) (T (DESTRUCTURING-BIND (CL::SS . CL::SE) (CL:POP CL:MAP) (PROG1 (CL:IF (< CL::SE CL::SS) NIL (CL:SUBSEQ (CL:ELT CL::S CL:ELT) CL::SS CL::SE)) (CL:IF (NULL CL:MAP) (CL:POP CL::PIECES) (CL:POP (CDAR CL::PIECES)))))))))) (CL:MULTIPLE-VALUE-SETQ (CL::RESULT CL::PIECES) (CL::MATCH-DIRECTORY-LISTS CL::S CL::FW)) (CL:IF CL::RESULT (CL:SETQ CL::RESULT NIL) (CL:ERROR "How can these not match?  They matched a minute ago:~S ~S" CL::S CL::FW)) (* ;; "OK; PIECES is a list of references to parts of S.  They are either (start-element . end-element) or (start-element (map . pair)...).  We now walk TP, filling in its wild elements from PIECES") (CL:DO* ((CL::TP (CDR CL::TW) (CDR CL::TP)) (CL::TF (CAR CL::TP) (CAR CL::TP)) (CL::PP) (CL::STARPOS) (CL::OLDSTAR) (CL::ELTLIST)) ((NULL CL::TP) (CONS (CAR CL::S) (CL:NREVERSE CL::RESULT))) (COND ((EQ CL::TF :WILD-INFERIORS) (COND ((CL:CONSP (CL:SETQ CL::PP (CL::POP-A-PIECE))) (CL:DOLIST (CL::P CL::PP) (CL:PUSH CL::P CL::RESULT))) ((NULL CL::PP) (CL:ERROR "NIL can't match :WILD-INFERIORS")) (T (CL:PUSH CL::PP CL::RESULT)))) ((EQ CL::TF :WILD) (COND ((CL:CONSP (CL:SETQ CL::PP (CL::POP-A-PIECE))) (CL:ERROR "Multiple directory levels ~s can't match :WILD" CL::PP)) ((NULL CL::PP) (CL:ERROR "NIL can't match :WILD-INFERIORS")) (T (CL:PUSH CL::PP CL::RESULT)))) ((CL:SETQ CL::STARPOS (CL:POSITION #\* CL::TF)) (CL:SETQ CL::ELTLIST NIL) (CL:SETQ CL::OLDSTAR 0) (WHILE CL::STARPOS DO (CL:PUSH (CL:SUBSEQ CL::TF CL::OLDSTAR CL::STARPOS) CL::ELTLIST) (CL:WHEN (NULL (CAR CL::ELTLIST)) (CL:POP CL::ELTLIST)) (CL:PUSH (CL:SETQ CL::PP (CL::POP-A-PIECE)) CL::ELTLIST) (CL:WHEN (CL:LISTP CL::PP) (CL:ERROR "Can't match *: ~s" CL::PP)) (CL:SETQ CL::OLDSTAR (CL:1+ CL::STARPOS)) (CL:SETQ CL::STARPOS (CL:POSITION #\* CL::TF :START CL::OLDSTAR)) FINALLY (CL:IF (< CL::OLDSTAR (CL:LENGTH CL::TF)) (CL:PUSH (CL:SUBSEQ CL::TF CL::OLDSTAR) CL::ELTLIST)) (CL:PUSH (CL:APPLY (CL:FUNCTION CL:CONCATENATE) (CONS (QUOTE STRING) (CL:NREVERSE CL::ELTLIST))) CL::RESULT))) (T (CL:PUSH CL::TF CL::RESULT))))))))))))

(CL:DEFUN CL:LOAD-LOGICAL-PATHNAME-TRANSLATIONS (CL::HOST) (CL:UNLESS (CL:STRINGP CL::HOST) (CL:ERROR "~S not a string" CL::HOST)) (CL:UNLESS (CL::LOGICAL-HOST-P CL::HOST) (CL:DOLIST (CL::PLACE (QUOTE ("LOGICAL-HOSTS" "{DSK}~/LOGICAL-HOSTS" "{DSK}/usr/local/lde/LOGICAL-HOSTS"))) (* ;; "We'll look in 1) the current directory 2) the user's home directory 3) {DSK}<usr>local>lde> for a file named LOGICAL-HOSTS which is then LOADed; it may contain (SETF (LOGICAL-PATHNAME-TRANSLATIONS host) '((trans lations))) forms or LOGICAL-HOSTS filecom forms") (CL:WHEN (CL:PROBE-FILE CL::PLACE) (CL:LOAD CL::PLACE) (CL:IF (CL::LOGICAL-HOST-P CL::HOST) (CL:RETURN-FROM CL:LOAD-LOGICAL-PATHNAME-TRANSLATIONS T)))) (CL:ERROR "Found no translations for ~s" CL::HOST)))

(CL:DEFUN CL:WILD-PATHNAME-P (PATHNAME &OPTIONAL CL::FIELD-KEY) (CL:SETQ PATHNAME (PATHNAME PATHNAME)) (CL:FLET ((CL::WILD-VALUE (CL::V) (OR (EQ CL::V :WILD) (AND (CL:STRINGP CL::V) (STRPOS "*" CL::V) T))) (CL::WILD-DIR-VALUE (CL::V) (OR (EQ CL::V :WILD) (EQ CL::V :WILD-INFERIORS) (AND (CL:STRINGP CL::V) (STRPOS "*" CL::V) T)))) (CL:ECASE CL::FIELD-KEY (:HOST (CL::WILD-VALUE (CL:PATHNAME-HOST PATHNAME))) (:DEVICE (CL::WILD-VALUE (CL:PATHNAME-DEVICE PATHNAME))) (:NAME (CL::WILD-VALUE (CL:PATHNAME-NAME PATHNAME))) (:TYPE (CL::WILD-VALUE (CL:PATHNAME-TYPE PATHNAME))) (:VERSION (CL::WILD-VALUE (CL:PATHNAME-VERSION PATHNAME))) (:DIRECTORY (AND (CL:CONSP (CL:PATHNAME-DIRECTORY PATHNAME)) (CL:SOME (CL:FUNCTION CL::WILD-DIR-VALUE) (CL:PATHNAME-DIRECTORY PATHNAME)))) ((NIL) (OR (CL::WILD-VALUE (CL:PATHNAME-HOST PATHNAME)) (CL::WILD-VALUE (CL:PATHNAME-DEVICE PATHNAME)) (CL::WILD-VALUE (CL:PATHNAME-NAME PATHNAME)) (CL::WILD-VALUE (CL:PATHNAME-TYPE PATHNAME)) (CL::WILD-VALUE (CL:PATHNAME-VERSION PATHNAME)) (AND (CL:CONSP (CL:PATHNAME-DIRECTORY PATHNAME)) (CL:SOME (CL:FUNCTION CL::WILD-DIR-VALUE) (CL:PATHNAME-DIRECTORY PATHNAME))))))))

(CL:DEFUN LOOKUP-PATHNAMECASE (HOST) (* ;; "Returns a PATHNAMECASE record corresponding to HOST; also registers HOST on \HOSTTOPATHNAMECASE list.  Default registration is case-sensitive comparison and monocase-string case inversion.  The initial value of \HOSTTOPATHNAMECASE will handle the most common devices (DSK, UNIX, FLOPPY), and we have special hacks checking for NS and PUP hosts, so users should only have to register stuff like TCP and NFS devices.") (CL:FLET ((LOOKITUP (HOST) (COND ((FASSOC HOST \HOSTTOPATHNAMECASE)) ((OR (STRPOS ":" HOST) (ETHERHOSTNUMBER HOST)) (PUSH \HOSTTOPATHNAMECASE (create PATHNAMECASE HOST-NAME _ HOST STRING-COMPARE _ (QUOTE STRING-EQUAL) LOCAL-TO-COMMON _ (QUOTE FLIP-MONOCASE-STRING) COMMON-TO-LOCAL _ (QUOTE FLIP-MONOCASE-STRING))) (CAR \HOSTTOPATHNAMECASE))))) (* ;; "The perverse structure is here to try and avoid calling CANONICAL.HOSTNAME unless absolutely necessary; it's SLOW") (IF (OR (EQ HOST :WILD) (STRPOS "*" HOST)) THEN (CONSTANT (create PATHNAMECASE HOST-NAME _ NIL STRING-COMPARE _ (QUOTE CL:STRING=) LOCAL-TO-COMMON _ (QUOTE CL:IDENTITY) COMMON-TO-LOCAL _ (QUOTE CL:IDENTITY))) ELSE (SETQ HOST (U-CASE HOST)) (IF (CL::LOGICAL-HOST-P HOST) THEN (CONSTANT (create PATHNAMECASE HOST-NAME _ NIL STRING-COMPARE _ (QUOTE STRING-EQUAL) LOCAL-TO-COMMON _ (QUOTE CL:IDENTITY) COMMON-TO-LOCAL _ (CL:FUNCTION (LAMBDA (X) (if (STRINGP X) then (U-CASE X) else X))))) ELSE (SETQ HOST (MKATOM HOST)) (LET (CH) (COND ((LOOKITUP HOST)) ((AND (SETQ CH (CANONICAL.HOSTNAME HOST)) (LOOKITUP CH))) (T (* ; "Punt and assume case-sensitivity") (PUSH \HOSTTOPATHNAMECASE (create PATHNAMECASE HOST-NAME _ HOST STRING-COMPARE _ (QUOTE EQUAL) LOCAL-TO-COMMON _ (QUOTE FLIP-MONOCASE-STRING) COMMON-TO-LOCAL _ (QUOTE FLIP-MONOCASE-STRING))) (CAR \HOSTTOPATHNAMECASE))))))))

(CL:DEFUN REGISTER-PATHNAMECASE (HOST/DEVICE &KEY (STRING-COMPARE (QUOTE CL:STRING=) S-P) (LOCAL-TO-COMMON (QUOTE FLIP-MONOCASE-STRING) L-P) (COMMON-TO-LOCAL (QUOTE FLIP-MONOCASE-STRING) C-P) CASE-INSENSITIVE) (SETQ HOST/DEVICE (OR (CANONICAL.HOSTNAME HOST/DEVICE) (MKATOM HOST/DEVICE))) (CL:WHEN CASE-INSENSITIVE (CL:UNLESS S-P (SETQ STRING-COMPARE (QUOTE STRING-EQUAL))) (CL:UNLESS L-P (SETQ LOCAL-TO-COMMON (QUOTE FLIP-MONOCASE-STRING))) (CL:UNLESS C-P (SETQ COMMON-TO-LOCAL (QUOTE FLIP-MONOCASE-STRING)))) (LET ((OLDREC (FASSOC HOST/DEVICE \HOSTTOPATHNAMECASE))) (IF OLDREC THEN (REPLACE (PATHNAMECASE STRING-COMPARE) OF OLDREC WITH STRING-COMPARE) (REPLACE (PATHNAMECASE LOCAL-TO-COMMON) OF OLDREC WITH LOCAL-TO-COMMON) (REPLACE (PATHNAMECASE COMMON-TO-LOCAL) OF OLDREC WITH COMMON-TO-LOCAL) ELSE (PUSH \HOSTTOPATHNAMECASE (create PATHNAMECASE HOST-NAME _ HOST/DEVICE STRING-COMPARE _ STRING-COMPARE LOCAL-TO-COMMON _ LOCAL-TO-COMMON COMMON-TO-LOCAL _ COMMON-TO-LOCAL)))))

(CL:DEFUN UNREGISTER-PATHNAMECASE (HOST/DEVICE) (SETQ \HOSTTOPATHNAMECASE (CL:DELETE HOST/DEVICE \HOSTTOPATHNAMECASE :KEY (CL:FUNCTION CAR))))
(DEFINEQ

(UNPACKLOGICALNAME.STRING

(LAMBDA (STRING HOST) (* ; "Edited  3-Aug-91 09:45 by jrb:") (* ;;; "Unpacks the logical-pathname string STRING into a plist similar to that produced by UNPACKFILENAME.STRING") (LET ((RESULT (LIST (QUOTE HOST) HOST (QUOTE DEVICE) :UNSPECIFIC)) (TBL CL::LOGICAL-WORD-BITTABLE) DELIM DIR) (SETQ STRING (U-CASE STRING)) (SETQ DELIM (STRPOSL TBL STRING)) (* ;; "First check for HOST:") (CL:FLET ((GRAB-PIECE (TAG) (* ;; "Conventions:") (* ;; "DELIM == (CL:1+ (CL:LENGTH STRING)) - string contains no delimiters and will be the last piece") (* ;; "DELIM == NIL - string is empty") (IF (= DELIM (CL:1+ (CL:LENGTH STRING))) THEN (LISTPUT RESULT TAG STRING) (SETQ STRING "") (SETQ DELIM NIL) ELSE (LISTPUT RESULT TAG (SUBSTRING STRING 1 (CL:1- DELIM))) (IF (SUBSTRING STRING (CL:1+ DELIM) NIL STRING) THEN (SETQ DELIM (OR (STRPOSL TBL STRING) (CL:1+ (CL:LENGTH STRING)))) ELSE (SETQ STRING "") (SETQ DELIM NIL))))) (CL:WHEN (AND DELIM (EQUAL (SUBSTRING STRING DELIM DELIM) ":")) (GRAB-PIECE (QUOTE HOST))) (CL:WHEN (AND HOST (NOT (EQUAL HOST (LISTGET RESULT (QUOTE HOST))))) (CL:ERROR "Host argument ~s doesn't match logical pathname string host ~s" HOST (LISTGET RESULT (QUOTE HOST)))) (* ;; "Then [;]{DIRECTORY ;}*") (CL:WHEN (AND DELIM (EQUAL (SUBSTRING STRING DELIM DELIM) ";")) (SETQ DIR (CL:IF (EQ DELIM 1) (QUOTE DIRECTORY) (QUOTE RELATIVEDIRECTORY))) (WHILE (AND (SETQ DELIM (STRPOSL TBL STRING (CL:1+ DELIM))) (EQUAL (SUBSTRING STRING DELIM DELIM) ";")) BIND WHERE2 _ DELIM DO (SETQ WHERE2 DELIM) FINALLY (PROGN (LISTPUT RESULT DIR (SUBSTRING STRING (CL:IF (EQ DIR (QUOTE DIRECTORY)) 2 1) (CL:1- WHERE2))) (IF (= WHERE2 (CL:LENGTH STRING)) THEN (SETQ STRING "") (SETQ DELIM NIL) ELSE (SUBSTRING STRING (CL:1+ WHERE2) NIL STRING) (SETQ DELIM (STRPOSL TBL STRING)))))) (* ;; "Then [NAME] [ . TYPE [ .VERSION]]") (CL:WHEN DELIM (GRAB-PIECE (QUOTE NAME))) (CL:WHEN DELIM (GRAB-PIECE (QUOTE EXTENSION)) (CL:WHEN (NOT (EQUAL STRING "")) (LISTPUT RESULT (QUOTE VERSION) (CL:IF (EQUAL STRING "NEWEST") :NEWEST STRING)) (SETQ STRING "") (SETQ DELIM NIL)))) (CL:WHEN (AND (NULL DELIM) (NOT (EQUAL STRING ""))) (LISTPUT RESULT (QUOTE NAME) STRING)) RESULT))
)
)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(%%INITIALIZE-DEFAULT-PATHNAME)
)
(DEFINEQ

(FLIP-MONOCASE

(LAMBDA (X) (* ; "Edited  6-Aug-91 19:53 by jrb:") (if (OR (U-CASEP X) (L-CASEP X)) then (FLIP-CASE X) else X))
)

(FLIP-MONOCASE-STRING

(LAMBDA (X) (if (STRINGP X) then (FLIP-MONOCASE X) else X)))
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA)

(ADDTOVAR NLAML)

(ADDTOVAR LAMA CL:ENOUGH-NAMESTRING CL:HOST-NAMESTRING FILE-NAME CL:MERGE-PATHNAMES PATHNAME %%PRINT-DIRECTORY-COMPONENT CL:MAKE-PATHNAME %%PRINT-PATHNAME %%PRINT-LP)
)
(PUTPROPS CMLPATHNAME COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (4941 11158 (%%PARSE-DIRECTORY-PATH 4951 . 5645) (%%PRINT-LP 5647 . 5935) (
%%PRINT-PATHNAME 5937 . 6111) (CL:MAKE-PATHNAME 6113 . 10290) (%%PRINT-DIRECTORY-COMPONENT 10292 . 
11156)) (13546 18731 (PATHNAME 13556 . 13754) (CL:MERGE-PATHNAMES 13756 . 15149) (FILE-NAME 15151 . 
15294) (CL:HOST-NAMESTRING 15296 . 15489) (CL:ENOUGH-NAMESTRING 15491 . 18496) (%%NUMERIC-STRING-P 
18498 . 18729)) (54067 56258 (UNPACKLOGICALNAME.STRING 54077 . 56256)) (56327 56559 (FLIP-MONOCASE 
56337 . 56469) (FLIP-MONOCASE-STRING 56471 . 56557)))))
STOP