(FILECREATED "31-Mar-86 15:54:13" {ERIS}<LISPCORE>CML>LAB>CMLCONVERT.;53 82640
changes to: (VARS CMLCONFLICTS)
(FNS \CMLSTRUCT.CLTYPE.TO.ILTYPE CMLCONVERT.MAKECOMS)
previous date: "26-Mar-86 17:17:42" {ERIS}<LISPCORE>CML>LAB>CMLCONVERT.;51)
(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CMLCONVERTCOMS)
(RPAQQ CMLCONVERTCOMS
((* Miscellaneous LISPCORE↑ development aids to help bring Common Lisp online. Not intended
for general lisp users. *)
(COMS (* Common Lisp names. *)
(VARS CMLCONVERT.FNNAMES CMLCONVERT.MACROS CMLCONVERT.SPECIALFORMS
CMLCONVERT.EVAL.WHEN.TAGS)
(P (SETQ CMLCONVERT.NAMES (SORT (APPEND CMLCONVERT.FNNAMES CMLCONVERT.MACROS
CMLCONVERT.SPECIALFORMS NIL))))
(COMS (* Namespace conflicts. MENU and STREAM are on CMLCONFLICTS because the Spice
Lisp implementation has MENU and STREAM DEFSTRUCTs. *)
(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 CMLCONVERT.NAME CMLCONVERT.NAMEIFY CMLCONVERT.NAMEIFYFN CMLIMPLEMENTED
CMLUNIMPLEMENTED)
(FNS CMLCONVERT.MOVECOMMENTS CMLCONVERT.MOVECOMMENTS.COND CMLCONVERT.CONDP
CMLCONVERT.COMMENTP))
(PROP CL:NAME %%ASET MACROP MACRO-P %%PUT %%RPLACA %%RPLACD %%SET-PLIST ;)
(COMS (* Spice Lisp file to Interlisp filepackage helpers. *)
(INITVARS (CMLCONVERT.SPICEDIR (QUOTE {ERIS}<COMMONLISP>CODE>))
(CMLCONVERT.FPKGDIR (QUOTE {ERIS}<COMMONLISP>FPKG>)))
(FNS CMLCONVERTALL CMLCONVERTONE CMLCONVERT CMLCONVERT.CONVERTFILE
CMLCONVERT.CONVERTCOMMENTFILE CMLCONVERT.STRINGTOCOMMENT CMLCONVERT.MAKECOMS
CMLCONVERT.READFILE CMLCONVERT.CONTAINS)
(COMS (* Read macro workarounds. *)
(FNS CMLCONVERT.READHASHMACRO CMLREADVBAR)
(MACROS \RDCONC FIXDOT)
(CONSTANTS READ.RT))
(COMS (* RECORD package workarounds. *)
(FNS CMLCONVERT.RECORDECL1 \CMLSTRUCT.CLTYPE.TO.ILTYPE DEFSTRUCT.TRANSLATE)
(P (MOVD? (QUOTE \RECORDBLOCK/RECORDECL1)
(QUOTE CMLCONVERT.OLD.RECORDECL1))
(MOVD (QUOTE CMLCONVERT.RECORDECL1)
(QUOTE \RECORDBLOCK/RECORDECL1))))
(FNS CMLCONVERT.FPKG.CONSTANTS CMLCONVERT.FPKG.DEFTYPE CMLCONVERT.FPKG.DEFSETF
CMLCONVERT.FPKG.FNS CMLCONVERT.FPKG.INITVARS CMLCONVERT.FPKG.MACROS
CMLCONVERT.FPKG.P CMLCONVERT.FPKG.PROPS CMLCONVERT.FPKG.RECORDS
CMLCONVERT.FPKG.VARS CMLCONVERT.FPKG.EVAL-WHEN CMLCONVERT.FPKG.;;;
CMLCONVERT.ADDTOCOMS)
(PROP CMLCONVERT.FPKG DEFCONSTANT DEFMACRO DEFUN DEFPARAMETER DEFSETF DEFSTRUCT DEFVAR
EVAL-WHEN DEFTYPE * DEFINE-SYSTEM-CONSTANT)
(* (PROP CMLCONVERT.FPKG DEFINE-MODIFY-MACRO DEFINE-SETF-METHOD)
These were CMLCONVERT.FPKG.MACROS and CMLCONVERT.FPKG.DEFSETF *)
(* Ignore package declarations, global comments, for at least the time being. *)
(VARS CMLIGNOREFNS)
(P (FOR NAME IN CMLIGNOREFNS DO (PUTPROP NAME (QUOTE CMLCONVERT.FPKG)
(QUOTE NILL))
(OR (GETD NAME)
(MOVD (QUOTE *)
NAME))))
(VARS (CMLCONVERT.RDTBL (COPYREADTABLE CMLRDTBL))
(CMLCONVERT.COMMENT.RDTBL (COPYREADTABLE CMLRDTBL)))
(P (SETSYNTAX (QUOTE ;)
(QUOTE OTHER)
CMLCONVERT.RDTBL)
(SETSYNTAX (QUOTE #)
(QUOTE (SPLICE FIRST NONIMMEDIATE ESCQUOTE CMLCONVERT.READHASHMACRO))
CMLCONVERT.RDTBL)
(SETSYNTAX (QUOTE ;)
(QUOTE OTHER)
CMLCONVERT.COMMENT.RDTBL)
(SETSYNTAX (QUOTE ,)
(QUOTE OTHER)
CMLCONVERT.COMMENT.RDTBL)))))
(* Miscellaneous LISPCORE↑ development aids to help bring Common Lisp online. Not intended for
general lisp users. *)
(* Common Lisp names. *)
(RPAQQ CMLCONVERT.FNNAMES (* + - / /= 1+ 1- < <= = > >= 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
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 LISP-IMPLEMENTATION-TYPE
LISP-IMPLEMENTATION-VERSION LIST LIST* LIST-ALL-PACKAGES LIST-LENGTH
LISTEN 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 NUERATOR NULL NUMBERP
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-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 SUBSEQ 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))
(RPAQQ CMLCONVERT.MACROS
(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 CMLCONVERT.SPECIALFORMS
(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 CMLCONVERT.EVAL.WHEN.TAGS ((EVAL . EVAL@LOAD)
(CL:COMPILE . EVAL@COMPILE)
(LOAD . COPY)
(COMPILE-MACLISP . EVAL@COMPILE)))
(SETQ CMLCONVERT.NAMES (SORT (APPEND CMLCONVERT.FNNAMES CMLCONVERT.MACROS CMLCONVERT.SPECIALFORMS NIL
)))
(* Namespace conflicts. MENU and STREAM are on CMLCONFLICTS because the Spice Lisp
implementation has MENU and STREAM DEFSTRUCTs. *)
(RPAQQ CMLCONFLICTS
(APPLY ARRAYP ASSOC ATAN ATOM BLOCK BREAK COMPILE COS COUNT DECLARE DELETE DIRECTORY DO ELT
ERROR EVERY EXPT FIND FIRST FLOOR GCD IF LDIFF LENGTH LOG MAP MAPC MAPCAR MAPCON
MAPHASH MAPLIST MEMBER MENU MERGE MOD NOTANY NOTEVERY NREVERSE NTH POSITION PRIN1 PUSH
PUSHNEW REMOVE REPLACE REVERSE SIN SOME SQRT STREAM 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
(CMLCONVERT.NAME
(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)))
(CMLCONVERT.NAMEIFY
(LAMBDA (EXPR) (* kbr:
"20-Mar-86 19:18")
(PROG (TAIL)
(COND
((LITATOM EXPR)
(RETURN (CMLCONVERT.NAME EXPR)))
((NOT (LISTP EXPR))
(RETURN EXPR)))
(SETQ TAIL EXPR)
(while TAIL do (RPLACA TAIL (CMLCONVERT.NAMEIFY (CAR TAIL)))
(COND
((NOT (LISTP (CDR TAIL)))
(RPLACD TAIL (CMLCONVERT.NAMEIFY (CDR TAIL)))
(RETURN))
(T (pop TAIL))))
(RETURN EXPR))))
(CMLCONVERT.NAMEIFYFN
(LAMBDA (FN) (* kbr:
"28-Aug-85 13:27")
(PUTDEF FN (QUOTE FNS)
(CMLCONVERT.NAMEIFY (GETDEF FN (QUOTE FNS))))))
(CMLIMPLEMENTED
(LAMBDA NIL (* kbr:
"29-Aug-85 16:32")
(PROG (NAMES CMLCONVERT.NAME)
(for NAME in CMLCONVERT.NAMES do (SETQ CMLCONVERT.NAME (CMLCONVERT.NAME
NAME))
(COND
((OR (GETD CMLCONVERT.NAME)
(GETPROP CMLCONVERT.NAME (QUOTE MACRO))
)
(push NAMES CMLCONVERT.NAME))))
(RETURN (DREVERSE NAMES)))))
(CMLUNIMPLEMENTED
(LAMBDA NIL (* kbr:
"29-Aug-85 16:33")
(PROG (NAMES CMLCONVERT.NAME)
(for NAME in CMLCONVERT.NAMES do (SETQ CMLCONVERT.NAME (CMLCONVERT.NAME
NAME))
(COND
((NOT (OR (GETD CMLCONVERT.NAME)
(GETPROP CMLCONVERT.NAME
(QUOTE MACRO))))
(push NAMES CMLCONVERT.NAME))))
(RETURN (DREVERSE NAMES)))))
)
(DEFINEQ
(CMLCONVERT.MOVECOMMENTS
(LAMBDA (EXPR) (* kbr:
"24-Mar-86 17:51")
(* Fixes up some of the
most common cases of
misplaced comments
generated during
conversion. *)
(COND
((NOT (LISTP EXPR))
EXPR)
(T (SELECTQ (CAR EXPR)
(* EXPR)
(COND (COND
((CMLCONVERT.CONDP EXPR)
(CMLCONVERT.MOVECOMMENTS.COND EXPR))))
EXPR)))))
(CMLCONVERT.MOVECOMMENTS.COND
(LAMBDA (EXPR) (* kbr:
"24-Mar-86 18:09")
(* Move COND comments.
Misplaced comments
between branches are
common. We fix this.
*)
(PROG (BRANCHES)
(for BRANCH1 in (CDR EXPR) as BRANCH2 in (APPEND (CDDR EXPR)
(QUOTE (ENDOFCOND)))
do (COND
((NOT (CMLCONVERT.COMMENTP BRANCH1))
(push BRANCHES BRANCH1))
((EQLENGTH BRANCH1 2) (* Empty comment.
Ignore it. *)
NIL)
((CMLCONVERT.COMMENTP BRANCH2) (* Comment followed by a
comment. Glue together
with following comment
to be inserted in next
pass through loop.
*)
(RPLACD BRANCH2 (NCONC (DREVERSE (CDR (DREVERSE (CDR BRANCH1))))
(CDR BRANCH2))))
(T (* Make comment apply to
following branch.
*)
(COND
((EQLENGTH BRANCH2 1)
(RPLACA BRANCH2 (BQUOTE (PROGN (\, BRANCH1)
(\, (CAR BRANCH2))))))
(T (RPLACD BRANCH2 (CONS BRANCH1 (CDR BRANCH2))))))))
(RPLACD EXPR (DREVERSE BRANCHES)))))
(CMLCONVERT.CONDP
(LAMBDA (EXPR) (* kbr:
"24-Mar-86 17:52")
(AND (LISTP EXPR)
(EQ (CAR EXPR)
(QUOTE COND))
(LISTP (CDR EXPR))
(for BRANCH in (CDR EXPR) always (LISTP BRANCH)))))
(CMLCONVERT.COMMENTP
(LAMBDA (EXPR) (* kbr:
"24-Mar-86 18:04")
(AND (LISTP EXPR)
(EQ (CAR EXPR)
(QUOTE *))
(EQ (CAR (LAST EXPR))
(QUOTE *)))))
)
(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. *)
(RPAQ? CMLCONVERT.SPICEDIR (QUOTE {ERIS}<COMMONLISP>CODE>))
(RPAQ? CMLCONVERT.FPKGDIR (QUOTE {ERIS}<COMMONLISP>FPKG>))
(DEFINEQ
(CMLCONVERTALL
(LAMBDA NIL (* kbr:
"23-Mar-86 15:22")
(PROG (SPICEFILENAME)
(OR (BOUNDP (QUOTE SPICEFILES))
(SETQ SPICEFILES (DIRECTORY (PACK* CMLCONVERT.SPICEDIR (QUOTE *.SLISP;)))))
(for SPICEFILENAME in SPICEFILES do (CMLCONVERTONE SPICEFILENAME)
(pop SPICEFILES)))))
(CMLCONVERTONE
(LAMBDA (SPICEFILENAME) (* kbr:
"23-Mar-86 15:22")
(PROG (FPKGFILENAME)
(PRINT SPICEFILENAME)
(CMLCONVERT SPICEFILENAME)
(SETQ FPKGFILENAME (PACK* CMLCONVERT.FPKGDIR (FILENAMEFIELD SPICEFILENAME (QUOTE NAME))))
(PRINT (MAKEFILE FPKGFILENAME))
(for FN in (FILECOMSLST FPKGFILENAME) do (REMPROP FN (QUOTE EXPR))))))
(CMLCONVERT
(LAMBDA (FILE) (* kbr:
"20-Mar-86 10:39")
(PROG (FILECOMS)
(CLOSEF? (QUOTE {CORE}CMLCONVERT;1))
(DELFILE (QUOTE {CORE}CMLCONVERT;1))
(CMLCONVERT.CONVERTFILE FILE (QUOTE {CORE}CMLCONVERT;1))
(SETQ FILECOMS (CMLCONVERT.MAKECOMS FILE (QUOTE {CORE}CMLCONVERT;1)))
(RETURN FILECOMS))))
(CMLCONVERT.CONVERTFILE
(LAMBDA (FROMFILE TOFILE) (* kbr:
"24-Mar-86 16:51")
(PROG (FROMSTREAM TOSTREAM COMMENTSTREAM COMMENTFILE CODE INCOMMENT INSTRING INESCAPE)
(SETQ FROMSTREAM (OPENSTREAM FROMFILE (QUOTE INPUT)))
(SETQ TOSTREAM (OPENSTREAM TOFILE (QUOTE OUTPUT)
(QUOTE NEW)))
(SETQ COMMENTFILE (QUOTE {CORE}CMLCONVERTCOMMENTFILE;1))
(DELFILE COMMENTFILE)
(while (NOT (EOFP FROMSTREAM))
do (SETQ CODE (\BIN FROMSTREAM))
(COND
(INESCAPE (COND
(INCOMMENT (\BOUT COMMENTSTREAM CODE))
(T (\BOUT TOSTREAM CODE)))
(SETQ INESCAPE NIL))
(T (COND
((EQ CODE (CHARCODE \))
(SETQ INESCAPE T)))
(COND
((AND (EQ CODE (CHARCODE %"))
(NOT INCOMMENT))
(SETQ INSTRING (NOT INSTRING))))
(COND
((AND (EQ CODE (CHARCODE ;))
(NOT INSTRING))
(COND
((NOT INCOMMENT)
(SETQ COMMENTSTREAM (OPENSTREAM COMMENTFILE (QUOTE OUTPUT)
(QUOTE NEW)))
(SETQ INCOMMENT T))))
((EQ CODE (CHARCODE CR))
(COND
(INCOMMENT (COND
((OR (EOFP FROMSTREAM)
(NOT (EQ (\PEEKBIN FROMSTREAM)
(CHARCODE ;))))
(CLOSEF COMMENTSTREAM)
(SETQ INCOMMENT NIL)
(CMLCONVERT.CONVERTCOMMENTFILE COMMENTFILE TOSTREAM)
(DELFILE COMMENTFILE)
(\BOUT TOSTREAM CODE))
(T (\BOUT COMMENTSTREAM CODE))))
(T (\BOUT TOSTREAM CODE))))
(INCOMMENT (\BOUT COMMENTSTREAM CODE))
(INSTRING (\BOUT TOSTREAM CODE))
(T (\BOUT TOSTREAM (U-CASECODE CODE)))))))
(CLOSEF FROMSTREAM)
(RETURN (CLOSEF TOSTREAM)))))
(CMLCONVERT.CONVERTCOMMENTFILE
(LAMBDA (COMMENTFILE TOSTREAM) (* kbr:
"24-Mar-86 18:38")
(PROG (COMMENTSTREAM BADCOMMENT)
(SETQ COMMENTSTREAM (COND
((STRINGP COMMENTFILE)
(OPENSTRINGSTREAM COMMENTFILE (QUOTE INPUT)))
(T (OPENSTREAM COMMENTFILE (QUOTE INPUT)))))
(PROGN (OR (EOFP COMMENTSTREAM)
(SKIPSEPRS COMMENTSTREAM CMLCONVERT.COMMENT.RDTBL))
(COND
((EOFP COMMENTSTREAM) (* Empty comment *)
(\BOUT TOSTREAM (CHARCODE " "))
(GO EXIT))))
(while (NOT (EOFP COMMENTSTREAM)) do (COND
((OR (NULL (NLSETQ (READ COMMENTSTREAM
CMLCONVERT.COMMENT.RDTBL))
)
(NULL (NLSETQ (SKIPSEPRS COMMENTSTREAM
CMLCONVERT.COMMENT.RDTBL)
))) (* Bad comment.
Will have to use string.
*)
(SETQ BADCOMMENT T)
(RETURN))))
(SETFILEPTR COMMENTSTREAM 0)
(PRIN1 "(; " TOSTREAM)
(COND
(BADCOMMENT (\BOUT TOSTREAM (CHARCODE %"))
(while (NOT (EOFP COMMENTSTREAM))
do (PROG (CODE)
(SETQ CODE (\BIN COMMENTSTREAM))
(COND
((OR (EQ CODE (CHARCODE %"))
(EQ CODE (CHARCODE %.))) (* What pain! The escape
character in
CMLCONVERT.RDTBL is \,
not %%. *)
(\BOUT TOSTREAM (CHARCODE \))
(\BOUT TOSTREAM CODE))
(T (\BOUT TOSTREAM CODE)))))
(\BOUT TOSTREAM (CHARCODE %")))
(T (while (NOT (EOFP COMMENTSTREAM)) do (PRIN2 (READ COMMENTSTREAM
CMLCONVERT.COMMENT.RDTBL)
TOSTREAM CMLCONVERT.RDTBL)
(PRIN1 " " TOSTREAM)
(SKIPSEPRS COMMENTSTREAM T))))
(PRIN1 " ;)" TOSTREAM)
EXIT
(CLOSEF COMMENTSTREAM))))
(CMLCONVERT.STRINGTOCOMMENT
(LAMBDA (STRING) (* kbr:
"20-Mar-86 11:48")
(PROG (STREAM ANSWER)
(CLOSEF? (QUOTE {CORE}CMLCONVERTCOMMENT;1))
(DELFILE (QUOTE {CORE}CMLCONVERTCOMMENT;1))
(SETQ STREAM (OPENSTREAM (QUOTE {CORE}CMLCONVERTCOMMENT;1)
(QUOTE OUTPUT)
(QUOTE NEW)))
(CMLCONVERT.CONVERTCOMMENTFILE STRING STREAM)
(CLOSEF STREAM)
(SETQ STREAM (OPENSTREAM (QUOTE {CORE}CMLCONVERTCOMMENT;1)
(QUOTE INPUT)
(QUOTE OLD)))
(SETQ ANSWER (CMLCONVERT.NAMEIFY (READ STREAM)))
(CLOSEF STREAM)
(RETURN ANSWER))))
(CMLCONVERT.MAKECOMS
(LAMBDA (FILE CONVERTEDFILE) (* kbr:
"31-Mar-86 12:20")
(* Create FILECOMS for
one FILE *)
(PROG (FILECOMS FORMS FPKGFN)
(SETQ FILECOMS (FILECOMS FILE))
(SET FILECOMS NIL) (* Get FPKG expressions
*)
(SETQ FORMS (CMLCONVERT.READFILE CONVERTEDFILE)) (* Establish FPKG in
lisp environment *)
(for FORM in FORMS when (LISTP FORM)
do (COND
((SETQ FPKGFN (GETPROP (CAR FORM)
(QUOTE CMLCONVERT.FPKG)))
(COND
((FMEMB (CAR FORM)
(QUOTE (DEFINE-MODIFY-MACRO DEFINE-SETF-METHOD DEFMACRO DEFUN DEFSETF
DEFTYPE))) (* A form we understand
about and we need to
eval (well, pretty safe
with DFNFLG = PROP) *)
(EVAL FORM)
(APPLY* FPKGFN FILECOMS FORM))
((FMEMB (CAR FORM)
(QUOTE (DEFCONSTANT DEFVAR)))
(APPLY* FPKGFN FILECOMS FORM))
((EQ (CAR FORM)
(QUOTE DEFSTRUCT))
(COND
((CMLCONVERT.CONTAINS FORM (QUOTE :INCLUDE))
(APPLY* (FUNCTION CMLCONVERT.FPKG.P)
FILECOMS
(BQUOTE (* (* Couldn't
completely convert this
DEFSTRUCT because it
contains :INCLUDE.
*) (\, FORM)))))
(T (EVAL FORM)
(APPLY* FPKGFN FILECOMS FORM))))))
(T (APPLY* (FUNCTION CMLCONVERT.FPKG.P)
FILECOMS FORM))))
(RETURN FILECOMS))))
(CMLCONVERT.READFILE
(LAMBDA (FILE) (* kbr:
"24-Mar-86 19:08")
(* READFILE with
translation. *)
(PROG (ANSWER EXPRS EXPR EXPAND)
(RESETLST (RESETSAVE NIL (LIST (QUOTE INPUT)
(INFILE FILE)))
(SETQ FILE (INPUT))
(while (NOT (EOFP FILE))
do (SETQ EXPR (READ FILE CMLCONVERT.RDTBL))
(COND
((NOT (EQ (CAR (LAST (GETSYNTAX (QUOTE #)
CMLCONVERT.RDTBL)))
(QUOTE CMLCONVERT.READHASHMACRO))) (* BREAK1 NIL T)
(* I don't know why this
happens but I know how
to fix it real good.
*)
(printout T "Warning. Readtable smashed after reading" T EXPR T
"Unsmashing and continuing." T)
(SETSYNTAX (QUOTE #)
(QUOTE (SPLICE FIRST NONIMMEDIATE ESCQUOTE CMLCONVERT.READHASHMACRO
))
CMLCONVERT.RDTBL)))
(SETQ EXPAND (CMLCONVERT.NAMEIFY EXPR))
(SETQ EXPRS (NCONC EXPRS (COND
((AND (LISTP EXPAND)
(EQ (CAR EXPAND)
(QUOTE EVAL-WHEN)))
(CDDR EXPAND))
(T (LIST EXPAND)))))
(SKIPSEPRS FILE CMLCONVERT.RDTBL))
(CLOSEF FILE))
(* The CMU Spice Lisp style is to document each function and macro with a
comment before each function and macro.
Pull these comments into our defs. *)
(for EXPR in EXPRS do (CMLCONVERT.MOVECOMMENTS EXPR))
(for EXPR in EXPRS when (AND (LISTP EXPR)
(FMEMB (CAR EXPR)
(QUOTE (DEFUN DEFMACRO)))
(OR (NULL (CADDR EXPR))
(LISTP (CADDR EXPR)))
(for FORM in (CADDR EXPR) thereis (CMLCONVERT.COMMENTP FORM)))
do (RPLACA (CDDR EXPR)
(for FORM in (CADDR EXPR) when (NOT (CMLCONVERT.COMMENTP FORM)) collect FORM))
)
(for EXPR in EXPRS when (AND (LISTP EXPR)
(FMEMB (CAR EXPR)
(QUOTE (DEFUN DEFMACRO)))
(OR (NULL (CADDR EXPR))
(LISTP (CADDR EXPR)))
(STRINGP (CADDDR EXPR)))
do (RPLACA (CDDDR EXPR)
(CMLCONVERT.STRINGTOCOMMENT (CADDDR EXPR))))
(for EXPR in EXPRS when (AND (LISTP EXPR)
(FMEMB (CAR EXPR)
(QUOTE (DEFUN DEFMACRO)))
(OR (NULL (CADDR EXPR))
(LISTP (CADDR EXPR)))
(AND (LISTP (CADDDR EXPR))
(EQLENGTH (CADDDR EXPR)
3)
(EQ (CAR (CADDDR EXPR))
(QUOTE *))
(STRINGP (CADR (CADDDR EXPR)))
(EQ (CADDR (CADDDR EXPR))
(QUOTE *))))
do (RPLACA (CDDDR EXPR)
(CMLCONVERT.STRINGTOCOMMENT (CADR (CADDDR EXPR)))))
(for EXPR1 in EXPRS as EXPR2 in (APPEND (CDR EXPRS)
(QUOTE ((EOF))))
do (COND
((AND (LISTP EXPR1)
(EQ (CAR EXPR1)
(QUOTE *))
(LISTP EXPR2)
(FMEMB (CAR EXPR2)
(QUOTE (DEFUN DEFMACRO)))) (* Pull in comment.
*)
(COND
((OR (NULL (CADDR EXPR2))
(LISTP (CADDR EXPR2)))
(RPLACD (CDDR EXPR2)
(CONS EXPR1 (CDDDR EXPR2))))
(T (* Spice Lisp DEFUN? *)
(RPLACD (CDDDR EXPR2)
(CONS EXPR1 (CDDDDR EXPR2))))))
((AND (LISTP EXPR1)
(EQ (CAR EXPR1)
(QUOTE DEFSTRUCT))) (* Strip comments
because Xerox DEFSTRUCT
can't handle them I
guess. *)
(SETQ EXPR1 (BQUOTE ((\, (CAR EXPR1))
(\, (CADR EXPR1))
(\,@ (for FIELD in (CDDR EXPR1)
when (NOT (AND (LISTP FIELD)
(EQ (CAR FIELD)
(QUOTE *)))) collect FIELD)))))
(push ANSWER EXPR1))
((LISTP EXPR1)
(push ANSWER EXPR1))
((EQ EXPR1 (CHARACTER (CHARCODE ↑L))) (* Form feed.
Ignore it. *)
NIL)
(T (printout T "Warning. Expected to read list in converted file instead of" T
EXPR1 T))))
(SETQ ANSWER (DREVERSE ANSWER))
(RETURN ANSWER))))
(CMLCONVERT.CONTAINS
(LAMBDA (X Y) (* kbr:
"22-Mar-86 14:34")
(OR (EQ X Y)
(AND (LISTP X)
(OR (CMLCONVERT.CONTAINS (CAR X)
Y)
(CMLCONVERT.CONTAINS (CDR X)
Y))))))
)
(* Read macro workarounds. *)
(DEFINEQ
(CMLCONVERT.READHASHMACRO
(LAMBDA (STREAM RDTBL INDEX) (* kbr:
"21-Mar-86 12:07")
(DECLARE (USEDFREE #CURRENTRDTBL# \RBFLG)
(GLOBALVARS \PERCENTFLG \BRKFLG \SEPRFLG))
(LET ((NEXTCHAR (PEEKCCODE STREAM))
READVAL EVALFORM)
(while (DIGITCHARP NEXTCHAR) do (SETQ INDEX (PLUS (TIMES (OR INDEX 0)
10)
(DIFFERENCE NEXTCHAR
(CHARCODE 0))))
(READCCODE STREAM RDTBL)
(SETQ NEXTCHAR (PEEKCCODE STREAM RDTBL)))
(SELCHARQ NEXTCHAR
(' (READCCODE STREAM RDTBL)
(LIST (LIST (QUOTE FUNCTION)
(READ STREAM RDTBL))))
(%. (READCCODE STREAM RDTBL)
(SETQ EVALFORM (READ STREAM RDTBL))
(printout T "Warning. Not evaluating " T EVALFORM T)
(RETFROM (QUOTE \SUBREAD)
EVALFORM))
(, (READCCODE STREAM RDTBL)
(LIST (LIST (QUOTE LOADTIMECONSTANT)
(READ STREAM RDTBL))))
(\ (READCCODE STREAM RDTBL)
(SETQ NEXTCHAR (PEEKCCODE STREAM RDTBL))
(LIST (INT-CHAR (CHARCODE.DECODE (COND
((OR (ILESSP NEXTCHAR (CHARCODE A))
(AND (IGREATERP NEXTCHAR (CHARCODE
Z))
(ILESSP NEXTCHAR (CHARCODE a)))
(IGREATERP NEXTCHAR (CHARCODE z)))
(CHARACTER (\BIN STREAM RDTBL)))
(T (PROG (CHAR) (* PATCH AROUND ABOUT
NOT KNOWING (CHARCODE
DELETE) *)
(SETQ CHAR (READ STREAM RDTBL))
(COND
((EQ (U-CASE CHAR)
(QUOTE DELETE))
(SETQ CHAR (QUOTE DEL))))
(RETURN CHAR))))))))
("*" (READCCODE STREAM RDTBL)
(LIST (LET ((CONTENTS
(for (C ←(READCCODE STREAM RDTBL))
by (READCCODE STREAM RDTBL)
until (NOT (MEMQ C (CONSTANT (LIST (CHARCODE 0)
(CHARCODE 1)))))
collect (IDIFFERENCE C (CONSTANT (CHARCODE 0))))))
(COND
(INDEX (FILL.VECTOR (MAKE-ARRAY INDEX :ELEMENT-TYPE
(QUOTE BIT))
CONTENTS))
((EQ (LENGTH CONTENTS)
0)
(MAKE-ARRAY 0))
(T (MAKE-ARRAY (LENGTH CONTENTS)
:INITIAL-CONTENTS CONTENTS :ELEMENT-TYPE
(QUOTE BIT)))))))
("(" (* GOD. Why do I have
to do this hack? *)
(RETFROM (QUOTE \SUBREAD)
(PROG (READTYPE LST END ELT DOTLOC SHIFTEDCHARSET)
(SETQ ELT (LET ((CONTENTS (READ STREAM RDTBL)))
(COND
(INDEX (FILL.VECTOR (MAKE-ARRAY INDEX)
CONTENTS))
((EQ (LENGTH CONTENTS)
0)
(MAKE-ARRAY 0))
(T (MAKE-ARRAY (LENGTH CONTENTS)
:INITIAL-CONTENTS CONTENTS)))))
(* Back over
right-bracket and return
instead of setting free
\RBFLG)
(SETQ READTYPE (STKARG 3 (QUOTE \SUBREAD)))
(SETQ LST (STKARG 8 (QUOTE \SUBREAD)))
(SETQ END (STKARG 9 (QUOTE \SUBREAD)))(* (SETQ DOTLOC
(STKARG 11 (QUOTE
\SUBREAD))))
(SETQ SHIFTEDCHARSET (STKARG 12 (QUOTE \SUBREAD)))
(\RDCONC ELT (AND \RBFLG (\BACKNSCHAR STREAM SHIFTEDCHARSET))
(RETURN ELT)) (* (FIXDOT))
(RETURN LST))))
(":" (READCCODE STREAM RDTBL) (* not right!)
(LIST (RSTRING STREAM RDTBL)))
((O o)
(READCCODE STREAM RDTBL)
(LIST (READNUMBERINBASE STREAM 8)))
((B b)
(READCCODE STREAM RDTBL)
(LIST (READNUMBERINBASE STREAM 2)))
((X x)
(READCCODE STREAM RDTBL)
(LIST (READNUMBERINBASE STREAM 16)))
((R r)
(READCCODE STREAM RDTBL)
(LIST (READNUMBERINBASE STREAM INDEX)))
((A a)
(READCCODE STREAM RDTBL)
(LIST (LET ((CONTENTS (READ STREAM RDTBL)))
(MAKE-ARRAY (ESTIMATE-DIMENSIONALITY INDEX CONTENTS)
:INITIAL-CONTENTS CONTENTS))))
((S s)
(READCCODE STREAM RDTBL)
(LIST (CREATE-STRUCTURE (READ STREAM RDTBL))))
(+ (READCCODE STREAM RDTBL)
(COND
((NOT (CMLREAD.FEATURE.PARSER (READ STREAM SIMPLERDTBL)))
(READ STREAM RDTBL)))
NIL)
(- (READCCODE STREAM RDTBL)
(COND
((CMLREAD.FEATURE.PARSER (READ STREAM SIMPLERDTBL))
(READ STREAM RDTBL)))
NIL)
("|" (READCCODE STREAM RDTBL) (* special comment)
(SKIP.HASH.COMMENT STREAM RDTBL) (* WARNING: ANOTHER
GROSS PATCH HERE.
*)
(RETFROM (QUOTE \SUBREAD)
NIL))
(< (READ<))
((SPACE TAB NEWLINE PAGE RETURN RIGHTPAREN)
(READCCODE STREAM RDTBL)
(ERROR "Illegal read syntax " (CHARCODE.UNDECODE NEXTCHAR)))
(PROGN (READCCODE STREAM RDTBL)
(LIST (APPLY* (OR (GETPROP (CHARACTER NEXTCHAR)
(QUOTE HASHREADMACRO))
(ERROR "Undefined hashmacro char" NEXTCHAR))
STREAM RDTBL)))))))
(CMLREADVBAR
(LAMBDA (STREAM RDTBL) (* kbr:
"20-Mar-86 13:02")
(PROG (CODE CODES ANSWER)
(SETQ CODES (while (NOT (EQ (SETQ CODE (\BIN STREAM))
(CHARCODE %|))) collect CODE))
(SETQ ANSWER (PACKC CODES))
(RETURN ANSWER))))
)
(DECLARE: EVAL@COMPILE
(PUTPROPS \RDCONC MACRO ((ELT . TOPFORMS)
(COND (LST (RPLACD END (SETQ END (CONS ELT))))
((EQ READTYPE READ.RT) . TOPFORMS)
(T (SETQ LST (SETQ END (CONS ELT)))))))
(PUTPROPS FIXDOT MACRO (NIL (PROGN (* Fix a non-first dot followed by a singleton)
(AND DOTLOC (CDDR DOTLOC)
(NULL (CDDDR DOTLOC))
(RPLACD DOTLOC (CADDR DOTLOC))))))
)
(DECLARE: EVAL@COMPILE
(RPAQQ READ.RT NIL)
(CONSTANTS READ.RT)
)
(* RECORD package workarounds. *)
(DEFINEQ
(CMLCONVERT.RECORDECL1
(LAMBDA (DECL PARENT) (* kbr:
"20-Mar-86 23:21")
(* DEATH TO THE
BLECHEROUS BUG! *)
(COND
((AND (LISTP DECL)
(FMEMB (CAR DECL)
(QUOTE (RECORD TYPERECORD)))
(LISTP (CAR (CADDR DECL)))
(EQ (CADR (CAR (CADDR DECL)))
(QUOTE POINTER)))
(SETQ DECL (BQUOTE ((\, (CAR DECL))
(\, (CADR DECL))
(\, (for FIELD in (CADDR DECL)
collect (COND
((AND (LISTP FIELD)
(EQ (CADR FIELD)
(QUOTE POINTER)))
(CAR FIELD))
(T FIELD))))
(\,@ (CDDDR DECL)))))))
(CMLCONVERT.OLD.RECORDECL1 DECL PARENT)))
(\CMLSTRUCT.CLTYPE.TO.ILTYPE
(LAMBDA (ELEMENTTYPE) (* kbr:
"31-Mar-86 11:01")
(* * Returns the most specific InterLisp type descriptor which will hold a
given type.)
(* * Note: This function accepts only a limited subset of the Common Lisp
type specifiers: T FLOAT SINGLE-FLOAT FIXNUM BIT
(MOD n) (UNSIGNED-BYTE n) INTEGER (INTEGER low high) XPOINTER
DOUBLE-POINTER)
(COND
((AND (LISTP ELEMENTTYPE)
(EQ (CAR ELEMENTTYPE)
(QUOTE QUOTE))) (* WHAT!!! *)
(SETQ ELEMENTTYPE (CADR ELEMENTTYPE))))
(SELECTQ ELEMENTTYPE
((STRING-CHAR T SIMPLE-STRING SIMPLE-VECTOR LIST)
(QUOTE POINTER))
(FIXNUM (QUOTE SIGNEDWORD))
(INTEGER (QUOTE FIXP))
(BIT (QUOTE (BITS 1)))
(XPOINTER ELEMENTTYPE)
((SINGLE-FLOAT FLOAT)
(QUOTE FLOATP))
(COND
((AND (EQ (CAR (LISTP ELEMENTTYPE))
(QUOTE MOD))
(NULL (CDDR ELEMENTTYPE))
(FIXP (CADR ELEMENTTYPE))
(ILESSP 1 (CADR ELEMENTTYPE))) (* (MOD n) is converted
to the next higher
enclosing type.)
(LET ((MOD# (CADR ELEMENTTYPE)))
(COND
((ILEQ MOD# (LLSH 1 BITSPERWORD))
(BQUOTE (BITS (\, (INTEGERLENGTH (SUB1 MOD#))))))
((ILEQ MOD# MAX.FIXP)
(QUOTE FIXP))
(T (QUOTE POINTER)))))
((AND (EQ (CAR (LISTP ELEMENTTYPE))
(QUOTE UNSIGNED-BYTE))
(NULL (CDDR ELEMENTTYPE))
(FIXP (CADR ELEMENTTYPE))
(ILESSP 0 (CADR ELEMENTTYPE))) (* (UNSIGNED.BYTE n) is
converted to the next
higher enclosing type.)
(LET ((#BITS (CADR ELEMENTTYPE)))
(COND
((ILEQ #BITS BITSPERWORD)
(BQUOTE (BITS (\, #BITS))))
((ILEQ #BITS (CONSTANT (INTEGERLENGTH MAX.FIXP)))
(QUOTE FIXP))
(T (QUOTE POINTER)))))
((AND (EQ (CAR (LISTP ELEMENTTYPE))
(QUOTE INTEGER))
(NULL (CDDDR ELEMENTTYPE))
(FIXP (CADR ELEMENTTYPE))
(FIXP (CADDR ELEMENTTYPE))
(ILESSP (CADR ELEMENTTYPE)
(CADDR ELEMENTTYPE))) (* (INTEGER low high))
(LET* ((LOW (CADR ELEMENTTYPE))
(HIGH (CADDR ELEMENTTYPE))
(RANGE (IDIFFERENCE HIGH LOW))) (* Type simplification
should probably be done
somewhere else)
(COND
((IEQP LOW 0) (* (INTEGER 0 high) =>
(MOD nbits))
(\CMLSTRUCT.CLTYPE.TO.ILTYPE (BQUOTE (MOD (\, (ADD1 RANGE))))))
((AND (IGEQ LOW MIN.FIXP)
(ILEQ HIGH MAX.FIXP)) (* (INTEGER >= MIN.FIXP
<= MAX.FIXP) == FIXNUM)
(QUOTE FIXP))
(T (QUOTE POINTER)))))
((OR (EQUAL ELEMENTTYPE (QUOTE (SIMPLE-VECTOR CL:* FIXNUM)))
(EQUAL ELEMENTTYPE (QUOTE (SIMPLE-VECTOR * FIXNUM)))) (* I don't really know
what this should be.
*)
(RPLACA (CDR ELEMENTTYPE)
(QUOTE *))
(QUOTE POINTER))
((FMEMB ELEMENTTYPE (USERDATATYPES))
(QUOTE POINTER))
(T (ERROR "Bad type specifier" ELEMENTTYPE))))))
(DEFSTRUCT.TRANSLATE
(LAMBDA (TAIL) (* kbr:
"21-Mar-86 18:40")
(LET* ((name&options (CAR TAIL))
(slotdescrs (CDR TAIL))
options
(doc (AND (STRINGP (CAR slotdescrs))
(pop slotdescrs)))
type class (name (COND
((LISTP name&options)
(CAR name&options))
(T name&options)))
(slots)
(slotnames)
(slotfns)
(initialization)
(includes)
slotnames
(conc-name (CONCAT name "-"))
(constructors)
(predicate (PACK* name "-P"))
(print-function (FUNCTION DEFAULT-STRUCTURE-PRINTER))
(copier (PACK* "COPY-" name))
named NAMED)
(COND
((LISTP name&options)
(for option in (SETQ options (CDR name&options))
do (COND
((LISTP option)
(SELECTQ (CAR option)
(:CLASS (SETQ class (CADR option))
NIL)
(:CONSTRUCTOR (push constructors (CDR option)))
(:CONC-NAME (SETQ conc-name (OR (CADR option)
"")))
(:INCLUDE (push includes (CADR option)))
(:COPIER (SETQ copier (CADR option)))
(:PRINT-FUNCTION
(SETQ print-function (CADR option)))
(:PREDICATE (SETQ predicate (CADR option)))
(:TYPE (SETQ class (PACK* (CADR option)
"-CLASS")))
(:INITIAL-OFFSET
(HELP ":INITIAL-OFFSET unimplemented for DEFSTRUCT"))
(SHOULDNT (CONCAT option "bad option"))))
(T (SELECTQ option
(:NAMED (SETQ NAMED T))
(ERROR "DEFSTRUCT declaration error " option)))))))
(COND
(includes (COND
((AND (EQ class (QUOTE LIST-CLASS))
(NULL (CDR includes)))
(LET* ((includename (CAR includes))
(includeslotdescrs (CDR includes)))
(bind slotname includedescr for x
in (CDDR (OR (RECLOOK includename)
(ERROR "Undefined structure in :INCLUDE "
includename)))
eachtime (SETQ slotname (OR (CAR (LISTP x))
x))
(SETQ includedescr (OR (OR (FMEMB slotname
includeslotdescrs)
slotname)
(FASSOC slotname includeslotdescrs))
) do (push slotdescrs (OR includedescr x))
(* redeclaration takes
precedence))))
(T (HELP "Can't fake includes yet")))))
(bind slotname options for x in slotdescrs
eachtime (SETQ slotname (OR (CAR (LISTP x))
x))
(SETQ options (CDDR (LISTP x)))
do
(push slotnames slotname)
(* * make slot accessor and settor fns and dmacros)
(pushlist
slotfns
(LET (conc setfconc)
(BQUOTE
((DEFUN (\, (SETQ conc (PACK* conc-name slotname)))
(object)
(fetch ((\, name)
(\, slotname)) of object))
(DECLARE: EVAL@COMPILE (PUTPROP (QUOTE (\, conc))
(QUOTE DMACRO)
(QUOTE ((obj)
(fetch ((\, name)
(\, slotname))
of obj))))
(\,@ (COND
((CADR (MEMB (QUOTE :READ-ONLY)
options))
NIL)
(T (BQUOTE ((PUTPROP (QUOTE (\, (SETQ setfconc
(PACK* "SETF-" conc))))
(QUOTE DMACRO)
(QUOTE ((obj value)
(replace ((\, name)
(\, slotname))
obj value))))
(DEFSETF (\, conc)
(\, setfconc))))))))))))
(* * include this init form so that create will initialize, although we
do it in our constructor as well)
(COND
((CDR (LISTP x))
(pushlist initialization (BQUOTE ((\, slotname)←(\, (CADR (LISTP x))))))))
(* * make the field definition)
(bind (type ←(QUOTE POINTER)) for option on (CDDR (LISTP x))
by (CDDR option) do (SELECTQ (CAR option)
(:TYPE (SETQ type (\CMLSTRUCT.CLTYPE.TO.ILTYPE
(CADR option))))
(:READ-ONLY (* Handled in settor
building section))
(ERROR "Bad DEFSTRUCT slot " x))
finally (push slots (LIST slotname type))))
(BQUOTE
(((\, (SELECTQ class
((NIL STRUCTURE)
(QUOTE DATATYPE))
(LIST-CLASS (if NAMED
then (QUOTE TYPERECORD)
else (QUOTE RECORD)))
((VECTOR VECTOR-CLASS)
(QUOTE ARRAYRECORD))
(HELP)))
(\, name)
(\, (COND
((EQ class (QUOTE VECTOR-CLASS)) (* Mysterious problem
I don't understand.
*)
(for SLOT in slots when (LISTP SLOT) collect (CAR SLOT)))
(T slots)))
(\., initialization))
(\., slotfns)
(\., (AND predicate (BQUOTE ((DEFUN (\, predicate)
(obj)
(type? (\, name)
obj))))))
(\., (AND copier (BQUOTE ((DEFUN (\, copier)
(obj)
(create (\, name) using obj))))))
(\., (AND print-function (BQUOTE ((DEFPRINT (QUOTE (\, name))
(FUNCTION (LAMBDA (x stream)
(COND
(stream
(AND (EQ stream T)
(SETQ stream (
TTYDISPLAYSTREAM
)))
(APPLY* (FUNCTION (\,
print-function
))
x stream 0)
(QUOTE ("")))))))))))
(\.,
(for constructor in (OR constructors (LIST (LIST (PACK* "MAKE-" name))))
collect
(COND
((CDR constructor)
(BQUOTE (DEFUN (\, (CAR constructor))
(\, (CADR constructor))
(create (\, name)
(\,@ (for x in (CADR constructor)
join (COND
((FMEMB x (QUOTE (&KEY &OPTIONAL &REST)
))
NIL)
((LISTP x)
(LIST (CAR x)
(QUOTE ←)
(CAR x)))
(T (LIST x (QUOTE ←)
x)))))))))
(T (BQUOTE (DEFUN (\, (CAR constructor))
(&KEY (\,@ (for x in slotdescrs
collect (COND
((NLISTP x)
x)
(T (LIST (CAR x)
(CADR x)))))))
(create (\, name)
(\,@ (for x in slotnames
join (LIST x (QUOTE ←)
x))))))))))
(\., (for slot in slotnames bind conc setfconc
join (BQUOTE ((DEFUN (\, (SETQ conc (PACK* conc-name slot)))
(object)
(fetch ((\, name)
(\, slot))
object))
(DECLARE: EVAL@COMPILE
(PUTPROP (QUOTE (\, conc))
(QUOTE DMACRO)
(QUOTE ((obj)
(fetch ((\, name)
(\, slot))
obj))))
(PUTPROP (QUOTE (\, (SETQ setfconc (PACK* "SETF-" conc))
))
(QUOTE DMACRO)
(QUOTE ((obj value)
(replace ((\, name)
(\, slot))
obj value))))
(DEFSETF (\, conc)
(\, setfconc))))))))))))
)
(MOVD? (QUOTE \RECORDBLOCK/RECORDECL1)
(QUOTE CMLCONVERT.OLD.RECORDECL1))
(MOVD (QUOTE CMLCONVERT.RECORDECL1)
(QUOTE \RECORDBLOCK/RECORDECL1))
(DEFINEQ
(CMLCONVERT.FPKG.CONSTANTS
(LAMBDA (FILECOMS EXPR) (* kbr:
"19-Mar-86 15:52")
(* CONSTANTS file
package command.
EXPR is a RPAQ?
expression. *)
(PROG NIL
(CMLCONVERT.ADDTOCOMS FILECOMS (QUOTE CONSTANTS)
(LIST (CADR EXPR)
(CADDR EXPR))))))
(CMLCONVERT.FPKG.DEFTYPE
(LAMBDA (FILECOMS EXPR) (* kbr:
"19-Mar-86 15:53")
(* Put a DEFTYPE
expression into a file
package. EXPR is the
deftype expression.
*)
(PROG NIL
(CMLCONVERT.ADDTOCOMS FILECOMS (QUOTE RECORDS)
(CADR EXPR)))))
(CMLCONVERT.FPKG.DEFSETF
(LAMBDA (FILECOMS EXPR) (* kbr:
"19-Mar-86 15:53")
(* PROPS file package
command. *)
(PROG NIL
(for PROPNAME in (QUOTE (SETF-METHOD-EXPANDER SETF-INVERSE))
when (GETPROP (CADR EXPR)
PROPNAME) do (CMLCONVERT.ADDTOCOMS FILECOMS (QUOTE PROPS)
(LIST (CADR EXPR)
PROPNAME))))))
(CMLCONVERT.FPKG.FNS
(LAMBDA (FILECOMS EXPR) (* kbr:
"19-Mar-86 15:53")
(* FNS file package
command. EXPR is a
definition. *)
(PROG NIL
(CMLCONVERT.ADDTOCOMS FILECOMS (QUOTE FNS)
(CADR EXPR)))))
(CMLCONVERT.FPKG.INITVARS
(LAMBDA (FILECOMS EXPR) (* kbr:
"19-Mar-86 15:53")
(* INITVARS file
package command.
EXPR is a RPAQ?
expression. *)
(PROG NIL
(CMLCONVERT.ADDTOCOMS FILECOMS (QUOTE INITVARS)
(LIST (CADR EXPR)
(CADDR EXPR))))))
(CMLCONVERT.FPKG.MACROS
(LAMBDA (FILECOMS EXPR) (* kbr:
"19-Mar-86 15:46")
(* MACROS file package
command. EXPR is a
definition. *)
(PROG (MACRO)
(SETQ MACRO (SELECTQ (CAR EXPR)
((DEFMACRO DEFINE-MODIFY-MACRO)
(CADR EXPR))
(SHOULDNT)))
(CMLCONVERT.ADDTOCOMS FILECOMS (QUOTE MACROS)
MACRO))))
(CMLCONVERT.FPKG.P
(LAMBDA (FILECOMS EXPR) (* kbr:
"19-Mar-86 15:46")
(* P file package
command. EXPR to be
evaled when loaded.
*)
(PROG NIL
(CMLCONVERT.ADDTOCOMS FILECOMS (QUOTE P)
EXPR))))
(CMLCONVERT.FPKG.PROPS
(LAMBDA (FILECOMS EXPR) (* kbr:
"19-Mar-86 15:48")
(* PROPS file package
command. *)
(PROG (ATOM PROPNAME)
(SETQ ATOM (CADR EXPR))
(SETQ PROPNAME (CADDR EXPR))
(CMLCONVERT.ADDTOCOMS FILECOMS (QUOTE PROPS)
(LIST ATOM PROPNAME)))))
(CMLCONVERT.FPKG.RECORDS
(LAMBDA (FILECOMS EXPR) (* kbr:
"19-Mar-86 15:49")
(* RECORDS file
package command.
EXPR is a record package
declaration. *)
(PROG (NAME)
(SETQ NAME (OR (CAR (LISTP (CADR EXPR)))
(CADR EXPR)))
(CMLCONVERT.ADDTOCOMS FILECOMS (QUOTE RECORDS)
NAME))))
(CMLCONVERT.FPKG.VARS
(LAMBDA (FILECOMS EXPR) (* kbr:
"19-Mar-86 15:49")
(* VARS file package
command. EXPR is a RPAQ
expression. *)
(PROG NIL
(CMLCONVERT.ADDTOCOMS FILECOMS (QUOTE VARS)
(LIST (CADR EXPR)
(CADDR EXPR))))))
(CMLCONVERT.FPKG.EVAL-WHEN
(LAMBDA (FILECOMS EXPR) (* kbr:
"20-Mar-86 12:38")
(* DECLARE: file
package command.
EXPR is an EVAL-WHEN
expression. *)
(PROG (TAGS FORMS)
(SETQ TAGS (for SITUATION in (CADR EXPR) collect (CDR (ASSOC SITUATION
CMLCONVERT.EVAL.WHEN.TAGS
))))
(SETQ FORMS (CDDR EXPR))
(SET FILECOMS (NCONC (EVAL FILECOMS)
(LIST (BQUOTE (DECLARE: (\,@ TAGS)
(P (\,@ FORMS))))))))))
(CMLCONVERT.FPKG.;;;
(LAMBDA (FILECOMS EXPR) (* kbr:
"19-Mar-86 15:52")
(PROG NIL)))
(CMLCONVERT.ADDTOCOMS
(LAMBDA (FILECOMS TYPE FORM) (* kbr:
"22-Mar-86 16:13")
(PROG (BUCKET)
(SETQ BUCKET (CAR (LAST (EVAL FILECOMS))))
(COND
((OR (NULL BUCKET)
(NOT (EQ (CAR BUCKET)
TYPE)))
(SETQ BUCKET (LIST TYPE))
(SET FILECOMS (NCONC (EVAL FILECOMS)
(LIST BUCKET)))))
(NCONC BUCKET (LIST FORM)))))
)
(PUTPROPS DEFCONSTANT CMLCONVERT.FPKG CMLCONVERT.FPKG.CONSTANTS)
(PUTPROPS DEFMACRO CMLCONVERT.FPKG CMLCONVERT.FPKG.MACROS)
(PUTPROPS DEFUN CMLCONVERT.FPKG CMLCONVERT.FPKG.FNS)
(PUTPROPS DEFPARAMETER CMLCONVERT.FPKG CMLCONVERT.FPKG.VARS)
(PUTPROPS DEFSETF CMLCONVERT.FPKG CMLCONVERT.FPKG.DEFSETF)
(PUTPROPS DEFSTRUCT CMLCONVERT.FPKG CMLCONVERT.FPKG.RECORDS)
(PUTPROPS DEFVAR CMLCONVERT.FPKG CMLCONVERT.FPKG.INITVARS)
(PUTPROPS EVAL-WHEN CMLCONVERT.FPKG CMLCONVERT.FPKG.EVAL-WHEN)
(PUTPROPS DEFTYPE CMLCONVERT.FPKG CMLCONVERT.FPKG.DEFTYPE)
(PUTPROPS * CMLCONVERT.FPKG CMLCONVERT.FPKG.;;;)
(PUTPROPS DEFINE-SYSTEM-CONSTANT CMLCONVERT.FPKG CMLCONVERT.FPKG.CONSTANTS)
(* (PROP CMLCONVERT.FPKG DEFINE-MODIFY-MACRO DEFINE-SETF-METHOD) These were
CMLCONVERT.FPKG.MACROS and CMLCONVERT.FPKG.DEFSETF *)
(* 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 CMLCONVERT.FPKG)
(QUOTE NILL))
(OR (GETD NAME)
(MOVD (QUOTE *)
NAME)))
(RPAQ CMLCONVERT.RDTBL (COPYREADTABLE CMLRDTBL))
(RPAQ CMLCONVERT.COMMENT.RDTBL (COPYREADTABLE CMLRDTBL))
(SETSYNTAX (QUOTE ;)
(QUOTE OTHER)
CMLCONVERT.RDTBL)
(SETSYNTAX (QUOTE #)
(QUOTE (SPLICE FIRST NONIMMEDIATE ESCQUOTE CMLCONVERT.READHASHMACRO))
CMLCONVERT.RDTBL)
(SETSYNTAX (QUOTE ;)
(QUOTE OTHER)
CMLCONVERT.COMMENT.RDTBL)
(SETSYNTAX (QUOTE ,)
(QUOTE OTHER)
CMLCONVERT.COMMENT.RDTBL)
(PUTPROPS CMLCONVERT COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (14787 18464 (CMLCONVERT.NAME 14797 . 15612) (CMLCONVERT.NAMEIFY 15614 . 16417) (
CMLCONVERT.NAMEIFYFN 16419 . 16714) (CMLIMPLEMENTED 16716 . 17576) (CMLUNIMPLEMENTED 17578 . 18462)) (
18465 22709 (CMLCONVERT.MOVECOMMENTS 18475 . 19434) (CMLCONVERT.MOVECOMMENTS.COND 19436 . 21988) (
CMLCONVERT.CONDP 21990 . 22369) (CMLCONVERT.COMMENTP 22371 . 22707)) (23222 42123 (CMLCONVERTALL 23232
. 23762) (CMLCONVERTONE 23764 . 24295) (CMLCONVERT 24297 . 24793) (CMLCONVERT.CONVERTFILE 24795 .
27535) (CMLCONVERT.CONVERTCOMMENTFILE 27537 . 30816) (CMLCONVERT.STRINGTOCOMMENT 30818 . 31682) (
CMLCONVERT.MAKECOMS 31684 . 34570) (CMLCONVERT.READFILE 34572 . 41716) (CMLCONVERT.CONTAINS 41718 .
42121)) (42162 51735 (CMLCONVERT.READHASHMACRO 42172 . 51293) (CMLREADVBAR 51295 . 51733)) (52408
71711 (CMLCONVERT.RECORDECL1 52418 . 53685) (\CMLSTRUCT.CLTYPE.TO.ILTYPE 53687 . 58352) (
DEFSTRUCT.TRANSLATE 58354 . 71709)) (71868 80836 (CMLCONVERT.FPKG.CONSTANTS 71878 . 72605) (
CMLCONVERT.FPKG.DEFTYPE 72607 . 73380) (CMLCONVERT.FPKG.DEFSETF 73382 . 74149) (CMLCONVERT.FPKG.FNS
74151 . 74737) (CMLCONVERT.FPKG.INITVARS 74739 . 75463) (CMLCONVERT.FPKG.MACROS 75465 . 76242) (
CMLCONVERT.FPKG.P 76244 . 76900) (CMLCONVERT.FPKG.PROPS 76902 . 77491) (CMLCONVERT.FPKG.RECORDS 77493
. 78267) (CMLCONVERT.FPKG.VARS 78269 . 78906) (CMLCONVERT.FPKG.EVAL-WHEN 78908 . 80025) (
CMLCONVERT.FPKG.;;; 80027 . 80248) (CMLCONVERT.ADDTOCOMS 80250 . 80834)))))
STOP