(FILECREATED "27-Mar-85 13:53:10" {ERIS}<LISPNEW>PATCHES>PACKFILENAMEPATCH.;1 10498
changes to: (FNS PACKFILENAME PACKFILENAME.STRING)
(VARS PACKFILENAMEPATCHCOMS)
previous date: "27-Mar-85 13:37:01" {ERIS}<LISPNEW>SOURCES>PACKFILENAMEPATCH.;1)
(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT PACKFILENAMEPATCHCOMS)
(RPAQQ PACKFILENAMEPATCHCOMS [(FNS PACKFILENAME PACKFILENAME.STRING)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA PACKFILENAME.STRING PACKFILENAME])
(DEFINEQ
(PACKFILENAME
[LAMBDA N (* lmm "25-Mar-85 17:26")
(if (AND (EQ N 1)
(LISTP (ARG N 1)))
then (* spread argument list)
(APPLY (FUNCTION PACKFILENAME)
(ARG N 1))
else (PROG ((BLIP "")
(I 1)
HOST DEVICE STRUCTURE DIRECTORY NAME EXTENSION VERSION TEMPORARY PROTECTION ACCOUNT
PACKLIST VAR VAL TEMP)
(DECLARE (SPECVARS HOST DEVICE STRUCTURE DIRECTORY NAME EXTENSION VERSION TEMPORARY
PROTECTION ACCOUNT))
LP (COND
((NOT (IGREATERP I N))
(COND
((LISTP (SETQ VAR (ARG N I)))
(SETQ VAL (CDR VAR))
(SETQ VAR (CAR VAR)))
((NOT (IGREATERP (SETQ I (ADD1 I))
N))
(SETQ VAL (ARG N I)))
(T (SETQ VAL)))
(OR (STRINGP VAL)
(ATOM VAL)
(ERRORX (LIST 27 VAL))) (* fields must be atom)
(SELECTQ VAR
(BODY (MAP (UNPACKFILENAME.STRING (COND
((LISTP VAL)
(* PACKFILENAME for error checking of fields)
(PACKFILENAME VAL))
(T VAL)))
[FUNCTION (LAMBDA (X)
(* NIL => not yet seen, BLIP => seen as NIL.)
(OR (EVALV (CAR X))
(SET (CAR X)
(OR (CADR X)
BLIP]
(FUNCTION CDDR)))
[HOST (OR HOST (SETQ HOST
(if VAL
then (SELCHARQ (CHCON1 VAL)
(({ %[ %()
(SUBSTRING VAL 2
(SELCHARQ (NTHCHARCODE
VAL -1)
((} %] %))
-2)
-1)))
VAL)
else BLIP]
[(PATHNAME DIRECTORY) (* DIRECTORY really is treated as
{Host}device:<directory>)
(COND
(VAL (for X on (SETQ VAL (UNPACKFILENAME.STRING VAL NIL T))
by (CDDR X)
do (SELECTQ (CAR X)
[HOST (COND
((NOT HOST)
(SETQ HOST (OR (CADR X)
BLIP]
[DEVICE (COND
((NOT DEVICE)
(SETQ DEVICE (OR (CADR X)
BLIP]
[DIRECTORY (OR DIRECTORY (SETQ DIRECTORY
(OR (CADR X)
BLIP]
(ERROR "Illegal field in DIRECTORY slot" VAL)))
(for X on VAL by (CDDR X)
do (SELECTQ (CAR X)
(HOST (OR DEVICE (SETQ DEVICE BLIP))
(OR DIRECTORY (SETQ DIRECTORY BLIP)))
(DEVICE (OR DIRECTORY (SETQ DIRECTORY BLIP)))
NIL)))
(T (OR DIRECTORY (SETQ DIRECTORY BLIP]
[(DEVICE DIRECTORY HOST NAME EXTENSION VERSION TEMPORARY)
(OR (EVALV VAR)
(SET VAR (OR VAL BLIP]
(\ILLEGAL.ARG VAR))
(SETQ I (ADD1 I))
(GO LP)))
(SELECTQ TEMPORARY
[(T S ;S) (* hack for Interlisp-D!)
(OR HOST DEVICE (PROGN (SETQ HOST (QUOTE CORE))
(SETQ TEMPORARY]
NIL)
(RETURN (PACK (NCONC (AND HOST (NEQ HOST BLIP)
(LIST "{" HOST "}"))
[AND DEVICE (NEQ DEVICE BLIP)
(SELCHARQ (NTHCHARCODE DEVICE -1)
(: (LIST DEVICE))
(LIST DEVICE (QUOTE :]
(AND DIRECTORY (NEQ DIRECTORY BLIP)
(LIST "<" DIRECTORY ">"))
(AND NAME (NEQ NAME BLIP)
(LIST NAME))
(AND (OR (AND EXTENSION (NEQ EXTENSION BLIP))
(AND VERSION (NEQ VERSION BLIP)))
(LIST (COND
((AND EXTENSION (EQ (CHCON1 EXTENSION)
(CHARCODE %.)))
BLIP)
(T (QUOTE %.)))
(OR EXTENSION BLIP)))
[AND VERSION (NEQ VERSION BLIP)
(COND
((FIXP VERSION)
(LIST (QUOTE ;)
VERSION))
(T (SELCHARQ (CHCON1 VERSION)
(; (LIST VERSION))
((%. !)
(LIST (QUOTE ;)
(SUBSTRING VERSION 2 -1)))
(LIST (QUOTE ;)
VERSION]
(AND TEMPORARY (NEQ TEMPORARY BLIP)
(LIST (QUOTE ;)
(SELECTQ TEMPORARY
((S ;S)
(QUOTE S))
T])
(PACKFILENAME.STRING
[LAMBDA N (* lmm "25-Mar-85 17:29")
(if (AND (EQ N 1)
(LISTP (ARG N 1)))
then (* spread argument list)
(APPLY (FUNCTION PACKFILENAME.STRING)
(ARG N 1))
else (PROG ((BLIP "")
(I 1)
HOST DEVICE STRUCTURE DIRECTORY NAME EXTENSION VERSION TEMPORARY PROTECTION ACCOUNT
PACKLIST VAR VAL TEMP)
(DECLARE (SPECVARS HOST DEVICE STRUCTURE DIRECTORY NAME EXTENSION VERSION TEMPORARY
PROTECTION ACCOUNT))
LP (COND
((NOT (IGREATERP I N))
(COND
((LISTP (SETQ VAR (ARG N I)))
(SETQ VAL (CDR VAR))
(SETQ VAR (CAR VAR)))
((NOT (IGREATERP (SETQ I (ADD1 I))
N))
(SETQ VAL (ARG N I)))
(T (SETQ VAL)))
(OR (STRINGP VAL)
(ATOM VAL)
(ERRORX (LIST 27 VAL))) (* fields must be atom)
(SELECTQ VAR
(BODY (MAP (UNPACKFILENAME.STRING (COND
((LISTP VAL)
(* PACKFILENAME.STRING for error checking of fields)
(PACKFILENAME.STRING VAL))
(T VAL)))
[FUNCTION (LAMBDA (X)
(* NIL => not yet seen, BLIP => seen as NIL.)
(OR (EVALV (CAR X))
(SET (CAR X)
(OR (CADR X)
BLIP]
(FUNCTION CDDR)))
[HOST (OR HOST (SETQ HOST
(if VAL
then (SELCHARQ (CHCON1 VAL)
(({ %[ %()
(SUBSTRING VAL 2
(SELCHARQ (NTHCHARCODE
VAL -1)
((} %] %))
-2)
-1)))
VAL)
else BLIP]
[(PATHNAME DIRECTORY) (* DIRECTORY really is treated as
{Host}device:<directory>)
(COND
(VAL (for X on (SETQ VAL (UNPACKFILENAME.STRING VAL NIL T))
by (CDDR X)
do (SELECTQ (CAR X)
[HOST (COND
((NOT HOST)
(SETQ HOST (OR (CADR X)
BLIP]
[DEVICE (COND
((NOT DEVICE)
(SETQ DEVICE (OR (CADR X)
BLIP]
[DIRECTORY (OR DIRECTORY (SETQ DIRECTORY
(OR (CADR X)
BLIP]
(ERROR "Illegal field in DIRECTORY slot" VAL)))
(for X on VAL by (CDDR X)
do (SELECTQ (CAR X)
(HOST (OR DEVICE (SETQ DEVICE BLIP))
(OR DIRECTORY (SETQ DIRECTORY BLIP)))
(DEVICE (OR DIRECTORY (SETQ DIRECTORY BLIP)))
NIL)))
(T (OR DIRECTORY (SETQ DIRECTORY BLIP]
[(DEVICE DIRECTORY HOST NAME EXTENSION VERSION TEMPORARY)
(OR (EVALV VAR)
(SET VAR (OR VAL BLIP]
(\ILLEGAL.ARG VAR))
(SETQ I (ADD1 I))
(GO LP)))
(SELECTQ TEMPORARY
[(T S ;S) (* hack for Interlisp-D!)
(OR HOST DEVICE (PROGN (SETQ HOST (QUOTE CORE))
(SETQ TEMPORARY]
NIL)
(RETURN (CONCATLIST (NCONC (AND HOST (NEQ HOST BLIP)
(LIST "{" HOST "}"))
[AND DEVICE (NEQ DEVICE BLIP)
(SELCHARQ (NTHCHARCODE DEVICE -1)
(: (LIST DEVICE))
(LIST DEVICE (QUOTE :]
(AND DIRECTORY (NEQ DIRECTORY BLIP)
(LIST "<" DIRECTORY ">"))
(AND NAME (NEQ NAME BLIP)
(LIST NAME))
(AND (OR (AND EXTENSION (NEQ EXTENSION BLIP))
(AND VERSION (NEQ VERSION BLIP)))
(LIST (COND
((AND EXTENSION (EQ (CHCON1 EXTENSION)
(CHARCODE %.)))
BLIP)
(T (QUOTE %.)))
(OR EXTENSION BLIP)))
[AND VERSION (NEQ VERSION BLIP)
(COND
((FIXP VERSION)
(LIST (QUOTE ;)
VERSION))
(T (SELCHARQ (CHCON1 VERSION)
(; (LIST VERSION))
((%. !)
(LIST (QUOTE ;)
(SUBSTRING VERSION 2 -1)))
(LIST (QUOTE ;)
VERSION]
(AND TEMPORARY (NEQ TEMPORARY BLIP)
(LIST (QUOTE ;)
(SELECTQ TEMPORARY
((S ;S)
(QUOTE S))
T])
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA PACKFILENAME.STRING PACKFILENAME)
)
(PUTPROPS PACKFILENAMEPATCH COPYRIGHT ("Xerox Corporation" 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (610 10246 (PACKFILENAME 620 . 5421) (PACKFILENAME.STRING 5423 . 10244)))))
STOP