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

(FILECREATED "12-Oct-93 22:11:23" "{Pele:mv:envos}<LispCore>Sources>CLTL2>LLREAD.;2"
 121366 

      changes to%:  (FNS \RSTRING2)
                    (MACROS \NSIN)

      previous date%: " 4-May-91 08:47:17" "{Pele:mv:envos}<LispCore>Sources>CLTL2>LLREAD.;1")


(* ; "
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 \SUBREAD-FLIPCASE READTABLE-CASEARRAY 
                   \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*)
               (RESOURCES \PNAMECASEBITS)
                                                             (* ; "For READTABLE-CASE :INVERT")
)
        [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  3-Apr-91 21:08 by jrb:") (* ;;; "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)) (.CALL.SUBREAD. FILE NIL NIL NIL T RATOM.RT)))
)

(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 (QUOTE INPUT))) (FDEVOP (QUOTE 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* (QUOTE SKREAD)) (*READTABLE* (\GTREADTABLE RDTBL)) (\RBFLG) (STRM (\GETSTREAM FILE (QUOTE INPUT))) CH) (DECLARE (LISP:SPECIAL *READTABLE* *READ-SUPPRESS* \RBFLG)) (COND (REREADSTRING (* ; "REREADSTRING is string of chars already read.") (SETQ STRM (LISP:MAKE-CONCATENATED-STREAM (LISP: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") (QUOTE %))) (RIGHTBRACKET.RC (* ; "unbalanced right bracket") (QUOTE %])) (AND \RBFLG (QUOTE %]))))))
)
)



(* ; "CommonLisp read entry points")


(DEFINEQ

(LISP:READ

(LISP: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))))
)

(LISP:READ-PRESERVING-WHITESPACE

(LISP: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))))
)

(LISP:READ-DELIMITED-LIST

(LISP: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) (LISP: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))))
)

(LISP:PARSE-INTEGER

(LISP:LAMBDA (STRING &KEY START END (RADIX 10) JUNK-ALLOWED) (* ; "Edited  8-Feb-91 13:24 by gadener") (LISP:IF (NOT (LISP: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 (LISP:1+ INDEX))) (COND ((>= INDEX STOP) (* ; "no characters remain") (RETURN (COND (JUNK-ALLOWED (* ; "don't error") (LISP: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 (QUOTE -))) (+ (SETQ SIGN (QUOTE +))) (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 (LISP: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 (QUOTE -)) 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 (LISP:ERROR ERR (if (OR START END) then (LISP: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  3-Apr-91 21:16 by jrb:") (* ;; "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 \PNAMECASEBITS) (PROG ((CASEBASE (READTABLE-CASEARRAY RDTBL)) (PBASE (ffetch (STRINGP XBASE) of \PNAMESTRING)) (SHIFTEDCHARSET (UNFOLD (ACCESS-CHARSET STREAM) 256)) (SA (fetch READSA of RDTBL)) (INVERTCASE (AND (fetch (READTABLEP LOWER/FLIPCASE) of RDTBL) (NOT (fetch (READTABLEP CASEINSENSITIVE) of RDTBL)))) J CH SNX ANSLIST ANSTAIL ESCAPE-APPEARED ESCAPING FATSEEN) (AND INVERTCASE (for old J from 16 to 0 bind (CASEBITSBASE _ (ffetch (ARRAYP BASE) of \PNAMECASEBITS)) do (\PUTBASE CASEBITSBASE J 0))) (SETQ J 0) 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) (SETA \PNAMECASEBITS J 1)) (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))) (AND INVERTCASE ESCAPING (SETA \PNAMECASEBITS J 1)) (SETQ J (ADD1 J)) (GO LP) FINISH (AND INVERTCASE (NOT ANSLIST) (\SUBREAD-FLIPCASE PBASE \PNAMECASEBITS (SUB1 J) CASEBASE)) (SETQ CH (\SMASHSTRING (ALLOCSTRING J NIL NIL FATSEEN) 0 \PNAMESTRING J)) (COND (ANSLIST (RPLACD ANSTAIL (SETQ ANSTAIL (CONS CH NIL))) (SETQ CH (CONCATLIST ANSLIST)))) (RETURN (if ESCAPE-APPEARED then (* ; "do it this way because multiple values are slow") (LISP:VALUES CH T) else CH)))))
)

(\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* (QUOTE 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)) (LISP:UNWIND-PROTECT (PROGN (AND EOF-SUPPRESS (REPLACE ENDOFSTREAMOP OF STREAM WITH (LISP:FUNCTION (LAMBDA (STREAM) (RETFROM (QUOTE \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 CASEBITS EOF-SUPPRESS EOF-VALUE CHAR PRESERVE-WHITESPACE) (* ; "Edited 22-Apr-91 11:35 by jrb:") (* ;; "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))) (INVERTCASE (AND (fetch (READTABLEP LOWER/FLIPCASE) of *READTABLE*) (NOT (fetch (READTABLEP CASEINSENSITIVE) of *READTABLE*)))) 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") (AND INVERTCASE (for old J from 0 to 15 bind (CASEBITSBASE _ (ffetch (ARRAYP BASE) of CASEBITS)) do (\PUTBASE CASEBITSBASE J 0))) (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) (AND INVERTCASE (SETA CASEBITS J 1)) (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) (AND INVERTCASE (SETA CASEBITS J 1)) (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 (if INVERTCASE then (* ;; "Case of the unescaped letters was inverted, but maybe shouldn't have been (if they came in mixed-case).  Need to check here.  It's done as a post-processing pass to make the other cases fast (anyone who uses the :INVERT case and expects it to be fast deserves to lose).") (\SUBREAD-FLIPCASE PBASE CASEBITS (SUB1 J) CASEBASE)) (\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 CASEBITS))) (\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 CASEBITS)) (\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.") (LISP:ERROR "Unmatched ~A encountered while reading to a ~A" (LISP:CODE-CHAR CH) (LISP: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 (LISP: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))
)

(\SUBREAD-FLIPCASE

(LAMBDA (STRINGBASE CASEBITS LEN CASEBASE) (* ; "Edited 10-Feb-91 17:08 by jrb:") (* ;; "Handles the possible case inversion required by the :INVERT READTABLE-CASE setting.") (* ;; "STRINGBASE is the base of the string used by \SUBREAD to accumulate characters for symbols") (* ;; "CASEBITS is a bit-array with 1s in the places corresponding to escaped characters in STRINGBASE") (* ;; "LEN points to the last character in STRINGBASE (0-based addressing)") (* ;; "CASEBASE is the base of the casearray") (LET (PBVAL UPPERSEEN LOWERSEEN) (if (for I from 0 to LEN by 1 do (AND UPPERSEEN LOWERSEEN (RETURN T)) (if (ZEROP (ELT CASEBITS I)) then (SETQ PBVAL (\GETBASECHAR \FATPNAMESTRINGP STRINGBASE I)) (COND ((AND (IGEQ PBVAL (CHARCODE a)) (ILEQ PBVAL (CHARCODE z))) (SETQ LOWERSEEN T)) ((AND (IGEQ PBVAL (CHARCODE A)) (ILEQ PBVAL (CHARCODE Z))) (SETQ UPPERSEEN T)))) finally (RETURN (AND UPPERSEEN LOWERSEEN))) then (for I from 0 to LEN by 1 when (AND (ZEROP (ELT CASEBITS I)) (ILEQ (SETQ PBVAL (\GETBASECHAR \FATPNAMESTRINGP STRINGBASE I)) \MAXTHINCHAR)) do (\PNAMESTRINGPUTCHAR STRINGBASE I (\GETBASEBYTE CASEBASE PBVAL))))))
)

(READTABLE-CASEARRAY

(LAMBDA (READTABLE) (* ; "Edited  9-Feb-91 11:24 by jrb:") (SELECTQ (COMMON-LISP:READTABLE-CASE READTABLE) (:PRESERVE NIL) (:UPCASE (ffetch (ARRAYP BASE) of UPPERCASEARRAY)) (:DOWNCASE (ffetch (ARRAYP BASE) of LOWERCASEARRAY)) (:INVERT (ffetch (ARRAYP BASE) of FLIPCASEARRAY)) (ERROR "Bogus value of CL:READTABLE-CASE" (COMMON-LISP:READTABLE-CASE READTABLE))))
)

(\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.") (LISP: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 (LISP: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) (LISP: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") (LISP: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 LISP: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 (LISP:MAKE-ARRAY INDEX) CONTENTS)) (T (LISP: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 (LISP:MAKE-ARRAY INDEX :ELEMENT-TYPE (QUOTE BIT)) CONTENTS)) (T (LISP:MAKE-ARRAY (LENGTH CONTENTS) :INITIAL-CONTENTS CONTENTS :ELEMENT-TYPE (QUOTE BIT)))))) (":" (* ;; "The same thing HASH-COLON does.") (LISP: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))) (LISP: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))) (LISP:READ STREAM RDTBL))) (LISP:VALUES)) (- (* ; "Skip expression if feature IS present") (COND ((CMLREAD.FEATURE.PARSER (READ STREAM RDTBL)) (LISP:READ STREAM RDTBL))) (LISP:VALUES)) ("|" (* ; "special comment") (SKIP.HASH.COMMENT STREAM RDTBL) (LISP: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 (LISP: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 ((LISP: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") (LISP: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") (LISP: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 (LISP: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 (LISP: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

       ((INFINITY 8551)
        ("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

          [X (DESTRUCTURING-BIND (STREAM EOF-SUPPRESS EOF-VALUE CHAR PRESERVE-WHITESPACE READTYPE)
                    X
                    `(WITH-RESOURCES (\PNAMESTRING \PNAMECASEBITS)
                            (\SUBREAD
 (\GETSTREAM ,STREAM 'INPUT)
                                   (fetch
 (READTABLEP READSA) of
 *READTABLE*)
                                   ,[COND
                                       (READTYPE)
                                       (T `(COND
                                              (,CHAR -1)
                                              (T READ.RT]
                                   \PNAMESTRING
                                   (READTABLE-CASEARRAY
 *READTABLE*)
                                   \PNAMECASEBITS
                                   ,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*)
)

(DECLARE%: EVAL@COMPILE 

[PUTDEF '\PNAMECASEBITS 'RESOURCES '(NEW (ARRAY \PNAMELIMIT '(BITS 1)
                                                0]
)
)



(* ; "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)) (LISP: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) ((LISP: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 (LISP: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 (LISP: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 (LISP: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 (LISP:VALUES (CHARCODE ESC) (IPLUS 1 CHARNUM)))) (T (RETURN (CHARCODE ESC))))))))) (IN16BITFLG (* ; "Under processing 16 bit code.") (COND (COUNTP (RETURN (LISP:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) (IPLUS 2 CHARNUM)))) (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2))))) (T (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (LISP:VALUES (CHARCODE ESC) (IPLUS 1 CHARNUM)))) (T (RETURN (CHARCODE ESC))))))) (IN16BITFLG (* ; "Under processing 16 bit code.") (COND (COUNTP (RETURN (LISP: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 (LISP: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 (LISP: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 (LISP: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 (LISP: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 (LISP: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 (LISP:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) CHARNUM))) (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2))))) (T (COND (COUNTP (RETURN (LISP: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 (LISP: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 (LISP:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) CHARNUM))) (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2))))) (T (COND (COUNTP (RETURN (LISP:VALUES (CHARCODE ESC) CHARNUM))) (T (RETURN (CHARCODE ESC))))))))) (IN16BITFLG (* ; "Under processing 16 bit code.") (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (LISP:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) CHARNUM))) (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2))))) (T (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (LISP: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 (LISP:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) CHARNUM))) (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2))))) (T (COND (COUNTP (RETURN (LISP: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 (LISP: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 (LISP: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 (LISP: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 (LISP:VALUES (\CONV.HANKAKU.KANA CH1) 1)) (T (\CONV.HANKAKU.KANA CH1)))) (T (* ; "ASCII") (COND (COUNTP (LISP: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 (LISP: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 (LISP: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 (LISP: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 (LISP:VALUES (\CONV.HANKAKU.KANA CH1) 0))) (T (RETURN (\CONV.HANKAKU.KANA CH1))))) (T (* ; "ASCII") (COND (COUNTP (RETURN (LISP: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 (LISP: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 (LISP:VALUES (\CONV.HANKAKU.KANA (\BIN STREAM)) 2)) (T (\CONV.HANKAKU.KANA (\BIN STREAM))))) ((\GAIJIP CH1) (COND (COUNTP (LISP: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 (LISP: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 (LISP: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 (LISP:VALUES NIL 0))) (T (RETURN NIL))))) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (LISP: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 (LISP:VALUES NIL 0))) (T (RETURN NIL))))) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (LISP: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 (LISP: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 (LISP:VALUES NIL 0))) (T (RETURN NIL))))) (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (LISP: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 (LISP: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 (LISP: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 (LISP: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 (6813 13667 (LASTC 6823 . 7816) (PEEKC 7818 . 8123) (PEEKCCODE 8125 . 8348) (RATOM 
8350 . 8852) (READ 8854 . 9308) (READC 9310 . 9617) (READCCODE 9619 . 9974) (READP 9976 . 10310) (
SETREADMACROFLG 10312 . 10468) (SKIPSEPRCODES 10470 . 11235) (SKIPSEPRS 11237 . 11929) (
\NSIN.24BITENCODING.ERROR 11931 . 12506) (SKREAD 12508 . 13665)) (13713 17922 (CL:READ 13723 . 14058) 
(CL:READ-PRESERVING-WHITESPACE 14060 . 14522) (CL:READ-DELIMITED-LIST 14524 . 15180) (CL:PARSE-INTEGER
 15182 . 17920)) (17955 29055 (RSTRING 17965 . 18519) (READ-EXTENDED-TOKEN 18521 . 21321) (\RSTRING2 
21323 . 29053)) (29091 49402 (\TOP-LEVEL-READ 29101 . 30405) (\SUBREAD 30407 . 45359) (\SUBREADCONCAT 
45361 . 45873) (\SUBREAD-FLIPCASE 45875 . 47025) (READTABLE-CASEARRAY 47027 . 47414) (\READ.SYMBOL 
47416 . 48205) (\INVALID.SYMBOL 48207 . 48828) (\APPLYREADMACRO 48830 . 49057) (INREADMACROP 49059 . 
49400)) (49436 49564 (READQUOTE 49446 . 49562)) (49589 55986 (READVBAR 49599 . 50464) (READHASHMACRO 
50466 . 53266) (DEFMACRO-LAMBDA-LIST-KEYWORD-P 53268 . 53431) (DIGITBASEP 53433 . 53891) (
READNUMBERINBASE 53893 . 54863) (ESTIMATE-DIMENSIONALITY 54865 . 55097) (SKIP.HASH.COMMENT 55099 . 
55610) (CMLREAD.FEATURE.PARSER 55612 . 55984)) (56030 58355 (CHARACTER.READ 56040 . 56689) (
CHARCODE.DECODE 56691 . 58353)) (78466 81556 (\MAKE.JIS.TO.XCCS.CONV.TABLE 78476 . 81554)) (85497 
85682 (CONVHANKAKU 85507 . 85680)) (88788 102661 (\JISIN 88798 . 91820) (\JISPEEK 91822 . 95409) (
\BACKJISCHAR 95411 . 95639) (\SHIFTJISIN 95641 . 96538) (\SHIFTJISPEEK 96540 . 97703) (
\BACKSHIFTJISCHAR 97705 . 97976) (\EUCIN 97978 . 99215) (\EUCPEEK 99217 . 101281) (\BACKEUCCHAR 101283
 . 101859) (\THROUGHIN 101861 . 102190) (\THROUGHPEEK 102192 . 102528) (\BACKTHROUGHCHAR 102530 . 
102659)))))
STOP