(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