From 21c8759084459e4e47a9b859e077a48b2beac02a Mon Sep 17 00:00:00 2001 From: rmkaplan <69548581+rmkaplan@users.noreply.github.com> Date: Thu, 22 Apr 2021 21:10:48 -0700 Subject: [PATCH] Change default EOL to LF on UFS (#312) UFS changes the the default in \UFSeol to LF.EOLC. LLREAD changes \rprint2 to convert EOL to LF if escaped in a string. NSPROTECTION eliminates literal EOL --- lispusers/NSPROTECTION | 106 +++++++--- lispusers/NSPROTECTION.LCOM | Bin 23527 -> 23701 bytes sources/LLREAD | 2 +- sources/LLREAD.LCOM | Bin 59996 -> 59320 bytes sources/UFS | 375 +++++++++++++++++++----------------- sources/UFS.LCOM | Bin 37187 -> 37347 bytes 6 files changed, 277 insertions(+), 206 deletions(-) diff --git a/lispusers/NSPROTECTION b/lispusers/NSPROTECTION index b935d63b..4d7deb75 100644 --- a/lispusers/NSPROTECTION +++ b/lispusers/NSPROTECTION @@ -1,16 +1,47 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 7-Sep-89 12:31:44" "{piglet/n}vanmelle>lispusers>nsprotection;4" 31274 +(FILECREATED "21-Apr-2021 11:56:06"  +{DSK}kaplan>Local>medley3.5>git-medley>lispusers>NSPROTECTION.;4 32481 - changes to%: (FNS NSPROT.SET.MULTIPLE)) + changes to%: (FNS NSPROT.LIMITCHARS) + + previous date%: " 7-Sep-89 12:31:44" +{DSK}kaplan>Local>medley3.5>git-medley>lispusers>NSPROTECTION.;2) -(* " -Copyright (c) 1987, 1989 by Xerox Corporation. All rights reserved. +(* ; " +Copyright (c) 1987, 1989, 2021 by Xerox Corporation. ") (PRETTYCOMPRINT NSPROTECTIONCOMS) -(RPAQQ NSPROTECTIONCOMS ((COMS (* ; "Main window selection handlers") (FNS NSPROTECTION NSPROT.SHOW NSPROT.FETCH.PROTECTION NSPROT.NEW.ENTRY NSPROT.APPLY NSPROT.SET.PROTECTION NSPROT.SET.PROTECTION.ONE NSPROT.SET.MULTIPLE NSPROT.SET.TO.DEFAULT NSPROT.BEGIN.COMMAND) (FNS NSPROT.HANDLE.TYPE NSPROT.RESTORE.TYPE NSPROT.HANDLE.VERIFY NSPROT.RESTORE.VERIFY NSPROT.PARSE.FILENAME NSPROT.PARSE.PROTECTIONS NSPROT.STRIP.HOST NSPROT.EXPAND.FULLNAME)) (COMS (* ; "Handle protection submenus") (FNS NSPROT.GET.SUBMENU NSPROT.ADD.SUBMENU NSPROT.REMOVE.SUBMENUS NSPROT.CHANGE.STATE NSPROT.HANDLE.ALL NSPROT.MESSAGE.ALL NSPROT.HANDLE.SUBTYPE NSPROT.SHOW.PROT.VALUE)) (COMS (* ; "utilities") (FNS NSPROT.DIRECTORY.SYNTAXP NSPROT.TOP.LEVELP NSPROT.GET.FONT NSPROT.PROMPT NSPROT.CLEAR.PROMPT NSPROT.LIMITCHARS NSPROT.PAGEFULLFN NSPROT.ICONFN)) (INITVARS NSPROT.PLAIN.FONT NSPROT.BOLD.FONT) (VARS NSPROT.ICON) (GLOBALVARS NSPROT.PLAIN.FONT NSPROT.BOLD.FONT \NSFILING.ATTRIBUTES NSPROT.ICON \DEFAULTTTYDISPLAYSTREAM) (LOCALVARS . T) (COMS (DECLARE%: DONTEVAL@LOAD DOCOPY (P (AND (EQ MAKESYSNAME :LYRIC) (FILESLOAD (SYSLOAD) NSRANDOM)))) (FNS ADD.NSPROTECTION) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (ADD.NSPROTECTION)))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA NSPROT.PROMPT))))) +(RPAQQ NSPROTECTIONCOMS + [(COMS (* ; "Main window selection handlers") + (FNS NSPROTECTION NSPROT.SHOW NSPROT.FETCH.PROTECTION NSPROT.NEW.ENTRY NSPROT.APPLY + NSPROT.SET.PROTECTION NSPROT.SET.PROTECTION.ONE NSPROT.SET.MULTIPLE + NSPROT.SET.TO.DEFAULT NSPROT.BEGIN.COMMAND) + (FNS NSPROT.HANDLE.TYPE NSPROT.RESTORE.TYPE NSPROT.HANDLE.VERIFY NSPROT.RESTORE.VERIFY + NSPROT.PARSE.FILENAME NSPROT.PARSE.PROTECTIONS NSPROT.STRIP.HOST + NSPROT.EXPAND.FULLNAME)) + (COMS (* ; "Handle protection submenus") + (FNS NSPROT.GET.SUBMENU NSPROT.ADD.SUBMENU NSPROT.REMOVE.SUBMENUS NSPROT.CHANGE.STATE + NSPROT.HANDLE.ALL NSPROT.MESSAGE.ALL NSPROT.HANDLE.SUBTYPE NSPROT.SHOW.PROT.VALUE) + ) + (COMS (* ; "utilities") + (FNS NSPROT.DIRECTORY.SYNTAXP NSPROT.TOP.LEVELP NSPROT.GET.FONT NSPROT.PROMPT + NSPROT.CLEAR.PROMPT NSPROT.LIMITCHARS NSPROT.PAGEFULLFN NSPROT.ICONFN)) + (INITVARS NSPROT.PLAIN.FONT NSPROT.BOLD.FONT) + (VARS NSPROT.ICON) + (GLOBALVARS NSPROT.PLAIN.FONT NSPROT.BOLD.FONT \NSFILING.ATTRIBUTES NSPROT.ICON + \DEFAULTTTYDISPLAYSTREAM) + (LOCALVARS . T) + [COMS [DECLARE%: DONTEVAL@LOAD DOCOPY (P (AND (EQ MAKESYSNAME :LYRIC) + (FILESLOAD (SYSLOAD) + NSRANDOM] + (FNS ADD.NSPROTECTION) + (DECLARE%: DONTEVAL@LOAD DOCOPY (P (ADD.NSPROTECTION] + (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) + (NLAML) + (LAMA]) @@ -159,8 +190,16 @@ Copyright (c) 1987, 1989 by Xerox Corporation. All rights reserved. ) (NSPROT.LIMITCHARS -(LAMBDA (ITEM WINDOW CHAR) (* ; "Edited 21-Aug-87 12:00 by bvm:") (SELECTQ CHAR ((% - Â) (FM.SKIPNEXT WINDOW) NIL) T))) + [LAMBDA (ITEM WINDOW CHAR) (* ; "Edited 21-Apr-2021 11:55 by rmk:") + + (* ;; "RMK: Got rid of literal %% in favor of CHARCODE CR, for switch to default LF EOL convention. But compiled file may end up with LF") + + (SELECTC CHAR + ((LIST (CHARACTER (CHARCODE CR)) + 'Â) + (FM.SKIPNEXT WINDOW) + NIL) + T]) (NSPROT.PAGEFULLFN (LAMBDA (PW) (* ; "Edited 2-Aug-89 16:19 by bvm") (* ;; "PAGEFULLFN for prompt window--makes the window a line bigger and allows output to proceed") (SETQ \CURRENTDISPLAYLINE (PROG1 \#DISPLAYLINES (GETPROMPTWINDOW (MAINWINDOW PW) (+ 1 \#DISPLAYLINES)) (* ; "\Currentdisplayline is the line we're on when window fills, origin zero")))) @@ -171,14 +210,17 @@ Copyright (c) 1987, 1989 by Xerox Corporation. All rights reserved. ) ) -(RPAQ? NSPROT.PLAIN.FONT NIL) +(RPAQ? NSPROT.PLAIN.FONT NIL) -(RPAQ? NSPROT.BOLD.FONT NIL) +(RPAQ? NSPROT.BOLD.FONT NIL) -(RPAQQ NSPROT.ICON (#*(80 40)OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@@@@@@@@@@@@@@CL@@@@@@@@@@@@@@@@@@CL@@@@@@@@@@@@@@@@@@CL@@@@@@@@@@@@@@@@@@CL@@@@@@@@@@@@@@AN@@CL@@@@@@@@@@@@@@GOH@CL@@@@@@@@@@@@@@OOL@CL@@@@@@@@@@@@@AOCN@CL@@@@@@@@@@@@@ANAN@CL@@@@@@@@@@@@@CL@O@CL@@@@@@@@@@@@@CL@O@CL@@@@@@@@@@@@@GH@G@CL@@@@@@@@@@@@@GH@GHCL@@@@@@@@@@@@@GH@GHCL@@@@@@@@@@@@@O@@CHCL@@@@@@@@@@@@@O@@CHCLAOOOOOOOOOOOOO@@CHCLCOOOOOOOOOOOOO@@CHCLCOOOOOOOOOOOOO@@CHCLAOOOOOOOOOOOOO@@CHCL@GNGNGN@@@@@@O@@CHCL@GNGNGN@@@@@@O@@CHCL@GNFFGN@@@@@@GH@GHCL@FFFFGN@@@@@@GH@GHCL@FF@@GN@@@@@@GH@G@CL@@@@@FF@@@@@@CL@O@CL@@@@@FF@@@@@@CL@O@CL@@@@@@@@@@@@@ANAN@CL@@@@@@@@@@@@@AOCN@CL@@@@@@@@@@@@@@OOL@CL@@@@@@@@@@@@@@GOH@CL@@@@@@@@@@@@@@CO@@CL@@@@@@@@@@@@@@@L@@CL@@@@@@@@@@@@@@@@@@CL@@@@@@@@@@@@@@@@@@CL@@@@@@@@@@@@@@@@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO NIL (4 22 51 14))) +(RPAQQ NSPROT.ICON (#*(80 40)OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@@@@@@@@@@@@@@CL@@@@@@@@@@@@@@@@@@CL@@@@@@@@@@@@@@@@@@CL@@@@@@@@@@@@@@@@@@CL@@@@@@@@@@@@@@AN@@CL@@@@@@@@@@@@@@GOH@CL@@@@@@@@@@@@@@OOL@CL@@@@@@@@@@@@@AOCN@CL@@@@@@@@@@@@@ANAN@CL@@@@@@@@@@@@@CL@O@CL@@@@@@@@@@@@@CL@O@CL@@@@@@@@@@@@@GH@G@CL@@@@@@@@@@@@@GH@GHCL@@@@@@@@@@@@@GH@GHCL@@@@@@@@@@@@@O@@CHCL@@@@@@@@@@@@@O@@CHCLAOOOOOOOOOOOOO@@CHCLCOOOOOOOOOOOOO@@CHCLCOOOOOOOOOOOOO@@CHCLAOOOOOOOOOOOOO@@CHCL@GNGNGN@@@@@@O@@CHCL@GNGNGN@@@@@@O@@CHCL@GNFFGN@@@@@@GH@GHCL@FFFFGN@@@@@@GH@GHCL@FF@@GN@@@@@@GH@G@CL@@@@@FF@@@@@@CL@O@CL@@@@@FF@@@@@@CL@O@CL@@@@@@@@@@@@@ANAN@CL@@@@@@@@@@@@@AOCN@CL@@@@@@@@@@@@@@OOL@CL@@@@@@@@@@@@@@GOH@CL@@@@@@@@@@@@@@CO@@CL@@@@@@@@@@@@@@@L@@CL@@@@@@@@@@@@@@@@@@CL@@@@@@@@@@@@@@@@@@CL@@@@@@@@@@@@@@@@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO + NIL + (4 22 51 14))) (DECLARE%: DOEVAL@COMPILE DONTCOPY -(GLOBALVARS NSPROT.PLAIN.FONT NSPROT.BOLD.FONT \NSFILING.ATTRIBUTES NSPROT.ICON \DEFAULTTTYDISPLAYSTREAM) +(GLOBALVARS NSPROT.PLAIN.FONT NSPROT.BOLD.FONT \NSFILING.ATTRIBUTES NSPROT.ICON + \DEFAULTTTYDISPLAYSTREAM) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY @@ -186,7 +228,9 @@ Copyright (c) 1987, 1989 by Xerox Corporation. All rights reserved. ) (DECLARE%: DONTEVAL@LOAD DOCOPY -(AND (EQ MAKESYSNAME :LYRIC) (FILESLOAD (SYSLOAD) NSRANDOM)) +(AND (EQ MAKESYSNAME :LYRIC) + (FILESLOAD (SYSLOAD) + NSRANDOM)) ) (DEFINEQ @@ -196,30 +240,30 @@ Copyright (c) 1987, 1989 by Xerox Corporation. All rights reserved. ) (DECLARE%: DONTEVAL@LOAD DOCOPY -(ADD.NSPROTECTION) +(ADD.NSPROTECTION) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS -(ADDTOVAR NLAMA) +(ADDTOVAR NLAMA ) -(ADDTOVAR NLAML) +(ADDTOVAR NLAML ) -(ADDTOVAR LAMA NSPROT.PROMPT) +(ADDTOVAR LAMA ) ) -(PUTPROPS NSPROTECTION COPYRIGHT ("Xerox Corporation" 1987 1989)) +(PUTPROPS NSPROTECTION COPYRIGHT ("Xerox Corporation" 1987 1989 2021)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (1695 14166 (NSPROTECTION 1705 . 4891) (NSPROT.SHOW 4893 . 5411) ( -NSPROT.FETCH.PROTECTION 5413 . 8347) (NSPROT.NEW.ENTRY 8349 . 8972) (NSPROT.APPLY 8974 . 9903) ( -NSPROT.SET.PROTECTION 9905 . 10481) (NSPROT.SET.PROTECTION.ONE 10483 . 11359) (NSPROT.SET.MULTIPLE -11361 . 12860) (NSPROT.SET.TO.DEFAULT 12862 . 13674) (NSPROT.BEGIN.COMMAND 13676 . 14164)) (14167 -21199 (NSPROT.HANDLE.TYPE 14177 . 14477) (NSPROT.RESTORE.TYPE 14479 . 14830) (NSPROT.HANDLE.VERIFY -14832 . 15192) (NSPROT.RESTORE.VERIFY 15194 . 15525) (NSPROT.PARSE.FILENAME 15527 . 17256) ( -NSPROT.PARSE.PROTECTIONS 17258 . 19753) (NSPROT.STRIP.HOST 19755 . 20136) (NSPROT.EXPAND.FULLNAME -20138 . 21197)) (21243 25794 (NSPROT.GET.SUBMENU 21253 . 23057) (NSPROT.ADD.SUBMENU 23059 . 23366) ( -NSPROT.REMOVE.SUBMENUS 23368 . 23788) (NSPROT.CHANGE.STATE 23790 . 24072) (NSPROT.HANDLE.ALL 24074 . -24316) (NSPROT.MESSAGE.ALL 24318 . 24590) (NSPROT.HANDLE.SUBTYPE 24592 . 25137) ( -NSPROT.SHOW.PROT.VALUE 25139 . 25792)) (25821 29042 (NSPROT.DIRECTORY.SYNTAXP 25831 . 26015) ( -NSPROT.TOP.LEVELP 26017 . 26179) (NSPROT.GET.FONT 26181 . 26700) (NSPROT.PROMPT 26702 . 27226) ( -NSPROT.CLEAR.PROMPT 27228 . 28111) (NSPROT.LIMITCHARS 28113 . 28254) (NSPROT.PAGEFULLFN 28256 . 28616) - (NSPROT.ICONFN 28618 . 29040)) (30249 30998 (ADD.NSPROTECTION 30259 . 30996))))) + (FILEMAP (NIL (2525 14996 (NSPROTECTION 2535 . 5721) (NSPROT.SHOW 5723 . 6241) ( +NSPROT.FETCH.PROTECTION 6243 . 9177) (NSPROT.NEW.ENTRY 9179 . 9802) (NSPROT.APPLY 9804 . 10733) ( +NSPROT.SET.PROTECTION 10735 . 11311) (NSPROT.SET.PROTECTION.ONE 11313 . 12189) (NSPROT.SET.MULTIPLE +12191 . 13690) (NSPROT.SET.TO.DEFAULT 13692 . 14504) (NSPROT.BEGIN.COMMAND 14506 . 14994)) (14997 +22029 (NSPROT.HANDLE.TYPE 15007 . 15307) (NSPROT.RESTORE.TYPE 15309 . 15660) (NSPROT.HANDLE.VERIFY +15662 . 16022) (NSPROT.RESTORE.VERIFY 16024 . 16355) (NSPROT.PARSE.FILENAME 16357 . 18086) ( +NSPROT.PARSE.PROTECTIONS 18088 . 20583) (NSPROT.STRIP.HOST 20585 . 20966) (NSPROT.EXPAND.FULLNAME +20968 . 22027)) (22073 26624 (NSPROT.GET.SUBMENU 22083 . 23887) (NSPROT.ADD.SUBMENU 23889 . 24196) ( +NSPROT.REMOVE.SUBMENUS 24198 . 24618) (NSPROT.CHANGE.STATE 24620 . 24902) (NSPROT.HANDLE.ALL 24904 . +25146) (NSPROT.MESSAGE.ALL 25148 . 25420) (NSPROT.HANDLE.SUBTYPE 25422 . 25967) ( +NSPROT.SHOW.PROT.VALUE 25969 . 26622)) (26651 30154 (NSPROT.DIRECTORY.SYNTAXP 26661 . 26845) ( +NSPROT.TOP.LEVELP 26847 . 27009) (NSPROT.GET.FONT 27011 . 27530) (NSPROT.PROMPT 27532 . 28056) ( +NSPROT.CLEAR.PROMPT 28058 . 28941) (NSPROT.LIMITCHARS 28943 . 29366) (NSPROT.PAGEFULLFN 29368 . 29728) + (NSPROT.ICONFN 29730 . 30152)) (31446 32195 (ADD.NSPROTECTION 31456 . 32193))))) STOP diff --git a/lispusers/NSPROTECTION.LCOM b/lispusers/NSPROTECTION.LCOM index 8aa94ef4d1cde2cbc741a31e337104e79103cd56..26e696dbdee673e3d3f084c084cec921dd6c4a21 100644 GIT binary patch delta 829 zcmaF9opI_;#tH7pTpDhkKCaF|u8twDE(%IUhPsXgMY=`?MurN8hE}F#Rt9ED3K~ku z`MCv|IjJcM`FRRT3S8AL!QQntp~b01#dg_=1v!a%c0T#Zi8*$;sVOUQ=;%tEdY|l81Nh7J0mXvt4>EEs7IgsW5p!G!B!P~ceA96elr`7sCWN(l zhVv4TK3lidAhj>u1AwHJM>) delta 715 zcmZ9JO=uHA6vx@x+EU#}LE9>#FN3X#b=U50Vv@DQ=3~<)-F(<=)uNywSz=_f8=6g_ zlv0YG1VLE52!%@3L%j%lC_SnNK`fqo61{lvBzRMbZxV{&<;}d`y#IgRym`9AeBWlC zOl4SKDy=GsStX_^Ng!gFOX_7V5(Xh8ivc+}PQXXXR=rU(^a@xe5LiwYXI3T}3)X$T zY)9*Q#n6`|KIm*PCs##3utXBLOv!AUL}X!H4ulEV)WbMmff`z5+ZsR-6k@XpNVNEb|JgBtZ-XpnR`nR`n*ZwlyMy zFO@4ou2`7OYkX1B`0Sjjr3|a2|&N~1A diff --git a/sources/LLREAD b/sources/LLREAD index 11b33ada..ec0dd1f8 100644 --- a/sources/LLREAD +++ b/sources/LLREAD @@ -1 +1 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 4-Feb-2021 17:06:41" {DSK}larry>ilisp>medley>sources>LLREAD.;5 167254 changes to%: (VARS LLREADCOMS) (FNS LASTC PEEKC PEEKCCODE RATOM READ READC READCCODE READP SETREADMACROFLG SKIPSEPRCODES SKIPSEPRS \NSIN.24BITENCODING.ERROR SKREAD CL:READ CL:READ-PRESERVING-WHITESPACE CL:READ-DELIMITED-LIST CL:PARSE-INTEGER RSTRING READ-EXTENDED-TOKEN \RSTRING2 \TOP-LEVEL-READ \SUBREAD \SUBREADCONCAT \READ.SYMBOL \INVALID.SYMBOL \APPLYREADMACRO INREADMACROP READQUOTE READVBAR READHASHMACRO DEFMACRO-LAMBDA-LIST-KEYWORD-P DIGITBASEP READNUMBERINBASE ESTIMATE-DIMENSIONALITY SKIP.HASH.COMMENT CMLREAD.FEATURE.PARSER CHARACTER.READ CHARCODE.DECODE \MAKE.JIS.TO.XCCS.CONV.TABLE CONVHANKAKU \JISIN \JISPEEK \BACKJISCHAR \SHIFTJISIN \SHIFTJISPEEK \BACKSHIFTJISCHAR \EUCIN \EUCPEEK \BACKEUCCHAR \THROUGHIN \THROUGHPEEK \BACKTHROUGHCHAR \ORIG-INVALID.SYMBOL) previous date%: " 4-Feb-2021 12:10:07" {DSK}larry>ilisp>medley>sources>LLREAD.;4) (* ; " Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1993, 2021 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT LLREADCOMS) (RPAQQ LLREADCOMS [(COMS (* ; "Reader entrypoints") (FNS LASTC PEEKC PEEKCCODE RATOM READ READC READCCODE READP SETREADMACROFLG SKIPSEPRCODES SKIPSEPRS \NSIN.24BITENCODING.ERROR SKREAD)) (COMS (* ; "CommonLisp read entry points") (FNS CL:READ CL:READ-PRESERVING-WHITESPACE CL:READ-DELIMITED-LIST CL:PARSE-INTEGER) (GLOBALVARS CMLRDTBL)) (COMS (* ; "reading strings") (FNS RSTRING READ-EXTENDED-TOKEN \RSTRING2)) [COMS (* ; "Core of the reader") (FNS \TOP-LEVEL-READ \SUBREAD \SUBREADCONCAT \ORIG-READ.SYMBOL \ORIG-INVALID.SYMBOL \APPLYREADMACRO INREADMACROP) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (MOVD? '\ORIG-READ.SYMBOL '\READ.SYMBOL) (MOVD? '\ORIG-INVALID.SYMBOL '\INVALID.SYMBOL] (COMS (* ; "Read macro for '") (FNS READQUOTE)) (COMS (* ; "# macro") (FNS READVBAR READHASHMACRO DEFMACRO-LAMBDA-LIST-KEYWORD-P DIGITBASEP READNUMBERINBASE ESTIMATE-DIMENSIONALITY SKIP.HASH.COMMENT CMLREAD.FEATURE.PARSER)) (COMS (* ; "Reading characters with #\") (FNS CHARACTER.READ CHARCODE.DECODE) (VARS CHARACTERNAMES CHARACTERSETNAMES)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (CONSTANTS * READTYPES) (MACROS .CALL.SUBREAD. FIXDOT RBCONTEXT PROPRB \RDCONC) (EXPORT (MACROS \BACKCHAR \BACKNSCHAR \CHECKEOLC \INCHAR \INCCODE \PEEKCCODE \NSIN \NSPEEK NUMERIC-CHARSET)) (SPECVARS *READ-NEWLINE-SUPPRESS* \RefillBufferFn) (GLOBALVARS *KEYWORD-PACKAGE* *INTERLISP-PACKAGE*)) [COMS (* ;  "Support for various external formats") [COMS (* ; "JIS to XCCS conversion table.") (VARS *JIS-TO-XCCS-CONV-NO-FONT-TABLE* *JIS-TO-XCCS-CODE-MAP* *HANKAKU-TO-ZENKAKU-CODE-MAP*) (GLOBALVARS *JIS-TO-XCCS-CONV-NO-FONT-TABLE* *JIS-TO-XCCS-CONV-TABLE-LIST* *JIS-TO-XCCS-CODE-MAP* *HANKAKU-TO-ZENKAKU-CODE-MAP* *JIS-1KU-TO-XCCS-CONV-TABLE* *JIS-2KU-TO-XCCS-CONV-TABLE* *JIS-6KU-TO-XCCS-CONV-TABLE* *XCCS-TO-JIS-CONV-TABLE* *HANKAKU-TO-ZENKAKU-CONV-TABLE* *ZENKAKU-TO-HANKAKU-CONV-TABLE*) (FNS \MAKE.JIS.TO.XCCS.CONV.TABLE) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\MAKE.JIS.TO.XCCS.CONV.TABLE] [COMS (* ; "JIS to XCCS converter") (INITVARS (*REPLACE-NO-FONT-CODE* T) (*DEFAULT-NOT-CONVERTED-FAT-CODE* 8739)) (GLOBALVARS *REPLACE-NO-FONT-CODE* *DEFAULT-NOT-CONVERTED-FAT-CODE*) (DECLARE%: DOEVAL@COMPILE DONTCOPY (EXPORT (MACROS \CONV.JIS.TO.XCCS \DO.CONV.JIS.TO.XCCS] [COMS (* ; "XCCS to JIS converter") (FNS CONVHANKAKU) (DECLARE%: DOEVAL@COMPILE DONTCOPY (EXPORT (MACROS \CONV.XCCS.TO.JIS \DO.CONV.XCCS.TO.JIS \ASCIIP \NOT.EQUIVALENT.TO.JIS \CONV.HANKAKU.TO.ZENKAKUP \CONV.ZENKAKU.KANA] (COMS (FNS \JISIN \JISPEEK \BACKJISCHAR \SHIFTJISIN \SHIFTJISPEEK \BACKSHIFTJISCHAR \EUCIN \EUCPEEK \BACKEUCCHAR \THROUGHIN \THROUGHPEEK \BACKTHROUGHCHAR) (DECLARE%: DOEVAL@COMPILE DONTCOPY (EXPORT (* ;; "XCCS specific macro. Although the decoder and encoder are implemented as functions in general, only for XCCS, they are implemeted as macros for efficiency reason.") (MACROS \XCCSIN \XCCSPEEK \BACKXCCSCHAR \XCCSP) (* ;; "JIS specific macro") (MACROS \EXTRACT.NO.FONT.CODE \EXTARACT.CONV.TABLE \NOT.EQUIVALENT.TO.XCCS \EXTRACT.SET \EXTRACT.CODE \CHNAGE.KI.MODE \KIMODEP \HANKAKUP \KANJIP \NOTGAIJIP \INVALID.TENP \CONV.HANKAKU.KANA \OUTKI \OUTKO) (* ;; "Shift-JIS specific macro") (MACROS \CONV.SJIS.TO.JIS \CONV.JIS.TO.SJIS \SJIS.KANJI.FIRST.BYTEP ) (* ;; "EUC specific macro") (MACROS \EUC.KANJI.FIRST.BYTEP \GAIJIP \EUC.HANKAKUP] (INITVARS (*SIGNAL-24BIT-NSENCODING-ERROR*) (*READ-NEWLINE-SUPPRESS*) (\RefillBufferFn (FUNCTION \READCREFILL))) (* ;  "Top level val of \RefillBufferFn means act like READC--we must be doing a raw BIN (or PEEKBIN?)") (LOCALVARS . T) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA CONVHANKAKU CL:PARSE-INTEGER CL:READ-DELIMITED-LIST CL:READ-PRESERVING-WHITESPACE CL:READ]) (* ; "Reader entrypoints") (DEFINEQ (LASTC [LAMBDA (FILE) (* ; "Edited 6-Jan-88 15:31 by jds") (* ;; "Be careful only to do BIN's if we first were able to back up, so that an EOF doesn't happen. This is really an inadequate implementation, because it fails for files that cannot be backed up. Eventually, we must change the character reading functions READ, RATOM, READC to save the last character they read in an STREAM field.") (LET* ((STREAM (\GETSTREAM FILE 'INPUT)) (LASTCCODE (FETCH (STREAM LASTCCODE) OF STREAM))) (* ;; "(FCHARACTER (SELCHARQ C (CR (SELECTC (ffetch EOLCONVENTION of STREAM) (CR.EOLC (CHARCODE EOL)) C)) (LF (SELECTC (ffetch EOLCONVENTION of STREAM) (LF.EOLC (CHARCODE EOL)) (CRLF.EOLC (COND ((EQ (CHARCODE CR) (UNINTERRUPTABLY (AND (\BACKNSCHAR STREAM SHIFTEDCHARSET) (PROG1 (PROGN (\BACKNSCHAR STREAM SHIFTEDCHARSET) (\NSIN STREAM SHIFTEDCHARSET)) (\NSIN STREAM SHIFTEDCHARSET))))) (CHARCODE EOL)) (T C))) C)) (NIL 0) C))") (COND ((IEQP LASTCCODE 65535) NIL) (T (FCHARACTER LASTCCODE]) (PEEKC [LAMBDA (FILE FLG) (* rmk%: "10-Apr-85 11:55") (* ;; "FLG says to proceed as if Control were T--not implemented correctly here NIL") (LET [(\RefillBufferFn (FUNCTION \PEEKREFILL)) (STREAM (\GETSTREAM FILE 'INPUT] (DECLARE (SPECVARS \RefillBufferFn)) (FCHARACTER (PEEKCCODE STREAM]) (PEEKCCODE [LAMBDA (FILE NOERROR) (* bvm%: "12-Sep-86 15:19") (LET [(\RefillBufferFn (FUNCTION \PEEKREFILL)) (STREAM (\GETSTREAM FILE 'INPUT] (DECLARE (SPECVARS \RefillBufferFn)) (\PEEKCCODE STREAM NOERROR]) (RATOM [LAMBDA (FILE RDTBL) (* ; "Edited 30-Mar-87 17:21 by bvm:") (* ;;; "Like READ except interpret break characters as single character atoms. I.e., always returns an atom") (SETQ RDTBL (\GTREADTABLE RDTBL)) (LET ((*READTABLE* RDTBL) (*PACKAGE* (if (fetch (READTABLEP USESILPACKAGE) of RDTBL) then *INTERLISP-PACKAGE* else *PACKAGE*)) (\RefillBufferFn (FUNCTION \RATOM/RSTRING-REFILL))) (DECLARE (SPECVARS *READTABLE* *PACKAGE* \RefillBufferFn)) (WITH-RESOURCE (\PNAMESTRING) (\SUBREAD (\GETSTREAM FILE 'INPUT) (fetch (READTABLEP READSA) of *READTABLE*) RATOM.RT \PNAMESTRING (AND (fetch (READTABLEP CASEINSENSITIVE) of *READTABLE*) (fetch (ARRAYP BASE) of UPPERCASEARRAY)) NIL NIL NIL T]) (READ [LAMBDA (FILE RDTBL FLG) (* ; "Edited 19-Mar-87 18:35 by bvm:") (LET ((*READTABLE* (\GTREADTABLE RDTBL)) (*READ-NEWLINE-SUPPRESS* FLG)) (DECLARE (SPECVARS *READTABLE* *READ-NEWLINE-SUPPRESS*)) (* ;; "*READ-NEWLINE-SUPPRESS* is used freely by \FILLBUFFER") (* ;; "Call reader with PRESERVE-WHITESPACE = T, since that's the semantics Interlisp has always had before (though maybe not explicitly stated).") (\TOP-LEVEL-READ FILE NIL NIL NIL T]) (READC [LAMBDA (FILE RDTBL) (* ; "Edited 6-Jan-88 15:30 by jds") (LET ((*READTABLE* (\GTREADTABLE RDTBL)) (\RefillBufferFn (FUNCTION \READCREFILL))) (DECLARE (SPECVARS *READTABLE* \RefillBufferFn)) (FCHARACTER (REPLACE (STREAM LASTCCODE) OF (\INSTREAMARG FILE) WITH (\INCCODE (\INSTREAMARG FILE]) (READCCODE [LAMBDA (FILE RDTBL) (* ; "Edited 3-Jun-88 01:30 by atm") (* ;;; "returns a 16 bit character code. \INCHAR does the EOL conversion and this function converts to a 16 bit value. Saves the character for LASTC as well.") (SETQ FILE (\GETSTREAM FILE 'INPUT)) (FDEVOP 'READCHARCODE (fetch (STREAM DEVICE) of FILE) FILE RDTBL]) (READP [LAMBDA (FILE FLG) (* rmk%: " 5-Apr-85 09:09") (* ;  "The 10 does not do the EOL check on the peeked character.") (LET* ((STREAM (\GETSTREAM FILE 'INPUT)) (DEVICE (ffetch (STREAM DEVICE) of STREAM))) (COND ((ffetch (FDEV READP) of DEVICE) (FDEVOP 'READP DEVICE STREAM FLG)) (T (\GENERIC.READP STREAM FLG]) (SETREADMACROFLG [LAMBDA (FLG) (* rmk%: "25-OCT-83 16:13") (* ;  "D doesn't cause the read-macro context error, hence doesn't maintain this flag") NIL]) (SKIPSEPRCODES [LAMBDA (FILE RDTBL) (* ; "Edited 6-Jan-88 13:09 by jds") (* ;; "Passes over non-separators to peek at the first non-separator on FILE. Returns either last peeked character, or NIL if no non-seprs left in the file.") (bind PREVC C SHIFTEDCHARSET (STREAM _ (\GETSTREAM FILE 'INPUT)) (SA _ (fetch (READTABLEP READSA) of (\GTREADTABLE RDTBL))) (\RefillBufferFn _ '\PEEKREFILL) first (SETQ SHIFTEDCHARSET (UNFOLD (ACCESS-CHARSET STREAM) 256)) declare (SPECVARS \RefillBufferFn) while [EQ SEPRCHAR.RC (\SYNCODE SA (SETQ C (OR (\NSPEEK STREAM SHIFTEDCHARSET SHIFTEDCHARSET T) (RETURN] do (SETQ PREVC C) (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET) finally (AND PREVC (replace (STREAM LASTCCODE) of STREAM with PREVC)) (RETURN C]) (SKIPSEPRS [LAMBDA (FILE RDTBL) (* ; "Edited 11-Sep-87 17:52 by bvm:") (* ;; "Passes over non-separators to peek at the first non-separator on FILE. Returns either last peeked character, or NIL if no non-seprs left in the file.") (bind C SHIFTEDCHARSET (STREAM _ (\GETSTREAM FILE 'INPUT)) (SA _ (fetch (READTABLEP READSA) of (\GTREADTABLE RDTBL))) (\RefillBufferFn _ '\PEEKREFILL) first (SETQ SHIFTEDCHARSET (UNFOLD (ACCESS-CHARSET STREAM) 256)) declare (SPECVARS \RefillBufferFn) while [EQ SEPRCHAR.RC (\SYNCODE SA (SETQ C (OR (\NSPEEK STREAM SHIFTEDCHARSET SHIFTEDCHARSET T) (RETURN] do (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET) finally (RETURN (FCHARACTER C]) (\NSIN.24BITENCODING.ERROR [LAMBDA (STREAM) (* bvm%: "12-Mar-86 15:35") (DECLARE (USEDFREE *SIGNAL-24BIT-NSENCODING-ERROR*)) (* ;;; "Called if we see the sequence shift,shift on STREAM -- means shift to 24-bit character set, which we don't support. Usually this just means we're erroneously reading a binary file as text. If this function returns, its value is taken as a character set to shift to") (COND (*SIGNAL-24BIT-NSENCODING-ERROR* (* ;  "Only cause error if user/reader cares") (ERROR "24-bit NS encoding not supported" STREAM))) (* ; "Return charset zero") 0]) (SKREAD [LAMBDA (FILE REREADSTRING RDTBL) (* ; "Edited 6-Apr-88 11:06 by amd") (LET ((*READ-SUPPRESS* 'SKREAD) (*READTABLE* (\GTREADTABLE RDTBL)) (\RBFLG) (STRM (\GETSTREAM FILE 'INPUT)) CH) (DECLARE (CL:SPECIAL *READTABLE* *READ-SUPPRESS* \RBFLG)) [COND (REREADSTRING (* ;  "REREADSTRING is string of chars already read.") (SETQ STRM (CL:MAKE-CONCATENATED-STREAM (CL:MAKE-STRING-INPUT-STREAM (MKSTRING REREADSTRING )) STRM] (* ;  "Because of return requirements, have to preview stream for unbalanced closing bracket/paren") (if (NULL (SETQ CH (SKIPSEPRCODES STRM))) then (\EOF.ACTION STRM) else (SELECTC (PROG1 (\SYNCODE (fetch (READTABLEP READSA) of *READTABLE*) CH) (* ;; "Read in suppressed mode. Reader sets \Rbflg free if read ended on unbalanced bracket. Reason we do the READ in all cases is so that we need to consume the unbalanced paren/bracket, just as if we really had read it; however, READ doesn't set \Rbflg for these cases") (\TOP-LEVEL-READ STRM NIL NIL NIL T)) (RIGHTPAREN.RC (* ; "unbalanced right paren") '%)) (RIGHTBRACKET.RC (* ; "unbalanced right bracket") '%]) (AND \RBFLG '%]]) ) (* ; "CommonLisp read entry points") (DEFINEQ (CL:READ [CL:LAMBDA (&OPTIONAL (INPUT-STREAM *STANDARD-INPUT*) (EOF-ERROR-P T) EOF-VALUE RECURSIVE-P) (* ; "Edited 14-Dec-86 18:48 by bvm") (COND (RECURSIVE-P (* ;  "Dive straight into reader using current settings of everything") (.CALL.SUBREAD. INPUT-STREAM)) (T (\TOP-LEVEL-READ INPUT-STREAM (NOT EOF-ERROR-P) EOF-VALUE]) (CL:READ-PRESERVING-WHITESPACE [CL:LAMBDA (&OPTIONAL (STREAM *STANDARD-INPUT*) (EOF-ERRORP T) (EOF-VALUE NIL) (RECURSIVEP NIL)) (* ; "Edited 19-Mar-87 18:33 by bvm:") (* ;; "Reads from stream and returns the object read, preserving the whitespace that followed the object.") (COND (RECURSIVEP (* ;  "Dive straight into reader using current settings of everything") (.CALL.SUBREAD. STREAM)) (T (\TOP-LEVEL-READ STREAM (NOT EOF-ERRORP) EOF-VALUE NIL T]) (CL:READ-DELIMITED-LIST [CL:LAMBDA (CHAR &OPTIONAL (INPUT-STREAM *STANDARD-INPUT*) RECURSIVE-P) (* ; "Edited 14-Dec-86 18:48 by bvm") (* ;;; "Read a list of elements terminated by CHAR. CHAR must not be a separator char, and ideally should not be a constituent char (if it is, it must be preceded by whitespace for READ-DELIMITED-LIST to work)") (LET [(ENDCODE (OR (FIXP CHAR) (CL:CHAR-CODE CHAR))) (INSTREAM (\GETSTREAM INPUT-STREAM 'INPUT] (if RECURSIVE-P then (* ;  "Have to dive into reader without disturbing *CIRCLE-READ-LIST*") (.CALL.SUBREAD. INPUT-STREAM NIL NIL ENDCODE) else (\TOP-LEVEL-READ INPUT-STREAM NIL NIL ENDCODE]) (CL:PARSE-INTEGER [CL:LAMBDA (STRING &KEY START END (RADIX 10) JUNK-ALLOWED) (* ;  "Edited 8-Feb-91 13:24 by gadener") (CL:IF (NOT (CL:STRINGP STRING)) (ERROR "This is not a string : ~S" STRING) (PROG ((SA (fetch (READTABLEP READSA) of CMLRDTBL)) (BASE (fetch (STRINGP BASE) of STRING)) (LEN (fetch (STRINGP LENGTH) of STRING)) (OFFST (fetch (STRINGP OFFST) of STRING)) (FATP (fetch (STRINGP FATSTRINGP) of STRING)) MAXDIGITCODE MAXALPHACODE INDEX STOP CHAR SIGN STARTINT ENDINT ERR) (SETQ RADIX (\CHECKRADIX RADIX)) (SETQ INDEX (+ OFFST (if (NULL START) then 0 elseif (< START 0) then (\ILLEGAL.ARG START) else START))) (SETQ STOP (+ OFFST (if (NULL END) then LEN elseif (OR (> END LEN) (< END 0)) then (\ILLEGAL.ARG END) else END))) (SETQ MAXDIGITCODE (+ (CHARCODE 0) RADIX -1)) (SETQ MAXALPHACODE (AND (> RADIX 10) (+ (CHARCODE A) RADIX -11))) (while (AND (< INDEX STOP) (EQ (\SYNCODE SA (\GETBASECHAR FATP BASE INDEX)) SEPRCHAR.RC)) do (* ; "Skip over separators") (SETQ INDEX (CL:1+ INDEX))) [COND ((>= INDEX STOP) (* ; "no characters remain") (RETURN (COND (JUNK-ALLOWED (* ; "don't error") (CL:VALUES NIL STOP)) (T (SETQ ERR "No non-whitespace characters in integer string: ~S") (GO FAIL] (* ;; "Start parsing a number. Allowed to start with a single sign, then digits in radix, nothing else. Assume collating sequence is (+, -) < digits < uppercase letters < lowercase letters.") (do (SETQ CHAR (\GETBASECHAR FATP BASE INDEX)) (if (<= CHAR MAXDIGITCODE) then (* ; "sign or digit") (if (>= CHAR (CHARCODE 0)) then (* ; " digit") (OR STARTINT (SETQ STARTINT INDEX)) elseif (AND (NOT SIGN) (NOT STARTINT)) then (* ;  "maybe sign. No good if not at start") (SELCHARQ CHAR (- (SETQ SIGN '-)) (+ (SETQ SIGN '+)) (RETURN)) else (RETURN)) elseif (AND MAXALPHACODE (<= (if (>= CHAR (CHARCODE "a")) then (* ; "uppercase it first") (- CHAR (- (CHARCODE "a") (CHARCODE "A"))) else CHAR) MAXALPHACODE)) then (* ; "is alphabetic digit") (OR STARTINT (SETQ STARTINT INDEX)) else (RETURN)) repeatwhile (< (add INDEX 1) STOP)) (SETQ ENDINT INDEX) (RETURN (CL:VALUES (COND ([AND STARTINT (OR JUNK-ALLOWED (EQ INDEX STOP) (do (if (NEQ (\SYNCODE SA CHAR) SEPRCHAR.RC) then (* ; " junk found") (RETURN NIL) elseif (EQ (add INDEX 1) STOP) then (* ; "at end of string, win") (RETURN T) else (SETQ CHAR (\GETBASECHAR FATP BASE INDEX] (\MKINTEGER BASE STARTINT ENDINT (EQ SIGN '-) RADIX FATP)) (JUNK-ALLOWED NIL) ((NULL STARTINT) (SETQ ERR "There aren't any digits in this integer string: ~S.") (GO FAIL)) (T (SETQ ERR "There is junk in this integer string: ~S.") (GO FAIL))) (- INDEX OFFST))) FAIL (CL:ERROR ERR (if (OR START END) then (CL:SUBSEQ STRING (OR START 0) (OR END LEN)) else STRING))))]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS CMLRDTBL) ) (* ; "reading strings") (DEFINEQ (RSTRING [LAMBDA (FILE RDTBL RSFLG) (* ; "Edited 22-Mar-87 20:53 by bvm:") (LET ((*READTABLE* (\GTREADTABLE RDTBL)) (\RefillBufferFn '\RATOM/RSTRING-REFILL) (*READ-SUPPRESS* NIL)) (DECLARE (SPECVARS *READTABLE* \RefillBufferFn *READ-SUPPRESS*)) (* ;; "It's not clear that *READ-SUPPRESS* is supposed to affect anything other than calls to READ. So play it safe and force \Rstring2 to really read a string.") (WITH-RESOURCE (\PNAMESTRING) (\RSTRING2 (\GETSTREAM FILE 'INPUT) (fetch READSA of *READTABLE*) (OR RSFLG T) \PNAMESTRING]) (READ-EXTENDED-TOKEN [LAMBDA (STREAM RDTBL ESCAPE-ALLOWED-P) (* ; "Edited 11-Sep-87 16:23 by bvm:") (* ;; "This is a cross between RSTRING and \SUBREAD. Read a %"token%" from STREAM, as defined by the Common Lisp reader and the syntax in RDTBL. EOF terminates as well. If ESCAPE-ALLOWED-P is true, escapes are honored and if one appears, a second value of T is returned. Otherwise, escapes are treated as vanilla chars and the caller can barf on them itself if it desires.") (SETQ RDTBL (\GTREADTABLE RDTBL)) (WITH-RESOURCE (\PNAMESTRING) (PROG ((CASEBASE (AND (fetch (READTABLEP CASEINSENSITIVE) of RDTBL) (fetch (ARRAYP BASE) of UPPERCASEARRAY))) (PBASE (ffetch (STRINGP XBASE) of \PNAMESTRING)) (SHIFTEDCHARSET (UNFOLD (ACCESS-CHARSET STREAM) 256)) (J 0) (SA (fetch READSA of RDTBL)) CH SNX ANSLIST ANSTAIL ESCAPE-APPEARED ESCAPING FATSEEN) LP (if (\EOFP STREAM) then (* ;  "end of file terminates string just like a sepr/break") (GO FINISH)) (SETQ CH (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET)) (* ; "NOTE: This should really be (\CHECKEOLC (\NSIN --) --), but eol is usually a break or sepr and the \BACKNSCHAR doesn't work right. Fix this when we unread correctly") (SETQ SNX (\SYNCODE SA CH)) [COND ((AND ESCAPE-ALLOWED-P (SELECTC SNX (ESCAPE.RC (SETQ CH (\CHECKEOLC (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET) (ffetch EOLCONVENTION of STREAM) STREAM)) (SETQ ESCAPE-APPEARED T)) (MULTIPLE-ESCAPE.RC (SETQ ESCAPING (NOT ESCAPING)) (SETQ ESCAPE-APPEARED T) (GO LP)) NIL))) (ESCAPING (* ; "eat chars until next |")) ((fetch STOPATOM of SNX) (\BACKNSCHAR STREAM SHIFTEDCHARSET) (GO FINISH)) ((AND CASEBASE (ILEQ CH \MAXTHINCHAR)) (SETQ CH (\GETBASEBYTE CASEBASE CH] (COND ((EQ J \PNAMELIMIT) (* ;  "Filled PNSTR so have to save those chars away and start filling up a new buffer") (SETQ J (\SMASHSTRING (ALLOCSTRING J NIL NIL FATSEEN) 0 \PNAMESTRING J)) [COND [ANSLIST (RPLACD ANSTAIL (SETQ ANSTAIL (CONS J NIL] (T (SETQ ANSTAIL (SETQ ANSLIST (CONS J NIL] (SETQ J 0))) (\PNAMESTRINGPUTCHAR PBASE J CH) (COND ((AND (NOT FATSEEN) (IGREATERP CH \MAXTHINCHAR)) (SETQ FATSEEN T))) (SETQ J (ADD1 J)) (GO LP) FINISH (SETQ J (\SMASHSTRING (ALLOCSTRING J NIL NIL FATSEEN) 0 \PNAMESTRING J)) [COND (ANSLIST (RPLACD ANSTAIL (SETQ ANSTAIL (CONS J NIL))) (SETQ J (CONCATLIST ANSLIST] (RETURN (if ESCAPE-APPEARED then (* ;  "do it this way because multiple values are slow") (CL:VALUES J T) else J]) (\RSTRING2 [LAMBDA (STREAM SA RSFLG PNSTR) (* ;  "Edited 4-Aug-93 12:38 by sybalskY:MV:ENVOS") (* ;;; "The main string reader. Reads characters from STREAM according to the syntax table SA and returns a string. PNSTR is an instance of the global resource \PNAMESTRING, which we can use all to ourselves as a buffer.") (* ;;; "If RSFLG is T then the call is from RSTRING, in which case the string is terminated by a break or sepr in SA. If RSFLG is NIL then the string is terminated by a string delimiter. If RSFLG is SKIP then CR's and the following separator chars are discarded as an otherwise normal string is read") (DECLARE (USEDFREE *READTABLE* *READ-SUPPRESS*)) (PROG ((EOLC (ffetch EOLCONVENTION of STREAM)) (PBASE (SELECTQ (SYSTEMTYPE) (VAX PNSTR) (ffetch (STRINGP XBASE) of PNSTR))) (SHIFTEDCHARSET (UNFOLD (ACCESS-CHARSET STREAM) 256)) (J 0) EOLCHAR CH SNX ANSLIST ANSTAIL LASTC FATSEEN SKIPPING) (SELECTC EOLC (CRLF.EOLC (SETQ EOLCHAR (CHARCODE CR))) (CR.EOLC (SETQ EOLCHAR (CHARCODE CR))) (LF.EOLC (SETQ EOLCHAR (CHARCODE LF))) NIL) RS2LP (SETQ CH (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET)) [COND ((EQ CH EOLCHAR) (* ;; "We just read the stream's EOL character, so we have to turn it into our EOL. Most places do this with \CHECKEOLC, but we can't do that here, because if the eol is CRLF and would terminate the read, \BACKNSCHAR won't work right.") (COND ([AND (EQ RSFLG T) (fetch STOPATOM of (\SYNCODE SA (CHARCODE CR] (* ;  "From RSTRING, eol terminates read. Leave eol in buffer") (\BACKNSCHAR STREAM SHIFTEDCHARSET) (GO FINISH)) (T (COND ((AND (EQ EOLC CRLF.EOLC) (EQ (\PEEKBIN STREAM T) (CHARCODE LF))) (* ; "Eat the LF after the CR") (\BIN STREAM))) (SETQ CH (CHARCODE CR] (SETQ SNX (\SYNCODE SA CH)) (SELECTC SNX (OTHER.RC (* ; "Normal case, nothing to do")) (ESCAPE.RC [COND ((fetch ESCAPEFLG of *READTABLE*) (SETQ CH (\CHECKEOLC (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET) EOLC STREAM)) (COND ((AND (EQ RSFLG 'SKIP) (EQ CH (CHARCODE CR))) (* ;  "Strip leading spaces after escaped returns, too, but leave the CR in the string") (SETQ SKIPPING 0) (GO PUTCHAR]) (SELECTQ RSFLG (NIL (* ; "end check is dbl quote") (COND ((EQ SNX STRINGDELIM.RC) (* ; "Got it") (SETQ LASTC CH) (GO FINISH)))) (T (* ;  "if called from RSTRING, end check is break or sepr, and we must leave delim in stream") (COND ((fetch STOPATOM of SNX) (\BACKNSCHAR STREAM SHIFTEDCHARSET) (GO FINISH)))) (SKIP (* ;  "Like NIL but strip cr's and leading spaces") (SELECTC SNX (STRINGDELIM.RC (SETQ LASTC CH) (GO FINISH)) (SEPRCHAR.RC (* ; "Assume that CR is a sepr") (COND [SKIPPING (COND ((EQ CH (CHARCODE EOL)) (* ;  "Multiple CR's while skipping are kept") (COND ((EQ SKIPPING T) (* ;  "Turn previous space back into CR. Note that J is guaranteed to be at least 1") (\PNAMESTRINGPUTCHAR PBASE (SUB1 J) CH) (SETQ SKIPPING 0))) (GO PUTCHAR)) (T (* ; "Continue skipping seprs") (GO RS2LP] ((EQ CH (CHARCODE EOL)) (* ;  "Turn CR into space and start skipping seprs") (SETQ SKIPPING T) (SETQ CH (CHARCODE SPACE)) (GO PUTCHAR)))) NIL)) (SHOULDNT))) (SETQ SKIPPING NIL) PUTCHAR [COND ((NOT *READ-SUPPRESS*) (* ; "Accumulate character") (COND ((EQ J \PNAMELIMIT) (* ;  "Filled PNSTR so have to save those chars away and start filling up a new buffer") (SETQ J (\SMASHSTRING (ALLOCSTRING J NIL NIL FATSEEN) 0 PNSTR J)) [COND [ANSLIST (RPLACD ANSTAIL (SETQ ANSTAIL (CONS J NIL] (T (SETQ ANSTAIL (SETQ ANSLIST (CONS J NIL] (SETQ J 0))) (\PNAMESTRINGPUTCHAR PBASE J CH) (SETQ LASTC CH) (COND ((AND (NOT FATSEEN) (IGREATERP CH \MAXTHINCHAR)) (SETQ FATSEEN T))) (SETQ J (ADD1 J] (COND ((OR (NEQ RSFLG T) (NOT (\EOFP STREAM))) (* ; "in RSTRING (RSFLG=T), if we've read something already, then end of file terminates string just like a sepr/break") (GO RS2LP))) FINISH (AND LASTC (replace (STREAM LASTCCODE) of STREAM with LASTC)) (RETURN (COND ((NOT *READ-SUPPRESS*) (SETQ J (\SMASHSTRING (ALLOCSTRING J NIL NIL FATSEEN) 0 PNSTR J)) (COND (ANSLIST (RPLACD ANSTAIL (SETQ ANSTAIL (CONS J NIL))) (CONCATLIST ANSLIST)) (T J]) ) (* ; "Core of the reader") (DEFINEQ (\TOP-LEVEL-READ [LAMBDA (STREAM EOF-SUPPRESS EOF-VALUE CHAR PRESERVE-WHITESPACE) (* ; "Edited 13-Dec-88 16:28 by jds") (* ;; "Entry to the guts of the reader from a place where you may not be already under the reader. CHAR is for READ-DELIMITED-LIST -- it is charcode to terminate read, in which case we are reading a sequence of things instead of a single thing. EOF-SUPPRESS is the opposite of CL:READ's EOF-ERROR-P arg.") (* ;;  " I EOF-SUPPRESS, set the stream's EODOFSTREAMOP to retfrom here with EOF-VALUE as its result.") (LET ((*PACKAGE* (COND ((fetch (READTABLEP USESILPACKAGE) of (\DTEST *READTABLE* 'READTABLEP)) *INTERLISP-PACKAGE*) (T *PACKAGE*))) (\RefillBufferFn (FUNCTION \READREFILL)) (*CIRCLE-READ-LIST* NIL) (OLD-EOS-OP (fetch ENDOFSTREAMOP of STREAM))) (DECLARE (SPECVARS *PACKAGE* \RefillBufferFn *CIRCLE-READ-LIST* EOF-VALUE)) (CL:UNWIND-PROTECT (PROGN [AND EOF-SUPPRESS (REPLACE ENDOFSTREAMOP OF STREAM WITH #'(LAMBDA (STREAM) (RETFROM '\TOP-LEVEL-READ EOF-VALUE] (LET ((RESULT (.CALL.SUBREAD. STREAM EOF-SUPPRESS EOF-VALUE CHAR PRESERVE-WHITESPACE))) (if *CIRCLE-READ-LIST* then (* ;  "There were calls to #=, so go fix up all the ## references.") (HASH-STRUCTURE-SMASH RESULT)) RESULT)) (REPLACE ENDOFSTREAMOP OF STREAM WITH OLD-EOS-OP))]) (\SUBREAD [LAMBDA (STREAM SA READTYPE PNSTR CASEBASE EOF-SUPPRESS EOF-VALUE CHAR PRESERVE-WHITESPACE) (* ; "Edited 7-Jan-88 18:38 by jds") (* ;; "Values of READTYPE are: --- READ.RT for top level of READ, --- NOPROPRB.RT if right-bracket isn't to be propagated -- sublist beginning with left-bracket --- PROPRB.RT if propagation is not suppressed -- sublist beginning with left-paren --- RATOM.RT for call from RATOM") (* ;; "PNSTR is an instance of the global resource \PNAMESTRING, acquired in READ and passed on from level to level. It is released during read-macro applications, then reacquired.") (* ;; "CASEBASE is base of uppercasearray if read table is case-insensitive.") (* ;; "If EOF-SUPPRESS is true, then if we are at end of file we should return EOF-VALUE instead of erroring (we need this because we might actually be sitting before end of file in front of something that reads nothing, e.g., a comment, so caller can't check EOFP itself). Always false on recursive calls.") (* ;; "If CHAR is supplied, it is a character code which, when read (in isolation), should terminate this call to read. Never on when at top-level.") (* ;; "\RBFLG is propagated for top-level calls, in case they are embedded in read-macros. SKREAD also depends on this.") (* ;;  "If PRESERVE-WHITESPACE is true, doesn't throw away the whitespace that terminates the read.") (DECLARE (USEDFREE *READTABLE* \RBFLG)) (* ;; "\RDCONC is a macro that adds a new element as specified by its first argument to the current sublist. Its other arguments will be executed instead if we are the top-level call") (PROG ((TOPLEVELP (SELECTC READTYPE ((LIST READ.RT RATOM.RT) T) NIL)) (SHIFTEDCHARSET (UNFOLD (ACCESS-CHARSET STREAM) 256)) (PBASE (SELECTQ (SYSTEMTYPE) (VAX PNSTR) (ffetch (STRINGP XBASE) of PNSTR))) SNX LST END ELT DOTLOC CH J ESCAPEFLG INVALIDFLG PACKAGE NCOLONS AT-EOF EOF-POSSIBILITY EXTRASEGMENTS LASTC) (if (AND TOPLEVELP (NOT (\INTERMP STREAM))) then (* ;; "EOF is allowed to terminate tokens on direct READ calls. Not if reading from terminal, because \FILLBUFFER made sure to put something at the end.") (SETQ EOF-POSSIBILITY T)) NEWTOKEN (* ;; "Here ready to scan a new token. First skip over separator characters") (SETQ J 0) [SETQ EXTRASEGMENTS (SETQ INVALIDFLG (SETQ ESCAPEFLG (SETQ PACKAGE (SETQ NCOLONS NIL] (if (AND EOF-SUPPRESS (NULL (SKIPSEPRCODES STREAM))) then (* ;  "caller specified eof-error-p of NIL. Happens only on top-level calls") (RETURN EOF-VALUE)) (SETQ SHIFTEDCHARSET (UNFOLD (ACCESS-CHARSET STREAM) 256)) (* ; "By Skipping Separator Characters,Happens CHARSET-Mode Exchanging. (Solution of AR#114 in FX, edited by tt [Jan-22-'90])") (repeatwhile (EQ [SETQ SNX (\SYNCODE SA (SETQ CH (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET] SEPRCHAR.RC)) (COND ((EQ CH CHAR) (* ;  "Read desired terminating char. TOPLEVELP is always false here") (replace (STREAM LASTCCODE) of STREAM with CH) (* ; "Save last char for LASTC.") (RETURN LST)) ((EQ SNX OTHER.RC) (* ; "Start of an atom") (COND ([AND (EQ CH (CHARCODE %.)) (fetch STOPATOM of (\SYNCODE SA (\NSPEEK STREAM SHIFTEDCHARSET SHIFTEDCHARSET] (* ;; "An isolated, unescaped dot. This special check on every atom could be eliminated if . had a special SNX code") (SETQ DOTLOC END) (* ;  "DOTLOC points to CONS cell one before the dot, NIL for car of list, as desired.") )) (GO GOTATOMCHAR)) [(fetch STOPATOM of SNX) (* ;  "This character definitely does not start an atom") (COND ((EQ READTYPE RATOM.RT) (GO SINGLECHARATOM)) (T (GO BREAK] ((EQ SNX PACKAGEDELIM.RC) (* ;  "Starting a symbol with a package delimiter -- must be a keyword") (SETQ NCOLONS 1) (SETQ PACKAGE *KEYWORD-PACKAGE*) (SETQ ESCAPEFLG T) (GO NEXTATOMCHAR)) [(AND (SELECTC (fetch MACROCONTEXT of SNX) (FIRST.RMC T) (ALONE.RMC (fetch STOPATOM of (\SYNCODE SA (\NSPEEK STREAM SHIFTEDCHARSET SHIFTEDCHARSET)))) NIL) (fetch READMACROFLG of *READTABLE*)) (COND ((EQ READTYPE RATOM.RT) (GO SINGLECHARATOM)) (T (GO MACRO] (T (* ;  "Some character that starts an atom but has non-trivial syntax attributes") )) ATOMLOOP (* ;; "At this point, we are accumulating an atom, and CH does not have syntax OTHER, so we have to check special cases") (SELECTC SNX (ESCAPE.RC (* ;  "Take next character to be alphabetic, case exact") (COND ((fetch ESCAPEFLG of *READTABLE*) (SETQ CH (\CHECKEOLC (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET) (ffetch EOLCONVENTION of STREAM) STREAM)) (* ;  "No EOFP check needed -- it's an error to have escape char with nothing following") (SETQ ESCAPEFLG T) (GO PUTATOMCHAR)))) (MULTIPLE-ESCAPE.RC (* ;; "Take characters up to next multiple escape to be alphabetic, except that single escape chars still escape the next char") (SETQ ESCAPEFLG T) [bind ESCFLG do (SETQ CH (\CHECKEOLC (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET) (ffetch EOLCONVENTION of STREAM) STREAM)) (COND ([NOT (COND (ESCFLG (SETQ ESCFLG NIL)) (T (SELECTC (SETQ SNX (\SYNCODE SA CH)) (MULTIPLE-ESCAPE.RC (* ;  "Finished escaped sequence, resume normal processing") (GO NEXTATOMCHAR)) (ESCAPE.RC (* ;  "Pass the next char thru verbatim") (SETQ ESCFLG T)) NIL] (* ;  "All others are pname chars, quoted") (if (NOT *READ-SUPPRESS*) then (COND ((EQ J \PNAMELIMIT) (* ;  "if there have been escapes, can't be a number, so ok to error now.") (LISPERROR "ATOM TOO LONG" (\SUBREADCONCAT EXTRASEGMENTS PBASE J)) (GO NEWTOKEN))) (\PNAMESTRINGPUTCHAR PBASE J CH) (add J 1]) NIL) GOTATOMCHAR (* ;; "CH is a vanilla atom char to accumulate") [COND ((AND CASEBASE (ILEQ CH \MAXTHINCHAR)) (* ; "Uppercase atom characters") (SETQ CH (\GETBASEBYTE CASEBASE CH] PUTATOMCHAR (if (NOT *READ-SUPPRESS*) then (COND ((EQ J \PNAMELIMIT) (* ; "Symbol is too long. However, it could just be a bignum, so keep accumulating characters until we have to do something.") (push EXTRASEGMENTS (\SMASHSTRING (ALLOCSTRING J NIL NIL T) 0 PNSTR J)) (SETQ J 0))) (\PNAMESTRINGPUTCHAR PBASE J CH) (add J 1) (SETQ LASTC CH) (* ; "Save CH for LASTC.")) NEXTATOMCHAR (if (AND EOF-POSSIBILITY (SETQ AT-EOF (\EOFP STREAM))) then (* ;  "EOF terminates atoms at top level") (GO FINISHATOM) elseif (EQ [SETQ SNX (\SYNCODE SA (SETQ CH (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET] OTHER.RC) then (* ;  "normal case tested first--another vanilla constituent char, so keep accumulating atom chars") (GO GOTATOMCHAR) elseif (fetch STOPATOM of SNX) then (* ; "Terminates atom") (GO FINISHATOM) elseif (EQ SNX PACKAGEDELIM.RC) then (GO GOTPACKAGEDELIM) else (GO ATOMLOOP)) FINISHATOM (* ;;  "Come here when an atom has been terminated, either by a break/sepr char or by end of file.") (if INVALIDFLG then (replace (STREAM LASTCCODE) of STREAM with (OR LASTC CH 65535)) (\INVALID.SYMBOL PBASE J NCOLONS PACKAGE EXTRASEGMENTS)) [SETQ ELT (AND (NOT *READ-SUPPRESS*) (if EXTRASEGMENTS then (* ;; "More than \PNAMELIMIT chars were read. Can't be a symbol, but might be a number. Pack up all the strings we have into a single string and try to parse it as a number.") (SETQ EXTRASEGMENTS (\SUBREADCONCAT EXTRASEGMENTS PBASE J)) (OR (AND (NULL (OR PACKAGE ESCAPEFLG NCOLONS)) (\PARSE.NUMBER (fetch (STRINGP BASE) of EXTRASEGMENTS ) (fetch (STRINGP OFFST) of EXTRASEGMENTS) (fetch (STRINGP LENGTH) of EXTRASEGMENTS) \FATPNAMESTRINGP)) (LISPERROR "ATOM TOO LONG" EXTRASEGMENTS)) else (\READ.SYMBOL PBASE 0 J \FATPNAMESTRINGP PACKAGE (EQ NCOLONS 1) ESCAPEFLG] (replace (STREAM LASTCCODE) of STREAM with CH) (* ; "Save last READ char for LASTC.") (if AT-EOF then (* ;  "top-level read, atom terminated by EOF") (RETURN ELT)) (\RDCONC ELT (PROGN (COND ((OR PRESERVE-WHITESPACE (NEQ SNX SEPRCHAR.RC)) (* ; "At top-level, put back the terminating character if preserving whitespace or terminator is significant") (replace (STREAM LASTCCODE) of STREAM with (OR LASTC CH 65535)) (* ;  "And LASTC will return the last REAL char read.") (\BACKNSCHAR STREAM SHIFTEDCHARSET))) (RETURN ELT))) (if (EQ SNX SEPRCHAR.RC) then (* ;  "Terminated with sepr, go on to next char") (GO NEWTOKEN) elseif (EQ CH CHAR) then (* ; "read terminates here") (replace (STREAM LASTCCODE) of STREAM with CH) (RETURN LST) else (* ;  "Terminated with break, jump into the break char code") (GO BREAK)) GOTPACKAGEDELIM (* ;; "Come here if CH is a package delimiter. Note that we have already scanned at least one character of the token, so this must be an interior delim") (COND (*READ-SUPPRESS* (* ; "Don't care about packages")) [(AND (EQ J 0) (NULL EXTRASEGMENTS)) (* ;; "No chars accumulated, so must be 2 colons in a row. Note that the case where we've just started scanning a token happens up at NEWTOKEN") (SETQ LASTC CH) (COND ((AND (EQ NCOLONS 1) (NEQ PACKAGE *KEYWORD-PACKAGE*)) (* ;  "Two colons in a row means internal symbol") (SETQ NCOLONS 2)) (T (* ;  "Error, e.g., `FOO:::BAZ' or `::BAR'") (SETQ INVALIDFLG T) (GO GOTATOMCHAR] ((NULL NCOLONS) (* ;  "We have just scanned the package name") (SETQ NCOLONS 1) (SETQ LASTC CH) [SETQ PACKAGE (COND (EXTRASEGMENTS (LISPERROR "ATOM TOO LONG" (\SUBREADCONCAT EXTRASEGMENTS PBASE J )) (SETQ EXTRASEGMENTS NIL)) ((\FIND.PACKAGE.INTERNAL PBASE 0 J \FATPNAMESTRINGP)) (T (* ;  "Error, but don't signal yet -- save name as string for benefit of error handlers") (\GETBASESTRING PBASE 0 J \FATPNAMESTRINGP] (SETQ J 0)) (T (* ;  "Have alread seen one or more colons, and have scanned more symbol. This colon is an error.") (SETQ LASTC CH) (SETQ INVALIDFLG T) (GO GOTATOMCHAR))) (SETQ ESCAPEFLG T) (* ; "Result MUST be a symbol now") (GO NEXTATOMCHAR) SINGLECHARATOM (* ;; "Come here to create a symbol whose single character is CH -- no package stuff to worry about. This happens mainly for RATOM. We create the single char atom in IL for backward compatibility.") (\PNAMESTRINGPUTCHAR PBASE 0 CH) (SETQ ELT (\READ.SYMBOL PBASE 0 1 \FATPNAMESTRINGP *INTERLISP-PACKAGE*)) (replace (STREAM LASTCCODE) of STREAM with CH) (\RDCONC ELT (RETURN ELT)) (GO NEWTOKEN) (* ;; "End of atom scanning code") BREAK (* ;; "At this point, we have just read a break character, stored in CH") (replace (STREAM LASTCCODE) of STREAM with CH) [SELECTC SNX (LEFTPAREN.RC (* ;; "recursively read a list. If that list (or any of it's non-bracketed sublists) is terminated by a right bracket it terminates our read as well. PROPRB macro worries about right-bracket propagation: if the subread encounters a right bracket (sets \RBFLG), PROPRB returns true. In addition, if we were not called by a left-bracket (READTYPE = NOPROPRB.RT) it sets \RBFLG in caller, thereby propagating the bracket upward.") (COND ((PROG1 (PROPRB (SETQ ELT (\SUBREAD STREAM SA PROPRB.RT PNSTR CASEBASE))) (\RDCONC ELT (RETURN ELT))) (* ;; "PROG1 is true if the subread encountered a right bracket") (FIXDOT) (* ; "Fix dotted pair if necessary") (RETURN LST)))) (LEFTBRACKET.RC (* ;; "recursively read a list, terminated by either right paren or right bracket. In this case, right bracket is not propagated upward--we continue reading elements after it.") (SETQ ELT (\SUBREAD STREAM SA NOPROPRB.RT PNSTR CASEBASE)) (\RDCONC ELT (RETURN ELT))) ((LIST RIGHTPAREN.RC RIGHTBRACKET.RC) (* ;; "Terminate one or more lists, return what we have accumulated so far. In the case of Right bracket, if caller did not have the matching left bracket, we have to allow the bracket to close more than one list.") (RETURN (COND (TOPLEVELP (* ;; "Naked right paren/bracket returns NIL. This is sort of bogus in common lisp, but changing it would be a significant change to Interlisp folks.") NIL) (CHAR (* ;; "call from READ-DELIMITED-LIST doesn't want to terminate this way. Could read as NIL and not terminate, but seems best to error.") (CL:ERROR "Unmatched ~A encountered while reading to a ~A" (CL:CODE-CHAR CH) (CL:CODE-CHAR CHAR)) LST) (T (FIXDOT) (AND (EQ SNX RIGHTBRACKET.RC) (NEQ READTYPE NOPROPRB.RT) (SETQ \RBFLG T)) LST)))) (STRINGDELIM.RC (* ;; "Invoke string reader") (SETQ ELT (\RSTRING2 STREAM SA NIL PNSTR)) (\RDCONC ELT (RETURN ELT))) (COND ((OR (EQ SNX BREAKCHAR.RC) (NOT (fetch READMACROFLG of *READTABLE*))) (* ;  "A breakchar or a disabled always macro") (GO SINGLECHARATOM)) (T (GO MACRO] (GO NEWTOKEN) MACRO (SELECTQ (fetch MACROTYPE of (SETQ SNX (\GETREADMACRODEF CH *READTABLE*))) (MACRO (COND ((PROG1 (PROPRB [SETQ ELT (RELEASERESOURCE \PNAMESTRING PNSTR (CL:MULTIPLE-VALUE-LIST (\APPLYREADMACRO STREAM SNX] (* ;  "Ignore right-bracket if macro is called at top-level read") ) [COND ((NULL ELT) (* ;  "Macro returned zero values, read as nothing") ) (T (SETQ ELT (CAR ELT)) (\RDCONC ELT (RETURN ELT]) (FIXDOT) (* ;  "Encountered right bracket if we get here -- return what we have") (RETURN LST)))) (INFIX (* ;; "We give macro TCONC list of what we've accumulated so far--it gets to modify it as it pleases and return it. We continue from there.") (COND ((PROG1 [PROPRB (SETQ ELT (RELEASERESOURCE \PNAMESTRING PNSTR (\APPLYREADMACRO STREAM SNX (AND LST (CONS LST END] [COND [TOPLEVELP (* ;  "What does INFIX mean at top level?? See IRM") (COND ((AND (LISTP ELT) (CDR ELT)) (* ;  "Result is in TCONC format, so it's returnable") (RETURN (COND ((EQ (CDR ELT) (CAR ELT)) (* ; "TCONC list of one element--return the element. This is how INFIX top level macro can return a non-list. ") (CAAR ELT)) (T (CAR ELT] (T (* ;  "Reading sublist. Take apart TCONC list and continue.") (SETQ LST (CAR ELT)) (SETQ END (CDR ELT]) (FIXDOT) (* ;  "Macro hit right bracket if we got to here") (RETURN LST)))) (SPLICE (* ;; "Macro returns arbitrary number of values to be spliced inline.") [RBCONTEXT (SETQ ELT (RELEASERESOURCE \PNAMESTRING PNSTR (\APPLYREADMACRO STREAM SNX] (* ;  "Note: we don't care if there was terminating right-bracket") (* ; "Why? -bvm") (COND ((OR (NULL ELT) TOPLEVELP) (* ;; "On the 10, it actually returns ELT if it is a list and the next token is a closing paren or bracket. Hard to see how to get that behavior--rmk") (GO NEWTOKEN)) ((NLISTP ELT) (* ;  "The 10 throws initial non-lists away (What if LST/END aren't set?)") (SETQ ELT (AND LST (LIST '%. ELT))) (SETQ DOTLOC END))) [COND ((NOT *READ-SUPPRESS*) (COND (LST (RPLACD END ELT)) (T (SETQ LST ELT))) (SETQ END (LAST ELT)) (COND ((CDR END) (* ; "A dotted pair") (SETQ DOTLOC END) (RPLACD END (CONS '%. (SETQ END (CONS (CDR END]) (SHOULDNT)) (GO NEWTOKEN]) (\SUBREADCONCAT [LAMBDA (EXTRASEGMENTS PBASE J) (* ; "Edited 16-Jan-87 15:08 by bvm:") (* ;; "Produces a string consisting of all the characters \SUBREAD has been buffering up into a token. Last J chars are stored at PBASE. EXTRASEGMENTS is a list of strings in reverse order in the case that more characters were scanned than the pname string accommodates.") (SETQ PBASE (\GETBASESTRING PBASE 0 J \FATPNAMESTRINGP)) (if EXTRASEGMENTS then (CONCATLIST (NCONC1 (REVERSE EXTRASEGMENTS) PBASE)) else PBASE]) (\ORIG-READ.SYMBOL [LAMBDA (BASE OFFSET LEN FATP PACKAGE EXTERNALP NONNUMERICP) (* bvm%: " 3-Aug-86 15:25") (* ;;; "Read a number or symbol from the string defined by BASE OFFSET LEN FATP PACKAGE is NIL if no package was specified, a package object or a string if an unknown package was typed (causes error). EXTERNALP is true if symbol was typed with one colon, which requires that the symbol exist and be external. NONNUMERICP is true if we know the symbol is not a number, e.g., some characters in it were escaped.") (* ;;; "For now a dummy definition") (COND (PACKAGE (* ; "For debugging") (CONCAT PACKAGE (COND (EXTERNALP ":") (T "::")) (\GETBASESTRING BASE OFFSET LEN FATP))) (T (OR (AND (NOT NONNUMERICP) (\PARSE.NUMBER BASE OFFSET LEN FATP)) (\MKATOM BASE OFFSET LEN FATP T]) (\ORIG-INVALID.SYMBOL [LAMBDA (BASE LEN NCOLONS PACKAGE EXTRASEGMENTS) (* ; "Edited 15-Jan-87 17:33 by bvm:") (* ;;; "Called when scanning a symbol that has more than 2 colons, or more than 1 non-consecutive colon. If return from here, will read the symbol as though the extra colons were escaped.") (CL:CERROR "Treat the extra colon(s) as if they were escaped" "Invalid symbol syntax in %"~A%"" (CONCAT (if (AND PACKAGE (NEQ PACKAGE *KEYWORD-PACKAGE*)) then (if (STRINGP PACKAGE) then PACKAGE else (CL:PACKAGE-NAME PACKAGE)) else "") (SELECTQ NCOLONS (1 ":") (2 "::") "") (\SUBREADCONCAT EXTRASEGMENTS BASE LEN]) (\APPLYREADMACRO [LAMBDA (STREAM MACDEF ANSCELL) (* bvm%: " 4-May-86 16:38") (* ;  "INREADMACROP searches for this framename") (DECLARE (USEDFREE *READTABLE*)) (APPLY* (fetch MACROFN of MACDEF) STREAM *READTABLE* ANSCELL]) (INREADMACROP [LAMBDA NIL (* edited%: "26-MAY-79 00:12") (PROG (TEM (\READDEPTH -1)) (DECLARE (SPECVARS \READDEPTH)) (COND ([NULL (SETQ TEM (STKPOS '\APPLYREADMACRO] (RETURN NIL))) (MAPDL [FUNCTION (LAMBDA (NM POS) (COND ((EQ NM '\SUBREAD) (SETQ \READDEPTH (ADD1 \READDEPTH] TEM) (RELSTK TEM) (RETURN \READDEPTH]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (MOVD? '\ORIG-READ.SYMBOL '\READ.SYMBOL) (MOVD? '\ORIG-INVALID.SYMBOL '\INVALID.SYMBOL) ) (* ; "Read macro for '") (DEFINEQ (READQUOTE [LAMBDA (FILE) (* ; "Edited 19-Mar-87 16:10 by bvm:") (LIST 'QUOTE (CL:READ FILE T NIL T]) ) (* ; "# macro") (DEFINEQ (READVBAR [LAMBDA (STREAM RDTBL) (* bvm%: "14-May-86 17:31") (* ;;; "Read Interlisp's | macro. Originally this char was just a sepr in FILERDTBL but was then extended in various hokey ways, because it was the only character plausibly available for redefinition. Today it is extended still further to be Common Lisp # in all the cases not already taken by some other meaning") (SELCHARQ (PEEKCCODE STREAM) (%' (* ;  "commonlisp defines #'X to mean (FUNCTION X), but here it's BQUOTE") (READCCODE STREAM) (READBQUOTE STREAM RDTBL)) ((%( { ^) (* ; "Used by HPRINT") (HREAD STREAM)) (%# (READCCODE STREAM) (* ; "|# = Common Lisp #") (READHASHMACRO STREAM RDTBL)) ((EOL TAB SPACE) (* ; "CR or tab, treat as separator") (CL:VALUES)) (PROGN (* ;  "Everything else not already preempted by old-style | is interpreted as Common Lisp") (READHASHMACRO STREAM RDTBL]) (READHASHMACRO [LAMBDA (STREAM RDTBL INDEX) (* amd "15-Oct-86 16:36") (* ;;; "Implements the standard # macro dispatch -- reads next character to find out what to do. Can return zero values if we just want to skip something.") (LET ([READFN (COND ((fetch (READTABLEP COMMONLISP) of RDTBL) (* ;; "Kludge: if we have to recursively read something that will not end up as the resulting list structure, use the reader that passes thru CMLTRANSLATE") (FUNCTION CL:READ)) (T (FUNCTION READ] NEXTCHAR READVAL) [while (DIGITCHARP (SETQ NEXTCHAR (PEEKCCODE STREAM RDTBL))) do (SETQ INDEX (PLUS (TIMES (OR INDEX 0) 10) (DIFFERENCE (READCCODE STREAM RDTBL) (CHARCODE 0] (SELCHARQ NEXTCHAR ("(" [LET ((CONTENTS (APPLY* READFN STREAM))) (COND (INDEX (FILL-VECTOR (CL:MAKE-ARRAY INDEX) CONTENTS)) (T (CL:MAKE-ARRAY (LENGTH CONTENTS) :INITIAL-CONTENTS CONTENTS]) (PROGN (* ;  "Those cases we left the dispatching char in buffer for convenience of the next read. Now eat it") (SELCHARQ (READCCODE STREAM RDTBL) (%' (LIST 'FUNCTION (READ STREAM RDTBL))) (%. (EVAL (APPLY* READFN STREAM))) (%, (LIST 'LOADTIMECONSTANT (READ STREAM RDTBL))) (\ (CHARACTER.READ STREAM)) ("*" (* ; "Read bit vector") [LET [(CONTENTS (while (MEMQ (PEEKCCODE STREAM RDTBL) (CHARCODE (0 1))) collect (IDIFFERENCE (READCCODE STREAM RDTBL) (CHARCODE 0] (COND (INDEX (FILL-VECTOR (CL:MAKE-ARRAY INDEX :ELEMENT-TYPE 'BIT) CONTENTS)) (T (CL:MAKE-ARRAY (LENGTH CONTENTS) :INITIAL-CONTENTS CONTENTS :ELEMENT-TYPE 'BIT]) (":" (* ;; "The same thing HASH-COLON does.") (CL:MAKE-SYMBOL (READ-EXTENDED-TOKEN STREAM RDTBL))) ((O o) (READNUMBERINBASE STREAM 8)) ((B b) (READNUMBERINBASE STREAM 2)) ((X x) (READNUMBERINBASE STREAM 16)) ((R r) (READNUMBERINBASE STREAM INDEX)) ((A a) (LET ((CONTENTS (APPLY* READFN STREAM))) (CL:MAKE-ARRAY (ESTIMATE-DIMENSIONALITY INDEX CONTENTS) :INITIAL-CONTENTS CONTENTS))) ((S s) (CREATE-STRUCTURE (APPLY* READFN STREAM))) ((C c) (DESTRUCTURING-BIND (NUM DEN) (APPLY* READFN STREAM) (COMPLEX NUM DEN))) (+ (* ;  "Skip expression if feature not present") (COND ((NOT (CMLREAD.FEATURE.PARSER (READ STREAM RDTBL))) (CL:READ STREAM RDTBL))) (CL:VALUES)) (- (* ;  "Skip expression if feature IS present") (COND ((CMLREAD.FEATURE.PARSER (READ STREAM RDTBL)) (CL:READ STREAM RDTBL))) (CL:VALUES)) ("|" (* ; "special comment") (SKIP.HASH.COMMENT STREAM RDTBL) (CL:VALUES)) (< (ERROR "#< construct is un-READ-able" (READ))) ((SPACE TAB NEWLINE PAGE RETURN %)) (ERROR "Illegal read syntax " (CHARCODE.UNDECODE NEXTCHAR))) (%" (* ;  "An extension -- read string without cr's and leading spaces") (RSTRING STREAM RDTBL 'SKIP)) (APPLY* (OR (GET (CHARACTER NEXTCHAR) 'HASHREADMACRO) (ERROR "Undefined hashmacro char" NEXTCHAR)) STREAM RDTBL]) (DEFMACRO-LAMBDA-LIST-KEYWORD-P [LAMBDA (S) (* bvm%: " 3-Nov-86 15:12") (AND (FMEMB S '(&OPTIONAL &REST &KEY &ALLOW-OTHER-KEYS &AUX &BODY &WHOLE)) T]) (DIGITBASEP [LAMBDA (CODE RADIX) (* lmm "11-Jun-85 00:54") (COND ((AND (GEQ CODE (CHARCODE 0)) (LESSP CODE (PLUS (CHARCODE 0) RADIX))) (DIFFERENCE CODE (CHARCODE 0))) ((GREATERP RADIX 10) [COND ((AND (GEQ CODE (CHARCODE a)) (LEQ CODE (CHARCODE z))) (add CODE (DIFFERENCE (CHARCODE A) (CHARCODE a] (COND ((AND (GEQ CODE (CHARCODE A)) (LEQ CODE (CHARCODE Z))) [SETQ CODE (PLUS 10 (DIFFERENCE CODE (CHARCODE A] (COND ((LESSP CODE RADIX) CODE]) (READNUMBERINBASE [LAMBDA (STREAM RADIX) (* bvm%: " 4-Nov-86 21:34") (PROG ((BODY (READ-EXTENDED-TOKEN STREAM)) (I 1) CH VAL NUMERATOR SIGN BASE) (* ; "First check for leading sign") (if *READ-SUPPRESS* then (* ; "work is done") (RETURN NIL)) (SELCHARQ (SETQ CH (NTHCHARCODE BODY 1)) (+ (GO NEXTCH)) (- (SETQ SIGN T) (GO NEXTCH)) NIL) LP (if (SETQ BASE (DIGITBASEP CH RADIX)) then (SETQ VAL (+ (TIMES (OR VAL 0) RADIX) BASE)) elseif (EQ CH (CHARCODE "/")) then (* ; "Ratio marker") (if (OR NUMERATOR (NULL VAL)) then (GO MALFORMED)) (SETQ NUMERATOR VAL) (SETQ VAL NIL) else (* ;  "Terminated by a character that is not a token delimiter") (GO MALFORMED)) NEXTCH (if (SETQ CH (NTHCHARCODE BODY (add I 1))) then (GO LP) else (* ; "end of token, fall thru")) DONE (if (NULL VAL) then (GO MALFORMED)) (if NUMERATOR then (SETQ VAL (%%/ NUMERATOR VAL))) (RETURN (if SIGN then (- VAL) else VAL)) MALFORMED (RETURN (CL:ERROR "Malformed base ~D rational ~S" RADIX BODY]) (ESTIMATE-DIMENSIONALITY [LAMBDA (RANK CONTENTS) (* bvm%: " 9-May-86 16:06") (COND ((NULL RANK) (ERROR "No rank found while reading array" NIL)) ((EQ RANK 0) NIL) (T (to RANK as (D _ CONTENTS) by (CAR D) collect (LENGTH D]) (SKIP.HASH.COMMENT [LAMBDA (STREAM RDTBL) (* bvm%: "12-Sep-86 21:02") (PROG NIL (* ;; "a tiny fsm that recognizes #| ... |# with possible nestings of itself") LP (SELCHARQ (READCCODE STREAM RDTBL) ("#" (GO SHARP)) ("|" (GO VBAR)) (GO LP)) SHARP (SELCHARQ (READCCODE STREAM RDTBL) ("|" (* ;  "#| -- recursively skip nested section") (SKIP.HASH.COMMENT STREAM RDTBL) (GO LP)) ("#" (GO SHARP)) (GO LP)) VBAR (SELCHARQ (READCCODE STREAM RDTBL) ("|" (GO VBAR)) ("#" (* ; "found closing |#") (RETURN)) (GO LP]) (CMLREAD.FEATURE.PARSER [LAMBDA (EXPR) (* bvm%: " 3-Nov-86 15:07") (COND ((CL:CONSP EXPR) (SELECTQ (CAR EXPR) ((:AND AND) (EVERY (CDR EXPR) (FUNCTION CMLREAD.FEATURE.PARSER))) ((:OR OR) (SOME (CDR EXPR) (FUNCTION CMLREAD.FEATURE.PARSER))) ((:NOT NOT) (NOT (CMLREAD.FEATURE.PARSER (CADR EXPR)))) (ERROR "Bad feature expression" EXPR))) ((FMEMB EXPR *FEATURES*) T]) ) (* ; "Reading characters with #\") (DEFINEQ (CHARACTER.READ [LAMBDA (STREAM) (* bvm%: " 4-Nov-86 21:50") (* ;;; "Called by the #\ macro -- reads a character object consisting of the thing next named") (LET ((NEXTCHAR (READCCODE STREAM)) CH) (COND ((OR (NULL (SETQ CH (PEEKCCODE STREAM T))) (fetch STOPATOM of (\SYNCODE (fetch READSA of *READTABLE*) CH))) (* ;  "Terminates next, so it's just this char") (CL:CODE-CHAR NEXTCHAR)) (*READ-SUPPRESS* (* ;  "don't try to decode it, could be illegal") (READ-EXTENDED-TOKEN STREAM) NIL) (T (* ;  "Read a whole name, up to the next break/sepr") (CL:CODE-CHAR (CHARCODE.DECODE (CONCAT (ALLOCSTRING 1 NEXTCHAR) (READ-EXTENDED-TOKEN STREAM]) (CHARCODE.DECODE [LAMBDA (C NOERROR) (* ;  "Edited 1-Aug-2020 18:52 by rmk:") (* ; "Edited 18-Feb-87 22:03 by bvm:") (DECLARE (GLOBALVARS CHARACTERNAMES CHARACTERSETNAMES)) (* ;; "RMK 2020: Added hexstring decoding for Unicode: no commas or other delimiters") (* ;; "This overrides the definition in LLREAD. It should be placed there, but for some reason it is not possible to then recompile that file: loading a new .LCOM says that \INVALID.SYMBOL is a bad compiled function, and then it loses track of the keyword package. Could be a load-sequence problem that would be resolved if this is installed in a new INIT.SYSOUT rather than an overlay of files already loaded into the LISP.SYSOUT") (COND ((NOT C) NIL) ((LISTP C) (CONS (CHARCODE.DECODE (CAR C) NOERROR) (CHARCODE.DECODE (CDR C) NOERROR))) ((NOT (OR (ATOM C) (STRINGP C))) (AND (NOT NOERROR) (ERROR "BAD CHARACTER SPECIFICATION" C))) ((EQ (NCHARS C) 1) (CHCON1 C)) (T (SELCHARQ (CHCON1 C) (^ (AND (SETQ C (CHARCODE.DECODE (SUBSTRING C 2 -1) NOERROR)) (LOGAND C (LOGNOT 96)))) (%# (* ;; "We use IPLUS instead of LOGOR here because some people want ##char to read as Xerox Meta, i.e., 1,char") (AND (SETQ C (CHARCODE.DECODE (SUBSTRING C 2 -1) NOERROR)) (IPLUS C 128))) (LET ((STR (MKSTRING C))) (for X in CHARACTERNAMES when (STRING.EQUAL (CAR X) STR) do (RETURN (OR (NUMBERP (CADR X)) (CHARCODE.DECODE (CADR X) NOERROR))) finally (RETURN (LET ((POS (STRPOSL '(%, - "." "|") STR)) CH CSET) (* ; "In the form charset,char") (COND ((AND POS (SETQ CH (OR (CL:PARSE-INTEGER STR :START POS :RADIX 8 :JUNK-ALLOWED T) (CHARCODE.DECODE (SUBSTRING STR (ADD1 POS)) NOERROR))) (< CH 256) (>= CH 0)) (* ;  "parsed the char part as an octal number or character spec") (if (AND [SETQ CSET (OR (CL:PARSE-INTEGER STR :END (SUB1 POS) :RADIX 8 :JUNK-ALLOWED T) (for PAIR in CHARACTERSETNAMES first (SETQ POS (SUBSTRING STR 1 (SUB1 POS))) when (STRING.EQUAL (CAR PAIR) POS) do (RETURN (CADR PAIR] (< CSET 256) (>= CSET 0)) then (* ;  "parsed the charset part as an octal number or standard charset name") (LOGOR CH (LLSH CSET 8)) elseif (NOT NOERROR) then (ERROR "BAD CHARACTERSET SPECIFICATION" C))) ((AND (NOT (FIXP C)) (CL:PARSE-INTEGER (CL:IF (EQ 1 (OR (STRPOS "0x" STR) (STRPOS "0X" STR) (STRPOS "U+" STR))) (SUBSTRING STR 3) STR) :RADIX 16 :JUNK-ALLOWED T))) ((NOT NOERROR) (ERROR "BAD CHARACTER SPECIFICATION" C]) ) (RPAQQ CHARACTERNAMES (("Page" 12) ("Form" 12) ("FF" 12) ("Rubout" 127) ("Del" 127) ("Null" 0) ("Escape" 27) ("Esc" 27) ("Bell" 7) ("Tab" 9) ("Backspace" 8) ("Bs" 8) ("Newline" 13) ("CR" 13) ("EOL" 13) ("Return" 13) ("Tenexeol" 31) ("Space" 32) ("Sp" 32) ("Linefeed" 10) ("LF" 10))) (RPAQQ CHARACTERSETNAMES (("Greek" 38) ("Cyrillic" 39) ("Hira" 36) ("Hiragana" 36) ("Kata" 37) ("Katakana" 37) ("Kanji" 48))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (RPAQQ READTYPES (READ.RT RATOM.RT NOPROPRB.RT PROPRB.RT)) (DECLARE%: EVAL@COMPILE (RPAQQ READ.RT NIL) (RPAQQ RATOM.RT 1) (RPAQQ NOPROPRB.RT T) (RPAQQ PROPRB.RT 0) (CONSTANTS READ.RT RATOM.RT NOPROPRB.RT PROPRB.RT) ) (DECLARE%: EVAL@COMPILE (PUTPROPS .CALL.SUBREAD. MACRO ((STREAM EOF-SUPPRESS EOF-VALUE CHAR PRESERVE-WHITESPACE) (WITH-RESOURCE (\PNAMESTRING) (\SUBREAD (\GETSTREAM STREAM 'INPUT) (fetch (READTABLEP READSA) of *READTABLE* ) (COND (CHAR -1) (T READ.RT)) \PNAMESTRING (AND (fetch (READTABLEP CASEINSENSITIVE) of *READTABLE*) (fetch (ARRAYP BASE) of UPPERCASEARRAY )) EOF-SUPPRESS EOF-VALUE CHAR PRESERVE-WHITESPACE )))) (PUTPROPS FIXDOT MACRO [NIL (PROGN (* ;  "Fix a non-first dot followed by a singleton") (AND DOTLOC (CDDR DOTLOC) (NULL (CDDDR DOTLOC)) (RPLACD DOTLOC (CADDR DOTLOC]) (PUTPROPS RBCONTEXT MACRO ((X . Y) ([LAMBDA (\RBFLG) (DECLARE (SPECVARS \RBFLG)) (PROGN X . Y) \RBFLG] NIL))) (PUTPROPS PROPRB MACRO [(X . Y) (* ;  "Propagates the right-bracket flag") (AND (RBCONTEXT X . Y) (OR (EQ READTYPE NOPROPRB.RT) (SETQ \RBFLG T]) (PUTPROPS \RDCONC MACRO [(ELT . TOPFORMS) (* ;; "Add ELT to the accumulating list to be returned by \SUBREAD. If at top level and no list accumulated, then run TOPFORMS") (COND [LST (RPLACD END (SETQ END (CONS ELT] (TOPLEVELP . TOPFORMS) ((NOT *READ-SUPPRESS*) (* ;  "Don't bother consing the result if it's going to be thrown away") (SETQ END (SETQ LST (CONS ELT]) ) (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (PUTPROPS \BACKCHAR MACRO (OPENLAMBDA (STREAM) (* ; "Backs up over an NS character") (\BACKNSCHAR STREAM (UNFOLD (ACCESS-CHARSET STREAM) 256)))) (PUTPROPS \BACKNSCHAR MACRO [(ST SHIFTEDCHARSET COUNTERVAR) (COND ((\XCCSP ST) (\BACKXCCSCHAR ST SHIFTEDCHARSET COUNTERVAR)) (T (COND ['COUNTERVAR (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR (CL:FUNCALL (ffetch (STREAM BACKCHARFN) of ST) ST T] (T (CL:FUNCALL (ffetch (STREAM BACKCHARFN) of ST) ST NIL]) (PUTPROPS \CHECKEOLC MACRO (OPENLAMBDA (CH EOLC STREAM PEEKBINFLG COUNTERVAR) (* ;; "Subtracts number of bytes read from COUNTERVAR, which may be NIL. In fact, should be NIL if PEEKBINFLG is T.") (SELCHARQ CH (CR (SELECTC EOLC (CR.EOLC (CHARCODE EOL)) (CRLF.EOLC (COND [PEEKBINFLG (* ;; "T from PEEKC, compile-time constant. In this case, must leave the fileptr where it was, except for possibly advancing over character set shifts") (COND ([EQ (CHARCODE LF) (UNINTERRUPTABLY (\NSIN STREAM (UNFOLD (ACCESS-CHARSET STREAM) 256)) (* ;; "Read the NS CR. We know that there aren't any font-shift characters in front of the CR, because they would have already been read by the \NSPEEK that got the CR character. Since we are going to NS back the CR character, we don't need to update the counter variable") (PROG1 (\PEEKBIN STREAM T) (* ;; "LF must be in next BYTE after NS CR, regardless of coding. Character-set shifting bytes can't intervene. Then we back up over the CR that was \NSINed above.") (\BACKNSCHAR STREAM)))] (CHARCODE EOL)) (T (CHARCODE CR] ((EQ (CHARCODE LF) (\PEEKBIN STREAM T)) (\BIN STREAM) (AND 'COUNTERVAR (SETQ COUNTERVAR (SUB1 COUNTERVAR))) (CHARCODE EOL)) (T (CHARCODE CR)))) (CHARCODE CR))) (LF (COND ((EQ EOLC LF.EOLC) (CHARCODE EOL)) (T (CHARCODE LF)))) CH))) (PUTPROPS \INCHAR MACRO (OPENLAMBDA (STREAM COUNTERVAR) (* ; "returns a 16 bit character code") (\CHECKEOLC (\NSIN STREAM (UNFOLD (ACCESS-CHARSET STREAM) 256) NIL COUNTERVAR) (FFETCH EOLCONVENTION OF STREAM) STREAM NIL COUNTERVAR))) (PUTPROPS \INCCODE MACRO (OPENLAMBDA (STREAM COUNTERVAR) (* ; "returns a 16 bit character code") (\CHECKEOLC (\NSIN STREAM (UNFOLD (ACCESS-CHARSET STREAM) 256) NIL COUNTERVAR) (ffetch EOLCONVENTION of STREAM) STREAM NIL COUNTERVAR))) (PUTPROPS \PEEKCCODE MACRO (OPENLAMBDA (STREAM NOERROR) (\CHECKEOLC (\NSPEEK STREAM (UNFOLD (ACCESS-CHARSET STREAM) 256) NIL NOERROR) (ffetch EOLCONVENTION of STREAM) STREAM T))) (PUTPROPS \NSIN MACRO [(ST SHIFTEDCSET SHIFTEDCSETVAR COUNTERVAR) (* ;;; "Dispatches to the appropriate character code decoder. If you want to support a new character encoding format, you have to write a decoder and add it here.") (COND ((\XCCSP ST) (\XCCSIN ST SHIFTEDCSET SHIFTEDCSETVAR COUNTERVAR)) (T (COND ('COUNTERVAR (CL:MULTIPLE-VALUE-BIND (CODE NUM) (CL:FUNCALL (ffetch (STREAM INCCODEFN) of ST) ST T) (AND NUM (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR NUM ))) CODE)) (T (CL:FUNCALL (ffetch (STREAM INCCODEFN) of ST) ST NIL]) (PUTPROPS \NSPEEK MACRO [(ST SHIFTEDCSET SHIFTEDCSETVAR NOERROR COUNTERVAR) (* ;;; "Dispatches to the appropriate character code decoder. If you want to support a new character encoding format, you have to write a decoder and add it here.") (COND ((\XCCSP ST) (\XCCSPEEK ST (UNFOLD (ACCESS-CHARSET ST) 256) NIL NOERROR)) (T (COND ('COUNTERVAR (CL:MULTIPLE-VALUE-BIND (CODE NUM) (CL:FUNCALL (ffetch (STREAM PEEKCCODEFN) of ST) ST NOERROR T) (AND NUM (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR NUM))) CODE)) (T (CL:FUNCALL (ffetch (STREAM PEEKCCODEFN) of ST) ST NOERROR NIL]) (PUTPROPS NUMERIC-CHARSET MACRO (= . ACCESS-CHARSET)) ) (* "END EXPORTED DEFINITIONS") (DECLARE%: DOEVAL@COMPILE DONTCOPY (SPECVARS *READ-NEWLINE-SUPPRESS* \RefillBufferFn) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS *KEYWORD-PACKAGE* *INTERLISP-PACKAGE*) ) ) (* ; "Support for various external formats") (* ; "JIS to XCCS conversion table.") (RPAQQ *JIS-TO-XCCS-CONV-NO-FONT-TABLE* ((8484 . 8484) (8485 . 8485) (8497 . 9155) (8798 . 61376) (8802 . 8802) (8805 . 64892) (8806 . 64894) (8820 . 9148) (8821 . 9132) (8822 . 213) (8830 . 8830) (10273 . 61189) (10274 . 61188) (10275 . 10275) (10276 . 10276) (10277 . 10277) (10278 . 10278) (10279 . 10279) (10280 . 10280) (10281 . 10281) (10282 . 10282) (10283 . 61414) (10284 . 61410) (10285 . 61409) (10286 . 10286) (10287 . 10287) (10288 . 10288) (10289 . 10289) (10290 . 10290) (10291 . 10291) (10292 . 10292) (10293 . 10293) (10294 . 61411) (10295 . 10295) (10296 . 10296) (10297 . 10297) (10298 . 10298) (10299 . 10299) (10300 . 10300) (10301 . 10301) (10302 . 10302) (10303 . 10303) (10304 . 10304))) (RPAQQ *JIS-TO-XCCS-CODE-MAP* ((1 (1 33 . 33) (2 33 . 34) (3 33 . 35) (6 0 . 183) (7 0 . 58) (8 0 . 59) (9 0 . 63) (10 0 . 33) (11 33 . 43) (12 33 . 44) (13 0 . 194) (14 0 . 193) (15 0 . 200) (16 0 . 195) (18 0 . 204) (19 33 . 51) (20 33 . 52) (21 33 . 53) (22 33 . 54) (23 33 . 55) (24 33 . 56) (25 33 . 57) (26 33 . 58) (27 33 . 59) (28 33 . 60) (29 239 . 36) (30 33 . 62) (31 0 . 47) (32 0 . 92) (33 0 . 126) (34 33 . 66) (35 0 . 124) (36 33 . 68) (37 33 . 69) (38 0 . 169) (39 0 . 39) (40 0 . 170) (41 0 . 186) (42 0 . 40) (43 0 . 41) (44 33 . 76) (45 33 . 77) (46 0 . 91) (47 0 . 93) (48 0 . 123) (49 0 . 125) (50 239 . 50) (51 239 . 51) (52 0 . 171) (53 0 . 187) (54 33 . 86) (55 33 . 87) (56 33 . 88) (57 33 . 89) (58 33 . 90) (59 33 . 91) (60 0 . 43) (61 0 . 45) (62 0 . 177) (63 0 . 180) (64 0 . 184) (65 0 . 61) (66 33 . 98) (67 0 . 60) (68 0 . 62) (69 33 . 101) (70 33 . 102) (71 33 . 103) (72 33 . 104) (73 33 . 105) (74 33 . 106) (75 0 . 176) (76 33 . 108) (77 33 . 109) (78 33 . 110) (79 0 . 165) (80 0 . 164) (81 0 . 162) (82 0 . 163) (83 0 . 37) (84 0 . 35) (85 0 . 38) (86 0 . 42) (87 0 . 64) (88 0 . 167) (89 33 . 121) (90 33 . 122) (91 33 . 123) (92 33 . 124) (93 33 . 125) (94 33 . 126)) (2 (1 34 . 33) (2 34 . 34) (3 34 . 35) (4 34 . 36) (5 34 . 37) (6 34 . 38) (7 34 . 39) (8 34 . 40) (9 34 . 41) (10 0 . 174) (11 0 . 172) (12 0 . 173) (13 0 . 175) (14 34 . 46) (26 239 . 74) (27 239 . 76) (28 239 . 89) (29 239 . 88) (30 239 . 91) (31 239 . 90) (32 239 . 87) (33 239 . 86) (42 239 . 182) (43 239 . 183) (44 239 . 106) (45 239 . 79) (46 239 . 78) (47 239 . 181) (48 239 . 180) (60 239 . 108) (61 239 . 112) (63 239 . 186) (64 239 . 185) (65 239 . 114) (67 239 . 66) (68 239 . 67) (71 239 . 113) (72 239 . 111) (73 239 . 117) (74 34 . 106) (82 241 . 40) (83 239 . 65) (87 239 . 48) (88 239 . 49) (89 0 . 176)) (6 (1 38 . 65) (2 38 . 66) (3 38 . 68) (4 38 . 69) (5 38 . 70) (6 38 . 73) (7 38 . 74) (8 38 . 75) (9 38 . 76) (10 38 . 77) (11 38 . 78) (12 38 . 79) (13 38 . 80) (14 38 . 81) (15 38 . 82) (16 38 . 83) (17 38 . 85) (18 38 . 86) (19 38 . 88) (20 38 . 89) (21 38 . 90) (22 38 . 91) (23 38 . 92) (24 38 . 93) (33 38 . 97) (34 38 . 98) (35 38 . 100) (36 38 . 101) (37 38 . 102) (38 38 . 105) (39 38 . 106) (40 38 . 107) (41 38 . 108) (42 38 . 109) (43 38 . 110) (44 38 . 111) (45 38 . 112) (46 38 . 113) (47 38 . 114) (48 38 . 115) (49 38 . 117) (50 38 . 118) (51 38 . 120) (52 38 . 121) (53 38 . 122) (54 38 . 123) (55 38 . 124) (56 38 . 125)))) (RPAQQ *HANKAKU-TO-ZENKAKU-CODE-MAP* ((161 . 8483) (162 . 8534) (163 . 8535) (164 . 8482) (165 . 183) (166 . 9586) (167 . 9505) (168 . 9507) (169 . 9509) (170 . 9511) (171 . 9513) (172 . 9571) (173 . 9573) (174 . 9575) (175 . 9539) (176 . 8508) (177 . 9506) (178 . 9508) (179 . 9510) (180 . 9512) (181 . 9514) (182 . 9515) (183 . 9517) (184 . 9519) (185 . 9521) (186 . 9523) (187 . 9525) (188 . 9527) (189 . 9529) (190 . 9531) (191 . 9533) (192 . 9535) (193 . 9537) (194 . 9540) (195 . 9542) (196 . 9544) (197 . 9546) (198 . 9547) (199 . 9548) (200 . 9549) (201 . 9550) (202 . 9551) (203 . 9554) (204 . 9557) (205 . 9560) (206 . 9563) (207 . 9566) (208 . 9567) (209 . 9568) (210 . 9569) (211 . 9570) (212 . 9572) (213 . 9574) (214 . 9576) (215 . 9577) (216 . 9578) (217 . 9579) (218 . 9580) (219 . 9581) (220 . 9583) (221 . 9587) (222 . 8491) (223 . 8492))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS *JIS-TO-XCCS-CONV-NO-FONT-TABLE* *JIS-TO-XCCS-CONV-TABLE-LIST* *JIS-TO-XCCS-CODE-MAP* *HANKAKU-TO-ZENKAKU-CODE-MAP* *JIS-1KU-TO-XCCS-CONV-TABLE* *JIS-2KU-TO-XCCS-CONV-TABLE* *JIS-6KU-TO-XCCS-CONV-TABLE* *XCCS-TO-JIS-CONV-TABLE* *HANKAKU-TO-ZENKAKU-CONV-TABLE* *ZENKAKU-TO-HANKAKU-CONV-TABLE*) ) (DEFINEQ (\MAKE.JIS.TO.XCCS.CONV.TABLE [LAMBDA NIL (* ; "Edited 20-Feb-91 19:28 by nm") (* ;;; "The JIS codes which are not equivalent to XCCS reside in 1, 2, 3, 6, 8 and 84 KU. In case of 3 and 84 KU, the corresponding XCCS is calicutated from JIS. In case of 1,2 and 6 KU, we have to prepare conversion tables for each because the mapping between XCCS and JIS are random. 8 KU is treated specially because no displayable font is assigned for 8 KU in XCCS. They are handled with *JIS-TO-XCCS-CONV-NO-FONT-TABLE*.") (* ;;; "Each conversion table is an byte array of size 188 (94 * 2). 94 is a largest number of TEN. TEN is one origin. Each JIS code is represented with two bytes in the table. The first byte is a character set and the second byte is a character code in XCCS. If both of the first byte and the second byte are 255, it means the JIS code is not defined for the entry. If the first byte is 255 and the second byte is 0, it means a JIS code is defined for the entry and there is a XCCS code corresponding to the JIS code, but no displayable font is assigned for the code in XCCS. In the last case, the real XCCS code is found in *JIS-TO-XCCS-CONV-NO-FONT-TABLE*.") (* ;;; "*HANKAKU-TO-ZENKAKU-CONV-TABLE* holds the mapping between JIS HANAKAKU-KANA code to XCCS. XCCS does not support HANKAKU code.") (SETQ *JIS-1KU-TO-XCCS-CONV-TABLE* (ARRAY 188 'BYTE 255)) (SETQ *JIS-2KU-TO-XCCS-CONV-TABLE* (ARRAY 188 'BYTE 255)) (SETQ *JIS-6KU-TO-XCCS-CONV-TABLE* (ARRAY 188 'BYTE 255)) (SETQ *XCCS-TO-JIS-CONV-TABLE* (HASHARRAY 256)) (SETQ *HANKAKU-TO-ZENKAKU-CONV-TABLE* (HASHARRAY 64)) (SETQ *ZENKAKU-TO-HANKAKU-CONV-TABLE* (HASHARRAY 64)) (CL:DO ((TABLES (LIST *JIS-1KU-TO-XCCS-CONV-TABLE* *JIS-2KU-TO-XCCS-CONV-TABLE* *JIS-6KU-TO-XCCS-CONV-TABLE*) (CDR TABLES)) (KU '(1 2 6) (CDR KU)) CODEMAP) ((CL:ENDP TABLES)) (SETQ CODEMAP (CDR (ASSOC (CAR KU) *JIS-TO-XCCS-CODE-MAP*))) (for MAP in CODEMAP do (SETA (CAR TABLES) (IDIFFERENCE (UNFOLD (CAR MAP) 2) 1) (CADR MAP)) (SETA (CAR TABLES) (UNFOLD (CAR MAP) 2) (CDDR MAP)))) (bind KU TEN TABLE for ENTRY in *JIS-TO-XCCS-CONV-NO-FONT-TABLE* do (SETQ KU (IDIFFERENCE (FOLDLO (CAR ENTRY) 256) 32)) (SETQ TABLE (SELECTQ KU (1 *JIS-1KU-TO-XCCS-CONV-TABLE*) (2 *JIS-2KU-TO-XCCS-CONV-TABLE*) (6 *JIS-6KU-TO-XCCS-CONV-TABLE*) NIL)) (AND TABLE (SETA TABLE (UNFOLD (IDIFFERENCE (LOGAND 255 (CAR ENTRY)) 32) 2) 0))) (for MAP in *HANKAKU-TO-ZENKAKU-CODE-MAP* do (PUTHASH (CAR MAP) (CDR MAP) *HANKAKU-TO-ZENKAKU-CONV-TABLE*)) (for MAP in *HANKAKU-TO-ZENKAKU-CODE-MAP* do (PUTHASH (CDR MAP) (CAR MAP) *ZENKAKU-TO-HANKAKU-CONV-TABLE*)) (for MAP in (APPEND [for KU in *JIS-TO-XCCS-CODE-MAP* join (for TEN in (CDR KU) collect `(,(LOGOR (UNFOLD (CADR TEN) 256) (CDDR TEN)) \, (LOGOR (UNFOLD (IPLUS (CAR KU) 32) 256) (IPLUS (CAR TEN) 32] *JIS-TO-XCCS-CONV-NO-FONT-TABLE*) do (PUTHASH (CAR MAP) (CDR MAP) *XCCS-TO-JIS-CONV-TABLE*)) (SETQ *JIS-TO-XCCS-CONV-TABLE-LIST* `((33 \, *JIS-1KU-TO-XCCS-CONV-TABLE*) (34 \, *JIS-2KU-TO-XCCS-CONV-TABLE*) (38 \, *JIS-6KU-TO-XCCS-CONV-TABLE*]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (\MAKE.JIS.TO.XCCS.CONV.TABLE) ) (* ; "JIS to XCCS converter") (RPAQ? *REPLACE-NO-FONT-CODE* T) (RPAQ? *DEFAULT-NOT-CONVERTED-FAT-CODE* 8739) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS *REPLACE-NO-FONT-CODE* *DEFAULT-NOT-CONVERTED-FAT-CODE*) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (PUTPROPS \CONV.JIS.TO.XCCS MACRO [OPENLAMBDA (KU TEN) (* ;;; "Some character code is not equivalent between JIS and XCCS. In such case, we have to convert the character to corresponding XCCS.") (COND ((\NOT.EQUIVALENT.TO.XCCS KU) (\DO.CONV.JIS.TO.XCCS KU TEN)) (T (LOGOR (UNFOLD KU 256) TEN]) (PUTPROPS \DO.CONV.JIS.TO.XCCS MACRO [(KU TEN) (* ;;; " Convert a JIS code divided into KU (high 8 bit) and TEN (low 8 bit) to an corresponding XCCS code.") (COND ((\INVALID.TENP TEN) *DEFAULT-NOT-CONVERTED-FAT-CODE*) (T (SELECTQ KU ((33 34 38) (* ; "1, 2 and 6 KU") [LET* ((CONVTABLE (\EXTARACT.CONV.TABLE KU)) (SET (\EXTRACT.SET TEN CONVTABLE)) (CODE (\EXTRACT.CODE TEN CONVTABLE))) (COND ((NEQ SET 255) (LOGOR (UNFOLD SET 256) CODE)) (T (COND ((EQ CODE 255) (* ; "Not defined in JIS.") *DEFAULT-NOT-CONVERTED-FAT-CODE*) (T (* ;  "Defined in JIS but the displayable font is not assigned in the corresponding code in XCCS.") (COND (*REPLACE-NO-FONT-CODE* *DEFAULT-NOT-CONVERTED-FAT-CODE*) (T (\EXTRACT.NO.FONT.CODE (LOGOR (UNFOLD KU 256) TEN]) (35 (* ; "3 KU") (* ;  "Alpha numeric codes are all defined as single byte codes in XCCS.") TEN) (40 (* ; "8 KU") (COND [(< 0 TEN 33) (COND (*REPLACE-NO-FONT-CODE* *DEFAULT-NOT-CONVERTED-FAT-CODE*) (T (\EXTRACT.NO.FONT.CODE (LOGOR KU TEN] (T *DEFAULT-NOT-CONVERTED-FAT-CODE*))) (116 (* ; "84 KU") (COND ((< 0 TEN 5) (LOGOR 29952 TEN)) (T *DEFAULT-NOT-CONVERTED-FAT-CODE*))) (117 (* ; "85 KU") (COND ((< 0 TEN 28) (LOGOR 29696 TEN)) (T *DEFAULT-NOT-CONVERTED-FAT-CODE*))) *DEFAULT-NOT-CONVERTED-FAT-CODE*]) ) (* "END EXPORTED DEFINITIONS") ) (* ; "XCCS to JIS converter") (DEFINEQ (CONVHANKAKU [LAMBDA ARGS (* ; "Edited 8-Feb-91 13:42 by nm") (PROG1 (STREAMPROP (ARG ARGS 1) :HTOZP) (AND (> ARGS 1) (STREAMPROP (ARG ARGS 1) :HTOZP (ARG ARGS 2))))]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (PUTPROPS \CONV.XCCS.TO.JIS MACRO (OPENLAMBDA (OUTSTREAM CC) (* ;;; "Returns JIS code corresponding to XCCS charcode. Handle HANKAKU as well as ZENKAKU. If OUTSTREAM wants to convert ZENKAKUKANA to HANKAKUKANA, do so. Never returns two byte charcode for alpha-numeric character, they are all treated as single byte characode.") (OR (COND ((\ASCIIP CC) CC) ((\NOT.EQUIVALENT.TO.JIS CC) (\DO.CONV.XCCS.TO.JIS CC)) ((\CONV.HANKAKU.TO.ZENKAKUP OUTSTREAM) (* ;  "ZENKAKUKANA comes here, because their charcodes are equiavalent to JIS.") (\CONV.ZENKAKU.KANA CC)) (T CC)) CC))) (PUTPROPS \DO.CONV.XCCS.TO.JIS MACRO ((CC) (GETHASH CC *XCCS-TO-JIS-CONV-TABLE*))) (PUTPROPS \ASCIIP MACRO (OPENLAMBDA (CC) (AND (EQ (FOLDLO CC 256) 0) (< (LOGAND CC 255) 128)))) (PUTPROPS \NOT.EQUIVALENT.TO.JIS MACRO (OPENLAMBDA (CC) (OR (EQ (FOLDLO CC 256) 0) (EQ (FOLDLO CC 256) 33) (EQ (FOLDLO CC 256) 34) (EQ (FOLDLO CC 256) 38) (EQ (FOLDLO CC 256) 40) (EQ (FOLDLO CC 256) 239) (EQ (FOLDLO CC 256) 241)))) (PUTPROPS \CONV.HANKAKU.TO.ZENKAKUP MACRO ((OUTSTREAM) (STREAMPROP OUTSTREAM :HTOZP))) (PUTPROPS \CONV.ZENKAKU.KANA MACRO ((CHAR) (GETHASH CHAR *ZENKAKU-TO-HANKAKU-CONV-TABLE*))) ) (* "END EXPORTED DEFINITIONS") ) (DEFINEQ (\JISIN [LAMBDA (STREAM COUNTP) (* ; "Edited 25-Feb-91 15:47 by nm") (* ;;; "Returns a 16 bit XCCS code. Assuming the input character stream is encoded with JIS. Allows the incorrect usage of KI and KO based on the two different JIS, OLDJIS and NEWJIS, because it is very likely that these two different sets of KI and KO are used simultaneously, although it is against a standard! ") (* ;;; "If COUNP is non-NIL, the number of bytes read is returned as a second value. Doesn't do EOL conversion -- \INCHAR or \INCCODE do that.") (PROG (CH1 CH2 CH3 (IN16BITFLG (\KIMODEP STREAM T)) (CHARNUM 0)) RETRY (AND (SETQ CH1 (\BIN STREAM)) (COND [(EQ CH1 (CHARCODE ESC)) (* ; "Might be KI or KO.") (SETQ CH2 (\BIN STREAM)) (COND [(EQ CH2 (CHARCODE $)) (* ; "Might be KI") (SETQ CH3 (\BIN STREAM)) (COND ((OR (EQ CH3 (CHARCODE B)) (EQ CH3 (CHARCODE @))) (* ; "KI") (\CHNAGE.KI.MODE STREAM T T) (AND COUNTP (SETQ CHARNUM (IPLUS CHARNUM 3))) (* ; "Here we have to try the same preocedure again, because bogus duplicated KI/KO sequence might come again!") (SETQ IN16BITFLG T) (GO RETRY)) (T (COND [IN16BITFLG (* ; "Under processing 16 bit code.") (\BACKFILEPTR STREAM) (COND [COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) (IPLUS 2 CHARNUM] (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2] (T (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (COND [COUNTP (RETURN (CL:VALUES (CHARCODE ESC) (IPLUS 1 CHARNUM] (T (RETURN (CHARCODE ESC] [(EQ CH2 (CHARCODE %()) (* ; "Might be KO") (SETQ CH3 (\BIN STREAM)) (COND ((OR (EQ CH3 (CHARCODE J)) (EQ CH3 (CHARCODE H))) (* ; "KO") (\CHNAGE.KI.MODE STREAM T NIL) (AND COUNTP (SETQ CHARNUM (IPLUS CHARNUM 3))) (* ;  "Oops. Yes, we have to try again to ignore duplicated KI/KO sequence.") (SETQ IN16BITFLG NIL) (GO RETRY)) (T (COND [IN16BITFLG (* ; "Under processing 16 bit code.") (\BACKFILEPTR STREAM) (COND [COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) (IPLUS 2 CHARNUM] (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2] (T (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (COND [COUNTP (RETURN (CL:VALUES (CHARCODE ESC) (IPLUS 1 CHARNUM] (T (RETURN (CHARCODE ESC] [IN16BITFLG (* ; "Under processing 16 bit code.") (COND [COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) (IPLUS 2 CHARNUM] (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2] (T (\BACKFILEPTR STREAM) (COND [COUNTP (RETURN (CL:VALUES (CHARCODE ESC) (IPLUS 1 CHARNUM] (T (RETURN (CHARCODE ESC] [IN16BITFLG (* ; "Under processing 16 bit code.") (COND [COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS CH1 (\BIN STREAM)) (IPLUS 2 CHARNUM] (T (RETURN (\CONV.JIS.TO.XCCS CH1 (\BIN STREAM] [(\HANKAKUP CH1) (* ; "HANKAKU-KATAKANA is converted to ZENKAKU-KATAKANA because XCCS does not support HANKAKU-KATAKANA.") (COND [COUNTP (RETURN (CL:VALUES (\CONV.HANKAKU.KANA CH1) (IPLUS 1 CHARNUM] (T (RETURN (\CONV.HANKAKU.KANA CH1] (T (* ;; "C0, SP, DEL, C1, 10/0, or 15/15 of 0 character set.") (COND [COUNTP (RETURN (CL:VALUES CH1 (IPLUS 1 CHARNUM] (T (RETURN CH1]) (\JISPEEK [LAMBDA (STREAM NOERROR COUNTP) (* ; "Edited 25-Feb-91 16:27 by nm") (* ;;; "Returns a 16 bit XCCS code. Assuming the input character stream is encoded with JIS. Allows the incorrect usage of KI and KO based on the two different JIS, OLDJIS and NEWJIS, because it is very likely that these two different sets of KI and KO are used simultaneously, although it is against a standard! May actually read the KI or KO. ") (* ;;; "If COUNTP is non-NIL, the number of bytes read is returned as a second value. Doesn't do EOL conversion -- \INCHAR or \INCCODE do that.") (PROG ((IN16BITFLG (\KIMODEP STREAM T)) (CHARNUM 0) (CH1 (\PEEKBIN STREAM NOERROR)) CH2 CH3) RETRY (COND [(NULL CH1) (COND (COUNTP (RETURN (CL:VALUES NIL CHARNUM))) (T (RETURN NIL] [(EQ CH1 (CHARCODE ESC)) (* ; "Might be KI or KO.") (\BIN STREAM) (* ; "Consume the first ESC.") (SETQ CH2 (\PEEKBIN STREAM NOERROR)) (COND [(NULL CH2) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES NIL CHARNUM))) (T (RETURN NIL] [(EQ CH2 (CHARCODE $)) (* ; "Might be KI") (\BIN STREAM) (* ; "Consume the $.") (SETQ CH3 (\PEEKBIN STREAM NOERROR)) (COND [(NULL CH3) (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES NIL CHARNUM))) (T (RETURN NIL] ((OR (EQ CH3 (CHARCODE B)) (EQ CH3 (CHARCODE @))) (* ; "KI") (\CHNAGE.KI.MODE STREAM T T) (AND COUNTP (SETQ CHARNUM (IPLUS CHARNUM 3))) (\BIN STREAM) (* ; "Consume the B or @.") (SETQ IN16BITFLG T) (GO RETRY)) (T (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (COND [IN16BITFLG (* ; "Under processing 16 bit code.") (COND (COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) CHARNUM))) (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2] (T (COND (COUNTP (RETURN (CL:VALUES (CHARCODE ESC) CHARNUM))) (T (RETURN (CHARCODE ESC] [(EQ CH2 (CHARCODE %()) (* ; "Might be KO") (\BIN STREAM) (* ; "Consume the (.") (SETQ CH3 (\PEEKBIN STREAM NOERROR)) (COND [(NULL CH3) (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES NIL CHARNUM))) (T (RETURN NIL] ((OR (EQ CH3 (CHARCODE J)) (EQ CH3 (CHARCODE H))) (* ; "KO") (\CHNAGE.KI.MODE STREAM T NIL) (AND COUNTP (SETQ CHARNUM 3)) (\BIN STREAM) (* ; "Consume the J or H.") (SETQ IN16BITFLG NIL) (GO RETRY)) (T (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (COND [IN16BITFLG (* ; "Under processing 16 bit code.") (COND (COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) CHARNUM))) (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2] (T (COND (COUNTP (RETURN (CL:VALUES (CHARCODE ESC) CHARNUM))) (T (RETURN (CHARCODE ESC] [IN16BITFLG (* ; "Under processing 16 bit code.") (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) CHARNUM))) (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2] (T (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES (CHARCODE ESC) CHARNUM))) (T (RETURN (CHARCODE ESC] [IN16BITFLG (* ; "Under processing 16 bit code.") (\BIN STREAM) (* ; "Consume the first byte.") (SETQ CH2 (\PEEKBIN STREAM NOERROR)) (\BACKFILEPTR STREAM) (COND [CH2 (COND (COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) CHARNUM))) (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2] (T (COND (COUNTP (RETURN (CL:VALUES NIL CHARNUM))) (T (RETURN NIL] [(\HANKAKUP CH1) (* ; "HANKAKU-KATAKANA is converted to ZENKAKU-KATAKANA because XCCS does not support HANKAKU-KATAKANA.") (COND (COUNTP (RETURN (CL:VALUES (\CONV.HANKAKU.KANA CH1) CHARNUM))) (T (RETURN (\CONV.HANKAKU.KANA CH1] (T (* ;; "C0, SP, DEL, C1, 10/0, or 15/15 of 0 character set.") (COND (COUNTP (RETURN (CL:VALUES CH1 CHARNUM))) (T (RETURN CH1]) (\BACKJISCHAR [LAMBDA (STREAM COUNTP) (* ; "Edited 25-Feb-91 17:05 by nm") (COND ((\BACKFILEPTR STREAM) (COND [(\KIMODEP STREAM T) (COND ((\BACKFILEPTR STREAM) (AND COUNTP 2)) (T (AND COUNTP 1] (COUNTP 1))) (COUNTP 0]) (\SHIFTJISIN [LAMBDA (STREAM COUNTP) (* ; "Edited 25-Feb-91 15:49 by nm") (* ;;; "Returns a 16 bit XCCS code. Assuming the input character stream is encoded with Shift-JIS. If COUNP is non-NIL, the number of bytes read is returned as a second value. Doesn't do EOL conversion -- \INCHAR or \INCCODE do that..") (LET ((CH1 (\BIN STREAM)) CH2) (AND CH1 (COND [(\SJIS.KANJI.FIRST.BYTEP CH1) (* ;  "Read next byte and compose a kanji character.") (\CONV.SJIS.TO.JIS CH1 (\BIN STREAM)) (* ;  "CH1 and CH2 is adjusted to represent JIS code in \CONV.SJIS.TO.JIS.") (COND (COUNTP (CL:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) 2)) (T (\CONV.JIS.TO.XCCS CH1 CH2] (T (* ; "ASCII or HANKAKU-KATAKANA") (COND [(\HANKAKUP CH1) (* ; "HANKAKU-KATAKANA") (COND (COUNTP (CL:VALUES (\CONV.HANKAKU.KANA CH1) 1)) (T (\CONV.HANKAKU.KANA CH1] (T (* ; "ASCII") (COND (COUNTP (CL:VALUES CH1 1)) (T CH1]) (\SHIFTJISPEEK [LAMBDA (STREAM NOERROR COUNTP) (* ; "Edited 25-Feb-91 16:30 by nm") (* ;;; "Returns a 16 bit XCCS code. Assuming the input character stream is encoded with Shift-JIS. Doesn't do EOL conversion -- \INCHAR or \INCCODE do that.") (PROG ((CH1 (\PEEKBIN STREAM NOERROR)) CH2) (COND [(NULL CH1) (COND (COUNTP (RETURN (CL:VALUES NIL 0))) (T (RETURN NIL] [(\SJIS.KANJI.FIRST.BYTEP CH1) (* ;  "Read next byte and compose a kanji character.") (\BIN STREAM) (* ; "Consume the first byte.") [COND ((NULL (SETQ CH2 (\PEEKBIN STREAM NOERROR))) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES NIL 0))) (T (RETURN NIL] (\BACKFILEPTR STREAM) (\CONV.SJIS.TO.JIS CH1 CH2) (* ;  "CH1 and CH2 is adjusted to represent JIS code in \CONV.SJIS.TO.JIS.") (COND (COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) 0))) (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2] (T (* ; "ASCII or HANKAKU-KATAKANA") (RETURN (COND [(\HANKAKUP CH1) (* ; "HANKAKU-KATAKANA") (COND (COUNTP (RETURN (CL:VALUES (\CONV.HANKAKU.KANA CH1) 0))) (T (RETURN (\CONV.HANKAKU.KANA CH1] (T (* ; "ASCII") (COND (COUNTP (RETURN (CL:VALUES CH1 0))) (T (RETURN CH1]) (\BACKSHIFTJISCHAR [LAMBDA (STREAM COUNTP) (* ; "Edited 25-Feb-91 17:05 by nm") (COND ((\BACKFILEPTR STREAM) (COND [(\BACKFILEPTR STREAM) (COND ((\SJIS.KANJI.FIRST.BYTEP (\PEEKBIN STREAM)) (AND COUNTP 2)) (T (\BIN STREAM) (AND COUNTP 1] (COUNTP 1))) (COUNTP 0]) (\EUCIN [LAMBDA (STREAM COUNTP) (* ; "Edited 25-Feb-91 15:54 by nm") (* ;;; "Returns a 16 bit XCCS code. Assuming the input character stream is encoded with EUC (Extended Unix Codes). Although EUC is independent of a particular language, the language implemented here is Japanese, thus this should be called as UJIS (Unixnized extended JIS code). JEIDA uses EUC as UJIS. ") (* ;;; "If COUNP is non-NIL, the number of bytes read is returned as a second value. Doesn't do EOL conversion -- \INCHAR or \INCCODE do that.") (LET ((CH1 (\BIN STREAM)) CH2) (AND CH1 (COND [(\EUC.KANJI.FIRST.BYTEP CH1) (* ;  "Read next byte and compose a kanji character.") (COND (COUNTP (CL:VALUES (\CONV.JIS.TO.XCCS (LOGAND CH1 127) (LOGAND (\BIN STREAM) 127)) 2)) (T (\CONV.JIS.TO.XCCS (LOGAND CH1 127) (LOGAND (\BIN STREAM) 127] [(\EUC.HANKAKUP CH1) (COND (COUNTP (CL:VALUES (\CONV.HANKAKU.KANA (\BIN STREAM)) 2)) (T (\CONV.HANKAKU.KANA (\BIN STREAM] [(\GAIJIP CH1) (COND (COUNTP (CL:VALUES (\CONV.JIS.TO.XCCS (LOGAND (\BIN STREAM) 127) (LOGAND (\BIN STREAM) 127)) 3)) (T (\CONV.JIS.TO.XCCS (LOGAND (\BIN STREAM) 127) (LOGAND (\BIN STREAM) 127] (T (* ; "ASCII, C0, C1, SP or DEL") (COND (COUNTP (CL:VALUES CH1 1)) (T CH1]) (\EUCPEEK [LAMBDA (STREAM NOERROR COUNTP) (* ; "Edited 25-Feb-91 16:35 by nm") (* ;;; "Returns a 16 bit XCCS code. Assuming the input character stream is encoded with EUC (Extended Unix Codes). Although EUC is independent of a particular language, the language implemented here is Japanese, thus this should be called as UJIS (Unixnized extended JIS code). JEIDA uses EUC as UJIS. Doesn't do EOL conversion -- \INCHAR or \INCCODE do that.") (PROG ((CH1 (\PEEKBIN STREAM NOERROR)) CH2) (COND [(NULL CH1) (COND (COUNTP (RETURN (CL:VALUES NIL 0))) (T (RETURN NIL] [(\EUC.KANJI.FIRST.BYTEP CH1) (* ;  "Read next byte and compose a kanji character.") (\BIN STREAM) (* ; "Consume the first byte.") [COND ((NULL (SETQ CH2 (\PEEKBIN STREAM NOERROR))) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES NIL 0))) (T (RETURN NIL] (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS (LOGAND CH1 127) (LOGAND CH2 127)) 0))) (T (RETURN (\CONV.JIS.TO.XCCS (LOGAND CH1 127) (LOGAND CH2 127] [(\EUC.HANKAKUP CH1) (\BIN STREAM) (* ; "Consume the SS2.") [COND ((NULL (SETQ CH2 (\PEEKBIN STREAM NOERROR))) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES NIL 0))) (T (RETURN NIL] (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES (\CONV.HANKAKU.KANA CH2) 0))) (T (RETURN (\CONV.HANKAKU.KANA CH2] [(\GAIJIP CH1) (\BIN STREAM) (* ; "Consume the SS3.") [COND ((NULL (SETQ CH1 (\PEEKBIN STREAM NOERROR))) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES NIL 0))) (T (RETURN NIL] (\BIN STREAM) (* ;  "Consume the first byte in GAIJI.") [COND ((NULL (SETQ CH2 (\PEEKBIN STREAM NOERROR))) (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES NIL 0))) (T (RETURN NIL] (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS (LOGAND CH1 127) (LOGAND CH2 127)) 0))) (T (RETURN (\CONV.JIS.TO.XCCS (LOGAND CH1 127) (LOGAND CH2 127] (T (* ; "ASCII, C0, C1, SP or DEL") (COND (COUNTP (RETURN (CL:VALUES CH1 0))) (T (RETURN CH1]) (\BACKEUCCHAR [LAMBDA (STREAM COUNTP) (* ; "Edited 25-Feb-91 17:06 by nm") (COND ((\BACKFILEPTR STREAM) (COND ((BITTEST (\PEEKBIN STREAM) (MASK.1'S 7 1)) (* ; "C1, KAINJI, HANKAKU or GAIJI") (COND [(\BACKFILEPTR STREAM) (COND ((\EUC.HANKAKUP (\PEEKBIN STREAM)) (AND COUNTP 2)) ((BITTEST (\PEEKBIN STREAM) (MASK.1'S 7 1)) (* ; "KANJI or GAIJI") (COND [(\BACKFILEPTR STREAM) (COND ((\GAIJIP (\PEEKBIN STREAM)) (AND COUNTP 3)) (T (* ; "KANJI") (\BIN STREAM) (AND COUNTP 2] (COUNTP 2))) (T (* ; "C1") (\BIN STREAM) (AND COUNTP 1] (COUNTP 1))) (COUNTP 1))) (COUNTP 0]) (\THROUGHIN [LAMBDA (STREAM COUNTP) (* ; "Edited 26-Feb-91 13:36 by nm") (* ;;; "Read in a single byte from STREAM and returns it without any character conversion, just through as if.") (* ;;; "If COUNP is non-NIL, always 1 is returned as the second value.") (COND (COUNTP (CL:VALUES (\BIN STREAM) 1)) (T (\BIN STREAM]) (\THROUGHPEEK [LAMBDA (STREAM NOERROR COUNTP) (* ; "Edited 26-Feb-91 13:40 by nm") (* ;;; "Returns a 8 bit code without any character conversion, just through as if.") (* ;;; "If COUNTP is non-NIL, always 0 is returned as its second value.") (COND (COUNTP (CL:VALUES (\PEEKBIN STREAM NOERROR) 0)) (T (\PEEKBIN STREAM NOERROR]) (\BACKTHROUGHCHAR [LAMBDA (STREAM COUNTP) (* ; "Edited 26-Feb-91 13:43 by nm") (COND ((\BACKFILEPTR STREAM) 1) (COUNTP 0]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (PUTPROPS \XCCSIN MACRO [(STREAM SHIFTEDCSET SHIFTEDCSETVAR COUNTERVAR) (* ;;; "returns a 16 bit character code. SHIFTEDCSET is STREAM's char set left shifted 8, SHIFTEDCSETVAR if non-NIL is the variable to set if char set changes. COUNTERVAR if non-NIL is decremented by number of bytes read. Doesn't do EOL conversion -- \INCHAR and \INCCODE do that.") (LET ((CHAR (\BIN STREAM)) SCSET) (COND [(EQ CHAR NSCHARSETSHIFT) (* ; "Shifting character sets") [ACCESS-CHARSET STREAM (SETQ SCSET (COND ((NEQ NSCHARSETSHIFT (SETQ CHAR (\BIN STREAM))) (AND 'COUNTERVAR (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR 2))) CHAR) ((PROGN (* ;  "2 shift-bytes means not run-encoded") (AND 'COUNTERVAR (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR 3))) (EQ 0 (\BIN STREAM))) \NORUNCODE) (T (\NSIN.24BITENCODING.ERROR STREAM] (SETQ CHAR (\BIN STREAM)) (SETQ SCSET (COND ('SHIFTEDCSETVAR (* ; "CHARSETVAR=NIL means don't set") (SETQ SHIFTEDCSETVAR (UNFOLD SCSET 256))) (T (UNFOLD SCSET 256] (T (SETQ SCSET SHIFTEDCSET))) (COND ((EQ SCSET (UNFOLD \NORUNCODE 256)) (* ;  "just read two bytes and combine them to a 16 bit value") (AND 'COUNTERVAR (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR 2 ))) (LOGOR (UNFOLD CHAR 256) (\BIN STREAM))) (CHAR (AND 'COUNTERVAR (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR 1) )) (AND CHAR (LOGOR SCSET CHAR]) (PUTPROPS \XCCSPEEK MACRO [(STREAM SHIFTEDCSET SHIFTEDCSETVAR NOERROR COUNTERVAR) (* ;; "Returns a 16 bit character code. Doesn't do EOL conversion--\INCHAR does that. May actually read the character-set shift, storing the result in the stream. COUNTERVAR, if given, is updated to reflect any such bytes that are actually read") (PROG ((CHAR (\PEEKBIN STREAM NOERROR)) SCSET) (COND ((NULL CHAR) (RETURN NIL)) [(EQ CHAR NSCHARSETSHIFT) (* ; "CHARSETVAR=NIL means don't set") (\BIN STREAM) (* ; "Consume the char shift byte") [ACCESS-CHARSET STREAM (SETQ SCSET (COND ((NEQ NSCHARSETSHIFT (SETQ CHAR (\BIN STREAM))) (* ;  "Note: no eof error check on this \BIN -- an eof in the middle of a charset shift is an error") (AND 'COUNTERVAR (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR 2)) ) CHAR) ((PROGN (* ;  "2 shift-bytes means not run-encoded") (AND 'COUNTERVAR (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR 3) )) (EQ 0 (\BIN STREAM))) \NORUNCODE) (T (\NSIN.24BITENCODING.ERROR STREAM] [SETQ SCSET (COND ('SHIFTEDCSETVAR (* ; "CHARSETVAR=NIL means don't set") (SETQ SHIFTEDCSETVAR (UNFOLD SCSET 256))) (T (UNFOLD SCSET 256] (COND ((NULL (SETQ CHAR (\PEEKBIN STREAM NOERROR))) (RETURN NIL] (T (SETQ SCSET SHIFTEDCSET))) (RETURN (COND ((EQ SCSET (UNFOLD \NORUNCODE 256)) (* ;; "just peek two bytes and combine them to a 16 bit value. Again, is an error if we hit eof in mid-character") (\BIN STREAM) (PROG1 (LOGOR (UNFOLD CHAR 256) (\PEEKBIN STREAM NOERROR)) (\BACKFILEPTR STREAM))) (T (LOGOR SHIFTEDCSET CHAR]) (PUTPROPS \BACKXCCSCHAR MACRO [(STREAM SHIFTEDCHARSET COUNTERVAR) (AND (\BACKFILEPTR STREAM) (COND [[COND (SHIFTEDCHARSET (EQ SHIFTEDCHARSET (UNFOLD \NORUNCODE 256))) (T (EQ \NORUNCODE (ACCESS-CHARSET STREAM] (COND ((\BACKFILEPTR STREAM) (AND 'COUNTERVAR (add COUNTERVAR 2)) T) ('COUNTERVAR (add COUNTERVAR 1] ('COUNTERVAR (add COUNTERVAR 1]) (PUTPROPS \XCCSP MACRO [OPENLAMBDA (ST) (NOT (ffetch (STREAM NOTXCCS) of (\DTEST ST 'STREAM]) ) (DECLARE%: EVAL@COMPILE (PUTPROPS \EXTRACT.NO.FONT.CODE MACRO ((JISCODE) (CDR (ASSOC JISCODE *JIS-TO-XCCS-CONV-NO-FONT-TABLE*)) )) (PUTPROPS \EXTARACT.CONV.TABLE MACRO ((KU) (CDR (ASSOC KU *JIS-TO-XCCS-CONV-TABLE-LIST*)))) (PUTPROPS \NOT.EQUIVALENT.TO.XCCS MACRO ((KU) (* ;;; " The JIS codes which are not equiavelent to XCCS reside in 1, 2, 3, 6, 8 and 84 KU. Although from 84-5 to 94-94 inclusive are not defined in JIS, that is they are GAIJI, they are also handled here.") (OR (EQ KU 33) (EQ KU 34) (EQ KU 35) (EQ KU 38) (EQ KU 40) (EQ KU 116) (EQ KU 117)))) (PUTPROPS \EXTRACT.SET MACRO ((TEN TABLE) (ELT TABLE (IDIFFERENCE (UNFOLD (IDIFFERENCE TEN 32) 2) 1)))) (PUTPROPS \EXTRACT.CODE MACRO ((TEN TABLE) (ELT TABLE (UNFOLD (IDIFFERENCE TEN 32) 2)))) (PUTPROPS \CHNAGE.KI.MODE MACRO [OPENLAMBDA (ST INPUTFLG ENTERP) (* ;;; "INPUTFLG is true if \CHNAGE.KI.MODE is called in the context in which ST is an input stream.") (COND [INPUTFLG (COND (ENTERP (freplace (STREAM IN.KANJIIN) of (\DTEST ST 'STREAM) with T)) (T (freplace (STREAM IN.KANJIIN) of (\DTEST ST 'STREAM) with NIL] (T (COND (ENTERP (freplace (STREAM OUT.KANJIIN) of (\DTEST ST 'STREAM) with T)) (T (freplace (STREAM OUT.KANJIIN) of (\DTEST ST 'STREAM) with NIL]) (PUTPROPS \KIMODEP MACRO [OPENLAMBDA (ST INPUTFLG) (* ;;; "INPUTFLG is true if \KIMODEP is called in the context in which ST is an input stream.") (COND [INPUTFLG (ffetch (STREAM IN.KANJIIN) of (\DTEST ST 'STREAM] (T (ffetch (STREAM OUT.KANJIIN) of (\DTEST ST 'STREAM]) (PUTPROPS \HANKAKUP MACRO ((CHAR) (< 160 CHAR 224))) (PUTPROPS \KANJIP MACRO ((CHAR) (< 12158 CHAR 29733))) (PUTPROPS \NOTGAIJIP MACRO ((CHAR) (OR (< 8480 CHAR 10305) (< 12158 CHAR 29733)))) (PUTPROPS \INVALID.TENP MACRO (OPENLAMBDA (TEN) (OR (< TEN 33) (< 126 TEN)))) (PUTPROPS \CONV.HANKAKU.KANA MACRO ((CHAR) (GETHASH CHAR *HANKAKU-TO-ZENKAKU-CONV-TABLE*))) (PUTPROPS \OUTKI MACRO ((STREAM) (\BOUT OUTSTREAM (CHARCODE ESC)) (\BOUT OUTSTREAM (CHARCODE $)) (\BOUT OUTSTREAM (CHARCODE B)))) (PUTPROPS \OUTKO MACRO ((STREAM) (\BOUT OUTSTREAM (CHARCODE ESC)) (\BOUT OUTSTREAM (CHARCODE %()) (\BOUT OUTSTREAM (CHARCODE J)))) ) (DECLARE%: EVAL@COMPILE (PUTPROPS \CONV.SJIS.TO.JIS MACRO [OPENLAMBDA (HI LO) (* ;;; "Convert Shift-JIS to JIS. The variable named CH1 and CH2 are set to the converted hight 8 bit and low 8bit of JIS code respectively.") [SETQ CH1 (IDIFFERENCE HI (COND ((> HI 159) 177) (T 113] (SETQ CH1 (IPLUS (UNFOLD CH1 2) 1)) (SETQ CH2 (COND [(> LO 158) (PROG1 (IDIFFERENCE LO 126) (SETQ CH1 (IPLUS CH1 1)))] (T (IDIFFERENCE LO (COND ((> LO 126) (IPLUS 31 1)) (T 31]) (PUTPROPS \CONV.JIS.TO.SJIS MACRO [OPENLAMBDA (HI LO) (* ;;; "Convert JIS to Shift-JIS. The variable named CH1 and CH2 are set to the converted hight 8 bit and low 8bit of Shift-JIS code respectively.") [SETQ CH2 (COND ((ODDP HI) (SETQ CH2 (IPLUS LO 31)) (COND ((>= CH2 127) (IPLUS CH2 1)) (T CH2))) (T (IPLUS LO 126] (SETQ CH1 (IPLUS (FOLDLO (IDIFFERENCE HI 33) 2) 129)) (AND (> CH1 159) (SETQ CH1 (IPLUS CH1 64]) (PUTPROPS \SJIS.KANJI.FIRST.BYTEP MACRO (OPENLAMBDA (CHAR) (OR (< 127 CHAR 160) (< 223 CHAR 256)))) ) (DECLARE%: EVAL@COMPILE (PUTPROPS \EUC.KANJI.FIRST.BYTEP MACRO ((CHAR) (< 160 CHAR 255))) (PUTPROPS \GAIJIP MACRO ((CHAR) (EQ CHAR 143))) (PUTPROPS \EUC.HANKAKUP MACRO ((CHAR) (EQ CHAR 142))) ) (* "END EXPORTED DEFINITIONS") ) (RPAQ? *SIGNAL-24BIT-NSENCODING-ERROR* ) (RPAQ? *READ-NEWLINE-SUPPRESS* ) (RPAQ? \RefillBufferFn (FUNCTION \READCREFILL)) (* ; "Top level val of \RefillBufferFn means act like READC--we must be doing a raw BIN (or PEEKBIN?)") (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA CONVHANKAKU CL:PARSE-INTEGER CL:READ-DELIMITED-LIST CL:READ-PRESERVING-WHITESPACE CL:READ) ) (PUTPROPS LLREAD COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1990 1991 1993 2021)) (DECLARE%: DONTCOPY (FILEMAP (NIL (7856 18392 (LASTC 7866 . 8996) (PEEKC 8998 . 9386) (PEEKCCODE 9388 . 9677) (RATOM 9679 . 10760) (READ 10762 . 11322) (READC 11324 . 11741) (READCCODE 11743 . 12159) (READP 12161 . 12713) ( SETREADMACROFLG 12715 . 13014) (SKIPSEPRCODES 13016 . 14361) (SKIPSEPRS 14363 . 15620) ( \NSIN.24BITENCODING.ERROR 15622 . 16441) (SKREAD 16443 . 18390)) (18438 27113 (CL:READ 18448 . 18997) (CL:READ-PRESERVING-WHITESPACE 18999 . 19721) (CL:READ-DELIMITED-LIST 19723 . 20638) (CL:PARSE-INTEGER 20640 . 27111)) (27206 40219 (RSTRING 27216 . 27948) (READ-EXTENDED-TOKEN 27950 . 32511) (\RSTRING2 32513 . 40217)) (40255 72572 (\TOP-LEVEL-READ 40265 . 42248) (\SUBREAD 42250 . 68988) (\SUBREADCONCAT 68990 . 69613) (\ORIG-READ.SYMBOL 69615 . 70683) (\ORIG-INVALID.SYMBOL 70685 . 71584) (\APPLYREADMACRO 71586 . 72002) (INREADMACROP 72004 . 72570)) (72731 72906 (READQUOTE 72741 . 72904)) (72931 84835 ( READVBAR 72941 . 74272) (READHASHMACRO 74274 . 80084) (DEFMACRO-LAMBDA-LIST-KEYWORD-P 80086 . 80306) ( DIGITBASEP 80308 . 81042) (READNUMBERINBASE 81044 . 82930) (ESTIMATE-DIMENSIONALITY 82932 . 83257) ( SKIP.HASH.COMMENT 83259 . 84227) (CMLREAD.FEATURE.PARSER 84229 . 84833)) (84879 91412 (CHARACTER.READ 84889 . 86143) (CHARCODE.DECODE 86145 . 91410)) (111622 116838 (\MAKE.JIS.TO.XCCS.CONV.TABLE 111632 . 116836)) (120754 121073 (CONVHANKAKU 120764 . 121071)) (124044 149184 (\JISIN 124054 . 129755) ( \JISPEEK 129757 . 136383) (\BACKJISCHAR 136385 . 136754) (\SHIFTJISIN 136756 . 138395) (\SHIFTJISPEEK 138397 . 140503) (\BACKSHIFTJISCHAR 140505 . 140935) (\EUCIN 140937 . 143328) (\EUCPEEK 143330 . 146909) (\BACKEUCCHAR 146911 . 148154) (\THROUGHIN 148156 . 148571) (\THROUGHPEEK 148573 . 148987) ( \BACKTHROUGHCHAR 148989 . 149182))))) STOP \ No newline at end of file +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "19-Apr-2021 21:52:10"  {DSK}kaplan>Local>medley3.5>git-medley>sources>LLREAD.;3 167165 changes to%: (FNS \RSTRING2) previous date%: " 4-Feb-2021 17:06:41" {DSK}kaplan>Local>medley3.5>git-medley>sources>LLREAD.;2) (* ; " Copyright (c) 1981-1988, 1990-1991, 1993, 2021 by Venue & Xerox Corporation. ") (PRETTYCOMPRINT LLREADCOMS) (RPAQQ LLREADCOMS [(COMS (* ; "Reader entrypoints") (FNS LASTC PEEKC PEEKCCODE RATOM READ READC READCCODE READP SETREADMACROFLG SKIPSEPRCODES SKIPSEPRS \NSIN.24BITENCODING.ERROR SKREAD)) (COMS (* ; "CommonLisp read entry points") (FNS CL:READ CL:READ-PRESERVING-WHITESPACE CL:READ-DELIMITED-LIST CL:PARSE-INTEGER) (GLOBALVARS CMLRDTBL)) (COMS (* ; "reading strings") (FNS RSTRING READ-EXTENDED-TOKEN \RSTRING2)) [COMS (* ; "Core of the reader") (FNS \TOP-LEVEL-READ \SUBREAD \SUBREADCONCAT \ORIG-READ.SYMBOL \ORIG-INVALID.SYMBOL \APPLYREADMACRO INREADMACROP) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (MOVD? '\ORIG-READ.SYMBOL '\READ.SYMBOL) (MOVD? '\ORIG-INVALID.SYMBOL '\INVALID.SYMBOL] (COMS (* ; "Read macro for '") (FNS READQUOTE)) (COMS (* ; "# macro") (FNS READVBAR READHASHMACRO DEFMACRO-LAMBDA-LIST-KEYWORD-P DIGITBASEP READNUMBERINBASE ESTIMATE-DIMENSIONALITY SKIP.HASH.COMMENT CMLREAD.FEATURE.PARSER)) (COMS (* ; "Reading characters with #\") (FNS CHARACTER.READ CHARCODE.DECODE) (VARS CHARACTERNAMES CHARACTERSETNAMES)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (CONSTANTS * READTYPES) (MACROS .CALL.SUBREAD. FIXDOT RBCONTEXT PROPRB \RDCONC) (EXPORT (MACROS \BACKCHAR \BACKNSCHAR \CHECKEOLC \INCHAR \INCCODE \PEEKCCODE \NSIN \NSPEEK NUMERIC-CHARSET)) (SPECVARS *READ-NEWLINE-SUPPRESS* \RefillBufferFn) (GLOBALVARS *KEYWORD-PACKAGE* *INTERLISP-PACKAGE*)) [COMS (* ;  "Support for various external formats") [COMS (* ; "JIS to XCCS conversion table.") (VARS *JIS-TO-XCCS-CONV-NO-FONT-TABLE* *JIS-TO-XCCS-CODE-MAP* *HANKAKU-TO-ZENKAKU-CODE-MAP*) (GLOBALVARS *JIS-TO-XCCS-CONV-NO-FONT-TABLE* *JIS-TO-XCCS-CONV-TABLE-LIST* *JIS-TO-XCCS-CODE-MAP* *HANKAKU-TO-ZENKAKU-CODE-MAP* *JIS-1KU-TO-XCCS-CONV-TABLE* *JIS-2KU-TO-XCCS-CONV-TABLE* *JIS-6KU-TO-XCCS-CONV-TABLE* *XCCS-TO-JIS-CONV-TABLE* *HANKAKU-TO-ZENKAKU-CONV-TABLE* *ZENKAKU-TO-HANKAKU-CONV-TABLE*) (FNS \MAKE.JIS.TO.XCCS.CONV.TABLE) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\MAKE.JIS.TO.XCCS.CONV.TABLE] [COMS (* ; "JIS to XCCS converter") (INITVARS (*REPLACE-NO-FONT-CODE* T) (*DEFAULT-NOT-CONVERTED-FAT-CODE* 8739)) (GLOBALVARS *REPLACE-NO-FONT-CODE* *DEFAULT-NOT-CONVERTED-FAT-CODE*) (DECLARE%: DOEVAL@COMPILE DONTCOPY (EXPORT (MACROS \CONV.JIS.TO.XCCS \DO.CONV.JIS.TO.XCCS] [COMS (* ; "XCCS to JIS converter") (FNS CONVHANKAKU) (DECLARE%: DOEVAL@COMPILE DONTCOPY (EXPORT (MACROS \CONV.XCCS.TO.JIS \DO.CONV.XCCS.TO.JIS \ASCIIP \NOT.EQUIVALENT.TO.JIS \CONV.HANKAKU.TO.ZENKAKUP \CONV.ZENKAKU.KANA] (COMS (FNS \JISIN \JISPEEK \BACKJISCHAR \SHIFTJISIN \SHIFTJISPEEK \BACKSHIFTJISCHAR \EUCIN \EUCPEEK \BACKEUCCHAR \THROUGHIN \THROUGHPEEK \BACKTHROUGHCHAR) (DECLARE%: DOEVAL@COMPILE DONTCOPY (EXPORT (* ;; "XCCS specific macro. Although the decoder and encoder are implemented as functions in general, only for XCCS, they are implemeted as macros for efficiency reason.") (MACROS \XCCSIN \XCCSPEEK \BACKXCCSCHAR \XCCSP) (* ;; "JIS specific macro") (MACROS \EXTRACT.NO.FONT.CODE \EXTARACT.CONV.TABLE \NOT.EQUIVALENT.TO.XCCS \EXTRACT.SET \EXTRACT.CODE \CHNAGE.KI.MODE \KIMODEP \HANKAKUP \KANJIP \NOTGAIJIP \INVALID.TENP \CONV.HANKAKU.KANA \OUTKI \OUTKO) (* ;; "Shift-JIS specific macro") (MACROS \CONV.SJIS.TO.JIS \CONV.JIS.TO.SJIS \SJIS.KANJI.FIRST.BYTEP ) (* ;; "EUC specific macro") (MACROS \EUC.KANJI.FIRST.BYTEP \GAIJIP \EUC.HANKAKUP] (INITVARS (*SIGNAL-24BIT-NSENCODING-ERROR*) (*READ-NEWLINE-SUPPRESS*) (\RefillBufferFn (FUNCTION \READCREFILL))) (* ;  "Top level val of \RefillBufferFn means act like READC--we must be doing a raw BIN (or PEEKBIN?)") (LOCALVARS . T) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA CONVHANKAKU CL:PARSE-INTEGER CL:READ-DELIMITED-LIST CL:READ-PRESERVING-WHITESPACE CL:READ]) (* ; "Reader entrypoints") (DEFINEQ (LASTC [LAMBDA (FILE) (* ; "Edited 6-Jan-88 15:31 by jds") (* ;; "Be careful only to do BIN's if we first were able to back up, so that an EOF doesn't happen. This is really an inadequate implementation, because it fails for files that cannot be backed up. Eventually, we must change the character reading functions READ, RATOM, READC to save the last character they read in an STREAM field.") (LET* ((STREAM (\GETSTREAM FILE 'INPUT)) (LASTCCODE (FETCH (STREAM LASTCCODE) OF STREAM))) (* ;; "(FCHARACTER (SELCHARQ C (CR (SELECTC (ffetch EOLCONVENTION of STREAM) (CR.EOLC (CHARCODE EOL)) C)) (LF (SELECTC (ffetch EOLCONVENTION of STREAM) (LF.EOLC (CHARCODE EOL)) (CRLF.EOLC (COND ((EQ (CHARCODE CR) (UNINTERRUPTABLY (AND (\BACKNSCHAR STREAM SHIFTEDCHARSET) (PROG1 (PROGN (\BACKNSCHAR STREAM SHIFTEDCHARSET) (\NSIN STREAM SHIFTEDCHARSET)) (\NSIN STREAM SHIFTEDCHARSET))))) (CHARCODE EOL)) (T C))) C)) (NIL 0) C))") (COND ((IEQP LASTCCODE 65535) NIL) (T (FCHARACTER LASTCCODE]) (PEEKC [LAMBDA (FILE FLG) (* rmk%: "10-Apr-85 11:55") (* ;; "FLG says to proceed as if Control were T--not implemented correctly here NIL") (LET [(\RefillBufferFn (FUNCTION \PEEKREFILL)) (STREAM (\GETSTREAM FILE 'INPUT] (DECLARE (SPECVARS \RefillBufferFn)) (FCHARACTER (PEEKCCODE STREAM]) (PEEKCCODE [LAMBDA (FILE NOERROR) (* bvm%: "12-Sep-86 15:19") (LET [(\RefillBufferFn (FUNCTION \PEEKREFILL)) (STREAM (\GETSTREAM FILE 'INPUT] (DECLARE (SPECVARS \RefillBufferFn)) (\PEEKCCODE STREAM NOERROR]) (RATOM [LAMBDA (FILE RDTBL) (* ; "Edited 30-Mar-87 17:21 by bvm:") (* ;;; "Like READ except interpret break characters as single character atoms. I.e., always returns an atom") (SETQ RDTBL (\GTREADTABLE RDTBL)) (LET ((*READTABLE* RDTBL) (*PACKAGE* (if (fetch (READTABLEP USESILPACKAGE) of RDTBL) then *INTERLISP-PACKAGE* else *PACKAGE*)) (\RefillBufferFn (FUNCTION \RATOM/RSTRING-REFILL))) (DECLARE (SPECVARS *READTABLE* *PACKAGE* \RefillBufferFn)) (WITH-RESOURCE (\PNAMESTRING) (\SUBREAD (\GETSTREAM FILE 'INPUT) (fetch (READTABLEP READSA) of *READTABLE*) RATOM.RT \PNAMESTRING (AND (fetch (READTABLEP CASEINSENSITIVE) of *READTABLE*) (fetch (ARRAYP BASE) of UPPERCASEARRAY)) NIL NIL NIL T]) (READ [LAMBDA (FILE RDTBL FLG) (* ; "Edited 19-Mar-87 18:35 by bvm:") (LET ((*READTABLE* (\GTREADTABLE RDTBL)) (*READ-NEWLINE-SUPPRESS* FLG)) (DECLARE (SPECVARS *READTABLE* *READ-NEWLINE-SUPPRESS*)) (* ;; "*READ-NEWLINE-SUPPRESS* is used freely by \FILLBUFFER") (* ;; "Call reader with PRESERVE-WHITESPACE = T, since that's the semantics Interlisp has always had before (though maybe not explicitly stated).") (\TOP-LEVEL-READ FILE NIL NIL NIL T]) (READC [LAMBDA (FILE RDTBL) (* ; "Edited 6-Jan-88 15:30 by jds") (LET ((*READTABLE* (\GTREADTABLE RDTBL)) (\RefillBufferFn (FUNCTION \READCREFILL))) (DECLARE (SPECVARS *READTABLE* \RefillBufferFn)) (FCHARACTER (REPLACE (STREAM LASTCCODE) OF (\INSTREAMARG FILE) WITH (\INCCODE (\INSTREAMARG FILE]) (READCCODE [LAMBDA (FILE RDTBL) (* ; "Edited 3-Jun-88 01:30 by atm") (* ;;; "returns a 16 bit character code. \INCHAR does the EOL conversion and this function converts to a 16 bit value. Saves the character for LASTC as well.") (SETQ FILE (\GETSTREAM FILE 'INPUT)) (FDEVOP 'READCHARCODE (fetch (STREAM DEVICE) of FILE) FILE RDTBL]) (READP [LAMBDA (FILE FLG) (* rmk%: " 5-Apr-85 09:09") (* ;  "The 10 does not do the EOL check on the peeked character.") (LET* ((STREAM (\GETSTREAM FILE 'INPUT)) (DEVICE (ffetch (STREAM DEVICE) of STREAM))) (COND ((ffetch (FDEV READP) of DEVICE) (FDEVOP 'READP DEVICE STREAM FLG)) (T (\GENERIC.READP STREAM FLG]) (SETREADMACROFLG [LAMBDA (FLG) (* rmk%: "25-OCT-83 16:13") (* ;  "D doesn't cause the read-macro context error, hence doesn't maintain this flag") NIL]) (SKIPSEPRCODES [LAMBDA (FILE RDTBL) (* ; "Edited 6-Jan-88 13:09 by jds") (* ;; "Passes over non-separators to peek at the first non-separator on FILE. Returns either last peeked character, or NIL if no non-seprs left in the file.") (bind PREVC C SHIFTEDCHARSET (STREAM _ (\GETSTREAM FILE 'INPUT)) (SA _ (fetch (READTABLEP READSA) of (\GTREADTABLE RDTBL))) (\RefillBufferFn _ '\PEEKREFILL) first (SETQ SHIFTEDCHARSET (UNFOLD (ACCESS-CHARSET STREAM) 256)) declare (SPECVARS \RefillBufferFn) while [EQ SEPRCHAR.RC (\SYNCODE SA (SETQ C (OR (\NSPEEK STREAM SHIFTEDCHARSET SHIFTEDCHARSET T) (RETURN] do (SETQ PREVC C) (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET) finally (AND PREVC (replace (STREAM LASTCCODE) of STREAM with PREVC)) (RETURN C]) (SKIPSEPRS [LAMBDA (FILE RDTBL) (* ; "Edited 11-Sep-87 17:52 by bvm:") (* ;; "Passes over non-separators to peek at the first non-separator on FILE. Returns either last peeked character, or NIL if no non-seprs left in the file.") (bind C SHIFTEDCHARSET (STREAM _ (\GETSTREAM FILE 'INPUT)) (SA _ (fetch (READTABLEP READSA) of (\GTREADTABLE RDTBL))) (\RefillBufferFn _ '\PEEKREFILL) first (SETQ SHIFTEDCHARSET (UNFOLD (ACCESS-CHARSET STREAM) 256)) declare (SPECVARS \RefillBufferFn) while [EQ SEPRCHAR.RC (\SYNCODE SA (SETQ C (OR (\NSPEEK STREAM SHIFTEDCHARSET SHIFTEDCHARSET T) (RETURN] do (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET) finally (RETURN (FCHARACTER C]) (\NSIN.24BITENCODING.ERROR [LAMBDA (STREAM) (* bvm%: "12-Mar-86 15:35") (DECLARE (USEDFREE *SIGNAL-24BIT-NSENCODING-ERROR*)) (* ;;; "Called if we see the sequence shift,shift on STREAM -- means shift to 24-bit character set, which we don't support. Usually this just means we're erroneously reading a binary file as text. If this function returns, its value is taken as a character set to shift to") (COND (*SIGNAL-24BIT-NSENCODING-ERROR* (* ;  "Only cause error if user/reader cares") (ERROR "24-bit NS encoding not supported" STREAM))) (* ; "Return charset zero") 0]) (SKREAD [LAMBDA (FILE REREADSTRING RDTBL) (* ; "Edited 6-Apr-88 11:06 by amd") (LET ((*READ-SUPPRESS* 'SKREAD) (*READTABLE* (\GTREADTABLE RDTBL)) (\RBFLG) (STRM (\GETSTREAM FILE 'INPUT)) CH) (DECLARE (CL:SPECIAL *READTABLE* *READ-SUPPRESS* \RBFLG)) [COND (REREADSTRING (* ;  "REREADSTRING is string of chars already read.") (SETQ STRM (CL:MAKE-CONCATENATED-STREAM (CL:MAKE-STRING-INPUT-STREAM (MKSTRING REREADSTRING )) STRM] (* ;  "Because of return requirements, have to preview stream for unbalanced closing bracket/paren") (if (NULL (SETQ CH (SKIPSEPRCODES STRM))) then (\EOF.ACTION STRM) else (SELECTC (PROG1 (\SYNCODE (fetch (READTABLEP READSA) of *READTABLE*) CH) (* ;; "Read in suppressed mode. Reader sets \Rbflg free if read ended on unbalanced bracket. Reason we do the READ in all cases is so that we need to consume the unbalanced paren/bracket, just as if we really had read it; however, READ doesn't set \Rbflg for these cases") (\TOP-LEVEL-READ STRM NIL NIL NIL T)) (RIGHTPAREN.RC (* ; "unbalanced right paren") '%)) (RIGHTBRACKET.RC (* ; "unbalanced right bracket") '%]) (AND \RBFLG '%]]) ) (* ; "CommonLisp read entry points") (DEFINEQ (CL:READ [CL:LAMBDA (&OPTIONAL (INPUT-STREAM *STANDARD-INPUT*) (EOF-ERROR-P T) EOF-VALUE RECURSIVE-P) (* ; "Edited 14-Dec-86 18:48 by bvm") (COND (RECURSIVE-P (* ;  "Dive straight into reader using current settings of everything") (.CALL.SUBREAD. INPUT-STREAM)) (T (\TOP-LEVEL-READ INPUT-STREAM (NOT EOF-ERROR-P) EOF-VALUE]) (CL:READ-PRESERVING-WHITESPACE [CL:LAMBDA (&OPTIONAL (STREAM *STANDARD-INPUT*) (EOF-ERRORP T) (EOF-VALUE NIL) (RECURSIVEP NIL)) (* ; "Edited 19-Mar-87 18:33 by bvm:") (* ;; "Reads from stream and returns the object read, preserving the whitespace that followed the object.") (COND (RECURSIVEP (* ;  "Dive straight into reader using current settings of everything") (.CALL.SUBREAD. STREAM)) (T (\TOP-LEVEL-READ STREAM (NOT EOF-ERRORP) EOF-VALUE NIL T]) (CL:READ-DELIMITED-LIST [CL:LAMBDA (CHAR &OPTIONAL (INPUT-STREAM *STANDARD-INPUT*) RECURSIVE-P) (* ; "Edited 14-Dec-86 18:48 by bvm") (* ;;; "Read a list of elements terminated by CHAR. CHAR must not be a separator char, and ideally should not be a constituent char (if it is, it must be preceded by whitespace for READ-DELIMITED-LIST to work)") (LET [(ENDCODE (OR (FIXP CHAR) (CL:CHAR-CODE CHAR))) (INSTREAM (\GETSTREAM INPUT-STREAM 'INPUT] (if RECURSIVE-P then (* ;  "Have to dive into reader without disturbing *CIRCLE-READ-LIST*") (.CALL.SUBREAD. INPUT-STREAM NIL NIL ENDCODE) else (\TOP-LEVEL-READ INPUT-STREAM NIL NIL ENDCODE]) (CL:PARSE-INTEGER [CL:LAMBDA (STRING &KEY START END (RADIX 10) JUNK-ALLOWED) (* ;  "Edited 8-Feb-91 13:24 by gadener") (CL:IF (NOT (CL:STRINGP STRING)) (ERROR "This is not a string : ~S" STRING) (PROG ((SA (fetch (READTABLEP READSA) of CMLRDTBL)) (BASE (fetch (STRINGP BASE) of STRING)) (LEN (fetch (STRINGP LENGTH) of STRING)) (OFFST (fetch (STRINGP OFFST) of STRING)) (FATP (fetch (STRINGP FATSTRINGP) of STRING)) MAXDIGITCODE MAXALPHACODE INDEX STOP CHAR SIGN STARTINT ENDINT ERR) (SETQ RADIX (\CHECKRADIX RADIX)) (SETQ INDEX (+ OFFST (if (NULL START) then 0 elseif (< START 0) then (\ILLEGAL.ARG START) else START))) (SETQ STOP (+ OFFST (if (NULL END) then LEN elseif (OR (> END LEN) (< END 0)) then (\ILLEGAL.ARG END) else END))) (SETQ MAXDIGITCODE (+ (CHARCODE 0) RADIX -1)) (SETQ MAXALPHACODE (AND (> RADIX 10) (+ (CHARCODE A) RADIX -11))) (while (AND (< INDEX STOP) (EQ (\SYNCODE SA (\GETBASECHAR FATP BASE INDEX)) SEPRCHAR.RC)) do (* ; "Skip over separators") (SETQ INDEX (CL:1+ INDEX))) [COND ((>= INDEX STOP) (* ; "no characters remain") (RETURN (COND (JUNK-ALLOWED (* ; "don't error") (CL:VALUES NIL STOP)) (T (SETQ ERR "No non-whitespace characters in integer string: ~S") (GO FAIL] (* ;; "Start parsing a number. Allowed to start with a single sign, then digits in radix, nothing else. Assume collating sequence is (+, -) < digits < uppercase letters < lowercase letters.") (do (SETQ CHAR (\GETBASECHAR FATP BASE INDEX)) (if (<= CHAR MAXDIGITCODE) then (* ; "sign or digit") (if (>= CHAR (CHARCODE 0)) then (* ; " digit") (OR STARTINT (SETQ STARTINT INDEX)) elseif (AND (NOT SIGN) (NOT STARTINT)) then (* ;  "maybe sign. No good if not at start") (SELCHARQ CHAR (- (SETQ SIGN '-)) (+ (SETQ SIGN '+)) (RETURN)) else (RETURN)) elseif (AND MAXALPHACODE (<= (if (>= CHAR (CHARCODE "a")) then (* ; "uppercase it first") (- CHAR (- (CHARCODE "a") (CHARCODE "A"))) else CHAR) MAXALPHACODE)) then (* ; "is alphabetic digit") (OR STARTINT (SETQ STARTINT INDEX)) else (RETURN)) repeatwhile (< (add INDEX 1) STOP)) (SETQ ENDINT INDEX) (RETURN (CL:VALUES (COND ([AND STARTINT (OR JUNK-ALLOWED (EQ INDEX STOP) (do (if (NEQ (\SYNCODE SA CHAR) SEPRCHAR.RC) then (* ; " junk found") (RETURN NIL) elseif (EQ (add INDEX 1) STOP) then (* ; "at end of string, win") (RETURN T) else (SETQ CHAR (\GETBASECHAR FATP BASE INDEX] (\MKINTEGER BASE STARTINT ENDINT (EQ SIGN '-) RADIX FATP)) (JUNK-ALLOWED NIL) ((NULL STARTINT) (SETQ ERR "There aren't any digits in this integer string: ~S.") (GO FAIL)) (T (SETQ ERR "There is junk in this integer string: ~S.") (GO FAIL))) (- INDEX OFFST))) FAIL (CL:ERROR ERR (if (OR START END) then (CL:SUBSEQ STRING (OR START 0) (OR END LEN)) else STRING))))]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS CMLRDTBL) ) (* ; "reading strings") (DEFINEQ (RSTRING [LAMBDA (FILE RDTBL RSFLG) (* ; "Edited 22-Mar-87 20:53 by bvm:") (LET ((*READTABLE* (\GTREADTABLE RDTBL)) (\RefillBufferFn '\RATOM/RSTRING-REFILL) (*READ-SUPPRESS* NIL)) (DECLARE (SPECVARS *READTABLE* \RefillBufferFn *READ-SUPPRESS*)) (* ;; "It's not clear that *READ-SUPPRESS* is supposed to affect anything other than calls to READ. So play it safe and force \Rstring2 to really read a string.") (WITH-RESOURCE (\PNAMESTRING) (\RSTRING2 (\GETSTREAM FILE 'INPUT) (fetch READSA of *READTABLE*) (OR RSFLG T) \PNAMESTRING]) (READ-EXTENDED-TOKEN [LAMBDA (STREAM RDTBL ESCAPE-ALLOWED-P) (* ; "Edited 11-Sep-87 16:23 by bvm:") (* ;; "This is a cross between RSTRING and \SUBREAD. Read a %"token%" from STREAM, as defined by the Common Lisp reader and the syntax in RDTBL. EOF terminates as well. If ESCAPE-ALLOWED-P is true, escapes are honored and if one appears, a second value of T is returned. Otherwise, escapes are treated as vanilla chars and the caller can barf on them itself if it desires.") (SETQ RDTBL (\GTREADTABLE RDTBL)) (WITH-RESOURCE (\PNAMESTRING) (PROG ((CASEBASE (AND (fetch (READTABLEP CASEINSENSITIVE) of RDTBL) (fetch (ARRAYP BASE) of UPPERCASEARRAY))) (PBASE (ffetch (STRINGP XBASE) of \PNAMESTRING)) (SHIFTEDCHARSET (UNFOLD (ACCESS-CHARSET STREAM) 256)) (J 0) (SA (fetch READSA of RDTBL)) CH SNX ANSLIST ANSTAIL ESCAPE-APPEARED ESCAPING FATSEEN) LP (if (\EOFP STREAM) then (* ;  "end of file terminates string just like a sepr/break") (GO FINISH)) (SETQ CH (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET)) (* ; "NOTE: This should really be (\CHECKEOLC (\NSIN --) --), but eol is usually a break or sepr and the \BACKNSCHAR doesn't work right. Fix this when we unread correctly") (SETQ SNX (\SYNCODE SA CH)) [COND ((AND ESCAPE-ALLOWED-P (SELECTC SNX (ESCAPE.RC (SETQ CH (\CHECKEOLC (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET) (ffetch EOLCONVENTION of STREAM) STREAM)) (SETQ ESCAPE-APPEARED T)) (MULTIPLE-ESCAPE.RC (SETQ ESCAPING (NOT ESCAPING)) (SETQ ESCAPE-APPEARED T) (GO LP)) NIL))) (ESCAPING (* ; "eat chars until next |")) ((fetch STOPATOM of SNX) (\BACKNSCHAR STREAM SHIFTEDCHARSET) (GO FINISH)) ((AND CASEBASE (ILEQ CH \MAXTHINCHAR)) (SETQ CH (\GETBASEBYTE CASEBASE CH] (COND ((EQ J \PNAMELIMIT) (* ;  "Filled PNSTR so have to save those chars away and start filling up a new buffer") (SETQ J (\SMASHSTRING (ALLOCSTRING J NIL NIL FATSEEN) 0 \PNAMESTRING J)) [COND [ANSLIST (RPLACD ANSTAIL (SETQ ANSTAIL (CONS J NIL] (T (SETQ ANSTAIL (SETQ ANSLIST (CONS J NIL] (SETQ J 0))) (\PNAMESTRINGPUTCHAR PBASE J CH) (COND ((AND (NOT FATSEEN) (IGREATERP CH \MAXTHINCHAR)) (SETQ FATSEEN T))) (SETQ J (ADD1 J)) (GO LP) FINISH (SETQ J (\SMASHSTRING (ALLOCSTRING J NIL NIL FATSEEN) 0 \PNAMESTRING J)) [COND (ANSLIST (RPLACD ANSTAIL (SETQ ANSTAIL (CONS J NIL))) (SETQ J (CONCATLIST ANSLIST] (RETURN (if ESCAPE-APPEARED then (* ;  "do it this way because multiple values are slow") (CL:VALUES J T) else J]) (\RSTRING2 [LAMBDA (STREAM SA RSFLG PNSTR) (* ; "Edited 19-Apr-2021 21:52 by rmk:") (* ;;; "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.") (* ;; "An escaped LF is handled below, stays as LF even from an LF file.") (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 EOL] (SETQ SNX (\SYNCODE SA CH)) (SELECTC SNX (OTHER.RC (* ; "Normal case, nothing to do")) (ESCAPE.RC (* ; "Read the escaped character") (* ;; "\PRINSTRING puts an escape %% before an LF in the string, whether or not it is going to an LF or CR file. An EOL(CR) will be printed as LF on an LF file or CRLF, otherwise left alone. \CHECKEOLC will return EOL for an LF on an LF file, because it doesn't know about escapes. On a CR or an LF file, a CR will come in as an EOL. So the trick here is: don't call \CHECKEOLC on an escaped LF, no matter what the EOL convention of the file..") [COND ((fetch ESCAPEFLG of *READTABLE*) (SETQ CH (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET)) (COND ((EQ CH (CHARCODE LF)) (* ;  "An escaped LF stays as an LF, even from a LF file.") (GO PUTCHAR)) (T (SETQ CH (\CHECKEOLC CH EOLC STREAM)) (COND ((AND (EQ RSFLG 'SKIP) (EQ CH (CHARCODE EOL))) (* ;  "Strip leading spaces after escaped returns, too, but leave the CR in the string") (SETQ SKIPPING 0) (GO PUTCHAR]) (SELECTQ RSFLG (NIL (* ; "end check is dbl quote") (COND ((EQ SNX STRINGDELIM.RC) (* ; "Got it") (SETQ LASTC CH) (GO FINISH)))) (T (* ;  "if called from RSTRING, end check is break or sepr, and we must leave delim in stream") (COND ((fetch STOPATOM of SNX) (\BACKNSCHAR STREAM SHIFTEDCHARSET) (GO FINISH)))) (SKIP (* ;  "Like NIL but strip cr's and leading spaces") (SELECTC SNX (STRINGDELIM.RC (SETQ LASTC CH) (GO FINISH)) (SEPRCHAR.RC (* ; "Assume that CR is a sepr") (COND [SKIPPING (COND ((EQ CH (CHARCODE EOL)) (* ;  "Multiple CR's while skipping are kept") (COND ((EQ SKIPPING T) (* ;  "Turn previous space back into CR. Note that J is guaranteed to be at least 1") (\PNAMESTRINGPUTCHAR PBASE (SUB1 J) CH) (SETQ SKIPPING 0))) (GO PUTCHAR)) (T (* ; "Continue skipping seprs") (GO RS2LP] ((EQ CH (CHARCODE EOL)) (* ;  "Turn CR into space and start skipping seprs") (SETQ SKIPPING T) (SETQ CH (CHARCODE SPACE)) (GO PUTCHAR)))) NIL)) (SHOULDNT))) (SETQ SKIPPING NIL) PUTCHAR [COND ((NOT *READ-SUPPRESS*) (* ; "Accumulate character") (COND ((EQ J \PNAMELIMIT) (* ;  "Filled PNSTR so have to save those chars away and start filling up a new buffer") (SETQ J (\SMASHSTRING (ALLOCSTRING J NIL NIL FATSEEN) 0 PNSTR J)) [COND [ANSLIST (RPLACD ANSTAIL (SETQ ANSTAIL (CONS J NIL] (T (SETQ ANSTAIL (SETQ ANSLIST (CONS J NIL] (SETQ J 0))) (\PNAMESTRINGPUTCHAR PBASE J CH) (SETQ LASTC CH) (COND ((AND (NOT FATSEEN) (IGREATERP CH \MAXTHINCHAR)) (SETQ FATSEEN T))) (SETQ J (ADD1 J] (COND ((OR (NEQ RSFLG T) (NOT (\EOFP STREAM))) (* ; "in RSTRING (RSFLG=T), if we've read something already, then end of file terminates string just like a sepr/break") (GO RS2LP))) FINISH (AND LASTC (replace (STREAM LASTCCODE) of STREAM with LASTC)) (RETURN (COND ((NOT *READ-SUPPRESS*) (SETQ J (\SMASHSTRING (ALLOCSTRING J NIL NIL FATSEEN) 0 PNSTR J)) (COND (ANSLIST (RPLACD ANSTAIL (SETQ ANSTAIL (CONS J NIL))) (CONCATLIST ANSLIST)) (T J]) ) (* ; "Core of the reader") (DEFINEQ (\TOP-LEVEL-READ [LAMBDA (STREAM EOF-SUPPRESS EOF-VALUE CHAR PRESERVE-WHITESPACE) (* ; "Edited 13-Dec-88 16:28 by jds") (* ;; "Entry to the guts of the reader from a place where you may not be already under the reader. CHAR is for READ-DELIMITED-LIST -- it is charcode to terminate read, in which case we are reading a sequence of things instead of a single thing. EOF-SUPPRESS is the opposite of CL:READ's EOF-ERROR-P arg.") (* ;;  " I EOF-SUPPRESS, set the stream's EODOFSTREAMOP to retfrom here with EOF-VALUE as its result.") (LET ((*PACKAGE* (COND ((fetch (READTABLEP USESILPACKAGE) of (\DTEST *READTABLE* 'READTABLEP)) *INTERLISP-PACKAGE*) (T *PACKAGE*))) (\RefillBufferFn (FUNCTION \READREFILL)) (*CIRCLE-READ-LIST* NIL) (OLD-EOS-OP (fetch ENDOFSTREAMOP of STREAM))) (DECLARE (SPECVARS *PACKAGE* \RefillBufferFn *CIRCLE-READ-LIST* EOF-VALUE)) (CL:UNWIND-PROTECT (PROGN [AND EOF-SUPPRESS (REPLACE ENDOFSTREAMOP OF STREAM WITH #'(LAMBDA (STREAM) (RETFROM '\TOP-LEVEL-READ EOF-VALUE] (LET ((RESULT (.CALL.SUBREAD. STREAM EOF-SUPPRESS EOF-VALUE CHAR PRESERVE-WHITESPACE))) (if *CIRCLE-READ-LIST* then (* ;  "There were calls to #=, so go fix up all the ## references.") (HASH-STRUCTURE-SMASH RESULT)) RESULT)) (REPLACE ENDOFSTREAMOP OF STREAM WITH OLD-EOS-OP))]) (\SUBREAD [LAMBDA (STREAM SA READTYPE PNSTR CASEBASE EOF-SUPPRESS EOF-VALUE CHAR PRESERVE-WHITESPACE) (* ; "Edited 7-Jan-88 18:38 by jds") (* ;; "Values of READTYPE are: --- READ.RT for top level of READ, --- NOPROPRB.RT if right-bracket isn't to be propagated -- sublist beginning with left-bracket --- PROPRB.RT if propagation is not suppressed -- sublist beginning with left-paren --- RATOM.RT for call from RATOM") (* ;; "PNSTR is an instance of the global resource \PNAMESTRING, acquired in READ and passed on from level to level. It is released during read-macro applications, then reacquired.") (* ;; "CASEBASE is base of uppercasearray if read table is case-insensitive.") (* ;; "If EOF-SUPPRESS is true, then if we are at end of file we should return EOF-VALUE instead of erroring (we need this because we might actually be sitting before end of file in front of something that reads nothing, e.g., a comment, so caller can't check EOFP itself). Always false on recursive calls.") (* ;; "If CHAR is supplied, it is a character code which, when read (in isolation), should terminate this call to read. Never on when at top-level.") (* ;; "\RBFLG is propagated for top-level calls, in case they are embedded in read-macros. SKREAD also depends on this.") (* ;;  "If PRESERVE-WHITESPACE is true, doesn't throw away the whitespace that terminates the read.") (DECLARE (USEDFREE *READTABLE* \RBFLG)) (* ;; "\RDCONC is a macro that adds a new element as specified by its first argument to the current sublist. Its other arguments will be executed instead if we are the top-level call") (PROG ((TOPLEVELP (SELECTC READTYPE ((LIST READ.RT RATOM.RT) T) NIL)) (SHIFTEDCHARSET (UNFOLD (ACCESS-CHARSET STREAM) 256)) (PBASE (SELECTQ (SYSTEMTYPE) (VAX PNSTR) (ffetch (STRINGP XBASE) of PNSTR))) SNX LST END ELT DOTLOC CH J ESCAPEFLG INVALIDFLG PACKAGE NCOLONS AT-EOF EOF-POSSIBILITY EXTRASEGMENTS LASTC) (if (AND TOPLEVELP (NOT (\INTERMP STREAM))) then (* ;; "EOF is allowed to terminate tokens on direct READ calls. Not if reading from terminal, because \FILLBUFFER made sure to put something at the end.") (SETQ EOF-POSSIBILITY T)) NEWTOKEN (* ;; "Here ready to scan a new token. First skip over separator characters") (SETQ J 0) [SETQ EXTRASEGMENTS (SETQ INVALIDFLG (SETQ ESCAPEFLG (SETQ PACKAGE (SETQ NCOLONS NIL] (if (AND EOF-SUPPRESS (NULL (SKIPSEPRCODES STREAM))) then (* ;  "caller specified eof-error-p of NIL. Happens only on top-level calls") (RETURN EOF-VALUE)) (SETQ SHIFTEDCHARSET (UNFOLD (ACCESS-CHARSET STREAM) 256)) (* ; "By Skipping Separator Characters,Happens CHARSET-Mode Exchanging. (Solution of AR#114 in FX, edited by tt [Jan-22-'90])") (repeatwhile (EQ [SETQ SNX (\SYNCODE SA (SETQ CH (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET] SEPRCHAR.RC)) (COND ((EQ CH CHAR) (* ;  "Read desired terminating char. TOPLEVELP is always false here") (replace (STREAM LASTCCODE) of STREAM with CH) (* ; "Save last char for LASTC.") (RETURN LST)) ((EQ SNX OTHER.RC) (* ; "Start of an atom") (COND ([AND (EQ CH (CHARCODE %.)) (fetch STOPATOM of (\SYNCODE SA (\NSPEEK STREAM SHIFTEDCHARSET SHIFTEDCHARSET] (* ;; "An isolated, unescaped dot. This special check on every atom could be eliminated if . had a special SNX code") (SETQ DOTLOC END) (* ;  "DOTLOC points to CONS cell one before the dot, NIL for car of list, as desired.") )) (GO GOTATOMCHAR)) [(fetch STOPATOM of SNX) (* ;  "This character definitely does not start an atom") (COND ((EQ READTYPE RATOM.RT) (GO SINGLECHARATOM)) (T (GO BREAK] ((EQ SNX PACKAGEDELIM.RC) (* ;  "Starting a symbol with a package delimiter -- must be a keyword") (SETQ NCOLONS 1) (SETQ PACKAGE *KEYWORD-PACKAGE*) (SETQ ESCAPEFLG T) (GO NEXTATOMCHAR)) [(AND (SELECTC (fetch MACROCONTEXT of SNX) (FIRST.RMC T) (ALONE.RMC (fetch STOPATOM of (\SYNCODE SA (\NSPEEK STREAM SHIFTEDCHARSET SHIFTEDCHARSET)))) NIL) (fetch READMACROFLG of *READTABLE*)) (COND ((EQ READTYPE RATOM.RT) (GO SINGLECHARATOM)) (T (GO MACRO] (T (* ;  "Some character that starts an atom but has non-trivial syntax attributes") )) ATOMLOOP (* ;; "At this point, we are accumulating an atom, and CH does not have syntax OTHER, so we have to check special cases") (SELECTC SNX (ESCAPE.RC (* ;  "Take next character to be alphabetic, case exact") (COND ((fetch ESCAPEFLG of *READTABLE*) (SETQ CH (\CHECKEOLC (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET) (ffetch EOLCONVENTION of STREAM) STREAM)) (* ;  "No EOFP check needed -- it's an error to have escape char with nothing following") (SETQ ESCAPEFLG T) (GO PUTATOMCHAR)))) (MULTIPLE-ESCAPE.RC (* ;; "Take characters up to next multiple escape to be alphabetic, except that single escape chars still escape the next char") (SETQ ESCAPEFLG T) [bind ESCFLG do (SETQ CH (\CHECKEOLC (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET) (ffetch EOLCONVENTION of STREAM) STREAM)) (COND ([NOT (COND (ESCFLG (SETQ ESCFLG NIL)) (T (SELECTC (SETQ SNX (\SYNCODE SA CH)) (MULTIPLE-ESCAPE.RC (* ;  "Finished escaped sequence, resume normal processing") (GO NEXTATOMCHAR)) (ESCAPE.RC (* ;  "Pass the next char thru verbatim") (SETQ ESCFLG T)) NIL] (* ;  "All others are pname chars, quoted") (if (NOT *READ-SUPPRESS*) then (COND ((EQ J \PNAMELIMIT) (* ;  "if there have been escapes, can't be a number, so ok to error now.") (LISPERROR "ATOM TOO LONG" (\SUBREADCONCAT EXTRASEGMENTS PBASE J)) (GO NEWTOKEN))) (\PNAMESTRINGPUTCHAR PBASE J CH) (add J 1]) NIL) GOTATOMCHAR (* ;; "CH is a vanilla atom char to accumulate") [COND ((AND CASEBASE (ILEQ CH \MAXTHINCHAR)) (* ; "Uppercase atom characters") (SETQ CH (\GETBASEBYTE CASEBASE CH] PUTATOMCHAR (if (NOT *READ-SUPPRESS*) then (COND ((EQ J \PNAMELIMIT) (* ; "Symbol is too long. However, it could just be a bignum, so keep accumulating characters until we have to do something.") (push EXTRASEGMENTS (\SMASHSTRING (ALLOCSTRING J NIL NIL T) 0 PNSTR J)) (SETQ J 0))) (\PNAMESTRINGPUTCHAR PBASE J CH) (add J 1) (SETQ LASTC CH) (* ; "Save CH for LASTC.")) NEXTATOMCHAR (if (AND EOF-POSSIBILITY (SETQ AT-EOF (\EOFP STREAM))) then (* ;  "EOF terminates atoms at top level") (GO FINISHATOM) elseif (EQ [SETQ SNX (\SYNCODE SA (SETQ CH (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET] OTHER.RC) then (* ;  "normal case tested first--another vanilla constituent char, so keep accumulating atom chars") (GO GOTATOMCHAR) elseif (fetch STOPATOM of SNX) then (* ; "Terminates atom") (GO FINISHATOM) elseif (EQ SNX PACKAGEDELIM.RC) then (GO GOTPACKAGEDELIM) else (GO ATOMLOOP)) FINISHATOM (* ;;  "Come here when an atom has been terminated, either by a break/sepr char or by end of file.") (if INVALIDFLG then (replace (STREAM LASTCCODE) of STREAM with (OR LASTC CH 65535)) (\INVALID.SYMBOL PBASE J NCOLONS PACKAGE EXTRASEGMENTS)) [SETQ ELT (AND (NOT *READ-SUPPRESS*) (if EXTRASEGMENTS then (* ;; "More than \PNAMELIMIT chars were read. Can't be a symbol, but might be a number. Pack up all the strings we have into a single string and try to parse it as a number.") (SETQ EXTRASEGMENTS (\SUBREADCONCAT EXTRASEGMENTS PBASE J)) (OR (AND (NULL (OR PACKAGE ESCAPEFLG NCOLONS)) (\PARSE.NUMBER (fetch (STRINGP BASE) of EXTRASEGMENTS ) (fetch (STRINGP OFFST) of EXTRASEGMENTS) (fetch (STRINGP LENGTH) of EXTRASEGMENTS) \FATPNAMESTRINGP)) (LISPERROR "ATOM TOO LONG" EXTRASEGMENTS)) else (\READ.SYMBOL PBASE 0 J \FATPNAMESTRINGP PACKAGE (EQ NCOLONS 1) ESCAPEFLG] (replace (STREAM LASTCCODE) of STREAM with CH) (* ; "Save last READ char for LASTC.") (if AT-EOF then (* ;  "top-level read, atom terminated by EOF") (RETURN ELT)) (\RDCONC ELT (PROGN (COND ((OR PRESERVE-WHITESPACE (NEQ SNX SEPRCHAR.RC)) (* ; "At top-level, put back the terminating character if preserving whitespace or terminator is significant") (replace (STREAM LASTCCODE) of STREAM with (OR LASTC CH 65535)) (* ;  "And LASTC will return the last REAL char read.") (\BACKNSCHAR STREAM SHIFTEDCHARSET))) (RETURN ELT))) (if (EQ SNX SEPRCHAR.RC) then (* ;  "Terminated with sepr, go on to next char") (GO NEWTOKEN) elseif (EQ CH CHAR) then (* ; "read terminates here") (replace (STREAM LASTCCODE) of STREAM with CH) (RETURN LST) else (* ;  "Terminated with break, jump into the break char code") (GO BREAK)) GOTPACKAGEDELIM (* ;; "Come here if CH is a package delimiter. Note that we have already scanned at least one character of the token, so this must be an interior delim") (COND (*READ-SUPPRESS* (* ; "Don't care about packages")) [(AND (EQ J 0) (NULL EXTRASEGMENTS)) (* ;; "No chars accumulated, so must be 2 colons in a row. Note that the case where we've just started scanning a token happens up at NEWTOKEN") (SETQ LASTC CH) (COND ((AND (EQ NCOLONS 1) (NEQ PACKAGE *KEYWORD-PACKAGE*)) (* ;  "Two colons in a row means internal symbol") (SETQ NCOLONS 2)) (T (* ;  "Error, e.g., `FOO:::BAZ' or `::BAR'") (SETQ INVALIDFLG T) (GO GOTATOMCHAR] ((NULL NCOLONS) (* ;  "We have just scanned the package name") (SETQ NCOLONS 1) (SETQ LASTC CH) [SETQ PACKAGE (COND (EXTRASEGMENTS (LISPERROR "ATOM TOO LONG" (\SUBREADCONCAT EXTRASEGMENTS PBASE J )) (SETQ EXTRASEGMENTS NIL)) ((\FIND.PACKAGE.INTERNAL PBASE 0 J \FATPNAMESTRINGP)) (T (* ;  "Error, but don't signal yet -- save name as string for benefit of error handlers") (\GETBASESTRING PBASE 0 J \FATPNAMESTRINGP] (SETQ J 0)) (T (* ;  "Have alread seen one or more colons, and have scanned more symbol. This colon is an error.") (SETQ LASTC CH) (SETQ INVALIDFLG T) (GO GOTATOMCHAR))) (SETQ ESCAPEFLG T) (* ; "Result MUST be a symbol now") (GO NEXTATOMCHAR) SINGLECHARATOM (* ;; "Come here to create a symbol whose single character is CH -- no package stuff to worry about. This happens mainly for RATOM. We create the single char atom in IL for backward compatibility.") (\PNAMESTRINGPUTCHAR PBASE 0 CH) (SETQ ELT (\READ.SYMBOL PBASE 0 1 \FATPNAMESTRINGP *INTERLISP-PACKAGE*)) (replace (STREAM LASTCCODE) of STREAM with CH) (\RDCONC ELT (RETURN ELT)) (GO NEWTOKEN) (* ;; "End of atom scanning code") BREAK (* ;; "At this point, we have just read a break character, stored in CH") (replace (STREAM LASTCCODE) of STREAM with CH) [SELECTC SNX (LEFTPAREN.RC (* ;; "recursively read a list. If that list (or any of it's non-bracketed sublists) is terminated by a right bracket it terminates our read as well. PROPRB macro worries about right-bracket propagation: if the subread encounters a right bracket (sets \RBFLG), PROPRB returns true. In addition, if we were not called by a left-bracket (READTYPE = NOPROPRB.RT) it sets \RBFLG in caller, thereby propagating the bracket upward.") (COND ((PROG1 (PROPRB (SETQ ELT (\SUBREAD STREAM SA PROPRB.RT PNSTR CASEBASE))) (\RDCONC ELT (RETURN ELT))) (* ;; "PROG1 is true if the subread encountered a right bracket") (FIXDOT) (* ; "Fix dotted pair if necessary") (RETURN LST)))) (LEFTBRACKET.RC (* ;; "recursively read a list, terminated by either right paren or right bracket. In this case, right bracket is not propagated upward--we continue reading elements after it.") (SETQ ELT (\SUBREAD STREAM SA NOPROPRB.RT PNSTR CASEBASE)) (\RDCONC ELT (RETURN ELT))) ((LIST RIGHTPAREN.RC RIGHTBRACKET.RC) (* ;; "Terminate one or more lists, return what we have accumulated so far. In the case of Right bracket, if caller did not have the matching left bracket, we have to allow the bracket to close more than one list.") (RETURN (COND (TOPLEVELP (* ;; "Naked right paren/bracket returns NIL. This is sort of bogus in common lisp, but changing it would be a significant change to Interlisp folks.") NIL) (CHAR (* ;; "call from READ-DELIMITED-LIST doesn't want to terminate this way. Could read as NIL and not terminate, but seems best to error.") (CL:ERROR "Unmatched ~A encountered while reading to a ~A" (CL:CODE-CHAR CH) (CL:CODE-CHAR CHAR)) LST) (T (FIXDOT) (AND (EQ SNX RIGHTBRACKET.RC) (NEQ READTYPE NOPROPRB.RT) (SETQ \RBFLG T)) LST)))) (STRINGDELIM.RC (* ;; "Invoke string reader") (SETQ ELT (\RSTRING2 STREAM SA NIL PNSTR)) (\RDCONC ELT (RETURN ELT))) (COND ((OR (EQ SNX BREAKCHAR.RC) (NOT (fetch READMACROFLG of *READTABLE*))) (* ;  "A breakchar or a disabled always macro") (GO SINGLECHARATOM)) (T (GO MACRO] (GO NEWTOKEN) MACRO (SELECTQ (fetch MACROTYPE of (SETQ SNX (\GETREADMACRODEF CH *READTABLE*))) (MACRO (COND ((PROG1 (PROPRB [SETQ ELT (RELEASERESOURCE \PNAMESTRING PNSTR (CL:MULTIPLE-VALUE-LIST (\APPLYREADMACRO STREAM SNX] (* ;  "Ignore right-bracket if macro is called at top-level read") ) [COND ((NULL ELT) (* ;  "Macro returned zero values, read as nothing") ) (T (SETQ ELT (CAR ELT)) (\RDCONC ELT (RETURN ELT]) (FIXDOT) (* ;  "Encountered right bracket if we get here -- return what we have") (RETURN LST)))) (INFIX (* ;; "We give macro TCONC list of what we've accumulated so far--it gets to modify it as it pleases and return it. We continue from there.") (COND ((PROG1 [PROPRB (SETQ ELT (RELEASERESOURCE \PNAMESTRING PNSTR (\APPLYREADMACRO STREAM SNX (AND LST (CONS LST END] [COND [TOPLEVELP (* ;  "What does INFIX mean at top level?? See IRM") (COND ((AND (LISTP ELT) (CDR ELT)) (* ;  "Result is in TCONC format, so it's returnable") (RETURN (COND ((EQ (CDR ELT) (CAR ELT)) (* ; "TCONC list of one element--return the element. This is how INFIX top level macro can return a non-list. ") (CAAR ELT)) (T (CAR ELT] (T (* ;  "Reading sublist. Take apart TCONC list and continue.") (SETQ LST (CAR ELT)) (SETQ END (CDR ELT]) (FIXDOT) (* ;  "Macro hit right bracket if we got to here") (RETURN LST)))) (SPLICE (* ;; "Macro returns arbitrary number of values to be spliced inline.") [RBCONTEXT (SETQ ELT (RELEASERESOURCE \PNAMESTRING PNSTR (\APPLYREADMACRO STREAM SNX] (* ;  "Note: we don't care if there was terminating right-bracket") (* ; "Why? -bvm") (COND ((OR (NULL ELT) TOPLEVELP) (* ;; "On the 10, it actually returns ELT if it is a list and the next token is a closing paren or bracket. Hard to see how to get that behavior--rmk") (GO NEWTOKEN)) ((NLISTP ELT) (* ;  "The 10 throws initial non-lists away (What if LST/END aren't set?)") (SETQ ELT (AND LST (LIST '%. ELT))) (SETQ DOTLOC END))) [COND ((NOT *READ-SUPPRESS*) (COND (LST (RPLACD END ELT)) (T (SETQ LST ELT))) (SETQ END (LAST ELT)) (COND ((CDR END) (* ; "A dotted pair") (SETQ DOTLOC END) (RPLACD END (CONS '%. (SETQ END (CONS (CDR END]) (SHOULDNT)) (GO NEWTOKEN]) (\SUBREADCONCAT [LAMBDA (EXTRASEGMENTS PBASE J) (* ; "Edited 16-Jan-87 15:08 by bvm:") (* ;; "Produces a string consisting of all the characters \SUBREAD has been buffering up into a token. Last J chars are stored at PBASE. EXTRASEGMENTS is a list of strings in reverse order in the case that more characters were scanned than the pname string accommodates.") (SETQ PBASE (\GETBASESTRING PBASE 0 J \FATPNAMESTRINGP)) (if EXTRASEGMENTS then (CONCATLIST (NCONC1 (REVERSE EXTRASEGMENTS) PBASE)) else PBASE]) (\ORIG-READ.SYMBOL [LAMBDA (BASE OFFSET LEN FATP PACKAGE EXTERNALP NONNUMERICP) (* bvm%: " 3-Aug-86 15:25") (* ;;; "Read a number or symbol from the string defined by BASE OFFSET LEN FATP PACKAGE is NIL if no package was specified, a package object or a string if an unknown package was typed (causes error). EXTERNALP is true if symbol was typed with one colon, which requires that the symbol exist and be external. NONNUMERICP is true if we know the symbol is not a number, e.g., some characters in it were escaped.") (* ;;; "For now a dummy definition") (COND (PACKAGE (* ; "For debugging") (CONCAT PACKAGE (COND (EXTERNALP ":") (T "::")) (\GETBASESTRING BASE OFFSET LEN FATP))) (T (OR (AND (NOT NONNUMERICP) (\PARSE.NUMBER BASE OFFSET LEN FATP)) (\MKATOM BASE OFFSET LEN FATP T]) (\ORIG-INVALID.SYMBOL [LAMBDA (BASE LEN NCOLONS PACKAGE EXTRASEGMENTS) (* ; "Edited 15-Jan-87 17:33 by bvm:") (* ;;; "Called when scanning a symbol that has more than 2 colons, or more than 1 non-consecutive colon. If return from here, will read the symbol as though the extra colons were escaped.") (CL:CERROR "Treat the extra colon(s) as if they were escaped" "Invalid symbol syntax in %"~A%"" (CONCAT (if (AND PACKAGE (NEQ PACKAGE *KEYWORD-PACKAGE*)) then (if (STRINGP PACKAGE) then PACKAGE else (CL:PACKAGE-NAME PACKAGE)) else "") (SELECTQ NCOLONS (1 ":") (2 "::") "") (\SUBREADCONCAT EXTRASEGMENTS BASE LEN]) (\APPLYREADMACRO [LAMBDA (STREAM MACDEF ANSCELL) (* bvm%: " 4-May-86 16:38") (* ;  "INREADMACROP searches for this framename") (DECLARE (USEDFREE *READTABLE*)) (APPLY* (fetch MACROFN of MACDEF) STREAM *READTABLE* ANSCELL]) (INREADMACROP [LAMBDA NIL (* edited%: "26-MAY-79 00:12") (PROG (TEM (\READDEPTH -1)) (DECLARE (SPECVARS \READDEPTH)) (COND ([NULL (SETQ TEM (STKPOS '\APPLYREADMACRO] (RETURN NIL))) (MAPDL [FUNCTION (LAMBDA (NM POS) (COND ((EQ NM '\SUBREAD) (SETQ \READDEPTH (ADD1 \READDEPTH] TEM) (RELSTK TEM) (RETURN \READDEPTH]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (MOVD? '\ORIG-READ.SYMBOL '\READ.SYMBOL) (MOVD? '\ORIG-INVALID.SYMBOL '\INVALID.SYMBOL) ) (* ; "Read macro for '") (DEFINEQ (READQUOTE [LAMBDA (FILE) (* ; "Edited 19-Mar-87 16:10 by bvm:") (LIST 'QUOTE (CL:READ FILE T NIL T]) ) (* ; "# macro") (DEFINEQ (READVBAR [LAMBDA (STREAM RDTBL) (* bvm%: "14-May-86 17:31") (* ;;; "Read Interlisp's | macro. Originally this char was just a sepr in FILERDTBL but was then extended in various hokey ways, because it was the only character plausibly available for redefinition. Today it is extended still further to be Common Lisp # in all the cases not already taken by some other meaning") (SELCHARQ (PEEKCCODE STREAM) (%' (* ;  "commonlisp defines #'X to mean (FUNCTION X), but here it's BQUOTE") (READCCODE STREAM) (READBQUOTE STREAM RDTBL)) ((%( { ^) (* ; "Used by HPRINT") (HREAD STREAM)) (%# (READCCODE STREAM) (* ; "|# = Common Lisp #") (READHASHMACRO STREAM RDTBL)) ((EOL TAB SPACE) (* ; "CR or tab, treat as separator") (CL:VALUES)) (PROGN (* ;  "Everything else not already preempted by old-style | is interpreted as Common Lisp") (READHASHMACRO STREAM RDTBL]) (READHASHMACRO [LAMBDA (STREAM RDTBL INDEX) (* amd "15-Oct-86 16:36") (* ;;; "Implements the standard # macro dispatch -- reads next character to find out what to do. Can return zero values if we just want to skip something.") (LET ([READFN (COND ((fetch (READTABLEP COMMONLISP) of RDTBL) (* ;; "Kludge: if we have to recursively read something that will not end up as the resulting list structure, use the reader that passes thru CMLTRANSLATE") (FUNCTION CL:READ)) (T (FUNCTION READ] NEXTCHAR READVAL) [while (DIGITCHARP (SETQ NEXTCHAR (PEEKCCODE STREAM RDTBL))) do (SETQ INDEX (PLUS (TIMES (OR INDEX 0) 10) (DIFFERENCE (READCCODE STREAM RDTBL) (CHARCODE 0] (SELCHARQ NEXTCHAR ("(" [LET ((CONTENTS (APPLY* READFN STREAM))) (COND (INDEX (FILL-VECTOR (CL:MAKE-ARRAY INDEX) CONTENTS)) (T (CL:MAKE-ARRAY (LENGTH CONTENTS) :INITIAL-CONTENTS CONTENTS]) (PROGN (* ;  "Those cases we left the dispatching char in buffer for convenience of the next read. Now eat it") (SELCHARQ (READCCODE STREAM RDTBL) (%' (LIST 'FUNCTION (READ STREAM RDTBL))) (%. (EVAL (APPLY* READFN STREAM))) (%, (LIST 'LOADTIMECONSTANT (READ STREAM RDTBL))) (\ (CHARACTER.READ STREAM)) ("*" (* ; "Read bit vector") [LET [(CONTENTS (while (MEMQ (PEEKCCODE STREAM RDTBL) (CHARCODE (0 1))) collect (IDIFFERENCE (READCCODE STREAM RDTBL) (CHARCODE 0] (COND (INDEX (FILL-VECTOR (CL:MAKE-ARRAY INDEX :ELEMENT-TYPE 'BIT) CONTENTS)) (T (CL:MAKE-ARRAY (LENGTH CONTENTS) :INITIAL-CONTENTS CONTENTS :ELEMENT-TYPE 'BIT]) (":" (* ;; "The same thing HASH-COLON does.") (CL:MAKE-SYMBOL (READ-EXTENDED-TOKEN STREAM RDTBL))) ((O o) (READNUMBERINBASE STREAM 8)) ((B b) (READNUMBERINBASE STREAM 2)) ((X x) (READNUMBERINBASE STREAM 16)) ((R r) (READNUMBERINBASE STREAM INDEX)) ((A a) (LET ((CONTENTS (APPLY* READFN STREAM))) (CL:MAKE-ARRAY (ESTIMATE-DIMENSIONALITY INDEX CONTENTS) :INITIAL-CONTENTS CONTENTS))) ((S s) (CREATE-STRUCTURE (APPLY* READFN STREAM))) ((C c) (DESTRUCTURING-BIND (NUM DEN) (APPLY* READFN STREAM) (COMPLEX NUM DEN))) (+ (* ;  "Skip expression if feature not present") (COND ((NOT (CMLREAD.FEATURE.PARSER (READ STREAM RDTBL))) (CL:READ STREAM RDTBL))) (CL:VALUES)) (- (* ;  "Skip expression if feature IS present") (COND ((CMLREAD.FEATURE.PARSER (READ STREAM RDTBL)) (CL:READ STREAM RDTBL))) (CL:VALUES)) ("|" (* ; "special comment") (SKIP.HASH.COMMENT STREAM RDTBL) (CL:VALUES)) (< (ERROR "#< construct is un-READ-able" (READ))) ((SPACE TAB NEWLINE PAGE RETURN %)) (ERROR "Illegal read syntax " (CHARCODE.UNDECODE NEXTCHAR))) (%" (* ;  "An extension -- read string without cr's and leading spaces") (RSTRING STREAM RDTBL 'SKIP)) (APPLY* (OR (GET (CHARACTER NEXTCHAR) 'HASHREADMACRO) (ERROR "Undefined hashmacro char" NEXTCHAR)) STREAM RDTBL]) (DEFMACRO-LAMBDA-LIST-KEYWORD-P [LAMBDA (S) (* bvm%: " 3-Nov-86 15:12") (AND (FMEMB S '(&OPTIONAL &REST &KEY &ALLOW-OTHER-KEYS &AUX &BODY &WHOLE)) T]) (DIGITBASEP [LAMBDA (CODE RADIX) (* lmm "11-Jun-85 00:54") (COND ((AND (GEQ CODE (CHARCODE 0)) (LESSP CODE (PLUS (CHARCODE 0) RADIX))) (DIFFERENCE CODE (CHARCODE 0))) ((GREATERP RADIX 10) [COND ((AND (GEQ CODE (CHARCODE a)) (LEQ CODE (CHARCODE z))) (add CODE (DIFFERENCE (CHARCODE A) (CHARCODE a] (COND ((AND (GEQ CODE (CHARCODE A)) (LEQ CODE (CHARCODE Z))) [SETQ CODE (PLUS 10 (DIFFERENCE CODE (CHARCODE A] (COND ((LESSP CODE RADIX) CODE]) (READNUMBERINBASE [LAMBDA (STREAM RADIX) (* bvm%: " 4-Nov-86 21:34") (PROG ((BODY (READ-EXTENDED-TOKEN STREAM)) (I 1) CH VAL NUMERATOR SIGN BASE) (* ; "First check for leading sign") (if *READ-SUPPRESS* then (* ; "work is done") (RETURN NIL)) (SELCHARQ (SETQ CH (NTHCHARCODE BODY 1)) (+ (GO NEXTCH)) (- (SETQ SIGN T) (GO NEXTCH)) NIL) LP (if (SETQ BASE (DIGITBASEP CH RADIX)) then (SETQ VAL (+ (TIMES (OR VAL 0) RADIX) BASE)) elseif (EQ CH (CHARCODE "/")) then (* ; "Ratio marker") (if (OR NUMERATOR (NULL VAL)) then (GO MALFORMED)) (SETQ NUMERATOR VAL) (SETQ VAL NIL) else (* ;  "Terminated by a character that is not a token delimiter") (GO MALFORMED)) NEXTCH (if (SETQ CH (NTHCHARCODE BODY (add I 1))) then (GO LP) else (* ; "end of token, fall thru")) DONE (if (NULL VAL) then (GO MALFORMED)) (if NUMERATOR then (SETQ VAL (%%/ NUMERATOR VAL))) (RETURN (if SIGN then (- VAL) else VAL)) MALFORMED (RETURN (CL:ERROR "Malformed base ~D rational ~S" RADIX BODY]) (ESTIMATE-DIMENSIONALITY [LAMBDA (RANK CONTENTS) (* bvm%: " 9-May-86 16:06") (COND ((NULL RANK) (ERROR "No rank found while reading array" NIL)) ((EQ RANK 0) NIL) (T (to RANK as (D _ CONTENTS) by (CAR D) collect (LENGTH D]) (SKIP.HASH.COMMENT [LAMBDA (STREAM RDTBL) (* bvm%: "12-Sep-86 21:02") (PROG NIL (* ;; "a tiny fsm that recognizes #| ... |# with possible nestings of itself") LP (SELCHARQ (READCCODE STREAM RDTBL) ("#" (GO SHARP)) ("|" (GO VBAR)) (GO LP)) SHARP (SELCHARQ (READCCODE STREAM RDTBL) ("|" (* ;  "#| -- recursively skip nested section") (SKIP.HASH.COMMENT STREAM RDTBL) (GO LP)) ("#" (GO SHARP)) (GO LP)) VBAR (SELCHARQ (READCCODE STREAM RDTBL) ("|" (GO VBAR)) ("#" (* ; "found closing |#") (RETURN)) (GO LP]) (CMLREAD.FEATURE.PARSER [LAMBDA (EXPR) (* bvm%: " 3-Nov-86 15:07") (COND ((CL:CONSP EXPR) (SELECTQ (CAR EXPR) ((:AND AND) (EVERY (CDR EXPR) (FUNCTION CMLREAD.FEATURE.PARSER))) ((:OR OR) (SOME (CDR EXPR) (FUNCTION CMLREAD.FEATURE.PARSER))) ((:NOT NOT) (NOT (CMLREAD.FEATURE.PARSER (CADR EXPR)))) (ERROR "Bad feature expression" EXPR))) ((FMEMB EXPR *FEATURES*) T]) ) (* ; "Reading characters with #\") (DEFINEQ (CHARACTER.READ [LAMBDA (STREAM) (* bvm%: " 4-Nov-86 21:50") (* ;;; "Called by the #\ macro -- reads a character object consisting of the thing next named") (LET ((NEXTCHAR (READCCODE STREAM)) CH) (COND ((OR (NULL (SETQ CH (PEEKCCODE STREAM T))) (fetch STOPATOM of (\SYNCODE (fetch READSA of *READTABLE*) CH))) (* ;  "Terminates next, so it's just this char") (CL:CODE-CHAR NEXTCHAR)) (*READ-SUPPRESS* (* ;  "don't try to decode it, could be illegal") (READ-EXTENDED-TOKEN STREAM) NIL) (T (* ;  "Read a whole name, up to the next break/sepr") (CL:CODE-CHAR (CHARCODE.DECODE (CONCAT (ALLOCSTRING 1 NEXTCHAR) (READ-EXTENDED-TOKEN STREAM]) (CHARCODE.DECODE [LAMBDA (C NOERROR) (* ;  "Edited 1-Aug-2020 18:52 by rmk:") (* ; "Edited 18-Feb-87 22:03 by bvm:") (DECLARE (GLOBALVARS CHARACTERNAMES CHARACTERSETNAMES)) (* ;; "RMK 2020: Added hexstring decoding for Unicode: no commas or other delimiters") (* ;; "This overrides the definition in LLREAD. It should be placed there, but for some reason it is not possible to then recompile that file: loading a new .LCOM says that \INVALID.SYMBOL is a bad compiled function, and then it loses track of the keyword package. Could be a load-sequence problem that would be resolved if this is installed in a new INIT.SYSOUT rather than an overlay of files already loaded into the LISP.SYSOUT") (COND ((NOT C) NIL) ((LISTP C) (CONS (CHARCODE.DECODE (CAR C) NOERROR) (CHARCODE.DECODE (CDR C) NOERROR))) ((NOT (OR (ATOM C) (STRINGP C))) (AND (NOT NOERROR) (ERROR "BAD CHARACTER SPECIFICATION" C))) ((EQ (NCHARS C) 1) (CHCON1 C)) (T (SELCHARQ (CHCON1 C) (^ (AND (SETQ C (CHARCODE.DECODE (SUBSTRING C 2 -1) NOERROR)) (LOGAND C (LOGNOT 96)))) (%# (* ;; "We use IPLUS instead of LOGOR here because some people want ##char to read as Xerox Meta, i.e., 1,char") (AND (SETQ C (CHARCODE.DECODE (SUBSTRING C 2 -1) NOERROR)) (IPLUS C 128))) (LET ((STR (MKSTRING C))) (for X in CHARACTERNAMES when (STRING.EQUAL (CAR X) STR) do (RETURN (OR (NUMBERP (CADR X)) (CHARCODE.DECODE (CADR X) NOERROR))) finally (RETURN (LET ((POS (STRPOSL '(%, - "." "|") STR)) CH CSET) (* ; "In the form charset,char") (COND ((AND POS (SETQ CH (OR (CL:PARSE-INTEGER STR :START POS :RADIX 8 :JUNK-ALLOWED T) (CHARCODE.DECODE (SUBSTRING STR (ADD1 POS)) NOERROR))) (< CH 256) (>= CH 0)) (* ;  "parsed the char part as an octal number or character spec") (if (AND [SETQ CSET (OR (CL:PARSE-INTEGER STR :END (SUB1 POS) :RADIX 8 :JUNK-ALLOWED T) (for PAIR in CHARACTERSETNAMES first (SETQ POS (SUBSTRING STR 1 (SUB1 POS))) when (STRING.EQUAL (CAR PAIR) POS) do (RETURN (CADR PAIR] (< CSET 256) (>= CSET 0)) then (* ;  "parsed the charset part as an octal number or standard charset name") (LOGOR CH (LLSH CSET 8)) elseif (NOT NOERROR) then (ERROR "BAD CHARACTERSET SPECIFICATION" C))) ((AND (NOT (FIXP C)) (CL:PARSE-INTEGER (CL:IF (EQ 1 (OR (STRPOS "0x" STR) (STRPOS "0X" STR) (STRPOS "U+" STR))) (SUBSTRING STR 3) STR) :RADIX 16 :JUNK-ALLOWED T))) ((NOT NOERROR) (ERROR "BAD CHARACTER SPECIFICATION" C]) ) (RPAQQ CHARACTERNAMES (("Page" 12) ("Form" 12) ("FF" 12) ("Rubout" 127) ("Del" 127) ("Null" 0) ("Escape" 27) ("Esc" 27) ("Bell" 7) ("Tab" 9) ("Backspace" 8) ("Bs" 8) ("Newline" 13) ("CR" 13) ("EOL" 13) ("Return" 13) ("Tenexeol" 31) ("Space" 32) ("Sp" 32) ("Linefeed" 10) ("LF" 10))) (RPAQQ CHARACTERSETNAMES (("Greek" 38) ("Cyrillic" 39) ("Hira" 36) ("Hiragana" 36) ("Kata" 37) ("Katakana" 37) ("Kanji" 48))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (RPAQQ READTYPES (READ.RT RATOM.RT NOPROPRB.RT PROPRB.RT)) (DECLARE%: EVAL@COMPILE (RPAQQ READ.RT NIL) (RPAQQ RATOM.RT 1) (RPAQQ NOPROPRB.RT T) (RPAQQ PROPRB.RT 0) (CONSTANTS READ.RT RATOM.RT NOPROPRB.RT PROPRB.RT) ) (DECLARE%: EVAL@COMPILE (PUTPROPS .CALL.SUBREAD. MACRO ((STREAM EOF-SUPPRESS EOF-VALUE CHAR PRESERVE-WHITESPACE) (WITH-RESOURCE (\PNAMESTRING) (\SUBREAD (\GETSTREAM STREAM 'INPUT) (fetch (READTABLEP READSA) of *READTABLE* ) (COND (CHAR -1) (T READ.RT)) \PNAMESTRING (AND (fetch (READTABLEP CASEINSENSITIVE) of *READTABLE*) (fetch (ARRAYP BASE) of UPPERCASEARRAY )) EOF-SUPPRESS EOF-VALUE CHAR PRESERVE-WHITESPACE )))) (PUTPROPS FIXDOT MACRO [NIL (PROGN (* ;  "Fix a non-first dot followed by a singleton") (AND DOTLOC (CDDR DOTLOC) (NULL (CDDDR DOTLOC)) (RPLACD DOTLOC (CADDR DOTLOC]) (PUTPROPS RBCONTEXT MACRO ((X . Y) ([LAMBDA (\RBFLG) (DECLARE (SPECVARS \RBFLG)) (PROGN X . Y) \RBFLG] NIL))) (PUTPROPS PROPRB MACRO [(X . Y) (* ;  "Propagates the right-bracket flag") (AND (RBCONTEXT X . Y) (OR (EQ READTYPE NOPROPRB.RT) (SETQ \RBFLG T]) (PUTPROPS \RDCONC MACRO [(ELT . TOPFORMS) (* ;; "Add ELT to the accumulating list to be returned by \SUBREAD. If at top level and no list accumulated, then run TOPFORMS") (COND [LST (RPLACD END (SETQ END (CONS ELT] (TOPLEVELP . TOPFORMS) ((NOT *READ-SUPPRESS*) (* ;  "Don't bother consing the result if it's going to be thrown away") (SETQ END (SETQ LST (CONS ELT]) ) (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (PUTPROPS \BACKCHAR MACRO (OPENLAMBDA (STREAM) (* ; "Backs up over an NS character") (\BACKNSCHAR STREAM (UNFOLD (ACCESS-CHARSET STREAM) 256)))) (PUTPROPS \BACKNSCHAR MACRO [(ST SHIFTEDCHARSET COUNTERVAR) (COND ((\XCCSP ST) (\BACKXCCSCHAR ST SHIFTEDCHARSET COUNTERVAR)) (T (COND ['COUNTERVAR (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR (CL:FUNCALL (ffetch (STREAM BACKCHARFN) of ST) ST T] (T (CL:FUNCALL (ffetch (STREAM BACKCHARFN) of ST) ST NIL]) (PUTPROPS \CHECKEOLC MACRO (OPENLAMBDA (CH EOLC STREAM PEEKBINFLG COUNTERVAR) (* ;; "Subtracts number of bytes read from COUNTERVAR, which may be NIL. In fact, should be NIL if PEEKBINFLG is T.") (SELCHARQ CH (CR (SELECTC EOLC (CR.EOLC (CHARCODE EOL)) (CRLF.EOLC (COND [PEEKBINFLG (* ;; "T from PEEKC, compile-time constant. In this case, must leave the fileptr where it was, except for possibly advancing over character set shifts") (COND ([EQ (CHARCODE LF) (UNINTERRUPTABLY (\NSIN STREAM (UNFOLD (ACCESS-CHARSET STREAM) 256)) (* ;; "Read the NS CR. We know that there aren't any font-shift characters in front of the CR, because they would have already been read by the \NSPEEK that got the CR character. Since we are going to NS back the CR character, we don't need to update the counter variable") (PROG1 (\PEEKBIN STREAM T) (* ;; "LF must be in next BYTE after NS CR, regardless of coding. Character-set shifting bytes can't intervene. Then we back up over the CR that was \NSINed above.") (\BACKNSCHAR STREAM)))] (CHARCODE EOL)) (T (CHARCODE CR] ((EQ (CHARCODE LF) (\PEEKBIN STREAM T)) (\BIN STREAM) (AND 'COUNTERVAR (SETQ COUNTERVAR (SUB1 COUNTERVAR))) (CHARCODE EOL)) (T (CHARCODE CR)))) (CHARCODE CR))) (LF (COND ((EQ EOLC LF.EOLC) (CHARCODE EOL)) (T (CHARCODE LF)))) CH))) (PUTPROPS \INCHAR MACRO (OPENLAMBDA (STREAM COUNTERVAR) (* ; "returns a 16 bit character code") (\CHECKEOLC (\NSIN STREAM (UNFOLD (ACCESS-CHARSET STREAM) 256) NIL COUNTERVAR) (FFETCH EOLCONVENTION OF STREAM) STREAM NIL COUNTERVAR))) (PUTPROPS \INCCODE MACRO (OPENLAMBDA (STREAM COUNTERVAR) (* ; "returns a 16 bit character code") (\CHECKEOLC (\NSIN STREAM (UNFOLD (ACCESS-CHARSET STREAM) 256) NIL COUNTERVAR) (ffetch EOLCONVENTION of STREAM) STREAM NIL COUNTERVAR))) (PUTPROPS \PEEKCCODE MACRO (OPENLAMBDA (STREAM NOERROR) (\CHECKEOLC (\NSPEEK STREAM (UNFOLD (ACCESS-CHARSET STREAM) 256) NIL NOERROR) (ffetch EOLCONVENTION of STREAM) STREAM T))) (PUTPROPS \NSIN MACRO [(ST SHIFTEDCSET SHIFTEDCSETVAR COUNTERVAR) (* ;;; "Dispatches to the appropriate character code decoder. If you want to support a new character encoding format, you have to write a decoder and add it here.") (COND ((\XCCSP ST) (\XCCSIN ST SHIFTEDCSET SHIFTEDCSETVAR COUNTERVAR)) (T (COND ('COUNTERVAR (CL:MULTIPLE-VALUE-BIND (CODE NUM) (CL:FUNCALL (ffetch (STREAM INCCODEFN) of ST) ST T) (AND NUM (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR NUM ))) CODE)) (T (CL:FUNCALL (ffetch (STREAM INCCODEFN) of ST) ST NIL]) (PUTPROPS \NSPEEK MACRO [(ST SHIFTEDCSET SHIFTEDCSETVAR NOERROR COUNTERVAR) (* ;;; "Dispatches to the appropriate character code decoder. If you want to support a new character encoding format, you have to write a decoder and add it here.") (COND ((\XCCSP ST) (\XCCSPEEK ST (UNFOLD (ACCESS-CHARSET ST) 256) NIL NOERROR)) (T (COND ('COUNTERVAR (CL:MULTIPLE-VALUE-BIND (CODE NUM) (CL:FUNCALL (ffetch (STREAM PEEKCCODEFN) of ST) ST NOERROR T) (AND NUM (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR NUM))) CODE)) (T (CL:FUNCALL (ffetch (STREAM PEEKCCODEFN) of ST) ST NOERROR NIL]) (PUTPROPS NUMERIC-CHARSET MACRO (= . ACCESS-CHARSET)) ) (* "END EXPORTED DEFINITIONS") (DECLARE%: DOEVAL@COMPILE DONTCOPY (SPECVARS *READ-NEWLINE-SUPPRESS* \RefillBufferFn) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS *KEYWORD-PACKAGE* *INTERLISP-PACKAGE*) ) ) (* ; "Support for various external formats") (* ; "JIS to XCCS conversion table.") (RPAQQ *JIS-TO-XCCS-CONV-NO-FONT-TABLE* ((8484 . 8484) (8485 . 8485) (8497 . 9155) (8798 . 61376) (8802 . 8802) (8805 . 64892) (8806 . 64894) (8820 . 9148) (8821 . 9132) (8822 . 213) (8830 . 8830) (10273 . 61189) (10274 . 61188) (10275 . 10275) (10276 . 10276) (10277 . 10277) (10278 . 10278) (10279 . 10279) (10280 . 10280) (10281 . 10281) (10282 . 10282) (10283 . 61414) (10284 . 61410) (10285 . 61409) (10286 . 10286) (10287 . 10287) (10288 . 10288) (10289 . 10289) (10290 . 10290) (10291 . 10291) (10292 . 10292) (10293 . 10293) (10294 . 61411) (10295 . 10295) (10296 . 10296) (10297 . 10297) (10298 . 10298) (10299 . 10299) (10300 . 10300) (10301 . 10301) (10302 . 10302) (10303 . 10303) (10304 . 10304))) (RPAQQ *JIS-TO-XCCS-CODE-MAP* ((1 (1 33 . 33) (2 33 . 34) (3 33 . 35) (6 0 . 183) (7 0 . 58) (8 0 . 59) (9 0 . 63) (10 0 . 33) (11 33 . 43) (12 33 . 44) (13 0 . 194) (14 0 . 193) (15 0 . 200) (16 0 . 195) (18 0 . 204) (19 33 . 51) (20 33 . 52) (21 33 . 53) (22 33 . 54) (23 33 . 55) (24 33 . 56) (25 33 . 57) (26 33 . 58) (27 33 . 59) (28 33 . 60) (29 239 . 36) (30 33 . 62) (31 0 . 47) (32 0 . 92) (33 0 . 126) (34 33 . 66) (35 0 . 124) (36 33 . 68) (37 33 . 69) (38 0 . 169) (39 0 . 39) (40 0 . 170) (41 0 . 186) (42 0 . 40) (43 0 . 41) (44 33 . 76) (45 33 . 77) (46 0 . 91) (47 0 . 93) (48 0 . 123) (49 0 . 125) (50 239 . 50) (51 239 . 51) (52 0 . 171) (53 0 . 187) (54 33 . 86) (55 33 . 87) (56 33 . 88) (57 33 . 89) (58 33 . 90) (59 33 . 91) (60 0 . 43) (61 0 . 45) (62 0 . 177) (63 0 . 180) (64 0 . 184) (65 0 . 61) (66 33 . 98) (67 0 . 60) (68 0 . 62) (69 33 . 101) (70 33 . 102) (71 33 . 103) (72 33 . 104) (73 33 . 105) (74 33 . 106) (75 0 . 176) (76 33 . 108) (77 33 . 109) (78 33 . 110) (79 0 . 165) (80 0 . 164) (81 0 . 162) (82 0 . 163) (83 0 . 37) (84 0 . 35) (85 0 . 38) (86 0 . 42) (87 0 . 64) (88 0 . 167) (89 33 . 121) (90 33 . 122) (91 33 . 123) (92 33 . 124) (93 33 . 125) (94 33 . 126)) (2 (1 34 . 33) (2 34 . 34) (3 34 . 35) (4 34 . 36) (5 34 . 37) (6 34 . 38) (7 34 . 39) (8 34 . 40) (9 34 . 41) (10 0 . 174) (11 0 . 172) (12 0 . 173) (13 0 . 175) (14 34 . 46) (26 239 . 74) (27 239 . 76) (28 239 . 89) (29 239 . 88) (30 239 . 91) (31 239 . 90) (32 239 . 87) (33 239 . 86) (42 239 . 182) (43 239 . 183) (44 239 . 106) (45 239 . 79) (46 239 . 78) (47 239 . 181) (48 239 . 180) (60 239 . 108) (61 239 . 112) (63 239 . 186) (64 239 . 185) (65 239 . 114) (67 239 . 66) (68 239 . 67) (71 239 . 113) (72 239 . 111) (73 239 . 117) (74 34 . 106) (82 241 . 40) (83 239 . 65) (87 239 . 48) (88 239 . 49) (89 0 . 176)) (6 (1 38 . 65) (2 38 . 66) (3 38 . 68) (4 38 . 69) (5 38 . 70) (6 38 . 73) (7 38 . 74) (8 38 . 75) (9 38 . 76) (10 38 . 77) (11 38 . 78) (12 38 . 79) (13 38 . 80) (14 38 . 81) (15 38 . 82) (16 38 . 83) (17 38 . 85) (18 38 . 86) (19 38 . 88) (20 38 . 89) (21 38 . 90) (22 38 . 91) (23 38 . 92) (24 38 . 93) (33 38 . 97) (34 38 . 98) (35 38 . 100) (36 38 . 101) (37 38 . 102) (38 38 . 105) (39 38 . 106) (40 38 . 107) (41 38 . 108) (42 38 . 109) (43 38 . 110) (44 38 . 111) (45 38 . 112) (46 38 . 113) (47 38 . 114) (48 38 . 115) (49 38 . 117) (50 38 . 118) (51 38 . 120) (52 38 . 121) (53 38 . 122) (54 38 . 123) (55 38 . 124) (56 38 . 125)))) (RPAQQ *HANKAKU-TO-ZENKAKU-CODE-MAP* ((161 . 8483) (162 . 8534) (163 . 8535) (164 . 8482) (165 . 183) (166 . 9586) (167 . 9505) (168 . 9507) (169 . 9509) (170 . 9511) (171 . 9513) (172 . 9571) (173 . 9573) (174 . 9575) (175 . 9539) (176 . 8508) (177 . 9506) (178 . 9508) (179 . 9510) (180 . 9512) (181 . 9514) (182 . 9515) (183 . 9517) (184 . 9519) (185 . 9521) (186 . 9523) (187 . 9525) (188 . 9527) (189 . 9529) (190 . 9531) (191 . 9533) (192 . 9535) (193 . 9537) (194 . 9540) (195 . 9542) (196 . 9544) (197 . 9546) (198 . 9547) (199 . 9548) (200 . 9549) (201 . 9550) (202 . 9551) (203 . 9554) (204 . 9557) (205 . 9560) (206 . 9563) (207 . 9566) (208 . 9567) (209 . 9568) (210 . 9569) (211 . 9570) (212 . 9572) (213 . 9574) (214 . 9576) (215 . 9577) (216 . 9578) (217 . 9579) (218 . 9580) (219 . 9581) (220 . 9583) (221 . 9587) (222 . 8491) (223 . 8492))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS *JIS-TO-XCCS-CONV-NO-FONT-TABLE* *JIS-TO-XCCS-CONV-TABLE-LIST* *JIS-TO-XCCS-CODE-MAP* *HANKAKU-TO-ZENKAKU-CODE-MAP* *JIS-1KU-TO-XCCS-CONV-TABLE* *JIS-2KU-TO-XCCS-CONV-TABLE* *JIS-6KU-TO-XCCS-CONV-TABLE* *XCCS-TO-JIS-CONV-TABLE* *HANKAKU-TO-ZENKAKU-CONV-TABLE* *ZENKAKU-TO-HANKAKU-CONV-TABLE*) ) (DEFINEQ (\MAKE.JIS.TO.XCCS.CONV.TABLE [LAMBDA NIL (* ; "Edited 20-Feb-91 19:28 by nm") (* ;;; "The JIS codes which are not equivalent to XCCS reside in 1, 2, 3, 6, 8 and 84 KU. In case of 3 and 84 KU, the corresponding XCCS is calicutated from JIS. In case of 1,2 and 6 KU, we have to prepare conversion tables for each because the mapping between XCCS and JIS are random. 8 KU is treated specially because no displayable font is assigned for 8 KU in XCCS. They are handled with *JIS-TO-XCCS-CONV-NO-FONT-TABLE*.") (* ;;; "Each conversion table is an byte array of size 188 (94 * 2). 94 is a largest number of TEN. TEN is one origin. Each JIS code is represented with two bytes in the table. The first byte is a character set and the second byte is a character code in XCCS. If both of the first byte and the second byte are 255, it means the JIS code is not defined for the entry. If the first byte is 255 and the second byte is 0, it means a JIS code is defined for the entry and there is a XCCS code corresponding to the JIS code, but no displayable font is assigned for the code in XCCS. In the last case, the real XCCS code is found in *JIS-TO-XCCS-CONV-NO-FONT-TABLE*.") (* ;;; "*HANKAKU-TO-ZENKAKU-CONV-TABLE* holds the mapping between JIS HANAKAKU-KANA code to XCCS. XCCS does not support HANKAKU code.") (SETQ *JIS-1KU-TO-XCCS-CONV-TABLE* (ARRAY 188 'BYTE 255)) (SETQ *JIS-2KU-TO-XCCS-CONV-TABLE* (ARRAY 188 'BYTE 255)) (SETQ *JIS-6KU-TO-XCCS-CONV-TABLE* (ARRAY 188 'BYTE 255)) (SETQ *XCCS-TO-JIS-CONV-TABLE* (HASHARRAY 256)) (SETQ *HANKAKU-TO-ZENKAKU-CONV-TABLE* (HASHARRAY 64)) (SETQ *ZENKAKU-TO-HANKAKU-CONV-TABLE* (HASHARRAY 64)) (CL:DO ((TABLES (LIST *JIS-1KU-TO-XCCS-CONV-TABLE* *JIS-2KU-TO-XCCS-CONV-TABLE* *JIS-6KU-TO-XCCS-CONV-TABLE*) (CDR TABLES)) (KU '(1 2 6) (CDR KU)) CODEMAP) ((CL:ENDP TABLES)) (SETQ CODEMAP (CDR (ASSOC (CAR KU) *JIS-TO-XCCS-CODE-MAP*))) (for MAP in CODEMAP do (SETA (CAR TABLES) (IDIFFERENCE (UNFOLD (CAR MAP) 2) 1) (CADR MAP)) (SETA (CAR TABLES) (UNFOLD (CAR MAP) 2) (CDDR MAP)))) (bind KU TEN TABLE for ENTRY in *JIS-TO-XCCS-CONV-NO-FONT-TABLE* do (SETQ KU (IDIFFERENCE (FOLDLO (CAR ENTRY) 256) 32)) (SETQ TABLE (SELECTQ KU (1 *JIS-1KU-TO-XCCS-CONV-TABLE*) (2 *JIS-2KU-TO-XCCS-CONV-TABLE*) (6 *JIS-6KU-TO-XCCS-CONV-TABLE*) NIL)) (AND TABLE (SETA TABLE (UNFOLD (IDIFFERENCE (LOGAND 255 (CAR ENTRY)) 32) 2) 0))) (for MAP in *HANKAKU-TO-ZENKAKU-CODE-MAP* do (PUTHASH (CAR MAP) (CDR MAP) *HANKAKU-TO-ZENKAKU-CONV-TABLE*)) (for MAP in *HANKAKU-TO-ZENKAKU-CODE-MAP* do (PUTHASH (CDR MAP) (CAR MAP) *ZENKAKU-TO-HANKAKU-CONV-TABLE*)) (for MAP in (APPEND [for KU in *JIS-TO-XCCS-CODE-MAP* join (for TEN in (CDR KU) collect `(,(LOGOR (UNFOLD (CADR TEN) 256) (CDDR TEN)) \, (LOGOR (UNFOLD (IPLUS (CAR KU) 32) 256) (IPLUS (CAR TEN) 32] *JIS-TO-XCCS-CONV-NO-FONT-TABLE*) do (PUTHASH (CAR MAP) (CDR MAP) *XCCS-TO-JIS-CONV-TABLE*)) (SETQ *JIS-TO-XCCS-CONV-TABLE-LIST* `((33 \, *JIS-1KU-TO-XCCS-CONV-TABLE*) (34 \, *JIS-2KU-TO-XCCS-CONV-TABLE*) (38 \, *JIS-6KU-TO-XCCS-CONV-TABLE*]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (\MAKE.JIS.TO.XCCS.CONV.TABLE) ) (* ; "JIS to XCCS converter") (RPAQ? *REPLACE-NO-FONT-CODE* T) (RPAQ? *DEFAULT-NOT-CONVERTED-FAT-CODE* 8739) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS *REPLACE-NO-FONT-CODE* *DEFAULT-NOT-CONVERTED-FAT-CODE*) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (PUTPROPS \CONV.JIS.TO.XCCS MACRO [OPENLAMBDA (KU TEN) (* ;;; "Some character code is not equivalent between JIS and XCCS. In such case, we have to convert the character to corresponding XCCS.") (COND ((\NOT.EQUIVALENT.TO.XCCS KU) (\DO.CONV.JIS.TO.XCCS KU TEN)) (T (LOGOR (UNFOLD KU 256) TEN]) (PUTPROPS \DO.CONV.JIS.TO.XCCS MACRO [(KU TEN) (* ;;; " Convert a JIS code divided into KU (high 8 bit) and TEN (low 8 bit) to an corresponding XCCS code.") (COND ((\INVALID.TENP TEN) *DEFAULT-NOT-CONVERTED-FAT-CODE*) (T (SELECTQ KU ((33 34 38) (* ; "1, 2 and 6 KU") [LET* ((CONVTABLE (\EXTARACT.CONV.TABLE KU)) (SET (\EXTRACT.SET TEN CONVTABLE)) (CODE (\EXTRACT.CODE TEN CONVTABLE))) (COND ((NEQ SET 255) (LOGOR (UNFOLD SET 256) CODE)) (T (COND ((EQ CODE 255) (* ; "Not defined in JIS.") *DEFAULT-NOT-CONVERTED-FAT-CODE*) (T (* ;  "Defined in JIS but the displayable font is not assigned in the corresponding code in XCCS.") (COND (*REPLACE-NO-FONT-CODE* *DEFAULT-NOT-CONVERTED-FAT-CODE*) (T (\EXTRACT.NO.FONT.CODE (LOGOR (UNFOLD KU 256) TEN]) (35 (* ; "3 KU") (* ;  "Alpha numeric codes are all defined as single byte codes in XCCS.") TEN) (40 (* ; "8 KU") (COND [(< 0 TEN 33) (COND (*REPLACE-NO-FONT-CODE* *DEFAULT-NOT-CONVERTED-FAT-CODE*) (T (\EXTRACT.NO.FONT.CODE (LOGOR KU TEN] (T *DEFAULT-NOT-CONVERTED-FAT-CODE*))) (116 (* ; "84 KU") (COND ((< 0 TEN 5) (LOGOR 29952 TEN)) (T *DEFAULT-NOT-CONVERTED-FAT-CODE*))) (117 (* ; "85 KU") (COND ((< 0 TEN 28) (LOGOR 29696 TEN)) (T *DEFAULT-NOT-CONVERTED-FAT-CODE*))) *DEFAULT-NOT-CONVERTED-FAT-CODE*]) ) (* "END EXPORTED DEFINITIONS") ) (* ; "XCCS to JIS converter") (DEFINEQ (CONVHANKAKU [LAMBDA ARGS (* ; "Edited 8-Feb-91 13:42 by nm") (PROG1 (STREAMPROP (ARG ARGS 1) :HTOZP) (AND (> ARGS 1) (STREAMPROP (ARG ARGS 1) :HTOZP (ARG ARGS 2))))]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (PUTPROPS \CONV.XCCS.TO.JIS MACRO (OPENLAMBDA (OUTSTREAM CC) (* ;;; "Returns JIS code corresponding to XCCS charcode. Handle HANKAKU as well as ZENKAKU. If OUTSTREAM wants to convert ZENKAKUKANA to HANKAKUKANA, do so. Never returns two byte charcode for alpha-numeric character, they are all treated as single byte characode.") (OR (COND ((\ASCIIP CC) CC) ((\NOT.EQUIVALENT.TO.JIS CC) (\DO.CONV.XCCS.TO.JIS CC)) ((\CONV.HANKAKU.TO.ZENKAKUP OUTSTREAM) (* ;  "ZENKAKUKANA comes here, because their charcodes are equiavalent to JIS.") (\CONV.ZENKAKU.KANA CC)) (T CC)) CC))) (PUTPROPS \DO.CONV.XCCS.TO.JIS MACRO ((CC) (GETHASH CC *XCCS-TO-JIS-CONV-TABLE*))) (PUTPROPS \ASCIIP MACRO (OPENLAMBDA (CC) (AND (EQ (FOLDLO CC 256) 0) (< (LOGAND CC 255) 128)))) (PUTPROPS \NOT.EQUIVALENT.TO.JIS MACRO (OPENLAMBDA (CC) (OR (EQ (FOLDLO CC 256) 0) (EQ (FOLDLO CC 256) 33) (EQ (FOLDLO CC 256) 34) (EQ (FOLDLO CC 256) 38) (EQ (FOLDLO CC 256) 40) (EQ (FOLDLO CC 256) 239) (EQ (FOLDLO CC 256) 241)))) (PUTPROPS \CONV.HANKAKU.TO.ZENKAKUP MACRO ((OUTSTREAM) (STREAMPROP OUTSTREAM :HTOZP))) (PUTPROPS \CONV.ZENKAKU.KANA MACRO ((CHAR) (GETHASH CHAR *ZENKAKU-TO-HANKAKU-CONV-TABLE*))) ) (* "END EXPORTED DEFINITIONS") ) (DEFINEQ (\JISIN [LAMBDA (STREAM COUNTP) (* ; "Edited 25-Feb-91 15:47 by nm") (* ;;; "Returns a 16 bit XCCS code. Assuming the input character stream is encoded with JIS. Allows the incorrect usage of KI and KO based on the two different JIS, OLDJIS and NEWJIS, because it is very likely that these two different sets of KI and KO are used simultaneously, although it is against a standard! ") (* ;;; "If COUNP is non-NIL, the number of bytes read is returned as a second value. Doesn't do EOL conversion -- \INCHAR or \INCCODE do that.") (PROG (CH1 CH2 CH3 (IN16BITFLG (\KIMODEP STREAM T)) (CHARNUM 0)) RETRY (AND (SETQ CH1 (\BIN STREAM)) (COND [(EQ CH1 (CHARCODE ESC)) (* ; "Might be KI or KO.") (SETQ CH2 (\BIN STREAM)) (COND [(EQ CH2 (CHARCODE $)) (* ; "Might be KI") (SETQ CH3 (\BIN STREAM)) (COND ((OR (EQ CH3 (CHARCODE B)) (EQ CH3 (CHARCODE @))) (* ; "KI") (\CHNAGE.KI.MODE STREAM T T) (AND COUNTP (SETQ CHARNUM (IPLUS CHARNUM 3))) (* ; "Here we have to try the same preocedure again, because bogus duplicated KI/KO sequence might come again!") (SETQ IN16BITFLG T) (GO RETRY)) (T (COND [IN16BITFLG (* ; "Under processing 16 bit code.") (\BACKFILEPTR STREAM) (COND [COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) (IPLUS 2 CHARNUM] (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2] (T (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (COND [COUNTP (RETURN (CL:VALUES (CHARCODE ESC) (IPLUS 1 CHARNUM] (T (RETURN (CHARCODE ESC] [(EQ CH2 (CHARCODE %()) (* ; "Might be KO") (SETQ CH3 (\BIN STREAM)) (COND ((OR (EQ CH3 (CHARCODE J)) (EQ CH3 (CHARCODE H))) (* ; "KO") (\CHNAGE.KI.MODE STREAM T NIL) (AND COUNTP (SETQ CHARNUM (IPLUS CHARNUM 3))) (* ;  "Oops. Yes, we have to try again to ignore duplicated KI/KO sequence.") (SETQ IN16BITFLG NIL) (GO RETRY)) (T (COND [IN16BITFLG (* ; "Under processing 16 bit code.") (\BACKFILEPTR STREAM) (COND [COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) (IPLUS 2 CHARNUM] (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2] (T (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (COND [COUNTP (RETURN (CL:VALUES (CHARCODE ESC) (IPLUS 1 CHARNUM] (T (RETURN (CHARCODE ESC] [IN16BITFLG (* ; "Under processing 16 bit code.") (COND [COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) (IPLUS 2 CHARNUM] (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2] (T (\BACKFILEPTR STREAM) (COND [COUNTP (RETURN (CL:VALUES (CHARCODE ESC) (IPLUS 1 CHARNUM] (T (RETURN (CHARCODE ESC] [IN16BITFLG (* ; "Under processing 16 bit code.") (COND [COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS CH1 (\BIN STREAM)) (IPLUS 2 CHARNUM] (T (RETURN (\CONV.JIS.TO.XCCS CH1 (\BIN STREAM] [(\HANKAKUP CH1) (* ; "HANKAKU-KATAKANA is converted to ZENKAKU-KATAKANA because XCCS does not support HANKAKU-KATAKANA.") (COND [COUNTP (RETURN (CL:VALUES (\CONV.HANKAKU.KANA CH1) (IPLUS 1 CHARNUM] (T (RETURN (\CONV.HANKAKU.KANA CH1] (T (* ;; "C0, SP, DEL, C1, 10/0, or 15/15 of 0 character set.") (COND [COUNTP (RETURN (CL:VALUES CH1 (IPLUS 1 CHARNUM] (T (RETURN CH1]) (\JISPEEK [LAMBDA (STREAM NOERROR COUNTP) (* ; "Edited 25-Feb-91 16:27 by nm") (* ;;; "Returns a 16 bit XCCS code. Assuming the input character stream is encoded with JIS. Allows the incorrect usage of KI and KO based on the two different JIS, OLDJIS and NEWJIS, because it is very likely that these two different sets of KI and KO are used simultaneously, although it is against a standard! May actually read the KI or KO. ") (* ;;; "If COUNTP is non-NIL, the number of bytes read is returned as a second value. Doesn't do EOL conversion -- \INCHAR or \INCCODE do that.") (PROG ((IN16BITFLG (\KIMODEP STREAM T)) (CHARNUM 0) (CH1 (\PEEKBIN STREAM NOERROR)) CH2 CH3) RETRY (COND [(NULL CH1) (COND (COUNTP (RETURN (CL:VALUES NIL CHARNUM))) (T (RETURN NIL] [(EQ CH1 (CHARCODE ESC)) (* ; "Might be KI or KO.") (\BIN STREAM) (* ; "Consume the first ESC.") (SETQ CH2 (\PEEKBIN STREAM NOERROR)) (COND [(NULL CH2) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES NIL CHARNUM))) (T (RETURN NIL] [(EQ CH2 (CHARCODE $)) (* ; "Might be KI") (\BIN STREAM) (* ; "Consume the $.") (SETQ CH3 (\PEEKBIN STREAM NOERROR)) (COND [(NULL CH3) (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES NIL CHARNUM))) (T (RETURN NIL] ((OR (EQ CH3 (CHARCODE B)) (EQ CH3 (CHARCODE @))) (* ; "KI") (\CHNAGE.KI.MODE STREAM T T) (AND COUNTP (SETQ CHARNUM (IPLUS CHARNUM 3))) (\BIN STREAM) (* ; "Consume the B or @.") (SETQ IN16BITFLG T) (GO RETRY)) (T (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (COND [IN16BITFLG (* ; "Under processing 16 bit code.") (COND (COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) CHARNUM))) (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2] (T (COND (COUNTP (RETURN (CL:VALUES (CHARCODE ESC) CHARNUM))) (T (RETURN (CHARCODE ESC] [(EQ CH2 (CHARCODE %()) (* ; "Might be KO") (\BIN STREAM) (* ; "Consume the (.") (SETQ CH3 (\PEEKBIN STREAM NOERROR)) (COND [(NULL CH3) (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES NIL CHARNUM))) (T (RETURN NIL] ((OR (EQ CH3 (CHARCODE J)) (EQ CH3 (CHARCODE H))) (* ; "KO") (\CHNAGE.KI.MODE STREAM T NIL) (AND COUNTP (SETQ CHARNUM 3)) (\BIN STREAM) (* ; "Consume the J or H.") (SETQ IN16BITFLG NIL) (GO RETRY)) (T (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (COND [IN16BITFLG (* ; "Under processing 16 bit code.") (COND (COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) CHARNUM))) (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2] (T (COND (COUNTP (RETURN (CL:VALUES (CHARCODE ESC) CHARNUM))) (T (RETURN (CHARCODE ESC] [IN16BITFLG (* ; "Under processing 16 bit code.") (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) CHARNUM))) (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2] (T (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES (CHARCODE ESC) CHARNUM))) (T (RETURN (CHARCODE ESC] [IN16BITFLG (* ; "Under processing 16 bit code.") (\BIN STREAM) (* ; "Consume the first byte.") (SETQ CH2 (\PEEKBIN STREAM NOERROR)) (\BACKFILEPTR STREAM) (COND [CH2 (COND (COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) CHARNUM))) (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2] (T (COND (COUNTP (RETURN (CL:VALUES NIL CHARNUM))) (T (RETURN NIL] [(\HANKAKUP CH1) (* ; "HANKAKU-KATAKANA is converted to ZENKAKU-KATAKANA because XCCS does not support HANKAKU-KATAKANA.") (COND (COUNTP (RETURN (CL:VALUES (\CONV.HANKAKU.KANA CH1) CHARNUM))) (T (RETURN (\CONV.HANKAKU.KANA CH1] (T (* ;; "C0, SP, DEL, C1, 10/0, or 15/15 of 0 character set.") (COND (COUNTP (RETURN (CL:VALUES CH1 CHARNUM))) (T (RETURN CH1]) (\BACKJISCHAR [LAMBDA (STREAM COUNTP) (* ; "Edited 25-Feb-91 17:05 by nm") (COND ((\BACKFILEPTR STREAM) (COND [(\KIMODEP STREAM T) (COND ((\BACKFILEPTR STREAM) (AND COUNTP 2)) (T (AND COUNTP 1] (COUNTP 1))) (COUNTP 0]) (\SHIFTJISIN [LAMBDA (STREAM COUNTP) (* ; "Edited 25-Feb-91 15:49 by nm") (* ;;; "Returns a 16 bit XCCS code. Assuming the input character stream is encoded with Shift-JIS. If COUNP is non-NIL, the number of bytes read is returned as a second value. Doesn't do EOL conversion -- \INCHAR or \INCCODE do that..") (LET ((CH1 (\BIN STREAM)) CH2) (AND CH1 (COND [(\SJIS.KANJI.FIRST.BYTEP CH1) (* ;  "Read next byte and compose a kanji character.") (\CONV.SJIS.TO.JIS CH1 (\BIN STREAM)) (* ;  "CH1 and CH2 is adjusted to represent JIS code in \CONV.SJIS.TO.JIS.") (COND (COUNTP (CL:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) 2)) (T (\CONV.JIS.TO.XCCS CH1 CH2] (T (* ; "ASCII or HANKAKU-KATAKANA") (COND [(\HANKAKUP CH1) (* ; "HANKAKU-KATAKANA") (COND (COUNTP (CL:VALUES (\CONV.HANKAKU.KANA CH1) 1)) (T (\CONV.HANKAKU.KANA CH1] (T (* ; "ASCII") (COND (COUNTP (CL:VALUES CH1 1)) (T CH1]) (\SHIFTJISPEEK [LAMBDA (STREAM NOERROR COUNTP) (* ; "Edited 25-Feb-91 16:30 by nm") (* ;;; "Returns a 16 bit XCCS code. Assuming the input character stream is encoded with Shift-JIS. Doesn't do EOL conversion -- \INCHAR or \INCCODE do that.") (PROG ((CH1 (\PEEKBIN STREAM NOERROR)) CH2) (COND [(NULL CH1) (COND (COUNTP (RETURN (CL:VALUES NIL 0))) (T (RETURN NIL] [(\SJIS.KANJI.FIRST.BYTEP CH1) (* ;  "Read next byte and compose a kanji character.") (\BIN STREAM) (* ; "Consume the first byte.") [COND ((NULL (SETQ CH2 (\PEEKBIN STREAM NOERROR))) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES NIL 0))) (T (RETURN NIL] (\BACKFILEPTR STREAM) (\CONV.SJIS.TO.JIS CH1 CH2) (* ;  "CH1 and CH2 is adjusted to represent JIS code in \CONV.SJIS.TO.JIS.") (COND (COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) 0))) (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2] (T (* ; "ASCII or HANKAKU-KATAKANA") (RETURN (COND [(\HANKAKUP CH1) (* ; "HANKAKU-KATAKANA") (COND (COUNTP (RETURN (CL:VALUES (\CONV.HANKAKU.KANA CH1) 0))) (T (RETURN (\CONV.HANKAKU.KANA CH1] (T (* ; "ASCII") (COND (COUNTP (RETURN (CL:VALUES CH1 0))) (T (RETURN CH1]) (\BACKSHIFTJISCHAR [LAMBDA (STREAM COUNTP) (* ; "Edited 25-Feb-91 17:05 by nm") (COND ((\BACKFILEPTR STREAM) (COND [(\BACKFILEPTR STREAM) (COND ((\SJIS.KANJI.FIRST.BYTEP (\PEEKBIN STREAM)) (AND COUNTP 2)) (T (\BIN STREAM) (AND COUNTP 1] (COUNTP 1))) (COUNTP 0]) (\EUCIN [LAMBDA (STREAM COUNTP) (* ; "Edited 25-Feb-91 15:54 by nm") (* ;;; "Returns a 16 bit XCCS code. Assuming the input character stream is encoded with EUC (Extended Unix Codes). Although EUC is independent of a particular language, the language implemented here is Japanese, thus this should be called as UJIS (Unixnized extended JIS code). JEIDA uses EUC as UJIS. ") (* ;;; "If COUNP is non-NIL, the number of bytes read is returned as a second value. Doesn't do EOL conversion -- \INCHAR or \INCCODE do that.") (LET ((CH1 (\BIN STREAM)) CH2) (AND CH1 (COND [(\EUC.KANJI.FIRST.BYTEP CH1) (* ;  "Read next byte and compose a kanji character.") (COND (COUNTP (CL:VALUES (\CONV.JIS.TO.XCCS (LOGAND CH1 127) (LOGAND (\BIN STREAM) 127)) 2)) (T (\CONV.JIS.TO.XCCS (LOGAND CH1 127) (LOGAND (\BIN STREAM) 127] [(\EUC.HANKAKUP CH1) (COND (COUNTP (CL:VALUES (\CONV.HANKAKU.KANA (\BIN STREAM)) 2)) (T (\CONV.HANKAKU.KANA (\BIN STREAM] [(\GAIJIP CH1) (COND (COUNTP (CL:VALUES (\CONV.JIS.TO.XCCS (LOGAND (\BIN STREAM) 127) (LOGAND (\BIN STREAM) 127)) 3)) (T (\CONV.JIS.TO.XCCS (LOGAND (\BIN STREAM) 127) (LOGAND (\BIN STREAM) 127] (T (* ; "ASCII, C0, C1, SP or DEL") (COND (COUNTP (CL:VALUES CH1 1)) (T CH1]) (\EUCPEEK [LAMBDA (STREAM NOERROR COUNTP) (* ; "Edited 25-Feb-91 16:35 by nm") (* ;;; "Returns a 16 bit XCCS code. Assuming the input character stream is encoded with EUC (Extended Unix Codes). Although EUC is independent of a particular language, the language implemented here is Japanese, thus this should be called as UJIS (Unixnized extended JIS code). JEIDA uses EUC as UJIS. Doesn't do EOL conversion -- \INCHAR or \INCCODE do that.") (PROG ((CH1 (\PEEKBIN STREAM NOERROR)) CH2) (COND [(NULL CH1) (COND (COUNTP (RETURN (CL:VALUES NIL 0))) (T (RETURN NIL] [(\EUC.KANJI.FIRST.BYTEP CH1) (* ;  "Read next byte and compose a kanji character.") (\BIN STREAM) (* ; "Consume the first byte.") [COND ((NULL (SETQ CH2 (\PEEKBIN STREAM NOERROR))) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES NIL 0))) (T (RETURN NIL] (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS (LOGAND CH1 127) (LOGAND CH2 127)) 0))) (T (RETURN (\CONV.JIS.TO.XCCS (LOGAND CH1 127) (LOGAND CH2 127] [(\EUC.HANKAKUP CH1) (\BIN STREAM) (* ; "Consume the SS2.") [COND ((NULL (SETQ CH2 (\PEEKBIN STREAM NOERROR))) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES NIL 0))) (T (RETURN NIL] (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES (\CONV.HANKAKU.KANA CH2) 0))) (T (RETURN (\CONV.HANKAKU.KANA CH2] [(\GAIJIP CH1) (\BIN STREAM) (* ; "Consume the SS3.") [COND ((NULL (SETQ CH1 (\PEEKBIN STREAM NOERROR))) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES NIL 0))) (T (RETURN NIL] (\BIN STREAM) (* ;  "Consume the first byte in GAIJI.") [COND ((NULL (SETQ CH2 (\PEEKBIN STREAM NOERROR))) (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES NIL 0))) (T (RETURN NIL] (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS (LOGAND CH1 127) (LOGAND CH2 127)) 0))) (T (RETURN (\CONV.JIS.TO.XCCS (LOGAND CH1 127) (LOGAND CH2 127] (T (* ; "ASCII, C0, C1, SP or DEL") (COND (COUNTP (RETURN (CL:VALUES CH1 0))) (T (RETURN CH1]) (\BACKEUCCHAR [LAMBDA (STREAM COUNTP) (* ; "Edited 25-Feb-91 17:06 by nm") (COND ((\BACKFILEPTR STREAM) (COND ((BITTEST (\PEEKBIN STREAM) (MASK.1'S 7 1)) (* ; "C1, KAINJI, HANKAKU or GAIJI") (COND [(\BACKFILEPTR STREAM) (COND ((\EUC.HANKAKUP (\PEEKBIN STREAM)) (AND COUNTP 2)) ((BITTEST (\PEEKBIN STREAM) (MASK.1'S 7 1)) (* ; "KANJI or GAIJI") (COND [(\BACKFILEPTR STREAM) (COND ((\GAIJIP (\PEEKBIN STREAM)) (AND COUNTP 3)) (T (* ; "KANJI") (\BIN STREAM) (AND COUNTP 2] (COUNTP 2))) (T (* ; "C1") (\BIN STREAM) (AND COUNTP 1] (COUNTP 1))) (COUNTP 1))) (COUNTP 0]) (\THROUGHIN [LAMBDA (STREAM COUNTP) (* ; "Edited 26-Feb-91 13:36 by nm") (* ;;; "Read in a single byte from STREAM and returns it without any character conversion, just through as if.") (* ;;; "If COUNP is non-NIL, always 1 is returned as the second value.") (COND (COUNTP (CL:VALUES (\BIN STREAM) 1)) (T (\BIN STREAM]) (\THROUGHPEEK [LAMBDA (STREAM NOERROR COUNTP) (* ; "Edited 26-Feb-91 13:40 by nm") (* ;;; "Returns a 8 bit code without any character conversion, just through as if.") (* ;;; "If COUNTP is non-NIL, always 0 is returned as its second value.") (COND (COUNTP (CL:VALUES (\PEEKBIN STREAM NOERROR) 0)) (T (\PEEKBIN STREAM NOERROR]) (\BACKTHROUGHCHAR [LAMBDA (STREAM COUNTP) (* ; "Edited 26-Feb-91 13:43 by nm") (COND ((\BACKFILEPTR STREAM) 1) (COUNTP 0]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (PUTPROPS \XCCSIN MACRO [(STREAM SHIFTEDCSET SHIFTEDCSETVAR COUNTERVAR) (* ;;; "returns a 16 bit character code. SHIFTEDCSET is STREAM's char set left shifted 8, SHIFTEDCSETVAR if non-NIL is the variable to set if char set changes. COUNTERVAR if non-NIL is decremented by number of bytes read. Doesn't do EOL conversion -- \INCHAR and \INCCODE do that.") (LET ((CHAR (\BIN STREAM)) SCSET) (COND [(EQ CHAR NSCHARSETSHIFT) (* ; "Shifting character sets") [ACCESS-CHARSET STREAM (SETQ SCSET (COND ((NEQ NSCHARSETSHIFT (SETQ CHAR (\BIN STREAM))) (AND 'COUNTERVAR (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR 2))) CHAR) ((PROGN (* ;  "2 shift-bytes means not run-encoded") (AND 'COUNTERVAR (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR 3))) (EQ 0 (\BIN STREAM))) \NORUNCODE) (T (\NSIN.24BITENCODING.ERROR STREAM] (SETQ CHAR (\BIN STREAM)) (SETQ SCSET (COND ('SHIFTEDCSETVAR (* ; "CHARSETVAR=NIL means don't set") (SETQ SHIFTEDCSETVAR (UNFOLD SCSET 256))) (T (UNFOLD SCSET 256] (T (SETQ SCSET SHIFTEDCSET))) (COND ((EQ SCSET (UNFOLD \NORUNCODE 256)) (* ;  "just read two bytes and combine them to a 16 bit value") (AND 'COUNTERVAR (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR 2 ))) (LOGOR (UNFOLD CHAR 256) (\BIN STREAM))) (CHAR (AND 'COUNTERVAR (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR 1) )) (AND CHAR (LOGOR SCSET CHAR]) (PUTPROPS \XCCSPEEK MACRO [(STREAM SHIFTEDCSET SHIFTEDCSETVAR NOERROR COUNTERVAR) (* ;; "Returns a 16 bit character code. Doesn't do EOL conversion--\INCHAR does that. May actually read the character-set shift, storing the result in the stream. COUNTERVAR, if given, is updated to reflect any such bytes that are actually read") (PROG ((CHAR (\PEEKBIN STREAM NOERROR)) SCSET) (COND ((NULL CHAR) (RETURN NIL)) [(EQ CHAR NSCHARSETSHIFT) (* ; "CHARSETVAR=NIL means don't set") (\BIN STREAM) (* ; "Consume the char shift byte") [ACCESS-CHARSET STREAM (SETQ SCSET (COND ((NEQ NSCHARSETSHIFT (SETQ CHAR (\BIN STREAM))) (* ;  "Note: no eof error check on this \BIN -- an eof in the middle of a charset shift is an error") (AND 'COUNTERVAR (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR 2)) ) CHAR) ((PROGN (* ;  "2 shift-bytes means not run-encoded") (AND 'COUNTERVAR (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR 3) )) (EQ 0 (\BIN STREAM))) \NORUNCODE) (T (\NSIN.24BITENCODING.ERROR STREAM] [SETQ SCSET (COND ('SHIFTEDCSETVAR (* ; "CHARSETVAR=NIL means don't set") (SETQ SHIFTEDCSETVAR (UNFOLD SCSET 256))) (T (UNFOLD SCSET 256] (COND ((NULL (SETQ CHAR (\PEEKBIN STREAM NOERROR))) (RETURN NIL] (T (SETQ SCSET SHIFTEDCSET))) (RETURN (COND ((EQ SCSET (UNFOLD \NORUNCODE 256)) (* ;; "just peek two bytes and combine them to a 16 bit value. Again, is an error if we hit eof in mid-character") (\BIN STREAM) (PROG1 (LOGOR (UNFOLD CHAR 256) (\PEEKBIN STREAM NOERROR)) (\BACKFILEPTR STREAM))) (T (LOGOR SHIFTEDCSET CHAR]) (PUTPROPS \BACKXCCSCHAR MACRO [(STREAM SHIFTEDCHARSET COUNTERVAR) (AND (\BACKFILEPTR STREAM) (COND [[COND (SHIFTEDCHARSET (EQ SHIFTEDCHARSET (UNFOLD \NORUNCODE 256))) (T (EQ \NORUNCODE (ACCESS-CHARSET STREAM] (COND ((\BACKFILEPTR STREAM) (AND 'COUNTERVAR (add COUNTERVAR 2)) T) ('COUNTERVAR (add COUNTERVAR 1] ('COUNTERVAR (add COUNTERVAR 1]) (PUTPROPS \XCCSP MACRO [OPENLAMBDA (ST) (NOT (ffetch (STREAM NOTXCCS) of (\DTEST ST 'STREAM]) ) (DECLARE%: EVAL@COMPILE (PUTPROPS \EXTRACT.NO.FONT.CODE MACRO ((JISCODE) (CDR (ASSOC JISCODE *JIS-TO-XCCS-CONV-NO-FONT-TABLE*)) )) (PUTPROPS \EXTARACT.CONV.TABLE MACRO ((KU) (CDR (ASSOC KU *JIS-TO-XCCS-CONV-TABLE-LIST*)))) (PUTPROPS \NOT.EQUIVALENT.TO.XCCS MACRO ((KU) (* ;;; " The JIS codes which are not equiavelent to XCCS reside in 1, 2, 3, 6, 8 and 84 KU. Although from 84-5 to 94-94 inclusive are not defined in JIS, that is they are GAIJI, they are also handled here.") (OR (EQ KU 33) (EQ KU 34) (EQ KU 35) (EQ KU 38) (EQ KU 40) (EQ KU 116) (EQ KU 117)))) (PUTPROPS \EXTRACT.SET MACRO ((TEN TABLE) (ELT TABLE (IDIFFERENCE (UNFOLD (IDIFFERENCE TEN 32) 2) 1)))) (PUTPROPS \EXTRACT.CODE MACRO ((TEN TABLE) (ELT TABLE (UNFOLD (IDIFFERENCE TEN 32) 2)))) (PUTPROPS \CHNAGE.KI.MODE MACRO [OPENLAMBDA (ST INPUTFLG ENTERP) (* ;;; "INPUTFLG is true if \CHNAGE.KI.MODE is called in the context in which ST is an input stream.") (COND [INPUTFLG (COND (ENTERP (freplace (STREAM IN.KANJIIN) of (\DTEST ST 'STREAM) with T)) (T (freplace (STREAM IN.KANJIIN) of (\DTEST ST 'STREAM) with NIL] (T (COND (ENTERP (freplace (STREAM OUT.KANJIIN) of (\DTEST ST 'STREAM) with T)) (T (freplace (STREAM OUT.KANJIIN) of (\DTEST ST 'STREAM) with NIL]) (PUTPROPS \KIMODEP MACRO [OPENLAMBDA (ST INPUTFLG) (* ;;; "INPUTFLG is true if \KIMODEP is called in the context in which ST is an input stream.") (COND [INPUTFLG (ffetch (STREAM IN.KANJIIN) of (\DTEST ST 'STREAM] (T (ffetch (STREAM OUT.KANJIIN) of (\DTEST ST 'STREAM]) (PUTPROPS \HANKAKUP MACRO ((CHAR) (< 160 CHAR 224))) (PUTPROPS \KANJIP MACRO ((CHAR) (< 12158 CHAR 29733))) (PUTPROPS \NOTGAIJIP MACRO ((CHAR) (OR (< 8480 CHAR 10305) (< 12158 CHAR 29733)))) (PUTPROPS \INVALID.TENP MACRO (OPENLAMBDA (TEN) (OR (< TEN 33) (< 126 TEN)))) (PUTPROPS \CONV.HANKAKU.KANA MACRO ((CHAR) (GETHASH CHAR *HANKAKU-TO-ZENKAKU-CONV-TABLE*))) (PUTPROPS \OUTKI MACRO ((STREAM) (\BOUT OUTSTREAM (CHARCODE ESC)) (\BOUT OUTSTREAM (CHARCODE $)) (\BOUT OUTSTREAM (CHARCODE B)))) (PUTPROPS \OUTKO MACRO ((STREAM) (\BOUT OUTSTREAM (CHARCODE ESC)) (\BOUT OUTSTREAM (CHARCODE %()) (\BOUT OUTSTREAM (CHARCODE J)))) ) (DECLARE%: EVAL@COMPILE (PUTPROPS \CONV.SJIS.TO.JIS MACRO [OPENLAMBDA (HI LO) (* ;;; "Convert Shift-JIS to JIS. The variable named CH1 and CH2 are set to the converted hight 8 bit and low 8bit of JIS code respectively.") [SETQ CH1 (IDIFFERENCE HI (COND ((> HI 159) 177) (T 113] (SETQ CH1 (IPLUS (UNFOLD CH1 2) 1)) (SETQ CH2 (COND [(> LO 158) (PROG1 (IDIFFERENCE LO 126) (SETQ CH1 (IPLUS CH1 1)))] (T (IDIFFERENCE LO (COND ((> LO 126) (IPLUS 31 1)) (T 31]) (PUTPROPS \CONV.JIS.TO.SJIS MACRO [OPENLAMBDA (HI LO) (* ;;; "Convert JIS to Shift-JIS. The variable named CH1 and CH2 are set to the converted hight 8 bit and low 8bit of Shift-JIS code respectively.") [SETQ CH2 (COND ((ODDP HI) (SETQ CH2 (IPLUS LO 31)) (COND ((>= CH2 127) (IPLUS CH2 1)) (T CH2))) (T (IPLUS LO 126] (SETQ CH1 (IPLUS (FOLDLO (IDIFFERENCE HI 33) 2) 129)) (AND (> CH1 159) (SETQ CH1 (IPLUS CH1 64]) (PUTPROPS \SJIS.KANJI.FIRST.BYTEP MACRO (OPENLAMBDA (CHAR) (OR (< 127 CHAR 160) (< 223 CHAR 256)))) ) (DECLARE%: EVAL@COMPILE (PUTPROPS \EUC.KANJI.FIRST.BYTEP MACRO ((CHAR) (< 160 CHAR 255))) (PUTPROPS \GAIJIP MACRO ((CHAR) (EQ CHAR 143))) (PUTPROPS \EUC.HANKAKUP MACRO ((CHAR) (EQ CHAR 142))) ) (* "END EXPORTED DEFINITIONS") ) (RPAQ? *SIGNAL-24BIT-NSENCODING-ERROR* ) (RPAQ? *READ-NEWLINE-SUPPRESS* ) (RPAQ? \RefillBufferFn (FUNCTION \READCREFILL)) (* ; "Top level val of \RefillBufferFn means act like READC--we must be doing a raw BIN (or PEEKBIN?)") (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA CONVHANKAKU CL:PARSE-INTEGER CL:READ-DELIMITED-LIST CL:READ-PRESERVING-WHITESPACE CL:READ) ) (PUTPROPS LLREAD COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1990 1991 1993 2021)) (DECLARE%: DONTCOPY (FILEMAP (NIL (6807 17343 (LASTC 6817 . 7947) (PEEKC 7949 . 8337) (PEEKCCODE 8339 . 8628) (RATOM 8630 . 9711) (READ 9713 . 10273) (READC 10275 . 10692) (READCCODE 10694 . 11110) (READP 11112 . 11664) ( SETREADMACROFLG 11666 . 11965) (SKIPSEPRCODES 11967 . 13312) (SKIPSEPRS 13314 . 14571) ( \NSIN.24BITENCODING.ERROR 14573 . 15392) (SKREAD 15394 . 17341)) (17389 26064 (CL:READ 17399 . 17948) (CL:READ-PRESERVING-WHITESPACE 17950 . 18672) (CL:READ-DELIMITED-LIST 18674 . 19589) (CL:PARSE-INTEGER 19591 . 26062)) (26157 40130 (RSTRING 26167 . 26899) (READ-EXTENDED-TOKEN 26901 . 31462) (\RSTRING2 31464 . 40128)) (40166 72483 (\TOP-LEVEL-READ 40176 . 42159) (\SUBREAD 42161 . 68899) (\SUBREADCONCAT 68901 . 69524) (\ORIG-READ.SYMBOL 69526 . 70594) (\ORIG-INVALID.SYMBOL 70596 . 71495) (\APPLYREADMACRO 71497 . 71913) (INREADMACROP 71915 . 72481)) (72642 72817 (READQUOTE 72652 . 72815)) (72842 84746 ( READVBAR 72852 . 74183) (READHASHMACRO 74185 . 79995) (DEFMACRO-LAMBDA-LIST-KEYWORD-P 79997 . 80217) ( DIGITBASEP 80219 . 80953) (READNUMBERINBASE 80955 . 82841) (ESTIMATE-DIMENSIONALITY 82843 . 83168) ( SKIP.HASH.COMMENT 83170 . 84138) (CMLREAD.FEATURE.PARSER 84140 . 84744)) (84790 91323 (CHARACTER.READ 84800 . 86054) (CHARCODE.DECODE 86056 . 91321)) (111533 116749 (\MAKE.JIS.TO.XCCS.CONV.TABLE 111543 . 116747)) (120665 120984 (CONVHANKAKU 120675 . 120982)) (123955 149095 (\JISIN 123965 . 129666) ( \JISPEEK 129668 . 136294) (\BACKJISCHAR 136296 . 136665) (\SHIFTJISIN 136667 . 138306) (\SHIFTJISPEEK 138308 . 140414) (\BACKSHIFTJISCHAR 140416 . 140846) (\EUCIN 140848 . 143239) (\EUCPEEK 143241 . 146820) (\BACKEUCCHAR 146822 . 148065) (\THROUGHIN 148067 . 148482) (\THROUGHPEEK 148484 . 148898) ( \BACKTHROUGHCHAR 148900 . 149093))))) STOP \ No newline at end of file diff --git a/sources/LLREAD.LCOM b/sources/LLREAD.LCOM index 29f65a71372a24d92d25a936a253b3f754e89171..72a179204934c1da361498c7b98766efd2bcdda1 100644 GIT binary patch delta 1049 zcmbtS&ui0Q7`9!NS;>$gQgrG|VAyuH=1cRlj+(4Z*Rr%JP3AmojM|2+YqplQ6NX6f z=1F7`bzYRAce{D;)`KS%m4P>R^B*W)ybLi}Hn$FM3w-4Jp7(j5=Y2lD?eBf>zx6%N zv=AQ>YxNLGkO)W=rO7BlIQa2mb+J}9^b%B;00-<|LY=rjI@!?cjaa2nGYU&Fxmqk3 zu|>UP=qr&h9h)mRL(VDIs4mxwdLt&wc}Yx!Z$tus_ZSgT#77Z_L+egm|7V32=L<`7 zdSf^W(|J|Pr?cZElr8_vt_eVL*)Tv|vE-X@ST7t7<4`Izt#SY36G3mW9P!!c6=h8PwxH0V2|v!wN9$iT{W-=hS$7GmHWw#FmJdO z(tJ)`xj=oe8{eH#s9o2Oo>|5zGv*c*bhXVL>hi$M!+x99nV&u1nTnczIvZvLhwpWM zqqAH`C{+}0V7#FcDZ)a10P0YWGO(`rUkQ_kbF5P}9# zmX-J(!1Hu3gXh>@0z-nDQYPg@Rs$}=!}ORKpRnIvPRj$!Q$2tO7?w9RX1&FLyznUHQ-JDS=@Io^_;NauiK5lFW+DW4VPq>|5wmWyS16tX&xLWpu?IfC6+WjSJR N>j4(=n=97%g5YD>cFK8nOO%o&C>Ev?Nog2r-dhOToX>#->C0whJ!T4FQ^fsAz|>#8EaO2`t7*Py{j?0PMzuYoGX zAh#L>;H@n;S67&*cyeyB*MKBR0@UVKm@F?m7?3qxRdqQoMEQxFX&D*UAij}hooVz( z?(oPX`Wugd98V}Q4bIHZEuO6}1HaOIS%---aXqjs#+1!Cwnx9cCegdsfaB@2*D-zf z`Z(eYBX1uyU)#@gN^XPO;B_h=_v8Y$#dGyOOb`+5f#yorNcuqOomPSByAa!QRr`s z(W_ECvUPOlj`SGE{X_qHMHsl9da93o+mRpWF*LzIr)C}xgWpG< zIoH|P=6h|c&~5k&hGKEq0V?U{#|Ilc-o0~g?Ia_xL1g& zs7!KK>1kzb@aqqs471wv)g$dw)AWK;l%`X?{DGdCuIlYnZNbq8H@E*i)^>(I>&2a+ zTQOF$p^EDY^k&`NA6Z5TwgWct^1a0Y86}fIEX&F414*1bn32Tt!Gu^Gyu34OWs5#w zRfS5LWD4PJlzbNw7#{%oft>)|Qa9HTFa?9yOftp}F>92Wr{Vi3#*DULmH@|NV4U_1 pw@9p<medley3.5>sources>UFS.;2 69364 +(FILECREATED "21-Apr-2021 11:36:54" {DSK}kaplan>Local>medley3.5>git-medley>sources>UFS.;5 69271 - changes to%: (VARS UFSCOMS) + changes to%: (FNS \UFSeol) - previous date%: "29-Mar-95 17:50:11" {DSK}medley3.5>sources>UFS.;1) + previous date%: "20-Apr-2021 12:11:36" +{DSK}kaplan>Local>medley3.5>git-medley>sources>UFS.;4) (* ; " -Copyright (c) 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 2000 by Venue & Xerox Corporation. All rights reserved. +Copyright (c) 1988-1995, 2000, 2021 by Venue & Xerox Corporation. ") (PRETTYCOMPRINT UFSCOMS) -(RPAQQ UFSCOMS +(RPAQQ UFSCOMS [(PROP (FILETYPE MAKEFILE-ENVIRONMENT) UFS) (DECLARE%: EVAL@COMPILE DONTEVAL@LOAD DONTCOPY (FILES (LOADCOMP) DIRECTORY FILEIO)) - (COMS (* ; "Create FDEV function.") + (INITVARS (\UFS.DEFAULT.EOLC NIL)) + (COMS (* ; "Create FDEV function.") (FNS \UFSCreateDevice \UFS.CREATE.DEVICE \UFSOpenDevice \UFSCloseDevice) (INITVARS (\UFSdevice) (\UFStopMonitor (CREATE.MONITORLOCK "UFSTopMonitor"))) @@ -25,15 +27,15 @@ Copyright (c) 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 2000 by Venue & Xe (COMS (DECLARE%: DONTCOPY (EXPORT (RECORDS UFSGENFILESTATE))) (INITRECORDS UFSGENFILESTATE) (SYSRECORDS UFSGENFILESTATE)) - (COMS (* ; - "UNIX File System's FDEV methods.") + (COMS (* ; + "UNIX File System's FDEV methods.") (FNS \UFSOpenFile \UFS.OPENP \UFS.RECOGNIZE.FILE \UFS.DIRECTORY.NAME \UFSCloseFile \UFSGetFileName \UFSDeleteFile \UFSRenameFile \UFSReadPages \UFSWritePages \UFSTruncateFile \UFSDirectoryNameP \UFSEventFn \UFSGetFileInfo \UFS.CREATE.PROPS \UFSSetFileInfo \UFSGenerateFiles \UFS.NEXTFILEFN \UFS.FILEINFOFN \UFS.VALID.PROPP \UFS.REGISTER.GFS \UFS.UNREGISTER.GFS \UFS.ABORT.DIRECTORY \UFS.ABORT.CL-DIRECTORY \UFS.CLEANUP.GFS.TABLE)) - (COMS (* ; "File Name parsing") + (COMS (* ; "File Name parsing") (FNS \UFSMakeUnixFormatName \UFSParseNameString \UFSParse-Directory \UFS.PARSE.BODY \UFS.ADJUST.HOST \UFS.FULLNAME \UFS.ADD.HOST.FIELD \UFS.REMOVE.HOST.FIELD \UFS.HANDLE.RELATIVEDIRECTORY) @@ -54,22 +56,22 @@ Copyright (c) 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 2000 by Venue & Xe \UFS.DEFAULT.DIRECTORY *DSK-UPPER-CASE-FILE-NAMES* \UFS.GFS.TABLE *DSK-HOST-NAME* *UFS-HOST-NAME*)) (COMS - (* ;; "Change UNIX Curent Directory") + (* ;; "Change UNIX Curent Directory") (FNS CHDIR) - (* ;; "To access UNIX special files by like {UNIX}/dev/ttya.") + (* ;; "To access UNIX special files by like {UNIX}/dev/ttya.") (FNS \DEVICEFILE.EOSERROR) - (* ;; "flush/revalidate unvisible stream, like dribble files.") + (* ;; "flush/revalidate unvisible stream, like dribble files.") (FNS \UNVISIBLE.PAGED.REVALIDATEFILELST \UNVISIBLE.FLUSH.OPEN.STREAMS) - (* ;; " Error handler") + (* ;; " Error handler") (FNS \UFSError)) - (COMS (* ; "File Type and EOL handling") + (COMS (* ; "File Type and EOL handling") (FNS \UFSGetFileType \UFSSetFileType \UFSeol) [DECLARE%: DONTEVAL@LOAD DOCOPY (VARS (DEFAULTFILETYPE 'BINARY) (DEFAULTFILETYPELIST '((NIL . BINARY) @@ -108,26 +110,28 @@ Copyright (c) 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 2000 by Venue & Xe (VM . BINARY] (GLOBALVARS DEFAULTFILETYPE DEFAULTFILETYPELIST)) (DECLARE%: EVAL@COMPILE DONTCOPY (COMS * UFSDECLS)) - (COMS (* ; "Filetypepatch functions. ") + (COMS (* ; "Filetypepatch functions. ") (FNS \UFSGetPrintFileType \UFSGetFileTypeConfirm \UFSPrintTypeMenu) - (* ; "for hardcopy") + (* ; "for hardcopy") (FNS \UFStoOtherCopyMess \UFStoOtherRenameMess) - (* ; "for copyfile,renamefile") + (* ; "for copyfile,renamefile") (INITVARS (FileTypeConfirmFlg T)) (GLOBALVARS FileTypeMenu FileTypeConfirmFlg)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) -(PUTPROPS UFS FILETYPE :BCOMPL) +(PUTPROPS UFS FILETYPE :BCOMPL) -(PUTPROPS UFS MAKEFILE-ENVIRONMENT (:PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10)) +(PUTPROPS UFS MAKEFILE-ENVIRONMENT (:PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10)) (DECLARE%: EVAL@COMPILE DONTEVAL@LOAD DONTCOPY (FILESLOAD (LOADCOMP) DIRECTORY FILEIO) ) +(RPAQ? \UFS.DEFAULT.EOLC NIL) + (* ; "Create FDEV function.") @@ -154,12 +158,12 @@ Copyright (c) 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 2000 by Venue & Xe (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (DATATYPE UFSGENFILESTATE ( - (* ;; - "Holds the file-directory-generator state for %"Unix%" file system enumeration.") + (* ;; + "Holds the file-directory-generator state for %"Unix%" file system enumeration.") (FINFOID FIXP) - (FILEID FIXP) (* ; - "Current file in list of 1 to TOTALNUM files.") + (FILEID FIXP) (* ; + "Current file in list of 1 to TOTALNUM files.") (TOTALNUM FIXP) DIRECTORY DEV (PROPP FLAG) THISFILE @@ -171,12 +175,12 @@ Copyright (c) 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 2000 by Venue & Xe (PROTECTION FIXP) AUTHOR (AULEN FIXP) - SUBGENERATORS (* ; -"A push-down list of generators for subdirectories. Used to generate to multiple-directory depths.") - CURRENT-DEPTH (* ; - "Current depth in the directory tree, so we can obey FILING.ENUMERATION.DEPTH") - MAX-DEPTH (* ; - "Value of FILING.ENUMERATION.DEPTH we were started with, so we can obey it.") + SUBGENERATORS (* ; +"A push-down list of generators for subdirectories. Used to generate to multiple-directory depths.") + CURRENT-DEPTH (* ; + "Current depth in the directory tree, so we can obey FILING.ENUMERATION.DEPTH") + MAX-DEPTH (* ; + "Value of FILING.ENUMERATION.DEPTH we were started with, so we can obey it.") )) ) @@ -409,46 +413,65 @@ update the map") (SETQ PAGES (RESTOREMAP STREAM))) (DELETED (* ; "the file disap (\UFSSetFileType (LAMBDA (FILENAME TYPE) (* ; "Edited 6-Jun-88 13:48 by HH") (LET ((EXTENSION (MKATOM (U-CASE (LISTGET (\UFSParseNameString FILENAME) (QUOTE EXTENSION)))))) (SETQ TYPE (MKATOM (U-CASE TYPE))) (for PAIR in DEFAULTFILETYPELIST bind PAIR finally (RETURN (EQ TYPE (MKATOM (U-CASE DEFAULTFILETYPE)))) do (if (EQUAL EXTENSION (MKATOM (U-CASE (CAR PAIR)))) then (RETURN (EQ TYPE (MKATOM (U-CASE (CDR PAIR))))))))) ) -(\UFSeol (LAMBDA (FILENAME TYPE RECOG) (* ; "Edited 27-Feb-89 16:21 by bvm") (if (AND (SETQ TYPE (SELECTQ (CADR TYPE) (TEXT (QUOTE TEXT)) (NIL NIL) (PROGN (* ; "Anything else reduces to binary") (QUOTE BINARY)))) (EQ RECOG (QUOTE NEW)) (NEQ TYPE (\UFSGetFileType FILENAME))) then (* ; "Warn user that TYPE will not be properly inferred when we next read this file") (PRINTOUT PROMPTWINDOW T "Warning: creating " TYPE " file, but name '" (\UFS.PARSE.BODY (\UFSParseNameString FILENAME)) "' does not have a " TYPE " extension.")) (SELECTQ (OR TYPE (\UFSGetFileType FILENAME)) (TEXT LF.EOLC) (PROGN (* ; "BINARY or unknown") CR.EOLC))) ) +(\UFSeol + [LAMBDA (FILENAME TYPE RECOG) (* ; "Edited 21-Apr-2021 11:36 by rmk:") + (if (AND [SETQ TYPE (SELECTQ (CADR TYPE) + (TEXT 'TEXT) + (NIL NIL) + (PROGN (* ; "Anything else reduces to binary") + 'BINARY] + (EQ RECOG 'NEW) + (NEQ TYPE (\UFSGetFileType FILENAME))) + then (* ; + "Warn user that TYPE will not be properly inferred when we next read this file") + (PRINTOUT PROMPTWINDOW T "Warning: creating " TYPE " file, but name '" + (\UFS.PARSE.BODY (\UFSParseNameString FILENAME)) + "' does not have a " TYPE " extension.")) + (SELECTQ (OR TYPE (\UFSGetFileType FILENAME)) + (TEXT LF.EOLC) + (PROGN (* ; + "BINARY or unknown. RMK: Switch default to LF") + (OR \UFS.DEFAULT.EOLC LF.EOLC]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (RPAQQ DEFAULTFILETYPE BINARY) -(RPAQQ DEFAULTFILETYPELIST ((NIL . BINARY) - (C . TEXT) - (H . TEXT) - (EL . TEXT) - (IM . TEXT) - (LISP . TEXT) - (LSP . TEXT) - (O . BINARY) - (OUT . BINARY) - (LCOM . BINARY) - (DFASL . BINARY) - (DCOM . BINARY) - (SKETCH . BINARY) - (TEDIT . BINARY) - (TED . BINARY) - (DISPLAYFONT . BINARY) - (AC . BINARY) - (WD . BINARY) - (IP . BINARY) - (INTERPRESS . BINARY) - (PRESS . BINARY) - (PSCFONT . BINARY) - (RST . BINARY) - (BIN . BINARY) - (MAIL . BINARY) - (SYSOUT . BINARY) - (SYSOUT.Z . BINARY) - (TAR . BINARY) - (INDEX . BINARY) - (HASH . BINARY) - (NOTEFILE . BINARY) - (Z . BINARY) - (VIRTUALMEM . BINARY) - (VM . BINARY))) +(RPAQQ DEFAULTFILETYPELIST + ((NIL . BINARY) + (C . TEXT) + (H . TEXT) + (EL . TEXT) + (IM . TEXT) + (LISP . TEXT) + (LSP . TEXT) + (O . BINARY) + (OUT . BINARY) + (LCOM . BINARY) + (DFASL . BINARY) + (DCOM . BINARY) + (SKETCH . BINARY) + (TEDIT . BINARY) + (TED . BINARY) + (DISPLAYFONT . BINARY) + (AC . BINARY) + (WD . BINARY) + (IP . BINARY) + (INTERPRESS . BINARY) + (PRESS . BINARY) + (PSCFONT . BINARY) + (RST . BINARY) + (BIN . BINARY) + (MAIL . BINARY) + (SYSOUT . BINARY) + (SYSOUT.Z . BINARY) + (TAR . BINARY) + (INDEX . BINARY) + (HASH . BINARY) + (NOTEFILE . BINARY) + (Z . BINARY) + (VIRTUALMEM . BINARY) + (VM . BINARY))) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY @@ -456,124 +479,127 @@ update the map") (SETQ PAGES (RESTOREMAP STREAM))) (DELETED (* ; "the file disap ) (DECLARE%: EVAL@COMPILE DONTCOPY -(RPAQQ UFSDECLS ((MACROS \UFS.FULLNAME.M \UFSGetMonitor \UFS.DEFAULT.DIR \UFS.FILE.RECOGNIZER - \UFS.DIRECTORY.RECOGNIZER DSKP) - (RECORDS UFSSTREAM NAME&ALLPROPS) - - (* ;; "File attribute code. For interface between Cfunc and LISPfunc.") +(RPAQQ UFSDECLS + ((MACROS \UFS.FULLNAME.M \UFSGetMonitor \UFS.DEFAULT.DIR \UFS.FILE.RECOGNIZER + \UFS.DIRECTORY.RECOGNIZER DSKP) + (RECORDS UFSSTREAM NAME&ALLPROPS) + + (* ;; "File attribute code. For interface between Cfunc and LISPfunc.") - (CONSTANTS (ATTR-LENGTH 1) - (ATTR-WDATE 2) - (ATTR-RDATE 3) - (ATTR-CDATE 4) - (ATTR-AUTHOR 5) - (ATTR-PROTECTION 6) - (ATTR-EOL 7) - (ATTR-ALL 8)) - - (* ;; "File RECOG code. For interface between Cfunc and LISPfunc.") + (CONSTANTS (ATTR-LENGTH 1) + (ATTR-WDATE 2) + (ATTR-RDATE 3) + (ATTR-CDATE 4) + (ATTR-AUTHOR 5) + (ATTR-PROTECTION 6) + (ATTR-EOL 7) + (ATTR-ALL 8)) + + (* ;; "File RECOG code. For interface between Cfunc and LISPfunc.") - (CONSTANTS (RECOG-OLD 0) - (RECOG-OLDEST 1) - (RECOG-NEW 2) - (RECOG-NEW-OLD 3) - (RECOG-OTHER 4) - (RECOG-NON 5)) - - (* ;; "File ACCESS code. For interface between Cfunc and LISPfunc.") + (CONSTANTS (RECOG-OLD 0) + (RECOG-OLDEST 1) + (RECOG-NEW 2) + (RECOG-NEW-OLD 3) + (RECOG-OTHER 4) + (RECOG-NON 5)) + + (* ;; "File ACCESS code. For interface between Cfunc and LISPfunc.") - (CONSTANTS (ACCESS-INPUT 0) - (ACCESS-OUTPUT 1) - (ACCESS-BOTH 2) - (ACCESS-APPEND 3) - (ACCESS-OTHER 4)) - - (* ;; "\UFSGetFileInfo allocate this size buffer to keep the user name.") + (CONSTANTS (ACCESS-INPUT 0) + (ACCESS-OUTPUT 1) + (ACCESS-BOTH 2) + (ACCESS-APPEND 3) + (ACCESS-OTHER 4)) + + (* ;; "\UFSGetFileInfo allocate this size buffer to keep the user name.") - (CONSTANTS (MAX-UNAME-LEN 512)) - - (* ;; "\UFSGetFileName allocate this size buffer to keep the path name.") + (CONSTANTS (MAX-UNAME-LEN 512)) + + (* ;; "\UFSGetFileName allocate this size buffer to keep the path name.") - (CONSTANTS (MAX-PATHNAME-LEN 256)) - (FILES (LOADCOMP) - PMAP) - (* ; "For \devicefile.eoserror"))) + (CONSTANTS (MAX-PATHNAME-LEN 256)) + (FILES (LOADCOMP) + PMAP) + (* ; "For \devicefile.eoserror"))) (DECLARE%: EVAL@COMPILE -[PUTPROPS \UFS.FULLNAME.M MACRO (LAMBDA (DIR NAME DEV ATOMP) - (DECLARE (GLOBALVARS *DSK-HOST-NAME* *UFS-HOST-NAME*)) +(PUTPROPS \UFS.FULLNAME.M MACRO [LAMBDA (DIR NAME DEV ATOMP) + (DECLARE (GLOBALVARS *DSK-HOST-NAME* *UFS-HOST-NAME*)) - (* ;; "NAME is a name string returned from UNIX. We turn it into a Lisp %"full file name%". This function is redefinable by code that hacks ufs names.") - - (COND - (NAME (* ; "Pass NIL thru transparently") - (COND - [(DSKP DEV) - (SETQ NAME (CONCAT *DSK-HOST-NAME* DIR NAME)) - (COND - [*DSK-UPPER-CASE-FILE-NAMES* - - (* ;; "DSK code uses *DSK-UPPER-CASE-FILE-NAMES* instead of *UPPER-CASE-FILE-NAMES*. I think the capability of case insensitive file recognition in Medley-S {DSK} device is essentially optional and implemented only to keep the compatibility with D-Machines. Actually the case insensitive file recognition is significantly slower than on the correct case (AR 11074). There is no reasonable way to solve this problem because the underlying UNIX file ysystem is case sensitive. Thus, I introduced the new parameter *DSK-UPPER-CASE-FILE-NAMES* with its default value NIL.") + (* ;; "NAME is a name string returned from UNIX. We turn it into a Lisp %"full file name%". This function is redefinable by code that hacks ufs names.") + (COND + (NAME (* ; "Pass NIL thru transparently") (COND - (ATOMP (MKATOM (U-CASE NAME))) - (T (U-CASE NAME] - (T (COND - (ATOMP (MKATOM NAME)) - (T NAME] - (T (SETQ NAME (CONCAT *UFS-HOST-NAME* DIR NAME)) - (COND - (ATOMP (MKATOM NAME)) - (T NAME] + [(DSKP DEV) + (SETQ NAME (CONCAT *DSK-HOST-NAME* DIR NAME)) + (COND + [*DSK-UPPER-CASE-FILE-NAMES* -(PUTPROPS \UFSGetMonitor MACRO ((DEV) - (SELECTQ (fetch (FDEV DEVICENAME) of DEV) - (DSK \DSKtopMonitor) - (UNIX \UFStopMonitor) - NIL))) + (* ;; "DSK code uses *DSK-UPPER-CASE-FILE-NAMES* instead of *UPPER-CASE-FILE-NAMES*. I think the capability of case insensitive file recognition in Medley-S {DSK} device is essentially optional and implemented only to keep the compatibility with D-Machines. Actually the case insensitive file recognition is significantly slower than on the correct case (AR 11074). There is no reasonable way to solve this problem because the underlying UNIX file ysystem is case sensitive. Thus, I introduced the new parameter *DSK-UPPER-CASE-FILE-NAMES* with its default value NIL.") -(PUTPROPS \UFS.DEFAULT.DIR MACRO ((DEV) - (SELECTQ (fetch (FDEV DEVICENAME) of DEV) - (DSK \DSK.DEFAULT.DIRECTORY) - (UNIX \UFS.DEFAULT.DIRECTORY) - NIL))) + (COND + (ATOMP (MKATOM (U-CASE NAME))) + (T (U-CASE NAME] + (T (COND + (ATOMP (MKATOM NAME)) + (T NAME] + (T (SETQ NAME (CONCAT *UFS-HOST-NAME* DIR NAME) + ) + (COND + (ATOMP (MKATOM NAME)) + (T NAME]) -[PUTPROPS \UFS.FILE.RECOGNIZER MACRO ((DEV) +(PUTPROPS \UFSGetMonitor MACRO ((DEV) + (SELECTQ (fetch (FDEV DEVICENAME) of DEV) + (DSK \DSKtopMonitor) + (UNIX \UFStopMonitor) + NIL))) - (* ;; - "Return a function that will do name recognition for this device") +(PUTPROPS \UFS.DEFAULT.DIR MACRO ((DEV) + (SELECTQ (fetch (FDEV DEVICENAME) of DEV) + (DSK \DSK.DEFAULT.DIRECTORY) + (UNIX \UFS.DEFAULT.DIRECTORY) + NIL))) - (SELECTQ (fetch (FDEV DEVICENAME) of DEV) - (DSK (FUNCTION \DSKGetFileName-C)) - (UNIX (FUNCTION \UFSGetFileName-C)) - (FUNCTION SHOULDNT] +(PUTPROPS \UFS.FILE.RECOGNIZER MACRO ((DEV) -[PUTPROPS \UFS.DIRECTORY.RECOGNIZER MACRO ((DEV) - (SELECTQ (fetch (FDEV DEVICENAME) of DEV) - (DSK (FUNCTION \DSKDirectoryNameP-C)) - (UNIX (FUNCTION \UFSDirectoryNameP-C)) - (FUNCTION SHOULDNT] + (* ;; + "Return a function that will do name recognition for this device") -[PUTPROPS DSKP MACRO ((DEV) - (EQ (fetch (FDEV DEVICENAME) of DEV) - 'DSK] + (SELECTQ (fetch (FDEV DEVICENAME) of DEV) + (DSK (FUNCTION \DSKGetFileName-C)) + (UNIX (FUNCTION \UFSGetFileName-C)) + (FUNCTION SHOULDNT)))) + +(PUTPROPS \UFS.DIRECTORY.RECOGNIZER MACRO ((DEV) + (SELECTQ (fetch (FDEV DEVICENAME) of + DEV) + (DSK (FUNCTION \DSKDirectoryNameP-C)) + (UNIX (FUNCTION \UFSDirectoryNameP-C)) + (FUNCTION SHOULDNT)))) + +(PUTPROPS DSKP MACRO ((DEV) + (EQ (fetch (FDEV DEVICENAME) of DEV) + 'DSK))) ) (DECLARE%: EVAL@COMPILE (ACCESSFNS UFSSTREAM ( - (* ;; - "Overlay for the STREAM record to allow mnemonic access to stream fields for ufs streams.") + (* ;; + "Overlay for the STREAM record to allow mnemonic access to stream fields for ufs streams.") (FILEID (fetch F1 of DATUM) (REPLACE F1 OF DATUM WITH NEWVALUE)) - (* ; "Unix file handle") + (* ; "Unix file handle") (CDATE (fetch F2 of DATUM) (REPLACE F2 OF DATUM WITH NEWVALUE)) - (* ; "IDate given to openstream") + (* ; "IDate given to openstream") (UNIXNAME (fetch F5 of DATUM) (REPLACE F5 OF DATUM WITH NEWVALUE)) - (* ; - "The name by which Unix knows this file") + (* ; + "The name by which Unix knows this file") )) (RECORD NAME&ALLPROPS (NAME . ALLPROPS)) @@ -747,25 +773,26 @@ update the map") (SETQ PAGES (RESTOREMAP STREAM))) (DELETED (* ; "the file disap (ADDTOVAR LAMA ) ) -(PUTPROPS UFS COPYRIGHT ("Venue & Xerox Corporation" 1988 1989 1990 1991 1992 1993 1994 1995 2000)) +(PUTPROPS UFS COPYRIGHT ("Venue & Xerox Corporation" 1988 1989 1990 1991 1992 1993 1994 1995 2000 2021 +)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (8170 9723 (\UFSCreateDevice 8180 . 8545) (\UFS.CREATE.DEVICE 8547 . 9403) ( -\UFSOpenDevice 9405 . 9582) (\UFSCloseDevice 9584 . 9721)) (13884 41794 (\UFSOpenFile 13894 . 17188) ( -\UFS.OPENP 17190 . 17687) (\UFS.RECOGNIZE.FILE 17689 . 18442) (\UFS.DIRECTORY.NAME 18444 . 19187) ( -\UFSCloseFile 19189 . 20165) (\UFSGetFileName 20167 . 20366) (\UFSDeleteFile 20368 . 20908) ( -\UFSRenameFile 20910 . 22075) (\UFSReadPages 22077 . 23212) (\UFSWritePages 23214 . 24434) ( -\UFSTruncateFile 24436 . 25933) (\UFSDirectoryNameP 25935 . 26989) (\UFSEventFn 26991 . 27653) ( -\UFSGetFileInfo 27655 . 29937) (\UFS.CREATE.PROPS 29939 . 30292) (\UFSSetFileInfo 30294 . 31523) ( -\UFSGenerateFiles 31525 . 34237) (\UFS.NEXTFILEFN 34239 . 38382) (\UFS.FILEINFOFN 38384 . 39833) ( -\UFS.VALID.PROPP 39835 . 40127) (\UFS.REGISTER.GFS 40129 . 40384) (\UFS.UNREGISTER.GFS 40386 . 40969) -(\UFS.ABORT.DIRECTORY 40971 . 41319) (\UFS.ABORT.CL-DIRECTORY 41321 . 41608) (\UFS.CLEANUP.GFS.TABLE -41610 . 41792)) (41829 48513 (\UFSMakeUnixFormatName 41839 . 42860) (\UFSParseNameString 42862 . 43236 -) (\UFSParse-Directory 43238 . 43779) (\UFS.PARSE.BODY 43781 . 44326) (\UFS.ADJUST.HOST 44328 . 44487) - (\UFS.FULLNAME 44489 . 45697) (\UFS.ADD.HOST.FIELD 45699 . 46059) (\UFS.REMOVE.HOST.FIELD 46061 . -47731) (\UFS.HANDLE.RELATIVEDIRECTORY 47733 . 48511)) (49329 49942 (CHDIR 49339 . 49940)) (50014 51000 - (\DEVICEFILE.EOSERROR 50024 . 50998)) (51073 52310 (\UNVISIBLE.PAGED.REVALIDATEFILELST 51083 . 51928) - (\UNVISIBLE.FLUSH.OPEN.STREAMS 51930 . 52308)) (52343 53969 (\UFSError 52353 . 53967)) (54013 55697 ( -\UFSGetFileType 54023 . 54624) (\UFSSetFileType 54626 . 55055) (\UFSeol 55057 . 55695)) (66049 67173 ( -\UFSGetPrintFileType 66059 . 66471) (\UFSGetFileTypeConfirm 66473 . 66921) (\UFSPrintTypeMenu 66923 . -67171)) (67203 68951 (\UFStoOtherCopyMess 67213 . 68204) (\UFStoOtherRenameMess 68206 . 68949))))) + (FILEMAP (NIL (8248 9801 (\UFSCreateDevice 8258 . 8623) (\UFS.CREATE.DEVICE 8625 . 9481) ( +\UFSOpenDevice 9483 . 9660) (\UFSCloseDevice 9662 . 9799)) (13962 41872 (\UFSOpenFile 13972 . 17266) ( +\UFS.OPENP 17268 . 17765) (\UFS.RECOGNIZE.FILE 17767 . 18520) (\UFS.DIRECTORY.NAME 18522 . 19265) ( +\UFSCloseFile 19267 . 20243) (\UFSGetFileName 20245 . 20444) (\UFSDeleteFile 20446 . 20986) ( +\UFSRenameFile 20988 . 22153) (\UFSReadPages 22155 . 23290) (\UFSWritePages 23292 . 24512) ( +\UFSTruncateFile 24514 . 26011) (\UFSDirectoryNameP 26013 . 27067) (\UFSEventFn 27069 . 27731) ( +\UFSGetFileInfo 27733 . 30015) (\UFS.CREATE.PROPS 30017 . 30370) (\UFSSetFileInfo 30372 . 31601) ( +\UFSGenerateFiles 31603 . 34315) (\UFS.NEXTFILEFN 34317 . 38460) (\UFS.FILEINFOFN 38462 . 39911) ( +\UFS.VALID.PROPP 39913 . 40205) (\UFS.REGISTER.GFS 40207 . 40462) (\UFS.UNREGISTER.GFS 40464 . 41047) +(\UFS.ABORT.DIRECTORY 41049 . 41397) (\UFS.ABORT.CL-DIRECTORY 41399 . 41686) (\UFS.CLEANUP.GFS.TABLE +41688 . 41870)) (41907 48591 (\UFSMakeUnixFormatName 41917 . 42938) (\UFSParseNameString 42940 . 43314 +) (\UFSParse-Directory 43316 . 43857) (\UFS.PARSE.BODY 43859 . 44404) (\UFS.ADJUST.HOST 44406 . 44565) + (\UFS.FULLNAME 44567 . 45775) (\UFS.ADD.HOST.FIELD 45777 . 46137) (\UFS.REMOVE.HOST.FIELD 46139 . +47809) (\UFS.HANDLE.RELATIVEDIRECTORY 47811 . 48589)) (49407 50020 (CHDIR 49417 . 50018)) (50092 51078 + (\DEVICEFILE.EOSERROR 50102 . 51076)) (51151 52388 (\UNVISIBLE.PAGED.REVALIDATEFILELST 51161 . 52006) + (\UNVISIBLE.FLUSH.OPEN.STREAMS 52008 . 52386)) (52421 54047 (\UFSError 52431 . 54045)) (54091 56338 ( +\UFSGetFileType 54101 . 54702) (\UFSSetFileType 54704 . 55133) (\UFSeol 55135 . 56336)) (65950 67074 ( +\UFSGetPrintFileType 65960 . 66372) (\UFSGetFileTypeConfirm 66374 . 66822) (\UFSPrintTypeMenu 66824 . +67072)) (67104 68852 (\UFStoOtherCopyMess 67114 . 68105) (\UFStoOtherRenameMess 68107 . 68850))))) STOP diff --git a/sources/UFS.LCOM b/sources/UFS.LCOM index 8984277c01dfa5ee9744b18b22cd1fecaedcb816..297bb55b9176b2571161e74c526af54a07cdc8dd 100644 GIT binary patch delta 1279 zcma)6O>7%g5U!o3Nmt!ehTx_@2`}5GwcB{*-DEex7Okw<8&a*;No=P;jUchNiK$}; z+ld@ zxb(rA-pN|4R`F z2s}{$QJ<4LB#x}FNXiA+(xVyi2dmPvj(Yb$B;w0jdo%tg5x09e)Y?@vK|t7?$fiva z2zPSyH^;XQjx9O2ZggWv$y%4jTy4rG|Sj^ZNEq1n%sxuwtl#UEFCQuFvkh#b;%(+M_yWPBi$fe!C{4*;6$48gTXBsNo2aK=}q63$S@|AfFd z!EmLO6BnF%kI|DD2=&K_2QTrlvBc=nyw8>4m@vF6v*&a1O2hCo(3!# zqMX%4XRHu--&nio&sG>b-&8Y=O$Diy*iL^*y6M7{2hf$NZM64DJ>{pBt-LKlOX|82 fibe?Qn@(+Z{Yw=IiuBwx!f}KT$Q&>G1(qzJMrEu- z%2mR!38hp~>csC8No1)~A(=YJ7=)kr*Wc&!v7}Tmz?JeYPxz}DH_v@ZDa7gZEqq4{n7*}o-0((Dm7xLqcU;NhvqVb zfs4(g5*ZKCbY;1$F4b_WkOBj&5QKeoZ%`!sq%3kW&;L(9-osFrt*?`zlI`P8#_Ha6 z*KR0Ul0c94ya*Y$-$yt0B&lYf+2J?sPyWN#+Dx*vy_-F4_#4Er-uK&Bv_|^IZIGr1 zerN;9st)Em+hB@zJ8pvCPmTbBLkCQpSeUdvhYV6~KToe5d>S&jK53nH{)}+jHEuOY z9a3xC^*w&R8u=AJpN%@v=a;bz#FivlraOfIRsJ}PDhNNh=QX@rdO)IYa(K6M{PWlX z*RXJ67o<3UL)-+#mUPL!10qMZa0&#D+*jy^^qI&Rn6O7(T|4}Ayo9IUOI-tgDm{R^ z8pqy%$j!YB=*zhfB9cY)MfO#QtGP17Te(ZnHs{B&y>a|0D54MIRje})jUs#E4K8lIw0H=Q zd|HiS>wxC$_K=RPjt-jBHg~T-y6-%7TzC#TZ(Vo=VpY!%GkJJ(QN>8><*E^ZA1_wMSHeTFWGvf$%5Kyx z!6Pmz9^z)`#g&8uk)dh{wOTe*-2?nD35I^NGE2M6eO<(zIgz0UO$W`G(h$z4G^L7b z5iESEbU2wN^hR$VecklaA5HY_X@qF3aW_52_tM820^Ml1fPT=JqHkx1Amir;sMvJV xhns_R{dhmU+!XI@t3`70crug-6Z&<&pWfd;Xx(b^d#vc?HG7Z8!z5#I=1-vNab*Ai