diff --git a/patches/LLREADPATCH b/patches/LLREADPATCH
deleted file mode 100644
index b10e1a29..00000000
--- a/patches/LLREADPATCH
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED " 1-Aug-2020 18:52:48" 
{DSK}<Users>kaplan>Local>medley3.5>lispcore>patches>LLREADPATCH.;5 5566   

      changes to%:  (FNS CHARCODE.DECODE)

      previous date%: "24-Jul-2020 08:50:43" 
{DSK}<Users>kaplan>Local>medley3.5>lispcore>patches>LLREADPATCH.;2)


(PRETTYCOMPRINT LLREADPATCHCOMS)

(RPAQQ LLREADPATCHCOMS ((FNS CHARCODE.DECODE)))
(DEFINEQ

(CHARCODE.DECODE
  [LAMBDA (C NOERROR)                                   (* ; "Edited  1-Aug-2020 18:52 by rmk:")
                                                             (* ; "Edited 18-Feb-87 22:03 by bvm:")
    (DECLARE (GLOBALVARS CHARACTERNAMES CHARACTERSETNAMES))

    (* ;; "RMK 2020:  Added hexstring decoding for  Unicode:  no commas or other delimiters")

    (* ;; "This overrides the definition in LLREAD.  It should be placed there, but for some reason it is not possible to then recompile that file:  loading a new .LCOM says that \INVALID.SYMBOL is a bad compiled function, and then it loses track of the keyword package. Could be a load-sequence problem that would be resolved if this is installed in a new INIT.SYSOUT rather than an overlay of files already loaded into the LISP.SYSOUT")

    (COND
       ((NOT C)
        NIL)
       ((LISTP C)
        (CONS (CHARCODE.DECODE (CAR C)
                     NOERROR)
              (CHARCODE.DECODE (CDR C)
                     NOERROR)))
       ((NOT (OR (ATOM C)
                 (STRINGP C)))
        (AND (NOT NOERROR)
             (ERROR "BAD CHARACTER SPECIFICATION" C)))
       ((EQ (NCHARS C)
            1)
        (CHCON1 C))
       (T
        (SELCHARQ (CHCON1 C)
             (^ (AND (SETQ C (CHARCODE.DECODE (SUBSTRING C 2 -1)
                                    NOERROR))
                     (LOGAND C (LOGNOT 96))))
             (%# 
                 (* ;; "We use IPLUS instead of LOGOR here because some people want ##char to read as Xerox Meta, i.e., 1,char")

                 (AND (SETQ C (CHARCODE.DECODE (SUBSTRING C 2 -1)
                                     NOERROR))
                      (IPLUS C 128)))
             (LET
              ((STR (MKSTRING C)))
              (for X in CHARACTERNAMES when (STRING.EQUAL (CAR X)
                                                               STR)
                 do (RETURN (OR (NUMBERP (CADR X))
                                    (CHARCODE.DECODE (CADR X)
                                           NOERROR)))
                 finally
                 (RETURN (LET ((POS (STRPOSL '(%, - "." "|")
                                           STR))
                               CH CSET)                      (* ; "In the form charset,char")
                              (COND
                                 ((AND POS (SETQ CH (OR (CL:PARSE-INTEGER STR :START POS :RADIX 8 
                                                               :JUNK-ALLOWED T)
                                                        (CHARCODE.DECODE (SUBSTRING STR
                                                                                    (ADD1 POS))
                                                               NOERROR)))
                                       (< CH 256)
                                       (>= CH 0))            (* ; 
                                        "parsed the char part as an octal number or character spec")
                                  (if (AND [SETQ CSET (OR (CL:PARSE-INTEGER STR :END (SUB1 POS)
                                                                     :RADIX 8 :JUNK-ALLOWED T)
                                                              (for PAIR in CHARACTERSETNAMES
                                                                 first (SETQ POS
                                                                            (SUBSTRING STR 1
                                                                                   (SUB1 POS)))
                                                                 when (STRING.EQUAL (CAR PAIR)
                                                                                 POS)
                                                                 do (RETURN (CADR PAIR]
                                               (< CSET 256)
                                               (>= CSET 0))
                                      then               (* ; 
                              "parsed the charset part as an octal number or standard charset name")
                                            (LOGOR CH (LLSH CSET 8))
                                    elseif (NOT NOERROR)
                                      then (ERROR "BAD CHARACTERSET SPECIFICATION" C)))
                                 ((AND (NOT (FIXP C))
                                       (CL:PARSE-INTEGER (CL:IF (EQ 1 (OR (STRPOS "0x" STR)
                                                                          (STRPOS "0X" STR)
                                                                          (STRPOS "U+" STR)))
                                                             (SUBSTRING STR 3)
                                                             STR)
                                              :RADIX 16 :JUNK-ALLOWED T)))
                                 ((NOT NOERROR)
                                  (ERROR "BAD CHARACTER SPECIFICATION" C])
)
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (427 5543 (CHARCODE.DECODE 437 . 5541)))))
STOP
\ No newline at end of file
diff --git a/patches/LLREADPATCH.LCOM b/patches/LLREADPATCH.LCOM
deleted file mode 100644
index 8978aec2..00000000
Binary files a/patches/LLREADPATCH.LCOM and /dev/null differ
diff --git a/patches/LLREADPATCH.LCOM.~5~ b/patches/LLREADPATCH.LCOM.~5~
deleted file mode 100644
index 8978aec2..00000000
Binary files a/patches/LLREADPATCH.LCOM.~5~ and /dev/null differ
diff --git a/patches/LLREADPATCH.~5~ b/patches/LLREADPATCH.~5~
deleted file mode 100644
index b10e1a29..00000000
--- a/patches/LLREADPATCH.~5~
+++ /dev/null
@@ -1 +0,0 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED " 1-Aug-2020 18:52:48" 
{DSK}<Users>kaplan>Local>medley3.5>lispcore>patches>LLREADPATCH.;5 5566   

      changes to%:  (FNS CHARCODE.DECODE)

      previous date%: "24-Jul-2020 08:50:43" 
{DSK}<Users>kaplan>Local>medley3.5>lispcore>patches>LLREADPATCH.;2)


(PRETTYCOMPRINT LLREADPATCHCOMS)

(RPAQQ LLREADPATCHCOMS ((FNS CHARCODE.DECODE)))
(DEFINEQ

(CHARCODE.DECODE
  [LAMBDA (C NOERROR)                                   (* ; "Edited  1-Aug-2020 18:52 by rmk:")
                                                             (* ; "Edited 18-Feb-87 22:03 by bvm:")
    (DECLARE (GLOBALVARS CHARACTERNAMES CHARACTERSETNAMES))

    (* ;; "RMK 2020:  Added hexstring decoding for  Unicode:  no commas or other delimiters")

    (* ;; "This overrides the definition in LLREAD.  It should be placed there, but for some reason it is not possible to then recompile that file:  loading a new .LCOM says that \INVALID.SYMBOL is a bad compiled function, and then it loses track of the keyword package. Could be a load-sequence problem that would be resolved if this is installed in a new INIT.SYSOUT rather than an overlay of files already loaded into the LISP.SYSOUT")

    (COND
       ((NOT C)
        NIL)
       ((LISTP C)
        (CONS (CHARCODE.DECODE (CAR C)
                     NOERROR)
              (CHARCODE.DECODE (CDR C)
                     NOERROR)))
       ((NOT (OR (ATOM C)
                 (STRINGP C)))
        (AND (NOT NOERROR)
             (ERROR "BAD CHARACTER SPECIFICATION" C)))
       ((EQ (NCHARS C)
            1)
        (CHCON1 C))
       (T
        (SELCHARQ (CHCON1 C)
             (^ (AND (SETQ C (CHARCODE.DECODE (SUBSTRING C 2 -1)
                                    NOERROR))
                     (LOGAND C (LOGNOT 96))))
             (%# 
                 (* ;; "We use IPLUS instead of LOGOR here because some people want ##char to read as Xerox Meta, i.e., 1,char")

                 (AND (SETQ C (CHARCODE.DECODE (SUBSTRING C 2 -1)
                                     NOERROR))
                      (IPLUS C 128)))
             (LET
              ((STR (MKSTRING C)))
              (for X in CHARACTERNAMES when (STRING.EQUAL (CAR X)
                                                               STR)
                 do (RETURN (OR (NUMBERP (CADR X))
                                    (CHARCODE.DECODE (CADR X)
                                           NOERROR)))
                 finally
                 (RETURN (LET ((POS (STRPOSL '(%, - "." "|")
                                           STR))
                               CH CSET)                      (* ; "In the form charset,char")
                              (COND
                                 ((AND POS (SETQ CH (OR (CL:PARSE-INTEGER STR :START POS :RADIX 8 
                                                               :JUNK-ALLOWED T)
                                                        (CHARCODE.DECODE (SUBSTRING STR
                                                                                    (ADD1 POS))
                                                               NOERROR)))
                                       (< CH 256)
                                       (>= CH 0))            (* ; 
                                        "parsed the char part as an octal number or character spec")
                                  (if (AND [SETQ CSET (OR (CL:PARSE-INTEGER STR :END (SUB1 POS)
                                                                     :RADIX 8 :JUNK-ALLOWED T)
                                                              (for PAIR in CHARACTERSETNAMES
                                                                 first (SETQ POS
                                                                            (SUBSTRING STR 1
                                                                                   (SUB1 POS)))
                                                                 when (STRING.EQUAL (CAR PAIR)
                                                                                 POS)
                                                                 do (RETURN (CADR PAIR]
                                               (< CSET 256)
                                               (>= CSET 0))
                                      then               (* ; 
                              "parsed the charset part as an octal number or standard charset name")
                                            (LOGOR CH (LLSH CSET 8))
                                    elseif (NOT NOERROR)
                                      then (ERROR "BAD CHARACTERSET SPECIFICATION" C)))
                                 ((AND (NOT (FIXP C))
                                       (CL:PARSE-INTEGER (CL:IF (EQ 1 (OR (STRPOS "0x" STR)
                                                                          (STRPOS "0X" STR)
                                                                          (STRPOS "U+" STR)))
                                                             (SUBSTRING STR 3)
                                                             STR)
                                              :RADIX 16 :JUNK-ALLOWED T)))
                                 ((NOT NOERROR)
                                  (ERROR "BAD CHARACTER SPECIFICATION" C])
)
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (427 5543 (CHARCODE.DECODE 437 . 5541)))))
STOP
\ No newline at end of file
diff --git a/sources/LLREAD b/sources/LLREAD
index 0a378e24..11b33ada 100644
--- a/sources/LLREAD
+++ b/sources/LLREAD
@@ -1,1666 +1 @@
-(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
-(FILECREATED " 4-Aug-93 14:43:07" |{PELE:MV:ENVOS}<LISPCORE>SOURCES>LLREAD.;8| 123882 
-
-      changes to%:  (FNS \RSTRING2)
-                    (MACROS \NSIN)
-
-      previous date%: "11-Mar-91 13:34:55" |{PELE:MV:ENVOS}<LISPCORE>SOURCES>LLREAD.;7|)
-
-
-(* ; "
-Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1993 by Venue & Xerox Corporation.  All rights reserved.
-")
-
-(PRETTYCOMPRINT LLREADCOMS)
-
-(RPAQQ LLREADCOMS
-       [(COMS                                                (* ; "Reader entrypoints")
-              (FNS LASTC PEEKC PEEKCCODE RATOM READ READC READCCODE READP SETREADMACROFLG 
-                   SKIPSEPRCODES SKIPSEPRS \NSIN.24BITENCODING.ERROR SKREAD))
-        (COMS                                                (* ; "CommonLisp read entry points")
-              (FNS CL:READ CL:READ-PRESERVING-WHITESPACE CL:READ-DELIMITED-LIST CL:PARSE-INTEGER))
-        (COMS                                                (* ; "reading strings")
-              (FNS RSTRING READ-EXTENDED-TOKEN \RSTRING2))
-        (COMS                                                (* ; "Core of the reader")
-              (FNS \TOP-LEVEL-READ \SUBREAD \SUBREADCONCAT \READ.SYMBOL \INVALID.SYMBOL 
-                   \APPLYREADMACRO INREADMACROP))
-        (COMS                                                (* ; "Read macro for '")
-              (FNS READQUOTE))
-        (COMS                                                (* ; "# macro")
-              (FNS READVBAR READHASHMACRO DEFMACRO-LAMBDA-LIST-KEYWORD-P DIGITBASEP READNUMBERINBASE
-                   ESTIMATE-DIMENSIONALITY SKIP.HASH.COMMENT CMLREAD.FEATURE.PARSER))
-        (COMS                                                (* ; "Reading characters with #\")
-              (FNS CHARACTER.READ CHARCODE.DECODE)
-              (VARS CHARACTERNAMES CHARACTERSETNAMES))
-        (DECLARE%: DOEVAL@COMPILE DONTCOPY (CONSTANTS * READTYPES)
-               (MACROS .CALL.SUBREAD. FIXDOT RBCONTEXT PROPRB \RDCONC)
-               (EXPORT (MACROS \BACKCHAR \BACKNSCHAR \CHECKEOLC \INCHAR \INCCODE \PEEKCCODE \NSIN 
-                              \NSPEEK NUMERIC-CHARSET))
-               (SPECVARS *READ-NEWLINE-SUPPRESS* \RefillBufferFn)
-               (GLOBALVARS *KEYWORD-PACKAGE* *INTERLISP-PACKAGE*))
-        [COMS                                                (* ; 
-                                                           "Support for various external formats")
-              [COMS                                          (* ; "JIS to XCCS conversion table.")
-                    (VARS *JIS-TO-XCCS-CONV-NO-FONT-TABLE* *JIS-TO-XCCS-CODE-MAP* 
-                          *HANKAKU-TO-ZENKAKU-CODE-MAP*)
-                    (GLOBALVARS *JIS-TO-XCCS-CONV-NO-FONT-TABLE* *JIS-TO-XCCS-CONV-TABLE-LIST* 
-                           *JIS-TO-XCCS-CODE-MAP* *HANKAKU-TO-ZENKAKU-CODE-MAP* 
-                           *JIS-1KU-TO-XCCS-CONV-TABLE* *JIS-2KU-TO-XCCS-CONV-TABLE* 
-                           *JIS-6KU-TO-XCCS-CONV-TABLE* *XCCS-TO-JIS-CONV-TABLE* 
-                           *HANKAKU-TO-ZENKAKU-CONV-TABLE* *ZENKAKU-TO-HANKAKU-CONV-TABLE*)
-                    (FNS \MAKE.JIS.TO.XCCS.CONV.TABLE)
-                    (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\MAKE.JIS.TO.XCCS.CONV.TABLE]
-              [COMS                                          (* ; "JIS to XCCS converter")
-                    (INITVARS (*REPLACE-NO-FONT-CODE* T)
-                           (*DEFAULT-NOT-CONVERTED-FAT-CODE* 8739))
-                    (GLOBALVARS *REPLACE-NO-FONT-CODE* *DEFAULT-NOT-CONVERTED-FAT-CODE*)
-                    (DECLARE%: DOEVAL@COMPILE DONTCOPY (EXPORT (MACROS \CONV.JIS.TO.XCCS 
-                                                                      \DO.CONV.JIS.TO.XCCS]
-              [COMS                                          (* ; "XCCS to JIS converter")
-                    (FNS CONVHANKAKU)
-                    (DECLARE%: DOEVAL@COMPILE DONTCOPY (EXPORT (MACROS \CONV.XCCS.TO.JIS 
-                                                                      \DO.CONV.XCCS.TO.JIS \ASCIIP 
-                                                                      \NOT.EQUIVALENT.TO.JIS 
-                                                                      \CONV.HANKAKU.TO.ZENKAKUP 
-                                                                      \CONV.ZENKAKU.KANA]
-              (COMS (FNS \JISIN \JISPEEK \BACKJISCHAR \SHIFTJISIN \SHIFTJISPEEK \BACKSHIFTJISCHAR 
-                         \EUCIN \EUCPEEK \BACKEUCCHAR \THROUGHIN \THROUGHPEEK \BACKTHROUGHCHAR)
-                    (DECLARE%: DOEVAL@COMPILE DONTCOPY
-                           (EXPORT 
-
-                                 (* ;; "XCCS specific macro.  Although the decoder and encoder are implemented as functions in general, only for XCCS, they are implemeted as macros for efficiency reason.")
-
-                                  (MACROS \XCCSIN \XCCSPEEK \BACKXCCSCHAR \XCCSP)
-                                  
-                                  (* ;; "JIS specific macro")
-
-                                  (MACROS \EXTRACT.NO.FONT.CODE \EXTARACT.CONV.TABLE 
-                                         \NOT.EQUIVALENT.TO.XCCS \EXTRACT.SET \EXTRACT.CODE 
-                                         \CHNAGE.KI.MODE \KIMODEP \HANKAKUP \KANJIP \NOTGAIJIP 
-                                         \INVALID.TENP \CONV.HANKAKU.KANA \OUTKI \OUTKO)
-                                  
-                                  (* ;; "Shift-JIS specific macro")
-
-                                  (MACROS \CONV.SJIS.TO.JIS \CONV.JIS.TO.SJIS \SJIS.KANJI.FIRST.BYTEP
-                                         )
-                                  
-                                  (* ;; "EUC specific macro")
-
-                                  (MACROS \EUC.KANJI.FIRST.BYTEP \GAIJIP \EUC.HANKAKUP]
-        (INITVARS (*SIGNAL-24BIT-NSENCODING-ERROR*)
-               (*READ-NEWLINE-SUPPRESS*)
-               (\RefillBufferFn (FUNCTION \READCREFILL)))
-                                                             (* ; 
-  "Top level val of \RefillBufferFn means act like READC--we must be doing a raw BIN (or PEEKBIN?)")
-        (LOCALVARS . T)
-        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
-               (ADDVARS (NLAMA)
-                      (NLAML)
-                      (LAMA CONVHANKAKU CL:PARSE-INTEGER CL:READ-DELIMITED-LIST 
-                            CL:READ-PRESERVING-WHITESPACE CL:READ])
-
-
-
-(* ; "Reader entrypoints")
-
-(DEFINEQ
-
-(LASTC
-(LAMBDA (FILE) (* ; "Edited  6-Jan-88 15:31 by jds") (* ;; "Be careful only to do BIN's if we first were able to back up, so that an EOF doesn't happen.  This is really an inadequate implementation, because it fails for files that cannot be backed up.  Eventually, we must change the character reading functions READ, RATOM, READC to save the last character they read in an STREAM field.") (LET* ((STREAM (\GETSTREAM FILE (QUOTE INPUT))) (LASTCCODE (FETCH (STREAM LASTCCODE) OF STREAM))) (* ;; "(FCHARACTER (SELCHARQ C (CR (SELECTC (ffetch EOLCONVENTION of STREAM) (CR.EOLC (CHARCODE EOL)) C)) (LF (SELECTC (ffetch EOLCONVENTION of STREAM) (LF.EOLC (CHARCODE EOL)) (CRLF.EOLC (COND ((EQ (CHARCODE CR) (UNINTERRUPTABLY (AND (\BACKNSCHAR STREAM SHIFTEDCHARSET) (PROG1 (PROGN (\BACKNSCHAR STREAM SHIFTEDCHARSET) (\NSIN STREAM SHIFTEDCHARSET)) (\NSIN STREAM SHIFTEDCHARSET))))) (CHARCODE EOL)) (T C))) C)) (NIL 0) C))") (COND ((IEQP LASTCCODE 65535) NIL) (T (FCHARACTER LASTCCODE)))))
-)
-
-(PEEKC
-(LAMBDA (FILE FLG) (* rmk%: "10-Apr-85 11:55") (* ;; "FLG says to proceed as if Control were T--not implemented correctly here NIL") (LET ((\RefillBufferFn (FUNCTION \PEEKREFILL)) (STREAM (\GETSTREAM FILE (QUOTE INPUT)))) (DECLARE (SPECVARS \RefillBufferFn)) (FCHARACTER (PEEKCCODE STREAM))))
-)
-
-(PEEKCCODE
-(LAMBDA (FILE NOERROR) (* bvm%: "12-Sep-86 15:19") (LET ((\RefillBufferFn (FUNCTION \PEEKREFILL)) (STREAM (\GETSTREAM FILE (QUOTE INPUT)))) (DECLARE (SPECVARS \RefillBufferFn)) (\PEEKCCODE STREAM NOERROR)))
-)
-
-(RATOM
-(LAMBDA (FILE RDTBL) (* ; "Edited 30-Mar-87 17:21 by bvm:") (* ;;; "Like READ except interpret break characters as single character atoms.  I.e., always returns an atom") (SETQ RDTBL (\GTREADTABLE RDTBL)) (LET ((*READTABLE* RDTBL) (*PACKAGE* (if (fetch (READTABLEP USESILPACKAGE) of RDTBL) then *INTERLISP-PACKAGE* else *PACKAGE*)) (\RefillBufferFn (FUNCTION \RATOM/RSTRING-REFILL))) (DECLARE (SPECVARS *READTABLE* *PACKAGE* \RefillBufferFn)) (WITH-RESOURCE (\PNAMESTRING) (\SUBREAD (\GETSTREAM FILE (QUOTE INPUT)) (fetch (READTABLEP READSA) of *READTABLE*) RATOM.RT \PNAMESTRING (AND (fetch (READTABLEP CASEINSENSITIVE) of *READTABLE*) (fetch (ARRAYP BASE) of UPPERCASEARRAY)) NIL NIL NIL T))))
-)
-
-(READ
-(LAMBDA (FILE RDTBL FLG) (* ; "Edited 19-Mar-87 18:35 by bvm:") (LET ((*READTABLE* (\GTREADTABLE RDTBL)) (*READ-NEWLINE-SUPPRESS* FLG)) (DECLARE (SPECVARS *READTABLE* *READ-NEWLINE-SUPPRESS*)) (* ;; "*READ-NEWLINE-SUPPRESS* is used freely by \FILLBUFFER") (* ;; "Call reader with PRESERVE-WHITESPACE = T, since that's the semantics Interlisp has always had before (though maybe not explicitly stated).") (\TOP-LEVEL-READ FILE NIL NIL NIL T)))
-)
-
-(READC
-(LAMBDA (FILE RDTBL) (* ; "Edited  6-Jan-88 15:30 by jds") (LET ((*READTABLE* (\GTREADTABLE RDTBL)) (\RefillBufferFn (FUNCTION \READCREFILL))) (DECLARE (SPECVARS *READTABLE* \RefillBufferFn)) (FCHARACTER (REPLACE (STREAM LASTCCODE) OF (\INSTREAMARG FILE) WITH (\INCCODE (\INSTREAMARG FILE))))))
-)
-
-(READCCODE
-  [LAMBDA (FILE RDTBL)                                   (* ; "Edited  3-Jun-88 01:30 by atm")
-
-(* ;;; "returns a 16 bit character code.  \INCHAR does the EOL conversion and this function converts to a 16 bit value.  Saves the character for LASTC as well.")
-
-    (SETQ FILE (\GETSTREAM FILE 'INPUT))
-    (FDEVOP 'READCHARCODE (fetch (STREAM DEVICE) of FILE)
-           FILE RDTBL])
-
-(READP
-(LAMBDA (FILE FLG) (* rmk%: " 5-Apr-85 09:09") (* ; "The 10 does not do the EOL check on the peeked character.") (LET* ((STREAM (\GETSTREAM FILE (QUOTE INPUT))) (DEVICE (ffetch (STREAM DEVICE) of STREAM))) (COND ((ffetch (FDEV READP) of DEVICE) (FDEVOP (QUOTE READP) DEVICE STREAM FLG)) (T (\GENERIC.READP STREAM FLG)))))
-)
-
-(SETREADMACROFLG
-(LAMBDA (FLG) (* rmk%: "25-OCT-83 16:13") (* ; "D doesn't cause the read-macro context error, hence doesn't maintain this flag") NIL)
-)
-
-(SKIPSEPRCODES
-(LAMBDA (FILE RDTBL) (* ; "Edited  6-Jan-88 13:09 by jds") (* ;; "Passes over non-separators to peek at the first non-separator on FILE.  Returns either last peeked character, or NIL if no non-seprs left in the file.") (bind PREVC C SHIFTEDCHARSET (STREAM _ (\GETSTREAM FILE (QUOTE INPUT))) (SA _ (fetch (READTABLEP READSA) of (\GTREADTABLE RDTBL))) (\RefillBufferFn _ (QUOTE \PEEKREFILL)) first (SETQ SHIFTEDCHARSET (UNFOLD (ACCESS-CHARSET STREAM) 256)) declare (SPECVARS \RefillBufferFn) while (EQ SEPRCHAR.RC (\SYNCODE SA (SETQ C (OR (\NSPEEK STREAM SHIFTEDCHARSET SHIFTEDCHARSET T) (RETURN))))) do (SETQ PREVC C) (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET) finally (AND PREVC (replace (STREAM LASTCCODE) of STREAM with PREVC)) (RETURN C)))
-)
-
-(SKIPSEPRS
-(LAMBDA (FILE RDTBL) (* ; "Edited 11-Sep-87 17:52 by bvm:") (* ;; "Passes over non-separators to peek at the first non-separator on FILE.  Returns either last peeked character, or NIL if no non-seprs left in the file.") (bind C SHIFTEDCHARSET (STREAM _ (\GETSTREAM FILE (QUOTE INPUT))) (SA _ (fetch (READTABLEP READSA) of (\GTREADTABLE RDTBL))) (\RefillBufferFn _ (QUOTE \PEEKREFILL)) first (SETQ SHIFTEDCHARSET (UNFOLD (ACCESS-CHARSET STREAM) 256)) declare (SPECVARS \RefillBufferFn) while (EQ SEPRCHAR.RC (\SYNCODE SA (SETQ C (OR (\NSPEEK STREAM SHIFTEDCHARSET SHIFTEDCHARSET T) (RETURN))))) do (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET) finally (RETURN (FCHARACTER C))))
-)
-
-(\NSIN.24BITENCODING.ERROR
-(LAMBDA (STREAM) (* bvm%: "12-Mar-86 15:35") (DECLARE (USEDFREE *SIGNAL-24BIT-NSENCODING-ERROR*)) (* ;;; "Called if we see the sequence shift,shift on STREAM -- means shift to 24-bit character set, which we don't support.  Usually this just means we're erroneously reading a binary file as text.  If this function returns, its value is taken as a character set to shift to") (COND (*SIGNAL-24BIT-NSENCODING-ERROR* (* ; "Only cause error if user/reader cares") (ERROR "24-bit NS encoding not supported" STREAM))) (* ; "Return charset zero") 0)
-)
-
-(SKREAD
-  [LAMBDA (FILE REREADSTRING RDTBL)                      (* ; "Edited  6-Apr-88 11:06 by amd")
-    (LET ((*READ-SUPPRESS* 'SKREAD)
-          (*READTABLE* (\GTREADTABLE RDTBL))
-          (\RBFLG)
-          (STRM (\GETSTREAM FILE 'INPUT))
-          CH)
-         (DECLARE (CL:SPECIAL *READTABLE* *READ-SUPPRESS* \RBFLG))
-         [COND
-            (REREADSTRING                                    (* ; 
-                                                    "REREADSTRING is string of chars already read.")
-                   (SETQ STRM (CL:MAKE-CONCATENATED-STREAM (CL:MAKE-STRING-INPUT-STREAM (MKSTRING
-                                                                                         REREADSTRING
-                                                                                         ))
-                                     STRM]                   (* ; 
-      "Because of return requirements, have to preview stream for unbalanced closing bracket/paren")
-         (if (NULL (SETQ CH (SKIPSEPRCODES STRM)))
-             then (\EOF.ACTION STRM)
-           else (SELECTC (PROG1 (\SYNCODE (fetch (READTABLEP READSA) of *READTABLE*)
-                                           CH)
-          (* ;; "Read in suppressed mode.  Reader sets \Rbflg free if read ended on unbalanced bracket.  Reason we do the READ in all cases is so that we need to consume the unbalanced paren/bracket, just as if we really had read it; however, READ doesn't set \Rbflg for these cases")
-
-                                    (\TOP-LEVEL-READ STRM NIL NIL NIL T))
-                        (RIGHTPAREN.RC                       (* ; "unbalanced right paren")
-                                       '%))
-                        (RIGHTBRACKET.RC                     (* ; "unbalanced right bracket")
-                             '%])
-                        (AND \RBFLG '%]])
-)
-
-
-
-(* ; "CommonLisp read entry points")
-
-(DEFINEQ
-
-(CL:READ
-(CL:LAMBDA (&OPTIONAL (INPUT-STREAM *STANDARD-INPUT*) (EOF-ERROR-P T) EOF-VALUE RECURSIVE-P) (* ; "Edited 14-Dec-86 18:48 by bvm") (COND (RECURSIVE-P (* ; "Dive straight into reader using current settings of everything") (.CALL.SUBREAD. INPUT-STREAM)) (T (\TOP-LEVEL-READ INPUT-STREAM (NOT EOF-ERROR-P) EOF-VALUE))))
-)
-
-(CL:READ-PRESERVING-WHITESPACE
-(CL:LAMBDA (&OPTIONAL (STREAM *STANDARD-INPUT*) (EOF-ERRORP T) (EOF-VALUE NIL) (RECURSIVEP NIL)) (* ; "Edited 19-Mar-87 18:33 by bvm:") (* ;; "Reads from stream and returns the object read, preserving the whitespace that followed the object.") (COND (RECURSIVEP (* ; "Dive straight into reader using current settings of everything") (.CALL.SUBREAD. STREAM)) (T (\TOP-LEVEL-READ STREAM (NOT EOF-ERRORP) EOF-VALUE NIL T))))
-)
-
-(CL:READ-DELIMITED-LIST
-(CL:LAMBDA (CHAR &OPTIONAL (INPUT-STREAM *STANDARD-INPUT*) RECURSIVE-P) (* ; "Edited 14-Dec-86 18:48 by bvm") (* ;;; "Read a list of elements terminated by CHAR.  CHAR must not be a separator char, and ideally should not be a constituent char (if it is, it must be preceded by whitespace for READ-DELIMITED-LIST to work)") (LET ((ENDCODE (OR (FIXP CHAR) (CL:CHAR-CODE CHAR))) (INSTREAM (\GETSTREAM INPUT-STREAM (QUOTE INPUT)))) (if RECURSIVE-P then (* ; "Have to dive into reader without disturbing *CIRCLE-READ-LIST*") (.CALL.SUBREAD. INPUT-STREAM NIL NIL ENDCODE) else (\TOP-LEVEL-READ INPUT-STREAM NIL NIL ENDCODE))))
-)
-
-(CL:PARSE-INTEGER
-  [CL:LAMBDA
-   (STRING &KEY START END (RADIX 10)
-          JUNK-ALLOWED)                                (* ; "Edited  8-Feb-91 13:24 by gadener")
-   (CL:IF (NOT (CL:STRINGP STRING))
-       (ERROR "This is not a string : ~S" STRING)
-       (PROG ((SA (fetch (READTABLEP READSA) of CMLRDTBL))
-              (BASE (fetch (STRINGP BASE) of STRING))
-              (LEN (fetch (STRINGP LENGTH) of STRING))
-              (OFFST (fetch (STRINGP OFFST) of STRING))
-              (FATP (fetch (STRINGP FATSTRINGP) of STRING))
-              MAXDIGITCODE MAXALPHACODE INDEX STOP CHAR SIGN STARTINT ENDINT ERR)
-             (SETQ RADIX (\CHECKRADIX RADIX))
-             (SETQ INDEX (+ OFFST (if (NULL START)
-                                      then 0
-                                    elseif (< START 0)
-                                      then (\ILLEGAL.ARG START)
-                                    else START)))
-             (SETQ STOP (+ OFFST (if (NULL END)
-                                     then LEN
-                                   elseif (OR (> END LEN)
-                                                  (< END 0))
-                                     then (\ILLEGAL.ARG END)
-                                   else END)))
-             (SETQ MAXDIGITCODE (+ (CHARCODE 0)
-                                   RADIX -1))
-             (SETQ MAXALPHACODE (AND (> RADIX 10)
-                                     (+ (CHARCODE A)
-                                        RADIX -11)))
-             (while (AND (< INDEX STOP)
-                             (EQ (\SYNCODE SA (\GETBASECHAR FATP BASE INDEX))
-                                 SEPRCHAR.RC)) do        (* ; "Skip over separators")
-                                                     (SETQ INDEX (CL:1+ INDEX)))
-             [COND
-                ((>= INDEX STOP)                             (* ; "no characters remain")
-                 (RETURN (COND
-                            (JUNK-ALLOWED                    (* ; "don't error")
-                                   (CL:VALUES NIL STOP))
-                            (T (SETQ ERR "No non-whitespace characters in integer string: ~S")
-                               (GO FAIL]
-
-        (* ;; "Start parsing a number.  Allowed to start with a single sign, then digits in radix, nothing else.  Assume collating sequence is (+, -) < digits < uppercase letters < lowercase letters.")
-
-             (do (SETQ CHAR (\GETBASECHAR FATP BASE INDEX))
-                    (if (<= CHAR MAXDIGITCODE)
-                        then                             (* ; "sign or digit")
-                              (if (>= CHAR (CHARCODE 0))
-                                  then                   (* ; " digit")
-                                        (OR STARTINT (SETQ STARTINT INDEX))
-                                elseif (AND (NOT SIGN)
-                                                (NOT STARTINT))
-                                  then                   (* ; 
-                                                           "maybe sign.  No good if not at start")
-                                        (SELCHARQ CHAR
-                                             (- (SETQ SIGN '-))
-                                             (+ (SETQ SIGN '+))
-                                             (RETURN))
-                                else (RETURN))
-                      elseif (AND MAXALPHACODE (<= (if (>= CHAR (CHARCODE "a"))
-                                                           then 
-                                                             (* ; "uppercase it first")
-                                                                 (- CHAR (- (CHARCODE "a")
-                                                                            (CHARCODE "A")))
-                                                         else CHAR)
-                                                       MAXALPHACODE))
-                        then                             (* ; "is alphabetic digit")
-                              (OR STARTINT (SETQ STARTINT INDEX))
-                      else (RETURN)) repeatwhile (< (add INDEX 1)
-                                                            STOP))
-             (SETQ ENDINT INDEX)
-             (RETURN (CL:VALUES (COND
-                                   ([AND STARTINT
-                                         (OR JUNK-ALLOWED (EQ INDEX STOP)
-                                             (do (if (NEQ (\SYNCODE SA CHAR)
-                                                                  SEPRCHAR.RC)
-                                                         then 
-                                                             (* ; " junk found")
-                                                               (RETURN NIL)
-                                                       elseif (EQ (add INDEX 1)
-                                                                      STOP)
-                                                         then 
-                                                             (* ; "at end of string, win")
-                                                               (RETURN T)
-                                                       else (SETQ CHAR (\GETBASECHAR FATP BASE 
-                                                                                  INDEX]
-                                    (\MKINTEGER BASE STARTINT ENDINT (EQ SIGN '-)
-                                           RADIX FATP))
-                                   (JUNK-ALLOWED NIL)
-                                   ((NULL STARTINT)
-                                    (SETQ ERR "There aren't any digits in this integer string: ~S.")
-                                    (GO FAIL))
-                                   (T (SETQ ERR "There is junk in this integer string: ~S.")
-                                      (GO FAIL)))
-                            (- INDEX OFFST)))
-         FAIL
-             (CL:ERROR ERR (if (OR START END)
-                               then (CL:SUBSEQ STRING (OR START 0)
-                                               (OR END LEN))
-                             else STRING))))])
-)
-
-
-
-(* ; "reading strings")
-
-(DEFINEQ
-
-(RSTRING
-(LAMBDA (FILE RDTBL RSFLG) (* ; "Edited 22-Mar-87 20:53 by bvm:") (LET ((*READTABLE* (\GTREADTABLE RDTBL)) (\RefillBufferFn (QUOTE \RATOM/RSTRING-REFILL)) (*READ-SUPPRESS* NIL)) (DECLARE (SPECVARS *READTABLE* \RefillBufferFn *READ-SUPPRESS*)) (* ;; "It's not clear that *READ-SUPPRESS* is supposed to affect anything other than calls to READ.  So play it safe and force \Rstring2 to really read a string.") (WITH-RESOURCE (\PNAMESTRING) (\RSTRING2 (\GETSTREAM FILE (QUOTE INPUT)) (fetch READSA of *READTABLE*) (OR RSFLG T) \PNAMESTRING))))
-)
-
-(READ-EXTENDED-TOKEN
-(LAMBDA (STREAM RDTBL ESCAPE-ALLOWED-P) (* ; "Edited 11-Sep-87 16:23 by bvm:") (* ;; "This is a cross between RSTRING and \SUBREAD.  Read a %"token%" from STREAM, as defined by the Common Lisp reader and the syntax in RDTBL.  EOF terminates as well.  If ESCAPE-ALLOWED-P is true, escapes are honored and if one appears, a second value of T is returned.  Otherwise, escapes are treated as vanilla chars and the caller can barf on them itself if it desires.") (SETQ RDTBL (\GTREADTABLE RDTBL)) (WITH-RESOURCE (\PNAMESTRING) (PROG ((CASEBASE (AND (fetch (READTABLEP CASEINSENSITIVE) of RDTBL) (fetch (ARRAYP BASE) of UPPERCASEARRAY))) (PBASE (ffetch (STRINGP XBASE) of \PNAMESTRING)) (SHIFTEDCHARSET (UNFOLD (ACCESS-CHARSET STREAM) 256)) (J 0) (SA (fetch READSA of RDTBL)) CH SNX ANSLIST ANSTAIL ESCAPE-APPEARED ESCAPING FATSEEN) LP (if (\EOFP STREAM) then (* ; "end of file terminates string just like a sepr/break") (GO FINISH)) (SETQ CH (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET)) (* ; "NOTE: This should really be (\CHECKEOLC (\NSIN --) --), but eol is usually a break or sepr and the \BACKNSCHAR doesn't work right.  Fix this when we unread correctly") (SETQ SNX (\SYNCODE SA CH)) (COND ((AND ESCAPE-ALLOWED-P (SELECTC SNX (ESCAPE.RC (SETQ CH (\CHECKEOLC (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET) (ffetch EOLCONVENTION of STREAM) STREAM)) (SETQ ESCAPE-APPEARED T)) (MULTIPLE-ESCAPE.RC (SETQ ESCAPING (NOT ESCAPING)) (SETQ ESCAPE-APPEARED T) (GO LP)) NIL))) (ESCAPING (* ; "eat chars until next |")) ((fetch STOPATOM of SNX) (\BACKNSCHAR STREAM SHIFTEDCHARSET) (GO FINISH)) ((AND CASEBASE (ILEQ CH \MAXTHINCHAR)) (SETQ CH (\GETBASEBYTE CASEBASE CH)))) (COND ((EQ J \PNAMELIMIT) (* ; "Filled PNSTR so have to save those chars away and start filling up a new buffer") (SETQ J (\SMASHSTRING (ALLOCSTRING J NIL NIL FATSEEN) 0 \PNAMESTRING J)) (COND (ANSLIST (RPLACD ANSTAIL (SETQ ANSTAIL (CONS J NIL)))) (T (SETQ ANSTAIL (SETQ ANSLIST (CONS J NIL))))) (SETQ J 0))) (\PNAMESTRINGPUTCHAR PBASE J CH) (COND ((AND (NOT FATSEEN) (IGREATERP CH \MAXTHINCHAR)) (SETQ FATSEEN T))) (SETQ J (ADD1 J)) (GO LP) FINISH (SETQ J (\SMASHSTRING (ALLOCSTRING J NIL NIL FATSEEN) 0 \PNAMESTRING J)) (COND (ANSLIST (RPLACD ANSTAIL (SETQ ANSTAIL (CONS J NIL))) (SETQ J (CONCATLIST ANSLIST)))) (RETURN (if ESCAPE-APPEARED then (* ; "do it this way because multiple values are slow") (CL:VALUES J T) else J)))))
-)
-
-(\RSTRING2
-  [LAMBDA (STREAM SA RSFLG PNSTR)             (* ; 
-                                                "Edited  4-Aug-93 12:38 by sybalskY:MV:ENVOS")
-
-(* ;;; "The main string reader.  Reads characters from STREAM according to the syntax table SA and returns a string.  PNSTR is an instance of the global resource \PNAMESTRING, which we can use all to ourselves as a buffer.")
-
-(* ;;; "If RSFLG is T then the call is from RSTRING, in which case the string is terminated by a break or sepr in SA.  If RSFLG is NIL then the string is terminated by a string delimiter.  If RSFLG is SKIP then CR's and the following separator chars are discarded as an otherwise normal string is read")
-
-    (DECLARE (USEDFREE *READTABLE* *READ-SUPPRESS*))
-    (PROG ((EOLC (ffetch EOLCONVENTION of STREAM))
-           (PBASE (SELECTQ (SYSTEMTYPE)
-                      (VAX PNSTR)
-                      (ffetch (STRINGP XBASE) of PNSTR)))
-           (SHIFTEDCHARSET (UNFOLD (ACCESS-CHARSET STREAM)
-                                  256))
-           (J 0)
-           EOLCHAR CH SNX ANSLIST ANSTAIL LASTC FATSEEN SKIPPING)
-          (SELECTC EOLC
-              (CRLF.EOLC (SETQ EOLCHAR (CHARCODE CR)))
-              (CR.EOLC (SETQ EOLCHAR (CHARCODE CR)))
-              (LF.EOLC (SETQ EOLCHAR (CHARCODE LF)))
-              NIL)
-      RS2LP
-          (SETQ CH (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET))
-          [COND
-             ((EQ CH EOLCHAR)
-
-              (* ;; "We just read the stream's EOL character, so we have to turn it into our EOL.  Most places do this with \CHECKEOLC, but we can't do that here, because if the eol is CRLF and would terminate the read, \BACKNSCHAR won't work right.")
-
-              (COND
-                 ([AND (EQ RSFLG T)
-                       (fetch STOPATOM of (\SYNCODE SA (CHARCODE CR]
-                                                             (* ; 
-                                          "From RSTRING, eol terminates read.  Leave eol in buffer")
-                  (\BACKNSCHAR STREAM SHIFTEDCHARSET)
-                  (GO FINISH))
-                 (T (COND
-                       ((AND (EQ EOLC CRLF.EOLC)
-                             (EQ (\PEEKBIN STREAM T)
-                                 (CHARCODE LF)))             (* ; "Eat the LF after the CR")
-                        (\BIN STREAM)))
-                    (SETQ CH (CHARCODE CR]
-          (SETQ SNX (\SYNCODE SA CH))
-          (SELECTC SNX
-              (OTHER.RC                                      (* ; "Normal case, nothing to do"))
-              (ESCAPE.RC [COND
-                            ((fetch ESCAPEFLG of *READTABLE*)
-                             (SETQ CH (\CHECKEOLC (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET)
-                                             EOLC STREAM))
-                             (COND
-                                ((AND (EQ RSFLG 'SKIP)
-                                      (EQ CH (CHARCODE CR))) (* ; 
-                  "Strip leading spaces after escaped returns, too, but leave the CR in the string")
-                                 (SETQ SKIPPING 0)
-                                 (GO PUTCHAR])
-              (SELECTQ RSFLG
-                  (NIL                                       (* ; "end check is dbl quote")
-                       (COND
-                          ((EQ SNX STRINGDELIM.RC)           (* ; "Got it")
-                           (SETQ LASTC CH)
-                           (GO FINISH))))
-                  (T                                         (* ; 
-            "if called from RSTRING, end check is break or sepr, and we must leave delim in stream")
-                     (COND
-                        ((fetch STOPATOM of SNX)
-                         (\BACKNSCHAR STREAM SHIFTEDCHARSET)
-                         (GO FINISH))))
-                  (SKIP                                      (* ; 
-                                                       "Like NIL but strip cr's and leading spaces")
-                        (SELECTC SNX
-                            (STRINGDELIM.RC 
-                                 (SETQ LASTC CH)
-                                 (GO FINISH))
-                            (SEPRCHAR.RC                     (* ; "Assume that CR is a sepr")
-                                         (COND
-                                            [SKIPPING (COND
-                                                         ((EQ CH (CHARCODE EOL))
-                                                             (* ; 
-                                                           "Multiple CR's while skipping are kept")
-                                                          (COND
-                                                             ((EQ SKIPPING T)
-                                                             (* ; 
-                    "Turn previous space back into CR.  Note that J is guaranteed to be at least 1")
-                                                              (\PNAMESTRINGPUTCHAR PBASE (SUB1 J)
-                                                                     CH)
-                                                              (SETQ SKIPPING 0)))
-                                                          (GO PUTCHAR))
-                                                         (T  (* ; "Continue skipping seprs")
-                                                            (GO RS2LP]
-                                            ((EQ CH (CHARCODE EOL))
-                                                             (* ; 
-                                                      "Turn CR into space and start skipping seprs")
-                                             (SETQ SKIPPING T)
-                                             (SETQ CH (CHARCODE SPACE))
-                                             (GO PUTCHAR))))
-                            NIL))
-                  (SHOULDNT)))
-          (SETQ SKIPPING NIL)
-      PUTCHAR
-          [COND
-             ((NOT *READ-SUPPRESS*)                          (* ; "Accumulate character")
-              (COND
-                 ((EQ J \PNAMELIMIT)                         (* ; 
-                  "Filled PNSTR so have to save those chars away and start filling up a new buffer")
-                  (SETQ J (\SMASHSTRING (ALLOCSTRING J NIL NIL FATSEEN)
-                                 0 PNSTR J))
-                  [COND
-                     [ANSLIST (RPLACD ANSTAIL (SETQ ANSTAIL (CONS J NIL]
-                     (T (SETQ ANSTAIL (SETQ ANSLIST (CONS J NIL]
-                  (SETQ J 0)))
-              (\PNAMESTRINGPUTCHAR PBASE J CH)
-              (SETQ LASTC CH)
-              (COND
-                 ((AND (NOT FATSEEN)
-                       (IGREATERP CH \MAXTHINCHAR))
-                  (SETQ FATSEEN T)))
-              (SETQ J (ADD1 J]
-          (COND
-             ((OR (NEQ RSFLG T)
-                  (NOT (\EOFP STREAM)))                      (* ; "in RSTRING (RSFLG=T), if we've read something already, then end of file terminates string just like a sepr/break")
-              (GO RS2LP)))
-      FINISH
-          (AND LASTC (replace (STREAM LASTCCODE) of STREAM with LASTC))
-          (RETURN (COND
-                     ((NOT *READ-SUPPRESS*)
-                      (SETQ J (\SMASHSTRING (ALLOCSTRING J NIL NIL FATSEEN)
-                                     0 PNSTR J))
-                      (COND
-                         (ANSLIST (RPLACD ANSTAIL (SETQ ANSTAIL (CONS J NIL)))
-                                (CONCATLIST ANSLIST))
-                         (T J])
-)
-
-
-
-(* ; "Core of the reader")
-
-(DEFINEQ
-
-(\TOP-LEVEL-READ
-  [LAMBDA (STREAM EOF-SUPPRESS EOF-VALUE CHAR PRESERVE-WHITESPACE)
-                                                             (* ; "Edited 13-Dec-88 16:28 by jds")
-
-    (* ;; "Entry to the guts of the reader from a place where you may not be already under the reader.  CHAR is for READ-DELIMITED-LIST -- it is charcode to terminate read, in which case we are reading a sequence of things instead of a single thing.  EOF-SUPPRESS is the opposite of CL:READ's EOF-ERROR-P arg.")
-
-    (* ;; 
-  " I EOF-SUPPRESS, set the stream's EODOFSTREAMOP to retfrom here with EOF-VALUE as its result.")
-
-    (LET ((*PACKAGE* (COND
-                        ((fetch (READTABLEP USESILPACKAGE) of (\DTEST *READTABLE*
-                                                                             'READTABLEP))
-                         *INTERLISP-PACKAGE*)
-                        (T *PACKAGE*)))
-          (\RefillBufferFn (FUNCTION \READREFILL))
-          (*CIRCLE-READ-LIST* NIL)
-          (OLD-EOS-OP (fetch ENDOFSTREAMOP of STREAM)))
-         (DECLARE (SPECVARS *PACKAGE* \RefillBufferFn *CIRCLE-READ-LIST* EOF-VALUE))
-         (CL:UNWIND-PROTECT
-             (PROGN [AND EOF-SUPPRESS (REPLACE ENDOFSTREAMOP OF STREAM
-                                         WITH #'(LAMBDA (STREAM)
-                                                      (RETFROM '\TOP-LEVEL-READ EOF-VALUE]
-                    (LET ((RESULT (.CALL.SUBREAD. STREAM EOF-SUPPRESS EOF-VALUE CHAR 
-                                         PRESERVE-WHITESPACE)))
-                         (if *CIRCLE-READ-LIST*
-                             then                        (* ; 
-                                      "There were calls to #=, so go fix up all the ## references.")
-                                   (HASH-STRUCTURE-SMASH RESULT))
-                         RESULT))
-             (REPLACE ENDOFSTREAMOP OF STREAM WITH OLD-EOS-OP))])
-
-(\SUBREAD
-(LAMBDA (STREAM SA READTYPE PNSTR CASEBASE EOF-SUPPRESS EOF-VALUE CHAR PRESERVE-WHITESPACE) (* ; "Edited  7-Jan-88 18:38 by jds") (* ;; "Values of READTYPE are: --- READ.RT for top level of READ, --- NOPROPRB.RT if right-bracket isn't to be propagated -- sublist beginning with left-bracket --- PROPRB.RT if propagation is not suppressed -- sublist beginning with left-paren --- RATOM.RT for call from RATOM") (* ;; "PNSTR is an instance of the global resource \PNAMESTRING, acquired in READ and passed on from level to level.  It is released during read-macro applications, then reacquired.") (* ;; "CASEBASE is base of uppercasearray if read table is case-insensitive.") (* ;; "If EOF-SUPPRESS is true, then if we are at end of file we should return EOF-VALUE instead of erroring (we need this because we might actually be sitting before end of file in front of something that reads nothing, e.g., a comment, so caller can't check EOFP itself).  Always false on recursive calls.") (* ;; "If CHAR is supplied, it is a character code which, when read (in isolation), should terminate this call to read.  Never on when at top-level.") (* ;; "\RBFLG is propagated for top-level calls, in case they are embedded in read-macros.  SKREAD also depends on this.") (* ;; "If PRESERVE-WHITESPACE is true, doesn't throw away the whitespace that terminates the read.") (DECLARE (USEDFREE *READTABLE* \RBFLG)) (* ;; "\RDCONC is a macro that adds a new element as specified by its first argument to the current sublist.  Its other arguments will be executed instead if we are the top-level call") (PROG ((TOPLEVELP (SELECTC READTYPE ((LIST READ.RT RATOM.RT) T) NIL)) (SHIFTEDCHARSET (UNFOLD (ACCESS-CHARSET STREAM) 256)) (PBASE (SELECTQ (SYSTEMTYPE) (VAX PNSTR) (ffetch (STRINGP XBASE) of PNSTR))) SNX LST END ELT DOTLOC CH J ESCAPEFLG INVALIDFLG PACKAGE NCOLONS AT-EOF EOF-POSSIBILITY EXTRASEGMENTS LASTC) (if (AND TOPLEVELP (NOT (\INTERMP STREAM))) then (* ;; "EOF is allowed to terminate tokens on direct READ calls.  Not if reading from terminal, because \FILLBUFFER made sure to put something at the end.") (SETQ EOF-POSSIBILITY T)) NEWTOKEN (* ;; "Here ready to scan a new token.  First skip over separator characters") (SETQ J 0) (SETQ EXTRASEGMENTS (SETQ INVALIDFLG (SETQ ESCAPEFLG (SETQ PACKAGE (SETQ NCOLONS NIL))))) (if (AND EOF-SUPPRESS (NULL (SKIPSEPRCODES STREAM))) then (* ; "caller specified eof-error-p of NIL.  Happens only on top-level calls") (RETURN EOF-VALUE)) (SETQ SHIFTEDCHARSET (UNFOLD (ACCESS-CHARSET STREAM) 256)) (* ; "By Skipping Separator Characters,Happens CHARSET-Mode Exchanging. (Solution of AR#114 in FX, edited by tt [Jan-22-'90])") (repeatwhile (EQ (SETQ SNX (\SYNCODE SA (SETQ CH (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET)))) SEPRCHAR.RC)) (COND ((EQ CH CHAR) (* ; "Read desired terminating char.  TOPLEVELP is always false here") (replace (STREAM LASTCCODE) of STREAM with CH) (* ; "Save last char for LASTC.") (RETURN LST)) ((EQ SNX OTHER.RC) (* ; "Start of an atom") (COND ((AND (EQ CH (CHARCODE %.)) (fetch STOPATOM of (\SYNCODE SA (\NSPEEK STREAM SHIFTEDCHARSET SHIFTEDCHARSET)))) (* ;; "An isolated, unescaped dot.  This special check on every atom could be eliminated if . had a special SNX code") (SETQ DOTLOC END) (* ; "DOTLOC points to CONS cell one before the dot, NIL for car of list, as desired."))) (GO GOTATOMCHAR)) ((fetch STOPATOM of SNX) (* ; "This character definitely does not start an atom") (COND ((EQ READTYPE RATOM.RT) (GO SINGLECHARATOM)) (T (GO BREAK)))) ((EQ SNX PACKAGEDELIM.RC) (* ; "Starting a symbol with a package delimiter -- must be a keyword") (SETQ NCOLONS 1) (SETQ PACKAGE *KEYWORD-PACKAGE*) (SETQ ESCAPEFLG T) (GO NEXTATOMCHAR)) ((AND (SELECTC (fetch MACROCONTEXT of SNX) (FIRST.RMC T) (ALONE.RMC (fetch STOPATOM of (\SYNCODE SA (\NSPEEK STREAM SHIFTEDCHARSET SHIFTEDCHARSET)))) NIL) (fetch READMACROFLG of *READTABLE*)) (COND ((EQ READTYPE RATOM.RT) (GO SINGLECHARATOM)) (T (GO MACRO)))) (T (* ; "Some character that starts an atom but has non-trivial syntax attributes"))) ATOMLOOP (* ;; "At this point, we are accumulating an atom, and CH does not have syntax OTHER, so we have to check special cases") (SELECTC SNX (ESCAPE.RC (* ; "Take next character to be alphabetic, case exact") (COND ((fetch ESCAPEFLG of *READTABLE*) (SETQ CH (\CHECKEOLC (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET) (ffetch EOLCONVENTION of STREAM) STREAM)) (* ; "No EOFP check needed -- it's an error to have escape char with nothing following") (SETQ ESCAPEFLG T) (GO PUTATOMCHAR)))) (MULTIPLE-ESCAPE.RC (* ;; "Take characters up to next multiple escape to be alphabetic, except that single escape chars still escape the next char") (SETQ ESCAPEFLG T) (bind ESCFLG do (SETQ CH (\CHECKEOLC (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET) (ffetch EOLCONVENTION of STREAM) STREAM)) (COND ((NOT (COND (ESCFLG (SETQ ESCFLG NIL)) (T (SELECTC (SETQ SNX (\SYNCODE SA CH)) (MULTIPLE-ESCAPE.RC (* ; "Finished escaped sequence, resume normal processing") (GO NEXTATOMCHAR)) (ESCAPE.RC (* ; "Pass the next char thru verbatim") (SETQ ESCFLG T)) NIL)))) (* ; "All others are pname chars, quoted") (if (NOT *READ-SUPPRESS*) then (COND ((EQ J \PNAMELIMIT) (* ; "if there have been escapes, can't be a number, so ok to error now.") (LISPERROR "ATOM TOO LONG" (\SUBREADCONCAT EXTRASEGMENTS PBASE J)) (GO NEWTOKEN))) (\PNAMESTRINGPUTCHAR PBASE J CH) (add J 1)))))) NIL) GOTATOMCHAR (* ;; "CH is a vanilla atom char to accumulate") (COND ((AND CASEBASE (ILEQ CH \MAXTHINCHAR)) (* ; "Uppercase atom characters") (SETQ CH (\GETBASEBYTE CASEBASE CH)))) PUTATOMCHAR (if (NOT *READ-SUPPRESS*) then (COND ((EQ J \PNAMELIMIT) (* ; "Symbol is too long.  However, it could just be a bignum, so keep accumulating characters until we have to do something.") (push EXTRASEGMENTS (\SMASHSTRING (ALLOCSTRING J NIL NIL T) 0 PNSTR J)) (SETQ J 0))) (\PNAMESTRINGPUTCHAR PBASE J CH) (add J 1) (SETQ LASTC CH) (* ; "Save CH for LASTC.")) NEXTATOMCHAR (if (AND EOF-POSSIBILITY (SETQ AT-EOF (\EOFP STREAM))) then (* ; "EOF terminates atoms at top level") (GO FINISHATOM) elseif (EQ (SETQ SNX (\SYNCODE SA (SETQ CH (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET)))) OTHER.RC) then (* ; "normal case tested first--another vanilla constituent char, so keep accumulating atom chars") (GO GOTATOMCHAR) elseif (fetch STOPATOM of SNX) then (* ; "Terminates atom") (GO FINISHATOM) elseif (EQ SNX PACKAGEDELIM.RC) then (GO GOTPACKAGEDELIM) else (GO ATOMLOOP)) FINISHATOM (* ;; "Come here when an atom has been terminated, either by a break/sepr char or by end of file.") (if INVALIDFLG then (replace (STREAM LASTCCODE) of STREAM with (OR LASTC CH 65535)) (\INVALID.SYMBOL PBASE J NCOLONS PACKAGE EXTRASEGMENTS)) (SETQ ELT (AND (NOT *READ-SUPPRESS*) (if EXTRASEGMENTS then (* ;; "More than \PNAMELIMIT chars were read.  Can't be a symbol, but might be a number.  Pack up all the strings we have into a single string and try to parse it as a number.") (SETQ EXTRASEGMENTS (\SUBREADCONCAT EXTRASEGMENTS PBASE J)) (OR (AND (NULL (OR PACKAGE ESCAPEFLG NCOLONS)) (\PARSE.NUMBER (fetch (STRINGP BASE) of EXTRASEGMENTS) (fetch (STRINGP OFFST) of EXTRASEGMENTS) (fetch (STRINGP LENGTH) of EXTRASEGMENTS) \FATPNAMESTRINGP)) (LISPERROR "ATOM TOO LONG" EXTRASEGMENTS)) else (\READ.SYMBOL PBASE 0 J \FATPNAMESTRINGP PACKAGE (EQ NCOLONS 1) ESCAPEFLG)))) (replace (STREAM LASTCCODE) of STREAM with CH) (* ; "Save last READ char for LASTC.") (if AT-EOF then (* ; "top-level read, atom terminated by EOF") (RETURN ELT)) (\RDCONC ELT (PROGN (COND ((OR PRESERVE-WHITESPACE (NEQ SNX SEPRCHAR.RC)) (* ; "At top-level, put back the terminating character if preserving whitespace or terminator is significant") (replace (STREAM LASTCCODE) of STREAM with (OR LASTC CH 65535)) (* ; "And LASTC will return the last REAL char read.") (\BACKNSCHAR STREAM SHIFTEDCHARSET))) (RETURN ELT))) (if (EQ SNX SEPRCHAR.RC) then (* ; "Terminated with sepr, go on to next char") (GO NEWTOKEN) elseif (EQ CH CHAR) then (* ; "read terminates here") (replace (STREAM LASTCCODE) of STREAM with CH) (RETURN LST) else (* ; "Terminated with break, jump into the break char code") (GO BREAK)) GOTPACKAGEDELIM (* ;; "Come here if CH is a package delimiter.  Note that we have already scanned at least one character of the token, so this must be an interior delim") (COND (*READ-SUPPRESS* (* ; "Don't care about packages")) ((AND (EQ J 0) (NULL EXTRASEGMENTS)) (* ;; "No chars accumulated, so must be 2 colons in a row.  Note that the case where we've just started scanning a token happens up at NEWTOKEN") (SETQ LASTC CH) (COND ((AND (EQ NCOLONS 1) (NEQ PACKAGE *KEYWORD-PACKAGE*)) (* ; "Two colons in a row means internal symbol") (SETQ NCOLONS 2)) (T (* ; "Error, e.g., `FOO:::BAZ' or `::BAR'") (SETQ INVALIDFLG T) (GO GOTATOMCHAR)))) ((NULL NCOLONS) (* ; "We have just scanned the package name") (SETQ NCOLONS 1) (SETQ LASTC CH) (SETQ PACKAGE (COND (EXTRASEGMENTS (LISPERROR "ATOM TOO LONG" (\SUBREADCONCAT EXTRASEGMENTS PBASE J)) (SETQ EXTRASEGMENTS NIL)) ((\FIND.PACKAGE.INTERNAL PBASE 0 J \FATPNAMESTRINGP)) (T (* ; "Error, but don't signal yet -- save name as string for benefit of error handlers") (\GETBASESTRING PBASE 0 J \FATPNAMESTRINGP)))) (SETQ J 0)) (T (* ; "Have alread seen one or more colons, and have scanned more symbol.  This colon is an error.") (SETQ LASTC CH) (SETQ INVALIDFLG T) (GO GOTATOMCHAR))) (SETQ ESCAPEFLG T) (* ; "Result MUST be a symbol now") (GO NEXTATOMCHAR) SINGLECHARATOM (* ;; "Come here to create a symbol whose single character is CH -- no package stuff to worry about.  This happens mainly for RATOM.  We create the single char atom in IL for backward compatibility.") (\PNAMESTRINGPUTCHAR PBASE 0 CH) (SETQ ELT (\READ.SYMBOL PBASE 0 1 \FATPNAMESTRINGP *INTERLISP-PACKAGE*)) (replace (STREAM LASTCCODE) of STREAM with CH) (\RDCONC ELT (RETURN ELT)) (GO NEWTOKEN) (* ;; "End of atom scanning code") BREAK (* ;; "At this point, we have just read a break character, stored in CH") (replace (STREAM LASTCCODE) of STREAM with CH) (SELECTC SNX (LEFTPAREN.RC (* ;; "recursively read a list.  If that list (or any of it's non-bracketed sublists) is terminated by a right bracket it terminates our read as well.  PROPRB macro worries about right-bracket propagation: if the subread encounters a right bracket (sets \RBFLG), PROPRB returns true.  In addition, if we were not called by a left-bracket (READTYPE = NOPROPRB.RT) it sets \RBFLG in caller, thereby propagating the bracket upward.") (COND ((PROG1 (PROPRB (SETQ ELT (\SUBREAD STREAM SA PROPRB.RT PNSTR CASEBASE))) (\RDCONC ELT (RETURN ELT))) (* ;; "PROG1 is true if the subread encountered a right bracket") (FIXDOT) (* ; "Fix dotted pair if necessary") (RETURN LST)))) (LEFTBRACKET.RC (* ;; "recursively read a list, terminated by either right paren or right bracket.  In this case, right bracket is not propagated upward--we continue reading elements after it.") (SETQ ELT (\SUBREAD STREAM SA NOPROPRB.RT PNSTR CASEBASE)) (\RDCONC ELT (RETURN ELT))) ((LIST RIGHTPAREN.RC RIGHTBRACKET.RC) (* ;; "Terminate one or more lists, return what we have accumulated so far.  In the case of Right bracket, if caller did not have the matching left bracket, we have to allow the bracket to close more than one list.") (RETURN (COND (TOPLEVELP (* ;; "Naked right paren/bracket returns NIL.  This is sort of bogus in common lisp, but changing it would be a significant change to Interlisp folks.") NIL) (CHAR (* ;; "call from READ-DELIMITED-LIST doesn't want to terminate this way.  Could read as NIL and not terminate, but seems best to error.") (CL:ERROR "Unmatched ~A encountered while reading to a ~A" (CL:CODE-CHAR CH) (CL:CODE-CHAR CHAR)) LST) (T (FIXDOT) (AND (EQ SNX RIGHTBRACKET.RC) (NEQ READTYPE NOPROPRB.RT) (SETQ \RBFLG T)) LST)))) (STRINGDELIM.RC (* ;; "Invoke string reader") (SETQ ELT (\RSTRING2 STREAM SA NIL PNSTR)) (\RDCONC ELT (RETURN ELT))) (COND ((OR (EQ SNX BREAKCHAR.RC) (NOT (fetch READMACROFLG of *READTABLE*))) (* ; "A breakchar or a disabled always macro") (GO SINGLECHARATOM)) (T (GO MACRO)))) (GO NEWTOKEN) MACRO (SELECTQ (fetch MACROTYPE of (SETQ SNX (\GETREADMACRODEF CH *READTABLE*))) (MACRO (COND ((PROG1 (PROPRB (SETQ ELT (RELEASERESOURCE \PNAMESTRING PNSTR (CL:MULTIPLE-VALUE-LIST (\APPLYREADMACRO STREAM SNX)))) (* ; "Ignore right-bracket if macro is called at top-level read")) (COND ((NULL ELT) (* ; "Macro returned zero values, read as nothing")) (T (SETQ ELT (CAR ELT)) (\RDCONC ELT (RETURN ELT))))) (FIXDOT) (* ; "Encountered right bracket if we get here -- return what we have") (RETURN LST)))) (INFIX (* ;; "We give macro TCONC list of what we've accumulated so far--it gets to modify it as it pleases and return it.  We continue from there.") (COND ((PROG1 (PROPRB (SETQ ELT (RELEASERESOURCE \PNAMESTRING PNSTR (\APPLYREADMACRO STREAM SNX (AND LST (CONS LST END)))))) (COND (TOPLEVELP (* ; "What does INFIX mean at top level??  See IRM") (COND ((AND (LISTP ELT) (CDR ELT)) (* ; "Result is in TCONC format, so it's returnable") (RETURN (COND ((EQ (CDR ELT) (CAR ELT)) (* ; "TCONC list of one element--return the element. This is how INFIX top level macro can return a non-list.  ") (CAAR ELT)) (T (CAR ELT))))))) (T (* ; "Reading sublist.  Take apart TCONC list and continue.") (SETQ LST (CAR ELT)) (SETQ END (CDR ELT))))) (FIXDOT) (* ; "Macro hit right bracket if we got to here") (RETURN LST)))) (SPLICE (* ;; "Macro returns arbitrary number of values to be spliced inline.") (RBCONTEXT (SETQ ELT (RELEASERESOURCE \PNAMESTRING PNSTR (\APPLYREADMACRO STREAM SNX)))) (* ; "Note: we don't care if there was terminating right-bracket") (* ; "Why? -bvm") (COND ((OR (NULL ELT) TOPLEVELP) (* ;; "On the 10, it actually returns ELT if it is a list and the next token is a closing paren or bracket.  Hard to see how to get that behavior--rmk") (GO NEWTOKEN)) ((NLISTP ELT) (* ; "The 10 throws initial non-lists away (What if LST/END aren't set?)") (SETQ ELT (AND LST (LIST (QUOTE %.) ELT))) (SETQ DOTLOC END))) (COND ((NOT *READ-SUPPRESS*) (COND (LST (RPLACD END ELT)) (T (SETQ LST ELT))) (SETQ END (LAST ELT)) (COND ((CDR END) (* ; "A dotted pair") (SETQ DOTLOC END) (RPLACD END (CONS (QUOTE %.) (SETQ END (CONS (CDR END)))))))))) (SHOULDNT)) (GO NEWTOKEN)))
-)
-
-(\SUBREADCONCAT
-(LAMBDA (EXTRASEGMENTS PBASE J) (* ; "Edited 16-Jan-87 15:08 by bvm:") (* ;; "Produces a string consisting of all the characters \SUBREAD has been buffering up into a token.  Last J chars are stored at PBASE.  EXTRASEGMENTS is a list of strings in reverse order in the case that more characters were scanned than the pname string accommodates.") (SETQ PBASE (\GETBASESTRING PBASE 0 J \FATPNAMESTRINGP)) (if EXTRASEGMENTS then (CONCATLIST (NCONC1 (REVERSE EXTRASEGMENTS) PBASE)) else PBASE))
-)
-
-(\READ.SYMBOL
-(LAMBDA (BASE OFFSET LEN FATP PACKAGE EXTERNALP NONNUMERICP) (* bvm%: " 3-Aug-86 15:25") (* ;;; "Read a number or symbol from the string defined by BASE OFFSET LEN FATP PACKAGE is NIL if no package was specified, a package object or a string if an unknown package was typed (causes error).  EXTERNALP is true if symbol was typed with one colon, which requires that the symbol exist and be external.  NONNUMERICP is true if we know the symbol is not a number, e.g., some characters in it were escaped.") (* ;;; "For now a dummy definition") (COND (PACKAGE (* ; "For debugging") (CONCAT PACKAGE (COND (EXTERNALP ":") (T "::")) (\GETBASESTRING BASE OFFSET LEN FATP))) (T (OR (AND (NOT NONNUMERICP) (\PARSE.NUMBER BASE OFFSET LEN FATP)) (\MKATOM BASE OFFSET LEN FATP T)))))
-)
-
-(\INVALID.SYMBOL
-(LAMBDA (BASE LEN NCOLONS PACKAGE EXTRASEGMENTS) (* ; "Edited 15-Jan-87 17:33 by bvm:") (* ;;; "Called when scanning a symbol that has more than 2 colons, or more than 1 non-consecutive colon.  If return from here, will read the symbol as though the extra colons were escaped.") (CL:CERROR "Treat the extra colon(s) as if they were escaped" "Invalid symbol syntax in %"~A%"" (CONCAT (if (AND PACKAGE (NEQ PACKAGE *KEYWORD-PACKAGE*)) then (if (STRINGP PACKAGE) then PACKAGE else (CL:PACKAGE-NAME PACKAGE)) else "") (SELECTQ NCOLONS (1 ":") (2 "::") "") (\SUBREADCONCAT EXTRASEGMENTS BASE LEN))))
-)
-
-(\APPLYREADMACRO
-(LAMBDA (STREAM MACDEF ANSCELL) (* bvm%: " 4-May-86 16:38") (* ; "INREADMACROP searches for this framename") (DECLARE (USEDFREE *READTABLE*)) (APPLY* (fetch MACROFN of MACDEF) STREAM *READTABLE* ANSCELL))
-)
-
-(INREADMACROP
-(LAMBDA NIL (* edited%: "26-MAY-79 00:12") (PROG (TEM (\READDEPTH -1)) (DECLARE (SPECVARS \READDEPTH)) (COND ((NULL (SETQ TEM (STKPOS (QUOTE \APPLYREADMACRO)))) (RETURN NIL))) (MAPDL (FUNCTION (LAMBDA (NM POS) (COND ((EQ NM (QUOTE \SUBREAD)) (SETQ \READDEPTH (ADD1 \READDEPTH)))))) TEM) (RELSTK TEM) (RETURN \READDEPTH)))
-)
-)
-
-
-
-(* ; "Read macro for '")
-
-(DEFINEQ
-
-(READQUOTE
-(LAMBDA (FILE) (* ; "Edited 19-Mar-87 16:10 by bvm:") (LIST (QUOTE QUOTE) (CL:READ FILE T NIL T))))
-)
-
-
-
-(* ; "# macro")
-
-(DEFINEQ
-
-(READVBAR
-(LAMBDA (STREAM RDTBL) (* bvm%: "14-May-86 17:31") (* ;;; "Read Interlisp's | macro.  Originally this char was just a sepr in FILERDTBL but was then extended in various hokey ways, because it was the only character plausibly available for redefinition.  Today it is extended still further to be Common Lisp # in all the cases not already taken by some other meaning") (SELCHARQ (PEEKCCODE STREAM) (%' (* ; "commonlisp defines #'X to mean (FUNCTION X), but here it's BQUOTE") (READCCODE STREAM) (READBQUOTE STREAM RDTBL)) ((%( { ^) (* ; "Used by HPRINT") (HREAD STREAM)) (%# (READCCODE STREAM) (* ; "|# = Common Lisp #") (READHASHMACRO STREAM RDTBL)) ((EOL TAB SPACE) (* ; "CR or tab, treat as separator") (CL:VALUES)) (PROGN (* ; "Everything else not already preempted by old-style | is interpreted as Common Lisp") (READHASHMACRO STREAM RDTBL))))
-)
-
-(READHASHMACRO
-(LAMBDA (STREAM RDTBL INDEX) (* amd "15-Oct-86 16:36") (* ;;; "Implements the standard # macro dispatch -- reads next character to find out what to do.  Can return zero values if we just want to skip something.") (LET ((READFN (COND ((fetch (READTABLEP COMMONLISP) of RDTBL) (* ;; "Kludge: if we have to recursively read something that will not end up as the resulting list structure, use the reader that passes thru CMLTRANSLATE") (FUNCTION CL:READ)) (T (FUNCTION READ)))) NEXTCHAR READVAL) (while (DIGITCHARP (SETQ NEXTCHAR (PEEKCCODE STREAM RDTBL))) do (SETQ INDEX (PLUS (TIMES (OR INDEX 0) 10) (DIFFERENCE (READCCODE STREAM RDTBL) (CHARCODE 0))))) (SELCHARQ NEXTCHAR ("(" (LET ((CONTENTS (APPLY* READFN STREAM))) (COND (INDEX (FILL-VECTOR (CL:MAKE-ARRAY INDEX) CONTENTS)) (T (CL:MAKE-ARRAY (LENGTH CONTENTS) :INITIAL-CONTENTS CONTENTS))))) (PROGN (* ; "Those cases we left the dispatching char in buffer for convenience of the next read.  Now eat it") (SELCHARQ (READCCODE STREAM RDTBL) (%' (LIST (QUOTE FUNCTION) (READ STREAM RDTBL))) (%. (EVAL (APPLY* READFN STREAM))) (%, (LIST (QUOTE LOADTIMECONSTANT) (READ STREAM RDTBL))) (\ (CHARACTER.READ STREAM)) ("*" (* ; "Read bit vector") (LET ((CONTENTS (while (MEMQ (PEEKCCODE STREAM RDTBL) (CHARCODE (0 1))) collect (IDIFFERENCE (READCCODE STREAM RDTBL) (CHARCODE 0))))) (COND (INDEX (FILL-VECTOR (CL:MAKE-ARRAY INDEX :ELEMENT-TYPE (QUOTE BIT)) CONTENTS)) (T (CL:MAKE-ARRAY (LENGTH CONTENTS) :INITIAL-CONTENTS CONTENTS :ELEMENT-TYPE (QUOTE BIT)))))) (":" (* ;; "The same thing HASH-COLON does.") (CL:MAKE-SYMBOL (READ-EXTENDED-TOKEN STREAM RDTBL))) ((O o) (READNUMBERINBASE STREAM 8)) ((B b) (READNUMBERINBASE STREAM 2)) ((X x) (READNUMBERINBASE STREAM 16)) ((R r) (READNUMBERINBASE STREAM INDEX)) ((A a) (LET ((CONTENTS (APPLY* READFN STREAM))) (CL:MAKE-ARRAY (ESTIMATE-DIMENSIONALITY INDEX CONTENTS) :INITIAL-CONTENTS CONTENTS))) ((S s) (CREATE-STRUCTURE (APPLY* READFN STREAM))) ((C c) (DESTRUCTURING-BIND (NUM DEN) (APPLY* READFN STREAM) (COMPLEX NUM DEN))) (+ (* ; "Skip expression if feature not present") (COND ((NOT (CMLREAD.FEATURE.PARSER (READ STREAM RDTBL))) (CL:READ STREAM RDTBL))) (CL:VALUES)) (- (* ; "Skip expression if feature IS present") (COND ((CMLREAD.FEATURE.PARSER (READ STREAM RDTBL)) (CL:READ STREAM RDTBL))) (CL:VALUES)) ("|" (* ; "special comment") (SKIP.HASH.COMMENT STREAM RDTBL) (CL:VALUES)) (< (ERROR "#< construct is un-READ-able" (READ))) ((SPACE TAB NEWLINE PAGE RETURN %)) (ERROR "Illegal read syntax " (CHARCODE.UNDECODE NEXTCHAR))) (%" (* ; "An extension -- read string without cr's and leading spaces") (RSTRING STREAM RDTBL (QUOTE SKIP))) (APPLY* (OR (GET (CHARACTER NEXTCHAR) (QUOTE HASHREADMACRO)) (ERROR "Undefined hashmacro char" NEXTCHAR)) STREAM RDTBL))))))
-)
-
-(DEFMACRO-LAMBDA-LIST-KEYWORD-P
-(LAMBDA (S) (* bvm%: " 3-Nov-86 15:12") (AND (FMEMB S (QUOTE (&OPTIONAL &REST &KEY &ALLOW-OTHER-KEYS &AUX &BODY &WHOLE))) T))
-)
-
-(DIGITBASEP
-(LAMBDA (CODE RADIX) (* lmm "11-Jun-85 00:54") (COND ((AND (GEQ CODE (CHARCODE 0)) (LESSP CODE (PLUS (CHARCODE 0) RADIX))) (DIFFERENCE CODE (CHARCODE 0))) ((GREATERP RADIX 10) (COND ((AND (GEQ CODE (CHARCODE a)) (LEQ CODE (CHARCODE z))) (add CODE (DIFFERENCE (CHARCODE A) (CHARCODE a))))) (COND ((AND (GEQ CODE (CHARCODE A)) (LEQ CODE (CHARCODE Z))) (SETQ CODE (PLUS 10 (DIFFERENCE CODE (CHARCODE A)))) (COND ((LESSP CODE RADIX) CODE)))))))
-)
-
-(READNUMBERINBASE
-(LAMBDA (STREAM RADIX) (* bvm%: " 4-Nov-86 21:34") (PROG ((BODY (READ-EXTENDED-TOKEN STREAM)) (I 1) CH VAL NUMERATOR SIGN BASE) (* ; "First check for leading sign") (if *READ-SUPPRESS* then (* ; "work is done") (RETURN NIL)) (SELCHARQ (SETQ CH (NTHCHARCODE BODY 1)) (+ (GO NEXTCH)) (- (SETQ SIGN T) (GO NEXTCH)) NIL) LP (if (SETQ BASE (DIGITBASEP CH RADIX)) then (SETQ VAL (+ (TIMES (OR VAL 0) RADIX) BASE)) elseif (EQ CH (CHARCODE "/")) then (* ; "Ratio marker") (if (OR NUMERATOR (NULL VAL)) then (GO MALFORMED)) (SETQ NUMERATOR VAL) (SETQ VAL NIL) else (* ; "Terminated by a character that is not a token delimiter") (GO MALFORMED)) NEXTCH (if (SETQ CH (NTHCHARCODE BODY (add I 1))) then (GO LP) else (* ; "end of token, fall thru")) DONE (if (NULL VAL) then (GO MALFORMED)) (if NUMERATOR then (SETQ VAL (%%/ NUMERATOR VAL))) (RETURN (if SIGN then (- VAL) else VAL)) MALFORMED (RETURN (CL:ERROR "Malformed base ~D rational ~S" RADIX BODY))))
-)
-
-(ESTIMATE-DIMENSIONALITY
-(LAMBDA (RANK CONTENTS) (* bvm%: " 9-May-86 16:06") (COND ((NULL RANK) (ERROR "No rank found while reading array" NIL)) ((EQ RANK 0) NIL) (T (to RANK as (D _ CONTENTS) by (CAR D) collect (LENGTH D)))))
-)
-
-(SKIP.HASH.COMMENT
-(LAMBDA (STREAM RDTBL) (* bvm%: "12-Sep-86 21:02") (PROG NIL (* ;; "a tiny fsm that recognizes #| ... |# with possible nestings of itself") LP (SELCHARQ (READCCODE STREAM RDTBL) ("#" (GO SHARP)) ("|" (GO VBAR)) (GO LP)) SHARP (SELCHARQ (READCCODE STREAM RDTBL) ("|" (* ; "#| -- recursively skip nested section") (SKIP.HASH.COMMENT STREAM RDTBL) (GO LP)) ("#" (GO SHARP)) (GO LP)) VBAR (SELCHARQ (READCCODE STREAM RDTBL) ("|" (GO VBAR)) ("#" (* ; "found closing |#") (RETURN)) (GO LP))))
-)
-
-(CMLREAD.FEATURE.PARSER
-(LAMBDA (EXPR) (* bvm%: " 3-Nov-86 15:07") (COND ((CL:CONSP EXPR) (SELECTQ (CAR EXPR) ((:AND AND) (EVERY (CDR EXPR) (FUNCTION CMLREAD.FEATURE.PARSER))) ((:OR OR) (SOME (CDR EXPR) (FUNCTION CMLREAD.FEATURE.PARSER))) ((:NOT NOT) (NOT (CMLREAD.FEATURE.PARSER (CADR EXPR)))) (ERROR "Bad feature expression" EXPR))) ((FMEMB EXPR *FEATURES*) T)))
-)
-)
-
-
-
-(* ; "Reading characters with #\")
-
-(DEFINEQ
-
-(CHARACTER.READ
-(LAMBDA (STREAM) (* bvm%: " 4-Nov-86 21:50") (* ;;; "Called by the #\ macro -- reads a character object consisting of the thing next named") (LET ((NEXTCHAR (READCCODE STREAM)) CH) (COND ((OR (NULL (SETQ CH (PEEKCCODE STREAM T))) (fetch STOPATOM of (\SYNCODE (fetch READSA of *READTABLE*) CH))) (* ; "Terminates next, so it's just this char") (CL:CODE-CHAR NEXTCHAR)) (*READ-SUPPRESS* (* ; "don't try to decode it, could be illegal") (READ-EXTENDED-TOKEN STREAM) NIL) (T (* ; "Read a whole name, up to the next break/sepr") (CL:CODE-CHAR (CHARCODE.DECODE (CONCAT (ALLOCSTRING 1 NEXTCHAR) (READ-EXTENDED-TOKEN STREAM))))))))
-)
-
-(CHARCODE.DECODE
-(LAMBDA (C NOERROR) (* ; "Edited 18-Feb-87 22:03 by bvm:") (DECLARE (GLOBALVARS CHARACTERNAMES CHARACTERSETNAMES)) (COND ((NOT C) NIL) ((LISTP C) (CONS (CHARCODE.DECODE (CAR C) NOERROR) (CHARCODE.DECODE (CDR C) NOERROR))) ((NOT (OR (ATOM C) (STRINGP C))) (AND (NOT NOERROR) (ERROR "BAD CHARACTER SPECIFICATION" C))) ((EQ (NCHARS C) 1) (CHCON1 C)) (T (SELCHARQ (CHCON1 C) (^ (AND (SETQ C (CHARCODE.DECODE (SUBSTRING C 2 -1) NOERROR)) (LOGAND C (LOGNOT 96)))) (%# (* ;; "We use IPLUS instead of LOGOR here because some people want ##char to read as Xerox Meta, i.e., 1,char") (AND (SETQ C (CHARCODE.DECODE (SUBSTRING C 2 -1) NOERROR)) (IPLUS C 128))) (LET ((STR (MKSTRING C))) (for X in CHARACTERNAMES when (STRING.EQUAL (CAR X) STR) do (RETURN (OR (NUMBERP (CADR X)) (CHARCODE.DECODE (CADR X) NOERROR))) finally (RETURN (LET ((POS (STRPOSL (QUOTE (%, - "." "|")) STR)) CH CSET) (* ; "In the form charset,char") (COND ((AND POS (SETQ CH (OR (CL:PARSE-INTEGER STR :START POS :RADIX 8 :JUNK-ALLOWED T) (CHARCODE.DECODE (SUBSTRING STR (ADD1 POS)) NOERROR))) (< CH 256) (>= CH 0)) (* ; "parsed the char part as an octal number or character spec") (if (AND (SETQ CSET (OR (CL:PARSE-INTEGER STR :END (SUB1 POS) :RADIX 8 :JUNK-ALLOWED T) (for PAIR in CHARACTERSETNAMES first (SETQ POS (SUBSTRING STR 1 (SUB1 POS))) when (STRING.EQUAL (CAR PAIR) POS) do (RETURN (CADR PAIR))))) (< CSET 256) (>= CSET 0)) then (* ; "parsed the charset part as an octal number or standard charset name") (LOGOR CH (LLSH CSET 8)) elseif (NOT NOERROR) then (ERROR "BAD CHARACTERSET SPECIFICATION" C))) ((NOT NOERROR) (ERROR "BAD CHARACTER SPECIFICATION" C)))))))))))
-)
-)
-
-(RPAQQ CHARACTERNAMES
-       (("Page" 12)
-        ("Form" 12)
-        ("FF" 12)
-        ("Rubout" 127)
-        ("Del" 127)
-        ("Null" 0)
-        ("Escape" 27)
-        ("Esc" 27)
-        ("Bell" 7)
-        ("Tab" 9)
-        ("Backspace" 8)
-        ("Bs" 8)
-        ("Newline" 13)
-        ("CR" 13)
-        ("EOL" 13)
-        ("Return" 13)
-        ("Tenexeol" 31)
-        ("Space" 32)
-        ("Sp" 32)
-        ("Linefeed" 10)
-        ("LF" 10)))
-
-(RPAQQ CHARACTERSETNAMES (("Greek" 38)
-                              ("Cyrillic" 39)
-                              ("Hira" 36)
-                              ("Hiragana" 36)
-                              ("Kata" 37)
-                              ("Katakana" 37)
-                              ("Kanji" 48)))
-(DECLARE%: DOEVAL@COMPILE DONTCOPY 
-
-(RPAQQ READTYPES (READ.RT RATOM.RT NOPROPRB.RT PROPRB.RT))
-(DECLARE%: EVAL@COMPILE 
-
-(RPAQQ READ.RT NIL)
-
-(RPAQQ RATOM.RT 1)
-
-(RPAQQ NOPROPRB.RT T)
-
-(RPAQQ PROPRB.RT 0)
-
-
-(CONSTANTS READ.RT RATOM.RT NOPROPRB.RT PROPRB.RT)
-)
-
-(DECLARE%: EVAL@COMPILE 
-
-(PUTPROPS .CALL.SUBREAD. MACRO ((STREAM EOF-SUPPRESS EOF-VALUE CHAR PRESERVE-WHITESPACE)
-                                        (WITH-RESOURCE (\PNAMESTRING)
-                                               (\SUBREAD (\GETSTREAM STREAM 'INPUT)
-                                                      (fetch (READTABLEP READSA) of 
-                                                                                          *READTABLE*
-                                                             )
-                                                      (COND
-                                                         (CHAR -1)
-                                                         (T READ.RT))
-                                                      \PNAMESTRING
-                                                      (AND (fetch (READTABLEP CASEINSENSITIVE)
-                                                              of *READTABLE*)
-                                                           (fetch (ARRAYP BASE) of 
-                                                                                       UPPERCASEARRAY
-                                                                  ))
-                                                      EOF-SUPPRESS EOF-VALUE CHAR PRESERVE-WHITESPACE
-                                                      ))))
-
-(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])
-
-(PUTPROPS RBCONTEXT MACRO ((X . Y)
-                                   ([LAMBDA (\RBFLG)
-                                      (DECLARE (SPECVARS \RBFLG))
-                                      (PROGN X . Y)
-                                      \RBFLG]
-                                    NIL)))
-
-(PUTPROPS PROPRB MACRO [(X . Y)                      (* ; 
-                                                           "Propagates the right-bracket flag")
-                                (AND (RBCONTEXT X . Y)
-                                     (OR (EQ READTYPE NOPROPRB.RT)
-                                         (SETQ \RBFLG T])
-
-(PUTPROPS \RDCONC MACRO [(ELT . TOPFORMS)
-
-                                 (* ;; "Add ELT to the accumulating list to be returned by \SUBREAD.  If at top level and no list accumulated, then run TOPFORMS")
-
-                                 (COND
-                                    [LST (RPLACD END (SETQ END (CONS ELT]
-                                    (TOPLEVELP . TOPFORMS)
-                                    ((NOT *READ-SUPPRESS*)   (* ; 
-                                  "Don't bother consing the result if it's going to be thrown away")
-                                     (SETQ END (SETQ LST (CONS ELT])
-)
-
-(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 
-
-(PUTPROPS \BACKCHAR MACRO (OPENLAMBDA (STREAM)       (* ; "Backs up over an NS character")
-                                         (\BACKNSCHAR STREAM (UNFOLD (ACCESS-CHARSET STREAM)
-                                                                    256))))
-
-(PUTPROPS \BACKNSCHAR MACRO [(ST SHIFTEDCHARSET COUNTERVAR)
-                                     (COND
-                                        ((\XCCSP ST)
-                                         (\BACKXCCSCHAR ST SHIFTEDCHARSET COUNTERVAR))
-                                        (T (COND
-                                              ['COUNTERVAR (SETQ COUNTERVAR
-                                                            (IDIFFERENCE COUNTERVAR
-                                                                   (CL:FUNCALL (ffetch
-                                                                                (STREAM BACKCHARFN)
-                                                                                  of ST)
-                                                                          ST T]
-                                              (T (CL:FUNCALL (ffetch (STREAM BACKCHARFN)
-                                                                of ST)
-                                                        ST NIL])
-
-(PUTPROPS \CHECKEOLC MACRO
-          (OPENLAMBDA
-           (CH EOLC STREAM PEEKBINFLG COUNTERVAR)
-
-           (* ;; "Subtracts number of bytes read from COUNTERVAR, which may be NIL.  In fact, should be NIL if PEEKBINFLG is T.")
-
-           (SELCHARQ CH
-                (CR (SELECTC EOLC
-                        (CR.EOLC (CHARCODE EOL))
-                        (CRLF.EOLC (COND
-                                      [PEEKBINFLG 
-
-                                 (* ;; "T from PEEKC, compile-time constant.  In this case, must leave the fileptr where it was, except for possibly advancing over character set shifts")
-
-                                             (COND
-                                                ([EQ (CHARCODE LF)
-                                                     (UNINTERRUPTABLY
-                                                         (\NSIN STREAM (UNFOLD (ACCESS-CHARSET STREAM
-                                                                                      )
-                                                                              256))
-
-                                 (* ;; "Read the NS CR.  We know that there aren't any font-shift characters in front of the CR, because they would have already been read by the \NSPEEK that got the CR character.  Since we are going to NS back the CR character, we don't need to update the counter variable")
-
-                                                         (PROG1 (\PEEKBIN STREAM T)
-
-                                 (* ;; "LF must be in next BYTE after NS CR, regardless of coding.  Character-set shifting bytes can't intervene.  Then we back up over the CR that was \NSINed above.")
-
-                                                             (\BACKNSCHAR STREAM)))]
-                                                 (CHARCODE EOL))
-                                                (T (CHARCODE CR]
-                                      ((EQ (CHARCODE LF)
-                                           (\PEEKBIN STREAM T))
-                                       (\BIN STREAM)
-                                       (AND 'COUNTERVAR (SETQ COUNTERVAR (SUB1 COUNTERVAR)))
-                                       (CHARCODE EOL))
-                                      (T (CHARCODE CR))))
-                        (CHARCODE CR)))
-                (LF (COND
-                       ((EQ EOLC LF.EOLC)
-                        (CHARCODE EOL))
-                       (T (CHARCODE LF))))
-                CH)))
-
-(PUTPROPS \INCHAR MACRO (OPENLAMBDA (STREAM COUNTERVAR)
-                                                             (* ; "returns a 16 bit character code")
-                                       (\CHECKEOLC (\NSIN STREAM (UNFOLD (ACCESS-CHARSET STREAM)
-                                                                        256)
-                                                          NIL COUNTERVAR)
-                                              (FFETCH EOLCONVENTION OF STREAM)
-                                              STREAM NIL COUNTERVAR)))
-
-(PUTPROPS \INCCODE MACRO (OPENLAMBDA (STREAM COUNTERVAR)
-                                                             (* ; "returns a 16 bit character code")
-                                        (\CHECKEOLC (\NSIN STREAM (UNFOLD (ACCESS-CHARSET STREAM)
-                                                                         256)
-                                                           NIL COUNTERVAR)
-                                               (ffetch EOLCONVENTION of STREAM)
-                                               STREAM NIL COUNTERVAR)))
-
-(PUTPROPS \PEEKCCODE MACRO (OPENLAMBDA (STREAM NOERROR)
-                                          (\CHECKEOLC (\NSPEEK STREAM (UNFOLD (ACCESS-CHARSET STREAM)
-                                                                             256)
-                                                             NIL NOERROR)
-                                                 (ffetch EOLCONVENTION of STREAM)
-                                                 STREAM T)))
-
-(PUTPROPS \NSIN MACRO [(ST SHIFTEDCSET SHIFTEDCSETVAR COUNTERVAR)
-
-(* ;;; "Dispatches to the appropriate character code decoder.  If you want to support a new character encoding format, you have to write a decoder and add it here.")
-
-                               (COND
-                                  ((\XCCSP ST)
-                                   (\XCCSIN ST SHIFTEDCSET SHIFTEDCSETVAR COUNTERVAR))
-                                  (T (COND
-                                        ('COUNTERVAR (CL:MULTIPLE-VALUE-BIND
-                                                      (CODE NUM)
-                                                      (CL:FUNCALL (ffetch (STREAM INCCODEFN)
-                                                                     of ST)
-                                                             ST T)
-                                                      (AND NUM (SETQ COUNTERVAR (IDIFFERENCE 
-                                                                                       COUNTERVAR NUM
-                                                                                       )))
-                                                      CODE))
-                                        (T (CL:FUNCALL (ffetch (STREAM INCCODEFN) of ST)
-                                                  ST NIL])
-
-(PUTPROPS \NSPEEK MACRO [(ST SHIFTEDCSET SHIFTEDCSETVAR NOERROR COUNTERVAR)
-
-(* ;;; "Dispatches to the appropriate character code decoder.  If you want to support a new character encoding format, you have to write a decoder and add it here.")
-
-                                 (COND
-                                    ((\XCCSP ST)
-                                     (\XCCSPEEK ST (UNFOLD (ACCESS-CHARSET ST)
-                                                          256)
-                                            NIL NOERROR))
-                                    (T (COND
-                                          ('COUNTERVAR (CL:MULTIPLE-VALUE-BIND
-                                                        (CODE NUM)
-                                                        (CL:FUNCALL (ffetch (STREAM PEEKCCODEFN)
-                                                                       of ST)
-                                                               ST NOERROR T)
-                                                        (AND NUM (SETQ COUNTERVAR (IDIFFERENCE 
-                                                                                         COUNTERVAR 
-                                                                                         NUM)))
-                                                        CODE))
-                                          (T (CL:FUNCALL (ffetch (STREAM PEEKCCODEFN)
-                                                            of ST)
-                                                    ST NOERROR NIL])
-
-(PUTPROPS NUMERIC-CHARSET MACRO (= . ACCESS-CHARSET))
-)
-
-(* "END EXPORTED DEFINITIONS")
-
-
-(DECLARE%: DOEVAL@COMPILE DONTCOPY
-
-(SPECVARS *READ-NEWLINE-SUPPRESS* \RefillBufferFn)
-)
-
-(DECLARE%: DOEVAL@COMPILE DONTCOPY
-
-(GLOBALVARS *KEYWORD-PACKAGE* *INTERLISP-PACKAGE*)
-)
-)
-
-
-
-(* ; "Support for various external formats")
-
-
-
-
-(* ; "JIS to XCCS conversion table.")
-
-
-(RPAQQ *JIS-TO-XCCS-CONV-NO-FONT-TABLE*
-       ((8484 . 8484)
-        (8485 . 8485)
-        (8497 . 9155)
-        (8798 . 61376)
-        (8802 . 8802)
-        (8805 . 64892)
-        (8806 . 64894)
-        (8820 . 9148)
-        (8821 . 9132)
-        (8822 . 213)
-        (8830 . 8830)
-        (10273 . 61189)
-        (10274 . 61188)
-        (10275 . 10275)
-        (10276 . 10276)
-        (10277 . 10277)
-        (10278 . 10278)
-        (10279 . 10279)
-        (10280 . 10280)
-        (10281 . 10281)
-        (10282 . 10282)
-        (10283 . 61414)
-        (10284 . 61410)
-        (10285 . 61409)
-        (10286 . 10286)
-        (10287 . 10287)
-        (10288 . 10288)
-        (10289 . 10289)
-        (10290 . 10290)
-        (10291 . 10291)
-        (10292 . 10292)
-        (10293 . 10293)
-        (10294 . 61411)
-        (10295 . 10295)
-        (10296 . 10296)
-        (10297 . 10297)
-        (10298 . 10298)
-        (10299 . 10299)
-        (10300 . 10300)
-        (10301 . 10301)
-        (10302 . 10302)
-        (10303 . 10303)
-        (10304 . 10304)))
-
-(RPAQQ *JIS-TO-XCCS-CODE-MAP*
-       ((1 (1 33 . 33)
-           (2 33 . 34)
-           (3 33 . 35)
-           (6 0 . 183)
-           (7 0 . 58)
-           (8 0 . 59)
-           (9 0 . 63)
-           (10 0 . 33)
-           (11 33 . 43)
-           (12 33 . 44)
-           (13 0 . 194)
-           (14 0 . 193)
-           (15 0 . 200)
-           (16 0 . 195)
-           (18 0 . 204)
-           (19 33 . 51)
-           (20 33 . 52)
-           (21 33 . 53)
-           (22 33 . 54)
-           (23 33 . 55)
-           (24 33 . 56)
-           (25 33 . 57)
-           (26 33 . 58)
-           (27 33 . 59)
-           (28 33 . 60)
-           (29 239 . 36)
-           (30 33 . 62)
-           (31 0 . 47)
-           (32 0 . 92)
-           (33 0 . 126)
-           (34 33 . 66)
-           (35 0 . 124)
-           (36 33 . 68)
-           (37 33 . 69)
-           (38 0 . 169)
-           (39 0 . 39)
-           (40 0 . 170)
-           (41 0 . 186)
-           (42 0 . 40)
-           (43 0 . 41)
-           (44 33 . 76)
-           (45 33 . 77)
-           (46 0 . 91)
-           (47 0 . 93)
-           (48 0 . 123)
-           (49 0 . 125)
-           (50 239 . 50)
-           (51 239 . 51)
-           (52 0 . 171)
-           (53 0 . 187)
-           (54 33 . 86)
-           (55 33 . 87)
-           (56 33 . 88)
-           (57 33 . 89)
-           (58 33 . 90)
-           (59 33 . 91)
-           (60 0 . 43)
-           (61 0 . 45)
-           (62 0 . 177)
-           (63 0 . 180)
-           (64 0 . 184)
-           (65 0 . 61)
-           (66 33 . 98)
-           (67 0 . 60)
-           (68 0 . 62)
-           (69 33 . 101)
-           (70 33 . 102)
-           (71 33 . 103)
-           (72 33 . 104)
-           (73 33 . 105)
-           (74 33 . 106)
-           (75 0 . 176)
-           (76 33 . 108)
-           (77 33 . 109)
-           (78 33 . 110)
-           (79 0 . 165)
-           (80 0 . 164)
-           (81 0 . 162)
-           (82 0 . 163)
-           (83 0 . 37)
-           (84 0 . 35)
-           (85 0 . 38)
-           (86 0 . 42)
-           (87 0 . 64)
-           (88 0 . 167)
-           (89 33 . 121)
-           (90 33 . 122)
-           (91 33 . 123)
-           (92 33 . 124)
-           (93 33 . 125)
-           (94 33 . 126))
-        (2 (1 34 . 33)
-           (2 34 . 34)
-           (3 34 . 35)
-           (4 34 . 36)
-           (5 34 . 37)
-           (6 34 . 38)
-           (7 34 . 39)
-           (8 34 . 40)
-           (9 34 . 41)
-           (10 0 . 174)
-           (11 0 . 172)
-           (12 0 . 173)
-           (13 0 . 175)
-           (14 34 . 46)
-           (26 239 . 74)
-           (27 239 . 76)
-           (28 239 . 89)
-           (29 239 . 88)
-           (30 239 . 91)
-           (31 239 . 90)
-           (32 239 . 87)
-           (33 239 . 86)
-           (42 239 . 182)
-           (43 239 . 183)
-           (44 239 . 106)
-           (45 239 . 79)
-           (46 239 . 78)
-           (47 239 . 181)
-           (48 239 . 180)
-           (60 239 . 108)
-           (61 239 . 112)
-           (63 239 . 186)
-           (64 239 . 185)
-           (65 239 . 114)
-           (67 239 . 66)
-           (68 239 . 67)
-           (71 239 . 113)
-           (72 239 . 111)
-           (73 239 . 117)
-           (74 34 . 106)
-           (82 241 . 40)
-           (83 239 . 65)
-           (87 239 . 48)
-           (88 239 . 49)
-           (89 0 . 176))
-        (6 (1 38 . 65)
-           (2 38 . 66)
-           (3 38 . 68)
-           (4 38 . 69)
-           (5 38 . 70)
-           (6 38 . 73)
-           (7 38 . 74)
-           (8 38 . 75)
-           (9 38 . 76)
-           (10 38 . 77)
-           (11 38 . 78)
-           (12 38 . 79)
-           (13 38 . 80)
-           (14 38 . 81)
-           (15 38 . 82)
-           (16 38 . 83)
-           (17 38 . 85)
-           (18 38 . 86)
-           (19 38 . 88)
-           (20 38 . 89)
-           (21 38 . 90)
-           (22 38 . 91)
-           (23 38 . 92)
-           (24 38 . 93)
-           (33 38 . 97)
-           (34 38 . 98)
-           (35 38 . 100)
-           (36 38 . 101)
-           (37 38 . 102)
-           (38 38 . 105)
-           (39 38 . 106)
-           (40 38 . 107)
-           (41 38 . 108)
-           (42 38 . 109)
-           (43 38 . 110)
-           (44 38 . 111)
-           (45 38 . 112)
-           (46 38 . 113)
-           (47 38 . 114)
-           (48 38 . 115)
-           (49 38 . 117)
-           (50 38 . 118)
-           (51 38 . 120)
-           (52 38 . 121)
-           (53 38 . 122)
-           (54 38 . 123)
-           (55 38 . 124)
-           (56 38 . 125))))
-
-(RPAQQ *HANKAKU-TO-ZENKAKU-CODE-MAP*
-       ((161 . 8483)
-        (162 . 8534)
-        (163 . 8535)
-        (164 . 8482)
-        (165 . 183)
-        (166 . 9586)
-        (167 . 9505)
-        (168 . 9507)
-        (169 . 9509)
-        (170 . 9511)
-        (171 . 9513)
-        (172 . 9571)
-        (173 . 9573)
-        (174 . 9575)
-        (175 . 9539)
-        (176 . 8508)
-        (177 . 9506)
-        (178 . 9508)
-        (179 . 9510)
-        (180 . 9512)
-        (181 . 9514)
-        (182 . 9515)
-        (183 . 9517)
-        (184 . 9519)
-        (185 . 9521)
-        (186 . 9523)
-        (187 . 9525)
-        (188 . 9527)
-        (189 . 9529)
-        (190 . 9531)
-        (191 . 9533)
-        (192 . 9535)
-        (193 . 9537)
-        (194 . 9540)
-        (195 . 9542)
-        (196 . 9544)
-        (197 . 9546)
-        (198 . 9547)
-        (199 . 9548)
-        (200 . 9549)
-        (201 . 9550)
-        (202 . 9551)
-        (203 . 9554)
-        (204 . 9557)
-        (205 . 9560)
-        (206 . 9563)
-        (207 . 9566)
-        (208 . 9567)
-        (209 . 9568)
-        (210 . 9569)
-        (211 . 9570)
-        (212 . 9572)
-        (213 . 9574)
-        (214 . 9576)
-        (215 . 9577)
-        (216 . 9578)
-        (217 . 9579)
-        (218 . 9580)
-        (219 . 9581)
-        (220 . 9583)
-        (221 . 9587)
-        (222 . 8491)
-        (223 . 8492)))
-(DECLARE%: DOEVAL@COMPILE DONTCOPY
-
-(GLOBALVARS *JIS-TO-XCCS-CONV-NO-FONT-TABLE* *JIS-TO-XCCS-CONV-TABLE-LIST* *JIS-TO-XCCS-CODE-MAP* 
-       *HANKAKU-TO-ZENKAKU-CODE-MAP* *JIS-1KU-TO-XCCS-CONV-TABLE* *JIS-2KU-TO-XCCS-CONV-TABLE* 
-       *JIS-6KU-TO-XCCS-CONV-TABLE* *XCCS-TO-JIS-CONV-TABLE* *HANKAKU-TO-ZENKAKU-CONV-TABLE* 
-       *ZENKAKU-TO-HANKAKU-CONV-TABLE*)
-)
-(DEFINEQ
-
-(\MAKE.JIS.TO.XCCS.CONV.TABLE
-(LAMBDA NIL (* ; "Edited 20-Feb-91 19:28 by nm") (* ;;; "The JIS codes which are not equivalent to XCCS reside in 1, 2, 3, 6, 8 and 84 KU.  In case of 3 and 84 KU, the corresponding XCCS is calicutated from JIS.  In case of 1,2 and 6 KU, we have to prepare conversion tables for each because the mapping between XCCS and JIS are random.  8 KU is treated specially because no displayable font is assigned for 8 KU in XCCS.  They are handled with *JIS-TO-XCCS-CONV-NO-FONT-TABLE*.") (* ;;; "Each conversion table is an byte array of size 188 (94 * 2).  94 is a largest number of TEN.  TEN is one origin.  Each JIS code is represented with two bytes in the table.  The first byte is a character set and the second byte is a character code in XCCS.  If both of the first byte and the second byte are 255, it means the JIS code is not defined for the entry.  If the first byte is 255 and the second byte is 0, it means a JIS code is defined for the entry and there is a XCCS code corresponding to the JIS code, but no displayable font is assigned for the code in XCCS.  In the last case, the real XCCS code is found in *JIS-TO-XCCS-CONV-NO-FONT-TABLE*.") (* ;;; "*HANKAKU-TO-ZENKAKU-CONV-TABLE* holds the mapping between JIS HANAKAKU-KANA code to XCCS.  XCCS does not support HANKAKU code.") (SETQ *JIS-1KU-TO-XCCS-CONV-TABLE* (ARRAY 188 (QUOTE BYTE) 255)) (SETQ *JIS-2KU-TO-XCCS-CONV-TABLE* (ARRAY 188 (QUOTE BYTE) 255)) (SETQ *JIS-6KU-TO-XCCS-CONV-TABLE* (ARRAY 188 (QUOTE BYTE) 255)) (SETQ *XCCS-TO-JIS-CONV-TABLE* (HASHARRAY 256)) (SETQ *HANKAKU-TO-ZENKAKU-CONV-TABLE* (HASHARRAY 64)) (SETQ *ZENKAKU-TO-HANKAKU-CONV-TABLE* (HASHARRAY 64)) (CL:DO ((TABLES (LIST *JIS-1KU-TO-XCCS-CONV-TABLE* *JIS-2KU-TO-XCCS-CONV-TABLE* *JIS-6KU-TO-XCCS-CONV-TABLE*) (CDR TABLES)) (KU (QUOTE (1 2 6)) (CDR KU)) CODEMAP) ((CL:ENDP TABLES)) (SETQ CODEMAP (CDR (ASSOC (CAR KU) *JIS-TO-XCCS-CODE-MAP*))) (for MAP in CODEMAP do (SETA (CAR TABLES) (IDIFFERENCE (UNFOLD (CAR MAP) 2) 1) (CADR MAP)) (SETA (CAR TABLES) (UNFOLD (CAR MAP) 2) (CDDR MAP)))) (bind KU TEN TABLE for ENTRY in *JIS-TO-XCCS-CONV-NO-FONT-TABLE* do (SETQ KU (IDIFFERENCE (FOLDLO (CAR ENTRY) 256) 32)) (SETQ TABLE (SELECTQ KU (1 *JIS-1KU-TO-XCCS-CONV-TABLE*) (2 *JIS-2KU-TO-XCCS-CONV-TABLE*) (6 *JIS-6KU-TO-XCCS-CONV-TABLE*) NIL)) (AND TABLE (SETA TABLE (UNFOLD (IDIFFERENCE (LOGAND 255 (CAR ENTRY)) 32) 2) 0))) (for MAP in *HANKAKU-TO-ZENKAKU-CODE-MAP* do (PUTHASH (CAR MAP) (CDR MAP) *HANKAKU-TO-ZENKAKU-CONV-TABLE*)) (for MAP in *HANKAKU-TO-ZENKAKU-CODE-MAP* do (PUTHASH (CDR MAP) (CAR MAP) *ZENKAKU-TO-HANKAKU-CONV-TABLE*)) (for MAP in (APPEND (for KU in *JIS-TO-XCCS-CODE-MAP* join (for TEN in (CDR KU) collect (BQUOTE ((\, (LOGOR (UNFOLD (CADR TEN) 256) (CDDR TEN))) \, (LOGOR (UNFOLD (IPLUS (CAR KU) 32) 256) (IPLUS (CAR TEN) 32)))))) *JIS-TO-XCCS-CONV-NO-FONT-TABLE*) do (PUTHASH (CAR MAP) (CDR MAP) *XCCS-TO-JIS-CONV-TABLE*)) (SETQ *JIS-TO-XCCS-CONV-TABLE-LIST* (BQUOTE ((33 \, *JIS-1KU-TO-XCCS-CONV-TABLE*) (34 \, *JIS-2KU-TO-XCCS-CONV-TABLE*) (38 \, *JIS-6KU-TO-XCCS-CONV-TABLE*)))))
-)
-)
-(DECLARE%: DONTEVAL@LOAD DOCOPY 
-
-(\MAKE.JIS.TO.XCCS.CONV.TABLE)
-)
-
-
-
-(* ; "JIS to XCCS converter")
-
-
-(RPAQ? *REPLACE-NO-FONT-CODE* T)
-
-(RPAQ? *DEFAULT-NOT-CONVERTED-FAT-CODE* 8739)
-(DECLARE%: DOEVAL@COMPILE DONTCOPY
-
-(GLOBALVARS *REPLACE-NO-FONT-CODE* *DEFAULT-NOT-CONVERTED-FAT-CODE*)
-)
-(DECLARE%: DOEVAL@COMPILE DONTCOPY 
-(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 
-
-(PUTPROPS \CONV.JIS.TO.XCCS MACRO [OPENLAMBDA (KU TEN)
-
-(* ;;; "Some character code is not equivalent between JIS and XCCS.  In such case, we have to convert the character to corresponding XCCS.")
-
-                                                 (COND
-                                                    ((\NOT.EQUIVALENT.TO.XCCS KU)
-                                                     (\DO.CONV.JIS.TO.XCCS KU TEN))
-                                                    (T (LOGOR (UNFOLD KU 256)
-                                                              TEN])
-
-(PUTPROPS \DO.CONV.JIS.TO.XCCS MACRO
-          [(KU TEN)
-
-(* ;;; " Convert a JIS code divided into KU (high 8 bit) and TEN (low 8 bit) to an corresponding XCCS code.")
-
-           (COND
-              ((\INVALID.TENP TEN)
-               *DEFAULT-NOT-CONVERTED-FAT-CODE*)
-              (T (SELECTQ KU
-                     ((33 34 38)                             (* ; "1, 2 and 6 KU")
-                          [LET* ((CONVTABLE (\EXTARACT.CONV.TABLE KU))
-                                 (SET (\EXTRACT.SET TEN CONVTABLE))
-                                 (CODE (\EXTRACT.CODE TEN CONVTABLE)))
-                                (COND
-                                   ((NEQ SET 255)
-                                    (LOGOR (UNFOLD SET 256)
-                                           CODE))
-                                   (T (COND
-                                         ((EQ CODE 255)      (* ; "Not defined in JIS.")
-                                          *DEFAULT-NOT-CONVERTED-FAT-CODE*)
-                                         (T                  (* ; 
-       "Defined in JIS but the displayable font is not assigned in the corresponding code in XCCS.")
-                                            (COND
-                                               (*REPLACE-NO-FONT-CODE* 
-                                                      *DEFAULT-NOT-CONVERTED-FAT-CODE*)
-                                               (T (\EXTRACT.NO.FONT.CODE (LOGOR (UNFOLD KU 256)
-                                                                                TEN])
-                     (35                                     (* ; "3 KU")
-                                                             (* ; 
-                                "Alpha numeric codes are all defined as single byte codes in XCCS.")
-                         TEN)
-                     (40                                     (* ; "8 KU")
-                         (COND
-                            [(< 0 TEN 33)
-                             (COND
-                                (*REPLACE-NO-FONT-CODE* *DEFAULT-NOT-CONVERTED-FAT-CODE*)
-                                (T (\EXTRACT.NO.FONT.CODE (LOGOR KU TEN]
-                            (T *DEFAULT-NOT-CONVERTED-FAT-CODE*)))
-                     (116                                    (* ; "84 KU")
-                          (COND
-                             ((< 0 TEN 5)
-                              (LOGOR 29952 TEN))
-                             (T *DEFAULT-NOT-CONVERTED-FAT-CODE*)))
-                     (117                                    (* ; "85 KU")
-                          (COND
-                             ((< 0 TEN 28)
-                              (LOGOR 29696 TEN))
-                             (T *DEFAULT-NOT-CONVERTED-FAT-CODE*)))
-                     *DEFAULT-NOT-CONVERTED-FAT-CODE*])
-)
-
-(* "END EXPORTED DEFINITIONS")
-
-)
-
-
-
-(* ; "XCCS to JIS converter")
-
-(DEFINEQ
-
-(CONVHANKAKU
-(LAMBDA ARGS (* ; "Edited  8-Feb-91 13:42 by nm") (PROG1 (STREAMPROP (ARG ARGS 1) :HTOZP) (AND (> ARGS 1) (STREAMPROP (ARG ARGS 1) :HTOZP (ARG ARGS 2)))))
-)
-)
-(DECLARE%: DOEVAL@COMPILE DONTCOPY 
-(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 
-
-(PUTPROPS \CONV.XCCS.TO.JIS MACRO (OPENLAMBDA (OUTSTREAM CC)
-
-(* ;;; "Returns JIS code corresponding to XCCS charcode.  Handle HANKAKU as well as ZENKAKU.  If OUTSTREAM wants to convert ZENKAKUKANA to HANKAKUKANA, do so.  Never returns two byte charcode for alpha-numeric character, they are all treated as single byte characode.")
-
-                                                 (OR (COND
-                                                        ((\ASCIIP CC)
-                                                         CC)
-                                                        ((\NOT.EQUIVALENT.TO.JIS CC)
-                                                         (\DO.CONV.XCCS.TO.JIS CC))
-                                                        ((\CONV.HANKAKU.TO.ZENKAKUP OUTSTREAM)
-                                                             (* ; 
-                          "ZENKAKUKANA comes here, because their charcodes are equiavalent to JIS.")
-                                                         (\CONV.ZENKAKU.KANA CC))
-                                                        (T CC))
-                                                     CC)))
-
-(PUTPROPS \DO.CONV.XCCS.TO.JIS MACRO ((CC)
-                                              (GETHASH CC *XCCS-TO-JIS-CONV-TABLE*)))
-
-(PUTPROPS \ASCIIP MACRO (OPENLAMBDA (CC)
-                                       (AND (EQ (FOLDLO CC 256)
-                                                0)
-                                            (< (LOGAND CC 255)
-                                               128))))
-
-(PUTPROPS \NOT.EQUIVALENT.TO.JIS MACRO (OPENLAMBDA (CC)
-                                                      (OR (EQ (FOLDLO CC 256)
-                                                              0)
-                                                          (EQ (FOLDLO CC 256)
-                                                              33)
-                                                          (EQ (FOLDLO CC 256)
-                                                              34)
-                                                          (EQ (FOLDLO CC 256)
-                                                              38)
-                                                          (EQ (FOLDLO CC 256)
-                                                              40)
-                                                          (EQ (FOLDLO CC 256)
-                                                              239)
-                                                          (EQ (FOLDLO CC 256)
-                                                              241))))
-
-(PUTPROPS \CONV.HANKAKU.TO.ZENKAKUP MACRO ((OUTSTREAM)
-                                                   (STREAMPROP OUTSTREAM :HTOZP)))
-
-(PUTPROPS \CONV.ZENKAKU.KANA MACRO ((CHAR)
-                                            (GETHASH CHAR *ZENKAKU-TO-HANKAKU-CONV-TABLE*)))
-)
-
-(* "END EXPORTED DEFINITIONS")
-
-)
-(DEFINEQ
-
-(\JISIN
-(LAMBDA (STREAM COUNTP) (* ; "Edited 25-Feb-91 15:47 by nm") (* ;;; "Returns a 16 bit XCCS code.  Assuming the input character stream is encoded with JIS.  Allows the incorrect usage of KI and KO based on the two different JIS, OLDJIS and NEWJIS, because it is very likely that these two different sets of KI and KO are used simultaneously, although it is against a standard!  ") (* ;;; "If COUNP is non-NIL, the number of bytes read is returned as a second value.  Doesn't do EOL conversion -- \INCHAR or \INCCODE do that.") (PROG (CH1 CH2 CH3 (IN16BITFLG (\KIMODEP STREAM T)) (CHARNUM 0)) RETRY (AND (SETQ CH1 (\BIN STREAM)) (COND ((EQ CH1 (CHARCODE ESC)) (* ; "Might be KI or KO.") (SETQ CH2 (\BIN STREAM)) (COND ((EQ CH2 (CHARCODE $)) (* ; "Might be KI") (SETQ CH3 (\BIN STREAM)) (COND ((OR (EQ CH3 (CHARCODE B)) (EQ CH3 (CHARCODE @))) (* ; "KI") (\CHNAGE.KI.MODE STREAM T T) (AND COUNTP (SETQ CHARNUM (IPLUS CHARNUM 3))) (* ; "Here we have to try the same preocedure again, because bogus duplicated KI/KO sequence might come again!") (SETQ IN16BITFLG T) (GO RETRY)) (T (COND (IN16BITFLG (* ; "Under processing 16 bit code.") (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) (IPLUS 2 CHARNUM)))) (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2))))) (T (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES (CHARCODE ESC) (IPLUS 1 CHARNUM)))) (T (RETURN (CHARCODE ESC))))))))) ((EQ CH2 (CHARCODE %()) (* ; "Might be KO") (SETQ CH3 (\BIN STREAM)) (COND ((OR (EQ CH3 (CHARCODE J)) (EQ CH3 (CHARCODE H))) (* ; "KO") (\CHNAGE.KI.MODE STREAM T NIL) (AND COUNTP (SETQ CHARNUM (IPLUS CHARNUM 3))) (* ; "Oops.  Yes, we have to try again to ignore duplicated KI/KO sequence.") (SETQ IN16BITFLG NIL) (GO RETRY)) (T (COND (IN16BITFLG (* ; "Under processing 16 bit code.") (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) (IPLUS 2 CHARNUM)))) (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2))))) (T (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES (CHARCODE ESC) (IPLUS 1 CHARNUM)))) (T (RETURN (CHARCODE ESC))))))))) (IN16BITFLG (* ; "Under processing 16 bit code.") (COND (COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) (IPLUS 2 CHARNUM)))) (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2))))) (T (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES (CHARCODE ESC) (IPLUS 1 CHARNUM)))) (T (RETURN (CHARCODE ESC))))))) (IN16BITFLG (* ; "Under processing 16 bit code.") (COND (COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS CH1 (\BIN STREAM)) (IPLUS 2 CHARNUM)))) (T (RETURN (\CONV.JIS.TO.XCCS CH1 (\BIN STREAM)))))) ((\HANKAKUP CH1) (* ; "HANKAKU-KATAKANA is converted to ZENKAKU-KATAKANA because XCCS does not support HANKAKU-KATAKANA.") (COND (COUNTP (RETURN (CL:VALUES (\CONV.HANKAKU.KANA CH1) (IPLUS 1 CHARNUM)))) (T (RETURN (\CONV.HANKAKU.KANA CH1))))) (T (* ;; "C0, SP, DEL, C1, 10/0, or 15/15 of 0 character set.") (COND (COUNTP (RETURN (CL:VALUES CH1 (IPLUS 1 CHARNUM)))) (T (RETURN CH1))))))))
-)
-
-(\JISPEEK
-(LAMBDA (STREAM NOERROR COUNTP) (* ; "Edited 25-Feb-91 16:27 by nm") (* ;;; "Returns a 16 bit XCCS code.  Assuming the input character stream is encoded with JIS.  Allows the incorrect usage of KI and KO based on the two different JIS, OLDJIS and NEWJIS, because it is very likely that these two different sets of KI and KO are used simultaneously, although it is against a standard!  May actually read the KI or KO.  ") (* ;;; "If COUNTP is non-NIL, the number of bytes read is returned as a second value.  Doesn't do EOL conversion -- \INCHAR or \INCCODE do that.") (PROG ((IN16BITFLG (\KIMODEP STREAM T)) (CHARNUM 0) (CH1 (\PEEKBIN STREAM NOERROR)) CH2 CH3) RETRY (COND ((NULL CH1) (COND (COUNTP (RETURN (CL:VALUES NIL CHARNUM))) (T (RETURN NIL)))) ((EQ CH1 (CHARCODE ESC)) (* ; "Might be KI or KO.") (\BIN STREAM) (* ; "Consume the first ESC.") (SETQ CH2 (\PEEKBIN STREAM NOERROR)) (COND ((NULL CH2) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES NIL CHARNUM))) (T (RETURN NIL)))) ((EQ CH2 (CHARCODE $)) (* ; "Might be KI") (\BIN STREAM) (* ; "Consume the $.") (SETQ CH3 (\PEEKBIN STREAM NOERROR)) (COND ((NULL CH3) (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES NIL CHARNUM))) (T (RETURN NIL)))) ((OR (EQ CH3 (CHARCODE B)) (EQ CH3 (CHARCODE @))) (* ; "KI") (\CHNAGE.KI.MODE STREAM T T) (AND COUNTP (SETQ CHARNUM (IPLUS CHARNUM 3))) (\BIN STREAM) (* ; "Consume the B or @.") (SETQ IN16BITFLG T) (GO RETRY)) (T (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (COND (IN16BITFLG (* ; "Under processing 16 bit code.") (COND (COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) CHARNUM))) (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2))))) (T (COND (COUNTP (RETURN (CL:VALUES (CHARCODE ESC) CHARNUM))) (T (RETURN (CHARCODE ESC))))))))) ((EQ CH2 (CHARCODE %()) (* ; "Might be KO") (\BIN STREAM) (* ; "Consume the (.") (SETQ CH3 (\PEEKBIN STREAM NOERROR)) (COND ((NULL CH3) (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES NIL CHARNUM))) (T (RETURN NIL)))) ((OR (EQ CH3 (CHARCODE J)) (EQ CH3 (CHARCODE H))) (* ; "KO") (\CHNAGE.KI.MODE STREAM T NIL) (AND COUNTP (SETQ CHARNUM 3)) (\BIN STREAM) (* ; "Consume the J or H.") (SETQ IN16BITFLG NIL) (GO RETRY)) (T (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (COND (IN16BITFLG (* ; "Under processing 16 bit code.") (COND (COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) CHARNUM))) (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2))))) (T (COND (COUNTP (RETURN (CL:VALUES (CHARCODE ESC) CHARNUM))) (T (RETURN (CHARCODE ESC))))))))) (IN16BITFLG (* ; "Under processing 16 bit code.") (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) CHARNUM))) (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2))))) (T (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES (CHARCODE ESC) CHARNUM))) (T (RETURN (CHARCODE ESC))))))) (IN16BITFLG (* ; "Under processing 16 bit code.") (\BIN STREAM) (* ; "Consume the first byte.") (SETQ CH2 (\PEEKBIN STREAM NOERROR)) (\BACKFILEPTR STREAM) (COND (CH2 (COND (COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) CHARNUM))) (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2))))) (T (COND (COUNTP (RETURN (CL:VALUES NIL CHARNUM))) (T (RETURN NIL)))))) ((\HANKAKUP CH1) (* ; "HANKAKU-KATAKANA is converted to ZENKAKU-KATAKANA because XCCS does not support HANKAKU-KATAKANA.") (COND (COUNTP (RETURN (CL:VALUES (\CONV.HANKAKU.KANA CH1) CHARNUM))) (T (RETURN (\CONV.HANKAKU.KANA CH1))))) (T (* ;; "C0, SP, DEL, C1, 10/0, or 15/15 of 0 character set.") (COND (COUNTP (RETURN (CL:VALUES CH1 CHARNUM))) (T (RETURN CH1)))))))
-)
-
-(\BACKJISCHAR
-(LAMBDA (STREAM COUNTP) (* ; "Edited 25-Feb-91 17:05 by nm") (COND ((\BACKFILEPTR STREAM) (COND ((\KIMODEP STREAM T) (COND ((\BACKFILEPTR STREAM) (AND COUNTP 2)) (T (AND COUNTP 1)))) (COUNTP 1))) (COUNTP 0)))
-)
-
-(\SHIFTJISIN
-(LAMBDA (STREAM COUNTP) (* ; "Edited 25-Feb-91 15:49 by nm") (* ;;; "Returns a 16 bit XCCS code.  Assuming the input character stream is encoded with Shift-JIS.  If COUNP is non-NIL, the number of bytes read is returned as a second value.  Doesn't do EOL conversion -- \INCHAR or \INCCODE do that..") (LET ((CH1 (\BIN STREAM)) CH2) (AND CH1 (COND ((\SJIS.KANJI.FIRST.BYTEP CH1) (* ; "Read next byte and compose a kanji character.") (\CONV.SJIS.TO.JIS CH1 (\BIN STREAM)) (* ; "CH1 and CH2 is adjusted to represent JIS code in \CONV.SJIS.TO.JIS.") (COND (COUNTP (CL:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) 2)) (T (\CONV.JIS.TO.XCCS CH1 CH2)))) (T (* ; "ASCII or HANKAKU-KATAKANA") (COND ((\HANKAKUP CH1) (* ; "HANKAKU-KATAKANA") (COND (COUNTP (CL:VALUES (\CONV.HANKAKU.KANA CH1) 1)) (T (\CONV.HANKAKU.KANA CH1)))) (T (* ; "ASCII") (COND (COUNTP (CL:VALUES CH1 1)) (T CH1)))))))))
-)
-
-(\SHIFTJISPEEK
-(LAMBDA (STREAM NOERROR COUNTP) (* ; "Edited 25-Feb-91 16:30 by nm") (* ;;; "Returns a 16 bit XCCS code.  Assuming the input character stream is encoded with Shift-JIS. Doesn't do EOL conversion -- \INCHAR or \INCCODE do that.") (PROG ((CH1 (\PEEKBIN STREAM NOERROR)) CH2) (COND ((NULL CH1) (COND (COUNTP (RETURN (CL:VALUES NIL 0))) (T (RETURN NIL)))) ((\SJIS.KANJI.FIRST.BYTEP CH1) (* ; "Read next byte and compose a kanji character.") (\BIN STREAM) (* ; "Consume the first byte.") (COND ((NULL (SETQ CH2 (\PEEKBIN STREAM NOERROR))) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES NIL 0))) (T (RETURN NIL))))) (\BACKFILEPTR STREAM) (\CONV.SJIS.TO.JIS CH1 CH2) (* ; "CH1 and CH2 is adjusted to represent JIS code in \CONV.SJIS.TO.JIS.") (COND (COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) 0))) (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2))))) (T (* ; "ASCII or HANKAKU-KATAKANA") (RETURN (COND ((\HANKAKUP CH1) (* ; "HANKAKU-KATAKANA") (COND (COUNTP (RETURN (CL:VALUES (\CONV.HANKAKU.KANA CH1) 0))) (T (RETURN (\CONV.HANKAKU.KANA CH1))))) (T (* ; "ASCII") (COND (COUNTP (RETURN (CL:VALUES CH1 0))) (T (RETURN CH1))))))))))
-)
-
-(\BACKSHIFTJISCHAR
-(LAMBDA (STREAM COUNTP) (* ; "Edited 25-Feb-91 17:05 by nm") (COND ((\BACKFILEPTR STREAM) (COND ((\BACKFILEPTR STREAM) (COND ((\SJIS.KANJI.FIRST.BYTEP (\PEEKBIN STREAM)) (AND COUNTP 2)) (T (\BIN STREAM) (AND COUNTP 1)))) (COUNTP 1))) (COUNTP 0)))
-)
-
-(\EUCIN
-(LAMBDA (STREAM COUNTP) (* ; "Edited 25-Feb-91 15:54 by nm") (* ;;; "Returns a 16 bit XCCS code.  Assuming the input character stream is encoded with EUC (Extended Unix Codes).  Although EUC is independent of a particular language, the language implemented here is Japanese, thus this should be called as UJIS (Unixnized extended JIS code).  JEIDA uses EUC as UJIS.  ") (* ;;; "If COUNP is non-NIL, the number of bytes read is returned as a second value.  Doesn't do EOL conversion -- \INCHAR or \INCCODE do that.") (LET ((CH1 (\BIN STREAM)) CH2) (AND CH1 (COND ((\EUC.KANJI.FIRST.BYTEP CH1) (* ; "Read next byte and compose a kanji character.") (COND (COUNTP (CL:VALUES (\CONV.JIS.TO.XCCS (LOGAND CH1 127) (LOGAND (\BIN STREAM) 127)) 2)) (T (\CONV.JIS.TO.XCCS (LOGAND CH1 127) (LOGAND (\BIN STREAM) 127))))) ((\EUC.HANKAKUP CH1) (COND (COUNTP (CL:VALUES (\CONV.HANKAKU.KANA (\BIN STREAM)) 2)) (T (\CONV.HANKAKU.KANA (\BIN STREAM))))) ((\GAIJIP CH1) (COND (COUNTP (CL:VALUES (\CONV.JIS.TO.XCCS (LOGAND (\BIN STREAM) 127) (LOGAND (\BIN STREAM) 127)) 3)) (T (\CONV.JIS.TO.XCCS (LOGAND (\BIN STREAM) 127) (LOGAND (\BIN STREAM) 127))))) (T (* ; "ASCII, C0, C1, SP or DEL") (COND (COUNTP (CL:VALUES CH1 1)) (T CH1)))))))
-)
-
-(\EUCPEEK
-(LAMBDA (STREAM NOERROR COUNTP) (* ; "Edited 25-Feb-91 16:35 by nm") (* ;;; "Returns a 16 bit XCCS code.  Assuming the input character stream is encoded with EUC (Extended Unix Codes).  Although EUC is independent of a particular language, the language implemented here is Japanese, thus this should be called as UJIS (Unixnized extended JIS code).  JEIDA uses EUC as UJIS. Doesn't do EOL conversion -- \INCHAR or \INCCODE do that.") (PROG ((CH1 (\PEEKBIN STREAM NOERROR)) CH2) (COND ((NULL CH1) (COND (COUNTP (RETURN (CL:VALUES NIL 0))) (T (RETURN NIL)))) ((\EUC.KANJI.FIRST.BYTEP CH1) (* ; "Read next byte and compose a kanji character.") (\BIN STREAM) (* ; "Consume the first byte.") (COND ((NULL (SETQ CH2 (\PEEKBIN STREAM NOERROR))) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES NIL 0))) (T (RETURN NIL))))) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS (LOGAND CH1 127) (LOGAND CH2 127)) 0))) (T (RETURN (\CONV.JIS.TO.XCCS (LOGAND CH1 127) (LOGAND CH2 127)))))) ((\EUC.HANKAKUP CH1) (\BIN STREAM) (* ; "Consume the SS2.") (COND ((NULL (SETQ CH2 (\PEEKBIN STREAM NOERROR))) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES NIL 0))) (T (RETURN NIL))))) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES (\CONV.HANKAKU.KANA CH2) 0))) (T (RETURN (\CONV.HANKAKU.KANA CH2))))) ((\GAIJIP CH1) (\BIN STREAM) (* ; "Consume the SS3.") (COND ((NULL (SETQ CH1 (\PEEKBIN STREAM NOERROR))) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES NIL 0))) (T (RETURN NIL))))) (\BIN STREAM) (* ; "Consume the first byte in GAIJI.") (COND ((NULL (SETQ CH2 (\PEEKBIN STREAM NOERROR))) (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES NIL 0))) (T (RETURN NIL))))) (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS (LOGAND CH1 127) (LOGAND CH2 127)) 0))) (T (RETURN (\CONV.JIS.TO.XCCS (LOGAND CH1 127) (LOGAND CH2 127)))))) (T (* ; "ASCII, C0, C1, SP or DEL") (COND (COUNTP (RETURN (CL:VALUES CH1 0))) (T (RETURN CH1)))))))
-)
-
-(\BACKEUCCHAR
-(LAMBDA (STREAM COUNTP) (* ; "Edited 25-Feb-91 17:06 by nm") (COND ((\BACKFILEPTR STREAM) (COND ((BITTEST (\PEEKBIN STREAM) (MASK.1'S 7 1)) (* ; "C1, KAINJI, HANKAKU or GAIJI") (COND ((\BACKFILEPTR STREAM) (COND ((\EUC.HANKAKUP (\PEEKBIN STREAM)) (AND COUNTP 2)) ((BITTEST (\PEEKBIN STREAM) (MASK.1'S 7 1)) (* ; "KANJI or GAIJI") (COND ((\BACKFILEPTR STREAM) (COND ((\GAIJIP (\PEEKBIN STREAM)) (AND COUNTP 3)) (T (* ; "KANJI") (\BIN STREAM) (AND COUNTP 2)))) (COUNTP 2))) (T (* ; "C1") (\BIN STREAM) (AND COUNTP 1)))) (COUNTP 1))) (COUNTP 1))) (COUNTP 0)))
-)
-
-(\THROUGHIN
-(LAMBDA (STREAM COUNTP) (* ; "Edited 26-Feb-91 13:36 by nm") (* ;;; "Read in a single byte from STREAM and returns it without any character conversion, just through as if.") (* ;;; "If COUNP is non-NIL, always 1 is returned as the second value.") (COND (COUNTP (CL:VALUES (\BIN STREAM) 1)) (T (\BIN STREAM))))
-)
-
-(\THROUGHPEEK
-(LAMBDA (STREAM NOERROR COUNTP) (* ; "Edited 26-Feb-91 13:40 by nm") (* ;;; "Returns a 8 bit code without any character conversion, just through as if.") (* ;;; "If COUNTP is non-NIL, always 0 is returned as its second value.") (COND (COUNTP (CL:VALUES (\PEEKBIN STREAM NOERROR) 0)) (T (\PEEKBIN STREAM NOERROR))))
-)
-
-(\BACKTHROUGHCHAR
-(LAMBDA (STREAM COUNTP) (* ; "Edited 26-Feb-91 13:43 by nm") (COND ((\BACKFILEPTR STREAM) 1) (COUNTP 0)))
-)
-)
-(DECLARE%: DOEVAL@COMPILE DONTCOPY 
-(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 
-
-(PUTPROPS \XCCSIN MACRO [(STREAM SHIFTEDCSET SHIFTEDCSETVAR COUNTERVAR)
-
-(* ;;; "returns a 16 bit character code.  SHIFTEDCSET is STREAM's char set left shifted 8, SHIFTEDCSETVAR if non-NIL is the variable to set if char set changes.  COUNTERVAR if non-NIL is decremented by number of bytes read.  Doesn't do EOL conversion -- \INCHAR and \INCCODE do that.")
-
-                                 (LET ((CHAR (\BIN STREAM))
-                                       SCSET)
-                                      (COND
-                                         [(EQ CHAR NSCHARSETSHIFT)
-                                                             (* ; "Shifting character sets")
-                                          [ACCESS-CHARSET STREAM
-                                                 (SETQ SCSET (COND
-                                                                ((NEQ NSCHARSETSHIFT (SETQ CHAR
-                                                                                      (\BIN STREAM)))
-                                                                 (AND 'COUNTERVAR (SETQ COUNTERVAR
-                                                                                   (IDIFFERENCE
-                                                                                    COUNTERVAR 2)))
-                                                                 CHAR)
-                                                                ((PROGN 
-                                                             (* ; 
-                                                           "2 shift-bytes means not run-encoded")
-                                                                        (AND 'COUNTERVAR
-                                                                             (SETQ COUNTERVAR
-                                                                              (IDIFFERENCE COUNTERVAR
-                                                                                     3)))
-                                                                        (EQ 0 (\BIN STREAM)))
-                                                                 \NORUNCODE)
-                                                                (T (\NSIN.24BITENCODING.ERROR
-                                                                    STREAM]
-                                          (SETQ CHAR (\BIN STREAM))
-                                          (SETQ SCSET (COND
-                                                         ('SHIFTEDCSETVAR 
-                                                             (* ; "CHARSETVAR=NIL means don't set")
-                                                                (SETQ SHIFTEDCSETVAR (UNFOLD SCSET 
-                                                                                            256)))
-                                                         (T (UNFOLD SCSET 256]
-                                         (T (SETQ SCSET SHIFTEDCSET)))
-                                      (COND
-                                         ((EQ SCSET (UNFOLD \NORUNCODE 256))
-                                                             (* ; 
-                                           "just read two bytes and combine them to a 16 bit value")
-                                          (AND 'COUNTERVAR (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR 2
-                                                                                   )))
-                                          (LOGOR (UNFOLD CHAR 256)
-                                                 (\BIN STREAM)))
-                                         (CHAR (AND 'COUNTERVAR (SETQ COUNTERVAR (IDIFFERENCE 
-                                                                                        COUNTERVAR 1)
-                                                                 ))
-                                               (AND CHAR (LOGOR SCSET CHAR])
-
-(PUTPROPS \XCCSPEEK MACRO [(STREAM SHIFTEDCSET SHIFTEDCSETVAR NOERROR COUNTERVAR)
-
-                                 (* ;; "Returns a 16 bit character code.  Doesn't do EOL conversion--\INCHAR does that.  May actually read the character-set shift, storing the result in the stream.  COUNTERVAR, if given, is updated to reflect any such bytes that are actually read")
-
-                                   (PROG ((CHAR (\PEEKBIN STREAM NOERROR))
-                                          SCSET)
-                                         (COND
-                                            ((NULL CHAR)
-                                             (RETURN NIL))
-                                            [(EQ CHAR NSCHARSETSHIFT)
-                                                             (* ; "CHARSETVAR=NIL means don't set")
-                                             (\BIN STREAM)   (* ; "Consume the char shift byte")
-                                             [ACCESS-CHARSET STREAM
-                                                    (SETQ SCSET (COND
-                                                                   ((NEQ NSCHARSETSHIFT
-                                                                         (SETQ CHAR (\BIN STREAM)))
-                                                             (* ; 
-     "Note: no eof error check on this \BIN -- an eof in the middle of a charset shift is an error")
-                                                                    (AND 'COUNTERVAR
-                                                                         (SETQ COUNTERVAR
-                                                                          (IDIFFERENCE COUNTERVAR 2))
-                                                                         )
-                                                                    CHAR)
-                                                                   ((PROGN 
-                                                             (* ; 
-                                                           "2 shift-bytes means not run-encoded")
-                                                                           (AND 'COUNTERVAR
-                                                                                (SETQ COUNTERVAR
-                                                                                 (IDIFFERENCE 
-                                                                                        COUNTERVAR 3)
-                                                                                 ))
-                                                                           (EQ 0 (\BIN STREAM)))
-                                                                    \NORUNCODE)
-                                                                   (T (\NSIN.24BITENCODING.ERROR
-                                                                       STREAM]
-                                             [SETQ SCSET (COND
-                                                            ('SHIFTEDCSETVAR 
-                                                             (* ; "CHARSETVAR=NIL means don't set")
-                                                                   (SETQ SHIFTEDCSETVAR
-                                                                    (UNFOLD SCSET 256)))
-                                                            (T (UNFOLD SCSET 256]
-                                             (COND
-                                                ((NULL (SETQ CHAR (\PEEKBIN STREAM NOERROR)))
-                                                 (RETURN NIL]
-                                            (T (SETQ SCSET SHIFTEDCSET)))
-                                         (RETURN (COND
-                                                    ((EQ SCSET (UNFOLD \NORUNCODE 256))
-
-                                              (* ;; "just peek two bytes and combine them to a 16 bit value.  Again, is an error if we hit eof in mid-character")
-
-                                                     (\BIN STREAM)
-                                                     (PROG1 (LOGOR (UNFOLD CHAR 256)
-                                                                   (\PEEKBIN STREAM NOERROR))
-                                                            (\BACKFILEPTR STREAM)))
-                                                    (T (LOGOR SHIFTEDCSET CHAR])
-
-(PUTPROPS \BACKXCCSCHAR MACRO [(STREAM SHIFTEDCHARSET COUNTERVAR)
-                                       (AND (\BACKFILEPTR STREAM)
-                                            (COND
-                                               [[COND
-                                                   (SHIFTEDCHARSET (EQ SHIFTEDCHARSET
-                                                                       (UNFOLD \NORUNCODE 256)))
-                                                   (T (EQ \NORUNCODE (ACCESS-CHARSET STREAM]
-                                                (COND
-                                                   ((\BACKFILEPTR STREAM)
-                                                    (AND 'COUNTERVAR (add COUNTERVAR 2))
-                                                    T)
-                                                   ('COUNTERVAR (add COUNTERVAR 1]
-                                               ('COUNTERVAR (add COUNTERVAR 1])
-
-(PUTPROPS \XCCSP MACRO [OPENLAMBDA (ST)
-                                      (NOT (ffetch (STREAM NOTXCCS) of (\DTEST ST
-                                                                                      'STREAM])
-)
-(DECLARE%: EVAL@COMPILE 
-
-(PUTPROPS \EXTRACT.NO.FONT.CODE MACRO ((JISCODE)
-                                               (CDR (ASSOC JISCODE *JIS-TO-XCCS-CONV-NO-FONT-TABLE*))
-                                               ))
-
-(PUTPROPS \EXTARACT.CONV.TABLE MACRO ((KU)
-                                              (CDR (ASSOC KU *JIS-TO-XCCS-CONV-TABLE-LIST*))))
-
-(PUTPROPS \NOT.EQUIVALENT.TO.XCCS MACRO ((KU)
-
-(* ;;; " The JIS codes which are not equiavelent to XCCS reside in 1, 2, 3, 6, 8 and 84 KU.  Although from 84-5 to 94-94 inclusive are not defined in JIS, that is they are GAIJI, they are also handled here.")
-
-                                                 (OR (EQ KU 33)
-                                                     (EQ KU 34)
-                                                     (EQ KU 35)
-                                                     (EQ KU 38)
-                                                     (EQ KU 40)
-                                                     (EQ KU 116)
-                                                     (EQ KU 117))))
-
-(PUTPROPS \EXTRACT.SET MACRO ((TEN TABLE)
-                                      (ELT TABLE (IDIFFERENCE (UNFOLD (IDIFFERENCE TEN 32)
-                                                                     2)
-                                                        1))))
-
-(PUTPROPS \EXTRACT.CODE MACRO ((TEN TABLE)
-                                       (ELT TABLE (UNFOLD (IDIFFERENCE TEN 32)
-                                                         2))))
-
-(PUTPROPS \CHNAGE.KI.MODE MACRO [OPENLAMBDA (ST INPUTFLG ENTERP)
-
-(* ;;; 
-"INPUTFLG is true if \CHNAGE.KI.MODE is called in the context in which ST is an input stream.")
-
-                                               (COND
-                                                  [INPUTFLG (COND
-                                                               (ENTERP (freplace (STREAM 
-                                                                                           IN.KANJIIN
-                                                                                            )
-                                                                          of (\DTEST ST
-                                                                                        'STREAM)
-                                                                          with T))
-                                                               (T (freplace (STREAM IN.KANJIIN)
-                                                                     of (\DTEST ST 'STREAM)
-                                                                     with NIL]
-                                                  (T (COND
-                                                        (ENTERP (freplace (STREAM OUT.KANJIIN)
-                                                                   of (\DTEST ST 'STREAM)
-                                                                   with T))
-                                                        (T (freplace (STREAM OUT.KANJIIN)
-                                                              of (\DTEST ST 'STREAM) with
-                                                                                         NIL])
-
-(PUTPROPS \KIMODEP MACRO [OPENLAMBDA (ST INPUTFLG)
-
-(* ;;; "INPUTFLG is true if \KIMODEP is called in the context in which ST is an input stream.")
-
-                                        (COND
-                                           [INPUTFLG (ffetch (STREAM IN.KANJIIN)
-                                                        of (\DTEST ST 'STREAM]
-                                           (T (ffetch (STREAM OUT.KANJIIN)
-                                                 of (\DTEST ST 'STREAM])
-
-(PUTPROPS \HANKAKUP MACRO ((CHAR)
-                                   (< 160 CHAR 224)))
-
-(PUTPROPS \KANJIP MACRO ((CHAR)
-                                 (< 12158 CHAR 29733)))
-
-(PUTPROPS \NOTGAIJIP MACRO ((CHAR)
-                                    (OR (< 8480 CHAR 10305)
-                                        (< 12158 CHAR 29733))))
-
-(PUTPROPS \INVALID.TENP MACRO (OPENLAMBDA (TEN)
-                                             (OR (< TEN 33)
-                                                 (< 126 TEN))))
-
-(PUTPROPS \CONV.HANKAKU.KANA MACRO ((CHAR)
-                                            (GETHASH CHAR *HANKAKU-TO-ZENKAKU-CONV-TABLE*)))
-
-(PUTPROPS \OUTKI MACRO ((STREAM)
-                                (\BOUT OUTSTREAM (CHARCODE ESC))
-                                (\BOUT OUTSTREAM (CHARCODE $))
-                                (\BOUT OUTSTREAM (CHARCODE B))))
-
-(PUTPROPS \OUTKO MACRO ((STREAM)
-                                (\BOUT OUTSTREAM (CHARCODE ESC))
-                                (\BOUT OUTSTREAM (CHARCODE %())
-                                (\BOUT OUTSTREAM (CHARCODE J))))
-)
-(DECLARE%: EVAL@COMPILE 
-
-(PUTPROPS \CONV.SJIS.TO.JIS MACRO [OPENLAMBDA (HI LO)
-
-(* ;;; "Convert Shift-JIS to JIS.  The variable named CH1 and CH2 are set to the converted hight 8 bit and low 8bit of JIS code respectively.")
-
-                                                 [SETQ CH1 (IDIFFERENCE HI (COND
-                                                                              ((> HI 159)
-                                                                               177)
-                                                                              (T 113]
-                                                 (SETQ CH1 (IPLUS (UNFOLD CH1 2)
-                                                                  1))
-                                                 (SETQ CH2 (COND
-                                                              [(> LO 158)
-                                                               (PROG1 (IDIFFERENCE LO 126)
-                                                                   (SETQ CH1 (IPLUS CH1 1)))]
-                                                              (T (IDIFFERENCE LO (COND
-                                                                                    ((> LO 126)
-                                                                                     (IPLUS 31 1))
-                                                                                    (T 31])
-
-(PUTPROPS \CONV.JIS.TO.SJIS MACRO [OPENLAMBDA (HI LO)
-
-(* ;;; "Convert JIS to Shift-JIS.  The variable named CH1 and CH2 are set to the converted hight 8 bit and low 8bit of Shift-JIS code respectively.")
-
-                                                 [SETQ CH2 (COND
-                                                              ((ODDP HI)
-                                                               (SETQ CH2 (IPLUS LO 31))
-                                                               (COND
-                                                                  ((>= CH2 127)
-                                                                   (IPLUS CH2 1))
-                                                                  (T CH2)))
-                                                              (T (IPLUS LO 126]
-                                                 (SETQ CH1 (IPLUS (FOLDLO (IDIFFERENCE HI 33)
-                                                                         2)
-                                                                  129))
-                                                 (AND (> CH1 159)
-                                                      (SETQ CH1 (IPLUS CH1 64])
-
-(PUTPROPS \SJIS.KANJI.FIRST.BYTEP MACRO (OPENLAMBDA (CHAR)
-                                                       (OR (< 127 CHAR 160)
-                                                           (< 223 CHAR 256))))
-)
-(DECLARE%: EVAL@COMPILE 
-
-(PUTPROPS \EUC.KANJI.FIRST.BYTEP MACRO ((CHAR)
-                                                (< 160 CHAR 255)))
-
-(PUTPROPS \GAIJIP MACRO ((CHAR)
-                                 (EQ CHAR 143)))
-
-(PUTPROPS \EUC.HANKAKUP MACRO ((CHAR)
-                                       (EQ CHAR 142)))
-)
-
-(* "END EXPORTED DEFINITIONS")
-
-)
-
-(RPAQ? *SIGNAL-24BIT-NSENCODING-ERROR* )
-
-(RPAQ? *READ-NEWLINE-SUPPRESS* )
-
-(RPAQ? \RefillBufferFn (FUNCTION \READCREFILL))
-
-
-
-(* ; 
-"Top level val of \RefillBufferFn means act like READC--we must be doing a raw BIN (or PEEKBIN?)")
-
-(DECLARE%: DOEVAL@COMPILE DONTCOPY
-
-(LOCALVARS . T)
-)
-(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
-
-(ADDTOVAR NLAMA )
-
-(ADDTOVAR NLAML )
-
-(ADDTOVAR LAMA CONVHANKAKU CL:PARSE-INTEGER CL:READ-DELIMITED-LIST CL:READ-PRESERVING-WHITESPACE
-                         CL:READ)
-)
-(PUTPROPS LLREAD COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1990 
-1991 1993))
-(DECLARE%: DONTCOPY
-  (FILEMAP (NIL (6621 14511 (LASTC 6631 . 7624) (PEEKC 7626 . 7931) (PEEKCCODE 7933 . 8156) (RATOM 8158
- . 8866) (READ 8868 . 9322) (READC 9324 . 9631) (READCCODE 9633 . 10049) (READP 10051 . 10385) (
-SETREADMACROFLG 10387 . 10543) (SKIPSEPRCODES 10545 . 11310) (SKIPSEPRS 11312 . 12004) (
-\NSIN.24BITENCODING.ERROR 12006 . 12581) (SKREAD 12583 . 14509)) (14557 22419 (CL:READ 14567 . 14898) 
-(CL:READ-PRESERVING-WHITESPACE 14900 . 15358) (CL:READ-DELIMITED-LIST 15360 . 16010) (CL:PARSE-INTEGER
- 16012 . 22417)) (22452 33124 (RSTRING 22462 . 23016) (READ-EXTENDED-TOKEN 23018 . 25433) (\RSTRING2 
-25435 . 33122)) (33160 51888 (\TOP-LEVEL-READ 33170 . 35157) (\SUBREAD 35159 . 49390) (\SUBREADCONCAT 
-49392 . 49904) (\READ.SYMBOL 49906 . 50695) (\INVALID.SYMBOL 50697 . 51314) (\APPLYREADMACRO 51316 . 
-51543) (INREADMACROP 51545 . 51886)) (51922 52048 (READQUOTE 51932 . 52046)) (52073 58440 (READVBAR 
-52083 . 52946) (READHASHMACRO 52948 . 55724) (DEFMACRO-LAMBDA-LIST-KEYWORD-P 55726 . 55889) (
-DIGITBASEP 55891 . 56349) (READNUMBERINBASE 56351 . 57319) (ESTIMATE-DIMENSIONALITY 57321 . 57553) (
-SKIP.HASH.COMMENT 57555 . 58066) (CMLREAD.FEATURE.PARSER 58068 . 58438)) (58484 60801 (CHARACTER.READ 
-58494 . 59139) (CHARCODE.DECODE 59141 . 60799)) (81086 84172 (\MAKE.JIS.TO.XCCS.CONV.TABLE 81096 . 
-84170)) (88113 88298 (CONVHANKAKU 88123 . 88296)) (91404 105185 (\JISIN 91414 . 94418) (\JISPEEK 94420
- . 97979) (\BACKJISCHAR 97981 . 98209) (\SHIFTJISIN 98211 . 99102) (\SHIFTJISPEEK 99104 . 100257) (
-\BACKSHIFTJISCHAR 100259 . 100530) (\EUCIN 100532 . 101761) (\EUCPEEK 101763 . 103809) (\BACKEUCCHAR 
-103811 . 104387) (\THROUGHIN 104389 . 104716) (\THROUGHPEEK 104718 . 105052) (\BACKTHROUGHCHAR 105054
- . 105183)))))
-STOP
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED " 4-Feb-2021 17:06:41" {DSK}<home>larry>ilisp>medley>sources>LLREAD.;5 167254 

      changes to%:  (VARS LLREADCOMS)
                    (FNS LASTC PEEKC PEEKCCODE RATOM READ READC READCCODE READP SETREADMACROFLG 
                         SKIPSEPRCODES SKIPSEPRS \NSIN.24BITENCODING.ERROR SKREAD CL:READ 
                         CL:READ-PRESERVING-WHITESPACE CL:READ-DELIMITED-LIST CL:PARSE-INTEGER 
                         RSTRING READ-EXTENDED-TOKEN \RSTRING2 \TOP-LEVEL-READ \SUBREAD 
                         \SUBREADCONCAT \READ.SYMBOL \INVALID.SYMBOL \APPLYREADMACRO INREADMACROP 
                         READQUOTE READVBAR READHASHMACRO DEFMACRO-LAMBDA-LIST-KEYWORD-P DIGITBASEP 
                         READNUMBERINBASE ESTIMATE-DIMENSIONALITY SKIP.HASH.COMMENT 
                         CMLREAD.FEATURE.PARSER CHARACTER.READ CHARCODE.DECODE 
                         \MAKE.JIS.TO.XCCS.CONV.TABLE CONVHANKAKU \JISIN \JISPEEK \BACKJISCHAR 
                         \SHIFTJISIN \SHIFTJISPEEK \BACKSHIFTJISCHAR \EUCIN \EUCPEEK \BACKEUCCHAR 
                         \THROUGHIN \THROUGHPEEK \BACKTHROUGHCHAR \ORIG-INVALID.SYMBOL)

      previous date%: " 4-Feb-2021 12:10:07" {DSK}<home>larry>ilisp>medley>sources>LLREAD.;4)


(* ; "
Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1993, 2021 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT LLREADCOMS)

(RPAQQ LLREADCOMS
       [(COMS                                                (* ; "Reader entrypoints")
              (FNS LASTC PEEKC PEEKCCODE RATOM READ READC READCCODE READP SETREADMACROFLG 
                   SKIPSEPRCODES SKIPSEPRS \NSIN.24BITENCODING.ERROR SKREAD))
        (COMS                                                (* ; "CommonLisp read entry points")
              (FNS CL:READ CL:READ-PRESERVING-WHITESPACE CL:READ-DELIMITED-LIST CL:PARSE-INTEGER)
              (GLOBALVARS CMLRDTBL))
        (COMS                                                (* ; "reading strings")
              (FNS RSTRING READ-EXTENDED-TOKEN \RSTRING2))
        [COMS                                                (* ; "Core of the reader")
              (FNS \TOP-LEVEL-READ \SUBREAD \SUBREADCONCAT \ORIG-READ.SYMBOL \ORIG-INVALID.SYMBOL 
                   \APPLYREADMACRO INREADMACROP)
              (DECLARE%: DONTEVAL@LOAD DOCOPY (P (MOVD? '\ORIG-READ.SYMBOL '\READ.SYMBOL)
                                                 (MOVD? '\ORIG-INVALID.SYMBOL '\INVALID.SYMBOL]
        (COMS                                                (* ; "Read macro for '")
              (FNS READQUOTE))
        (COMS                                                (* ; "# macro")
              (FNS READVBAR READHASHMACRO DEFMACRO-LAMBDA-LIST-KEYWORD-P DIGITBASEP READNUMBERINBASE
                   ESTIMATE-DIMENSIONALITY SKIP.HASH.COMMENT CMLREAD.FEATURE.PARSER))
        (COMS                                                (* ; "Reading characters with #\")
              (FNS CHARACTER.READ CHARCODE.DECODE)
              (VARS CHARACTERNAMES CHARACTERSETNAMES))
        (DECLARE%: DOEVAL@COMPILE DONTCOPY (CONSTANTS * READTYPES)
               (MACROS .CALL.SUBREAD. FIXDOT RBCONTEXT PROPRB \RDCONC)
               (EXPORT (MACROS \BACKCHAR \BACKNSCHAR \CHECKEOLC \INCHAR \INCCODE \PEEKCCODE \NSIN 
                              \NSPEEK NUMERIC-CHARSET))
               (SPECVARS *READ-NEWLINE-SUPPRESS* \RefillBufferFn)
               (GLOBALVARS *KEYWORD-PACKAGE* *INTERLISP-PACKAGE*))
        [COMS                                                (* ; 
                                                           "Support for various external formats")
              [COMS                                          (* ; "JIS to XCCS conversion table.")
                    (VARS *JIS-TO-XCCS-CONV-NO-FONT-TABLE* *JIS-TO-XCCS-CODE-MAP* 
                          *HANKAKU-TO-ZENKAKU-CODE-MAP*)
                    (GLOBALVARS *JIS-TO-XCCS-CONV-NO-FONT-TABLE* *JIS-TO-XCCS-CONV-TABLE-LIST* 
                           *JIS-TO-XCCS-CODE-MAP* *HANKAKU-TO-ZENKAKU-CODE-MAP* 
                           *JIS-1KU-TO-XCCS-CONV-TABLE* *JIS-2KU-TO-XCCS-CONV-TABLE* 
                           *JIS-6KU-TO-XCCS-CONV-TABLE* *XCCS-TO-JIS-CONV-TABLE* 
                           *HANKAKU-TO-ZENKAKU-CONV-TABLE* *ZENKAKU-TO-HANKAKU-CONV-TABLE*)
                    (FNS \MAKE.JIS.TO.XCCS.CONV.TABLE)
                    (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\MAKE.JIS.TO.XCCS.CONV.TABLE]
              [COMS                                          (* ; "JIS to XCCS converter")
                    (INITVARS (*REPLACE-NO-FONT-CODE* T)
                           (*DEFAULT-NOT-CONVERTED-FAT-CODE* 8739))
                    (GLOBALVARS *REPLACE-NO-FONT-CODE* *DEFAULT-NOT-CONVERTED-FAT-CODE*)
                    (DECLARE%: DOEVAL@COMPILE DONTCOPY (EXPORT (MACROS \CONV.JIS.TO.XCCS 
                                                                      \DO.CONV.JIS.TO.XCCS]
              [COMS                                          (* ; "XCCS to JIS converter")
                    (FNS CONVHANKAKU)
                    (DECLARE%: DOEVAL@COMPILE DONTCOPY (EXPORT (MACROS \CONV.XCCS.TO.JIS 
                                                                      \DO.CONV.XCCS.TO.JIS \ASCIIP 
                                                                      \NOT.EQUIVALENT.TO.JIS 
                                                                      \CONV.HANKAKU.TO.ZENKAKUP 
                                                                      \CONV.ZENKAKU.KANA]
              (COMS (FNS \JISIN \JISPEEK \BACKJISCHAR \SHIFTJISIN \SHIFTJISPEEK \BACKSHIFTJISCHAR 
                         \EUCIN \EUCPEEK \BACKEUCCHAR \THROUGHIN \THROUGHPEEK \BACKTHROUGHCHAR)
                    (DECLARE%: DOEVAL@COMPILE DONTCOPY
                           (EXPORT 

                                 (* ;; "XCCS specific macro.  Although the decoder and encoder are implemented as functions in general, only for XCCS, they are implemeted as macros for efficiency reason.")

                                  (MACROS \XCCSIN \XCCSPEEK \BACKXCCSCHAR \XCCSP)
                                  
                                  (* ;; "JIS specific macro")

                                  (MACROS \EXTRACT.NO.FONT.CODE \EXTARACT.CONV.TABLE 
                                         \NOT.EQUIVALENT.TO.XCCS \EXTRACT.SET \EXTRACT.CODE 
                                         \CHNAGE.KI.MODE \KIMODEP \HANKAKUP \KANJIP \NOTGAIJIP 
                                         \INVALID.TENP \CONV.HANKAKU.KANA \OUTKI \OUTKO)
                                  
                                  (* ;; "Shift-JIS specific macro")

                                  (MACROS \CONV.SJIS.TO.JIS \CONV.JIS.TO.SJIS \SJIS.KANJI.FIRST.BYTEP
                                         )
                                  
                                  (* ;; "EUC specific macro")

                                  (MACROS \EUC.KANJI.FIRST.BYTEP \GAIJIP \EUC.HANKAKUP]
        (INITVARS (*SIGNAL-24BIT-NSENCODING-ERROR*)
               (*READ-NEWLINE-SUPPRESS*)
               (\RefillBufferFn (FUNCTION \READCREFILL)))
                                                             (* ; 
  "Top level val of \RefillBufferFn means act like READC--we must be doing a raw BIN (or PEEKBIN?)")
        (LOCALVARS . T)
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
               (ADDVARS (NLAMA)
                      (NLAML)
                      (LAMA CONVHANKAKU CL:PARSE-INTEGER CL:READ-DELIMITED-LIST 
                            CL:READ-PRESERVING-WHITESPACE CL:READ])



(* ; "Reader entrypoints")

(DEFINEQ

(LASTC
  [LAMBDA (FILE)                                             (* ; "Edited  6-Jan-88 15:31 by jds")

    (* ;; "Be careful only to do BIN's if we first were able to back up, so that an EOF doesn't happen.  This is really an inadequate implementation, because it fails for files that cannot be backed up.  Eventually, we must change the character reading functions READ, RATOM, READC to save the last character they read in an STREAM field.")

    (LET* ((STREAM (\GETSTREAM FILE 'INPUT))
           (LASTCCODE (FETCH (STREAM LASTCCODE) OF STREAM)))

          (* ;; "(FCHARACTER (SELCHARQ C (CR (SELECTC (ffetch EOLCONVENTION of STREAM) (CR.EOLC (CHARCODE EOL)) C)) (LF (SELECTC (ffetch EOLCONVENTION of STREAM) (LF.EOLC (CHARCODE EOL)) (CRLF.EOLC (COND ((EQ (CHARCODE CR) (UNINTERRUPTABLY (AND (\BACKNSCHAR STREAM SHIFTEDCHARSET) (PROG1 (PROGN (\BACKNSCHAR STREAM SHIFTEDCHARSET) (\NSIN STREAM SHIFTEDCHARSET)) (\NSIN STREAM SHIFTEDCHARSET))))) (CHARCODE EOL)) (T C))) C)) (NIL 0) C))")

          (COND
             ((IEQP LASTCCODE 65535)
              NIL)
             (T (FCHARACTER LASTCCODE])

(PEEKC
  [LAMBDA (FILE FLG)                                         (* rmk%: "10-Apr-85 11:55")

    (* ;; "FLG says to proceed as if Control were T--not implemented correctly here NIL")

    (LET [(\RefillBufferFn (FUNCTION \PEEKREFILL))
          (STREAM (\GETSTREAM FILE 'INPUT]
         (DECLARE (SPECVARS \RefillBufferFn))
         (FCHARACTER (PEEKCCODE STREAM])

(PEEKCCODE
  [LAMBDA (FILE NOERROR)                                     (* bvm%: "12-Sep-86 15:19")
    (LET [(\RefillBufferFn (FUNCTION \PEEKREFILL))
          (STREAM (\GETSTREAM FILE 'INPUT]
         (DECLARE (SPECVARS \RefillBufferFn))
         (\PEEKCCODE STREAM NOERROR])

(RATOM
  [LAMBDA (FILE RDTBL)                                       (* ; "Edited 30-Mar-87 17:21 by bvm:")

(* ;;; "Like READ except interpret break characters as single character atoms.  I.e., always returns an atom")

    (SETQ RDTBL (\GTREADTABLE RDTBL))
    (LET ((*READTABLE* RDTBL)
          (*PACKAGE* (if (fetch (READTABLEP USESILPACKAGE) of RDTBL)
                         then *INTERLISP-PACKAGE*
                       else *PACKAGE*))
          (\RefillBufferFn (FUNCTION \RATOM/RSTRING-REFILL)))
         (DECLARE (SPECVARS *READTABLE* *PACKAGE* \RefillBufferFn))
         (WITH-RESOURCE (\PNAMESTRING)
                (\SUBREAD (\GETSTREAM FILE 'INPUT)
                       (fetch (READTABLEP READSA) of *READTABLE*)
                       RATOM.RT \PNAMESTRING (AND (fetch (READTABLEP CASEINSENSITIVE)
                                                     of *READTABLE*)
                                                  (fetch (ARRAYP BASE) of UPPERCASEARRAY))
                       NIL NIL NIL T])

(READ
  [LAMBDA (FILE RDTBL FLG)                                   (* ; "Edited 19-Mar-87 18:35 by bvm:")
    (LET ((*READTABLE* (\GTREADTABLE RDTBL))
          (*READ-NEWLINE-SUPPRESS* FLG))
         (DECLARE (SPECVARS *READTABLE* *READ-NEWLINE-SUPPRESS*))

         (* ;; "*READ-NEWLINE-SUPPRESS* is used freely by \FILLBUFFER")

         (* ;; "Call reader with PRESERVE-WHITESPACE = T, since that's the semantics Interlisp has always had before (though maybe not explicitly stated).")

         (\TOP-LEVEL-READ FILE NIL NIL NIL T])

(READC
  [LAMBDA (FILE RDTBL)                                       (* ; "Edited  6-Jan-88 15:30 by jds")
    (LET ((*READTABLE* (\GTREADTABLE RDTBL))
          (\RefillBufferFn (FUNCTION \READCREFILL)))
         (DECLARE (SPECVARS *READTABLE* \RefillBufferFn))
         (FCHARACTER (REPLACE (STREAM LASTCCODE) OF (\INSTREAMARG FILE)
                        WITH (\INCCODE (\INSTREAMARG FILE])

(READCCODE
  [LAMBDA (FILE RDTBL)                                       (* ; "Edited  3-Jun-88 01:30 by atm")

(* ;;; "returns a 16 bit character code.  \INCHAR does the EOL conversion and this function converts to a 16 bit value.  Saves the character for LASTC as well.")

    (SETQ FILE (\GETSTREAM FILE 'INPUT))
    (FDEVOP 'READCHARCODE (fetch (STREAM DEVICE) of FILE)
           FILE RDTBL])

(READP
  [LAMBDA (FILE FLG)                                         (* rmk%: " 5-Apr-85 09:09")
                                                             (* ; 
                                        "The 10 does not do the EOL check on the peeked character.")
    (LET* ((STREAM (\GETSTREAM FILE 'INPUT))
           (DEVICE (ffetch (STREAM DEVICE) of STREAM)))
          (COND
             ((ffetch (FDEV READP) of DEVICE)
              (FDEVOP 'READP DEVICE STREAM FLG))
             (T (\GENERIC.READP STREAM FLG])

(SETREADMACROFLG
  [LAMBDA (FLG)                                              (* rmk%: "25-OCT-83 16:13")
                                                             (* ; 
                   "D doesn't cause the read-macro context error, hence doesn't maintain this flag")
    NIL])

(SKIPSEPRCODES
  [LAMBDA (FILE RDTBL)                                       (* ; "Edited  6-Jan-88 13:09 by jds")

    (* ;; "Passes over non-separators to peek at the first non-separator on FILE.  Returns either last peeked character, or NIL if no non-seprs left in the file.")

    (bind PREVC C SHIFTEDCHARSET (STREAM _ (\GETSTREAM FILE 'INPUT))
           (SA _ (fetch (READTABLEP READSA) of (\GTREADTABLE RDTBL)))
           (\RefillBufferFn _ '\PEEKREFILL) first (SETQ SHIFTEDCHARSET (UNFOLD (ACCESS-CHARSET
                                                                                    STREAM)
                                                                                  256))
       declare (SPECVARS \RefillBufferFn)
       while [EQ SEPRCHAR.RC (\SYNCODE SA (SETQ C (OR (\NSPEEK STREAM SHIFTEDCHARSET 
                                                                 SHIFTEDCHARSET T)
                                                          (RETURN] do (SETQ PREVC C)
                                                                         (\NSIN STREAM SHIFTEDCHARSET
                                                                                SHIFTEDCHARSET)
       finally (AND PREVC (replace (STREAM LASTCCODE) of STREAM with PREVC))
             (RETURN C])

(SKIPSEPRS
  [LAMBDA (FILE RDTBL)                                       (* ; "Edited 11-Sep-87 17:52 by bvm:")

    (* ;; "Passes over non-separators to peek at the first non-separator on FILE.  Returns either last peeked character, or NIL if no non-seprs left in the file.")

    (bind C SHIFTEDCHARSET (STREAM _ (\GETSTREAM FILE 'INPUT))
           (SA _ (fetch (READTABLEP READSA) of (\GTREADTABLE RDTBL)))
           (\RefillBufferFn _ '\PEEKREFILL) first (SETQ SHIFTEDCHARSET (UNFOLD (ACCESS-CHARSET
                                                                                    STREAM)
                                                                                  256))
       declare (SPECVARS \RefillBufferFn)
       while [EQ SEPRCHAR.RC (\SYNCODE SA (SETQ C (OR (\NSPEEK STREAM SHIFTEDCHARSET 
                                                                 SHIFTEDCHARSET T)
                                                          (RETURN] do (\NSIN STREAM 
                                                                                 SHIFTEDCHARSET 
                                                                                 SHIFTEDCHARSET)
       finally (RETURN (FCHARACTER C])

(\NSIN.24BITENCODING.ERROR
  [LAMBDA (STREAM)                                           (* bvm%: "12-Mar-86 15:35")
    (DECLARE (USEDFREE *SIGNAL-24BIT-NSENCODING-ERROR*))

(* ;;; "Called if we see the sequence shift,shift on STREAM -- means shift to 24-bit character set, which we don't support.  Usually this just means we're erroneously reading a binary file as text.  If this function returns, its value is taken as a character set to shift to")

    (COND
       (*SIGNAL-24BIT-NSENCODING-ERROR*                      (* ; 
                                                           "Only cause error if user/reader cares")
              (ERROR "24-bit NS encoding not supported" STREAM)))
                                                             (* ; "Return charset zero")
    0])

(SKREAD
  [LAMBDA (FILE REREADSTRING RDTBL)                          (* ; "Edited  6-Apr-88 11:06 by amd")
    (LET ((*READ-SUPPRESS* 'SKREAD)
          (*READTABLE* (\GTREADTABLE RDTBL))
          (\RBFLG)
          (STRM (\GETSTREAM FILE 'INPUT))
          CH)
         (DECLARE (CL:SPECIAL *READTABLE* *READ-SUPPRESS* \RBFLG))
         [COND
            (REREADSTRING                                    (* ; 
                                                    "REREADSTRING is string of chars already read.")
                   (SETQ STRM (CL:MAKE-CONCATENATED-STREAM (CL:MAKE-STRING-INPUT-STREAM (MKSTRING
                                                                                         REREADSTRING
                                                                                         ))
                                     STRM]                   (* ; 
      "Because of return requirements, have to preview stream for unbalanced closing bracket/paren")
         (if (NULL (SETQ CH (SKIPSEPRCODES STRM)))
             then (\EOF.ACTION STRM)
           else (SELECTC (PROG1 (\SYNCODE (fetch (READTABLEP READSA) of *READTABLE*)
                                           CH)

                                 (* ;; "Read in suppressed mode.  Reader sets \Rbflg free if read ended on unbalanced bracket.  Reason we do the READ in all cases is so that we need to consume the unbalanced paren/bracket, just as if we really had read it; however, READ doesn't set \Rbflg for these cases")

                                 (\TOP-LEVEL-READ STRM NIL NIL NIL T))
                        (RIGHTPAREN.RC                       (* ; "unbalanced right paren")
                                       '%))
                        (RIGHTBRACKET.RC                     (* ; "unbalanced right bracket")
                             '%])
                        (AND \RBFLG '%]])
)



(* ; "CommonLisp read entry points")

(DEFINEQ

(CL:READ
  [CL:LAMBDA (&OPTIONAL (INPUT-STREAM *STANDARD-INPUT*)
                    (EOF-ERROR-P T)
                    EOF-VALUE RECURSIVE-P)                   (* ; "Edited 14-Dec-86 18:48 by bvm")
         (COND
            (RECURSIVE-P                                     (* ; 
                                   "Dive straight into reader using current settings of everything")
                   (.CALL.SUBREAD. INPUT-STREAM))
            (T (\TOP-LEVEL-READ INPUT-STREAM (NOT EOF-ERROR-P)
                      EOF-VALUE])

(CL:READ-PRESERVING-WHITESPACE
  [CL:LAMBDA (&OPTIONAL (STREAM *STANDARD-INPUT*)
                    (EOF-ERRORP T)
                    (EOF-VALUE NIL)
                    (RECURSIVEP NIL))                        (* ; "Edited 19-Mar-87 18:33 by bvm:")

         (* ;; 
"Reads from stream and returns the object read, preserving the whitespace that followed the object.")

         (COND
            (RECURSIVEP                                      (* ; 
                                   "Dive straight into reader using current settings of everything")
                   (.CALL.SUBREAD. STREAM))
            (T (\TOP-LEVEL-READ STREAM (NOT EOF-ERRORP)
                      EOF-VALUE NIL T])

(CL:READ-DELIMITED-LIST
  [CL:LAMBDA (CHAR &OPTIONAL (INPUT-STREAM *STANDARD-INPUT*)
                   RECURSIVE-P)                              (* ; "Edited 14-Dec-86 18:48 by bvm")

(* ;;; "Read a list of elements terminated by CHAR.  CHAR must not be a separator char, and ideally should not be a constituent char (if it is, it must be preceded by whitespace for READ-DELIMITED-LIST to work)")

         (LET [(ENDCODE (OR (FIXP CHAR)
                            (CL:CHAR-CODE CHAR)))
               (INSTREAM (\GETSTREAM INPUT-STREAM 'INPUT]
              (if RECURSIVE-P
                  then                                   (* ; 
                                   "Have to dive into reader without disturbing *CIRCLE-READ-LIST*")
                        (.CALL.SUBREAD. INPUT-STREAM NIL NIL ENDCODE)
                else (\TOP-LEVEL-READ INPUT-STREAM NIL NIL ENDCODE])

(CL:PARSE-INTEGER
  [CL:LAMBDA
   (STRING &KEY START END (RADIX 10)
          JUNK-ALLOWED)                                      (* ; 
                                                           "Edited  8-Feb-91 13:24 by gadener")
   (CL:IF (NOT (CL:STRINGP STRING))
       (ERROR "This is not a string : ~S" STRING)
       (PROG ((SA (fetch (READTABLEP READSA) of CMLRDTBL))
              (BASE (fetch (STRINGP BASE) of STRING))
              (LEN (fetch (STRINGP LENGTH) of STRING))
              (OFFST (fetch (STRINGP OFFST) of STRING))
              (FATP (fetch (STRINGP FATSTRINGP) of STRING))
              MAXDIGITCODE MAXALPHACODE INDEX STOP CHAR SIGN STARTINT ENDINT ERR)
             (SETQ RADIX (\CHECKRADIX RADIX))
             (SETQ INDEX (+ OFFST (if (NULL START)
                                      then 0
                                    elseif (< START 0)
                                      then (\ILLEGAL.ARG START)
                                    else START)))
             (SETQ STOP (+ OFFST (if (NULL END)
                                     then LEN
                                   elseif (OR (> END LEN)
                                                  (< END 0))
                                     then (\ILLEGAL.ARG END)
                                   else END)))
             (SETQ MAXDIGITCODE (+ (CHARCODE 0)
                                   RADIX -1))
             (SETQ MAXALPHACODE (AND (> RADIX 10)
                                     (+ (CHARCODE A)
                                        RADIX -11)))
             (while (AND (< INDEX STOP)
                             (EQ (\SYNCODE SA (\GETBASECHAR FATP BASE INDEX))
                                 SEPRCHAR.RC)) do        (* ; "Skip over separators")
                                                     (SETQ INDEX (CL:1+ INDEX)))
             [COND
                ((>= INDEX STOP)                             (* ; "no characters remain")
                 (RETURN (COND
                            (JUNK-ALLOWED                    (* ; "don't error")
                                   (CL:VALUES NIL STOP))
                            (T (SETQ ERR "No non-whitespace characters in integer string: ~S")
                               (GO FAIL]

        (* ;; "Start parsing a number.  Allowed to start with a single sign, then digits in radix, nothing else.  Assume collating sequence is (+, -) < digits < uppercase letters < lowercase letters.")

             (do (SETQ CHAR (\GETBASECHAR FATP BASE INDEX))
                    (if (<= CHAR MAXDIGITCODE)
                        then                             (* ; "sign or digit")
                              (if (>= CHAR (CHARCODE 0))
                                  then                   (* ; " digit")
                                        (OR STARTINT (SETQ STARTINT INDEX))
                                elseif (AND (NOT SIGN)
                                                (NOT STARTINT))
                                  then                   (* ; 
                                                           "maybe sign.  No good if not at start")
                                        (SELCHARQ CHAR
                                             (- (SETQ SIGN '-))
                                             (+ (SETQ SIGN '+))
                                             (RETURN))
                                else (RETURN))
                      elseif (AND MAXALPHACODE (<= (if (>= CHAR (CHARCODE "a"))
                                                           then 
                                                             (* ; "uppercase it first")
                                                                 (- CHAR (- (CHARCODE "a")
                                                                            (CHARCODE "A")))
                                                         else CHAR)
                                                       MAXALPHACODE))
                        then                             (* ; "is alphabetic digit")
                              (OR STARTINT (SETQ STARTINT INDEX))
                      else (RETURN)) repeatwhile (< (add INDEX 1)
                                                            STOP))
             (SETQ ENDINT INDEX)
             (RETURN (CL:VALUES (COND
                                   ([AND STARTINT
                                         (OR JUNK-ALLOWED (EQ INDEX STOP)
                                             (do (if (NEQ (\SYNCODE SA CHAR)
                                                                  SEPRCHAR.RC)
                                                         then 
                                                             (* ; " junk found")
                                                               (RETURN NIL)
                                                       elseif (EQ (add INDEX 1)
                                                                      STOP)
                                                         then 
                                                             (* ; "at end of string, win")
                                                               (RETURN T)
                                                       else (SETQ CHAR (\GETBASECHAR FATP BASE 
                                                                                  INDEX]
                                    (\MKINTEGER BASE STARTINT ENDINT (EQ SIGN '-)
                                           RADIX FATP))
                                   (JUNK-ALLOWED NIL)
                                   ((NULL STARTINT)
                                    (SETQ ERR "There aren't any digits in this integer string: ~S.")
                                    (GO FAIL))
                                   (T (SETQ ERR "There is junk in this integer string: ~S.")
                                      (GO FAIL)))
                            (- INDEX OFFST)))
         FAIL
             (CL:ERROR ERR (if (OR START END)
                               then (CL:SUBSEQ STRING (OR START 0)
                                               (OR END LEN))
                             else STRING))))])
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS CMLRDTBL)
)



(* ; "reading strings")

(DEFINEQ

(RSTRING
  [LAMBDA (FILE RDTBL RSFLG)                                 (* ; "Edited 22-Mar-87 20:53 by bvm:")
    (LET ((*READTABLE* (\GTREADTABLE RDTBL))
          (\RefillBufferFn '\RATOM/RSTRING-REFILL)
          (*READ-SUPPRESS* NIL))
         (DECLARE (SPECVARS *READTABLE* \RefillBufferFn *READ-SUPPRESS*))

         (* ;; "It's not clear that *READ-SUPPRESS* is supposed to affect anything other than calls to READ.  So play it safe and force \Rstring2 to really read a string.")

         (WITH-RESOURCE (\PNAMESTRING)
                (\RSTRING2 (\GETSTREAM FILE 'INPUT)
                       (fetch READSA of *READTABLE*)
                       (OR RSFLG T)
                       \PNAMESTRING])

(READ-EXTENDED-TOKEN
  [LAMBDA (STREAM RDTBL ESCAPE-ALLOWED-P)                    (* ; "Edited 11-Sep-87 16:23 by bvm:")

    (* ;; "This is a cross between RSTRING and \SUBREAD.  Read a %"token%" from STREAM, as defined by the Common Lisp reader and the syntax in RDTBL.  EOF terminates as well.  If ESCAPE-ALLOWED-P is true, escapes are honored and if one appears, a second value of T is returned.  Otherwise, escapes are treated as vanilla chars and the caller can barf on them itself if it desires.")

    (SETQ RDTBL (\GTREADTABLE RDTBL))
    (WITH-RESOURCE (\PNAMESTRING)
           (PROG ((CASEBASE (AND (fetch (READTABLEP CASEINSENSITIVE) of RDTBL)
                                 (fetch (ARRAYP BASE) of UPPERCASEARRAY)))
                  (PBASE (ffetch (STRINGP XBASE) of \PNAMESTRING))
                  (SHIFTEDCHARSET (UNFOLD (ACCESS-CHARSET STREAM)
                                         256))
                  (J 0)
                  (SA (fetch READSA of RDTBL))
                  CH SNX ANSLIST ANSTAIL ESCAPE-APPEARED ESCAPING FATSEEN)
             LP  (if (\EOFP STREAM)
                     then                                (* ; 
                                             "end of file terminates string just like a sepr/break")
                           (GO FINISH))
                 (SETQ CH (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET))
                                                             (* ; "NOTE: This should really be (\CHECKEOLC (\NSIN --) --), but eol is usually a break or sepr and the \BACKNSCHAR doesn't work right.  Fix this when we unread correctly")
                 (SETQ SNX (\SYNCODE SA CH))
                 [COND
                    ((AND ESCAPE-ALLOWED-P (SELECTC SNX
                                               (ESCAPE.RC (SETQ CH (\CHECKEOLC (\NSIN STREAM 
                                                                                      SHIFTEDCHARSET
                                                                                      SHIFTEDCHARSET)
                                                                          (ffetch EOLCONVENTION
                                                                             of STREAM)
                                                                          STREAM))
                                                          (SETQ ESCAPE-APPEARED T))
                                               (MULTIPLE-ESCAPE.RC 
                                                    (SETQ ESCAPING (NOT ESCAPING))
                                                    (SETQ ESCAPE-APPEARED T)
                                                    (GO LP))
                                               NIL)))
                    (ESCAPING                                (* ; "eat chars until next |"))
                    ((fetch STOPATOM of SNX)
                     (\BACKNSCHAR STREAM SHIFTEDCHARSET)
                     (GO FINISH))
                    ((AND CASEBASE (ILEQ CH \MAXTHINCHAR))
                     (SETQ CH (\GETBASEBYTE CASEBASE CH]
                 (COND
                    ((EQ J \PNAMELIMIT)                      (* ; 
                  "Filled PNSTR so have to save those chars away and start filling up a new buffer")
                     (SETQ J (\SMASHSTRING (ALLOCSTRING J NIL NIL FATSEEN)
                                    0 \PNAMESTRING J))
                     [COND
                        [ANSLIST (RPLACD ANSTAIL (SETQ ANSTAIL (CONS J NIL]
                        (T (SETQ ANSTAIL (SETQ ANSLIST (CONS J NIL]
                     (SETQ J 0)))
                 (\PNAMESTRINGPUTCHAR PBASE J CH)
                 (COND
                    ((AND (NOT FATSEEN)
                          (IGREATERP CH \MAXTHINCHAR))
                     (SETQ FATSEEN T)))
                 (SETQ J (ADD1 J))
                 (GO LP)
             FINISH
                 (SETQ J (\SMASHSTRING (ALLOCSTRING J NIL NIL FATSEEN)
                                0 \PNAMESTRING J))
                 [COND
                    (ANSLIST (RPLACD ANSTAIL (SETQ ANSTAIL (CONS J NIL)))
                           (SETQ J (CONCATLIST ANSLIST]
                 (RETURN (if ESCAPE-APPEARED
                             then                        (* ; 
                                                  "do it this way because multiple values are slow")
                                   (CL:VALUES J T)
                           else J])

(\RSTRING2
  [LAMBDA (STREAM SA RSFLG PNSTR)                            (* ; 
                                                      "Edited  4-Aug-93 12:38 by sybalskY:MV:ENVOS")

(* ;;; "The main string reader.  Reads characters from STREAM according to the syntax table SA and returns a string.  PNSTR is an instance of the global resource \PNAMESTRING, which we can use all to ourselves as a buffer.")

(* ;;; "If RSFLG is T then the call is from RSTRING, in which case the string is terminated by a break or sepr in SA.  If RSFLG is NIL then the string is terminated by a string delimiter.  If RSFLG is SKIP then CR's and the following separator chars are discarded as an otherwise normal string is read")

    (DECLARE (USEDFREE *READTABLE* *READ-SUPPRESS*))
    (PROG ((EOLC (ffetch EOLCONVENTION of STREAM))
           (PBASE (SELECTQ (SYSTEMTYPE)
                      (VAX PNSTR)
                      (ffetch (STRINGP XBASE) of PNSTR)))
           (SHIFTEDCHARSET (UNFOLD (ACCESS-CHARSET STREAM)
                                  256))
           (J 0)
           EOLCHAR CH SNX ANSLIST ANSTAIL LASTC FATSEEN SKIPPING)
          (SELECTC EOLC
              (CRLF.EOLC (SETQ EOLCHAR (CHARCODE CR)))
              (CR.EOLC (SETQ EOLCHAR (CHARCODE CR)))
              (LF.EOLC (SETQ EOLCHAR (CHARCODE LF)))
              NIL)
      RS2LP
          (SETQ CH (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET))
          [COND
             ((EQ CH EOLCHAR)

              (* ;; "We just read the stream's EOL character, so we have to turn it into our EOL.  Most places do this with \CHECKEOLC, but we can't do that here, because if the eol is CRLF and would terminate the read, \BACKNSCHAR won't work right.")

              (COND
                 ([AND (EQ RSFLG T)
                       (fetch STOPATOM of (\SYNCODE SA (CHARCODE CR]
                                                             (* ; 
                                          "From RSTRING, eol terminates read.  Leave eol in buffer")
                  (\BACKNSCHAR STREAM SHIFTEDCHARSET)
                  (GO FINISH))
                 (T (COND
                       ((AND (EQ EOLC CRLF.EOLC)
                             (EQ (\PEEKBIN STREAM T)
                                 (CHARCODE LF)))             (* ; "Eat the LF after the CR")
                        (\BIN STREAM)))
                    (SETQ CH (CHARCODE CR]
          (SETQ SNX (\SYNCODE SA CH))
          (SELECTC SNX
              (OTHER.RC                                      (* ; "Normal case, nothing to do"))
              (ESCAPE.RC [COND
                            ((fetch ESCAPEFLG of *READTABLE*)
                             (SETQ CH (\CHECKEOLC (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET)
                                             EOLC STREAM))
                             (COND
                                ((AND (EQ RSFLG 'SKIP)
                                      (EQ CH (CHARCODE CR))) (* ; 
                  "Strip leading spaces after escaped returns, too, but leave the CR in the string")
                                 (SETQ SKIPPING 0)
                                 (GO PUTCHAR])
              (SELECTQ RSFLG
                  (NIL                                       (* ; "end check is dbl quote")
                       (COND
                          ((EQ SNX STRINGDELIM.RC)           (* ; "Got it")
                           (SETQ LASTC CH)
                           (GO FINISH))))
                  (T                                         (* ; 
            "if called from RSTRING, end check is break or sepr, and we must leave delim in stream")
                     (COND
                        ((fetch STOPATOM of SNX)
                         (\BACKNSCHAR STREAM SHIFTEDCHARSET)
                         (GO FINISH))))
                  (SKIP                                      (* ; 
                                                       "Like NIL but strip cr's and leading spaces")
                        (SELECTC SNX
                            (STRINGDELIM.RC 
                                 (SETQ LASTC CH)
                                 (GO FINISH))
                            (SEPRCHAR.RC                     (* ; "Assume that CR is a sepr")
                                         (COND
                                            [SKIPPING (COND
                                                         ((EQ CH (CHARCODE EOL))
                                                             (* ; 
                                                           "Multiple CR's while skipping are kept")
                                                          (COND
                                                             ((EQ SKIPPING T)
                                                             (* ; 
                    "Turn previous space back into CR.  Note that J is guaranteed to be at least 1")
                                                              (\PNAMESTRINGPUTCHAR PBASE (SUB1 J)
                                                                     CH)
                                                              (SETQ SKIPPING 0)))
                                                          (GO PUTCHAR))
                                                         (T  (* ; "Continue skipping seprs")
                                                            (GO RS2LP]
                                            ((EQ CH (CHARCODE EOL))
                                                             (* ; 
                                                      "Turn CR into space and start skipping seprs")
                                             (SETQ SKIPPING T)
                                             (SETQ CH (CHARCODE SPACE))
                                             (GO PUTCHAR))))
                            NIL))
                  (SHOULDNT)))
          (SETQ SKIPPING NIL)
      PUTCHAR
          [COND
             ((NOT *READ-SUPPRESS*)                          (* ; "Accumulate character")
              (COND
                 ((EQ J \PNAMELIMIT)                         (* ; 
                  "Filled PNSTR so have to save those chars away and start filling up a new buffer")
                  (SETQ J (\SMASHSTRING (ALLOCSTRING J NIL NIL FATSEEN)
                                 0 PNSTR J))
                  [COND
                     [ANSLIST (RPLACD ANSTAIL (SETQ ANSTAIL (CONS J NIL]
                     (T (SETQ ANSTAIL (SETQ ANSLIST (CONS J NIL]
                  (SETQ J 0)))
              (\PNAMESTRINGPUTCHAR PBASE J CH)
              (SETQ LASTC CH)
              (COND
                 ((AND (NOT FATSEEN)
                       (IGREATERP CH \MAXTHINCHAR))
                  (SETQ FATSEEN T)))
              (SETQ J (ADD1 J]
          (COND
             ((OR (NEQ RSFLG T)
                  (NOT (\EOFP STREAM)))                      (* ; "in RSTRING (RSFLG=T), if we've read something already, then end of file terminates string just like a sepr/break")
              (GO RS2LP)))
      FINISH
          (AND LASTC (replace (STREAM LASTCCODE) of STREAM with LASTC))
          (RETURN (COND
                     ((NOT *READ-SUPPRESS*)
                      (SETQ J (\SMASHSTRING (ALLOCSTRING J NIL NIL FATSEEN)
                                     0 PNSTR J))
                      (COND
                         (ANSLIST (RPLACD ANSTAIL (SETQ ANSTAIL (CONS J NIL)))
                                (CONCATLIST ANSLIST))
                         (T J])
)



(* ; "Core of the reader")

(DEFINEQ

(\TOP-LEVEL-READ
  [LAMBDA (STREAM EOF-SUPPRESS EOF-VALUE CHAR PRESERVE-WHITESPACE)
                                                             (* ; "Edited 13-Dec-88 16:28 by jds")

    (* ;; "Entry to the guts of the reader from a place where you may not be already under the reader.  CHAR is for READ-DELIMITED-LIST -- it is charcode to terminate read, in which case we are reading a sequence of things instead of a single thing.  EOF-SUPPRESS is the opposite of CL:READ's EOF-ERROR-P arg.")

    (* ;; 
  " I EOF-SUPPRESS, set the stream's EODOFSTREAMOP to retfrom here with EOF-VALUE as its result.")

    (LET ((*PACKAGE* (COND
                        ((fetch (READTABLEP USESILPACKAGE) of (\DTEST *READTABLE*
                                                                             'READTABLEP))
                         *INTERLISP-PACKAGE*)
                        (T *PACKAGE*)))
          (\RefillBufferFn (FUNCTION \READREFILL))
          (*CIRCLE-READ-LIST* NIL)
          (OLD-EOS-OP (fetch ENDOFSTREAMOP of STREAM)))
         (DECLARE (SPECVARS *PACKAGE* \RefillBufferFn *CIRCLE-READ-LIST* EOF-VALUE))
         (CL:UNWIND-PROTECT
             (PROGN [AND EOF-SUPPRESS (REPLACE ENDOFSTREAMOP OF STREAM
                                         WITH #'(LAMBDA (STREAM)
                                                      (RETFROM '\TOP-LEVEL-READ EOF-VALUE]
                    (LET ((RESULT (.CALL.SUBREAD. STREAM EOF-SUPPRESS EOF-VALUE CHAR 
                                         PRESERVE-WHITESPACE)))
                         (if *CIRCLE-READ-LIST*
                             then                        (* ; 
                                      "There were calls to #=, so go fix up all the ## references.")
                                   (HASH-STRUCTURE-SMASH RESULT))
                         RESULT))
             (REPLACE ENDOFSTREAMOP OF STREAM WITH OLD-EOS-OP))])

(\SUBREAD
  [LAMBDA (STREAM SA READTYPE PNSTR CASEBASE EOF-SUPPRESS EOF-VALUE CHAR PRESERVE-WHITESPACE)
                                                             (* ; "Edited  7-Jan-88 18:38 by jds")

    (* ;; "Values of READTYPE are: --- READ.RT for top level of READ, --- NOPROPRB.RT if right-bracket isn't to be propagated -- sublist beginning with left-bracket --- PROPRB.RT if propagation is not suppressed -- sublist beginning with left-paren --- RATOM.RT for call from RATOM")

    (* ;; "PNSTR is an instance of the global resource \PNAMESTRING, acquired in READ and passed on from level to level.  It is released during read-macro applications, then reacquired.")

    (* ;; "CASEBASE is base of uppercasearray if read table is case-insensitive.")

    (* ;; "If EOF-SUPPRESS is true, then if we are at end of file we should return EOF-VALUE instead of erroring (we need this because we might actually be sitting before end of file in front of something that reads nothing, e.g., a comment, so caller can't check EOFP itself).  Always false on recursive calls.")

    (* ;; "If CHAR is supplied, it is a character code which, when read (in isolation), should terminate this call to read.  Never on when at top-level.")

    (* ;; "\RBFLG is propagated for top-level calls, in case they are embedded in read-macros.  SKREAD also depends on this.")

    (* ;; 
  "If PRESERVE-WHITESPACE is true, doesn't throw away the whitespace that terminates the read.")

    (DECLARE (USEDFREE *READTABLE* \RBFLG))

    (* ;; "\RDCONC is a macro that adds a new element as specified by its first argument to the current sublist.  Its other arguments will be executed instead if we are the top-level call")

    (PROG ((TOPLEVELP (SELECTC READTYPE
                          ((LIST READ.RT RATOM.RT) 
                               T)
                          NIL))
           (SHIFTEDCHARSET (UNFOLD (ACCESS-CHARSET STREAM)
                                  256))
           (PBASE (SELECTQ (SYSTEMTYPE)
                      (VAX PNSTR)
                      (ffetch (STRINGP XBASE) of PNSTR)))
           SNX LST END ELT DOTLOC CH J ESCAPEFLG INVALIDFLG PACKAGE NCOLONS AT-EOF EOF-POSSIBILITY 
           EXTRASEGMENTS LASTC)
          (if (AND TOPLEVELP (NOT (\INTERMP STREAM)))
              then 

                    (* ;; "EOF is allowed to terminate tokens on direct READ calls.  Not if reading from terminal, because \FILLBUFFER made sure to put something at the end.")

                    (SETQ EOF-POSSIBILITY T))
      NEWTOKEN
          

     (* ;; "Here ready to scan a new token.  First skip over separator characters")

          (SETQ J 0)
          [SETQ EXTRASEGMENTS (SETQ INVALIDFLG (SETQ ESCAPEFLG (SETQ PACKAGE (SETQ NCOLONS NIL]
          (if (AND EOF-SUPPRESS (NULL (SKIPSEPRCODES STREAM)))
              then                                       (* ; 
                            "caller specified eof-error-p of NIL.  Happens only on top-level calls")
                    (RETURN EOF-VALUE))
          (SETQ SHIFTEDCHARSET (UNFOLD (ACCESS-CHARSET STREAM)
                                      256))                  (* ; "By Skipping Separator Characters,Happens CHARSET-Mode Exchanging. (Solution of AR#114 in FX, edited by tt [Jan-22-'90])")
          (repeatwhile (EQ [SETQ SNX (\SYNCODE SA (SETQ CH (\NSIN STREAM SHIFTEDCHARSET 
                                                                      SHIFTEDCHARSET]
                               SEPRCHAR.RC))
          (COND
             ((EQ CH CHAR)                                   (* ; 
                                   "Read desired terminating char.  TOPLEVELP is always false here")
              (replace (STREAM LASTCCODE) of STREAM with CH)
                                                             (* ; "Save last char for LASTC.")
              (RETURN LST))
             ((EQ SNX OTHER.RC)                              (* ; "Start of an atom")
              (COND
                 ([AND (EQ CH (CHARCODE %.))
                       (fetch STOPATOM of (\SYNCODE SA (\NSPEEK STREAM SHIFTEDCHARSET 
                                                                      SHIFTEDCHARSET]

                  (* ;; "An isolated, unescaped dot.  This special check on every atom could be eliminated if . had a special SNX code")

                  (SETQ DOTLOC END)                          (* ; 
                  "DOTLOC points to CONS cell one before the dot, NIL for car of list, as desired.")
                  ))
              (GO GOTATOMCHAR))
             [(fetch STOPATOM of SNX)                (* ; 
                                                 "This character definitely does not start an atom")
              (COND
                 ((EQ READTYPE RATOM.RT)
                  (GO SINGLECHARATOM))
                 (T (GO BREAK]
             ((EQ SNX PACKAGEDELIM.RC)                       (* ; 
                                  "Starting a symbol with a package delimiter -- must be a keyword")
              (SETQ NCOLONS 1)
              (SETQ PACKAGE *KEYWORD-PACKAGE*)
              (SETQ ESCAPEFLG T)
              (GO NEXTATOMCHAR))
             [(AND (SELECTC (fetch MACROCONTEXT of SNX)
                       (FIRST.RMC T)
                       (ALONE.RMC (fetch STOPATOM of (\SYNCODE SA (\NSPEEK STREAM 
                                                                                 SHIFTEDCHARSET 
                                                                                 SHIFTEDCHARSET))))
                       NIL)
                   (fetch READMACROFLG of *READTABLE*))
              (COND
                 ((EQ READTYPE RATOM.RT)
                  (GO SINGLECHARATOM))
                 (T (GO MACRO]
             (T                                              (* ; 
                         "Some character that starts an atom but has non-trivial syntax attributes")
                ))
      ATOMLOOP
          

     (* ;; "At this point, we are accumulating an atom, and CH does not have syntax OTHER, so we have to check special cases")

          (SELECTC SNX
              (ESCAPE.RC                                     (* ; 
                                                 "Take next character to be alphabetic, case exact")
                         (COND
                            ((fetch ESCAPEFLG of *READTABLE*)
                             (SETQ CH (\CHECKEOLC (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET)
                                             (ffetch EOLCONVENTION of STREAM)
                                             STREAM))        (* ; 
                 "No EOFP check needed -- it's an error to have escape char with nothing following")
                             (SETQ ESCAPEFLG T)
                             (GO PUTATOMCHAR))))
              (MULTIPLE-ESCAPE.RC 
                                  (* ;; "Take characters up to next multiple escape to be alphabetic, except that single escape chars still escape the next char")

                   (SETQ ESCAPEFLG T)
                   [bind ESCFLG do (SETQ CH (\CHECKEOLC (\NSIN STREAM SHIFTEDCHARSET 
                                                                       SHIFTEDCHARSET)
                                                           (ffetch EOLCONVENTION of STREAM)
                                                           STREAM))
                                          (COND
                                             ([NOT (COND
                                                      (ESCFLG (SETQ ESCFLG NIL))
                                                      (T (SELECTC (SETQ SNX (\SYNCODE SA CH))
                                                             (MULTIPLE-ESCAPE.RC 
                                                             (* ; 
                                              "Finished escaped sequence, resume normal processing")
                                                                  (GO NEXTATOMCHAR))
                                                             (ESCAPE.RC 
                                                             (* ; 
                                                           "Pass the next char thru verbatim")
                                                                        (SETQ ESCFLG T))
                                                             NIL]
                                                             (* ; 
                                                           "All others are pname chars, quoted")
                                              (if (NOT *READ-SUPPRESS*)
                                                  then (COND
                                                              ((EQ J \PNAMELIMIT)
                                                             (* ; 
                               "if there have been escapes, can't be a number, so ok to error now.")
                                                               (LISPERROR "ATOM TOO LONG"
                                                                      (\SUBREADCONCAT 
                                                                             EXTRASEGMENTS PBASE J))
                                                               (GO NEWTOKEN)))
                                                        (\PNAMESTRINGPUTCHAR PBASE J CH)
                                                        (add J 1])
              NIL)
      GOTATOMCHAR
          

     (* ;; "CH is a vanilla atom char to accumulate")

          [COND
             ((AND CASEBASE (ILEQ CH \MAXTHINCHAR))          (* ; "Uppercase atom characters")
              (SETQ CH (\GETBASEBYTE CASEBASE CH]
      PUTATOMCHAR
          (if (NOT *READ-SUPPRESS*)
              then (COND
                          ((EQ J \PNAMELIMIT)                (* ; "Symbol is too long.  However, it could just be a bignum, so keep accumulating characters until we have to do something.")
                           (push EXTRASEGMENTS (\SMASHSTRING (ALLOCSTRING J NIL NIL T)
                                                          0 PNSTR J))
                           (SETQ J 0)))
                    (\PNAMESTRINGPUTCHAR PBASE J CH)
                    (add J 1)
                    (SETQ LASTC CH)                          (* ; "Save CH for LASTC."))
      NEXTATOMCHAR
          (if (AND EOF-POSSIBILITY (SETQ AT-EOF (\EOFP STREAM)))
              then                                       (* ; 
                                                           "EOF terminates atoms at top level")
                    (GO FINISHATOM)
            elseif (EQ [SETQ SNX (\SYNCODE SA (SETQ CH (\NSIN STREAM SHIFTEDCHARSET 
                                                                  SHIFTEDCHARSET]
                           OTHER.RC)
              then                                       (* ; 
      "normal case tested first--another vanilla constituent char, so keep accumulating atom chars")
                    (GO GOTATOMCHAR)
            elseif (fetch STOPATOM of SNX)
              then                                       (* ; "Terminates atom")
                    (GO FINISHATOM)
            elseif (EQ SNX PACKAGEDELIM.RC)
              then (GO GOTPACKAGEDELIM)
            else (GO ATOMLOOP))
      FINISHATOM
          

     (* ;; 
   "Come here when an atom has been terminated, either by a break/sepr char or by end of file.")

          (if INVALIDFLG
              then (replace (STREAM LASTCCODE) of STREAM with (OR LASTC CH 65535))
                    (\INVALID.SYMBOL PBASE J NCOLONS PACKAGE EXTRASEGMENTS))
          [SETQ ELT (AND (NOT *READ-SUPPRESS*)
                         (if EXTRASEGMENTS
                             then 

                                 (* ;; "More than \PNAMELIMIT chars were read.  Can't be a symbol, but might be a number.  Pack up all the strings we have into a single string and try to parse it as a number.")

                                   (SETQ EXTRASEGMENTS (\SUBREADCONCAT EXTRASEGMENTS PBASE J))
                                   (OR (AND (NULL (OR PACKAGE ESCAPEFLG NCOLONS))
                                            (\PARSE.NUMBER (fetch (STRINGP BASE) of 
                                                                                        EXTRASEGMENTS
                                                                  )
                                                   (fetch (STRINGP OFFST) of EXTRASEGMENTS)
                                                   (fetch (STRINGP LENGTH) of EXTRASEGMENTS)
                                                   \FATPNAMESTRINGP))
                                       (LISPERROR "ATOM TOO LONG" EXTRASEGMENTS))
                           else (\READ.SYMBOL PBASE 0 J \FATPNAMESTRINGP PACKAGE (EQ NCOLONS 1)
                                           ESCAPEFLG]
          (replace (STREAM LASTCCODE) of STREAM with CH)
                                                             (* ; "Save last READ char for LASTC.")
          (if AT-EOF
              then                                       (* ; 
                                                           "top-level read, atom terminated by EOF")
                    (RETURN ELT))
          (\RDCONC ELT (PROGN (COND
                                 ((OR PRESERVE-WHITESPACE (NEQ SNX SEPRCHAR.RC))
                                                             (* ; "At top-level, put back the terminating character if preserving whitespace or terminator is significant")
                                  (replace (STREAM LASTCCODE) of STREAM
                                     with (OR LASTC CH 65535))
                                                             (* ; 
                                                   "And LASTC will return the last REAL char read.")
                                  (\BACKNSCHAR STREAM SHIFTEDCHARSET)))
                              (RETURN ELT)))
          (if (EQ SNX SEPRCHAR.RC)
              then                                       (* ; 
                                                         "Terminated with sepr, go on to next char")
                    (GO NEWTOKEN)
            elseif (EQ CH CHAR)
              then                                       (* ; "read terminates here")
                    (replace (STREAM LASTCCODE) of STREAM with CH)
                    (RETURN LST)
            else                                         (* ; 
                                             "Terminated with break, jump into the break char code")
                  (GO BREAK))
      GOTPACKAGEDELIM
          

     (* ;; "Come here if CH is a package delimiter.  Note that we have already scanned at least one character of the token, so this must be an interior delim")

          (COND
             (*READ-SUPPRESS*                                (* ; "Don't care about packages"))
             [(AND (EQ J 0)
                   (NULL EXTRASEGMENTS))

              (* ;; "No chars accumulated, so must be 2 colons in a row.  Note that the case where we've just started scanning a token happens up at NEWTOKEN")

              (SETQ LASTC CH)
              (COND
                 ((AND (EQ NCOLONS 1)
                       (NEQ PACKAGE *KEYWORD-PACKAGE*))      (* ; 
                                                        "Two colons in a row means internal symbol")
                  (SETQ NCOLONS 2))
                 (T                                          (* ; 
                                                           "Error, e.g., `FOO:::BAZ' or `::BAR'")
                    (SETQ INVALIDFLG T)
                    (GO GOTATOMCHAR]
             ((NULL NCOLONS)                                 (* ; 
                                                           "We have just scanned the package name")
              (SETQ NCOLONS 1)
              (SETQ LASTC CH)
              [SETQ PACKAGE (COND
                               (EXTRASEGMENTS (LISPERROR "ATOM TOO LONG" (\SUBREADCONCAT 
                                                                                EXTRASEGMENTS PBASE J
                                                                                ))
                                      (SETQ EXTRASEGMENTS NIL))
                               ((\FIND.PACKAGE.INTERNAL PBASE 0 J \FATPNAMESTRINGP))
                               (T                            (* ; 
                 "Error, but don't signal yet -- save name as string for benefit of error handlers")
                                  (\GETBASESTRING PBASE 0 J \FATPNAMESTRINGP]
              (SETQ J 0))
             (T                                              (* ; 
      "Have alread seen one or more colons, and have scanned more symbol.  This colon is an error.")
                (SETQ LASTC CH)
                (SETQ INVALIDFLG T)
                (GO GOTATOMCHAR)))
          (SETQ ESCAPEFLG T)                                 (* ; "Result MUST be a symbol now")
          (GO NEXTATOMCHAR)
      SINGLECHARATOM
          

     (* ;; "Come here to create a symbol whose single character is CH -- no package stuff to worry about.  This happens mainly for RATOM.  We create the single char atom in IL for backward compatibility.")

          (\PNAMESTRINGPUTCHAR PBASE 0 CH)
          (SETQ ELT (\READ.SYMBOL PBASE 0 1 \FATPNAMESTRINGP *INTERLISP-PACKAGE*))
          (replace (STREAM LASTCCODE) of STREAM with CH)
          (\RDCONC ELT (RETURN ELT))
          (GO NEWTOKEN)

     (* ;; "End of atom scanning code")

      BREAK
          

     (* ;; "At this point, we have just read a break character, stored in CH")

          (replace (STREAM LASTCCODE) of STREAM with CH)
          [SELECTC SNX
              (LEFTPAREN.RC 
                            (* ;; "recursively read a list.  If that list (or any of it's non-bracketed sublists) is terminated by a right bracket it terminates our read as well.  PROPRB macro worries about right-bracket propagation: if the subread encounters a right bracket (sets \RBFLG), PROPRB returns true.  In addition, if we were not called by a left-bracket (READTYPE = NOPROPRB.RT) it sets \RBFLG in caller, thereby propagating the bracket upward.")

                            (COND
                               ((PROG1 (PROPRB (SETQ ELT (\SUBREAD STREAM SA PROPRB.RT PNSTR 
                                                                CASEBASE)))
                                    (\RDCONC ELT (RETURN ELT)))

                                (* ;; "PROG1 is true if the subread encountered a right bracket")

                                (FIXDOT)                     (* ; "Fix dotted pair if necessary")
                                (RETURN LST))))
              (LEFTBRACKET.RC 
                              (* ;; "recursively read a list, terminated by either right paren or right bracket.  In this case, right bracket is not propagated upward--we continue reading elements after it.")

                   (SETQ ELT (\SUBREAD STREAM SA NOPROPRB.RT PNSTR CASEBASE))
                   (\RDCONC ELT (RETURN ELT)))
              ((LIST RIGHTPAREN.RC RIGHTBRACKET.RC) 

                                 (* ;; "Terminate one or more lists, return what we have accumulated so far.  In the case of Right bracket, if caller did not have the matching left bracket, we have to allow the bracket to close more than one list.")

                   (RETURN (COND
                              (TOPLEVELP 

                                 (* ;; "Naked right paren/bracket returns NIL.  This is sort of bogus in common lisp, but changing it would be a significant change to Interlisp folks.")

                                     NIL)
                              (CHAR 

                                  (* ;; "call from READ-DELIMITED-LIST doesn't want to terminate this way.  Could read as NIL and not terminate, but seems best to error.")

                                    (CL:ERROR "Unmatched ~A encountered while reading to a ~A"
                                           (CL:CODE-CHAR CH)
                                           (CL:CODE-CHAR CHAR))
                                    LST)
                              (T (FIXDOT)
                                 (AND (EQ SNX RIGHTBRACKET.RC)
                                      (NEQ READTYPE NOPROPRB.RT)
                                      (SETQ \RBFLG T))
                                 LST))))
              (STRINGDELIM.RC 
                              (* ;; "Invoke string reader")

                   (SETQ ELT (\RSTRING2 STREAM SA NIL PNSTR))
                   (\RDCONC ELT (RETURN ELT)))
              (COND
                 ((OR (EQ SNX BREAKCHAR.RC)
                      (NOT (fetch READMACROFLG of *READTABLE*)))
                                                             (* ; 
                                                           "A breakchar or a disabled always macro")
                  (GO SINGLECHARATOM))
                 (T (GO MACRO]
          (GO NEWTOKEN)
      MACRO
          (SELECTQ (fetch MACROTYPE of (SETQ SNX (\GETREADMACRODEF CH *READTABLE*)))
              (MACRO (COND
                        ((PROG1 (PROPRB [SETQ ELT (RELEASERESOURCE \PNAMESTRING PNSTR
                                                         (CL:MULTIPLE-VALUE-LIST (\APPLYREADMACRO
                                                                                  STREAM SNX]
                                                             (* ; 
                                        "Ignore right-bracket if macro is called at top-level read")
                                       )
                             [COND
                                ((NULL ELT)                  (* ; 
                                                      "Macro returned zero values, read as nothing")
                                 )
                                (T (SETQ ELT (CAR ELT))
                                   (\RDCONC ELT (RETURN ELT])
                         (FIXDOT)                            (* ; 
                                  "Encountered right bracket if we get here -- return what we have")
                         (RETURN LST))))
              (INFIX 
                     (* ;; "We give macro TCONC list of what we've accumulated so far--it gets to modify it as it pleases and return it.  We continue from there.")

                     (COND
                        ((PROG1 [PROPRB (SETQ ELT (RELEASERESOURCE \PNAMESTRING PNSTR
                                                         (\APPLYREADMACRO STREAM SNX
                                                                (AND LST (CONS LST END]
                             [COND
                                [TOPLEVELP                   (* ; 
                                                     "What does INFIX mean at top level??  See IRM")
                                       (COND
                                          ((AND (LISTP ELT)
                                                (CDR ELT))   (* ; 
                                                    "Result is in TCONC format, so it's returnable")
                                           (RETURN (COND
                                                      ((EQ (CDR ELT)
                                                           (CAR ELT))
                                                             (* ; "TCONC list of one element--return the element. This is how INFIX top level macro can return a non-list.  ")
                                                       (CAAR ELT))
                                                      (T (CAR ELT]
                                (T                           (* ; 
                                            "Reading sublist.  Take apart TCONC list and continue.")
                                   (SETQ LST (CAR ELT))
                                   (SETQ END (CDR ELT])
                         (FIXDOT)                            (* ; 
                                                        "Macro hit right bracket if we got to here")
                         (RETURN LST))))
              (SPLICE 
                      (* ;; "Macro returns arbitrary number of values to be spliced inline.")

                      [RBCONTEXT (SETQ ELT (RELEASERESOURCE \PNAMESTRING PNSTR (\APPLYREADMACRO
                                                                                STREAM SNX]
                                                             (* ; 
                                       "Note: we don't care if there was terminating right-bracket")
                                                             (* ; "Why? -bvm")
                      (COND
                         ((OR (NULL ELT)
                              TOPLEVELP)

                          (* ;; "On the 10, it actually returns ELT if it is a list and the next token is a closing paren or bracket.  Hard to see how to get that behavior--rmk")

                          (GO NEWTOKEN))
                         ((NLISTP ELT)                       (* ; 
                               "The 10 throws initial non-lists away (What if LST/END aren't set?)")
                          (SETQ ELT (AND LST (LIST '%. ELT)))
                          (SETQ DOTLOC END)))
                      [COND
                         ((NOT *READ-SUPPRESS*)
                          (COND
                             (LST (RPLACD END ELT))
                             (T (SETQ LST ELT)))
                          (SETQ END (LAST ELT))
                          (COND
                             ((CDR END)                      (* ; "A dotted pair")
                              (SETQ DOTLOC END)
                              (RPLACD END (CONS '%. (SETQ END (CONS (CDR END])
              (SHOULDNT))
          (GO NEWTOKEN])

(\SUBREADCONCAT
  [LAMBDA (EXTRASEGMENTS PBASE J)                            (* ; "Edited 16-Jan-87 15:08 by bvm:")

    (* ;; "Produces a string consisting of all the characters \SUBREAD has been buffering up into a token.  Last J chars are stored at PBASE.  EXTRASEGMENTS is a list of strings in reverse order in the case that more characters were scanned than the pname string accommodates.")

    (SETQ PBASE (\GETBASESTRING PBASE 0 J \FATPNAMESTRINGP))
    (if EXTRASEGMENTS
        then (CONCATLIST (NCONC1 (REVERSE EXTRASEGMENTS)
                                    PBASE))
      else PBASE])

(\ORIG-READ.SYMBOL
  [LAMBDA (BASE OFFSET LEN FATP PACKAGE EXTERNALP NONNUMERICP)
                                                             (* bvm%: " 3-Aug-86 15:25")

(* ;;; "Read a number or symbol from the string defined by BASE OFFSET LEN FATP PACKAGE is NIL if no package was specified, a package object or a string if an unknown package was typed (causes error).  EXTERNALP is true if symbol was typed with one colon, which requires that the symbol exist and be external.  NONNUMERICP is true if we know the symbol is not a number, e.g., some characters in it were escaped.")

(* ;;; "For now a dummy definition")

    (COND
       (PACKAGE                                              (* ; "For debugging")
              (CONCAT PACKAGE (COND
                                 (EXTERNALP ":")
                                 (T "::"))
                     (\GETBASESTRING BASE OFFSET LEN FATP)))
       (T (OR (AND (NOT NONNUMERICP)
                   (\PARSE.NUMBER BASE OFFSET LEN FATP))
              (\MKATOM BASE OFFSET LEN FATP T])

(\ORIG-INVALID.SYMBOL
  [LAMBDA (BASE LEN NCOLONS PACKAGE EXTRASEGMENTS)           (* ; "Edited 15-Jan-87 17:33 by bvm:")

(* ;;; "Called when scanning a symbol that has more than 2 colons, or more than 1 non-consecutive colon.  If return from here, will read the symbol as though the extra colons were escaped.")

    (CL:CERROR "Treat the extra colon(s) as if they were escaped" "Invalid symbol syntax in %"~A%""
           (CONCAT (if (AND PACKAGE (NEQ PACKAGE *KEYWORD-PACKAGE*))
                       then (if (STRINGP PACKAGE)
                                    then PACKAGE
                                  else (CL:PACKAGE-NAME PACKAGE))
                     else "")
                  (SELECTQ NCOLONS
                      (1 ":")
                      (2 "::")
                      "")
                  (\SUBREADCONCAT EXTRASEGMENTS BASE LEN])

(\APPLYREADMACRO
  [LAMBDA (STREAM MACDEF ANSCELL)                            (* bvm%: " 4-May-86 16:38")
                                                             (* ; 
                                                         "INREADMACROP searches for this framename")
    (DECLARE (USEDFREE *READTABLE*))
    (APPLY* (fetch MACROFN of MACDEF)
           STREAM *READTABLE* ANSCELL])

(INREADMACROP
  [LAMBDA NIL                                                (* edited%: "26-MAY-79 00:12")
    (PROG (TEM (\READDEPTH -1))
          (DECLARE (SPECVARS \READDEPTH))
          (COND
             ([NULL (SETQ TEM (STKPOS '\APPLYREADMACRO]
              (RETURN NIL)))
          (MAPDL [FUNCTION (LAMBDA (NM POS)
                             (COND
                                ((EQ NM '\SUBREAD)
                                 (SETQ \READDEPTH (ADD1 \READDEPTH]
                 TEM)
          (RELSTK TEM)
          (RETURN \READDEPTH])
)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(MOVD? '\ORIG-READ.SYMBOL '\READ.SYMBOL)

(MOVD? '\ORIG-INVALID.SYMBOL '\INVALID.SYMBOL)
)



(* ; "Read macro for '")

(DEFINEQ

(READQUOTE
  [LAMBDA (FILE)                                             (* ; "Edited 19-Mar-87 16:10 by bvm:")
    (LIST 'QUOTE (CL:READ FILE T NIL T])
)



(* ; "# macro")

(DEFINEQ

(READVBAR
  [LAMBDA (STREAM RDTBL)                                     (* bvm%: "14-May-86 17:31")

(* ;;; "Read Interlisp's | macro.  Originally this char was just a sepr in FILERDTBL but was then extended in various hokey ways, because it was the only character plausibly available for redefinition.  Today it is extended still further to be Common Lisp # in all the cases not already taken by some other meaning")

    (SELCHARQ (PEEKCCODE STREAM)
         (%'                                                 (* ; 
                                "commonlisp defines #'X to mean (FUNCTION X), but here it's BQUOTE")
             (READCCODE STREAM)
             (READBQUOTE STREAM RDTBL))
         ((%( { ^)                                           (* ; "Used by HPRINT")
              (HREAD STREAM))
         (%# (READCCODE STREAM)                          (* ; "|# = Common Lisp #")
             (READHASHMACRO STREAM RDTBL))
         ((EOL TAB SPACE)                                    (* ; "CR or tab, treat as separator")
              (CL:VALUES))
         (PROGN                                              (* ; 
               "Everything else not already preempted by old-style | is interpreted as Common Lisp")
                (READHASHMACRO STREAM RDTBL])

(READHASHMACRO
  [LAMBDA (STREAM RDTBL INDEX)                               (* amd "15-Oct-86 16:36")

(* ;;; "Implements the standard # macro dispatch -- reads next character to find out what to do.  Can return zero values if we just want to skip something.")

    (LET ([READFN (COND
                     ((fetch (READTABLEP COMMONLISP) of RDTBL)

                      (* ;; "Kludge: if we have to recursively read something that will not end up as the resulting list structure, use the reader that passes thru CMLTRANSLATE")

                      (FUNCTION CL:READ))
                     (T (FUNCTION READ]
          NEXTCHAR READVAL)
         [while (DIGITCHARP (SETQ NEXTCHAR (PEEKCCODE STREAM RDTBL)))
            do (SETQ INDEX (PLUS (TIMES (OR INDEX 0)
                                            10)
                                     (DIFFERENCE (READCCODE STREAM RDTBL)
                                            (CHARCODE 0]
         (SELCHARQ NEXTCHAR
              ("(" [LET ((CONTENTS (APPLY* READFN STREAM)))
                        (COND
                           (INDEX (FILL-VECTOR (CL:MAKE-ARRAY INDEX)
                                         CONTENTS))
                           (T (CL:MAKE-ARRAY (LENGTH CONTENTS)
                                     :INITIAL-CONTENTS CONTENTS])
              (PROGN                                         (* ; 
 "Those cases we left the dispatching char in buffer for convenience of the next read.  Now eat it")
                     (SELCHARQ (READCCODE STREAM RDTBL)
                          (%' (LIST 'FUNCTION (READ STREAM RDTBL)))
                          (%. (EVAL (APPLY* READFN STREAM)))
                          (%, (LIST 'LOADTIMECONSTANT (READ STREAM RDTBL)))
                          (\ (CHARACTER.READ STREAM))
                          ("*"                               (* ; "Read bit vector")
                               [LET [(CONTENTS (while (MEMQ (PEEKCCODE STREAM RDTBL)
                                                                (CHARCODE (0 1)))
                                                  collect (IDIFFERENCE (READCCODE STREAM 
                                                                                  RDTBL)
                                                                     (CHARCODE 0]
                                    (COND
                                       (INDEX (FILL-VECTOR (CL:MAKE-ARRAY INDEX :ELEMENT-TYPE
                                                                  'BIT)
                                                     CONTENTS))
                                       (T (CL:MAKE-ARRAY (LENGTH CONTENTS)
                                                 :INITIAL-CONTENTS CONTENTS :ELEMENT-TYPE
                                                 'BIT])
                          (":" 
                               (* ;; "The same thing HASH-COLON does.")

                               (CL:MAKE-SYMBOL (READ-EXTENDED-TOKEN STREAM RDTBL)))
                          ((O o) 
                               (READNUMBERINBASE STREAM 8))
                          ((B b) 
                               (READNUMBERINBASE STREAM 2))
                          ((X x) 
                               (READNUMBERINBASE STREAM 16))
                          ((R r) 
                               (READNUMBERINBASE STREAM INDEX))
                          ((A a) 
                               (LET ((CONTENTS (APPLY* READFN STREAM)))
                                    (CL:MAKE-ARRAY (ESTIMATE-DIMENSIONALITY INDEX CONTENTS)
                                           :INITIAL-CONTENTS CONTENTS)))
                          ((S s) 
                               (CREATE-STRUCTURE (APPLY* READFN STREAM)))
                          ((C c) 
                               (DESTRUCTURING-BIND (NUM DEN)
                                      (APPLY* READFN STREAM)
                                      (COMPLEX NUM DEN)))
                          (+                                 (* ; 
                                                           "Skip expression if feature not present")
                             (COND
                                ((NOT (CMLREAD.FEATURE.PARSER (READ STREAM RDTBL)))
                                 (CL:READ STREAM RDTBL)))
                             (CL:VALUES))
                          (-                                 (* ; 
                                                           "Skip expression if feature IS present")
                             (COND
                                ((CMLREAD.FEATURE.PARSER (READ STREAM RDTBL))
                                 (CL:READ STREAM RDTBL)))
                             (CL:VALUES))
                          ("|"                               (* ; "special comment")
                               (SKIP.HASH.COMMENT STREAM RDTBL)
                               (CL:VALUES))
                          (< (ERROR "#< construct is un-READ-able" (READ)))
                          ((SPACE TAB NEWLINE PAGE RETURN %)) 
                               (ERROR "Illegal read syntax " (CHARCODE.UNDECODE NEXTCHAR)))
                          (%"                                (* ; 
                                      "An extension -- read string without cr's and leading spaces")
                              (RSTRING STREAM RDTBL 'SKIP))
                          (APPLY* (OR (GET (CHARACTER NEXTCHAR)
                                           'HASHREADMACRO)
                                      (ERROR "Undefined hashmacro char" NEXTCHAR))
                                 STREAM RDTBL])

(DEFMACRO-LAMBDA-LIST-KEYWORD-P
  [LAMBDA (S)                                                (* bvm%: " 3-Nov-86 15:12")
    (AND (FMEMB S '(&OPTIONAL &REST &KEY &ALLOW-OTHER-KEYS &AUX &BODY &WHOLE))
         T])

(DIGITBASEP
  [LAMBDA (CODE RADIX)                                       (* lmm "11-Jun-85 00:54")
    (COND
       ((AND (GEQ CODE (CHARCODE 0))
             (LESSP CODE (PLUS (CHARCODE 0)
                               RADIX)))
        (DIFFERENCE CODE (CHARCODE 0)))
       ((GREATERP RADIX 10)
        [COND
           ((AND (GEQ CODE (CHARCODE a))
                 (LEQ CODE (CHARCODE z)))
            (add CODE (DIFFERENCE (CHARCODE A)
                                 (CHARCODE a]
        (COND
           ((AND (GEQ CODE (CHARCODE A))
                 (LEQ CODE (CHARCODE Z)))
            [SETQ CODE (PLUS 10 (DIFFERENCE CODE (CHARCODE A]
            (COND
               ((LESSP CODE RADIX)
                CODE])

(READNUMBERINBASE
  [LAMBDA (STREAM RADIX)                                     (* bvm%: " 4-Nov-86 21:34")
    (PROG ((BODY (READ-EXTENDED-TOKEN STREAM))
           (I 1)
           CH VAL NUMERATOR SIGN BASE)                       (* ; "First check for leading sign")
          (if *READ-SUPPRESS*
              then                                       (* ; "work is done")
                    (RETURN NIL))
          (SELCHARQ (SETQ CH (NTHCHARCODE BODY 1))
               (+ (GO NEXTCH))
               (- (SETQ SIGN T)
                  (GO NEXTCH))
               NIL)
      LP  (if (SETQ BASE (DIGITBASEP CH RADIX))
              then (SETQ VAL (+ (TIMES (OR VAL 0)
                                           RADIX)
                                    BASE))
            elseif (EQ CH (CHARCODE "/"))
              then                                       (* ; "Ratio marker")
                    (if (OR NUMERATOR (NULL VAL))
                        then (GO MALFORMED))
                    (SETQ NUMERATOR VAL)
                    (SETQ VAL NIL)
            else                                         (* ; 
                                          "Terminated by a character that is not a token delimiter")
                  (GO MALFORMED))
      NEXTCH
          (if (SETQ CH (NTHCHARCODE BODY (add I 1)))
              then (GO LP)
            else                                         (* ; "end of token, fall thru"))
      DONE
          (if (NULL VAL)
              then (GO MALFORMED))
          (if NUMERATOR
              then (SETQ VAL (%%/ NUMERATOR VAL)))
          (RETURN (if SIGN
                      then (- VAL)
                    else VAL))
      MALFORMED
          (RETURN (CL:ERROR "Malformed base ~D rational ~S" RADIX BODY])

(ESTIMATE-DIMENSIONALITY
  [LAMBDA (RANK CONTENTS)                                    (* bvm%: " 9-May-86 16:06")
    (COND
       ((NULL RANK)
        (ERROR "No rank found while reading array" NIL))
       ((EQ RANK 0)
        NIL)
       (T (to RANK as (D _ CONTENTS) by (CAR D) collect (LENGTH D])

(SKIP.HASH.COMMENT
  [LAMBDA (STREAM RDTBL)                                     (* bvm%: "12-Sep-86 21:02")
    (PROG NIL

     (* ;; "a tiny fsm that recognizes #| ... |# with possible nestings of itself")

      LP  (SELCHARQ (READCCODE STREAM RDTBL)
               ("#" (GO SHARP))
               ("|" (GO VBAR))
               (GO LP))
      SHARP
          (SELCHARQ (READCCODE STREAM RDTBL)
               ("|"                                          (* ; 
                                                           "#| -- recursively skip nested section")
                    (SKIP.HASH.COMMENT STREAM RDTBL)
                    (GO LP))
               ("#" (GO SHARP))
               (GO LP))
      VBAR
          (SELCHARQ (READCCODE STREAM RDTBL)
               ("|" (GO VBAR))
               ("#"                                          (* ; "found closing |#")
                    (RETURN))
               (GO LP])

(CMLREAD.FEATURE.PARSER
  [LAMBDA (EXPR)                                             (* bvm%: " 3-Nov-86 15:07")
    (COND
       ((CL:CONSP EXPR)
        (SELECTQ (CAR EXPR)
            ((:AND AND) 
                 (EVERY (CDR EXPR)
                        (FUNCTION CMLREAD.FEATURE.PARSER)))
            ((:OR OR) 
                 (SOME (CDR EXPR)
                       (FUNCTION CMLREAD.FEATURE.PARSER)))
            ((:NOT NOT) 
                 (NOT (CMLREAD.FEATURE.PARSER (CADR EXPR))))
            (ERROR "Bad feature expression" EXPR)))
       ((FMEMB EXPR *FEATURES*)
        T])
)



(* ; "Reading characters with #\")

(DEFINEQ

(CHARACTER.READ
  [LAMBDA (STREAM)                                           (* bvm%: " 4-Nov-86 21:50")

(* ;;; "Called by the #\ macro -- reads a character object consisting of the thing next named")

    (LET ((NEXTCHAR (READCCODE STREAM))
          CH)
         (COND
            ((OR (NULL (SETQ CH (PEEKCCODE STREAM T)))
                 (fetch STOPATOM of (\SYNCODE (fetch READSA of *READTABLE*)
                                                   CH)))     (* ; 
                                                          "Terminates next, so it's just this char")
             (CL:CODE-CHAR NEXTCHAR))
            (*READ-SUPPRESS*                                 (* ; 
                                                         "don't try to decode it, could be illegal")
                   (READ-EXTENDED-TOKEN STREAM)
                   NIL)
            (T                                               (* ; 
                                                     "Read a whole name, up to the next break/sepr")
               (CL:CODE-CHAR (CHARCODE.DECODE (CONCAT (ALLOCSTRING 1 NEXTCHAR)
                                                         (READ-EXTENDED-TOKEN STREAM])

(CHARCODE.DECODE
  [LAMBDA (C NOERROR)                                        (* ; 
                                                           "Edited  1-Aug-2020 18:52 by rmk:")
                                                             (* ; "Edited 18-Feb-87 22:03 by bvm:")
    (DECLARE (GLOBALVARS CHARACTERNAMES CHARACTERSETNAMES))

    (* ;; "RMK 2020:  Added hexstring decoding for  Unicode:  no commas or other delimiters")

    (* ;; "This overrides the definition in LLREAD.  It should be placed there, but for some reason it is not possible to then recompile that file:  loading a new .LCOM says that \INVALID.SYMBOL is a bad compiled function, and then it loses track of the keyword package. Could be a load-sequence problem that would be resolved if this is installed in a new INIT.SYSOUT rather than an overlay of files already loaded into the LISP.SYSOUT")

    (COND
       ((NOT C)
        NIL)
       ((LISTP C)
        (CONS (CHARCODE.DECODE (CAR C)
                     NOERROR)
              (CHARCODE.DECODE (CDR C)
                     NOERROR)))
       ((NOT (OR (ATOM C)
                 (STRINGP C)))
        (AND (NOT NOERROR)
             (ERROR "BAD CHARACTER SPECIFICATION" C)))
       ((EQ (NCHARS C)
            1)
        (CHCON1 C))
       (T
        (SELCHARQ (CHCON1 C)
             (^ (AND (SETQ C (CHARCODE.DECODE (SUBSTRING C 2 -1)
                                    NOERROR))
                     (LOGAND C (LOGNOT 96))))
             (%# 
                 (* ;; "We use IPLUS instead of LOGOR here because some people want ##char to read as Xerox Meta, i.e., 1,char")

                 (AND (SETQ C (CHARCODE.DECODE (SUBSTRING C 2 -1)
                                     NOERROR))
                      (IPLUS C 128)))
             (LET
              ((STR (MKSTRING C)))
              (for X in CHARACTERNAMES when (STRING.EQUAL (CAR X)
                                                               STR)
                 do (RETURN (OR (NUMBERP (CADR X))
                                    (CHARCODE.DECODE (CADR X)
                                           NOERROR)))
                 finally
                 (RETURN (LET ((POS (STRPOSL '(%, - "." "|")
                                           STR))
                               CH CSET)                      (* ; "In the form charset,char")
                              (COND
                                 ((AND POS (SETQ CH (OR (CL:PARSE-INTEGER STR :START POS :RADIX 8
                                                               :JUNK-ALLOWED T)
                                                        (CHARCODE.DECODE (SUBSTRING STR
                                                                                    (ADD1 POS))
                                                               NOERROR)))
                                       (< CH 256)
                                       (>= CH 0))            (* ; 
                                        "parsed the char part as an octal number or character spec")
                                  (if (AND [SETQ CSET (OR (CL:PARSE-INTEGER STR :END
                                                                     (SUB1 POS)
                                                                     :RADIX 8 :JUNK-ALLOWED T)
                                                              (for PAIR in CHARACTERSETNAMES
                                                                 first (SETQ POS
                                                                            (SUBSTRING STR 1
                                                                                   (SUB1 POS)))
                                                                 when (STRING.EQUAL (CAR PAIR)
                                                                                 POS)
                                                                 do (RETURN (CADR PAIR]
                                               (< CSET 256)
                                               (>= CSET 0))
                                      then               (* ; 
                              "parsed the charset part as an octal number or standard charset name")
                                            (LOGOR CH (LLSH CSET 8))
                                    elseif (NOT NOERROR)
                                      then (ERROR "BAD CHARACTERSET SPECIFICATION" C)))
                                 ((AND (NOT (FIXP C))
                                       (CL:PARSE-INTEGER (CL:IF (EQ 1 (OR (STRPOS "0x" STR)
                                                                              (STRPOS "0X" STR)
                                                                              (STRPOS "U+" STR)))
                                                                 (SUBSTRING STR 3)
                                                                 STR)
                                              :RADIX 16 :JUNK-ALLOWED T)))
                                 ((NOT NOERROR)
                                  (ERROR "BAD CHARACTER SPECIFICATION" C])
)

(RPAQQ CHARACTERNAMES
       (("Page" 12)
        ("Form" 12)
        ("FF" 12)
        ("Rubout" 127)
        ("Del" 127)
        ("Null" 0)
        ("Escape" 27)
        ("Esc" 27)
        ("Bell" 7)
        ("Tab" 9)
        ("Backspace" 8)
        ("Bs" 8)
        ("Newline" 13)
        ("CR" 13)
        ("EOL" 13)
        ("Return" 13)
        ("Tenexeol" 31)
        ("Space" 32)
        ("Sp" 32)
        ("Linefeed" 10)
        ("LF" 10)))

(RPAQQ CHARACTERSETNAMES (("Greek" 38)
                              ("Cyrillic" 39)
                              ("Hira" 36)
                              ("Hiragana" 36)
                              ("Kata" 37)
                              ("Katakana" 37)
                              ("Kanji" 48)))
(DECLARE%: DOEVAL@COMPILE DONTCOPY 

(RPAQQ READTYPES (READ.RT RATOM.RT NOPROPRB.RT PROPRB.RT))
(DECLARE%: EVAL@COMPILE 

(RPAQQ READ.RT NIL)

(RPAQQ RATOM.RT 1)

(RPAQQ NOPROPRB.RT T)

(RPAQQ PROPRB.RT 0)


(CONSTANTS READ.RT RATOM.RT NOPROPRB.RT PROPRB.RT)
)

(DECLARE%: EVAL@COMPILE 

(PUTPROPS .CALL.SUBREAD. MACRO ((STREAM EOF-SUPPRESS EOF-VALUE CHAR PRESERVE-WHITESPACE)
                                        (WITH-RESOURCE (\PNAMESTRING)
                                               (\SUBREAD (\GETSTREAM STREAM 'INPUT)
                                                      (fetch (READTABLEP READSA) of 
                                                                                          *READTABLE*
                                                             )
                                                      (COND
                                                         (CHAR -1)
                                                         (T READ.RT))
                                                      \PNAMESTRING
                                                      (AND (fetch (READTABLEP CASEINSENSITIVE)
                                                              of *READTABLE*)
                                                           (fetch (ARRAYP BASE) of 
                                                                                       UPPERCASEARRAY
                                                                  ))
                                                      EOF-SUPPRESS EOF-VALUE CHAR PRESERVE-WHITESPACE
                                                      ))))

(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])

(PUTPROPS RBCONTEXT MACRO ((X . Y)
                                   ([LAMBDA (\RBFLG)
                                      (DECLARE (SPECVARS \RBFLG))
                                      (PROGN X . Y)
                                      \RBFLG]
                                    NIL)))

(PUTPROPS PROPRB MACRO [(X . Y)                      (* ; 
                                                           "Propagates the right-bracket flag")
                                (AND (RBCONTEXT X . Y)
                                     (OR (EQ READTYPE NOPROPRB.RT)
                                         (SETQ \RBFLG T])

(PUTPROPS \RDCONC MACRO [(ELT . TOPFORMS)

                                 (* ;; "Add ELT to the accumulating list to be returned by \SUBREAD.  If at top level and no list accumulated, then run TOPFORMS")

                                 (COND
                                    [LST (RPLACD END (SETQ END (CONS ELT]
                                    (TOPLEVELP . TOPFORMS)
                                    ((NOT *READ-SUPPRESS*)   (* ; 
                                  "Don't bother consing the result if it's going to be thrown away")
                                     (SETQ END (SETQ LST (CONS ELT])
)

(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 

(PUTPROPS \BACKCHAR MACRO (OPENLAMBDA (STREAM)       (* ; "Backs up over an NS character")
                                    (\BACKNSCHAR STREAM (UNFOLD (ACCESS-CHARSET STREAM)
                                                               256))))

(PUTPROPS \BACKNSCHAR MACRO [(ST SHIFTEDCHARSET COUNTERVAR)
                                     (COND
                                        ((\XCCSP ST)
                                         (\BACKXCCSCHAR ST SHIFTEDCHARSET COUNTERVAR))
                                        (T (COND
                                              ['COUNTERVAR (SETQ COUNTERVAR
                                                            (IDIFFERENCE COUNTERVAR
                                                                   (CL:FUNCALL (ffetch
                                                                                (STREAM BACKCHARFN)
                                                                                  of ST)
                                                                          ST T]
                                              (T (CL:FUNCALL (ffetch (STREAM BACKCHARFN)
                                                                of ST)
                                                        ST NIL])

(PUTPROPS \CHECKEOLC MACRO
          (OPENLAMBDA (CH EOLC STREAM PEEKBINFLG COUNTERVAR)

            (* ;; "Subtracts number of bytes read from COUNTERVAR, which may be NIL.  In fact, should be NIL if PEEKBINFLG is T.")

            (SELCHARQ CH
                 (CR (SELECTC EOLC
                         (CR.EOLC (CHARCODE EOL))
                         (CRLF.EOLC (COND
                                       [PEEKBINFLG 

                                 (* ;; "T from PEEKC, compile-time constant.  In this case, must leave the fileptr where it was, except for possibly advancing over character set shifts")

                                              (COND
                                                 ([EQ (CHARCODE LF)
                                                      (UNINTERRUPTABLY
                                                          (\NSIN STREAM (UNFOLD (ACCESS-CHARSET
                                                                                 STREAM)
                                                                               256))

                                 (* ;; "Read the NS CR.  We know that there aren't any font-shift characters in front of the CR, because they would have already been read by the \NSPEEK that got the CR character.  Since we are going to NS back the CR character, we don't need to update the counter variable")

                                                          (PROG1 (\PEEKBIN STREAM T)

                                 (* ;; "LF must be in next BYTE after NS CR, regardless of coding.  Character-set shifting bytes can't intervene.  Then we back up over the CR that was \NSINed above.")

                                                              (\BACKNSCHAR STREAM)))]
                                                  (CHARCODE EOL))
                                                 (T (CHARCODE CR]
                                       ((EQ (CHARCODE LF)
                                            (\PEEKBIN STREAM T))
                                        (\BIN STREAM)
                                        (AND 'COUNTERVAR (SETQ COUNTERVAR (SUB1 COUNTERVAR)))
                                        (CHARCODE EOL))
                                       (T (CHARCODE CR))))
                         (CHARCODE CR)))
                 (LF (COND
                        ((EQ EOLC LF.EOLC)
                         (CHARCODE EOL))
                        (T (CHARCODE LF))))
                 CH)))

(PUTPROPS \INCHAR MACRO (OPENLAMBDA (STREAM COUNTERVAR)
                                                             (* ; "returns a 16 bit character code")
                                  (\CHECKEOLC (\NSIN STREAM (UNFOLD (ACCESS-CHARSET STREAM)
                                                                   256)
                                                     NIL COUNTERVAR)
                                         (FFETCH EOLCONVENTION OF STREAM)
                                         STREAM NIL COUNTERVAR)))

(PUTPROPS \INCCODE MACRO (OPENLAMBDA (STREAM COUNTERVAR)
                                                             (* ; "returns a 16 bit character code")
                                   (\CHECKEOLC (\NSIN STREAM (UNFOLD (ACCESS-CHARSET STREAM)
                                                                    256)
                                                      NIL COUNTERVAR)
                                          (ffetch EOLCONVENTION of STREAM)
                                          STREAM NIL COUNTERVAR)))

(PUTPROPS \PEEKCCODE MACRO (OPENLAMBDA (STREAM NOERROR)
                                     (\CHECKEOLC (\NSPEEK STREAM (UNFOLD (ACCESS-CHARSET STREAM)
                                                                        256)
                                                        NIL NOERROR)
                                            (ffetch EOLCONVENTION of STREAM)
                                            STREAM T)))

(PUTPROPS \NSIN MACRO [(ST SHIFTEDCSET SHIFTEDCSETVAR COUNTERVAR)

(* ;;; "Dispatches to the appropriate character code decoder.  If you want to support a new character encoding format, you have to write a decoder and add it here.")

                               (COND
                                  ((\XCCSP ST)
                                   (\XCCSIN ST SHIFTEDCSET SHIFTEDCSETVAR COUNTERVAR))
                                  (T (COND
                                        ('COUNTERVAR (CL:MULTIPLE-VALUE-BIND
                                                      (CODE NUM)
                                                      (CL:FUNCALL (ffetch (STREAM INCCODEFN)
                                                                     of ST)
                                                             ST T)
                                                      (AND NUM (SETQ COUNTERVAR (IDIFFERENCE 
                                                                                       COUNTERVAR NUM
                                                                                       )))
                                                      CODE))
                                        (T (CL:FUNCALL (ffetch (STREAM INCCODEFN) of ST)
                                                  ST NIL])

(PUTPROPS \NSPEEK MACRO [(ST SHIFTEDCSET SHIFTEDCSETVAR NOERROR COUNTERVAR)

(* ;;; "Dispatches to the appropriate character code decoder.  If you want to support a new character encoding format, you have to write a decoder and add it here.")

                                 (COND
                                    ((\XCCSP ST)
                                     (\XCCSPEEK ST (UNFOLD (ACCESS-CHARSET ST)
                                                          256)
                                            NIL NOERROR))
                                    (T (COND
                                          ('COUNTERVAR (CL:MULTIPLE-VALUE-BIND
                                                        (CODE NUM)
                                                        (CL:FUNCALL (ffetch (STREAM PEEKCCODEFN)
                                                                       of ST)
                                                               ST NOERROR T)
                                                        (AND NUM (SETQ COUNTERVAR (IDIFFERENCE 
                                                                                         COUNTERVAR 
                                                                                         NUM)))
                                                        CODE))
                                          (T (CL:FUNCALL (ffetch (STREAM PEEKCCODEFN)
                                                            of ST)
                                                    ST NOERROR NIL])

(PUTPROPS NUMERIC-CHARSET MACRO (= . ACCESS-CHARSET))
)

(* "END EXPORTED DEFINITIONS")


(DECLARE%: DOEVAL@COMPILE DONTCOPY

(SPECVARS *READ-NEWLINE-SUPPRESS* \RefillBufferFn)
)

(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS *KEYWORD-PACKAGE* *INTERLISP-PACKAGE*)
)
)



(* ; "Support for various external formats")




(* ; "JIS to XCCS conversion table.")


(RPAQQ *JIS-TO-XCCS-CONV-NO-FONT-TABLE*
       ((8484 . 8484)
        (8485 . 8485)
        (8497 . 9155)
        (8798 . 61376)
        (8802 . 8802)
        (8805 . 64892)
        (8806 . 64894)
        (8820 . 9148)
        (8821 . 9132)
        (8822 . 213)
        (8830 . 8830)
        (10273 . 61189)
        (10274 . 61188)
        (10275 . 10275)
        (10276 . 10276)
        (10277 . 10277)
        (10278 . 10278)
        (10279 . 10279)
        (10280 . 10280)
        (10281 . 10281)
        (10282 . 10282)
        (10283 . 61414)
        (10284 . 61410)
        (10285 . 61409)
        (10286 . 10286)
        (10287 . 10287)
        (10288 . 10288)
        (10289 . 10289)
        (10290 . 10290)
        (10291 . 10291)
        (10292 . 10292)
        (10293 . 10293)
        (10294 . 61411)
        (10295 . 10295)
        (10296 . 10296)
        (10297 . 10297)
        (10298 . 10298)
        (10299 . 10299)
        (10300 . 10300)
        (10301 . 10301)
        (10302 . 10302)
        (10303 . 10303)
        (10304 . 10304)))

(RPAQQ *JIS-TO-XCCS-CODE-MAP*
       ((1 (1 33 . 33)
           (2 33 . 34)
           (3 33 . 35)
           (6 0 . 183)
           (7 0 . 58)
           (8 0 . 59)
           (9 0 . 63)
           (10 0 . 33)
           (11 33 . 43)
           (12 33 . 44)
           (13 0 . 194)
           (14 0 . 193)
           (15 0 . 200)
           (16 0 . 195)
           (18 0 . 204)
           (19 33 . 51)
           (20 33 . 52)
           (21 33 . 53)
           (22 33 . 54)
           (23 33 . 55)
           (24 33 . 56)
           (25 33 . 57)
           (26 33 . 58)
           (27 33 . 59)
           (28 33 . 60)
           (29 239 . 36)
           (30 33 . 62)
           (31 0 . 47)
           (32 0 . 92)
           (33 0 . 126)
           (34 33 . 66)
           (35 0 . 124)
           (36 33 . 68)
           (37 33 . 69)
           (38 0 . 169)
           (39 0 . 39)
           (40 0 . 170)
           (41 0 . 186)
           (42 0 . 40)
           (43 0 . 41)
           (44 33 . 76)
           (45 33 . 77)
           (46 0 . 91)
           (47 0 . 93)
           (48 0 . 123)
           (49 0 . 125)
           (50 239 . 50)
           (51 239 . 51)
           (52 0 . 171)
           (53 0 . 187)
           (54 33 . 86)
           (55 33 . 87)
           (56 33 . 88)
           (57 33 . 89)
           (58 33 . 90)
           (59 33 . 91)
           (60 0 . 43)
           (61 0 . 45)
           (62 0 . 177)
           (63 0 . 180)
           (64 0 . 184)
           (65 0 . 61)
           (66 33 . 98)
           (67 0 . 60)
           (68 0 . 62)
           (69 33 . 101)
           (70 33 . 102)
           (71 33 . 103)
           (72 33 . 104)
           (73 33 . 105)
           (74 33 . 106)
           (75 0 . 176)
           (76 33 . 108)
           (77 33 . 109)
           (78 33 . 110)
           (79 0 . 165)
           (80 0 . 164)
           (81 0 . 162)
           (82 0 . 163)
           (83 0 . 37)
           (84 0 . 35)
           (85 0 . 38)
           (86 0 . 42)
           (87 0 . 64)
           (88 0 . 167)
           (89 33 . 121)
           (90 33 . 122)
           (91 33 . 123)
           (92 33 . 124)
           (93 33 . 125)
           (94 33 . 126))
        (2 (1 34 . 33)
           (2 34 . 34)
           (3 34 . 35)
           (4 34 . 36)
           (5 34 . 37)
           (6 34 . 38)
           (7 34 . 39)
           (8 34 . 40)
           (9 34 . 41)
           (10 0 . 174)
           (11 0 . 172)
           (12 0 . 173)
           (13 0 . 175)
           (14 34 . 46)
           (26 239 . 74)
           (27 239 . 76)
           (28 239 . 89)
           (29 239 . 88)
           (30 239 . 91)
           (31 239 . 90)
           (32 239 . 87)
           (33 239 . 86)
           (42 239 . 182)
           (43 239 . 183)
           (44 239 . 106)
           (45 239 . 79)
           (46 239 . 78)
           (47 239 . 181)
           (48 239 . 180)
           (60 239 . 108)
           (61 239 . 112)
           (63 239 . 186)
           (64 239 . 185)
           (65 239 . 114)
           (67 239 . 66)
           (68 239 . 67)
           (71 239 . 113)
           (72 239 . 111)
           (73 239 . 117)
           (74 34 . 106)
           (82 241 . 40)
           (83 239 . 65)
           (87 239 . 48)
           (88 239 . 49)
           (89 0 . 176))
        (6 (1 38 . 65)
           (2 38 . 66)
           (3 38 . 68)
           (4 38 . 69)
           (5 38 . 70)
           (6 38 . 73)
           (7 38 . 74)
           (8 38 . 75)
           (9 38 . 76)
           (10 38 . 77)
           (11 38 . 78)
           (12 38 . 79)
           (13 38 . 80)
           (14 38 . 81)
           (15 38 . 82)
           (16 38 . 83)
           (17 38 . 85)
           (18 38 . 86)
           (19 38 . 88)
           (20 38 . 89)
           (21 38 . 90)
           (22 38 . 91)
           (23 38 . 92)
           (24 38 . 93)
           (33 38 . 97)
           (34 38 . 98)
           (35 38 . 100)
           (36 38 . 101)
           (37 38 . 102)
           (38 38 . 105)
           (39 38 . 106)
           (40 38 . 107)
           (41 38 . 108)
           (42 38 . 109)
           (43 38 . 110)
           (44 38 . 111)
           (45 38 . 112)
           (46 38 . 113)
           (47 38 . 114)
           (48 38 . 115)
           (49 38 . 117)
           (50 38 . 118)
           (51 38 . 120)
           (52 38 . 121)
           (53 38 . 122)
           (54 38 . 123)
           (55 38 . 124)
           (56 38 . 125))))

(RPAQQ *HANKAKU-TO-ZENKAKU-CODE-MAP*
       ((161 . 8483)
        (162 . 8534)
        (163 . 8535)
        (164 . 8482)
        (165 . 183)
        (166 . 9586)
        (167 . 9505)
        (168 . 9507)
        (169 . 9509)
        (170 . 9511)
        (171 . 9513)
        (172 . 9571)
        (173 . 9573)
        (174 . 9575)
        (175 . 9539)
        (176 . 8508)
        (177 . 9506)
        (178 . 9508)
        (179 . 9510)
        (180 . 9512)
        (181 . 9514)
        (182 . 9515)
        (183 . 9517)
        (184 . 9519)
        (185 . 9521)
        (186 . 9523)
        (187 . 9525)
        (188 . 9527)
        (189 . 9529)
        (190 . 9531)
        (191 . 9533)
        (192 . 9535)
        (193 . 9537)
        (194 . 9540)
        (195 . 9542)
        (196 . 9544)
        (197 . 9546)
        (198 . 9547)
        (199 . 9548)
        (200 . 9549)
        (201 . 9550)
        (202 . 9551)
        (203 . 9554)
        (204 . 9557)
        (205 . 9560)
        (206 . 9563)
        (207 . 9566)
        (208 . 9567)
        (209 . 9568)
        (210 . 9569)
        (211 . 9570)
        (212 . 9572)
        (213 . 9574)
        (214 . 9576)
        (215 . 9577)
        (216 . 9578)
        (217 . 9579)
        (218 . 9580)
        (219 . 9581)
        (220 . 9583)
        (221 . 9587)
        (222 . 8491)
        (223 . 8492)))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS *JIS-TO-XCCS-CONV-NO-FONT-TABLE* *JIS-TO-XCCS-CONV-TABLE-LIST* *JIS-TO-XCCS-CODE-MAP* 
       *HANKAKU-TO-ZENKAKU-CODE-MAP* *JIS-1KU-TO-XCCS-CONV-TABLE* *JIS-2KU-TO-XCCS-CONV-TABLE* 
       *JIS-6KU-TO-XCCS-CONV-TABLE* *XCCS-TO-JIS-CONV-TABLE* *HANKAKU-TO-ZENKAKU-CONV-TABLE* 
       *ZENKAKU-TO-HANKAKU-CONV-TABLE*)
)
(DEFINEQ

(\MAKE.JIS.TO.XCCS.CONV.TABLE
  [LAMBDA NIL                                                (* ; "Edited 20-Feb-91 19:28 by nm")

(* ;;; "The JIS codes which are not equivalent to XCCS reside in 1, 2, 3, 6, 8 and 84 KU.  In case of 3 and 84 KU, the corresponding XCCS is calicutated from JIS.  In case of 1,2 and 6 KU, we have to prepare conversion tables for each because the mapping between XCCS and JIS are random.  8 KU is treated specially because no displayable font is assigned for 8 KU in XCCS.  They are handled with *JIS-TO-XCCS-CONV-NO-FONT-TABLE*.")

(* ;;; "Each conversion table is an byte array of size 188 (94 * 2).  94 is a largest number of TEN.  TEN is one origin.  Each JIS code is represented with two bytes in the table.  The first byte is a character set and the second byte is a character code in XCCS.  If both of the first byte and the second byte are 255, it means the JIS code is not defined for the entry.  If the first byte is 255 and the second byte is 0, it means a JIS code is defined for the entry and there is a XCCS code corresponding to the JIS code, but no displayable font is assigned for the code in XCCS.  In the last case, the real XCCS code is found in *JIS-TO-XCCS-CONV-NO-FONT-TABLE*.")

(* ;;; "*HANKAKU-TO-ZENKAKU-CONV-TABLE* holds the mapping between JIS HANAKAKU-KANA code to XCCS.  XCCS does not support HANKAKU code.")

    (SETQ *JIS-1KU-TO-XCCS-CONV-TABLE* (ARRAY 188 'BYTE 255))
    (SETQ *JIS-2KU-TO-XCCS-CONV-TABLE* (ARRAY 188 'BYTE 255))
    (SETQ *JIS-6KU-TO-XCCS-CONV-TABLE* (ARRAY 188 'BYTE 255))
    (SETQ *XCCS-TO-JIS-CONV-TABLE* (HASHARRAY 256))
    (SETQ *HANKAKU-TO-ZENKAKU-CONV-TABLE* (HASHARRAY 64))
    (SETQ *ZENKAKU-TO-HANKAKU-CONV-TABLE* (HASHARRAY 64))
    (CL:DO ((TABLES (LIST *JIS-1KU-TO-XCCS-CONV-TABLE* *JIS-2KU-TO-XCCS-CONV-TABLE* 
                          *JIS-6KU-TO-XCCS-CONV-TABLE*)
                   (CDR TABLES))
            (KU '(1 2 6)
                (CDR KU))
            CODEMAP)
           ((CL:ENDP TABLES))
        (SETQ CODEMAP (CDR (ASSOC (CAR KU)
                                  *JIS-TO-XCCS-CODE-MAP*)))
        (for MAP in CODEMAP do (SETA (CAR TABLES)
                                                 (IDIFFERENCE (UNFOLD (CAR MAP)
                                                                     2)
                                                        1)
                                                 (CADR MAP))
                                          (SETA (CAR TABLES)
                                                (UNFOLD (CAR MAP)
                                                       2)
                                                (CDDR MAP))))
    (bind KU TEN TABLE for ENTRY in *JIS-TO-XCCS-CONV-NO-FONT-TABLE*
       do (SETQ KU (IDIFFERENCE (FOLDLO (CAR ENTRY)
                                           256)
                              32))
             (SETQ TABLE (SELECTQ KU
                             (1 *JIS-1KU-TO-XCCS-CONV-TABLE*)
                             (2 *JIS-2KU-TO-XCCS-CONV-TABLE*)
                             (6 *JIS-6KU-TO-XCCS-CONV-TABLE*)
                             NIL))
             (AND TABLE (SETA TABLE (UNFOLD (IDIFFERENCE (LOGAND 255 (CAR ENTRY))
                                                   32)
                                           2)
                              0)))
    (for MAP in *HANKAKU-TO-ZENKAKU-CODE-MAP* do (PUTHASH (CAR MAP)
                                                                    (CDR MAP)
                                                                    *HANKAKU-TO-ZENKAKU-CONV-TABLE*))
    (for MAP in *HANKAKU-TO-ZENKAKU-CODE-MAP* do (PUTHASH (CDR MAP)
                                                                    (CAR MAP)
                                                                    *ZENKAKU-TO-HANKAKU-CONV-TABLE*))
    (for MAP
       in (APPEND [for KU in *JIS-TO-XCCS-CODE-MAP*
                         join (for TEN in (CDR KU)
                                     collect `(,(LOGOR (UNFOLD (CADR TEN)
                                                                  256)
                                                           (CDDR TEN))
                                                   \,
                                                   (LOGOR (UNFOLD (IPLUS (CAR KU)
                                                                         32)
                                                                 256)
                                                          (IPLUS (CAR TEN)
                                                                 32]
                     *JIS-TO-XCCS-CONV-NO-FONT-TABLE*) do (PUTHASH (CAR MAP)
                                                                     (CDR MAP)
                                                                     *XCCS-TO-JIS-CONV-TABLE*))
    (SETQ *JIS-TO-XCCS-CONV-TABLE-LIST* `((33 \, *JIS-1KU-TO-XCCS-CONV-TABLE*)
                                          (34 \, *JIS-2KU-TO-XCCS-CONV-TABLE*)
                                          (38 \, *JIS-6KU-TO-XCCS-CONV-TABLE*])
)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(\MAKE.JIS.TO.XCCS.CONV.TABLE)
)



(* ; "JIS to XCCS converter")


(RPAQ? *REPLACE-NO-FONT-CODE* T)

(RPAQ? *DEFAULT-NOT-CONVERTED-FAT-CODE* 8739)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS *REPLACE-NO-FONT-CODE* *DEFAULT-NOT-CONVERTED-FAT-CODE*)
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY 
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 

(PUTPROPS \CONV.JIS.TO.XCCS MACRO [OPENLAMBDA (KU TEN)

(* ;;; "Some character code is not equivalent between JIS and XCCS.  In such case, we have to convert the character to corresponding XCCS.")

                                            (COND
                                               ((\NOT.EQUIVALENT.TO.XCCS KU)
                                                (\DO.CONV.JIS.TO.XCCS KU TEN))
                                               (T (LOGOR (UNFOLD KU 256)
                                                         TEN])

(PUTPROPS \DO.CONV.JIS.TO.XCCS MACRO
          [(KU TEN)

(* ;;; " Convert a JIS code divided into KU (high 8 bit) and TEN (low 8 bit) to an corresponding XCCS code.")

           (COND
              ((\INVALID.TENP TEN)
               *DEFAULT-NOT-CONVERTED-FAT-CODE*)
              (T (SELECTQ KU
                     ((33 34 38)                             (* ; "1, 2 and 6 KU")
                          [LET* ((CONVTABLE (\EXTARACT.CONV.TABLE KU))
                                 (SET (\EXTRACT.SET TEN CONVTABLE))
                                 (CODE (\EXTRACT.CODE TEN CONVTABLE)))
                                (COND
                                   ((NEQ SET 255)
                                    (LOGOR (UNFOLD SET 256)
                                           CODE))
                                   (T (COND
                                         ((EQ CODE 255)      (* ; "Not defined in JIS.")
                                          *DEFAULT-NOT-CONVERTED-FAT-CODE*)
                                         (T                  (* ; 
       "Defined in JIS but the displayable font is not assigned in the corresponding code in XCCS.")
                                            (COND
                                               (*REPLACE-NO-FONT-CODE* 
                                                      *DEFAULT-NOT-CONVERTED-FAT-CODE*)
                                               (T (\EXTRACT.NO.FONT.CODE (LOGOR (UNFOLD KU 256)
                                                                                TEN])
                     (35                                     (* ; "3 KU")
                                                             (* ; 
                                "Alpha numeric codes are all defined as single byte codes in XCCS.")
                         TEN)
                     (40                                     (* ; "8 KU")
                         (COND
                            [(< 0 TEN 33)
                             (COND
                                (*REPLACE-NO-FONT-CODE* *DEFAULT-NOT-CONVERTED-FAT-CODE*)
                                (T (\EXTRACT.NO.FONT.CODE (LOGOR KU TEN]
                            (T *DEFAULT-NOT-CONVERTED-FAT-CODE*)))
                     (116                                    (* ; "84 KU")
                          (COND
                             ((< 0 TEN 5)
                              (LOGOR 29952 TEN))
                             (T *DEFAULT-NOT-CONVERTED-FAT-CODE*)))
                     (117                                    (* ; "85 KU")
                          (COND
                             ((< 0 TEN 28)
                              (LOGOR 29696 TEN))
                             (T *DEFAULT-NOT-CONVERTED-FAT-CODE*)))
                     *DEFAULT-NOT-CONVERTED-FAT-CODE*])
)

(* "END EXPORTED DEFINITIONS")

)



(* ; "XCCS to JIS converter")

(DEFINEQ

(CONVHANKAKU
  [LAMBDA ARGS                                               (* ; "Edited  8-Feb-91 13:42 by nm")
    (PROG1 (STREAMPROP (ARG ARGS 1)
                  :HTOZP)
        (AND (> ARGS 1)
             (STREAMPROP (ARG ARGS 1)
                    :HTOZP
                    (ARG ARGS 2))))])
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY 
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 

(PUTPROPS \CONV.XCCS.TO.JIS MACRO (OPENLAMBDA (OUTSTREAM CC)

(* ;;; "Returns JIS code corresponding to XCCS charcode.  Handle HANKAKU as well as ZENKAKU.  If OUTSTREAM wants to convert ZENKAKUKANA to HANKAKUKANA, do so.  Never returns two byte charcode for alpha-numeric character, they are all treated as single byte characode.")

                                            (OR (COND
                                                   ((\ASCIIP CC)
                                                    CC)
                                                   ((\NOT.EQUIVALENT.TO.JIS CC)
                                                    (\DO.CONV.XCCS.TO.JIS CC))
                                                   ((\CONV.HANKAKU.TO.ZENKAKUP OUTSTREAM)
                                                             (* ; 
                          "ZENKAKUKANA comes here, because their charcodes are equiavalent to JIS.")
                                                    (\CONV.ZENKAKU.KANA CC))
                                                   (T CC))
                                                CC)))

(PUTPROPS \DO.CONV.XCCS.TO.JIS MACRO ((CC)
                                              (GETHASH CC *XCCS-TO-JIS-CONV-TABLE*)))

(PUTPROPS \ASCIIP MACRO (OPENLAMBDA (CC)
                                  (AND (EQ (FOLDLO CC 256)
                                           0)
                                       (< (LOGAND CC 255)
                                          128))))

(PUTPROPS \NOT.EQUIVALENT.TO.JIS MACRO (OPENLAMBDA (CC)
                                                 (OR (EQ (FOLDLO CC 256)
                                                         0)
                                                     (EQ (FOLDLO CC 256)
                                                         33)
                                                     (EQ (FOLDLO CC 256)
                                                         34)
                                                     (EQ (FOLDLO CC 256)
                                                         38)
                                                     (EQ (FOLDLO CC 256)
                                                         40)
                                                     (EQ (FOLDLO CC 256)
                                                         239)
                                                     (EQ (FOLDLO CC 256)
                                                         241))))

(PUTPROPS \CONV.HANKAKU.TO.ZENKAKUP MACRO ((OUTSTREAM)
                                                   (STREAMPROP OUTSTREAM :HTOZP)))

(PUTPROPS \CONV.ZENKAKU.KANA MACRO ((CHAR)
                                            (GETHASH CHAR *ZENKAKU-TO-HANKAKU-CONV-TABLE*)))
)

(* "END EXPORTED DEFINITIONS")

)
(DEFINEQ

(\JISIN
  [LAMBDA (STREAM COUNTP)                                    (* ; "Edited 25-Feb-91 15:47 by nm")

(* ;;; "Returns a 16 bit XCCS code.  Assuming the input character stream is encoded with JIS.  Allows the incorrect usage of KI and KO based on the two different JIS, OLDJIS and NEWJIS, because it is very likely that these two different sets of KI and KO are used simultaneously, although it is against a standard!  ")

(* ;;; "If COUNP is non-NIL, the number of bytes read is returned as a second value.  Doesn't do EOL conversion -- \INCHAR or \INCCODE do that.")

    (PROG (CH1 CH2 CH3 (IN16BITFLG (\KIMODEP STREAM T))
               (CHARNUM 0))
      RETRY
          (AND (SETQ CH1 (\BIN STREAM))
               (COND
                  [(EQ CH1 (CHARCODE ESC))                   (* ; "Might be KI or KO.")
                   (SETQ CH2 (\BIN STREAM))
                   (COND
                      [(EQ CH2 (CHARCODE $))                 (* ; "Might be KI")
                       (SETQ CH3 (\BIN STREAM))
                       (COND
                          ((OR (EQ CH3 (CHARCODE B))
                               (EQ CH3 (CHARCODE @)))        (* ; "KI")
                           (\CHNAGE.KI.MODE STREAM T T)
                           (AND COUNTP (SETQ CHARNUM (IPLUS CHARNUM 3)))
                                                             (* ; "Here we have to try the same preocedure again, because bogus duplicated KI/KO sequence might come again!")
                           (SETQ IN16BITFLG T)
                           (GO RETRY))
                          (T (COND
                                [IN16BITFLG                  (* ; "Under processing 16 bit code.")
                                       (\BACKFILEPTR STREAM)
                                       (COND
                                          [COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS CH1 CH2)
                                                                 (IPLUS 2 CHARNUM]
                                          (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2]
                                (T (\BACKFILEPTR STREAM)
                                   (\BACKFILEPTR STREAM)
                                   (COND
                                      [COUNTP (RETURN (CL:VALUES (CHARCODE ESC)
                                                             (IPLUS 1 CHARNUM]
                                      (T (RETURN (CHARCODE ESC]
                      [(EQ CH2 (CHARCODE %())                (* ; "Might be KO")
                       (SETQ CH3 (\BIN STREAM))
                       (COND
                          ((OR (EQ CH3 (CHARCODE J))
                               (EQ CH3 (CHARCODE H)))        (* ; "KO")
                           (\CHNAGE.KI.MODE STREAM T NIL)
                           (AND COUNTP (SETQ CHARNUM (IPLUS CHARNUM 3)))
                                                             (* ; 
                            "Oops.  Yes, we have to try again to ignore duplicated KI/KO sequence.")
                           (SETQ IN16BITFLG NIL)
                           (GO RETRY))
                          (T (COND
                                [IN16BITFLG                  (* ; "Under processing 16 bit code.")
                                       (\BACKFILEPTR STREAM)
                                       (COND
                                          [COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS CH1 CH2)
                                                                 (IPLUS 2 CHARNUM]
                                          (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2]
                                (T (\BACKFILEPTR STREAM)
                                   (\BACKFILEPTR STREAM)
                                   (COND
                                      [COUNTP (RETURN (CL:VALUES (CHARCODE ESC)
                                                             (IPLUS 1 CHARNUM]
                                      (T (RETURN (CHARCODE ESC]
                      [IN16BITFLG                            (* ; "Under processing 16 bit code.")
                             (COND
                                [COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS CH1 CH2)
                                                       (IPLUS 2 CHARNUM]
                                (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2]
                      (T (\BACKFILEPTR STREAM)
                         (COND
                            [COUNTP (RETURN (CL:VALUES (CHARCODE ESC)
                                                   (IPLUS 1 CHARNUM]
                            (T (RETURN (CHARCODE ESC]
                  [IN16BITFLG                                (* ; "Under processing 16 bit code.")
                         (COND
                            [COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS CH1 (\BIN STREAM))
                                                   (IPLUS 2 CHARNUM]
                            (T (RETURN (\CONV.JIS.TO.XCCS CH1 (\BIN STREAM]
                  [(\HANKAKUP CH1)                           (* ; 
"HANKAKU-KATAKANA is converted to ZENKAKU-KATAKANA because XCCS does not support HANKAKU-KATAKANA.")
                   (COND
                      [COUNTP (RETURN (CL:VALUES (\CONV.HANKAKU.KANA CH1)
                                             (IPLUS 1 CHARNUM]
                      (T (RETURN (\CONV.HANKAKU.KANA CH1]
                  (T 
                     (* ;; "C0, SP, DEL, C1, 10/0, or 15/15 of 0 character set.")

                     (COND
                        [COUNTP (RETURN (CL:VALUES CH1 (IPLUS 1 CHARNUM]
                        (T (RETURN CH1])

(\JISPEEK
  [LAMBDA (STREAM NOERROR COUNTP)                            (* ; "Edited 25-Feb-91 16:27 by nm")

(* ;;; "Returns a 16 bit XCCS code.  Assuming the input character stream is encoded with JIS.  Allows the incorrect usage of KI and KO based on the two different JIS, OLDJIS and NEWJIS, because it is very likely that these two different sets of KI and KO are used simultaneously, although it is against a standard!  May actually read the KI or KO.  ")

(* ;;; "If COUNTP is non-NIL, the number of bytes read is returned as a second value.  Doesn't do EOL conversion -- \INCHAR or \INCCODE do that.")

    (PROG ((IN16BITFLG (\KIMODEP STREAM T))
           (CHARNUM 0)
           (CH1 (\PEEKBIN STREAM NOERROR))
           CH2 CH3)
      RETRY
          (COND
             [(NULL CH1)
              (COND
                 (COUNTP (RETURN (CL:VALUES NIL CHARNUM)))
                 (T (RETURN NIL]
             [(EQ CH1 (CHARCODE ESC))                        (* ; "Might be KI or KO.")
              (\BIN STREAM)                                  (* ; "Consume the first ESC.")
              (SETQ CH2 (\PEEKBIN STREAM NOERROR))
              (COND
                 [(NULL CH2)
                  (\BACKFILEPTR STREAM)
                  (COND
                     (COUNTP (RETURN (CL:VALUES NIL CHARNUM)))
                     (T (RETURN NIL]
                 [(EQ CH2 (CHARCODE $))                      (* ; "Might be KI")
                  (\BIN STREAM)                              (* ; "Consume the $.")
                  (SETQ CH3 (\PEEKBIN STREAM NOERROR))
                  (COND
                     [(NULL CH3)
                      (\BACKFILEPTR STREAM)
                      (\BACKFILEPTR STREAM)
                      (COND
                         (COUNTP (RETURN (CL:VALUES NIL CHARNUM)))
                         (T (RETURN NIL]
                     ((OR (EQ CH3 (CHARCODE B))
                          (EQ CH3 (CHARCODE @)))             (* ; "KI")
                      (\CHNAGE.KI.MODE STREAM T T)
                      (AND COUNTP (SETQ CHARNUM (IPLUS CHARNUM 3)))
                      (\BIN STREAM)                          (* ; "Consume the B or @.")
                      (SETQ IN16BITFLG T)
                      (GO RETRY))
                     (T (\BACKFILEPTR STREAM)
                        (\BACKFILEPTR STREAM)
                        (COND
                           [IN16BITFLG                       (* ; "Under processing 16 bit code.")
                                  (COND
                                     (COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS CH1 CH2)
                                                            CHARNUM)))
                                     (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2]
                           (T (COND
                                 (COUNTP (RETURN (CL:VALUES (CHARCODE ESC)
                                                        CHARNUM)))
                                 (T (RETURN (CHARCODE ESC]
                 [(EQ CH2 (CHARCODE %())                     (* ; "Might be KO")
                  (\BIN STREAM)                              (* ; "Consume the (.")
                  (SETQ CH3 (\PEEKBIN STREAM NOERROR))
                  (COND
                     [(NULL CH3)
                      (\BACKFILEPTR STREAM)
                      (\BACKFILEPTR STREAM)
                      (COND
                         (COUNTP (RETURN (CL:VALUES NIL CHARNUM)))
                         (T (RETURN NIL]
                     ((OR (EQ CH3 (CHARCODE J))
                          (EQ CH3 (CHARCODE H)))             (* ; "KO")
                      (\CHNAGE.KI.MODE STREAM T NIL)
                      (AND COUNTP (SETQ CHARNUM 3))
                      (\BIN STREAM)                          (* ; "Consume the J or H.")
                      (SETQ IN16BITFLG NIL)
                      (GO RETRY))
                     (T (\BACKFILEPTR STREAM)
                        (\BACKFILEPTR STREAM)
                        (COND
                           [IN16BITFLG                       (* ; "Under processing 16 bit code.")
                                  (COND
                                     (COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS CH1 CH2)
                                                            CHARNUM)))
                                     (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2]
                           (T (COND
                                 (COUNTP (RETURN (CL:VALUES (CHARCODE ESC)
                                                        CHARNUM)))
                                 (T (RETURN (CHARCODE ESC]
                 [IN16BITFLG                                 (* ; "Under processing 16 bit code.")
                        (\BACKFILEPTR STREAM)
                        (COND
                           (COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS CH1 CH2)
                                                  CHARNUM)))
                           (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2]
                 (T (\BACKFILEPTR STREAM)
                    (COND
                       (COUNTP (RETURN (CL:VALUES (CHARCODE ESC)
                                              CHARNUM)))
                       (T (RETURN (CHARCODE ESC]
             [IN16BITFLG                                     (* ; "Under processing 16 bit code.")
                    (\BIN STREAM)                            (* ; "Consume the first byte.")
                    (SETQ CH2 (\PEEKBIN STREAM NOERROR))
                    (\BACKFILEPTR STREAM)
                    (COND
                       [CH2 (COND
                               (COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS CH1 CH2)
                                                      CHARNUM)))
                               (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2]
                       (T (COND
                             (COUNTP (RETURN (CL:VALUES NIL CHARNUM)))
                             (T (RETURN NIL]
             [(\HANKAKUP CH1)                                (* ; 
"HANKAKU-KATAKANA is converted to ZENKAKU-KATAKANA because XCCS does not support HANKAKU-KATAKANA.")
              (COND
                 (COUNTP (RETURN (CL:VALUES (\CONV.HANKAKU.KANA CH1)
                                        CHARNUM)))
                 (T (RETURN (\CONV.HANKAKU.KANA CH1]
             (T 
                (* ;; "C0, SP, DEL, C1, 10/0, or 15/15 of 0 character set.")

                (COND
                   (COUNTP (RETURN (CL:VALUES CH1 CHARNUM)))
                   (T (RETURN CH1])

(\BACKJISCHAR
  [LAMBDA (STREAM COUNTP)                                    (* ; "Edited 25-Feb-91 17:05 by nm")
    (COND
       ((\BACKFILEPTR STREAM)
        (COND
           [(\KIMODEP STREAM T)
            (COND
               ((\BACKFILEPTR STREAM)
                (AND COUNTP 2))
               (T (AND COUNTP 1]
           (COUNTP 1)))
       (COUNTP 0])

(\SHIFTJISIN
  [LAMBDA (STREAM COUNTP)                                    (* ; "Edited 25-Feb-91 15:49 by nm")

(* ;;; "Returns a 16 bit XCCS code.  Assuming the input character stream is encoded with Shift-JIS.  If COUNP is non-NIL, the number of bytes read is returned as a second value.  Doesn't do EOL conversion -- \INCHAR or \INCCODE do that..")

    (LET ((CH1 (\BIN STREAM))
          CH2)
         (AND CH1 (COND
                     [(\SJIS.KANJI.FIRST.BYTEP CH1)          (* ; 
                                                    "Read next byte and compose a kanji character.")
                      (\CONV.SJIS.TO.JIS CH1 (\BIN STREAM))  (* ; 
                              "CH1 and CH2 is adjusted to represent JIS code in \CONV.SJIS.TO.JIS.")
                      (COND
                         (COUNTP (CL:VALUES (\CONV.JIS.TO.XCCS CH1 CH2)
                                        2))
                         (T (\CONV.JIS.TO.XCCS CH1 CH2]
                     (T                                      (* ; "ASCII or HANKAKU-KATAKANA")
                        (COND
                           [(\HANKAKUP CH1)                  (* ; "HANKAKU-KATAKANA")
                            (COND
                               (COUNTP (CL:VALUES (\CONV.HANKAKU.KANA CH1)
                                              1))
                               (T (\CONV.HANKAKU.KANA CH1]
                           (T                                (* ; "ASCII")
                              (COND
                                 (COUNTP (CL:VALUES CH1 1))
                                 (T CH1])

(\SHIFTJISPEEK
  [LAMBDA (STREAM NOERROR COUNTP)                            (* ; "Edited 25-Feb-91 16:30 by nm")

(* ;;; "Returns a 16 bit XCCS code.  Assuming the input character stream is encoded with Shift-JIS. Doesn't do EOL conversion -- \INCHAR or \INCCODE do that.")

    (PROG ((CH1 (\PEEKBIN STREAM NOERROR))
           CH2)
          (COND
             [(NULL CH1)
              (COND
                 (COUNTP (RETURN (CL:VALUES NIL 0)))
                 (T (RETURN NIL]
             [(\SJIS.KANJI.FIRST.BYTEP CH1)                  (* ; 
                                                    "Read next byte and compose a kanji character.")
              (\BIN STREAM)                                  (* ; "Consume the first byte.")
              [COND
                 ((NULL (SETQ CH2 (\PEEKBIN STREAM NOERROR)))
                  (\BACKFILEPTR STREAM)
                  (COND
                     (COUNTP (RETURN (CL:VALUES NIL 0)))
                     (T (RETURN NIL]
              (\BACKFILEPTR STREAM)
              (\CONV.SJIS.TO.JIS CH1 CH2)                    (* ; 
                              "CH1 and CH2 is adjusted to represent JIS code in \CONV.SJIS.TO.JIS.")
              (COND
                 (COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS CH1 CH2)
                                        0)))
                 (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2]
             (T                                              (* ; "ASCII or HANKAKU-KATAKANA")
                (RETURN (COND
                           [(\HANKAKUP CH1)                  (* ; "HANKAKU-KATAKANA")
                            (COND
                               (COUNTP (RETURN (CL:VALUES (\CONV.HANKAKU.KANA CH1)
                                                      0)))
                               (T (RETURN (\CONV.HANKAKU.KANA CH1]
                           (T                                (* ; "ASCII")
                              (COND
                                 (COUNTP (RETURN (CL:VALUES CH1 0)))
                                 (T (RETURN CH1])

(\BACKSHIFTJISCHAR
  [LAMBDA (STREAM COUNTP)                                    (* ; "Edited 25-Feb-91 17:05 by nm")
    (COND
       ((\BACKFILEPTR STREAM)
        (COND
           [(\BACKFILEPTR STREAM)
            (COND
               ((\SJIS.KANJI.FIRST.BYTEP (\PEEKBIN STREAM))
                (AND COUNTP 2))
               (T (\BIN STREAM)
                  (AND COUNTP 1]
           (COUNTP 1)))
       (COUNTP 0])

(\EUCIN
  [LAMBDA (STREAM COUNTP)                                    (* ; "Edited 25-Feb-91 15:54 by nm")

(* ;;; "Returns a 16 bit XCCS code.  Assuming the input character stream is encoded with EUC (Extended Unix Codes).  Although EUC is independent of a particular language, the language implemented here is Japanese, thus this should be called as UJIS (Unixnized extended JIS code).  JEIDA uses EUC as UJIS.  ")

(* ;;; "If COUNP is non-NIL, the number of bytes read is returned as a second value.  Doesn't do EOL conversion -- \INCHAR or \INCCODE do that.")

    (LET ((CH1 (\BIN STREAM))
          CH2)
         (AND CH1 (COND
                     [(\EUC.KANJI.FIRST.BYTEP CH1)           (* ; 
                                                    "Read next byte and compose a kanji character.")
                      (COND
                         (COUNTP (CL:VALUES (\CONV.JIS.TO.XCCS (LOGAND CH1 127)
                                                   (LOGAND (\BIN STREAM)
                                                          127))
                                        2))
                         (T (\CONV.JIS.TO.XCCS (LOGAND CH1 127)
                                   (LOGAND (\BIN STREAM)
                                          127]
                     [(\EUC.HANKAKUP CH1)
                      (COND
                         (COUNTP (CL:VALUES (\CONV.HANKAKU.KANA (\BIN STREAM))
                                        2))
                         (T (\CONV.HANKAKU.KANA (\BIN STREAM]
                     [(\GAIJIP CH1)
                      (COND
                         (COUNTP (CL:VALUES (\CONV.JIS.TO.XCCS (LOGAND (\BIN STREAM)
                                                                      127)
                                                   (LOGAND (\BIN STREAM)
                                                          127))
                                        3))
                         (T (\CONV.JIS.TO.XCCS (LOGAND (\BIN STREAM)
                                                      127)
                                   (LOGAND (\BIN STREAM)
                                          127]
                     (T                                      (* ; "ASCII, C0, C1, SP or DEL")
                        (COND
                           (COUNTP (CL:VALUES CH1 1))
                           (T CH1])

(\EUCPEEK
  [LAMBDA (STREAM NOERROR COUNTP)                            (* ; "Edited 25-Feb-91 16:35 by nm")

(* ;;; "Returns a 16 bit XCCS code.  Assuming the input character stream is encoded with EUC (Extended Unix Codes).  Although EUC is independent of a particular language, the language implemented here is Japanese, thus this should be called as UJIS (Unixnized extended JIS code).  JEIDA uses EUC as UJIS. Doesn't do EOL conversion -- \INCHAR or \INCCODE do that.")

    (PROG ((CH1 (\PEEKBIN STREAM NOERROR))
           CH2)
          (COND
             [(NULL CH1)
              (COND
                 (COUNTP (RETURN (CL:VALUES NIL 0)))
                 (T (RETURN NIL]
             [(\EUC.KANJI.FIRST.BYTEP CH1)                   (* ; 
                                                    "Read next byte and compose a kanji character.")
              (\BIN STREAM)                                  (* ; "Consume the first byte.")
              [COND
                 ((NULL (SETQ CH2 (\PEEKBIN STREAM NOERROR)))
                  (\BACKFILEPTR STREAM)
                  (COND
                     (COUNTP (RETURN (CL:VALUES NIL 0)))
                     (T (RETURN NIL]
              (\BACKFILEPTR STREAM)
              (COND
                 (COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS (LOGAND CH1 127)
                                                   (LOGAND CH2 127))
                                        0)))
                 (T (RETURN (\CONV.JIS.TO.XCCS (LOGAND CH1 127)
                                   (LOGAND CH2 127]
             [(\EUC.HANKAKUP CH1)
              (\BIN STREAM)                                  (* ; "Consume the SS2.")
              [COND
                 ((NULL (SETQ CH2 (\PEEKBIN STREAM NOERROR)))
                  (\BACKFILEPTR STREAM)
                  (COND
                     (COUNTP (RETURN (CL:VALUES NIL 0)))
                     (T (RETURN NIL]
              (\BACKFILEPTR STREAM)
              (COND
                 (COUNTP (RETURN (CL:VALUES (\CONV.HANKAKU.KANA CH2)
                                        0)))
                 (T (RETURN (\CONV.HANKAKU.KANA CH2]
             [(\GAIJIP CH1)
              (\BIN STREAM)                                  (* ; "Consume the SS3.")
              [COND
                 ((NULL (SETQ CH1 (\PEEKBIN STREAM NOERROR)))
                  (\BACKFILEPTR STREAM)
                  (COND
                     (COUNTP (RETURN (CL:VALUES NIL 0)))
                     (T (RETURN NIL]
              (\BIN STREAM)                                  (* ; 
                                                           "Consume the first byte in GAIJI.")
              [COND
                 ((NULL (SETQ CH2 (\PEEKBIN STREAM NOERROR)))
                  (\BACKFILEPTR STREAM)
                  (\BACKFILEPTR STREAM)
                  (COND
                     (COUNTP (RETURN (CL:VALUES NIL 0)))
                     (T (RETURN NIL]
              (\BACKFILEPTR STREAM)
              (\BACKFILEPTR STREAM)
              (COND
                 (COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS (LOGAND CH1 127)
                                                   (LOGAND CH2 127))
                                        0)))
                 (T (RETURN (\CONV.JIS.TO.XCCS (LOGAND CH1 127)
                                   (LOGAND CH2 127]
             (T                                              (* ; "ASCII, C0, C1, SP or DEL")
                (COND
                   (COUNTP (RETURN (CL:VALUES CH1 0)))
                   (T (RETURN CH1])

(\BACKEUCCHAR
  [LAMBDA (STREAM COUNTP)                                    (* ; "Edited 25-Feb-91 17:06 by nm")
    (COND
       ((\BACKFILEPTR STREAM)
        (COND
           ((BITTEST (\PEEKBIN STREAM)
                   (MASK.1'S 7 1))                           (* ; "C1, KAINJI, HANKAKU or GAIJI")
            (COND
               [(\BACKFILEPTR STREAM)
                (COND
                   ((\EUC.HANKAKUP (\PEEKBIN STREAM))
                    (AND COUNTP 2))
                   ((BITTEST (\PEEKBIN STREAM)
                           (MASK.1'S 7 1))                   (* ; "KANJI or GAIJI")
                    (COND
                       [(\BACKFILEPTR STREAM)
                        (COND
                           ((\GAIJIP (\PEEKBIN STREAM))
                            (AND COUNTP 3))
                           (T                                (* ; "KANJI")
                              (\BIN STREAM)
                              (AND COUNTP 2]
                       (COUNTP 2)))
                   (T                                        (* ; "C1")
                      (\BIN STREAM)
                      (AND COUNTP 1]
               (COUNTP 1)))
           (COUNTP 1)))
       (COUNTP 0])

(\THROUGHIN
  [LAMBDA (STREAM COUNTP)                                    (* ; "Edited 26-Feb-91 13:36 by nm")

(* ;;; "Read in a single byte from STREAM and returns it without any character conversion, just through as if.")

(* ;;; "If COUNP is non-NIL, always 1 is returned as the second value.")

    (COND
       (COUNTP (CL:VALUES (\BIN STREAM)
                      1))
       (T (\BIN STREAM])

(\THROUGHPEEK
  [LAMBDA (STREAM NOERROR COUNTP)                            (* ; "Edited 26-Feb-91 13:40 by nm")

(* ;;; "Returns a 8 bit code without any character conversion, just through as if.")

(* ;;; "If COUNTP is non-NIL, always 0 is returned as its second value.")

    (COND
       (COUNTP (CL:VALUES (\PEEKBIN STREAM NOERROR)
                      0))
       (T (\PEEKBIN STREAM NOERROR])

(\BACKTHROUGHCHAR
  [LAMBDA (STREAM COUNTP)                                    (* ; "Edited 26-Feb-91 13:43 by nm")
    (COND
       ((\BACKFILEPTR STREAM)
        1)
       (COUNTP 0])
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY 
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 

(PUTPROPS \XCCSIN MACRO [(STREAM SHIFTEDCSET SHIFTEDCSETVAR COUNTERVAR)

(* ;;; "returns a 16 bit character code.  SHIFTEDCSET is STREAM's char set left shifted 8, SHIFTEDCSETVAR if non-NIL is the variable to set if char set changes.  COUNTERVAR if non-NIL is decremented by number of bytes read.  Doesn't do EOL conversion -- \INCHAR and \INCCODE do that.")

                                 (LET ((CHAR (\BIN STREAM))
                                       SCSET)
                                      (COND
                                         [(EQ CHAR NSCHARSETSHIFT)
                                                             (* ; "Shifting character sets")
                                          [ACCESS-CHARSET STREAM
                                                 (SETQ SCSET (COND
                                                                ((NEQ NSCHARSETSHIFT (SETQ CHAR
                                                                                      (\BIN STREAM)))
                                                                 (AND 'COUNTERVAR (SETQ COUNTERVAR
                                                                                   (IDIFFERENCE
                                                                                    COUNTERVAR 2)))
                                                                 CHAR)
                                                                ((PROGN 
                                                             (* ; 
                                                           "2 shift-bytes means not run-encoded")
                                                                        (AND 'COUNTERVAR
                                                                             (SETQ COUNTERVAR
                                                                              (IDIFFERENCE COUNTERVAR
                                                                                     3)))
                                                                        (EQ 0 (\BIN STREAM)))
                                                                 \NORUNCODE)
                                                                (T (\NSIN.24BITENCODING.ERROR
                                                                    STREAM]
                                          (SETQ CHAR (\BIN STREAM))
                                          (SETQ SCSET (COND
                                                         ('SHIFTEDCSETVAR 
                                                             (* ; "CHARSETVAR=NIL means don't set")
                                                                (SETQ SHIFTEDCSETVAR (UNFOLD SCSET 
                                                                                            256)))
                                                         (T (UNFOLD SCSET 256]
                                         (T (SETQ SCSET SHIFTEDCSET)))
                                      (COND
                                         ((EQ SCSET (UNFOLD \NORUNCODE 256))
                                                             (* ; 
                                           "just read two bytes and combine them to a 16 bit value")
                                          (AND 'COUNTERVAR (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR 2
                                                                                   )))
                                          (LOGOR (UNFOLD CHAR 256)
                                                 (\BIN STREAM)))
                                         (CHAR (AND 'COUNTERVAR (SETQ COUNTERVAR (IDIFFERENCE 
                                                                                        COUNTERVAR 1)
                                                                 ))
                                               (AND CHAR (LOGOR SCSET CHAR])

(PUTPROPS \XCCSPEEK MACRO [(STREAM SHIFTEDCSET SHIFTEDCSETVAR NOERROR COUNTERVAR)

                                 (* ;; "Returns a 16 bit character code.  Doesn't do EOL conversion--\INCHAR does that.  May actually read the character-set shift, storing the result in the stream.  COUNTERVAR, if given, is updated to reflect any such bytes that are actually read")

                                   (PROG ((CHAR (\PEEKBIN STREAM NOERROR))
                                          SCSET)
                                         (COND
                                            ((NULL CHAR)
                                             (RETURN NIL))
                                            [(EQ CHAR NSCHARSETSHIFT)
                                                             (* ; "CHARSETVAR=NIL means don't set")
                                             (\BIN STREAM)   (* ; "Consume the char shift byte")
                                             [ACCESS-CHARSET STREAM
                                                    (SETQ SCSET (COND
                                                                   ((NEQ NSCHARSETSHIFT
                                                                         (SETQ CHAR (\BIN STREAM)))
                                                             (* ; 
     "Note: no eof error check on this \BIN -- an eof in the middle of a charset shift is an error")
                                                                    (AND 'COUNTERVAR
                                                                         (SETQ COUNTERVAR
                                                                          (IDIFFERENCE COUNTERVAR 2))
                                                                         )
                                                                    CHAR)
                                                                   ((PROGN 
                                                             (* ; 
                                                           "2 shift-bytes means not run-encoded")
                                                                           (AND 'COUNTERVAR
                                                                                (SETQ COUNTERVAR
                                                                                 (IDIFFERENCE 
                                                                                        COUNTERVAR 3)
                                                                                 ))
                                                                           (EQ 0 (\BIN STREAM)))
                                                                    \NORUNCODE)
                                                                   (T (\NSIN.24BITENCODING.ERROR
                                                                       STREAM]
                                             [SETQ SCSET (COND
                                                            ('SHIFTEDCSETVAR 
                                                             (* ; "CHARSETVAR=NIL means don't set")
                                                                   (SETQ SHIFTEDCSETVAR
                                                                    (UNFOLD SCSET 256)))
                                                            (T (UNFOLD SCSET 256]
                                             (COND
                                                ((NULL (SETQ CHAR (\PEEKBIN STREAM NOERROR)))
                                                 (RETURN NIL]
                                            (T (SETQ SCSET SHIFTEDCSET)))
                                         (RETURN (COND
                                                    ((EQ SCSET (UNFOLD \NORUNCODE 256))

                                              (* ;; "just peek two bytes and combine them to a 16 bit value.  Again, is an error if we hit eof in mid-character")

                                                     (\BIN STREAM)
                                                     (PROG1 (LOGOR (UNFOLD CHAR 256)
                                                                   (\PEEKBIN STREAM NOERROR))
                                                            (\BACKFILEPTR STREAM)))
                                                    (T (LOGOR SHIFTEDCSET CHAR])

(PUTPROPS \BACKXCCSCHAR MACRO [(STREAM SHIFTEDCHARSET COUNTERVAR)
                                       (AND (\BACKFILEPTR STREAM)
                                            (COND
                                               [[COND
                                                   (SHIFTEDCHARSET (EQ SHIFTEDCHARSET
                                                                       (UNFOLD \NORUNCODE 256)))
                                                   (T (EQ \NORUNCODE (ACCESS-CHARSET STREAM]
                                                (COND
                                                   ((\BACKFILEPTR STREAM)
                                                    (AND 'COUNTERVAR (add COUNTERVAR 2))
                                                    T)
                                                   ('COUNTERVAR (add COUNTERVAR 1]
                                               ('COUNTERVAR (add COUNTERVAR 1])

(PUTPROPS \XCCSP MACRO [OPENLAMBDA (ST)
                                 (NOT (ffetch (STREAM NOTXCCS) of (\DTEST ST 'STREAM])
)
(DECLARE%: EVAL@COMPILE 

(PUTPROPS \EXTRACT.NO.FONT.CODE MACRO ((JISCODE)
                                               (CDR (ASSOC JISCODE *JIS-TO-XCCS-CONV-NO-FONT-TABLE*))
                                               ))

(PUTPROPS \EXTARACT.CONV.TABLE MACRO ((KU)
                                              (CDR (ASSOC KU *JIS-TO-XCCS-CONV-TABLE-LIST*))))

(PUTPROPS \NOT.EQUIVALENT.TO.XCCS MACRO ((KU)

(* ;;; " The JIS codes which are not equiavelent to XCCS reside in 1, 2, 3, 6, 8 and 84 KU.  Although from 84-5 to 94-94 inclusive are not defined in JIS, that is they are GAIJI, they are also handled here.")

                                                 (OR (EQ KU 33)
                                                     (EQ KU 34)
                                                     (EQ KU 35)
                                                     (EQ KU 38)
                                                     (EQ KU 40)
                                                     (EQ KU 116)
                                                     (EQ KU 117))))

(PUTPROPS \EXTRACT.SET MACRO ((TEN TABLE)
                                      (ELT TABLE (IDIFFERENCE (UNFOLD (IDIFFERENCE TEN 32)
                                                                     2)
                                                        1))))

(PUTPROPS \EXTRACT.CODE MACRO ((TEN TABLE)
                                       (ELT TABLE (UNFOLD (IDIFFERENCE TEN 32)
                                                         2))))

(PUTPROPS \CHNAGE.KI.MODE MACRO [OPENLAMBDA (ST INPUTFLG ENTERP)

(* ;;; 
"INPUTFLG is true if \CHNAGE.KI.MODE is called in the context in which ST is an input stream.")

                                          (COND
                                             [INPUTFLG (COND
                                                          (ENTERP (freplace (STREAM IN.KANJIIN)
                                                                     of (\DTEST ST 'STREAM)
                                                                     with T))
                                                          (T (freplace (STREAM IN.KANJIIN)
                                                                of (\DTEST ST 'STREAM)
                                                                with NIL]
                                             (T (COND
                                                   (ENTERP (freplace (STREAM OUT.KANJIIN)
                                                              of (\DTEST ST 'STREAM) with
                                                                                         T))
                                                   (T (freplace (STREAM OUT.KANJIIN)
                                                         of (\DTEST ST 'STREAM) with NIL])

(PUTPROPS \KIMODEP MACRO [OPENLAMBDA (ST INPUTFLG)

(* ;;; "INPUTFLG is true if \KIMODEP is called in the context in which ST is an input stream.")

                                   (COND
                                      [INPUTFLG (ffetch (STREAM IN.KANJIIN)
                                                   of (\DTEST ST 'STREAM]
                                      (T (ffetch (STREAM OUT.KANJIIN) of (\DTEST ST
                                                                                        'STREAM])

(PUTPROPS \HANKAKUP MACRO ((CHAR)
                                   (< 160 CHAR 224)))

(PUTPROPS \KANJIP MACRO ((CHAR)
                                 (< 12158 CHAR 29733)))

(PUTPROPS \NOTGAIJIP MACRO ((CHAR)
                                    (OR (< 8480 CHAR 10305)
                                        (< 12158 CHAR 29733))))

(PUTPROPS \INVALID.TENP MACRO (OPENLAMBDA (TEN)
                                        (OR (< TEN 33)
                                            (< 126 TEN))))

(PUTPROPS \CONV.HANKAKU.KANA MACRO ((CHAR)
                                            (GETHASH CHAR *HANKAKU-TO-ZENKAKU-CONV-TABLE*)))

(PUTPROPS \OUTKI MACRO ((STREAM)
                                (\BOUT OUTSTREAM (CHARCODE ESC))
                                (\BOUT OUTSTREAM (CHARCODE $))
                                (\BOUT OUTSTREAM (CHARCODE B))))

(PUTPROPS \OUTKO MACRO ((STREAM)
                                (\BOUT OUTSTREAM (CHARCODE ESC))
                                (\BOUT OUTSTREAM (CHARCODE %())
                                (\BOUT OUTSTREAM (CHARCODE J))))
)
(DECLARE%: EVAL@COMPILE 

(PUTPROPS \CONV.SJIS.TO.JIS MACRO [OPENLAMBDA (HI LO)

(* ;;; "Convert Shift-JIS to JIS.  The variable named CH1 and CH2 are set to the converted hight 8 bit and low 8bit of JIS code respectively.")

                                            [SETQ CH1 (IDIFFERENCE HI (COND
                                                                         ((> HI 159)
                                                                          177)
                                                                         (T 113]
                                            (SETQ CH1 (IPLUS (UNFOLD CH1 2)
                                                             1))
                                            (SETQ CH2 (COND
                                                         [(> LO 158)
                                                          (PROG1 (IDIFFERENCE LO 126)
                                                              (SETQ CH1 (IPLUS CH1 1)))]
                                                         (T (IDIFFERENCE LO (COND
                                                                               ((> LO 126)
                                                                                (IPLUS 31 1))
                                                                               (T 31])

(PUTPROPS \CONV.JIS.TO.SJIS MACRO [OPENLAMBDA (HI LO)

(* ;;; "Convert JIS to Shift-JIS.  The variable named CH1 and CH2 are set to the converted hight 8 bit and low 8bit of Shift-JIS code respectively.")

                                            [SETQ CH2 (COND
                                                         ((ODDP HI)
                                                          (SETQ CH2 (IPLUS LO 31))
                                                          (COND
                                                             ((>= CH2 127)
                                                              (IPLUS CH2 1))
                                                             (T CH2)))
                                                         (T (IPLUS LO 126]
                                            (SETQ CH1 (IPLUS (FOLDLO (IDIFFERENCE HI 33)
                                                                    2)
                                                             129))
                                            (AND (> CH1 159)
                                                 (SETQ CH1 (IPLUS CH1 64])

(PUTPROPS \SJIS.KANJI.FIRST.BYTEP MACRO (OPENLAMBDA (CHAR)
                                                  (OR (< 127 CHAR 160)
                                                      (< 223 CHAR 256))))
)
(DECLARE%: EVAL@COMPILE 

(PUTPROPS \EUC.KANJI.FIRST.BYTEP MACRO ((CHAR)
                                                (< 160 CHAR 255)))

(PUTPROPS \GAIJIP MACRO ((CHAR)
                                 (EQ CHAR 143)))

(PUTPROPS \EUC.HANKAKUP MACRO ((CHAR)
                                       (EQ CHAR 142)))
)

(* "END EXPORTED DEFINITIONS")

)

(RPAQ? *SIGNAL-24BIT-NSENCODING-ERROR* )

(RPAQ? *READ-NEWLINE-SUPPRESS* )

(RPAQ? \RefillBufferFn (FUNCTION \READCREFILL))



(* ; 
"Top level val of \RefillBufferFn means act like READC--we must be doing a raw BIN (or PEEKBIN?)")

(DECLARE%: DOEVAL@COMPILE DONTCOPY

(LOCALVARS . T)
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA )

(ADDTOVAR NLAML )

(ADDTOVAR LAMA CONVHANKAKU CL:PARSE-INTEGER CL:READ-DELIMITED-LIST CL:READ-PRESERVING-WHITESPACE
                         CL:READ)
)
(PUTPROPS LLREAD COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1990 
1991 1993 2021))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (7856 18392 (LASTC 7866 . 8996) (PEEKC 8998 . 9386) (PEEKCCODE 9388 . 9677) (RATOM 9679
 . 10760) (READ 10762 . 11322) (READC 11324 . 11741) (READCCODE 11743 . 12159) (READP 12161 . 12713) (
SETREADMACROFLG 12715 . 13014) (SKIPSEPRCODES 13016 . 14361) (SKIPSEPRS 14363 . 15620) (
\NSIN.24BITENCODING.ERROR 15622 . 16441) (SKREAD 16443 . 18390)) (18438 27113 (CL:READ 18448 . 18997) 
(CL:READ-PRESERVING-WHITESPACE 18999 . 19721) (CL:READ-DELIMITED-LIST 19723 . 20638) (CL:PARSE-INTEGER
 20640 . 27111)) (27206 40219 (RSTRING 27216 . 27948) (READ-EXTENDED-TOKEN 27950 . 32511) (\RSTRING2 
32513 . 40217)) (40255 72572 (\TOP-LEVEL-READ 40265 . 42248) (\SUBREAD 42250 . 68988) (\SUBREADCONCAT 
68990 . 69613) (\ORIG-READ.SYMBOL 69615 . 70683) (\ORIG-INVALID.SYMBOL 70685 . 71584) (\APPLYREADMACRO
 71586 . 72002) (INREADMACROP 72004 . 72570)) (72731 72906 (READQUOTE 72741 . 72904)) (72931 84835 (
READVBAR 72941 . 74272) (READHASHMACRO 74274 . 80084) (DEFMACRO-LAMBDA-LIST-KEYWORD-P 80086 . 80306) (
DIGITBASEP 80308 . 81042) (READNUMBERINBASE 81044 . 82930) (ESTIMATE-DIMENSIONALITY 82932 . 83257) (
SKIP.HASH.COMMENT 83259 . 84227) (CMLREAD.FEATURE.PARSER 84229 . 84833)) (84879 91412 (CHARACTER.READ 
84889 . 86143) (CHARCODE.DECODE 86145 . 91410)) (111622 116838 (\MAKE.JIS.TO.XCCS.CONV.TABLE 111632 . 
116836)) (120754 121073 (CONVHANKAKU 120764 . 121071)) (124044 149184 (\JISIN 124054 . 129755) (
\JISPEEK 129757 . 136383) (\BACKJISCHAR 136385 . 136754) (\SHIFTJISIN 136756 . 138395) (\SHIFTJISPEEK 
138397 . 140503) (\BACKSHIFTJISCHAR 140505 . 140935) (\EUCIN 140937 . 143328) (\EUCPEEK 143330 . 
146909) (\BACKEUCCHAR 146911 . 148154) (\THROUGHIN 148156 . 148571) (\THROUGHPEEK 148573 . 148987) (
\BACKTHROUGHCHAR 148989 . 149182)))))
STOP
\ No newline at end of file
diff --git a/sources/LLREAD.LCOM b/sources/LLREAD.LCOM
index 8e7870b7..29f65a71 100644
Binary files a/sources/LLREAD.LCOM and b/sources/LLREAD.LCOM differ
