(FILECREATED "24-Jan-86 14:44:09" {ERIS}<LISPCORE>LIBRARY>CMLREAD.;12 12037
changes to: (VARS CMLTRANSLATIONS)
previous date: "20-Jan-86 22:24:27" {ERIS}<LISPCORE>LIBRARY>CMLREAD.;11)
(* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CMLREADCOMS)
(RPAQQ CMLREADCOMS [(* * This is a collection of "clever" hacks designed to make our reader handle
Common Lisp)
(FNS CL:READ)
(COMS (* * Fake self-evaluating keywords)
(FNS DWIMKEYWORD)
[DECLARE: DONTEVAL@LOAD DOCOPY (*)
(ADDVARS (DWIMUSERFORMS (DWIMKEYWORD]
(ADVISE COMP.USERFN)
(* must turn off "packed" version of CLISP infix)
(VARS [CLISPCHARS (LDIFFERENCE CLISPCHARS (QUOTE (: - *]
(CLISPCHARRAY (MAKEBITTABLE CLISPCHARS))
(CLISPIFYPACKFLG NIL)
(DWIMINMACROSFLG)))
(COMS (VARS CMLTRANSLATIONS)
(FNS CMLTRANSLATE \MIXED.CASE.P))
(COMS (* * Attempt to build a commonlisp readtable. Not enough features in
readtables yet)
(FNS CMLRDTBL CMLREADVBAR CMLREADHASHMACRO CMLREAD.FEATURE.PARSER
CREATE-STRUCTURE)
(VARS (CMLRDTBL (CMLRDTBL])
(* * This is a collection of "clever" hacks designed to make our reader handle Common Lisp)
(DEFINEQ
(CL:READ
[CL:LAMBDA (FILE RDTBL) (* raf "24-Oct-85 18:07")
(CMLTRANSLATE (READ FILE (if (FMEMB RDTBL (QUOTE (T NIL)))
then CMLRDTBL
else RDTBL])
)
(* * Fake self-evaluating keywords)
(DEFINEQ
(DWIMKEYWORD
[LAMBDA NIL (* lmm " 8-Jul-85 13:17")
(AND (NULL FAULTAPPLYFLG)
(LITATOM FAULTX)
(EQ (NTHCHARCODE FAULTX 1)
(CHARCODE ":"))
(\MAKE.KEYWORD FAULTX])
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(ADDTOVAR DWIMUSERFORMS (DWIMKEYWORD))
)
(PUTPROPS COMP.USERFN READVICE [NIL (BEFORE NIL (if (\KEYWORDP X)
then
(RETURN (LIST (QUOTE QUOTE)
X])
(READVISE COMP.USERFN)
(* must turn off "packed" version of CLISP infix)
(RPAQ CLISPCHARS (LDIFFERENCE CLISPCHARS (QUOTE (: - *))))
(RPAQ CLISPCHARRAY (MAKEBITTABLE CLISPCHARS))
(RPAQQ CLISPIFYPACKFLG NIL)
(RPAQQ DWIMINMACROSFLG NIL)
(RPAQQ CMLTRANSLATIONS ((POSITION . CL:POSITION)
(LISTP . CL:LISTP)
[LAMBDA . CL:LAMBDA]
(MAPCAR . CL:MAPCAR)
(DO . CL:DO)
(DO* . CL:DO*)
(IF . CL:IF)
(LENGTH . CL:LENGTH)
(ATOM . CL:ATOM)
(MEMBER . CL:MEMBER)
(PUSH . CL:PUSH)
(REPLACE . CL:REPLACE)
(WHEN . CL:WHEN)
(UNLESS . CL:UNLESS)
(READ . CL:READ)
(EQUAL . CL:EQUAL)
(APPLY . CL:APPLY)
(SETQ . CL:SETQ)
(CHARACTER . CL:CHARACTER)
(SIN . CL:SIN)
(COS . CL:COS)
(TAN . CL:TAN)
(ARRAYP . CL:ARRAYP)
(* . CL:*)
(FIND . CL:FIND)
(FIRST . CL:FIRST)
(MAPC . CL:MAPC)
(NTH . CL:NTH)
(LDIFF . CL:LDIFF)
(SUBST . CL:SUBST)
(ASSOC . CL:ASSOC)
(MAPC . CL:MAPC)
(MAPLIST . CL:MAPLIST)
(MAPCON . CL:MAPCON)
(ELT . CL:ELT)
(REVERSE . CL:REVERSE)
(NREVERSE . CL:NREVERSE)
(MAP . CL:MAP)
(SOME . CL:SOME)
(EVERY . CL:EVERY)
(NOTANY . CL:NOTANY)
(NOTEVERY . CL:NOTEVERY)
(COERCE . CL:COERCE)
(DELETE . CL:DELETE)
(REMOVE . CL:REMOVE)
(COUNT . CL:COUNT)
(MAPHASH . CL:MAPHASH)
(PUTHASH . CL:PUTHASH)
(DECLARE . CL:DECLARE)))
(DEFINEQ
(CMLTRANSLATE
[LAMBDA (X) (* raf " 6-Nov-85 17:10")
(if (LITATOM X)
then (LET ((UX (U-CASE X)))
(OR (CDR (ASSOC UX CMLTRANSLATIONS))
UX))
elseif (LISTP X)
then (CONS (CMLTRANSLATE (CAR X))
(CMLTRANSLATE (CDR X)))
else X])
(\MIXED.CASE.P
[CL:LAMBDA (STR) (* raf " 6-Nov-85 17:06")
(SETQ STR (MKSTRING STR))
(LET [(LAST (SUB1 (CL:LENGTH STR]
(for I from 0 to LAST until (BOTH-CASE-P (AREF STR I))
finally (RETURN (if (= I LAST)
then NIL
elseif (UPPER-CASE-P (AREF STR I))
then (for J from I to LAST
thereis (LOWER-CASE-P (AREF STR J)))
else (for J from I to LAST thereis (UPPER-CASE-P
(AREF STR J])
)
(* * Attempt to build a commonlisp readtable. Not enough features in readtables yet)
(DEFINEQ
(CMLRDTBL
[LAMBDA NIL (* raf "14-Nov-85 20:45")
(* * Attempt to set up common lisp read table)
(* * Creates a copy of the "original" read-table.)
(PROG [(TBL (COPYREADTABLE (QUOTE ORIG]
(* * First reset the table)
(for I from 0 to 255 do (SETSYNTAX I (QUOTE OTHER)
TBL))
(* * Install the goodies)
(SETSEPR (CHARCODE (SPACE CR ↑L LF TAB))
1 TBL)
(SETSYNTAX (CHARCODE "'")
[QUOTE (MACRO FIRST NONIMMEDIATE NOESCQUOTE (LAMBDA (STREAM RDTBL)
(LIST (QUOTE QUOTE)
(READ STREAM RDTBL]
TBL)
(SETSYNTAX (CHARCODE ";")
[QUOTE (SPLICE FIRST (LAMBDA (STREAM RDTBL)
(until (EQ (READCCODE STREAM)
(CHARCODE NEWLINE))
do NIL]
TBL)
(SETSYNTAX (CHARCODE %))
(QUOTE RIGHTPAREN)
TBL)
(SETSYNTAX (CHARCODE %()
(QUOTE LEFTPAREN)
TBL)
(SETSYNTAX (CHARCODE "\")
(QUOTE ESCAPE)
TBL)
(SETSYNTAX (CHARCODE "|")
(QUOTE (MACRO ALWAYS CMLREADVBAR))
TBL)
(SETSYNTAX (CHARCODE %")
(QUOTE STRINGDELIM)
TBL)
(SETSYNTAX (CHARCODE "`")
(QUOTE (MACRO FIRST READBQUOTE))
TBL)
(SETSYNTAX (CHARCODE "#")
(QUOTE (MACRO FIRST CMLREADHASHMACRO))
TBL)
(SETSYNTAX (CHARCODE ",")
(QUOTE (MACRO FIRST READBQUOTECOMMA))
TBL)
(SETSYNTAX (CHARCODE "%%")
(QUOTE OTHER)
TBL)
(RETURN TBL])
(CMLREADVBAR
[LAMBDA (STREAM RDTBL)
(HELP])
(CMLREADHASHMACRO
[LAMBDA (STREAM RDTBL INDEX) (* raf "14-Nov-85 20:53")
(LET ((NEXTCHAR (PEEKCCODE STREAM))
READVAL)
(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 (QUOTE FUNCTION)
(READ STREAM RDTBL)))
(%. (READCCODE STREAM RDTBL)
(EVAL (READ STREAM RDTBL)))
(, (READCCODE STREAM RDTBL)
(LIST (QUOTE LOADTIMECONSTANT)
(READ STREAM RDTBL)))
[\ (INT-CHAR (CHARCODE.DECODE (READ STREAM CMLRDTBL]
["*" (READCCODE STREAM RDTBL)
(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]
(if INDEX
then (FILL.VECTOR (MAKE-ARRAY INDEX :ELEMENT-TYPE
(QUOTE BIT))
CONTENTS)
else (MAKE-ARRAY (LENGTH CONTENTS)
:INITIAL-CONTENTS CONTENTS :ELEMENT-TYPE
(QUOTE BIT]
["(" (LET ((CONTENTS (READ STREAM RDTBL)))
(if INDEX
then (FILL.VECTOR (MAKE-ARRAY INDEX)
CONTENTS)
else (MAKE-ARRAY (LENGTH CONTENTS)
:INITIAL-CONTENTS CONTENTS]
(":" (READCCODE STREAM RDTBL)
(RSTRING STREAM RDTBL))
((O o)
(READCCODE STREAM RDTBL)
(READNUMBERINBASE STREAM 8))
((B b)
(READCCODE STREAM RDTBL)
(READNUMBERINBASE STREAM 2))
((X x)
(READCCODE STREAM RDTBL)
(READNUMBERINBASE STREAM 16))
((R r)
(READCCODE STREAM RDTBL)
(READNUMBERINBASE STREAM INDEX))
((A a)
(READCCODE STREAM RDTBL)
(LET ((CONTENTS (READ STREAM RDTBL)))
(MAKE-ARRAY (ESTIMATE-DIMENSIONALITY INDEX CONTENTS)
:INITIAL-CONTENTS CONTENTS)))
((S s)
(READCCODE STREAM RDTBL)
(CREATE-STRUCTURE (READ STREAM RDTBL)))
(+ (READCCODE STREAM RDTBL)
(if (CMLREAD.FEATURE.PARSER (READ STREAM SIMPLERDTBL))
then (READ STREAM RDTBL)
else (READ STREAM RDTBL)
(READ STREAM RDTBL)))
(- (READCCODE STREAM RDTBL)
(if (NOT (CMLREAD.FEATURE.PARSER (READ STREAM SIMPLERDTBL)))
then (READ STREAM RDTBL)
else (READ STREAM RDTBL)
(READ STREAM RDTBL)))
("|" (READCCODE STREAM RDTBL) (* special comment)
(SKIP.HASH.COMMENT STREAM RDTBL)
(READ STREAM RDTBL))
(< (READ<))
((SPACE TAB NEWLINE PAGE RETURN RIGHTPAREN)
(READCCODE STREAM RDTBL)
(ERROR "Illegal read syntax " (CHARCODE.UNDECODE NEXTCHAR)))
(PROGN (READCCODE STREAM RDTBL)
(APPLY* (OR (GETPROP (CHARACTER NEXTCHAR)
(QUOTE HASHREADMACRO))
(ERROR "Undefined hashmacro char" NEXTCHAR))
STREAM RDTBL])
(CMLREAD.FEATURE.PARSER
(CL:LAMBDA (EXPR) (* raf " 5-Nov-85 17:50")
(CL:IF (CONSP EXPR)
(CL:APPLY (CAR EXPR)
(CL:MAPCAR (FUNCTION CMLREAD.FEATURE.PARSER)
(CDR EXPR)))
(AND (MEMBER EXPR *FEATURES*)
T))))
(CREATE-STRUCTURE
[CL:LAMBDA (STRUCTURE-FORM) (* raf "25-Oct-85 12:47")
(APPLY (PACK* (QUOTE MAKE-)
(U-CASE (CAR STRUCTURE-FORM)))
(for TAIL on (CDR STRUCTURE-FORM) by (CDDR TAIL)
join (LIST (\MAKE.KEYWORD (CAR TAIL))
(CADR TAIL])
)
(RPAQ CMLRDTBL (CMLRDTBL))
(PUTPROPS CMLREAD COPYRIGHT ("Xerox Corporation" 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1639 1888 (CL:READ 1649 . 1886)) (1927 2203 (DWIMKEYWORD 1937 . 2201)) (4910 5934 (
CMLTRANSLATE 4920 . 5300) (\MIXED.CASE.P 5302 . 5932)) (6022 11926 (CMLRDTBL 6032 . 7733) (CMLREADVBAR
7735 . 7792) (CMLREADHASHMACRO 7794 . 11241) (CMLREAD.FEATURE.PARSER 11243 . 11561) (CREATE-STRUCTURE
11563 . 11924)))))
STOP