(FILECREATED " 7-Aug-85 15:25:17" {ERIS}<LISPCORE>SOURCES>COMMON.;19 32415Q
changes to: (FNS READHASHMACRO)
previous date: " 1-Aug-85 15:30:41" {ERIS}<LISPCORE>SOURCES>COMMON.;18)
(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT COMMONCOMS)
(RPAQQ COMMONCOMS ((COMS (* BQUOTE AND FRIENDS) (FNS READVBAR DIGITBASEP READNUMBERINBASE
READHASHMACRO ESTIMATE-DIMENSIONALITY SKIP.HASH.COMMENT READBQUOTE READBQUOTECOMMA) (FNS BQUOTE
\BQUOTE.EXPAND BQ.CONS BQ.PROGN \BQUOTE.SPLICE \BQUOTE.STANDARD \UNCOMMA \BQUOTE.BREAKRESET) (VARS
\CML.READPREFIX (SIMPLERDTBL (COPYREADTABLE (QUOTE ORIG)))) (DECLARE: DONTEVAL@LOAD DOCOPY (VARS (
\INBQUOTE)) (ADDVARS (BREAKRESETFORMS (\BQUOTE.BREAKRESET))) (P (MAPC (QUOTE (\ORIGREADTABLE FILERDTBL
T EDITRDTBL DEDITRDTBL)) (FUNCTION (LAMBDA (RDTBL) (COND ((BOUNDP RDTBL) (SETSYNTAX (QUOTE %|) (QUOTE
(INFIX READVBAR)) (EVALV RDTBL)) (SELECTQ RDTBL ((CODERDTBL FILERDTBL) (* Don't set it loose on these
yet)) (PROGN (SETSYNTAX (QUOTE `) (QUOTE (MACRO FIRST READBQUOTE)) (EVALV RDTBL)) (SETSYNTAX (QUOTE ,
) (QUOTE (MACRO FIRST READBQUOTECOMMA)) (EVALV RDTBL))))))))))) (MACROS BQUOTE) (VARS \CML.READPREFIX)
) (COMS (* *FEATURES* used only by #+ #- reader, which is really disabled) (ADDVARS (*FEATURES* (QUOTE
INTERLISP)))) (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML
BQUOTE) (LAMA)))))
(* BQUOTE AND FRIENDS)
(DEFINEQ
(READVBAR
(LAMBDA (STREAM RDTBL TC) (* lmm " 1-Aug-85 09:43") (SELCHARQ (PEEKCCODE STREAM) (' (* commonlisp
defines "#'X" to mean (FUNCTION X) , but here its BQUOTE) (READCCODE STREAM) (TCONC TC (READBQUOTE
STREAM RDTBL))) ((%( { ↑) (TCONC TC (HREAD STREAM))) (# (READCCODE STREAM) (TCONC TC (READHASHMACRO
STREAM RDTBL))) ((EOL TAB SPACE) (* CR or tab, treat as separator) TC) (TCONC TC (READHASHMACRO STREAM
RDTBL)))))
(DIGITBASEP
[LAMBDA (CODE RADIX) (* lmm "11-Jun-85 00:54")
(if (AND (GEQ CODE (CHARCODE 0))
(LESSP CODE (PLUS (CHARCODE 0)
RADIX)))
then (DIFFERENCE CODE (CHARCODE 0))
elseif (GREATERP RADIX 12Q)
then [if (AND (GEQ CODE (CHARCODE a))
(LEQ CODE (CHARCODE z)))
then (add CODE (DIFFERENCE (CHARCODE A)
(CHARCODE a]
(if (AND (GEQ CODE (CHARCODE A))
(LEQ CODE (CHARCODE Z)))
then [SETQ CODE (PLUS 12Q (DIFFERENCE CODE (CHARCODE A]
(if (LESSP CODE RADIX)
then CODE])
(READNUMBERINBASE
[LAMBDA (STREAM RADIX) (* lmm " 8-Jul-85 13:56")
(bind (VAL ← 0)
BASE while (SETQ BASE (DIGITBASEP (PEEKCCODE STREAM)
RADIX))
do (READCCODE STREAM)
(SETQ VAL (PLUS (TIMES VAL RADIX)
BASE))
finally (RETURN VAL])
(READHASHMACRO
(LAMBDA (STREAM RDTBL INDEX) (* lmm " 7-Aug-85 12:47") (LET ((NEXTCHAR (PEEKCCODE STREAM)) READVAL) (
while (DIGITCHARP NEXTCHAR) do (SETQ INDEX (PLUS (TIMES (OR INDEX 0) 12Q) (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) (
READ-BIT-VECTOR STREAM INDEX)) ("(" (LET ((CONTENTS (READ STREAM RDTBL))) (if INDEX then (to (SUB1
INDEX) as (X ← CONTENTS) by (CDR X) do (OR (CDR X) (SETF (CDR X) (LIST (CAR X))))) else (SETQ INDEX (
LENGTH CONTENTS))) (MAKE-ARRAY (LIST INDEX) :INITIAL-CONTENTS CONTENTS))) (":" (READCCODE STREAM RDTBL
) (RSTRING STREAM RDTBL)) ((O o) (READCCODE STREAM RDTBL) (READNUMBERINBASE STREAM 10Q)) ((B b) (
READCCODE STREAM RDTBL) (READNUMBERINBASE STREAM 2)) ((X x) (READCCODE STREAM RDTBL) (READNUMBERINBASE
STREAM 20Q)) ((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 (MEMBER (READ STREAM SIMPLERDTBL) *FEATURES*) then (READ
STREAM RDTBL) else (SKREAD STREAM RDTBL) (READ STREAM SIMPLERDTBL))) (- (READCCODE STREAM RDTBL) (if (
NOT (MEMBER (READ STREAM SIMPLERDTBL) *FEATURES*)) then (READ STREAM RDTBL) else (SKREAD STREAM RDTBL)
(READ STREAM SIMPLERDTBL))) ("|" (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))))))
(ESTIMATE-DIMENSIONALITY
(LAMBDA (RANK CONTENTS) (if (EQ RANK 0) then NIL else (CONS (LENGTH CONTENTS) (ESTIMATE-DIMENSIONALITY
(SUB1 RANK) (CAR CONTENTS))))))
(SKIP.HASH.COMMENT
[LAMBDA (STREAM RDTBL) (* lmm " 5-Jul-85 12:44")
(do (SELCHARQ (READCCODE STREAM RDTBL)
(# (if (EQ (PEEKCCODE STREAM RDTBL)
(CHARCODE "|"))
then (READCCODE STREAM RDTBL)
(SKIP.HASH.COMMENT STREAM RDTBL)))
("|" (if (EQ (PEEKCCODE STREAM RDTBL)
(CHARCODE "#"))
then (READCCODE STREAM RDTBL)
(RETURN)))
NIL])
(READBQUOTE
[LAMBDA (FILE RDTBL) (* bvm: " 6-Jul-85 23:19")
(SELECTQ (PROGN (SKIPSEPRS FILE RDTBL)
(GETSYNTAX (PEEKCCODE FILE)
RDTBL))
((RIGHTPAREN RIGHTBRACKET) (* Shouldn't have to test this, since such a quote is
required to be escaped. This test is merely a nicety
for type-in)
(QUOTE `))
(LET ((\INBQUOTE T))
(DECLARE (SPECVARS \INBQUOTE))
(LIST (QUOTE BQUOTE)
(READ FILE RDTBL])
(READBQUOTECOMMA
[LAMBDA (FILE RDTBL)
(DECLARE (USEDFREE \INBQUOTE)) (* bvm: " 6-Jul-85 23:19")
(COND
[\INBQUOTE (* Valid context for comma)
(SELECTQ (SKIPSEPRS FILE RDTBL)
((@ %.)
(READC FILE)
(LIST (QUOTE \,@)
(READ FILE RDTBL)))
(LIST (QUOTE \,)
(READ FILE RDTBL]
(T (* Comma outside of backquote context is "an error";
however, it would be nice if we treat it as though it
had been escaped)
(LET ((CH (PEEKCCODE FILE)))
(COND
((OR (SYNTAXP CH (QUOTE BREAK)
RDTBL)
(SYNTAXP CH (QUOTE SEPR)
RDTBL))
(QUOTE ,))
(T (PACK* (QUOTE ,)
(READ FILE RDTBL])
)
(DEFINEQ
(BQUOTE
[NLAMBDA (FORM.WITH.COMMAS)
(DECLARE (LOCALVARS . T)) (* lmm " 1-Jul-85 12:29")
(EVAL (\BQUOTE.EXPAND (\UNCOMMA FORM.WITH.COMMAS)
1])
(\BQUOTE.EXPAND
[LAMBDA (EXPR LEVEL) (* lmm " 9-Jul-85 12:29")
(* Backquote expanding function *)
(COND
((ILESSP LEVEL 0) (* Perhaps the user hand constructed a malformed
backquoted form. *)
(ERROR "Too many commas" EXPR))
((ZEROP LEVEL)
(COND
[(LISTP EXPR)
(SELECTQ (CAR EXPR)
(BQUOTE (\BQUOTE.EXPAND (CADR EXPR)
1))
(CONS (\BQUOTE.EXPAND (CAR EXPR)
0)
(\BQUOTE.EXPAND (CDR EXPR)
0]
(T EXPR)))
[(EQ LEVEL 1)
(COND
[(LISTP EXPR)
(SELECTQ (CAR EXPR)
(\, (CADR EXPR))
(\,@ (ERROR ",@ in illegal context" EXPR))
(\., (ERROR ". , in illegal context" EXPR))
(BQUOTE (\BQUOTE.STANDARD EXPR 2))
(COND
([AND (LISTP (CAR EXPR))
(MEMB (CAAR EXPR)
(QUOTE (\,@ \.,]
(\BQUOTE.SPLICE EXPR))
(T (\BQUOTE.STANDARD EXPR 1]
(T (KWOTE EXPR]
(T (* LEVEL > 1.0 *)
(COND
((LISTP EXPR)
(SELECTQ (CAR EXPR)
((\, \,@ \.,)
(\BQUOTE.STANDARD EXPR (SUB1 LEVEL)))
(BQUOTE (\BQUOTE.STANDARD EXPR (ADD1 LEVEL)))
(\BQUOTE.STANDARD EXPR LEVEL)))
(T (KWOTE EXPR])
(BQ.CONS
[LAMBDA (XA XD) (* lmm "31-AUG-83 21:58")
(SELECTQ (CAR (LISTP XD))
((CONS LIST*)
(LIST* (QUOTE LIST*)
XA
(CDR XD)))
(LIST (LIST* (QUOTE LIST)
XA
(CDR XD)))
(COND
(XD (LIST (QUOTE CONS)
XA XD))
(T (LIST (QUOTE LIST)
XA])
(BQ.PROGN
[LAMBDA (L) (* lmm "31-AUG-83 22:21")
(COND
((CDR L)
(CONS (QUOTE PROGN)
L))
(T (CAR L])
(\BQUOTE.SPLICE
[LAMBDA (SEX) (* lmm "14-Jun-85 14:26")
(* Splice-in cases. ",@" uses NCONC & ",."
uses APPEND. *)
(PROG (A A1 A2 D FN ANSWER)
(SETQ A (CAR SEX))
(SETQ A1 (CAR A))
(SETQ A2 (CADR A))
(SETQ D (CDR SEX))
(SETQ D (\BQUOTE.EXPAND D 1))
[COND
((EQUAL D (QUOTE (QUOTE NIL))) (* (NCONC X (QUOTE NIL)) => X *)
(SETQ ANSWER A2))
(T [COND
((EQ A1 (QUOTE \,@))
(SETQ FN (QUOTE APPEND)))
(T (* \DOTCOMMA => Safe for us to NCONC.
*)
(SETQ FN (QUOTE NCONC]
(COND
[(AND (LISTP D)
(EQ (CAR D)
FN)) (* (NCONC X (NCONC . Y)) =>
(NCONC X . Y) *)
(SETQ ANSWER (CONS FN (CONS A2 (CDR D]
(T (SETQ ANSWER (LIST FN A2 D]
(RETURN ANSWER])
(\BQUOTE.STANDARD
[LAMBDA (EXPR LEVEL) (* lmm "14-Jun-85 14:17")
(* Standard case. *)
(LET ((BCAR (\BQUOTE.EXPAND (CAR EXPR)
LEVEL))
(BCDR (\BQUOTE.EXPAND (CDR EXPR)
LEVEL))
AV DV)
(COND
[(AND (SETQ AV (CONSTANTEXPRESSIONP BCAR))
(SETQ DV (CONSTANTEXPRESSIONP BCDR)))
(LIST (QUOTE QUOTE)
(CONS (CAR AV)
(CAR DV]
(T (BQ.CONS BCAR BCDR])
(\UNCOMMA
[LAMBDA (X) (* lmm "14-Jun-85 14:21")
(* This function does the expansion of a BQUOTEd form.)
(COND
((NLISTP X)
X)
(T (SELECTQ (CAR X)
[, (LET [(TAIL (\UNCOMMA (CDR X]
(CONS (LIST (QUOTE \,)
(CAR TAIL))
(CDR TAIL]
[(,. ., ,@ ,!)
(LET [(TAIL (\UNCOMMA (CDR X]
(CONS (LIST (QUOTE \,@)
(CAR TAIL))
(CDR TAIL]
(LET [(BCAR (\UNCOMMA (CAR X)))
(BCDR (\UNCOMMA (CDR X]
(COND
((AND (EQ BCAR (CAR X))
(EQ BCDR (CDR X)))
X)
(T (CONS BCAR BCDR])
(\BQUOTE.BREAKRESET
[LAMBDA (FLG) (* bvm: " 6-Jul-85 23:19")
(PROG1 \INBQUOTE (SETQ \INBQUOTE FLG])
)
(RPAQQ \CML.READPREFIX "|")
(RPAQ SIMPLERDTBL (COPYREADTABLE (QUOTE ORIG)))
(DECLARE: DONTEVAL@LOAD DOCOPY
(RPAQQ \INBQUOTE NIL)
(ADDTOVAR BREAKRESETFORMS (\BQUOTE.BREAKRESET))
(MAPC (QUOTE (\ORIGREADTABLE FILERDTBL T EDITRDTBL DEDITRDTBL)) (FUNCTION (LAMBDA (RDTBL) (COND ((
BOUNDP RDTBL) (SETSYNTAX (QUOTE %|) (QUOTE (INFIX READVBAR)) (EVALV RDTBL)) (SELECTQ RDTBL ((CODERDTBL
FILERDTBL) (* Don't set it loose on these yet)) (PROGN (SETSYNTAX (QUOTE `) (QUOTE (MACRO FIRST
READBQUOTE)) (EVALV RDTBL)) (SETSYNTAX (QUOTE ,) (QUOTE (MACRO FIRST READBQUOTECOMMA)) (EVALV RDTBL)))
))))))
)
(DECLARE: EVAL@COMPILE
(PUTPROPS BQUOTE MACRO (FORM (\BQUOTE.EXPAND (\UNCOMMA (CAR FORM)) 1)))
)
(RPAQQ \CML.READPREFIX "|")
(* *FEATURES* used only by #+ #- reader, which is really disabled)
(ADDTOVAR *FEATURES* (QUOTE INTERLISP))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML BQUOTE)
(ADDTOVAR LAMA )
)
(PUTPROPS COMMON COPYRIGHT ("Xerox Corporation" 3701Q))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2664Q 16276Q (READVBAR 2676Q . 3552Q) (DIGITBASEP 3554Q . 5116Q) (READNUMBERINBASE
5120Q . 5670Q) (READHASHMACRO 5672Q . 12063Q) (ESTIMATE-DIMENSIONALITY 12065Q . 12331Q) (
SKIP.HASH.COMMENT 12333Q . 13306Q) (READBQUOTE 13310Q . 14436Q) (READBQUOTECOMMA 14440Q . 16274Q)) (
16277Q 30326Q (BQUOTE 16311Q . 16640Q) (\BQUOTE.EXPAND 16642Q . 21670Q) (BQ.CONS 21672Q . 22543Q) (
BQ.PROGN 22545Q . 23054Q) (\BQUOTE.SPLICE 23056Q . 25312Q) (\BQUOTE.STANDARD 25314Q . 26401Q) (
\UNCOMMA 26403Q . 30054Q) (\BQUOTE.BREAKRESET 30056Q . 30324Q)))))
STOP