(FILECREATED "25-Jan-86 02:41:52" {ERIS}<LISPCORE>CML>LAB>CMLDEVELOPMENT.;18 34448
changes to: (FNS CMLFPKGFN.EVAL-WHEN CMLMAKECOMS CMLFIXCOMMENTS CMLCRUNCHCOMS
CMLFPKGFN.CONSTANTS CMLPKGFN.DEFTYPE CMLFPKGFN.DEFSETF CMLFPKGFN.FNS
CMLFPKGFN.INITVARS CMLFPKGFN.MACROS CMLFPKGFN.P CMLFPKGFN.PROPS
CMLFPKGFN.RECORDS CMLFPKGFN.VARS CMLFPKGFN.;;; CMLREADFILE CMLIMPORTFILE)
(VARS CMLDEVELOPMENTCOMS EVAL.WHEN.TAGS)
(PROPS (* CMLFPKGFN)
(; CL:NAME))
previous date: "24-Jan-86 01:32:21" {ERIS}<LISPCORE>CML>LAB>CMLDEVELOPMENT.;6)
(* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CMLDEVELOPMENTCOMS)
(RPAQQ CMLDEVELOPMENTCOMS [(* Miscellaneous LISPCORE↑ development aids to help bring Common Lisp
online. Not intended for general lisp users. *)
(COMS (* Common Lisp names. *)
(VARS CMLFNNAMES CMLMACROS CMLSPECIALFORMS EVAL.WHEN.TAGS)
[P (SETQ CMLNAMES (SORT (APPEND CMLFNNAMES CMLMACROS CMLSPECIALFORMS
NIL]
(VARS CMLCONFLICTS)
(P (FOR NAME IN CMLCONFLICTS DO (PUTPROP NAME (QUOTE CL:NAME)
(PACK* (QUOTE CL:)
NAME)))
(PUTPROP (QUOTE LAMBDA)
(QUOTE CL:NAME)
(QUOTE CL:LAMBDA)))
(FNS CMLNAME CMLNAMEIFY CMLNAMEIFYFN CMLIMPLEMENTED CMLUNIMPLEMENTED
))
(PROP CL:NAME \ASET MACROP MACRO-P \PUT \RPLACA \RPLACD \SET-PLIST ;)
(COMS (* Spice Lisp file to Interlisp filepackage helpers. *)
(FNS CMLIMPORTFILE CMLUPPERCASEFILE CMLMAKECOMS CMLFIXCOMMENTS
CMLCRUNCHCOMS CMLREADFILE)
(FNS CMLFPKGFN.CONSTANTS CMLPKGFN.DEFTYPE CMLFPKGFN.DEFSETF
CMLFPKGFN.FNS CMLFPKGFN.INITVARS CMLFPKGFN.MACROS CMLFPKGFN.P
CMLFPKGFN.PROPS CMLFPKGFN.RECORDS CMLFPKGFN.VARS
CMLFPKGFN.EVAL-WHEN CMLFPKGFN.;;;)
(PROP CMLFPKGFN DEFCONSTANT DEFINE-MODIFY-MACRO DEFINE-SETF-METHOD
DEFMACRO DEFUN DEFPARAMETER DEFSETF DEFSTRUCT DEFVAR EVAL-WHEN
DEFTYPE *)
(* Ignore package declarations, global comments, for at least the
time being. *)
(VARS CMLIGNOREFNS)
[P (FOR NAME IN CMLIGNOREFNS DO (PUTPROP NAME (QUOTE CMLFPKGFN)
(QUOTE NILL))
(OR (GETD NAME)
(MOVD (QUOTE *)
NAME]
(VARS (FILECMLRDTBL (COPYREADTABLE CMLRDTBL)))
(P (SETSYNTAX (QUOTE ;)
(QUOTE OTHER)
FILECMLRDTBL])
(* Miscellaneous LISPCORE↑ development aids to help bring Common Lisp online. Not intended for
general lisp users. *)
(* Common Lisp names. *)
(RPAQQ CMLFNNAMES (ABS ACONS ACOS ACOSH ADJOIN ADJUST-ARRAY ADJUSTABLE-ARRAY-P ALPHA-CHAR-P
ALPHANUMERICP APPEND APPLY APPLYHOOK APROPOS APROPOS-LIST AREF ARRAY-DIMENSION
ARRAY-DIMENSIONS ARRAY-ELEMENT-TYPE ARRAY-HAS-FILL-POINTER-P ARRAY-IN-BOUNDS-P
ARRAY-RANK ARRAY-ROW-MAJOR-INDEX ARRAY-TOTAL-SIZE ARRAYP ASH ASIN ASINH ASSOC
ASSOC-IF ASSOC-IF-NOT ATAN ATANH ATOM BIT BIT-AND BIT-ANDC1 BIT-ANDC2 BIT-EQV
BIT-IOR BIT-NAND BIT-NOR BIT-NOT BIT-ORC1 BIT-ORC2 BIT-VECTOR-P BIT-XOR BOOLE
BOTH-CASE-P BOUNDP BREAK BUTLAST BYTE BYTE-POSITION BYTE-SIZE CAR CDR CEILING
CERROR CHAR CHAR-BIT CHAR-BITS CHAR-BITS-LIMIT CHAR-CODE CHAR-DOWNCASE
CHAR-EQUAL CHAR-FONT CHAR-FONT-LIMIT CHAR-GREATERP CHAR-HYPER-BIT CHAR-INT
CHAR-LESSP CHAR-NAME CHAR-NOT-EQUAL CHAR-NOT-GREATERP CHAR-NOT-LESSP
CHAR-UPCASE CHAR/= CHAR< CHAR<= CHAR= CHAR> CHAR>= CHARACTER CHARACTERP CIS
CLEAR-INPUT CLEAR-OUTPUT CLOSE CLRHASH CODE-CHAR COERCE COMMONP COMPILE
COMPILE-FILE COMPILED-FUNCTION-P COMPLEX COMPLEXP CONCATENATE CONJUGATE CONS
CONSP CONSTANTP COPY-ALIST COPY-LIST COPY-READTABLE COPY-SEQ COPY-SYMBOL
COPY-TREE COS COSH COUNT COUNT-IF COUNT-IF-NOT DECODE-FLOAT
DECODE-UNIVERSAL-TIME DELETE DELETE-DUPLICATES DELETE-FILE DELETE-IF
DELETE-IF-NOT DENOMINATOR DEPOSIT-FIELD DESCRIBE DIGIT-CHAR DIGIT-CHAR-P
DIRECTORY DIRECTORY-NAMESTRING DISASSEMBLE DOCUMENTATION DPB DRIBBLE ED EIGHTH
ELT ENDP ENOUGH-NAMESTRING EQ EQ1 EQUAL EQUALP ERROR EVAL EVALHOOK EVENP EVERY
EXP EXPORT EXPT FBOUNDP FCEILING FFLOOR FIFTH FILE-AUTHOR FILE-LENGTH
FILE-NAMESTRING FILE-POSITION FILE-WRITE-DATE FILL-POINTER FIND-ALL-SYMBOLS
FIND-IF FIND-IF-NOT FIND-PACKAGE FIND-SYMBOL FINISH-OUTPUT FIRST FLOAT
FLOAT-DIGITS FLOAT-PRECISION FLOAT-RADIX FLOAT-SIGN FLOATP FLOOR FMAKUNBOUND
FORCE-OUTPUT FOURTH FRESH-LINE FROUND FTRUNCATE FTYPE FUNCALL FUNCTIONP GCD
GENSYM GENTEMP GET GET-DECODED-TIME GET-DISPATCH-MACRO-CHARACTER
GET-INTERNAL-REAL-TIME GET-INTERNAL-RUN-TIME GET-MACRO-CHARACTER
GET-OUTPUT-STREAM-STRING GET-PROPERTIES GET-SETF-METHOD
GET-SETF-METHOD-MULTIPLE-VALUE GET-UNIVERSAL-TIME GETF GETHASH GRAPHIC-CHAR-P
HASH-TABLE-COUNT HASH-TABLE-P HOST-NAMESTRING IDENTIFY IMAGPART IMPORT
IN-PACKAGE IN-PACKAGE INPUT-STREAM-P INSPECT INT-CHAR INTEGER-DECODE-FLOAT
INTEGER-LENGTH INTEGERP INTERN INTERNAL-TIME-UNITS-PER-SECOND INTERSECTION
ISQRT KEYWORD LAST LCM LDB LDB-TEST LDIFF LENGTH LISP-IMPLEMENTATION-TYPE
LISP-IMPLEMENTATION-VERSION LIST LIST* LIST-ALL-PACKAGES LIST-LENGTH LISTEN
LISP LOAD LOG LOGAND LOGANDC1 LOGANDC2 LOGBITP LOGCOUNT LOGEQV LOGIOR LOGNAND
LOGNOR LOGNOT LOGORC1 LOGORC2 LOGTEST LOGXOR LONG-SITE-NAME LOWER-CASE-P
MACHINE-INSTANCE MACHINE-TYPE MACHINE-VERSION MACRO-FUNCTION MACROEXPAND
MACROEXPAND-1 MAKE-ARRAY MAKE-BROADCASE-STREAM MAKE-DISPATCH-MACRO-CHARACTER
MAKE-ECHO-STREAM MAKE-HASH-TABLE MAKE-LIST MAKE-PACKAGE MAKE-PATHNAME
MAKE-RANDOM-STATE MAKE-SEQUENCE MAKE-STRING MAKE-STRING-INPUT-STREAM
MAKE-STRING-OUTPUT-STREAM MAKE-SYMBOL MAKE-SYNONYM-STREAM MAKE-TWO-WAY-STREAM
MAKUNBOUND MAP MAPC MAPCAN MAPCAR MAPCON MAPHASH MAPL MAPLIST MASK-FIELD MAX
MEMBER MEMBER-IF MEMBER-IF-NOT MERGE MERGE-PATHNAMES MIN MINUSP MISMATCH MOD
NAME-CHAR NAMESTRING NBUTLAST NCONC NINTERSECTION NINTH NOT NOTANY NOTEVERY
NRECONC NREVERSE NSET-DIFFERENCE NSET-EXCLUSIVE-OR NSTRING-CAPITALIZE
NSTRING-DOWNCASE NSTRING-UPCASE NSUBLIS NSUBST NSUBST-IF NSUBST-IF-NOT
NSUBSTITUTE NSUBSTITUTE-IF NSUBSTITUTE-IF-NOT NTH NTHCDR NULL NUMBERP NUERATOR
NUNION ODDP OPEN OUTPUT-STREAM-P PACKAGE-NAME PACKAGE-NICKNAMES
PACKAGE-SHADOWING-SYMBOLS PACKAGE-USE-LIST PACKAGE-USED-BY-LIST PACKAGEP
PAIRLIS PARSE-INTEGER PARSE-NAMESTRING PATHNAME PATHNAME-DEVICE
PATHNAME-DIRECTORY PATHNAME-HOST PATHNAME-NAME PATHNAME-TYPE PATHNAME-VERSION
PATHNAMEP PEEK-CHAR PHASE PLUSP POSITION POSITION-IF POSITION-IF-NOT PPRINT
PRIN1 PRIN1-TO-STRING PRINC PRINC-TO-STRING PRINT PROBE-FILE PROCLAIM PROVIDE
RANDOM RANDOM-STATE-P RASSOC RASSOC-IF RASSOC-IF-NOT RATIONAL RATIONALIZE
RATIONALP READ READ-BYTE READ-CHAR READ-CHAR-NO-HANG READ-DELIMITED-LIST
READ-EVAL-PRINT READ-FROM-STRING READ-LINE READ-PRESERVING-WHITESPACE
READTABLEP REALPART REDUCE REM REMHASH REMOVE REMOVE-DUPLICATES REMOVE-IF
REMOVE-IF-NOT REMPROP RENAME-FILE RENAME-PACKAGE REPALCE REQUIRE REST
REVAPPEND REVERSE ROOM ROUND RPLACA RPLACD SBIT SCALE-FLOAT SCHAR SEARCH
SECOND SET SET-CHAR-BIT SET-DIFFERENCE SET-DISPATCH-MACRO-CHARACTER
SET-EXCLUSIVE-OR SET-MACRO-CHARACTER SET-EXCLUSIVE-OR SET-MACRO-CHARACTER
SET-SYNTAX-FROM-CHAR SEVENTH SHADOW SHADOWING-IMPORT SHORT-SITE-NAME SIGNUM
SIMPLE-BIT-VECTOR-P SIMPLE-STRING-P SIMPLE-VECTOR-P SIN SINH SIXTH SLEEP
SOFTWARE-TYPE SOFTWARE-VERSION SOME SORT SPECIAL-FORM-P SQRT STABLE-SORT
STANDARD-CHAR-P STREAM-ELEMENT-TYPE STREAMUP STRING STRING-CAPITALIZE
STRING-CHAR STRING-CHAR-P STRING-DOWNCASE STRING-EQUAL STRING-GREATERP
STRING-LEFT-TRIM STRING-LESSP STRING-NOT-EQUAL STRING-NOT-GREATERP
STRING-NOT-LESSP STRING-RIGHT-TRIM STRING-TRIM STRING-UPCASE STRING/= STRING<
STRING<= STRING= STRING> STRING>= STRINGP SUBLIS SUSEQ SUBSETP SUBST SUBST-IF
SUBST-IF-NOT SUBSTITUTE SUBSTITUTE-IF SUBSTITUTE-IF-NOT SUBTYPEP SVREF SXHASH
SYMBOL-FUNCTION SYMBOL-NAME SYMBOL-PACKAGE SYMBOL-PLIST SYMBOL-VALUE TAILP TAN
TANH TENTH TERPRI THIRD TREE-EQUAL TRUENAME TRUNCATE TYPE-OF TYPEP UNEXPORT
UNINTERN UNION UNREAD-CHAR UNUSE-PACKAGE UPPER-CASE-P USE-PACKAGE
USER-HOMEDIR-PATHNAME VALUES VALUES-LIST VECTOR VECTOR-POP VECTOR-PUSH
VECTOR-PUSH-EXTEND VECTORP WARN WRITE WRITE-BYTE WRITE-CHAR WRITE-LINE
WRITE-STRING WRITE-TO-STRING Y-OR-N-P YES-OR-NO-P * + - / /= 1+ 1- < <= = > >=
))
(RPAQQ CMLMACROS (ASSERT CASE CCASE CHECK-TYPE DECF DEFCONSTANT DEFINE-MODIFY-MACRO
DEFINE-SETF-METHOD DEFMACRO DEFUN DEFVAR DO DO* DO-ALL-SYMBOLS
DO-EXTERNAL-SYMBOLS DO-SYMBOLS DOLIST DOTIMES ECASE ETYPECASE INCF LOCALLY
LOOP MULTIPLE-VALUE-BIND MULITPLE-VALUE-LIST MULTIPLE-VALUE-SETQ OR POP PROG
PROG* PROG1 PROG2 PSETF PSETQ PUSH PUSHNEW REMF RETURN ROTATEF SETF SHIFTF
STEP TIME TRACE TYPECASE UNLESS UNTRACE WHEN WITH-INPUT-FROM-STRING
WITH-OPEN-FILE WITH-OPEN-STREAM WITH-OUTPUT-TO-STRING))
(RPAQQ CMLSPECIALFORMS (BLOCK CATCH COMPILER-LET DECLARE EVAL-WHEN FLET FUNCTION GO IF LABELS LET
LET* MACROLET MULTIPLE-VALUE-CALL MULTIPLE-VALUE-PROG1 PROGN PROGV
QUOTE RETURN-FROM SETQ TAGBODY THE THROW UNWIND-PROTECT))
(RPAQQ EVAL.WHEN.TAGS ((EVAL . EVAL@LOAD)
(CL:COMPILE . EVAL@COMPILE)
(LOAD . COPY)))
(SETQ CMLNAMES (SORT (APPEND CMLFNNAMES CMLMACROS CMLSPECIALFORMS NIL)))
(RPAQQ CMLCONFLICTS (APPLY ARRAYP ASSOC ATAN ATOM BLOCK BREAK COMPILE COS COUNT DECLARE DELETE DO ELT
ERROR EVERY FIND FIRST IF LDIFF LENGTH MAP MAPC MAPCAR MAPCON MAPHASH
MAPLIST MEMBER MERGE NOTANY NOTEVERY NREVERSE NTH POSITION PRIN1 PUSH
PUSHNEW REMOVE REPLACE REVERSE SIN SOME SUBST TAN UNLESS WHEN *))
(FOR NAME IN CMLCONFLICTS DO (PUTPROP NAME (QUOTE CL:NAME)
(PACK* (QUOTE CL:)
NAME)))
(PUTPROP (QUOTE LAMBDA)
(QUOTE CL:NAME)
(QUOTE CL:LAMBDA))
(DEFINEQ
(CMLNAME
[LAMBDA (NAME) (* kbr:
"27-Aug-85 22:10")
(* Take NAME as you
would see it in a Common
Lisp file and return
NAME or CL:NAME as
Interlisp needs it.
*)
(OR (GETPROP NAME (QUOTE CL:NAME))
NAME])
(CMLNAMEIFY
[LAMBDA (EXPR) (* kbr:
"28-Aug-85 13:26")
(COND
[(LISTP EXPR)
(RPLACA EXPR (CMLNAMEIFY (CAR EXPR)))
(RPLACD EXPR (CMLNAMEIFY (CDR EXPR]
((LITATOM EXPR)
(CMLNAME EXPR))
(T EXPR])
(CMLNAMEIFYFN
[LAMBDA (FN) (* kbr:
"28-Aug-85 13:27")
(PUTDEF FN (QUOTE FNS)
(CMLNAMEIFY (GETDEF FN (QUOTE FNS])
(CMLIMPLEMENTED
[LAMBDA NIL (* kbr:
"29-Aug-85 16:32")
(PROG (NAMES CMLNAME)
[for NAME in CMLNAMES do (SETQ CMLNAME (CMLNAME NAME))
(COND
((OR (GETD CMLNAME)
(GETPROP CMLNAME (QUOTE MACRO)))
(push NAMES CMLNAME]
(RETURN (DREVERSE NAMES])
(CMLUNIMPLEMENTED
[LAMBDA NIL (* kbr:
"29-Aug-85 16:33")
(PROG (NAMES CMLNAME)
[for NAME in CMLNAMES do (SETQ CMLNAME (CMLNAME NAME))
(COND
([NOT (OR (GETD CMLNAME)
(GETPROP CMLNAME (QUOTE MACRO]
(push NAMES CMLNAME]
(RETURN (DREVERSE NAMES])
)
(PUTPROPS \ASET CL:NAME ASET)
(PUTPROPS MACROP CL:NAME MACRO-FUNCTION)
(PUTPROPS MACRO-P CL:NAME MACRO-FUNCTION)
(PUTPROPS \PUT CL:NAME PUT)
(PUTPROPS \RPLACA CL:NAME RPLACA)
(PUTPROPS \RPLACD CL:NAME RPLACD)
(PUTPROPS \SET-PLIST CL:NAME SETPROPLIST)
(PUTPROPS ; CL:NAME *)
(* Spice Lisp file to Interlisp filepackage helpers. *)
(DEFINEQ
(CMLIMPORTFILE
[LAMBDA (FILE) (* raf
"24-Jan-86 17:06")
(CMLUPPERCASEFILE FILE FILE)
(CMLMAKECOMS FILE)
(* * "Edit the comments?")
NIL])
(CMLUPPERCASEFILE
[LAMBDA (FROMFILE TOFILE COMMENTSFLG ESCAPESFLG) (* raf
"24-Jan-86 01:18")
(PROG (FROMSTREAM TOSTREAM CODE INCOMMENT INSTRING)
(SETQ FROMSTREAM (OPENSTREAM FROMFILE (QUOTE INPUT)))
(SETQ TOSTREAM (OPENSTREAM TOFILE (QUOTE OUTPUT)))
(OR COMMENTSFLG (SETQ COMMENTSFLG (QUOTE INTERLISP)))
(OR ESCAPESFLG (SETQ ESCAPESFLG (QUOTE INTERLISP)))
(while (NOT (EOFP FROMSTREAM)) do (SETQ CODE (\BIN FROMSTREAM))
(SELECTQ ESCAPESFLG
(INTERLISP [COND
((EQ CODE (CHARCODE %%))
(SETQ CODE (CHARCODE \)))
((EQ CODE (CHARCODE \))
(SETQ CODE (CHARCODE %%])
(COMMONLISP NIL)
(\ILLEGAL.ARG ESCAPESFLG))
[COND
((EQ CODE (CHARCODE %"))
(SETQ INSTRING (NOT INSTRING]
(SELECTQ COMMENTSFLG
(STRIP [COND
((EQ CODE (CHARCODE ;))
(SETQ INCOMMENT T))
((EQ CODE (CHARCODE CR))
(SETQ INCOMMENT NIL)
(\BOUT TOSTREAM CODE))
(INSTRING (\BOUT TOSTREAM CODE))
((NOT INCOMMENT)
(\BOUT TOSTREAM (U-CASECODE CODE])
(KEEP (\BOUT TOSTREAM (U-CASECODE CODE)))
(INTERLISP [COND
((EQ CODE (CHARCODE ;))
(COND
((NOT INCOMMENT)
(PRIN1 "(; %"" TOSTREAM)))
(SETQ INCOMMENT T))
((EQ CODE (CHARCODE CR))
(COND
(INCOMMENT (PRIN1 "%")" TOSTREAM)))
(SETQ INCOMMENT NIL)
(\BOUT TOSTREAM CODE))
((OR INCOMMENT INSTRING)
(\BOUT TOSTREAM CODE))
(T (\BOUT TOSTREAM (U-CASECODE CODE])
(\ILLEGAL.ARG COMMENTSFLG)))
(CLOSEF FROMSTREAM)
(RETURN (CLOSEF TOSTREAM])
(CMLMAKECOMS
[LAMBDA (FILE) (* raf
"25-Jan-86 02:26")
(* Create FILECOMS for
one FILE *)
(PROG (FILECOMS FORMS FPKGFN)
(SETQ FILECOMS (FILECOMS FILE))
(SET FILECOMS (TCONC NIL (LIST (QUOTE *)
FILECOMS))) (* Get FPKG expressions
*)
(SETQ FORMS (CMLREADFILE FILE)) (* Establish FPKG in
lisp environment *)
[for FORM in FORMS when (LISTP FORM) do (COND
((SETQ FPKGFN (GETPROP (CAR FORM)
(QUOTE CMLFPKGFN)))
(* A form we understand
about and is safe to
eval (well, pretty safe
with DFNFLG = PROP) *)
(EVAL FORM)
(APPLY* FPKGFN FILECOMS FORM))
(T (APPLY* (FUNCTION CMLFPKGFN.P)
FILECOMS FORM]
(RPLACD (SYMBOL-VALUE FILECOMS)
NIL) (* Unlink the
self-referencing list)
(SET FILECOMS (CAR (SYMBOL-VALUE FILECOMS))) (* Get the list)
(CMLCRUNCHCOMS FILECOMS)
(CMLFIXCOMMENTS FILECOMS)
(RETURN FILECOMS])
(CMLFIXCOMMENTS
[CL:LAMBDA (FILECOMS) (* raf
"25-Jan-86 02:23")
(CL:DO ((HEAD (SYMBOL-VALUE FILECOMS)
(CDR HEAD)))
((NULL HEAD))
(CL:IF (EQ (CAAR HEAD)
(QUOTE *))
(CL:DO ((COMMENT (CDDAR HEAD)
(CDR COMMENT)))
((NULL COMMENT))
(CL:IF (EQ (CAR COMMENT)
(QUOTE *))
(RPLACA COMMENT (QUOTE -])
(CMLCRUNCHCOMS
[CL:LAMBDA (FILECOMS) (* raf
"25-Jan-86 01:57")
(* * Compress sequences of the same coms with different names under them -
The outer loop holds pointers to the front of the coms list and to the
next (potentially) dissimilar segment of the list -
The inner loop smashes the list segements together if each of their head
elements is the same com and advances the pointers)
(CL:DO ((TAIL (CDR (SYMBOL-VALUE FILECOMS))
(CDR TAIL))
(HEAD (SYMBOL-VALUE FILECOMS)
(CDR HEAD)))
((NULL TAIL)
NIL)
(CL:DO ((HEADTYPE (CAAR HEAD)
(CAAR HEAD))
(TAILTYPE (CAAR TAIL)
(CAAR TAIL)))
((OR (NULL TAIL)
(EQ HEADTYPE (QUOTE DECLARE:))
(NEQ HEADTYPE TAILTYPE))
NIL) (* While the front
element is the same as
the next element, bash
them together)
(RPLACD (LAST (CAR HEAD))
(CDAR TAIL))
(SETQ TAIL (CDR TAIL))
(RPLACD HEAD TAIL])
(CMLREADFILE
[LAMBDA (FILE) (* raf
"24-Jan-86 23:56")
(* READFILE with
translation. *)
(PROG (ANSWER EXPR EXPAND)
(RESETLST (RESETSAVE NIL (LIST (QUOTE INPUT)
(INFILE FILE)))
(SETQ FILE (INPUT))
(while (NOT (EOFP FILE)) do (SETQ EXPR (READ FILE FILECMLRDTBL))
(SETQ EXPAND (CMLNAMEIFY EXPR))
(SETQ ANSWER (NCONC ANSWER (LIST EXPAND)))
(SKIPSEPRS FILE FILECMLRDTBL))
(CLOSEF FILE))
(RETURN ANSWER])
)
(DEFINEQ
(CMLFPKGFN.CONSTANTS
[LAMBDA (FILECOMS EXPR) (* raf
"25-Jan-86 01:11")
(* CONSTANTS file
package command.
EXPR is a RPAQ?
expression. *)
(TCONC (SYMBOL-VALUE FILECOMS)
(LIST (QUOTE CONSTANTS)
(LIST (CADR EXPR)
(CADDR EXPR])
(CMLPKGFN.DEFTYPE
[LAMBDA (FILECOMS EXPR) (* raf
"25-Jan-86 01:11")
(* Put a DEFTYPE
expression into a file
package. EXPR is the
deftype expression.
*)
(TCONC (SYMBOL-VALUE FILECOMS)
(LIST (QUOTE DEFTYPE)
(CADR EXPR])
(CMLFPKGFN.DEFSETF
[LAMBDA (FILECOMS EXPR) (* raf
"25-Jan-86 01:11")
(* PROPS file package
command. *)
(LET ((ATOM (CADR EXPR))
(COMS (SYMBOL-VALUE FILECOMS)))
(for PROPNAME in (QUOTE (SETF-METHOD-EXPANDER SETF-INVERSE)) when (GETPROP ATOM PROPNAME)
do (TCONC COMS (LIST (QUOTE PROPS)
ATOM PROPNAME])
(CMLFPKGFN.FNS
[LAMBDA (FILECOMS EXPR) (* raf
"25-Jan-86 01:12")
(* FNS file package
command. EXPR is a
definition. *)
(LET [(FN (SELECTQ (CAR EXPR)
(DEFUN (CADR EXPR))
(SHOULDNT]
(TCONC (SYMBOL-VALUE FILECOMS)
(LIST (QUOTE FNS)
FN])
(CMLFPKGFN.INITVARS
[LAMBDA (FILECOMS EXPR) (* raf
"25-Jan-86 01:12")
(* INITVARS file
package command.
EXPR is a RPAQ?
expression. *)
(TCONC (SYMBOL-VALUE FILECOMS)
(LIST (QUOTE INITVARS)
(LIST (CADR EXPR)
(CADDR EXPR])
(CMLFPKGFN.MACROS
[LAMBDA (FILECOMS EXPR) (* raf
"25-Jan-86 01:12")
(* MACROS file package
command. EXPR is a
definition. *)
(PROG [(MACRO (SELECTQ (CAR EXPR)
((DEFMACRO DEFINE-MODIFY-MACRO)
(CADR EXPR))
(SHOULDNT]
(TCONC (SYMBOL-VALUE FILECOMS)
(LIST (QUOTE MACROS)
MACRO])
(CMLFPKGFN.P
[LAMBDA (FILECOMS EXPR) (* raf
"25-Jan-86 01:12")
(* P file package
command. EXPR to be
evaled when loaded.
*)
(TCONC (SYMBOL-VALUE FILECOMS)
(LIST (QUOTE P)
EXPR])
(CMLFPKGFN.PROPS
[LAMBDA (FILECOMS EXPR) (* raf
"25-Jan-86 01:12")
(* PROPS file package
command. *)
(LET ((ATOM (CADR EXPR))
(PROPNAME (CAR EXPR)))
(TCONC (SYMBOL-VALUE FILECOMS)
(LIST (QUOTE PROPS)
(LIST ATOM PROPNAME])
(CMLFPKGFN.RECORDS
[LAMBDA (FILECOMS EXPR) (* raf
"25-Jan-86 01:13")
(* RECORDS file package
command. EXPR is a
record package
declaration. *)
(LET [(NAME (OR (CAR (LISTP (CADR EXPR)))
(CADR EXPR]
(TCONC (SYMBOL-VALUE FILECOMS)
(LIST (QUOTE RECORDS)
NAME])
(CMLFPKGFN.VARS
[LAMBDA (FILECOMS EXPR) (* raf
"25-Jan-86 01:13")
(* VARS file package
command. EXPR is a RPAQ
expression. *)
(TCONC (SYMBOL-VALUE FILECOMS)
(LIST (QUOTE VARS)
(LIST (CADR EXPR)
(CADDR EXPR])
(CMLFPKGFN.EVAL-WHEN
[LAMBDA (FILECOMS EXPR) (* raf
"25-Jan-86 02:39")
(* DECLARE: file
package command.
EXPR is an EVAL-WHEN
expression. *)
(LET ([TAGS (for SITUATION in (CADR EXPR) collect (CDR (ASSOC SITUATION EVAL.WHEN.TAGS]
(FORMS (CDDR EXPR)))
(TCONC (SYMBOL-VALUE FILECOMS)
(COPY (BQUOTE (DECLARE: (\,@ TAGS) (*)
(\,@ FORMS])
(CMLFPKGFN.;;;
[LAMBDA (FILECOMS EXPR) (* raf
"25-Jan-86 01:13")
(TCONC (SYMBOL-VALUE FILECOMS)
(BQUOTE
(* * (\,@ (CDR EXPR)))
])
)
(PUTPROPS DEFCONSTANT CMLFPKGFN CMLFPKGFN.CONSTANTS)
(PUTPROPS DEFINE-MODIFY-MACRO CMLFPKGFN CMLFPKGFN.MACROS)
(PUTPROPS DEFINE-SETF-METHOD CMLFPKGFN CMLFPKGFN.DEFSETF)
(PUTPROPS DEFMACRO CMLFPKGFN CMLFPKGFN.MACROS)
(PUTPROPS DEFUN CMLFPKGFN CMLFPKGFN.FNS)
(PUTPROPS DEFPARAMETER CMLFPKGFN CMLFPKGFN.VARS)
(PUTPROPS DEFSETF CMLFPKGFN CMLFPKGFN.DEFSETF)
(PUTPROPS DEFSTRUCT CMLFPKGFN CMLFPKGFN.RECORDS)
(PUTPROPS DEFVAR CMLFPKGFN CMLFPKGFN.INITVARS)
(PUTPROPS EVAL-WHEN CMLFPKGFN CMLFPKGFN.EVAL-WHEN)
(PUTPROPS DEFTYPE CMLFPKGFN CMLPKGFN.DEFTYPE)
(PUTPROPS * CMLFPKGFN CMLFPKGFN.;;;)
(* Ignore package declarations, global comments, for at least the time being. *)
(RPAQQ CMLIGNOREFNS (; CL:DECLARE EXPORT IMPORT IN-PACKAGE PROCLAIM PROVIDE REQUIRE SHADOW
USE-PACKAGE))
(FOR NAME IN CMLIGNOREFNS DO (PUTPROP NAME (QUOTE CMLFPKGFN)
(QUOTE NILL))
(OR (GETD NAME)
(MOVD (QUOTE *)
NAME)))
(RPAQ FILECMLRDTBL (COPYREADTABLE CMLRDTBL))
(SETSYNTAX (QUOTE ;)
(QUOTE OTHER)
FILECMLRDTBL)
(PUTPROPS CMLDEVELOPMENT COPYRIGHT ("Xerox Corporation" 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (12961 15526 (CMLNAME 12971 . 13765) (CMLNAMEIFY 13767 . 14139) (CMLNAMEIFYFN 14141 .
14404) (CMLIMPLEMENTED 14406 . 14959) (CMLUNIMPLEMENTED 14961 . 15524)) (15869 25256 (CMLIMPORTFILE
15879 . 16189) (CMLUPPERCASEFILE 16191 . 19793) (CMLMAKECOMS 19795 . 22037) (CMLFIXCOMMENTS 22039 .
22691) (CMLCRUNCHCOMS 22693 . 24317) (CMLREADFILE 24319 . 25254)) (25257 33259 (CMLFPKGFN.CONSTANTS
25267 . 25974) (CMLPKGFN.DEFTYPE 25976 . 26730) (CMLFPKGFN.DEFSETF 26732 . 27378) (CMLFPKGFN.FNS 27380
. 28054) (CMLFPKGFN.INITVARS 28056 . 28760) (CMLFPKGFN.MACROS 28762 . 29516) (CMLFPKGFN.P 29518 .
30156) (CMLFPKGFN.PROPS 30158 . 30718) (CMLFPKGFN.RECORDS 30720 . 31477) (CMLFPKGFN.VARS 31479 . 32095
) (CMLFPKGFN.EVAL-WHEN 32097 . 32958) (CMLFPKGFN.;;; 32960 . 33257)))))
STOP