(FILECREATED "28-Jul-86 14:57:37" {ERIS}<LISPCORE>LIBRARY>CMLPATHNAME.;13 32534
changes to: (FUNCTIONS FILE-NAMESTRING NAMESTRING %%INITIALIZE-DEFAULT-PATHNAME
PARSE-NAMESTRING1 PARSE-NAMESTRING)
(STRUCTURES PATHNAME)
(VARS CMLPATHNAMECOMS)
(FNS %%NUMERIC-STRING-P PARSE-NAMESTRING PARSE-NAMESTRING1)
previous date: "23-Jul-86 12:34:34" {ERIS}<LISPCORE>LIBRARY>CMLPATHNAME.;11)
(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CMLPATHNAMECOMS)
(RPAQQ CMLPATHNAMECOMS
[(* * "Common Lisp pathname functions")
(PROP FILETYPE CMLPATHNAME)
(STRUCTURES PATHNAME)
(FNS %%PRINT-PATHNAME MAKE-PATHNAME PATHNAME-HOST PATHNAME-DEVICE PATHNAME-DIRECTORY
PATHNAME-NAME PATHNAME-TYPE PATHNAME-VERSION)
(FNS PATHNAME MERGE-PATHNAMES FILE-NAME HOST-NAMESTRING ENOUGH-NAMESTRING %%NUMERIC-STRING-P)
(FUNCTIONS NAMESTRING PARSE-NAMESTRING PARSE-NAMESTRING1 TRUENAME)
(FUNCTIONS %%PATHNAME-EQUAL)
(FUNCTIONS %%INITIALIZE-DEFAULT-PATHNAME)
(DECLARE: DONTEVAL@LOAD DOCOPY (P (%%INITIALIZE-DEFAULT-PATHNAME)))
(FUNCTIONS FILE-NAMESTRING DIRECTORY-NAMESTRING)
(DECLARE: DONTCOPY (FUNCTIONS %%WILD-NAME %%COMPONENT-STRING %%UNPACKFILE1))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA ENOUGH-NAMESTRING HOST-NAMESTRING FILE-NAME MERGE-PATHNAMES PATHNAME
PATHNAME-VERSION PATHNAME-TYPE PATHNAME-NAME PATHNAME-DIRECTORY
PATHNAME-DEVICE PATHNAME-HOST MAKE-PATHNAME %%PRINT-PATHNAME])
(* * "Common Lisp pathname functions")
(PUTPROPS CMLPATHNAME FILETYPE COMPILE-FILE)
(DEFSTRUCT (PATHNAME (:CONC-NAME %%PATHNAME-)
(:PRINT-FUNCTION %%PRINT-PATHNAME)
(:CONSTRUCTOR %%MAKE-PATHNAME (HOST DEVICE DIRECTORY NAME TYPE VERSION))
(:PREDICATE PATHNAMEP)) HOST DEVICE DIRECTORY NAME TYPE VERSION)
(DEFINEQ
(%%PRINT-PATHNAME
(CL:LAMBDA (S CL:STREAM D) (* hdj " 2-Apr-86 10:59")
(CL:DECLARE (IGNORE D))
(FORMAT CL:STREAM "#.(PATHNAME ~S)" (NAMESTRING S))))
(MAKE-PATHNAME
(CL:LAMBDA (&KEY DEFAULTS (HOST NIL HOSTP)
(DEVICE NIL DEVICEP)
(DIRECTORY NIL DIRECTORYP)
(NAME NIL NAMEP)
(TYPE NIL TYPEP)
(VERSION NIL VERSIONP)) (* hdj " 9-Jun-86 15:29")
(* 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 (QUOTE SIMPLE-STRING))
HOST)
(CL:IF (STRINGP DEVICE)
(COERCE DEVICE (QUOTE SIMPLE-STRING))
DEVICE)
DIRECTORY
(CL:IF (STRINGP NAME)
(COERCE NAME (QUOTE SIMPLE-STRING))
NAME)
(CL:IF (STRINGP TYPE)
(COERCE TYPE (QUOTE SIMPLE-STRING))
TYPE)
VERSION)))
(PATHNAME-HOST
[CL:LAMBDA (PATHNAME) (* These can not be done by the
accessors because the pathname arg may
be a string or a symbol or etc.
*)
(* Returns the host slot of pathname.
Pathname may be a string, symbol, or
stream. *)
(%%PATHNAME-HOST (CL:IF (PATHNAMEP PATHNAME)
PATHNAME
(PATHNAME PATHNAME])
(PATHNAME-DEVICE
[CL:LAMBDA (PATHNAME) (* Returns the device slot of
pathname. Pathname may be a string,
symbol, or stream. *)
(%%PATHNAME-DEVICE (CL:IF (PATHNAMEP PATHNAME)
PATHNAME
(PATHNAME PATHNAME])
(PATHNAME-DIRECTORY
[CL:LAMBDA (PATHNAME) (* Returns the directory slot of
pathname. Pathname may be a string,
symbol, or stream. *)
(%%PATHNAME-DIRECTORY (CL:IF (PATHNAMEP PATHNAME)
PATHNAME
(PATHNAME PATHNAME])
(PATHNAME-NAME
[CL:LAMBDA (PATHNAME) (* Returns the name slot of pathname.
Pathname may be a string, symbol, or
stream. *)
(%%PATHNAME-NAME (CL:IF (PATHNAMEP PATHNAME)
PATHNAME
(PATHNAME PATHNAME])
(PATHNAME-TYPE
[CL:LAMBDA (PATHNAME) (* Returns the type slot of pathname.
Pathname may be a string, symbol, or
stream. *)
(%%PATHNAME-TYPE (CL:IF (PATHNAMEP PATHNAME)
PATHNAME
(PATHNAME PATHNAME])
(PATHNAME-VERSION
[CL:LAMBDA (PATHNAME) (* Returns the version slot of
pathname. Pathname may be a string,
symbol, or stream. *)
(%%PATHNAME-VERSION (CL:IF (PATHNAMEP PATHNAME)
PATHNAME
(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. *)
(VALUES (PARSE-NAMESTRING THING))))
(MERGE-PATHNAMES
[CL:LAMBDA (PATHNAME &OPTIONAL (DEFAULTS *DEFAULT-PATHNAME-DEFAULTS*)
DEFAULT-VERSION) (* hdj "20-Jun-86 11:34")
(* * "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))
(NAME (%%PATHNAME-NAME PATH))
(DEVICE (%%PATHNAME-DEVICE PATH)))
(%%MAKE-PATHNAME (OR (%%PATHNAME-HOST PATH)
(%%PATHNAME-HOST DEFAULT-PATH))
(OR DEVICE (%%PATHNAME-DEVICE DEFAULT-PATH))
(OR (%%PATHNAME-DIRECTORY PATH)
(%%PATHNAME-DIRECTORY DEFAULT-PATH))
(OR NAME (%%PATHNAME-NAME DEFAULT-PATH))
(OR (%%PATHNAME-TYPE PATH)
(%%PATHNAME-TYPE DEFAULT-PATH))
(OR (%%PATHNAME-VERSION PATH)
(CL:IF NAME DEFAULT-VERSION (OR (%%PATHNAME-VERSION DEFAULT-PATH)
DEFAULT-VERSION])
(FILE-NAME
[CL:LAMBDA (FILE) (* hdj "13-Jun-86 12:08")
(LET ((NAME (FULLNAME FILE)))
(if (STREAMP NAME)
then NAME
else (MKSTRING NAME])
(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])
(ENOUGH-NAMESTRING
(CL:LAMBDA (PATHNAME &OPTIONAL (DEFAULTS *DEFAULT-PATHNAME-DEFAULTS*))
(* hdj "10-Jun-86 18:04")
(* "Enough-Namestring")
(*
"Returns a string which uniquely identifies PATHNAME w.r.t. DEFAULTS.")
(LET* ((PATH (PATHNAME PATHNAME))
(DEFAULT-PATHNAME (PATHNAME DEFAULTS))
(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:DECLARE (SIMPLE-STRING RESULT))
(CL:WHEN [AND DEVICE (STRING-NOT-EQUAL DEVICE (%%COMPONENT-STRING (%%PATHNAME-DEVICE
DEFAULT-PATHNAME]
(SETQ RESULT DEVICE))
(CL:WHEN [AND DIRECTORY (NOT (EQUALP DIRECTORY (%%COMPONENT-STRING (
%%PATHNAME-DIRECTORY
DEFAULT-PATHNAME]
(SETQ RESULT (CONCATENATE (QUOTE SIMPLE-STRING)
RESULT "<" (THE SIMPLE-STRING DIRECTORY)
">")))
(CL:WHEN [AND NAME (STRING-NOT-EQUAL NAME (%%COMPONENT-STRING (%%PATHNAME-NAME
DEFAULT-PATHNAME]
(CL:SETQ RESULT (CONCATENATE (QUOTE SIMPLE-STRING)
RESULT
(THE SIMPLE-STRING NAME))
NEED-NAME T))
[CL:WHEN [AND TYPE (OR NEED-NAME (STRING-NOT-EQUAL TYPE (%%COMPONENT-STRING
(%%PATHNAME-TYPE
DEFAULT-PATHNAME]
(SETQ RESULT (CONCATENATE (QUOTE SIMPLE-STRING)
RESULT "." (THE SIMPLE-STRING TYPE]
[CL:WHEN [AND VERSION (OR NEED-NAME (NOT (EQL VERSION (%%PATHNAME-VERSION
DEFAULT-PATHNAME]
(SETQ RESULT (CONCATENATE (QUOTE SIMPLE-STRING)
RESULT ";" (THE SIMPLE-STRING (%%COMPONENT-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])
)
(DEFUN NAMESTRING (PATHNAME)
(* * "Returns the full form of PATHNAME as a string.")
(if (AND (STREAMP PATHNAME)
(NOT (fetch (STREAM NAMEDP) of PATHNAME)))
then (RETURN-FROM NAMESTRING ""))
(SETQ PATHNAME (PATHNAME PATHNAME))
(LET* ((HOST (%%PATHNAME-HOST PATHNAME))
(DEVICE (%%PATHNAME-DEVICE PATHNAME))
(DIRECTORY (%%PATHNAME-DIRECTORY PATHNAME))
(NAME (%%PATHNAME-NAME PATHNAME))
(TYPE (%%PATHNAME-TYPE PATHNAME))
(VERSION (%%PATHNAME-VERSION PATHNAME))
(RESULT NIL))
(CL:DECLARE (SIMPLE-STRING RESULT))
(CL:WHEN HOST (SETQ RESULT (CONCATENATE (QUOTE SIMPLE-STRING)
"{"
(THE SIMPLE-STRING HOST)
"}"))) (* "device will have `:' on end because of PARSE-NAMESTRING1 silliness (it allows you to have a device called NIL)")
(CL:WHEN DEVICE (SETQ RESULT (CONCATENATE (QUOTE SIMPLE-STRING)
RESULT
(THE SIMPLE-STRING DEVICE))))
(CL:WHEN DIRECTORY (SETQ RESULT (CONCATENATE (QUOTE SIMPLE-STRING)
RESULT "<" (CL:IF (EQ DIRECTORY :WILD)
"*"
(THE SIMPLE-STRING DIRECTORY))
">")))
(CL:WHEN NAME (SETQ RESULT (CONCATENATE (QUOTE SIMPLE-STRING)
RESULT
(CL:IF (EQ NAME :WILD)
"*"
(THE SIMPLE-STRING NAME)))))
(CL:WHEN TYPE (SETQ RESULT (CONCATENATE (QUOTE SIMPLE-STRING)
RESULT "." (CL:IF (EQ TYPE :WILD)
"*"
(THE SIMPLE-STRING TYPE)))))
(CL:WHEN VERSION (SETQ RESULT (CONCATENATE (QUOTE SIMPLE-STRING)
RESULT
(CASE VERSION (:WILD ";*")
(:NEWEST ";")
(NIL "")
(OTHERWISE (CONCATENATE (QUOTE SIMPLE-STRING)
";"
(PRINC-TO-STRING VERSION)))))))
RESULT))
(DEFUN PARSE-NAMESTRING (THING &OPTIONAL HOST (DEFAULTS *DEFAULT-PATHNAME-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 will parse anything)")
(CL:UNLESS DEFAULTS (CL:SETQ DEFAULTS *DEFAULT-PATHNAME-DEFAULTS*))
(CL:UNLESS HOST (SETQ HOST (%%PATHNAME-HOST DEFAULTS)))
(TYPECASE THING (STRING (SETQ THING (COERCE THING (QUOTE SIMPLE-STRING))))
(PATHNAME (RETURN-FROM PARSE-NAMESTRING (VALUES THING START)))
(STREAM (SETQ THING (FILE-NAME THING)))
(SYMBOL (SETQ THING (SYMBOL-NAME THING)))
(T (CL:ERROR "This is of an inappropriate type for parse-namestring: ~S" THING)))
(CL:UNLESS END (SETQ END (CL:LENGTH (THE SIMPLE-STRING THING))))
(LET* ((RESULT (PARSE-NAMESTRING1 (SUBSEQ THING START END)))
(PATH-LIST (CDR RESULT)))
(VALUES (MAKE-PATHNAME :HOST (LISTGET PATH-LIST (QUOTE HOST))
:DEVICE
(LISTGET PATH-LIST (QUOTE DEVICE))
:DIRECTORY
(%%WILD-NAME (LISTGET PATH-LIST (QUOTE DIRECTORY)))
:NAME
(%%WILD-NAME (LISTGET PATH-LIST (QUOTE NAME)))
:TYPE
(%%WILD-NAME (LISTGET PATH-LIST (QUOTE TYPE)))
:VERSION
(LET ((VERSION (LISTGET PATH-LIST (QUOTE VERSION))))
(CL:IF (CL:EQUAL VERSION "")
:NEWEST
(CL:IF (CL:EQUAL VERSION "*")
:WILD VERSION))))
(+ START (CAR RESULT)))))
(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 POS NIL)))
((OR (LITATOM FILE)
(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 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 POS (DREVERSE VAL)))))
(SETQ POS (IPLUS TEM 2))
(SETQ HOSTP T)))
(COND
((SETQ TEM (LASTCHPOS (CHARCODE :)
FILE POS)) (*
"all device returned have : on it so that NIL: will work")
(%%UNPACKFILE1 (QUOTE DEVICE)
POS TEM FILE PACKFLG ONEFIELDFLG VAL)
(SETQ POS (ADD1 TEM))
(SETQ HOSTP T)))
(COND
((EQ DIRFLG (QUOTE RETURN))
(LET ((TYPE (QUOTE DIRECTORY))
(START (SELCHARQ (NTHCHARCODE FILE POS)
(NIL (RETURN (CONS 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 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 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 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 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)))
(DEFUN TRUENAME (PATHNAME)
(* * "Return the pathname for the actual file described by the pathname An error is signalled if no such file exists.")
(LET ((RESULT (PROBE-FILE PATHNAME)))
(CL:UNLESS RESULT (CL:ERROR "The file ~S does not exist." (NAMESTRING PATHNAME)))
RESULT))
(DEFUN %%PATHNAME-EQUAL (PATHNAME1 PATHNAME2) (AND (CL:EQUAL (%%PATHNAME-HOST PATHNAME1)
(%%PATHNAME-HOST PATHNAME2))
(CL:EQUAL (%%PATHNAME-DEVICE PATHNAME1)
(%%PATHNAME-DEVICE PATHNAME2))
(CL: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))))
(DEFUN %%INITIALIZE-DEFAULT-PATHNAME NIL (DECLARE (GLOBALVARS *DEFAULT-PATHNAME-DEFAULTS*
\CONNECTED.DIRECTORY))
(SETQ *DEFAULT-PATHNAME-DEFAULTS* (PARSE-NAMESTRING
\CONNECTED.DIRECTORY
(FILENAMEFIELD
\CONNECTED.DIRECTORY
(QUOTE HOST))))
(SETF (%%PATHNAME-VERSION *DEFAULT-PATHNAME-DEFAULTS*)
:NEWEST)
*DEFAULT-PATHNAME-DEFAULTS*)
(DECLARE: DONTEVAL@LOAD DOCOPY
(%%INITIALIZE-DEFAULT-PATHNAME)
)
(DEFUN FILE-NAMESTRING (PATHNAME) (LET* ((PATH (PATHNAME PATHNAME))
(RESULT (CONCATENATE (QUOTE SIMPLE-STRING)
(%%COMPONENT-STRING (%%PATHNAME-NAME PATH))
"."
(%%COMPONENT-STRING (%%PATHNAME-TYPE PATH))))
(VERSION (%%PATHNAME-VERSION PATH)))
(CL:WHEN VERSION (SETQ RESULT
(CONCATENATE
(QUOTE SIMPLE-STRING)
RESULT
(CASE VERSION (:WILD ";*")
(:NEWEST ";")
(NIL "")
(OTHERWISE (CONCATENATE (QUOTE
SIMPLE-STRING
)
";"
(PRINC-TO-STRING
VERSION)))))))
RESULT))
(DEFUN DIRECTORY-NAMESTRING (PATHNAME) (*
"Returns the directory part of PATHNAME as a string. *")
(%%COMPONENT-STRING (%%PATHNAME-DIRECTORY (PATHNAME PATHNAME))))
(DECLARE: DONTCOPY
(DEFMACRO %%WILD-NAME (STRING) (BQUOTE (LET ((S (\, STRING)))
(CL:IF (STRING-EQUAL S "*")
:WILD S))))
(DEFMACRO %%COMPONENT-STRING (COMPONENT) (BQUOTE (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))
"")))))))
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA ENOUGH-NAMESTRING HOST-NAMESTRING FILE-NAME MERGE-PATHNAMES PATHNAME PATHNAME-VERSION
PATHNAME-TYPE PATHNAME-NAME PATHNAME-DIRECTORY PATHNAME-DEVICE PATHNAME-HOST
MAKE-PATHNAME %%PRINT-PATHNAME)
)
(PUTPROPS CMLPATHNAME COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2159 7411 (%%PRINT-PATHNAME 2169 . 2385) (MAKE-PATHNAME 2387 . 4228) (PATHNAME-HOST
4230 . 5056) (PATHNAME-DEVICE 5058 . 5527) (PATHNAME-DIRECTORY 5529 . 6013) (PATHNAME-NAME 6015 . 6473
) (PATHNAME-TYPE 6475 . 6933) (PATHNAME-VERSION 6935 . 7409)) (7412 13349 (PATHNAME 7422 . 7862) (
MERGE-PATHNAMES 7864 . 9402) (FILE-NAME 9404 . 9663) (HOST-NAMESTRING 9665 . 10039) (ENOUGH-NAMESTRING
10041 . 12943) (%%NUMERIC-STRING-P 12945 . 13347)))))
STOP