(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)

(FILECREATED "25-Oct-91 16:19:12" {DSK}<usr>local>lde>lispcore>sources>CMLREADTABLE.;3
 21290  

      changes to%:  (VARS CMLREADTABLECOMS) (VARIABLES CL:*READ-EVAL*) (FUNCTIONS HASH-DOT)

      previous date%: "15-Aug-91 23:36:53" {DSK}<usr>local>lde>lispcore>sources>CMLREADTABLE.;2)


(* ; "
Copyright (c) 1986, 1987, 1990, 1991 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT CMLREADTABLECOMS)

(RPAQQ CMLREADTABLECOMS ((COMS (* ; "Common Lisp readtable interface functions ") (FUNCTIONS HASH-LEFT-PAD-INITIAL-CONTENTS CL:SET-SYNTAX-FROM-CHAR CL:GET-DISPATCH-MACRO-CHARACTER CL:GET-MACRO-CHARACTER CL:MAKE-DISPATCH-MACRO-CHARACTER CL:SET-DISPATCH-MACRO-CHARACTER CL:SET-MACRO-CHARACTER CL:READTABLE-CASE CL::SET-READTABLE-CASE) (SETFS CL:READTABLE-CASE) (FUNCTIONS DO-DISPATCH-MACRO FIND-MACRO-FUNCTION CL-MACRO-WRAPPED-P CL-UNWRAP-MACRO CL-WRAP-MACRO IL-MACRO-WRAPPED-P IL-UNWRAP-MACRO IL-WRAP-MACRO)) (COMS (* ; "hash macro sub functions") (FUNCTIONS HASH-LEFTPAREN HASH-A HASH-B HASH-BACKSLASH HASH-C HASH-COLON HASH-COMMA HASH-DOT HASH-DOUBLEQUOTE HASH-ILLEGAL-HASH-CHAR HASH-LEFTANGLE HASH-MINUS HASH-NO-PARAMETER-ERROR HASH-O HASH-P HASH-PLUS HASH-QUOTE HASH-R HASH-S HASH-STAR HASH-VBAR HASH-X HASH-EQUAL HASH-NUMBER-SIGN HASH-STRUCTURE-SMASH HASH-STRUCTURE-LOOKUP) (* ; "Temporary") (VARIABLES *READ-SUPPRESS* CL:*READ-EVAL*)) (COMS (* ; "Common Lisp default readtables") (FNS CMLRDTBL INIT-CML-READTABLES SET-DEFAULT-HASHMACRO-SETTINGS CMLREADSEMI) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (INIT-CML-READTABLES)))) (PROP FILETYPE CMLREADTABLE)))



(* ; "Common Lisp readtable interface functions ")



(CL:DEFUN HASH-LEFT-PAD-INITIAL-CONTENTS (SIZE IVAL-LIST) (LET ((PADLENGTH (- SIZE (LENGTH IVAL-LIST)))) (COND ((> PADLENGTH 0) (APPEND IVAL-LIST (CL:MAKE-LIST PADLENGTH :INITIAL-ELEMENT (CAR (LAST IVAL-LIST))))) (T (CL:ERROR "Values list too long for #~D()" SIZE)))))

(CL:DEFUN CL:SET-SYNTAX-FROM-CHAR (TO-CHAR FROM-CHAR &OPTIONAL (TO-READTABLE *READTABLE*) (FROM-READTABLE CMLRDTBL)) (SETSYNTAX (CL:CHAR-CODE TO-CHAR) (GETSYNTAX (CL:CHAR-CODE FROM-CHAR) FROM-READTABLE) TO-READTABLE) T)

(CL:DEFUN CL:GET-DISPATCH-MACRO-CHARACTER (DISP-CHAR SUB-CHAR &OPTIONAL (READTABLE *READTABLE*)) (CL:WHEN (AND RTP (NULL READTABLE)) (SETQ READTABLE (FIND-READTABLE "LISP"))) (CDR (ASSOC SUB-CHAR (CDR (ASSOC DISP-CHAR (fetch (READTABLEP DISPATCHMACRODEFS) of READTABLE))))))

(CL:DEFUN CL:GET-MACRO-CHARACTER (CHAR &OPTIONAL (READTABLE *READTABLE* RTP)) (CL:WHEN (AND RTP (NULL READTABLE)) (SETQ READTABLE (FIND-READTABLE "LISP"))) (* ;;; "insures entry is Common Lisp form - (MACRO {FIRST,ALWAYS} (LAMBDA (STREAM READTABLE) (FUNCALL <function> '<char> STREAM))))") (LET ((TABENTRY (GETSYNTAX (CL:CHAR-CODE CHAR) READTABLE)) NON-TERMINATING-P) (AND (CL:CONSP TABENTRY) (EQ (CAR TABENTRY) (QUOTE MACRO)) (CL:CONSP (CDR TABENTRY)) (FMEMB (CADR TABENTRY) (QUOTE (ALWAYS FIRST))) (SETQ NON-TERMINATING-P (CADR TABENTRY)) (CL:CONSP (SETQ TABENTRY (CDDR TABENTRY))) (NULL (CDR TABENTRY)) (CL:VALUES (FIND-MACRO-FUNCTION (CAR TABENTRY)) (NEQ NON-TERMINATING-P (QUOTE ALWAYS))))))

(CL:DEFUN CL:MAKE-DISPATCH-MACRO-CHARACTER (CHAR &OPTIONAL NON-TERMINATING (READTABLE *READTABLE*)) (SETSYNTAX (CL:CHAR-CODE CHAR) (BQUOTE (MACRO (\, (CL:IF NON-TERMINATING (QUOTE FIRST) (QUOTE ALWAYS))) (LAMBDA (STREAM READTABLE Z) (DO-DISPATCH-MACRO (\, CHAR) STREAM READTABLE)))) READTABLE) T)

(CL:DEFUN CL:SET-DISPATCH-MACRO-CHARACTER (DISP-CHAR SUB-CHAR FUNCTION &OPTIONAL (READTABLE *READTABLE*)) (CL:IF (CL:DIGIT-CHAR-P SUB-CHAR) (CL:ERROR "Digit ~S illegal as a sub-character for a dispatching macro" SUB-CHAR)) (SETQ SUB-CHAR (CL:CHAR-UPCASE SUB-CHAR)) (LET ((DISP-TABLE (OR (ASSOC DISP-CHAR (fetch (READTABLEP DISPATCHMACRODEFS) of READTABLE)) (LET ((NEWTABLE (LIST DISP-CHAR))) (push (fetch (READTABLEP DISPATCHMACRODEFS) of READTABLE) NEWTABLE) NEWTABLE))) DISP-CONS) (if (SETQ DISP-CONS (ASSOC SUB-CHAR (CDR DISP-TABLE))) then (CL:SETF (CDR DISP-CONS) FUNCTION) else (push (CDR DISP-TABLE) (CONS SUB-CHAR FUNCTION))) T))

(CL:DEFUN CL:SET-MACRO-CHARACTER (CHAR FUNCTION &OPTIONAL NON-TERMINATING (READTABLE *READTABLE*)) (SETSYNTAX (CL:CHAR-CODE CHAR) (BQUOTE (MACRO (\, (CL:IF NON-TERMINATING (QUOTE FIRST) (QUOTE ALWAYS))) (\, (COND ((IL-MACRO-WRAPPED-P FUNCTION) (IL-UNWRAP-MACRO FUNCTION)) (T (CL-WRAP-MACRO FUNCTION CHAR)))))) READTABLE) T)

(CL:DEFUN CL:READTABLE-CASE (CL:READTABLE) (CL:IF (fetch (READTABLEP CASEINSENSITIVE) of CL:READTABLE) (CL:IF (fetch (READTABLEP LOWER/FLIPCASE) of CL:READTABLE) :DOWNCASE :UPCASE) (CL:IF (fetch (READTABLEP LOWER/FLIPCASE) of CL:READTABLE) :INVERT :PRESERVE)))

(CL:DEFUN CL::SET-READTABLE-CASE (CL:READTABLE CL::NEW-CASE) (CL:ECASE CL::NEW-CASE (:PRESERVE (CL:SETF (fetch (READTABLEP CASEINSENSITIVE) of CL:READTABLE) NIL (fetch (READTABLEP LOWER/FLIPCASE) of CL:READTABLE) NIL)) (:UPCASE (CL:SETF (fetch (READTABLEP CASEINSENSITIVE) of CL:READTABLE) T (fetch (READTABLEP LOWER/FLIPCASE) of CL:READTABLE) NIL)) (:DOWNCASE (CL:SETF (fetch (READTABLEP CASEINSENSITIVE) of CL:READTABLE) T (fetch (READTABLEP LOWER/FLIPCASE) of CL:READTABLE) T)) (:INVERT (CL:SETF (fetch (READTABLEP CASEINSENSITIVE) of CL:READTABLE) NIL (fetch (READTABLEP LOWER/FLIPCASE) of CL:READTABLE) T))) CL::NEW-CASE)

(CL:DEFSETF CL:READTABLE-CASE CL::SET-READTABLE-CASE)

(CL:DEFUN DO-DISPATCH-MACRO (CHAR STREAM RDTBL) (LET ((*READTABLE* RDTBL) (DISP-TABLE (CDR (ASSOC CHAR (fetch (READTABLEP DISPATCHMACRODEFS) of RDTBL)))) INDEX NEXTCHAR) (COND ((NOT DISP-TABLE) (CL:ERROR "~S is not a dispatch macro character" CHAR)) (T (* ; "DISPATCHMACRODEFS is a list of A-lists") (while (DIGITCHARP (SETQ NEXTCHAR (READCCODE STREAM RDTBL))) do (* ; "read the optional numeric arg") (SETQ INDEX (+ (TIMES (OR INDEX 0) 10) (- NEXTCHAR (CHARCODE 0))))) (LET* ((DISP-CHARACTER (CL:CHAR-UPCASE (CL:CODE-CHAR NEXTCHAR))) (DISP-FUNCTION (CDR (ASSOC DISP-CHARACTER DISP-TABLE)))) (if DISP-FUNCTION then (CL:FUNCALL DISP-FUNCTION STREAM DISP-CHARACTER INDEX) else (CL:IF *READ-SUPPRESS* (PROGN (* ; "Attempt to ignore it") (READ-EXTENDED-TOKEN STREAM *READTABLE* T) NIL) (CL:ERROR "Undefined dispatch character ~S for dispatch macro character ~S" DISP-CHARACTER CHAR))))))))

(CL:DEFUN FIND-MACRO-FUNCTION (FORM) (COND ((CL-MACRO-WRAPPED-P FORM) (CL-UNWRAP-MACRO FORM)) ((CL:FUNCTIONP FORM) (IL-WRAP-MACRO FORM))))

(CL:DEFUN CL-MACRO-WRAPPED-P (FORM) (* ;;; "Predicate that checks for forms built by CL-WRAP-MACRO") (AND (CL:CONSP FORM) (EQ (CAR FORM) (QUOTE CL:LAMBDA)) (CL:CONSP (CDR FORM)) (CL:EQUAL (CADR FORM) (QUOTE (STREAM READTABLE Z))) (CL:CONSP (CDDR FORM)) (NULL (CDDDR FORM)) (CL:CONSP (CADDR FORM)) (EQ (CAADDR FORM) (QUOTE CL:FUNCALL))))

(CL:DEFUN CL-UNWRAP-MACRO (FORM) (* ;;; "Fetches CL function out wrapped by CL-WRAP-MACRO") (CADR (CADR (CADDR FORM))))

(CL:DEFUN CL-WRAP-MACRO (FN CHAR) (* ;;; "Wraps a form around a CL readmacro to make it acceptable as an IL readmacro") (BQUOTE (CL:LAMBDA (STREAM READTABLE Z) (CL:FUNCALL (QUOTE (\, FN)) STREAM (\, CHAR)))))

(CL:DEFUN IL-MACRO-WRAPPED-P (FORM) (* ;;; "Predicate that checks for forms built by IL-WRAP-MACRO") (AND (CL:CONSP FORM) (EQ (CAR FORM) (QUOTE CL:LAMBDA)) (CL:CONSP (CDR FORM)) (EQUAL (CADR FORM) (QUOTE (STREAM CHAR))) (CL:CONSP (SETQ FORM (CDDR FORM))) (NULL (CDR FORM)) (CL:CONSP (SETQ FORM (CAR FORM))) (EQ (CAR FORM) (QUOTE CL:FUNCALL)) (EQ (CADDR FORM) (QUOTE STREAM))))

(CL:DEFUN IL-UNWRAP-MACRO (FORM) (CADR (CADR (CADDR FORM))))

(CL:DEFUN IL-WRAP-MACRO (FORM) (* ;;; "Wraps a form around an IL readmacro to make it acceptable as a CL readmacro") (BQUOTE (CL:LAMBDA (STREAM CHAR) (CL:FUNCALL (QUOTE (\, FORM)) STREAM))))



(* ; "hash macro sub functions")



(CL:DEFUN HASH-LEFTPAREN (STREAM CHAR INDEX) (LET ((CONTENTS (CL:READ-DELIMITED-LIST #\) STREAM T))) (COND (*READ-SUPPRESS* NIL) (\INBQUOTE (* ;; "We are inside a back-quote - generate %",(coerce ',contents 'vector)%"") (CL:WHEN INDEX (CL:CERROR "Ignore the explicit length" "Explicit length not allowed in backquoted vectors:~%%#~D~S" INDEX CONTENTS)) (LIST (QUOTE \,) (BQUOTE (COERCE (\, (LIST (QUOTE BQUOTE) CONTENTS)) (QUOTE CL:VECTOR))))) (INDEX (IF (<= (LENGTH CONTENTS) INDEX) THEN (LET ((VEC (CL:MAKE-ARRAY INDEX :INITIAL-ELEMENT (CAR (LAST CONTENTS))))) (LET ((XCL-USER::T0 (LENGTH CONTENTS)) (I 0)) (CL:BLOCK NIL (LET NIL (CL:TAGBODY LOOPTAG0015 (COND ((>= I XCL-USER::T0) (RETURN NIL))) (CL:SETF (CL:AREF VEC I) (POP CONTENTS)) (CL:INCF I) (GO LOOPTAG0015))))) VEC) ELSE (CL:ERROR "Values list too long for #~D()" INDEX))) (T (CL:MAKE-ARRAY (LENGTH CONTENTS) :INITIAL-CONTENTS CONTENTS)))))

(CL:DEFUN HASH-A (STREAM CHAR PARAM) (LET ((CONTENTS (CL:READ STREAM T NIL T))) (COND (*READ-SUPPRESS* NIL) (T (CL:MAKE-ARRAY (ESTIMATE-DIMENSIONALITY PARAM CONTENTS) :INITIAL-CONTENTS CONTENTS)))))

(CL:DEFUN HASH-B (STREAM CHAR PARAM) (COND (*READ-SUPPRESS* (READ-EXTENDED-TOKEN STREAM *READTABLE* T) NIL) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (READNUMBERINBASE STREAM 2))))

(CL:DEFUN HASH-BACKSLASH (STREAM CHAR PARAM) (COND (*READ-SUPPRESS* (CHARACTER.READ STREAM) NIL) (T (CL:IF (OR (NULL PARAM) (AND (TYPEP PARAM (QUOTE CL:FIXNUM)) (>= PARAM 0) (< PARAM LISP:CHAR-FONT-LIMIT))) (CHARACTER.READ STREAM) (CL:ERROR "Illegal font specifier ~S for #\" PARAM)))))

(CL:DEFUN HASH-C (STREAM CHAR PARAM) (COND (*READ-SUPPRESS* (CL:READ STREAM T NIL T) NIL) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (DESTRUCTURING-BIND (NUM DEN) (CL:READ STREAM T NIL T) (COMPLEX NUM DEN)))))

(CL:DEFUN HASH-COLON (STREAM CHAR PARAM) (* ; "Uninterned symbol.") (COND (*READ-SUPPRESS* (READ-EXTENDED-TOKEN STREAM *READTABLE* T) NIL) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (CL:MAKE-SYMBOL (READ-EXTENDED-TOKEN STREAM *READTABLE* T)))))

(CL:DEFUN HASH-COMMA (STREAM CHAR PARAM) (* ;;; "If the compiler is reading, then wrap up the form in a special data object to be noticed by FASL later.  If it's not the compiler, then treat exactly like #.") (COND (*READ-SUPPRESS* (CL:READ STREAM T NIL T) NIL) ((NULL CL:*READ-EVAL*) (ERROR "#, encountered on ~S with *READ-EVAL* NIL" STREAM)) (T (CL:WHEN *CLTL2-PEDANTIC* (CL:CERROR "Read it anyway" "#, encountered on ~S with *CLTL2-PEDANTIC* non-NIL" STREAM)) (HASH-NO-PARAMETER-ERROR CHAR PARAM) (LET ((FORM (CL:READ STREAM T NIL T))) (IF COMPILER::*COMPILER-IS-READING* THEN (COMPILER::MAKE-EVAL-WHEN-LOAD :FORM FORM) ELSEIF (FETCH (READTABLEP COMMONLISP) OF *READTABLE*) THEN (CL:EVAL FORM) ELSE (EVAL FORM))))))

(CL:DEFUN HASH-DOT (STREAM CHAR PARAM) (COND (*READ-SUPPRESS* (CL:READ STREAM T NIL T) NIL) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (CL:UNLESS CL:*READ-EVAL* (CL:CERROR "Read and eval anyway" "#. with *READ-EVAL* NIL on ~s" STREAM)) (COND ((fetch (READTABLEP COMMONLISP) of *READTABLE*) (CL:EVAL (CL:READ STREAM T NIL T))) (T (EVAL (CL:READ STREAM T NIL T)))))))

(CL:DEFUN HASH-DOUBLEQUOTE (STREAM CHAR PARAM) (* ;;; "An extension to Common Lisp.  This reads a normal string but ignores CR's and any whitespace immediately following them.") (COND (*READ-SUPPRESS* (CL:READ STREAM T NIL T) NIL) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (RSTRING STREAM *READTABLE* (QUOTE SKIP)))))

(CL:DEFUN HASH-ILLEGAL-HASH-CHAR (STREAM CHAR PARAM) (CL:ERROR "Illegal hash macro character ~S" CHAR))

(CL:DEFUN HASH-LEFTANGLE (STREAM CHAR PARAM) (HASH-NO-PARAMETER-ERROR CHAR PARAM) (CL:ERROR "Unreadable object #<~A>" (CL:READ STREAM T NIL T)))

(CL:DEFUN HASH-MINUS (STREAM CHAR PARAM) (* ;; "When *READ-SUPPRESS* is true, we want to simply skip over the two forms (the feature expression and the controlled expression).  Otherwise, we read the feature expression and, when it applies to us, skip over the controlled expression.  In any case, we never return a value.") (COND (*READ-SUPPRESS* (* ; "Skip two forms.") (CL:READ STREAM T NIL T) (CL:READ STREAM T NIL T)) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (CL:WHEN (CMLREAD.FEATURE.PARSER (LET ((*PACKAGE* *KEYWORD-PACKAGE*)) (CL:READ STREAM T NIL T))) (LET ((*READ-SUPPRESS* T)) (CL:READ STREAM T NIL T))))) (CL:VALUES))

(CL:DEFUN HASH-NO-PARAMETER-ERROR (CHAR PARAM) (CL:WHEN PARAM (CL:ERROR "Parameter ~D not allowed with hash macro ~S" PARAM CHAR)))

(CL:DEFUN HASH-O (STREAM CHAR PARAM) (COND (*READ-SUPPRESS* (READ-EXTENDED-TOKEN STREAM *READTABLE* T) NIL) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (READNUMBERINBASE STREAM 8))))

(CL:DEFUN HASH-P (STREAM CHAR PARAM) (COND (*READ-SUPPRESS* (CL:READ STREAM T NIL T) NIL) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (PATHNAME (CL:READ STREAM T NIL T)))))

(CL:DEFUN HASH-PLUS (STREAM CHAR PARAM) (* ;; "When *READ-SUPPRESS* is true, we want to simply skip over the two forms (the feature expression and the controlled expression).  Otherwise, we read the feature expression and, unless it applies to us, skip over the controlled expression.  In any case, we never return a value.") (COND (*READ-SUPPRESS* (* ; "Skip two forms.") (CL:READ STREAM T NIL T) (CL:READ STREAM T NIL T)) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (CL:UNLESS (CMLREAD.FEATURE.PARSER (LET ((*PACKAGE* *KEYWORD-PACKAGE*)) (CL:READ STREAM T NIL T))) (LET ((*READ-SUPPRESS* T)) (CL:READ STREAM T NIL T))))) (CL:VALUES))

(CL:DEFUN HASH-QUOTE (STREAM CHAR PARAM) (COND (*READ-SUPPRESS* (CL:READ STREAM T NIL T) NIL) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (LIST (QUOTE CL:FUNCTION) (CL:READ STREAM T NIL T)))))

(CL:DEFUN HASH-R (STREAM CHAR PARAM) (COND (*READ-SUPPRESS* (READ-EXTENDED-TOKEN STREAM *READTABLE* T) NIL) (PARAM (READNUMBERINBASE STREAM PARAM)) (T (CL:ERROR "No base supplied for #R"))))

(CL:DEFUN HASH-S (STREAM CHAR PARAM) (COND (*READ-SUPPRESS* (CL:READ STREAM T NIL T) NIL) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (CREATE-STRUCTURE (CL:READ STREAM T NIL T)))))

(CL:DEFUN HASH-STAR (STREAM CHAR PARAM) (DECLARE (IGNORE CHAR)) (IF (EQ (PEEKC STREAM) (QUOTE %()) THEN (* ; "It's a bitmap.") (IF *READ-SUPPRESS* THEN (CL:READ STREAM NIL NIL T) (CL:READ STREAM NIL NIL T) ELSEIF PARAM THEN (CL:ERROR "Unexpected parameter ~S given in #* bitmap syntax." PARAM) ELSE (FINISH-READING-BITMAP STREAM)) ELSE (* ; "It's a bit-vector.") (LET* ((CONTENTS (READ-EXTENDED-TOKEN STREAM)) (LEN (NCHARS CONTENTS))) (IF *READ-SUPPRESS* THEN NIL ELSEIF (AND (EQ LEN 0) PARAM (NEQ PARAM 0)) THEN (CL:ERROR "No contents specified for bit vector #~A*" PARAM) ELSEIF (AND PARAM (> LEN PARAM)) THEN (CL:ERROR "Bit vector contents longer than specified length in #~A*~A" PARAM CONTENTS) ELSE (LET ((BITARRAY (CL:MAKE-ARRAY (OR PARAM LEN) :ELEMENT-TYPE (QUOTE BIT) :INITIAL-ELEMENT (IF (AND PARAM (> PARAM LEN 0)) THEN (SELCHARQ (NTHCHARCODE CONTENTS -1) (0 0) (1 1) (CL:ERROR "Illegal bit vector element in #~A*~A" PARAM CONTENTS)) ELSE 0)))) (CL:DOTIMES (I LEN) (CL:SETF (CL:AREF BITARRAY I) (SELCHARQ (NTHCHARCODE CONTENTS (CL:1+ I)) (0 0) (1 1) (CL:ERROR "Illegal bit vector element in #~A*~A" PARAM CONTENTS)))) BITARRAY)))))

(CL:DEFUN HASH-VBAR (STREAM CHAR PARAM) (OR *READ-SUPPRESS* (HASH-NO-PARAMETER-ERROR CHAR PARAM)) (LET ((*READ-SUPPRESS* T)) (SKIP.HASH.COMMENT STREAM *READTABLE*) (CL:VALUES)))

(CL:DEFUN HASH-X (STREAM CHAR PARAM) (COND (*READ-SUPPRESS* (READ-EXTENDED-TOKEN STREAM *READTABLE* T) NIL) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (READNUMBERINBASE STREAM 16))))

(CL:DEFUN HASH-EQUAL (STREAM CHAR PARAM) (CL:IF *READ-SUPPRESS* (CL:VALUES) (PROGN (CL:IF (NULL PARAM) (CL:ERROR "#= encountered")) (CL:IF (CL:ASSOC PARAM *CIRCLE-READ-LIST*) (CL:ERROR "#~D= seen twice in same context")) (LET ((NEWNODE (CONS PARAM NIL))) (CL:PUSH NEWNODE *CIRCLE-READ-LIST*) (CL:SETF (CDR NEWNODE) (CL:READ STREAM T NIL T))))))

(CL:DEFUN HASH-NUMBER-SIGN (STREAM CHAR PARAM) (CL:IF *READ-SUPPRESS* NIL (LET ((CIRCLE-PART (CL:ASSOC PARAM *CIRCLE-READ-LIST*))) (COND (CIRCLE-PART) (T (CL:ERROR "#~D# encountered before #~D=" PARAM PARAM))))))

(CL:DEFUN HASH-STRUCTURE-SMASH (THING) (CL:TYPECASE THING (CONS (CL:IF (HASH-STRUCTURE-LOOKUP (CAR THING)) (CL:SETF (CAR THING) (CDAR THING)) (HASH-STRUCTURE-SMASH (CAR THING))) (CL:IF (HASH-STRUCTURE-LOOKUP (CDR THING)) (CL:SETF (CDR THING) (CDDR THING)) (HASH-STRUCTURE-SMASH (CDR THING)))) ((CL:ARRAY T) (LET* ((ASIZE (CL:ARRAY-TOTAL-SIZE THING)) (VARRAY (CL:IF (> (CL:ARRAY-RANK THING) 1) (CL:MAKE-ARRAY ASIZE :DISPLACED-TO THING) THING)) SLOTCONTENTS) (CL:DOTIMES (X ASIZE) (CL:SETQ SLOTCONTENTS (CL:AREF VARRAY X)) (CL:IF (HASH-STRUCTURE-LOOKUP SLOTCONTENTS) (CL:SETF (CL:AREF VARRAY X) (CDR SLOTCONTENTS)) (HASH-STRUCTURE-SMASH SLOTCONTENTS))))) (LISP::STRUCTURE-OBJECT (LET (SLOTCONTENTS) (CL:DOLIST (DESCR (LISP::STRUCTURE-POINTER-SLOTS (CL:TYPE-OF THING))) (CL:SETQ SLOTCONTENTS (FETCHFIELD DESCR THING)) (CL:IF (HASH-STRUCTURE-LOOKUP SLOTCONTENTS) (REPLACEFIELD DESCR THING (CDR SLOTCONTENTS)) (HASH-STRUCTURE-SMASH SLOTCONTENTS)))))))

(CL:DEFUN HASH-STRUCTURE-LOOKUP (SLOTCONTENTS) (AND (CL:CONSP SLOTCONTENTS) (MEMQ SLOTCONTENTS *CIRCLE-READ-LIST*)))



(* ; "Temporary")



(CL:DEFVAR *READ-SUPPRESS* NIL)

(CL:DEFVAR CL:*READ-EVAL* T)



(* ; "Common Lisp default readtables")


(DEFINEQ

(CMLRDTBL

(LAMBDA NIL (* ; "Edited  3-Apr-91 11:22 by jrb:") (* ;; "Creates a vanilla common-lisp read table") (PROG ((TBL (COPYREADTABLE (QUOTE ORIG)))) (* ;; "First reset the table") (for I from 0 to \MAXTHINCHAR do (SETSYNTAX I (QUOTE OTHER) TBL)) (* ;; "Install the goodies") (SETSEPR (CHARCODE (SPACE CR ^L LF TAB)) 1 TBL) (SETSYNTAX (CHARCODE "'") (QUOTE (MACRO ALWAYS READQUOTE)) TBL) (* ;; "Note that in cml, most of these macros are terminating, even though it would be nicer for us if they were not") (SETSYNTAX (CHARCODE ";") (QUOTE (MACRO ALWAYS CMLREADSEMI)) TBL) (SETSYNTAX (CHARCODE ")") (QUOTE RIGHTPAREN) TBL) (SETSYNTAX (CHARCODE "(") (QUOTE LEFTPAREN) TBL) (* ;; "These two PROPS == CL:READTABLE-CASE :UPCASE") (READTABLEPROP TBL (QUOTE CASEINSENSITIVE) T) (READTABLEPROP TBL (QUOTE LOWER/FLIPCASE) NIL) (READTABLEPROP TBL (QUOTE COMMONLISP) T) (READTABLEPROP TBL (QUOTE COMMONNUMSYNTAX) T) (READTABLEPROP TBL (QUOTE USESILPACKAGE) NIL) (READTABLEPROP TBL (QUOTE ESCAPECHAR) (CHARCODE "\")) (READTABLEPROP TBL (QUOTE MULTIPLE-ESCAPECHAR) (CHARCODE "|")) (if *PACKAGE* then (READTABLEPROP TBL (QUOTE PACKAGECHAR) (CHARCODE ":"))) (SET-DEFAULT-HASHMACRO-SETTINGS TBL) (SETSYNTAX (CHARCODE %") (QUOTE STRINGDELIM) TBL) (SETSYNTAX (CHARCODE "`") (QUOTE (MACRO ALWAYS READBQUOTE)) TBL) (SETSYNTAX (CHARCODE ",") (QUOTE (MACRO ALWAYS READBQUOTECOMMA)) TBL) (RETURN TBL)))
)

(INIT-CML-READTABLES

(LAMBDA NIL (* ; "Edited 16-Jan-87 15:47 by bvm:") (DECLARE (GLOBALVARS CMLRDTBL *COMMON-LISP-READ-ENVIRONMENT* READ-LINE-RDTBL)) (READTABLEPROP (SETQ CMLRDTBL (CMLRDTBL)) (QUOTE NAME) "LISP") (SETQ *COMMON-LISP-READ-ENVIRONMENT* (MAKE-READER-ENVIRONMENT (LISP:FIND-PACKAGE "USER") CMLRDTBL 10)) (LET ((FILETBL (COPYREADTABLE CMLRDTBL))) (* ; "Make one for files that has font indicators as seprs") (for I from 1 to 26 do (SETSYNTAX I (QUOTE SEPRCHAR) FILETBL)) (READTABLEPROP FILETBL (QUOTE NAME) "XCL")) (PROGN (* ; "Read table to make READ-LINE work easily") (SETQ READ-LINE-RDTBL (COPYREADTABLE (QUOTE ORIG))) (for I from 0 to \MAXTHINCHAR do (SETSYNTAX I (QUOTE OTHER) READ-LINE-RDTBL)) (SETBRK (CHARCODE (EOL)) NIL READ-LINE-RDTBL)))
)

(SET-DEFAULT-HASHMACRO-SETTINGS

(LAMBDA (RDTBL) (* ; "Edited  3-Apr-91 11:23 by jrb:") (READTABLEPROP RDTBL (QUOTE HASHMACROCHAR) (CHARCODE "#")) (LISP:MAKE-DISPATCH-MACRO-CHARACTER #\# T RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\( (QUOTE HASH-LEFTPAREN) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\' (QUOTE HASH-QUOTE) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\. (QUOTE HASH-DOT) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\, (QUOTE HASH-COMMA) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\\ (QUOTE HASH-BACKSLASH) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\* (QUOTE HASH-STAR) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\: (QUOTE HASH-COLON) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\O (QUOTE HASH-O) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\B (QUOTE HASH-B) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\X (QUOTE HASH-X) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\R (QUOTE HASH-R) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\A (QUOTE HASH-A) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\S (QUOTE HASH-S) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\C (QUOTE HASH-C) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\P (QUOTE HASH-P) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\+ (QUOTE HASH-PLUS) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\- (QUOTE HASH-MINUS) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\| (QUOTE HASH-VBAR) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\< (QUOTE HASH-LEFTANGLE) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\" (QUOTE HASH-DOUBLEQUOTE) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\= (QUOTE HASH-EQUAL) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\# (QUOTE HASH-NUMBER-SIGN) RDTBL) RDTBL)
)

(CMLREADSEMI

(LAMBDA (STREAM RDTBL) (* bvm%: "13-Oct-86 15:53") (* ;;; "Read and discard through end of line") (until (EQ (READCCODE STREAM) (CHARCODE NEWLINE)) do NIL) (LISP:VALUES))
)
)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(INIT-CML-READTABLES)
)

(PUTPROPS CMLREADTABLE FILETYPE CL:COMPILE-FILE)
(PUTPROPS CMLREADTABLE COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 1991))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (17000 21075 (CMLRDTBL 17010 . 18400) (INIT-CML-READTABLES 18402 . 19168) (
SET-DEFAULT-HASHMACRO-SETTINGS 19170 . 20882) (CMLREADSEMI 20884 . 21073)))))
STOP