(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "28-Sep-90 15:14:19" |{PELE:MV:ENVOS}SOURCES>CMLPATHNAME.;9| 42057 changes to%: (FNS CL:MAKE-PATHNAME) previous date%: "22-Aug-90 19:16:14" |{PELE:MV:ENVOS}SOURCES>CMLPATHNAME.;8|) (* ; " Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT CMLPATHNAMECOMS) (RPAQQ CMLPATHNAMECOMS [ (* ;; "Common Lisp pathname functions") (PROP FILETYPE CMLPATHNAME) (COMS (* ;; "useful macros") (FUNCTIONS %%WILD-NAME %%COMPONENT-STRING %%UNPACKFILE1)) (STRUCTURES PATHNAME DIRECTORY-COMPONENT) (FNS %%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*) (COMS (* ;; "Interlisp-D compatibility") (FUNCTIONS INTERLISP-NAMESTRING UNPACKPATHNAME.STRING)) (FUNCTIONS CL:FILE-NAMESTRING CL:DIRECTORY-NAMESTRING) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (%%INITIALIZE-DEFAULT-PATHNAME))) (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]) (* ;; "Common Lisp pathname functions") (PUTPROPS CMLPATHNAME FILETYPE CL:COMPILE-FILE) (* ;; "useful macros") (DEFMACRO %%WILD-NAME (STRING) `(LET ((S ,STRING)) (CL:IF (STRING-EQUAL S "*") :WILD S))) (DEFMACRO %%COMPONENT-STRING (COMPONENT) `(MKSTRING (OR ,COMPONENT ""))) (DEFMACRO %%UNPACKFILE1 (NAM ST END FILE PACKFLG ONEFIELDFLG VAL) `[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) (DEFINEQ (%%PRINT-PATHNAME (CL:LAMBDA (S STREAM D) (* hdj "19-Sep-86 15:49") (DECLARE (IGNORE D)) (CL:FORMAT STREAM "#.(~S ~S)" (QUOTE PATHNAME) (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)) (* ; "Edited 28-Sep-90 15:02 by jds") (* ;; "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.") (CL:IF DEFAULTS [LET ((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 HOSTP (SETQ HOST (%%PATHNAME-HOST *DEFAULT-PATHNAME-DEFAULTS*)))) (%%MAKE-PATHNAME (CL:IF (STRINGP HOST) (COERCE HOST 'CL:SIMPLE-STRING) HOST) (CL:IF (STRINGP DEVICE) (COERCE DEVICE 'CL:SIMPLE-STRING) DEVICE) (CL:IF DIRECTORY (CL:TYPECASE DIRECTORY (DIRECTORY-COMPONENT DIRECTORY) ((OR CL:SYMBOL STRING) [COND ((AND (CL:SYMBOLP DIRECTORY) (EQ DIRECTORY :WILD)) (%%MAKE-DIRECTORY-COMPONENT :TYPE :DIRECTORY :PATH :WILD )) (T (SETQ DIRECTORY (STRING DIRECTORY)) (LET [(DEFAULT-DIR (CL:IF DEFAULTS (%%PATHNAME-DIRECTORY DEFAULTS) (%%PATHNAME-DIRECTORY *DEFAULT-PATHNAME-DEFAULTS* ))) (DIREND (CL:1- (CL:LENGTH DIRECTORY] (CASE (CL:CHAR DIRECTORY DIREND) ((#\> #\/) (* ; "MAKE-PATHNAME does not accept :SUBDIRECTORY argument. Thus a subdirectory and a relative directory is indicated with the trail directory delimiter.") (* ;;  "If HOST is also specifed, it is a relative directory, otherwize a subdirectory.") (CL:IF HOSTP (%%MAKE-DIRECTORY-COMPONENT :TYPE :RELATIVE :PATH (CL:SUBSEQ DIRECTORY 0 DIREND)) (%%MAKE-DIRECTORY-COMPONENT :TYPE :DIRECTORY :PATH (CL:CONCATENATE 'STRING ( %%DIRECTORY-COMPONENT-PATH DEFAULT-DIR) (CL:SECOND \FILENAME.SYNTAX) (CL:SUBSEQ DIRECTORY 0 DIREND) )))) (T (%%MAKE-DIRECTORY-COMPONENT :TYPE :DIRECTORY :PATH DIRECTORY)))]) (T DIRECTORY)) DIRECTORY) (CL:IF (STRINGP NAME) (COERCE NAME 'CL:SIMPLE-STRING) NAME) (CL:IF (STRINGP TYPE) (COERCE TYPE 'CL:SIMPLE-STRING) TYPE) VERSION))) (%%PRINT-DIRECTORY-COMPONENT (CL: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))) (CL:FORMAT STREAM "~A" (CASE (%%DIRECTORY-COMPONENT-TYPE S) ((:SUBDIRECTORY :RELATIVE) (CL:CONCATENATE (QUOTE STRING) PATH ">")) (T (CL:IF (EQ PATH :WILD) (CL:CONCATENATE (QUOTE STRING) (CL:FIRST \FILENAME.SYNTAX) "*" (CL:SECOND \FILENAME.SYNTAX)) (CL:CONCATENATE (QUOTE STRING) (CL:FIRST \FILENAME.SYNTAX) PATH (CL:SECOND \FILENAME.SYNTAX)))))))) ) ) (CL:DEFUN CL:PATHNAME-HOST (PATHNAME) (* ;; "takes a stream, string, symbol, or pathname as arg, and returns the host slot of it") (%%PATHNAME-HOST (PATHNAME PATHNAME))) (CL:DEFUN CL:PATHNAME-DEVICE (PATHNAME) (* ;; "takes a stream, string, symbol, or pathname as arg, and returns the device slot of it") (%%PATHNAME-DEVICE (PATHNAME PATHNAME))) (CL:DEFUN CL:PATHNAME-DIRECTORY (PATHNAME) (* ;; "takes a stream, string, symbol, or pathname as arg, and returns the directory slot of it") (%%PATHNAME-DIRECTORY (PATHNAME PATHNAME))) (CL:DEFUN CL:PATHNAME-NAME (PATHNAME) (* ;; "takes a stream, string, symbol, or pathname as arg, and returns the name slot of it") (%%PATHNAME-NAME (PATHNAME PATHNAME))) (CL:DEFUN CL:PATHNAME-TYPE (PATHNAME) (* ;; "takes a stream, string, symbol, or pathname as arg, and returns the type slot of it") (%%PATHNAME-TYPE (PATHNAME PATHNAME))) (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 (CL:LAMBDA (THING) (* hdj " 2-Apr-86 11:01") (* ;; "Turns Thing into a pathname. Thing may be a string, symbol, stream, or pathname.") (CL:VALUES (CL:PARSE-NAMESTRING THING))) ) (CL:MERGE-PATHNAMES (CL:LAMBDA (PATHNAME &OPTIONAL (DEFAULTS *DEFAULT-PATHNAME-DEFAULTS*) (DEFAULT-VERSION :NEWEST CL::VERSION-SPECIFIED-P)) (* ; "Edited 21-Aug-90 17:12 by nm") (* ;;; "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 (CASE (%%DIRECTORY-COMPONENT-TYPE DIR) (:SUBDIRECTORY (CASE (SETQ DEFAULT-TYPE (%%DIRECTORY-COMPONENT-TYPE DEFAULT-DIR)) (:SUBDIRECTORY (* ; "Default is also a subdirectory, so explicit subdir overrides it") DIR) (T (* ; "Default is a full directory or a relative directory. Make sure to keep the type of the directory being same as the default one.") (CL:IF (EQ (%%DIRECTORY-COMPONENT-PATH DEFAULT-DIR) :WILD) (%%MAKE-DIRECTORY-COMPONENT :TYPE :RELATIVE :PATH (%%DIRECTORY-COMPONENT-PATH DIR)) (%%MAKE-DIRECTORY-COMPONENT :TYPE DEFAULT-TYPE :PATH (CL:CONCATENATE (QUOTE STRING) (%%DIRECTORY-COMPONENT-PATH DEFAULT-DIR) (CL:SECOND \FILENAME.SYNTAX) (%%DIRECTORY-COMPONENT-PATH DIR))))))) (T (CL:IF (NOT (EQ (%%DIRECTORY-COMPONENT-PATH DIR) :WILD)) 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 CL::VERSION-SPECIFIED-P DEFAULT-VERSION :NEWEST) (OR (%%PATHNAME-VERSION DEFAULT-PATH) (CL:IF CL::VERSION-SPECIFIED-P DEFAULT-VERSION :NEWEST))))))) ) (FILE-NAME (CL:LAMBDA (FILE) (* hdj " 9-Oct-86 15:12") (LET ((NAME (FULLNAME FILE))) (if (STREAMP NAME) then "" else (MKSTRING NAME)))) ) (CL:HOST-NAMESTRING (CL: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 7-Mar-90 16:49 by nm") (* ;; "Enough-Namestring returns a string which uniquely identifies PATHNAME w.r.t. DEFAULTS.") (LET* ((*PRINT-BASE* 10) (PATH (PATHNAME PATHNAME)) (DEFAULT-PATHNAME (PATHNAME DEFAULTS)) (HOST (%%PATHNAME-HOST PATH)) (DEVICE (%%PATHNAME-DEVICE PATH)) (DIRECTORY (%%PATHNAME-DIRECTORY PATH)) (NAME (%%PATHNAME-NAME PATH)) (TYPE (%%PATHNAME-TYPE PATH)) (VERSION (%%PATHNAME-VERSION PATH)) (RESULT "") (NEED-NAME NIL)) (CL:WHEN (AND HOST (CL:STRING-NOT-EQUAL HOST (%%COMPONENT-STRING (%%PATHNAME-HOST DEFAULT-PATHNAME)))) (SETQ RESULT (CL:CONCATENATE (QUOTE CL:SIMPLE-STRING) "{" (CL:PRINC-TO-STRING HOST) "}"))) (CL:WHEN (AND DEVICE (CL:STRING-NOT-EQUAL DEVICE (%%COMPONENT-STRING (%%PATHNAME-DEVICE DEFAULT-PATHNAME)))) (SETQ RESULT (CL:CONCATENATE (QUOTE CL:SIMPLE-STRING) RESULT (CL:PRINC-TO-STRING DEVICE) ":"))) (CL:WHEN (AND DIRECTORY (NOT (%%DIRECTORY-COMPONENT-EQUAL DIRECTORY (%%PATHNAME-DIRECTORY DEFAULT-PATHNAME)))) (CL:SETQ RESULT (CASE (%%DIRECTORY-COMPONENT-TYPE DIRECTORY) ((:SUBDIRECTORY :RELATIVE) (* ; "The initial directory delimiter is not needed for a subdirectory and a releative directory. Just concatenate a trail directory delimiter.") (CL:CONCATENATE (QUOTE CL:SIMPLE-STRING) RESULT (%%DIRECTORY-COMPONENT-PATH DIRECTORY) (CL:SECOND \FILENAME.SYNTAX))) (T (CL:IF (EQ (%%DIRECTORY-COMPONENT-PATH DIRECTORY) :WILD) (CL:CONCATENATE (QUOTE CL:SIMPLE-STRING) RESULT (CL:FIRST \FILENAME.SYNTAX) "*" (CL:SECOND \FILENAME.SYNTAX)) (CL:CONCATENATE (QUOTE CL:SIMPLE-STRING) RESULT (CL:FIRST \FILENAME.SYNTAX) (%%DIRECTORY-COMPONENT-PATH DIRECTORY) (CL:SECOND \FILENAME.SYNTAX))))))) (CL:WHEN (AND NAME (CL:STRING-NOT-EQUAL NAME (%%COMPONENT-STRING (%%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 (%%PATHNAME-TYPE DEFAULT-PATHNAME)))) (SETQ RESULT (CL:CONCATENATE (QUOTE CL:SIMPLE-STRING) RESULT "." (CL:PRINC-TO-STRING TYPE)))) (CL:WHEN (AND VERSION (OR NEED-NAME (CL:STRING-NOT-EQUAL (CL:PRINC-TO-STRING VERSION) (%%PATHNAME-VERSION DEFAULT-PATHNAME)))) (SETQ RESULT (CL:CONCATENATE (QUOTE CL:SIMPLE-STRING) RESULT (CASE VERSION (:WILD ";*") ((:NEWEST NIL) "") (CL:OTHERWISE (CL:CONCATENATE (QUOTE CL:SIMPLE-STRING) ";" (CL:PRINC-TO-STRING VERSION))))))) RESULT)) ) (%%NUMERIC-STRING-P (LAMBDA (STRING) (* hdj "28-Jul-86 12:25") (AND (CL: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 "")) [LET* ((PATHNAME (PATHNAME PATHNAME)) (CL::HOST (%%PATHNAME-HOST PATHNAME)) (CL::DEVICE (%%PATHNAME-DEVICE PATHNAME)) (CL:DIRECTORY (%%PATHNAME-DIRECTORY PATHNAME)) (CL::NAME (%%PATHNAME-NAME PATHNAME)) (TYPE (%%PATHNAME-TYPE PATHNAME)) (CL::VERSION (%%PATHNAME-VERSION PATHNAME)) (CL::RESULT NIL)) (CONCATLIST (NCONC (CL:WHEN CL::HOST (LIST "{" CL::HOST "}")) (CL:WHEN CL::DEVICE (LIST CL::DEVICE ":")) (CL:WHEN CL:DIRECTORY (CASE (%%DIRECTORY-COMPONENT-TYPE CL:DIRECTORY) ((:SUBDIRECTORY :RELATIVE) (* ; "The initial directory delimiter is not needed for a subdirectory and a releative directory. Just concatenate a trail directory delimiter.") (LIST (%%DIRECTORY-COMPONENT-PATH CL:DIRECTORY) (CL:SECOND \FILENAME.SYNTAX))) (T (CL:IF (EQ (%%DIRECTORY-COMPONENT-PATH CL:DIRECTORY) :WILD) NIL (LIST (CL:FIRST \FILENAME.SYNTAX) (%%DIRECTORY-COMPONENT-PATH CL:DIRECTORY) (CL:SECOND \FILENAME.SYNTAX)))))) (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 ':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:THIRD \FILENAME.SYNTAX)) "*") ((:NEWEST) (LIST "")) (T (LIST (CL:THIRD \FILENAME.SYNTAX) CL::VERSION)))] (T (LIST (CL:THIRD \FILENAME.SYNTAX) (CASE CL::VERSION ((:WILD) "*") ((:NEWEST) "") (T CL::VERSION))])]) (CL:DEFUN CL:PARSE-NAMESTRING (THING &OPTIONAL HOST DEFAULTS &KEY (START 0) END (JUNK-ALLOWED NIL)) (* ;;; "Parses a string representation of a pathname into a pathname. For details on the other silly arguments see the manual. NOTE that this version ignores JUNK-ALLOWED (because UNPACKFILENAME a.k.a. PARSE-NAMESTRING1 will parse anything) It also ignores Host and defaults since we don't support non-standard hosts") (DECLARE (IGNORE HOST DEFAULTS JUNK-ALLOWED)) (CL:TYPECASE 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 ( XCL:SYNONYM-STREAM-SYMBOL THING] (SETQ THING (FILE-NAME THING)))) (CL:SYMBOL (SETQ THING (CL:SYMBOL-NAME THING))) (T (CL:ERROR "This is of an inappropriate type for parse-namestring: ~S" THING))) (CL:UNLESS END (SETQ END (CL:LENGTH THING))) (LET* ((PATH-LIST (UNPACKFILENAME.STRING (SUBSTRING THING (+ 1 START) END) NIL NIL NIL NIL T))) (CL:VALUES [CL:MAKE-PATHNAME :HOST (LISTGET PATH-LIST 'HOST) :DEVICE (LISTGET PATH-LIST 'DEVICE) :DIRECTORY [LET [(CL:DIRECTORY (LISTGET PATH-LIST 'DIRECTORY)) (CL::SUBDIRECTORY (LISTGET PATH-LIST 'SUBDIRECTORY)) (CL::RELATIVEDIRECTORY (LISTGET PATH-LIST 'RELATIVEDIRECTORY] (COND (CL:DIRECTORY (%%MAKE-DIRECTORY-COMPONENT :TYPE :DIRECTORY :PATH (%%WILD-NAME CL:DIRECTORY))) (CL::SUBDIRECTORY (%%MAKE-DIRECTORY-COMPONENT :TYPE :SUBDIRECTORY :PATH (%%WILD-NAME CL::SUBDIRECTORY)) ) (CL::RELATIVEDIRECTORY (%%MAKE-DIRECTORY-COMPONENT :TYPE :RELATIVE :PATH (%%WILD-NAME CL::RELATIVEDIRECTORY)) ) (T (%%MAKE-DIRECTORY-COMPONENT :TYPE :DIRECTORY :PATH :WILD] :NAME (%%WILD-NAME (LISTGET PATH-LIST 'NAME)) :TYPE (%%WILD-NAME (LISTGET PATH-LIST 'EXTENSION)) :VERSION (LET [(VERSION (LISTGET PATH-LIST 'VERSION] (CL:IF (CL:EQUAL VERSION "") :NEWEST (CL:IF (CL:EQUAL VERSION "*") :WILD (MKATOM VERSION)))] 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 '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 '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 'DEVICE POS TEM FILE PACKFLG ONEFIELDFLG VAL) (SETQ POS (PLUS TEM 2)) (SETQ HOSTP T))) (COND [(EQ DIRFLG 'RETURN) (LET ((TYPE '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 '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 '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 '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 %.)) ';) (T T))) 'TYPE) (T (SELCHARQ (AND (EQ BEYONDEXT ';) (NTHCHARCODE FILE POS)) (P 'PROTECTION) (A (add POS 1) 'ACCOUNT) ((T S) 'TEMPORARY) '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 ( XCL: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) (AND (CL:EQUAL (%%PATHNAME-HOST PATHNAME1) (%%PATHNAME-HOST PATHNAME2)) (CL:EQUAL (%%PATHNAME-DEVICE PATHNAME1) (%%PATHNAME-DEVICE PATHNAME2)) (%%DIRECTORY-COMPONENT-EQUAL (%%PATHNAME-DIRECTORY PATHNAME1) (%%PATHNAME-DIRECTORY PATHNAME2)) (CL:EQUAL (%%PATHNAME-NAME PATHNAME1) (%%PATHNAME-NAME PATHNAME2)) (CL:EQUAL (%%PATHNAME-TYPE PATHNAME1) (%%PATHNAME-TYPE PATHNAME2)) (CL:EQUAL (%%PATHNAME-VERSION PATHNAME1) (%%PATHNAME-VERSION 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 () (DECLARE (GLOBALVARS *DEFAULT-PATHNAME-DEFAULTS* \CONNECTED.DIRECTORY)) (if (NOT (BOUNDP '\CONNECTED.DIRECTORY)) then (SETQ \CONNECTED.DIRECTORY '{DSK})) [SETQ *DEFAULT-PATHNAME-DEFAULTS* (CL:PARSE-NAMESTRING \CONNECTED.DIRECTORY (FILENAMEFIELD \CONNECTED.DIRECTORY 'HOST] (CL:SETF (%%PATHNAME-VERSION *DEFAULT-PATHNAME-DEFAULTS*) :NEWEST) *DEFAULT-PATHNAME-DEFAULTS*) (CL:DEFVAR *DEFAULT-PATHNAME-DEFAULTS*) (* ;; "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 '(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 'HOST (if ATOMFLG then (MKATOM COMPONENT) else COMPONENT) COMPONENT)) (if (SETQ COMPONENT (CL:PATHNAME-DEVICE FILE)) then (LIST 'DEVICE (if ATOMFLG then (MKATOM COMPONENT) else COMPONENT))) (if (SETQ COMPONENT (CL:PATHNAME-DIRECTORY FILE)) then (LIST 'DIRECTORY (if ATOMFLG then (MKATOM COMPONENT) else COMPONENT))) (if (SETQ COMPONENT (CL:PATHNAME-NAME FILE)) then (LIST 'NAME (if ATOMFLG then (MKATOM COMPONENT) else COMPONENT))) (if (SETQ COMPONENT (CL:PATHNAME-TYPE FILE)) then (LIST 'EXTENSION (if ATOMFLG then (MKATOM COMPONENT) else COMPONENT))) (if (SETQ COMPONENT (CL:PATHNAME-VERSION FILE)) then (LIST '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)) [RESULT (CL:CONCATENATE 'CL:SIMPLE-STRING (MKSTRING (%%COMPONENT-STRING ( %%PATHNAME-NAME PATH))) "." (MKSTRING (%%COMPONENT-STRING (%%PATHNAME-TYPE PATH] (VERSION (%%PATHNAME-VERSION PATH))) (CL:WHEN VERSION [SETQ RESULT (CL:CONCATENATE 'CL:SIMPLE-STRING RESULT (CASE VERSION (:WILD ";*") (:NEWEST ";") (CL:OTHERWISE (CL:CONCATENATE 'CL:SIMPLE-STRING ";" (CL:PRINC-TO-STRING VERSION))))]) RESULT)) (CL:DEFUN CL:DIRECTORY-NAMESTRING (PATHNAME) (* ;; "Returns the directory part of PATHNAME as a string.") (%%COMPONENT-STRING (%%PATHNAME-DIRECTORY (PATHNAME PATHNAME)))) (DECLARE%: DONTEVAL@LOAD DOCOPY (%%INITIALIZE-DEFAULT-PATHNAME) ) (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) ) (PRETTYCOMPRINT CMLPATHNAMECOMS) (RPAQQ CMLPATHNAMECOMS [ (* ;; "Common Lisp pathname functions") (PROP FILETYPE CMLPATHNAME) (COMS (* ;; "useful macros") (FUNCTIONS %%WILD-NAME %%COMPONENT-STRING %%UNPACKFILE1)) (STRUCTURES PATHNAME DIRECTORY-COMPONENT) (FNS %%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*) (COMS (* ;; "Interlisp-D compatibility") (FUNCTIONS INTERLISP-NAMESTRING UNPACKPATHNAME.STRING)) (FUNCTIONS CL:FILE-NAMESTRING CL:DIRECTORY-NAMESTRING) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (%%INITIALIZE-DEFAULT-PATHNAME))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA CL:ENOUGH-NAMESTRING CL:MERGE-PATHNAMES CL:MAKE-PATHNAME]) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA CL:ENOUGH-NAMESTRING CL:MERGE-PATHNAMES CL:MAKE-PATHNAME) ) (PUTPROPS CMLPATHNAME COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3597 9368 (%%PRINT-PATHNAME 3607 . 3768) (CL:MAKE-PATHNAME 3770 . 8520) ( %%PRINT-DIRECTORY-COMPONENT 8522 . 9366)) (10569 15893 (PATHNAME 10579 . 10771) (CL:MERGE-PATHNAMES 10773 . 12859) (FILE-NAME 12861 . 13002) (CL:HOST-NAMESTRING 13004 . 13193) (CL:ENOUGH-NAMESTRING 13195 . 15660) (%%NUMERIC-STRING-P 15662 . 15891))))) STOP