(FILECREATED "12-Mar-85 14:02:50" {ERIS}<LISPCORE>LIBRARY>FILENAMES.;1 18342
changes to: (VARS FILENAMESCOMS))
(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT FILENAMESCOMS)
(RPAQQ FILENAMESCOMS ((FNS REPACKFILENAME.STRING REPACKFILENAME.STRING.D REPACKFILENAME.STRING.LISPM
REPACKFILENAME.STRING.TOPS20 REPACKFILENAME.STRING.UNIX)))
(DEFINEQ
(REPACKFILENAME.STRING
[LAMBDA (NAME FOROSTYPE) (* edited: "12-Mar-85 13:51")
(LET ((NAMELST (UNPACKFILENAME.STRING NAME)))
(SELECTQ FOROSTYPE
(UNIX (REPACKFILENAME.STRING.UNIX NAMELST))
((TOPS20 TOPS-20)
(REPACKFILENAME.STRING.TOPS20 NAMELST))
((LISPM 3600 SYMBOLICS)
(REPACKFILENAME.STRING.LISPM NAMELST))
((D IFS)
(REPACKFILENAME.STRING.D NAMELST))
NAME])
(REPACKFILENAME.STRING.D
[LAMBDA N (* ejs: " 9-Mar-85 16:02")
(* * Convert file names to native format)
(if (AND (EQ N 1)
(LISTP (ARG N 1)))
then (* spread argument list)
(APPLY (FUNCTION REPACKFILENAME.STRING.D)
(ARG N 1))
else (PROG ((BLIP "")
(I 1)
HOST DEVICE STRUCTURE DIRECTORY NAME EXTENSION VERSION PACKLIST VAR VAL TEMP)
(DECLARE (SPECVARS HOST DEVICE STRUCTURE DIRECTORY NAME EXTENSION VERSION))
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)
(REPACKFILENAME.STRING.D 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]
[DIRECTORY (* DIRECTORY really is treated as
{Host}device:<directory>)
(for X on (UNPACKFILENAME.STRING VAL NIL T)
by (CDDR X) do (OR (EVALV (CAR X))
(SET (CAR X)
(OR (CADR X)
BLIP]
[(DEVICE HOST NAME EXTENSION VERSION)
(OR (EVALV VAR)
(SET VAR (OR VAL BLIP]
(\ILLEGAL.ARG VAR))
(SETQ I (ADD1 I))
(GO LP)))
(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)
(PROGN (SETQ DIRECTORY (CONCAT DIRECTORY))
[for C from 1 to (NCHARS DIRECTORY)
do (COND
([FMEMB (NTHCHARCODE DIRECTORY C)
(CONSTANT (LIST (CHARCODE %.]
(RPLCHARCODE DIRECTORY C (CHARCODE >]
(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])
(REPACKFILENAME.STRING.LISPM
[LAMBDA N (* ejs: "23-Feb-85 17:19")
(* * Can you believe this???)
(if (AND (EQ N 1)
(LISTP (ARG N 1)))
then (* spread argument list)
(APPLY (FUNCTION REPACKFILENAME.STRING.LISPM)
(ARG N 1))
else (PROG ((BLIP "")
(I 1)
HOST DEVICE STRUCTURE DIRECTORY NAME EXTENSION VERSION PACKLIST VAR VAL TEMP)
(DECLARE (SPECVARS HOST DEVICE STRUCTURE DIRECTORY NAME EXTENSION VERSION))
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)
(REPACKFILENAME.STRING.LISPM
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]
[DIRECTORY (* DIRECTORY really is treated as
{Host}device:<directory>)
(for X on (UNPACKFILENAME.STRING VAL NIL T)
by (CDDR X) do (OR (EVALV (CAR X))
(SET (CAR X)
(OR (CADR X)
BLIP]
[(DEVICE HOST NAME EXTENSION VERSION)
(OR (EVALV VAR)
(SET VAR (OR VAL BLIP]
(\ILLEGAL.ARG VAR))
(SETQ I (ADD1 I))
(GO LP)))
(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)
(PROGN (SETQ DIRECTORY (CONCAT DIRECTORY))
[for C from 1 to (NCHARS DIRECTORY)
do (COND
([FMEMB (NTHCHARCODE DIRECTORY C)
(CONSTANT (LIST (CHARCODE /)
(CHARCODE %.]
(RPLCHARCODE DIRECTORY C (CHARCODE >]
(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])
(REPACKFILENAME.STRING.TOPS20
[LAMBDA N (* ejs: "23-Feb-85 17:20")
(if (AND (EQ N 1)
(LISTP (ARG N 1)))
then (* spread argument list)
(APPLY (FUNCTION REPACKFILENAME.STRING.TOPS20)
(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)
(REPACKFILENAME.STRING.TOPS20
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]
[DIRECTORY (* DIRECTORY really is treated as
{Host}device:<directory>)
(for X on (UNPACKFILENAME.STRING VAL NIL T)
by (CDDR X) do (OR (EVALV (CAR X))
(SET (CAR X)
(OR (CADR X)
BLIP]
[(DEVICE 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)
(PROGN (SETQ DIRECTORY (CONCAT DIRECTORY))
[for C from 1 to (NCHARS DIRECTORY)
do (COND
([FMEMB (NTHCHARCODE DIRECTORY C)
(CONSTANT (LIST (CHARCODE /)
(CHARCODE >]
(RPLCHARCODE DIRECTORY C (CHARCODE %.]
(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])
(REPACKFILENAME.STRING.UNIX
[LAMBDA N (* ejs: "23-Feb-85 17:20")
(if (AND (EQ N 1)
(LISTP (ARG N 1)))
then (* spread argument list)
(APPLY (FUNCTION REPACKFILENAME.STRING.UNIX)
(ARG N 1))
else (PROG ((BLIP "")
(I 1)
HOST DEVICE STRUCTURE DIRECTORY NAME EXTENSION VERSION PACKLIST VAR VAL TEMP)
(DECLARE (SPECVARS HOST DEVICE STRUCTURE DIRECTORY NAME EXTENSION VERSION))
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)
(REPACKFILENAME.STRING.UNIX
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]
[DIRECTORY (* DIRECTORY really is treated as
{Host}device:<directory>)
(for X on (UNPACKFILENAME.STRING VAL NIL T)
by (CDDR X) do (OR (EVALV (CAR X))
(SET (CAR X)
(OR (CADR X)
BLIP]
[(DEVICE HOST NAME EXTENSION VERSION)
(OR (EVALV VAR)
(SET VAR (OR VAL BLIP]
(\ILLEGAL.ARG VAR))
(SETQ I (ADD1 I))
(GO LP)))
(RETURN (CONCATLIST
(NCONC (AND HOST (NEQ HOST BLIP)
(LIST "{" HOST "}"))
(AND DEVICE (NEQ DEVICE BLIP)
(LIST "/" DEVICE))
(AND DIRECTORY (NEQ DIRECTORY BLIP)
(PROGN (SETQ DIRECTORY (CONCAT DIRECTORY))
[for C from 1 to (NCHARS DIRECTORY)
do (COND
([FMEMB (NTHCHARCODE DIRECTORY C)
(CONSTANT (LIST (CHARCODE >)
(CHARCODE %.]
(RPLCHARCODE DIRECTORY C (CHARCODE /]
(LIST "/" DIRECTORY "/"))
(LIST "/" DIRECTORY "/"))
(AND NAME (NEQ NAME BLIP)
(LIST NAME))
(AND (OR (AND EXTENSION (NEQ EXTENSION BLIP))
(AND VERSION (NEQ VERSION BLIP)))
(LIST (COND
((OR (AND EXTENSION (EQ (CHCON1 EXTENSION)
(CHARCODE %.)))
(OR (NULL EXTENSION)
(EQ EXTENSION BLIP)
(STREQUAL EXTENSION "")))
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])
)
(PRETTYCOMPRINT FILENAMESCOMS)
(RPAQQ FILENAMESCOMS [(FNS REPACKFILENAME.STRING REPACKFILENAME.STRING.D REPACKFILENAME.STRING.LISPM
REPACKFILENAME.STRING.TOPS20 REPACKFILENAME.STRING.UNIX)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA REPACKFILENAME.STRING.UNIX
REPACKFILENAME.STRING.TOPS20
REPACKFILENAME.STRING.LISPM REPACKFILENAME.STRING.D])
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA REPACKFILENAME.STRING.UNIX REPACKFILENAME.STRING.TOPS20 REPACKFILENAME.STRING.LISPM
REPACKFILENAME.STRING.D)
)
(PUTPROPS FILENAMES COPYRIGHT ("Xerox Corporation" 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (399 17562 (REPACKFILENAME.STRING 409 . 894) (REPACKFILENAME.STRING.D 896 . 4912) (
REPACKFILENAME.STRING.LISPM 4914 . 8979) (REPACKFILENAME.STRING.TOPS20 8981 . 13473) (
REPACKFILENAME.STRING.UNIX 13475 . 17560)))))
STOP