(FILECREATED "26-Sep-86 11:37:30" {ERIS}<LISPCORE>SOURCES>CMLPATHNAME.;10 38400
changes to: (FUNCTIONS PARSE-NAMESTRING %%WILD-NAME %%COMPONENT-STRING %%UNPACKFILE1)
(VARS CMLPATHNAMECOMS)
previous date: "19-Sep-86 15:57:55" {ERIS}<LISPCORE>SOURCES>CMLPATHNAME.;7)
(* 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 INTERLISP-NAMESTRING)
(FUNCTIONS %%PATHNAME-EQUAL)
(FUNCTIONS %%INITIALIZE-DEFAULT-PATHNAME)
(* ;; "")
(* ;; "Interlisp-D compatibility")
(* ;; "")
(FUNCTIONS UNPACKPATHNAME.STRING)
(FUNCTIONS FILE-NAMESTRING DIRECTORY-NAMESTRING)
(DECLARE: DOEVAL@LOAD DONTCOPY (EXPORT (FUNCTIONS %%WILD-NAME %%COMPONENT-STRING
%%UNPACKFILE1)))
(DECLARE: DONTEVAL@LOAD DOCOPY (P (%%INITIALIZE-DEFAULT-PATHNAME)))
(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 "19-Sep-86 15:49")
(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) (* hdj "19-Sep-86 15:50")
(%%PATHNAME-DEVICE (CL:IF (PATHNAMEP PATHNAME)
PATHNAME
(PATHNAME PATHNAME)))))
(PATHNAME-DIRECTORY
(CL:LAMBDA (PATHNAME) (* hdj "19-Sep-86 15:50")
(%%PATHNAME-DIRECTORY (CL:IF (PATHNAMEP PATHNAME)
PATHNAME
(PATHNAME PATHNAME)))))
(PATHNAME-NAME
(CL:LAMBDA (PATHNAME) (* hdj "19-Sep-86 15:50")
(%%PATHNAME-NAME (CL:IF (PATHNAMEP PATHNAME)
PATHNAME
(PATHNAME PATHNAME)))))
(PATHNAME-TYPE
(CL:LAMBDA (PATHNAME) (* hdj "19-Sep-86 15:50")
(%%PATHNAME-TYPE (CL:IF (PATHNAMEP PATHNAME)
PATHNAME
(PATHNAME PATHNAME)))))
(PATHNAME-VERSION
(CL:LAMBDA (PATHNAME) (* hdj "19-Sep-86 15:50")
(%%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 "19-Sep-86 15:51")
(* ; "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))
(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))
(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 a.k.a. PARSE-NAMESTRING1 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 (MKSTRING (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 (OR (NULL VERSION)
(CL:EQUAL VERSION ""))
:NEWEST
(CL:IF (CL:EQUAL VERSION "*")
:WILD
(MKATOM 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)
(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 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 INTERLISP-NAMESTRING (PATHNAME) (* ;;;
"Returns the full form of PATHNAME as an Interlisp string.")
(if (AND (STREAMP PATHNAME)
(NOT (fetch (STREAM NAMEDP) of PATHNAME)))
then (RETURN-FROM INTERLISP-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 ""))
(DECLARE (SIMPLE-STRING RESULT))
(CL:WHEN HOST (SETQ RESULT (CONCAT "{" (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 (CONCAT RESULT (THE SIMPLE-STRING DEVICE))))
(CL:WHEN DIRECTORY (SETQ RESULT (CONCAT RESULT "<" (CL:IF (EQ DIRECTORY :WILD)
"*"
(THE SIMPLE-STRING DIRECTORY))
">")))
(CL:WHEN NAME (SETQ RESULT (CONCAT RESULT (CL:IF (EQ NAME :WILD)
"*"
(THE SIMPLE-STRING NAME)))))
(CL:WHEN TYPE (SETQ RESULT (CONCAT RESULT "." (CL:IF (EQ TYPE :WILD)
"*"
(THE SIMPLE-STRING TYPE)))))
(CL:WHEN VERSION (SETQ RESULT (CONCAT RESULT (CASE VERSION (:WILD ";*")
(:NEWEST ";")
(NIL "")
(OTHERWISE (CONCAT ";" (PRINC-TO-STRING
VERSION)))))))
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))
(if (NOT (BOUNDP (QUOTE \CONNECTED.DIRECTORY)))
then (SETQ \CONNECTED.DIRECTORY (QUOTE {DSK})))
(SETQ *DEFAULT-PATHNAME-DEFAULTS* (PARSE-NAMESTRING
\CONNECTED.DIRECTORY
(FILENAMEFIELD
\CONNECTED.DIRECTORY
(QUOTE HOST))))
(SETF (%%PATHNAME-VERSION *DEFAULT-PATHNAME-DEFAULTS*)
:NEWEST)
*DEFAULT-PATHNAME-DEFAULTS*)
(* ;; "")
(* ;; "Interlisp-D compatibility")
(* ;; "")
(DEFUN UNPACKPATHNAME.STRING (FILE &OPTIONAL ONEFIELDFLG DIRFLG ATOMFLG)
(* ;;
"Simulate the action of UNPACKFILENAME.STRING on a pathname")
(* ;; "")
(DECLARE (IGNORE DIRFLG))
(if ONEFIELDFLG
then (AND (CONSP ONEFIELDFLG)
(SETQ ONEFIELDFLG (CAR (CL:INTERSECTION ONEFIELDFLG
(QUOTE (HOST DEVICE DIRECTORY NAME EXTENSION VERSION))
))))
(LET ((RESULT (CASE ONEFIELDFLG (HOST (PATHNAME-HOST FILE))
(DEVICE (PATHNAME-DEVICE FILE))
(DIRECTORY (PATHNAME-DIRECTORY FILE))
(NAME (PATHNAME-NAME FILE))
(EXTENSION (PATHNAME-TYPE FILE))
(VERSION (PATHNAME-VERSION FILE))
(OTHERWISE NIL))))
(if ATOMFLG
then (MKATOM RESULT)
else RESULT))
else (LET ((COMPONENT))
(APPEND (if (SETQ COMPONENT (PATHNAME-HOST FILE))
then (LIST (QUOTE HOST)
(if ATOMFLG
then (MKATOM COMPONENT)
else COMPONENT)
COMPONENT))
(if (SETQ COMPONENT (PATHNAME-DEVICE FILE))
then (LIST (QUOTE DEVICE)
(if ATOMFLG
then (MKATOM COMPONENT)
else COMPONENT)))
(if (SETQ COMPONENT (PATHNAME-DIRECTORY FILE))
then (LIST (QUOTE DIRECTORY)
(if ATOMFLG
then (MKATOM COMPONENT)
else COMPONENT)))
(if (SETQ COMPONENT (PATHNAME-NAME FILE))
then (LIST (QUOTE NAME)
(if ATOMFLG
then (MKATOM COMPONENT)
else COMPONENT)))
(if (SETQ COMPONENT (PATHNAME-TYPE FILE))
then (LIST (QUOTE EXTENSION)
(if ATOMFLG
then (MKATOM COMPONENT)
else COMPONENT)))
(if (SETQ COMPONENT (PATHNAME-VERSION FILE))
then (LIST (QUOTE VERSION)
(if ATOMFLG
then (MKATOM COMPONENT)
else (MKSTRING COMPONENT))))))))
(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: DOEVAL@LOAD DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
(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))
"")))))))
(* END EXPORTED DEFINITIONS)
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(%%INITIALIZE-DEFAULT-PATHNAME)
)
(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 (2226 6542 (%%PRINT-PATHNAME 2236 . 2449) (MAKE-PATHNAME 2451 . 4292) (PATHNAME-HOST
4294 . 5120) (PATHNAME-DEVICE 5122 . 5404) (PATHNAME-DIRECTORY 5406 . 5700) (PATHNAME-NAME 5702 . 5976
) (PATHNAME-TYPE 5978 . 6252) (PATHNAME-VERSION 6254 . 6540)) (6543 12697 (PATHNAME 6553 . 6993) (
MERGE-PATHNAMES 6995 . 8533) (FILE-NAME 8535 . 8794) (HOST-NAMESTRING 8796 . 9170) (ENOUGH-NAMESTRING
9172 . 12291) (%%NUMERIC-STRING-P 12293 . 12695)))))
STOP