From 9b7464d9661a127f712902d16460998867bd86b2 Mon Sep 17 00:00:00 2001 From: rmkaplan Date: Sat, 25 Sep 2021 22:40:25 -0700 Subject: [PATCH 1/7] MULTI-COMPILE: Just MAKEFILE-NEW to get better filemap --- internal/library/MULTI-COMPILE | 25 ++++++++++++------------- 1 file changed, 12 insertions(+), 13 deletions(-) diff --git a/internal/library/MULTI-COMPILE b/internal/library/MULTI-COMPILE index cf980f09..57ad5780 100644 --- a/internal/library/MULTI-COMPILE +++ b/internal/library/MULTI-COMPILE @@ -1,13 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) -(FILECREATED "16-Nov-94 16:28:04" |{DSK}internal>library>MULTI-COMPILE.;4| 37236 +(FILECREATED "25-Sep-2021 21:28:08"  +|{DSK}kaplan>Local>medley3.5>git-medley>internal>library>MULTI-COMPILE.;2| 37172 - |changes| |to:| (VARS MULTI-COMPILECOMS) - (FNS FIND-UNCOMPILED-FILES) - - |previous| |date:| " 9-Sep-94 13:03:19" |{DSK}internal>library>MULTI-COMPILE.;3|) + |previous| |date:| "16-Nov-94 16:28:04" +|{DSK}kaplan>Local>medley3.5>git-medley>internal>library>MULTI-COMPILE.;1|) -; Copyright (c) 1988, 1990, 1991, 1992, 1993, 1994 by Venue & Xerox Corporation. All rights reserved. +; Copyright (c) 1988, 1990-1994, 2021 by Venue & Xerox Corporation. (PRETTYCOMPRINT MULTI-COMPILECOMS) @@ -601,12 +600,12 @@ (ADDTOVAR LAMA FIX-FILES) ) -(PUTPROPS MULTI-COMPILE COPYRIGHT ("Venue & Xerox Corporation" 1988 1990 1991 1992 1993 1994)) +(PUTPROPS MULTI-COMPILE COPYRIGHT ("Venue & Xerox Corporation" 1988 1990 1991 1992 1993 1994 2021)) (DECLARE\: DONTCOPY - (FILEMAP (NIL (7131 8389 (FIND-UNCOMPILED-FILES 7141 . 8387)) (8461 19787 (NEWERDCOMS? 8471 . 12445) ( -NEWERSOURCES? 12447 . 16359) (SETUP-FOR-RECOMPILE 16361 . 18749) (SMASH-OPCODES 18751 . 19269) ( -GET-DIRECTORY-LISTING 19271 . 19568) (GET-OPEN-FILES 19570 . 19785)) (31690 36610 (FIX-FILES 31700 . -34497) (FIX-FILE 34499 . 35090) (FIX-COPYRIGHT 35092 . 35319) (FIX-FILE-COPYRIGHT 35321 . 35481) ( -QUALIFY-FIELDS 35483 . 36022) (FIX-TEDIT 36024 . 36330) (FIX-DOCS 36332 . 36608)) (36735 36917 (CLFIX -36745 . 36915))))) + (FILEMAP (NIL (2676 6156 (BIGCOMP 2676 . 6156)) (6289 7061 (FIND-ALL-SOURCE-FILES 6289 . 7061)) (7062 +8320 (FIND-UNCOMPILED-FILES 7072 . 8318)) (8392 19718 (NEWERDCOMS? 8402 . 12376) (NEWERSOURCES? 12378 + . 16290) (SETUP-FOR-RECOMPILE 16292 . 18680) (SMASH-OPCODES 18682 . 19200) (GET-DIRECTORY-LISTING +19202 . 19499) (GET-OPEN-FILES 19501 . 19716)) (31621 36541 (FIX-FILES 31631 . 34428) (FIX-FILE 34430 + . 35021) (FIX-COPYRIGHT 35023 . 35250) (FIX-FILE-COPYRIGHT 35252 . 35412) (QUALIFY-FIELDS 35414 . +35953) (FIX-TEDIT 35955 . 36261) (FIX-DOCS 36263 . 36539)) (36666 36848 (CLFIX 36676 . 36846))))) STOP From c89ac61d34ef3095f3be93e1d8bc4c48c9866006 Mon Sep 17 00:00:00 2001 From: rmkaplan Date: Sat, 25 Sep 2021 22:47:16 -0700 Subject: [PATCH 2/7] IMAGEIO: Separate construction of :DISPLAY external format Defaults for 4/8/24 bit display FDEV's --- sources/IMAGEIO | 84 ++++++++++++++++++++++--------------------- sources/IMAGEIO.LCOM | Bin 35591 -> 35617 bytes 2 files changed, 44 insertions(+), 40 deletions(-) diff --git a/sources/IMAGEIO b/sources/IMAGEIO index ea111516..bb3fd43c 100644 --- a/sources/IMAGEIO +++ b/sources/IMAGEIO @@ -1,11 +1,12 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT XCCS) -(FILECREATED " 2-Aug-2021 19:41:35"  -{DSK}kaplan>Local>medley3.5>git-medley>sources>IMAGEIO.;4 79616 +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(FILECREATED "25-Sep-2021 20:58:07"  +{DSK}kaplan>Local>medley3.5>git-medley>sources>IMAGEIO.;4 79783 - changes to%: (FNS \DISPLAYINIT) + changes to%: (VARS IMAGEIOCOMS) + (FNS \DISPLAYINIT \4DISPLAYINIT \8DISPLAYINIT \24DISPLAYINIT) - previous date%: "28-Jun-99 16:33:59" -{DSK}kaplan>Local>medley3.5>git-medley>sources>IMAGEIO.;1) + previous date%: " 2-Aug-2021 19:41:35" +{DSK}kaplan>Local>medley3.5>git-medley>sources>IMAGEIO.;2) (* ; " @@ -27,7 +28,7 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by Venue & Xerox Corporation. (FNS \DRAWPOINT.GENERIC \DRAWPOLYGON.GENERIC \DRAWCIRCLE.GENERIC \DRAWELLIPSE.GENERIC) (FNS \IMAGEIOINIT \NOIMAGE.DSPFONT \UNIMPIMAGEOP) [COMS - (* ;; "stuff to support the checking and defaulting of arguments in the device independent drawing functions.") + (* ;; "stuff to support the checking and defaulting of arguments in the device independent drawing functions.") (FNS INSURE.BRUSH BRUSHP \POSSIBLECOLOR NEGSHADE) (DECLARE%: DONTCOPY EVAL@COMPILE (RESOURCES SYSTEMBRUSH)) @@ -42,7 +43,7 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by Venue & Xerox Corporation. (SYSRECORDS IMAGEOPS) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\IMAGEIOINIT))) [COMS - (* ;; "Implementation of display stream resident `files.' Done here cause it might matter that the display device get defined early so that its event fn will be evaluated as the last thing before logout") + (* ;; "Implementation of display stream resident `files.' Done here cause it might matter that the display device get defined early so that its event fn will be evaluated as the last thing before logout") (INITVARS (\COLORDISPLAYSTREAMTYPES '(4DISPLAY 8DISPLAY 24DISPLAY)) (\DISPLAYSTREAMTYPES (CONS 'DISPLAY \COLORDISPLAYSTREAMTYPES))) @@ -1170,11 +1171,11 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by Venue & Xerox Corporation. NIL]) (\DISPLAYINIT - [LAMBDA NIL (* ; "Edited 2-Aug-2021 19:41 by rmk:") + [LAMBDA NIL (* ; "Edited 25-Sep-2021 20:57 by rmk:") - (* ;; "Initializes global variables for the Display device") + (* ;; "Initializes global variables for the Display device") - (* ;; "Display Streams are referred to only by themselves so they do not need directory operations. Most of the fields in the DisplayDevice are empty to avoid something bad happening.") + (* ;; "Display Streams are referred to only by themselves so they do not need directory operations. Most of the fields in the DisplayDevice are empty to avoid something bad happening.") (DECLARE (GLOBALVARS DisplayFDEV \DISPLAYIMAGEOPS \DisplayDeviceMethods \DisplayDeviceData)) (SETQ \DisplayDeviceMethods (create WSOPS)) @@ -1186,6 +1187,8 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by Venue & Xerox Corporation. BOTTOM _ 0 WIDTH _ 1024 HEIGHT _ 808))) + (MAKE-EXTERNALFORMAT :DISPLAY NIL NIL NIL (FUNCTION \DSPPRINTCHAR) + NIL CR.EOLC) (SETQ \DISPLAYIMAGEOPS (create IMAGEOPS IMAGETYPE _ 'DISPLAY IMFONT _ (FUNCTION \DSPFONT.DISPLAY) @@ -1252,13 +1255,11 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by Venue & Xerox Corporation. WINDOWOPS _ \DisplayDeviceMethods WINDOWDATA _ \DisplayDeviceData DEVICEINFO _ (create DISPLAYSTATE) - DEFAULTEXTERNALFORMAT _ (MAKE-EXTERNALFORMAT :DISPLAY NIL NIL NIL - (FUNCTION \DSPPRINTCHAR) - NIL CR.EOLC))) + DEFAULTEXTERNALFORMAT _ :DISPLAY)) (\DEFINEDEVICE 'LFDISPLAY DisplayFDEV]) (\4DISPLAYINIT - [LAMBDA NIL (* ; "Edited 22-Apr-94 15:17 by sybalsky") + [LAMBDA NIL (* ; "Edited 25-Sep-2021 18:42 by rmk:") (DECLARE (GLOBALVARS \4DISPLAYIMAGEOPS \4DISPLAYFDEV)) (SETQ \4DISPLAYIMAGEOPS (create IMAGEOPS IMAGETYPE _ '4DISPLAY @@ -1322,11 +1323,12 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by Venue & Xerox Corporation. BLOCKIN _ (FUNCTION \ILLEGAL.DEVICEOP) BLOCKOUT _ (FUNCTION \NONPAGEDBOUTS) DEVICEINFO _ (create DISPLAYSTATE) - WINDOWOPS _ NIL)) + WINDOWOPS _ NIL + DEFAULTEXTERNALFORMAT _ :DISPLAY)) (\DEFINEDEVICE NIL \4DISPLAYFDEV]) (\8DISPLAYINIT - [LAMBDA NIL (* ; "Edited 22-Apr-94 15:18 by sybalsky") + [LAMBDA NIL (* ; "Edited 25-Sep-2021 18:43 by rmk:") (DECLARE (GLOBALVARS \8DISPLAYIMAGEOPS \8DISPLAYFDEV)) (SETQ \8DISPLAYIMAGEOPS (create IMAGEOPS IMAGETYPE _ '8DISPLAY @@ -1390,11 +1392,12 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by Venue & Xerox Corporation. BLOCKIN _ (FUNCTION \ILLEGAL.DEVICEOP) BLOCKOUT _ (FUNCTION \NONPAGEDBOUTS) DEVICEINFO _ (create DISPLAYSTATE) - WINDOWOPS _ NIL)) + WINDOWOPS _ NIL + DEFAULTEXTERNALFORMAT _ :DISPLAY)) (\DEFINEDEVICE NIL \8DISPLAYFDEV]) (\24DISPLAYINIT - [LAMBDA NIL (* ; "Edited 22-Apr-94 15:18 by sybalsky") + [LAMBDA NIL (* ; "Edited 25-Sep-2021 18:44 by rmk:") (DECLARE (GLOBALVARS \24DISPLAYIMAGEOPS \24DISPLAYFDEV)) (SETQ \24DISPLAYIMAGEOPS (create IMAGEOPS IMAGETYPE _ '24DISPLAY @@ -1458,7 +1461,8 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by Venue & Xerox Corporation. BLOCKIN _ (FUNCTION \ILLEGAL.DEVICEOP) BLOCKOUT _ (FUNCTION \NONPAGEDBOUTS) DEVICEINFO _ (create DISPLAYSTATE) - WINDOWOPS _ NIL)) + WINDOWOPS _ NIL + DEFAULTEXTERNALFORMAT _ :DISPLAY)) (\DEFINEDEVICE NIL \24DISPLAYFDEV]) (\DISPLAYSTREAMTYPEBPP @@ -1509,24 +1513,24 @@ Copyright (c) 1983-1991, 1993-1994, 1999, 2021 by Venue & Xerox Corporation. (PUTPROPS IMAGEIO COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 1991 1993 1994 1999 2021)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (3353 12110 (IMAGESTREAMP 3363 . 4195) (IMAGESTREAMTYPE 4197 . 4410) (IMAGESTREAMTYPEP -4412 . 5047) (OPENIMAGESTREAM 5049 . 10003) (\GOOD.DASHLST 10005 . 12108)) (12145 14442 ( -DRAWDASHEDLINE 12155 . 14440)) (14443 21783 (DSPBACKCOLOR 14453 . 14825) (DSPBOTTOMMARGIN 14827 . -15212) (DSPCOLOR 15214 . 15578) (DSPCLIPPINGREGION 15580 . 16285) (DSPRESET 16287 . 16567) (DSPFONT -16569 . 16933) (DSPLEFTMARGIN 16935 . 17316) (DSPLINEFEED 17318 . 17618) (DSPOPERATION 17620 . 17997) -(DSPRIGHTMARGIN 17999 . 18382) (DSPTOPMARGIN 18384 . 18763) (DSPSCALE 18765 . 19132) (DSPSPACEFACTOR -19134 . 19527) (DSPXPOSITION 19529 . 19834) (DSPYPOSITION 19836 . 20141) (DSPROTATE 20143 . 20438) ( -DSPPUSHSTATE 20440 . 20686) (DSPPOPSTATE 20688 . 20931) (DSPDEFAULTSTATE 20933 . 21185) (DSPSCALE2 -21187 . 21478) (DSPTRANSLATE 21480 . 21781)) (21784 30585 (DSPNEWPAGE 21794 . 22486) (DRAWBETWEEN -22488 . 23190) (DRAWCIRCLE 23192 . 23688) (DRAWARC 23690 . 24207) (DRAWCURVE 24209 . 24886) ( -DRAWELLIPSE 24888 . 25674) (DRAWLINE 25676 . 26066) (DRAWPOLYGON 26068 . 26523) (DRAWPOINT 26525 . -26944) (FILLPOLYGON 26946 . 27512) (DRAWTO 27514 . 27932) (FILLCIRCLE 27934 . 28157) (MOVETO 28159 . -28523) (RELDRAWTO 28525 . 29442) (BITMAPIMAGESIZE 29444 . 29615) (SCALEDBITBLT 29617 . 30583)) (30586 -37625 (\DRAWPOINT.GENERIC 30596 . 30943) (\DRAWPOLYGON.GENERIC 30945 . 33253) (\DRAWCIRCLE.GENERIC -33255 . 34913) (\DRAWELLIPSE.GENERIC 34915 . 37623)) (37626 43012 (\IMAGEIOINIT 37636 . 41769) ( -\NOIMAGE.DSPFONT 41771 . 42846) (\UNIMPIMAGEOP 42848 . 43010)) (43135 46259 (INSURE.BRUSH 43145 . -44519) (BRUSHP 44521 . 45311) (\POSSIBLECOLOR 45313 . 45864) (NEGSHADE 45866 . 46257)) (46815 47499 ( -DASHINGP 46825 . 47155) (INSURE.DASHING 47157 . 47497)) (57980 78429 (\DisplayEventFn 57990 . 58500) ( -\DISPLAYINIT 58502 . 64181) (\4DISPLAYINIT 64183 . 68820) (\8DISPLAYINIT 68822 . 73461) ( -\24DISPLAYINIT 73463 . 78170) (\DISPLAYSTREAMTYPEBPP 78172 . 78427))))) + (FILEMAP (NIL (3423 12180 (IMAGESTREAMP 3433 . 4265) (IMAGESTREAMTYPE 4267 . 4480) (IMAGESTREAMTYPEP +4482 . 5117) (OPENIMAGESTREAM 5119 . 10073) (\GOOD.DASHLST 10075 . 12178)) (12215 14512 ( +DRAWDASHEDLINE 12225 . 14510)) (14513 21853 (DSPBACKCOLOR 14523 . 14895) (DSPBOTTOMMARGIN 14897 . +15282) (DSPCOLOR 15284 . 15648) (DSPCLIPPINGREGION 15650 . 16355) (DSPRESET 16357 . 16637) (DSPFONT +16639 . 17003) (DSPLEFTMARGIN 17005 . 17386) (DSPLINEFEED 17388 . 17688) (DSPOPERATION 17690 . 18067) +(DSPRIGHTMARGIN 18069 . 18452) (DSPTOPMARGIN 18454 . 18833) (DSPSCALE 18835 . 19202) (DSPSPACEFACTOR +19204 . 19597) (DSPXPOSITION 19599 . 19904) (DSPYPOSITION 19906 . 20211) (DSPROTATE 20213 . 20508) ( +DSPPUSHSTATE 20510 . 20756) (DSPPOPSTATE 20758 . 21001) (DSPDEFAULTSTATE 21003 . 21255) (DSPSCALE2 +21257 . 21548) (DSPTRANSLATE 21550 . 21851)) (21854 30655 (DSPNEWPAGE 21864 . 22556) (DRAWBETWEEN +22558 . 23260) (DRAWCIRCLE 23262 . 23758) (DRAWARC 23760 . 24277) (DRAWCURVE 24279 . 24956) ( +DRAWELLIPSE 24958 . 25744) (DRAWLINE 25746 . 26136) (DRAWPOLYGON 26138 . 26593) (DRAWPOINT 26595 . +27014) (FILLPOLYGON 27016 . 27582) (DRAWTO 27584 . 28002) (FILLCIRCLE 28004 . 28227) (MOVETO 28229 . +28593) (RELDRAWTO 28595 . 29512) (BITMAPIMAGESIZE 29514 . 29685) (SCALEDBITBLT 29687 . 30653)) (30656 +37695 (\DRAWPOINT.GENERIC 30666 . 31013) (\DRAWPOLYGON.GENERIC 31015 . 33323) (\DRAWCIRCLE.GENERIC +33325 . 34983) (\DRAWELLIPSE.GENERIC 34985 . 37693)) (37696 43082 (\IMAGEIOINIT 37706 . 41839) ( +\NOIMAGE.DSPFONT 41841 . 42916) (\UNIMPIMAGEOP 42918 . 43080)) (43205 46329 (INSURE.BRUSH 43215 . +44589) (BRUSHP 44591 . 45381) (\POSSIBLECOLOR 45383 . 45934) (NEGSHADE 45936 . 46327)) (46885 47569 ( +DASHINGP 46895 . 47225) (INSURE.DASHING 47227 . 47567)) (58050 78596 (\DisplayEventFn 58060 . 58570) ( +\DISPLAYINIT 58572 . 64155) (\4DISPLAYINIT 64157 . 68858) (\8DISPLAYINIT 68860 . 73563) ( +\24DISPLAYINIT 73565 . 78337) (\DISPLAYSTREAMTYPEBPP 78339 . 78594))))) STOP diff --git a/sources/IMAGEIO.LCOM b/sources/IMAGEIO.LCOM index 943aa0ba13f86f71c7faada23443c80225b61807..7d6574b96154bc1c6e22bf30849ba2d8e4f8d860 100644 GIT binary patch delta 1770 zcmZux&u`;I6sGA4P*o89L0ixso`P0tks5hsY|l6cSl6Dk);hMa-DHcxN}-9`uDboP z?XEytR4vkKFC4ZSX(bMTxN$>}D+qezgv4LKg%esK{sW#9J82_w@#MWX?|t*V@4ctb zOW!^(J!{NUV>Rg>tx}B=pjy=sRgItDjVt;JlrQ@TuTrDRco{yv-`zgEceJ$AQu;T>0y1g#F&h>+UDsQJU4s5>`#&tWz_X%NvyLWQ5-~P0Qu^@yFe$Dlg z$hWsZ@G&nZ>an*dCv%VRhl{jscir}B8#trt zB3xJmP8qa`f?pnB+CcufFm7V08q1v7Kl4WLp-!uisOi2{QUXVH)b_^yLnP<~9 ztpRS+)bfKdswy9L4^C?bVCslAhvfxcYHJ!dz+_l|%*w!|eF*QGBxlXk3f53?L70gz z0mI^ha)!u&%%5RX#&Ve^7}(-|Qw)>j2P1EjK@BK~GKhdj*Cw-Gr(2PH=Mfm>60}UJ zVT3g`W4s2wRkskHdo~b9{y5zN9VzRV)_LApy`V}*s>ZOQRCLTWxPW904#>~oKyxMO z1t&Uk(s!|(2M3tQ>#&T9x^$bBt*};0WC{#v7+7u>7UW}KS@Q=CWd>F4lle)eGc{9R zTxHp`#CFq;ol3zIL(Vc8#1gZPti)75om@X-8j2(nN7HlDjiH-b0$NFm%2^+C;FM+A z!brw;>V?7Ria@+;wsXq~{V*PxdCm|u>9BXS7`F;V631vI7Em0%Rv??1$VZu|ss7!W zyG{v0P8{1u{d*}=F^bUC#p#@8SrCQ(RtFsw5E_wA_?1Y)>g9nR~gmN_#;+F{Z>+ZrN(JVz;Z{b%{AB9Vi zl?_=E)xuze88=YTDV#18bbraBa&u85YgdODu@uXq_g(mUX_|`Rdga-A?RoK+lM~qn z{YHJ>`1{pi^pobFFHbXV7;W{A@4&S@l5CG6)syDey+1ndVKgnG8R@TXckd1Lvs?dh T|0b5`*@s_DjPn0=RDSzEGG^cI delta 1747 zcmZ`(O=ufe5N4IogCo+WwreN#VWJX7~#^e{MaLLhr>CdM>oH(n_*ba+^1Ae!ltUW4?Y` zc=WXJcx?(;Icc`bimVVItU|PkVmx^-R{1=X&iv5|H7bOb;N82;#{T>5)^2kPCYm3# zcUz5CXZQZKiumfoIWbX~D?)1zO75!f127>=Gsgc5DWo(%aozQN$BG>@b!_aWl+DB2 zITE9yk%~&iN0Ph52!qD<=HBh*0d)4SRp7cCBv7}#B=XG-FYwZNXy0w#YwaH%z}9A` zi6JFLFTZ`bS2m1nDpf`BA}B0Mr2C}sgIQ!8B9Ot931gxdKN2VQiS$tX<}mSb^051j zTP}!8?)1c^g0#HlO>G~)EWS%ipLva&6dOCP7dW=F=2;GK%AsnmIAv!&b>hJE-7v12 zDGsL_GT5zy_U`6=7lT39Dfn)V8ee0-ToKQ_8C`|IL*jI*<%ULcLuI+4aHuaiffIYy z0+MG(pc7r(sZCzhWh0M~Rz%Cgy}+T2DWKgPLf2xxtjaW zx-|o5PNFFGf;6iITq95!48j#`mCtG85*kf=v$F}DkTG|)+1cLTI)GQWjQxW!h|DF& zUJO^$1el>Bw5b_ggL>a>S}U14qBI7^g|t3B#n>1OMtPQ$YI=WYrsmT#bp*+|*WBy4 zd%#fNrzK;`GN-@@LOCU*%&P*EGc=P$YUE3xIu+lpOkUvm3MfL#n50x6Pe+s#3F|G9 zYI1I~wh;t8f%~ zlA`36#y*%XeyYwMQ3Sn+BC$e0j7MoSXIw#v4p1tp(&s`^GE}3pf!ihqCN}^S>>7flgJHEZHkTPz{`TN^KyOlrPuvCyjUnQV|W$yZZU@Q(yeZJ?GtJC2A(`~ z)lbKc+>P#W?T;6VoD9;q+&iYf)?XCA?^L^=zVqfe>6R$3eJOSte?GU0IIexs{b%bf ctfUSrDOsiNk2{|aDonIbo?D^&Z@YBmKdr*x%m4rY From db3ca4956445192255b83ba4913b218a09682eae Mon Sep 17 00:00:00 2001 From: rmkaplan Date: Sat, 25 Sep 2021 22:48:04 -0700 Subject: [PATCH 3/7] Localize external format implementation in new EXTERNALFORMAT file Pieces moved from FILEIO and LLREAD, EXTERNALFORMAT added to FILESETS --- sources/EXTERNALFORMAT | 604 +++++++++++ sources/EXTERNALFORMAT.LCOM | Bin 0 -> 7957 bytes sources/FILEIO | 410 +------- sources/FILEIO.LCOM | Bin 49422 -> 45394 bytes sources/FILESETS | 169 --- sources/LLREAD | 1965 ----------------------------------- sources/LLREAD.LCOM | Bin 25465 -> 0 bytes 7 files changed, 659 insertions(+), 2489 deletions(-) create mode 100644 sources/EXTERNALFORMAT create mode 100644 sources/EXTERNALFORMAT.LCOM delete mode 100644 sources/FILESETS delete mode 100644 sources/LLREAD delete mode 100644 sources/LLREAD.LCOM diff --git a/sources/EXTERNALFORMAT b/sources/EXTERNALFORMAT new file mode 100644 index 00000000..f1b7402f --- /dev/null +++ b/sources/EXTERNALFORMAT @@ -0,0 +1,604 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(FILECREATED "19-Sep-2021 08:59:42"  +{DSK}kaplan>Local>medley3.5>git-medley>sources>EXTERNALFORMAT.;16 31868 + + changes to%: (VARS EXTERNALFORMATCOMS) + + previous date%: "11-Sep-2021 09:44:04" +{DSK}kaplan>Local>medley3.5>git-medley>sources>EXTERNALFORMAT.;15) + + +(PRETTYCOMPRINT EXTERNALFORMATCOMS) + +(RPAQQ EXTERNALFORMATCOMS + [(COMS (* ; + "EXTERNALFORMAT declaration and related functions (originally on FILEIO)") + (DECLARE%: DOEVAL@COMPILE DONTCOPY (EXPORT (RECORDS EXTERNALFORMAT))) + (INITRECORDS EXTERNALFORMAT) + (SYSRECORDS EXTERNALFORMAT) + (FNS \EXTERNALFORMAT MAKE-EXTERNALFORMAT) + (FNS \INSTALL.EXTERNALFORMAT \REMOVE.EXTERNALFORMAT FIND-FORMAT) + (GLOBALVARS *EXTERNALFORMATS* *DEFAULT-EXTERNALFORMATS* *DEFAULT-EXTERNALFORMAT*) + (INITVARS (*EXTERNALFORMATS* NIL) + [*DEFAULT-EXTERNALFORMATS* '((DSK :XCCS] + (*DEFAULT-EXTERNALFORMAT* :XCCS))) + [COMS + (* ;; "Generic functions not compiled open (originally on LLREAD)") + + (FNS \OUTCHAR \INCCODE \BACKCCODE \BACKCCODE.EOLC \PEEKCCODE \PEEKCCODE.NOEOLC + \INCCODE.EOLC \FORMATBYTESTREAM \CHECKEOLC.CRLF) + (DECLARE%: DOEVAL@COMPILE DONTCOPY (EXPORT (MACROS \CHECKEOLC] + (COMS + (* ;; "Also from FILEIO, but not clear that this is or ever has been used.") + + (FNS \CREATE.THROUGH.EXTERNALFORMAT \THROUGHIN \THROUGHBACKCCODE \THROUGHOUTCHARFN) + (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\CREATE.THROUGH.EXTERNALFORMAT]) + + + +(* ; "EXTERNALFORMAT declaration and related functions (originally on FILEIO)") + +(DECLARE%: DOEVAL@COMPILE DONTCOPY +(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE + +(DATATYPE EXTERNALFORMAT ((EOLVALID FLAG) (* ; "If true, the value of EOL field will replace the EOLCONVENTION field of the resulted stream. (Can't test EOL because it is always something)") + (EOL BITS 2) + (UNSTABLE FLAG) (* ; "T if (like XCCS runcodes) the byte encoding of a given character can change by other signals in the file, NIL if every charactercode has a single byte encoding (like UTF-8). ") + (INCCODEFN POINTER) (* ; + "Called with STREAM and 2 optional arguments, BYTECOUNTVAR and BYTECOUNTVAL") + (PEEKCCODEFN POINTER) (* ; + "Called with three arguments -- STREAM, NOERROR, and EOL") + (BACKCCODEFN POINTER) (* ; + "Called with STREAM and optional BYTECOUNTVAR and BYTECOUNTVAL") + (OUTCHARFN POINTER) (* ; + "Called with two arguments -- STREAM and CHARCODE") + (NAME POINTER) (* ; + "keyword name of this format, provided to \INSTALL.EXTERNALFORMAT") + (FORMATBYTESTREAMFN POINTER) (* ; "Function to copy the format state of a given stream to an IO stream that allows formatted byte sequences to be examined") + (EF1 POINTER) (* ; + "Extra fields for use of particular formats. Possibly to hold standardized translation tables") + (EF2 POINTER))) +) + +(/DECLAREDATATYPE 'EXTERNALFORMAT '(FLAG (BITS 2) + FLAG POINTER POINTER POINTER POINTER POINTER POINTER POINTER + POINTER) + '((EXTERNALFORMAT 0 (FLAGBITS . 0)) + (EXTERNALFORMAT 0 (BITS . 17)) + (EXTERNALFORMAT 0 (FLAGBITS . 48)) + (EXTERNALFORMAT 0 POINTER) + (EXTERNALFORMAT 2 POINTER) + (EXTERNALFORMAT 4 POINTER) + (EXTERNALFORMAT 6 POINTER) + (EXTERNALFORMAT 8 POINTER) + (EXTERNALFORMAT 10 POINTER) + (EXTERNALFORMAT 12 POINTER) + (EXTERNALFORMAT 14 POINTER)) + '16) + +(* "END EXPORTED DEFINITIONS") + +) + +(/DECLAREDATATYPE 'EXTERNALFORMAT '(FLAG (BITS 2) + FLAG POINTER POINTER POINTER POINTER POINTER POINTER POINTER + POINTER) + '((EXTERNALFORMAT 0 (FLAGBITS . 0)) + (EXTERNALFORMAT 0 (BITS . 17)) + (EXTERNALFORMAT 0 (FLAGBITS . 48)) + (EXTERNALFORMAT 0 POINTER) + (EXTERNALFORMAT 2 POINTER) + (EXTERNALFORMAT 4 POINTER) + (EXTERNALFORMAT 6 POINTER) + (EXTERNALFORMAT 8 POINTER) + (EXTERNALFORMAT 10 POINTER) + (EXTERNALFORMAT 12 POINTER) + (EXTERNALFORMAT 14 POINTER)) + '16) +(ADDTOVAR SYSTEMRECLST + +(DATATYPE EXTERNALFORMAT ((EOLVALID FLAG) + (EOL BITS 2) + (UNSTABLE FLAG) + (INCCODEFN POINTER) + (PEEKCCODEFN POINTER) + (BACKCCODEFN POINTER) + (OUTCHARFN POINTER) + (NAME POINTER) + (FORMATBYTESTREAMFN POINTER) + (EF1 POINTER) + (EF2 POINTER))) +) +(DEFINEQ + +(\EXTERNALFORMAT + [LAMBDA (STREAM NEWFORMAT/NAME) (* ; "Edited 10-Sep-2021 20:44 by rmk:") + (* ; "Edited 26-Feb-91 13:20 by nm") + +(* ;;; ";;; RMK July 2020: Added interface for per-device default external format. \DO.PARAMS.AT.OPEN will make that call even if it is not specified from the open. STREAMPROP is fixed to call \EXTERNALFORMAT to set the property EXTERNALFORMAT, to export a user-level way of manipulating this.") + +(* ;;; "") + +(* ;;; "If NEWFORMAT/NAME is nil, just returns the current external format name of STREAM. If NEWFORMAT/NAME is supplied and it is or names an external format, then the external format of STREAM is set to that format.") + +(* ;;; "") + +(* ;;; ":DEFAULT means the default external format for STREAM's filedevice") + +(* ;;; "The all-device default is in *DEFAULT-EXTERNALFORMAT* or the DEFAULTEXTERNALFORMAT field of the file device. The list currently has priority since that makes it easier for a user without EXPORTS.ALL to systematically override. That may or may not be a useful capability. ") + + (\DTEST STREAM 'STREAM) + (SETQ SAVEDNAME (fetch DEVICENAME of (fetch DEVICE of STREAM))) + (SETQ SAVEDDEFAULTFORMATNAME (fetch (FDEV DEFAULTEXTERNALFORMAT) of (fetch DEVICE + of STREAM))) + (SETQ FOUNDFORMAT (FIND-FORMAT SAVEDDEFAULTFORMATNAME T)) + (CL:WHEN NEWFORMAT/NAME + (CL:WHEN (type? READER-ENVIRONMENT NEWFORMAT/NAME) + (SETQ NEWFORMAT/NAME (fetch (READER-ENVIRONMENT REFORMAT) of NEWFORMAT/NAME))) + [LET (EXTFORMAT) + [COND + ((type? EXTERNALFORMAT NEWFORMAT/NAME) + (SETQ EXTFORMAT NEWFORMAT/NAME)) + (T (CL:WHEN (EQ NEWFORMAT/NAME :DEFAULT) + (SETQ NEWFORMAT/NAME (OR (CADR (ASSOC (fetch DEVICENAME + of (fetch DEVICE of + STREAM)) + *DEFAULT-EXTERNALFORMATS*)) + (fetch (FDEV DEFAULTEXTERNALFORMAT) + of (fetch DEVICE of STREAM)) + *DEFAULT-EXTERNALFORMAT*))) + (SETQ EXTFORMAT (FIND-FORMAT NEWFORMAT/NAME)) + (CL:UNLESS EXTFORMAT (ERROR NEWFORMAT/NAME + "is not a registered external format name")) + (CL:UNLESS (type? EXTERNALFORMAT EXTFORMAT) + (ERROR "INVALID EXTERNALFORMAT " EXTFORMAT] + (UNINTERRUPTABLY + (freplace (STREAM EXTERNALFORMAT) of STREAM with EXTFORMAT) + (CL:WHEN (ffetch (EXTERNALFORMAT EOLVALID) of EXTFORMAT) + (freplace (STREAM EOLCONVENTION) of STREAM with (ffetch + (EXTERNALFORMAT + EOL) of + EXTFORMAT + ))) + (freplace (STREAM OUTCHARFN) of STREAM with (ffetch (EXTERNALFORMAT + OUTCHARFN) + of EXTFORMAT)) + (freplace (STREAM INCCODEFN) of STREAM with (ffetch (EXTERNALFORMAT + INCCODEFN) + of EXTFORMAT)) + (freplace (STREAM PEEKCCODEFN) of STREAM with (ffetch ( + EXTERNALFORMAT + PEEKCCODEFN) + of EXTFORMAT)) + (freplace (STREAM BACKCCODEFN) of STREAM with (ffetch ( + EXTERNALFORMAT + BACKCCODEFN) + of EXTFORMAT)))]) + (ffetch (EXTERNALFORMAT NAME) of (fetch (STREAM EXTERNALFORMAT) of STREAM]) + +(MAKE-EXTERNALFORMAT + [LAMBDA (NAME INCCODEFN PEEKCCODEFN BACKCCODEFN OUTCHARFN FORMATBYTESTREAMFN EOL UNSTABLE) + (* ; "Edited 10-Sep-2021 19:47 by rmk:") + + (* ;; "Compiled creator for EXTERNALFORMAT so that declaration (EXPORTS.ALL) is not needed. If EOL is not specified, then EOLVALID is also NIL") + + (SETQ EOL (SELECTC EOL + ((LIST 'LF LF.EOLC) + LF.EOLC) + ((LIST 'CR CR.EOLC) + CR.EOLC) + ((LIST 'CRLF CRLF.EOLC) + CRLF.EOLC) + (NIL) + (SHOULDNT))) + (\INSTALL.EXTERNALFORMAT (CREATE EXTERNALFORMAT + NAME _ NAME + INCCODEFN _ INCCODEFN + PEEKCCODEFN _ PEEKCCODEFN + BACKCCODEFN _ BACKCCODEFN + OUTCHARFN _ OUTCHARFN + FORMATBYTESTREAMFN _ FORMATBYTESTREAMFN + EOLVALID _ EOL + EOL _ (OR EOL LF.EOLC) + UNSTABLE _ UNSTABLE]) +) +(DEFINEQ + +(\INSTALL.EXTERNALFORMAT + [LAMBDA (EXTFORMAT/NAME EXTERNALFORMAT) (* ; "Edited 5-Aug-2021 14:22 by rmk:") + +(* ;;; "Register an instance of the datatype EXTERNALFORMAT.") + +(* ;;; "For backward compatibility, the first argument can be a NAME with the second argument being the format. If so, the NAME must match the name inside the format") + + (LET (NAME) + (IF EXTERNALFORMAT + THEN + + (* ;; "Backwards compatibility") + + (SETQ NAME (MKATOM EXTFORMAT/NAME)) + (IF (EQ NAME (FETCH (EXTERNALFORMAT NAME) OF EXTERNALFORMAT)) + ELSEIF (FETCH (EXTERNALFORMAT NAME) OF EXTERNALFORMAT) + THEN (ERROR "Mismatch of specified name and name of the external format") + ELSE (REPLACE (EXTERNALFORMAT NAME) OF EXTERNALFORMAT WITH + NAME)) + ELSE (SETQ EXTERNALFORMAT EXTFORMAT/NAME) + (SETQ NAME (FETCH (EXTERNALFORMAT NAME) OF EXTERNALFORMAT))) + (IF (type? EXTERNALFORMAT EXTERNALFORMAT) + THEN (\REMOVE.EXTERNALFORMAT NAME) + (push *EXTERNALFORMATS* EXTERNALFORMAT) + ELSE (ERROR "INVALID EXTERNALFORMAT " EXTERNALFORMAT)) + EXTERNALFORMAT]) + +(\REMOVE.EXTERNALFORMAT + [LAMBDA (NAME/EXTFORMAT) (* ; "Edited 5-May-2021 15:42 by rmk:") + +(* ;;; "Deregisters external format EXTERNALFORMAT .") + + (SETQ NAME/EXTFORMAT (IF (TYPE? EXTERNALFORMAT NAME/EXTFORMAT) + THEN (FETCH (EXTERNALFORMAT NAME) OF NAME/EXTFORMAT) + ELSE (MKATOM NAME/EXTFORMAT))) + (SETQ *EXTERNALFORMATS* (DREMOVE (FIND EF IN *EXTERNALFORMATS* + SUCHTHAT (EQ NAME/EXTFORMAT (FETCH (EXTERNALFORMAT + NAME) + OF EF))) + *EXTERNALFORMATS*]) + +(FIND-FORMAT + [LAMBDA (NAME NOERROR) (* ; "Edited 7-Aug-2021 09:29 by rmk:") + (IF (TYPE? EXTERNALFORMAT NAME) + THEN NAME + ELSE (SETQ NAME (MKATOM NAME)) (* ; + "The EQMEMB allows for synonyms, the first of which should be canonical. E.g. (:UTF-8 :UTF8)") + (OR (FIND EF IN *EXTERNALFORMATS* SUCHTHAT (EQ NAME (FETCH ( + EXTERNALFORMAT + NAME) + OF EF))) + (CL:UNLESS NOERROR (ERROR NAME "is not an external format"]) +) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS *EXTERNALFORMATS* *DEFAULT-EXTERNALFORMATS* *DEFAULT-EXTERNALFORMAT*) +) + +(RPAQ? *EXTERNALFORMATS* NIL) + +(RPAQ? *DEFAULT-EXTERNALFORMATS* '((DSK :XCCS))) + +(RPAQ? *DEFAULT-EXTERNALFORMAT* :XCCS) + + + +(* ;; "Generic functions not compiled open (originally on LLREAD)") + +(DEFINEQ + +(\OUTCHAR + [LAMBDA (STREAM CODE) (* ; "Edited 10-Aug-2021 10:29 by rmk:") + + (* ;; "We can't do the EOL stuff here because we don't know whether BOUTs are legit.") + + (* ;; "Maybe the implementation function does something else, like move the X and Y positions. At best we could convert the EOL into either CR or LF, or into a CR-LF sequence that we pass by two calls to the lower implementation function.") + + (* ;; "") + + (* ;; "This would make CHARPOSITION generic:") + (* (FREPLACE (STREAM CHARPOSITION) + OF STREAM WITH (CL:IF + (EQ CODE (CHARCODE EOL)) 0 + (IPLUS16 1 (FFETCH + (STREAM CHARPOSITION) OF STREAM))))) + (CL:FUNCALL (OR (ffetch (STREAM OUTCHARFN) of STREAM) + \DEFAULTOUTCHAR) + STREAM CODE) + CODE]) + +(\INCCODE + [LAMBDA (STREAM BYTECOUNTVAR BYTECOUNTVAL) (* ; "Edited 7-Aug-2021 00:11 by rmk:") + + (* ;; "Calling functions pass the name of the BYTECOUNTVAR, or NIL. If non-NIL, implementing functions are required to SETQ *BYTECOUNTER* to the number of bytes read (positive) or backed up (negative).") + + (* ;; "Caller must bind BYTECOUNTVAR as a SPECVAR. BYTECOUNTVAL can be passed as the current value of BYTECOUNTVAR, to save a call to \EVALV1.") + + (IF BYTECOUNTVAR + THEN [LET ((*BYTECOUNTER* 0)) + (DECLARE (SPECVARS *BYTECOUNTER*)) + (PROG1 (CL:FUNCALL (OR (ffetch (STREAM INCCODEFN) of STREAM) + \DEFAULTINCCODE) + STREAM + '*BYTECOUNTER*) + (SET BYTECOUNTVAR (IDIFFERENCE (OR BYTECOUNTVAL (\EVALV1 BYTECOUNTVAR)) + *BYTECOUNTER*)))] + ELSE (CL:FUNCALL (OR (ffetch (STREAM INCCODEFN) of STREAM) + \DEFAULTINCCODE) + STREAM]) + +(\BACKCCODE + [LAMBDA (STREAM BYTECOUNTVAR BYTECOUNTVAL) (* ; "Edited 14-Aug-2021 00:26 by rmk:") + + (* ;; +"Format function returns T if the backup succeed, NIL otherwise (e.g at the beginning of the file)") + + (IF BYTECOUNTVAR + THEN [LET ((*BYTECOUNTER* 0)) + (DECLARE (SPECVARS *BYTECOUNTER*)) + (PROG1 (CL:FUNCALL (OR (ffetch (STREAM BACKCCODEFN) of STREAM) + \DEFAULTBACKCCODE) + STREAM T) + (SET BYTECOUNTVAR (IPLUS (OR BYTECOUNTVAL (\EVALV1 BYTECOUNTVAR)) + *BYTECOUNTER*)))] + ELSE (CL:FUNCALL (OR (ffetch (STREAM BACKCCODEFN) of STREAM) + \DEFAULTBACKCCODE) + STREAM]) + +(\BACKCCODE.EOLC + [LAMBDA (STREAM BYTECOUNTVAR BYTECOUNTVAL) (* ; "Edited 14-Aug-2021 00:27 by rmk:") + + (* ;; "If the EOLCONVENTION is CRLF, and the first backup is over an LF encoding, this looks to see whether the preceding bytes encode a CR and if so, backs up over those.") + + (* ;; "Within this we operate at the external-format implementation level.") + + (* ;; "Counting is unusual in general (mostly just COPYCHARS and PFCOPYBYTES) , and counting while backing up is even rarer. So for simplicity here we just count by looking at the byte pointer.") + + (LET [(STARTPOS (CL:WHEN BYTECOUNTVAR (\GETFILEPTR STREAM] + + (* ;; "In almost all cases, we just execute the first backup") + + (PROG1 (CL:WHEN (CL:FUNCALL (OR (ffetch (STREAM BACKCCODEFN) of STREAM) + \DEFAULTBACKCCODE) + STREAM) + (IF (AND (EQ CRLF.EOLC (FETCH (STREAM EOLCONVENTION) OF STREAM)) + (EQ (CHARCODE LF) + (CL:FUNCALL (OR (ffetch (STREAM PEEKCCODEFN) of STREAM) + \DEFAULTPEEKCCODE) + STREAM))) + THEN + + (* ;; + "We just backed over an LF in a CRLF file. If we go one more, do we get a CR?") + + (CL:WHEN (CL:FUNCALL (OR (ffetch (STREAM BACKCCODEFN) of STREAM + ) + \DEFAULTBACKCCODE) + STREAM) + (CL:UNLESS (EQ (CHARCODE CR) + (CL:FUNCALL (OR (ffetch (STREAM PEEKCCODEFN) + of STREAM) + \DEFAULTPEEKCCODE) + STREAM)) + + (* ;; "Not a preceding CR, reread it.") + + (CL:FUNCALL (OR (ffetch (STREAM INCCODEFN) of STREAM) + \DEFAULTINCCODE) + STREAM)) + T) + ELSE T)) + (CL:WHEN BYTECOUNTVAR + [SET BYTECOUNTVAR (IPLUS (OR BYTECOUNTVAL (\EVALV1 BYTECOUNTVAR)) + (IDIFFERENCE STARTPOS (\GETFILEPTR STREAM]))]) + +(\PEEKCCODE + [LAMBDA (STREAM NOERROR EOL) (* ; "Edited 14-Jun-2021 12:40 by rmk:") + (\CHECKEOLC (CL:FUNCALL (OR (ffetch (STREAM PEEKCCODEFN) of STREAM) + \DEFAULTPEEKCCODE) + STREAM NOERROR) + EOL STREAM T]) + +(\PEEKCCODE.NOEOLC + [LAMBDA (STREAM NOERROR) (* ; "Edited 27-Jun-2021 23:26 by rmk:") + (CL:FUNCALL (OR (ffetch (STREAM PEEKCCODEFN) of STREAM) + \DEFAULTPEEKCCODE) + STREAM NOERROR]) + +(\INCCODE.EOLC + [LAMBDA (STREAM EOLC BYTECOUNTVAR BYTECOUNTVAL) (* ; "Edited 8-Aug-2021 14:52 by rmk:") + + (* ;; + "EOL conversion around essentially a copy of \INCCODE but avoids the extra function call.") + + (* ;; " EOLC of NIL means all patterns go to EOL") + + (IF BYTECOUNTVAR + THEN [LET (*BYTECOUNTER* CODE) + (DECLARE (SPECVARS *BYTECOUNTER*)) + + (* ;; "The INCCODEFN first sets *BYTECOUNTER*") + + (CL:UNLESS BYTECOUNTVAL + (SETQ BYTECOUNTVAL (\EVALV1 BYTECOUNTVAR))) + (SETQ CODE (CL:FUNCALL (OR (ffetch (STREAM INCCODEFN) of STREAM) + \DEFAULTINCCODE) + STREAM T)) + + (* ;; "Update according to the number of first-char (CR or LF) bytes") + + (SETQ BYTECOUNTVAL (IDIFFERENCE BYTECOUNTVAL *BYTECOUNTER*)) + (SETQ *BYTECOUNTER* 0) + + (* ;; + "*BYTECOUNTER* will now be reset to the number of LF-after-CR bytes, if any") + + (PROG1 (\CHECKEOLC CODE (OR EOLC (FFETCH (STREAM EOLCONVENTION) + OF STREAM)) + STREAM NIL T) + + (* ;; "Post the results") + + (SET BYTECOUNTVAR (IDIFFERENCE BYTECOUNTVAL *BYTECOUNTER*)))] + ELSE (\CHECKEOLC (CL:FUNCALL (OR (ffetch (STREAM INCCODEFN) of STREAM) + \DEFAULTINCCODE) + STREAM) + (OR EOLC (FFETCH (STREAM EOLCONVENTION) OF STREAM)) + STREAM]) + +(\FORMATBYTESTREAM + [LAMBDA (STREAM BYTESTREAM) (* ; "Edited 24-Jun-2021 17:26 by rmk:") + + (* ;; "Create or modify a stream that will simulate the current character input/output byte sequences of STREAM. The set up here does what is common to all formats: an IO stream starting with STREAM external format and EOL.") + + (* ;; "If the format has its own FORMATBYTESTREAMFN function, that is applied to copy any other state. (Currently that function is a property of the format, not carried over into a stream field that can be changed dynamically.)") + + (CL:UNLESS (AND (STREAMP BYTESTREAM) + (\IOMODEP STREAM 'BOTH)) + (SETQ BYTESTREAM (OPENSTREAM '{NODIRCORE} 'BOTH))) + (LET ((FORMAT (FETCH (STREAM EXTERNALFORMAT) OF STREAM)) + (EOLC (FETCH (STREAM EOLCONVENTION) OF STREAM))) + (\EXTERNALFORMAT BYTESTREAM FORMAT) + (CL:WHEN (EQ EOLC ANY.EOLC) + (SETQ EOLC (OR (FETCH (EXTERNALFORMAT EOL) OF FORMAT) + LF.EOLC))) + (REPLACE (STREAM EOLCONVENTION) OF BYTESTREAM WITH EOLC) + (SETFILEPTR BYTESTREAM 0) + (SETFILEINFO BYTESTREAM 'ENDOFSTREAMOP (FUNCTION NILL)) + (CL:WHEN (FETCH (EXTERNALFORMAT FORMATBYTESTREAMFN) OF FORMAT) + (APPLY* (FETCH (EXTERNALFORMAT FORMATBYTESTREAMFN) OF FORMAT) + STREAM BYTESTREAM)) + BYTESTREAM]) + +(\CHECKEOLC.CRLF + [LAMBDA (STREAM PEEKBINFLG COUNTP) (* ; "Edited 6-Aug-2021 23:30 by rmk:") + + (* ;; "This is called only when a CR has been read and EOLC is either any or CRLF. This returns EOL if the next code is an LF") + + (* ;; "If COUNTP, that sets *BYTECOUNTER* freely with the number of LF bytes.") + + (DECLARE (USEDFREE *BYTECOUNTER*)) + (LET (CH) + [SETQ CH (COND + [PEEKBINFLG + + (* ;; + "T from PEEKC. In this case, must leave the fileptr where it was.") + + (* ;; "The CR itself hasn't been read, just peeked. So here we have to read it, then peek at the next character to see if it is an LF, and then back out the CR") + + (COND + ([EQ (CHARCODE LF) + (UNINTERRUPTABLY + + (* ;; " Since we are going to \BACKCCODE back the peeked character, we don't need to update the counter variable") + + (\INCCODE STREAM) + (PROG1 (\PEEKCCODE STREAM T 'NOEOLC) + + (* ;; + "This has to be a call to \PEEKCODE that doesn't itself to the checkeolc") + + (* ;; + "LF must be the next char after the CR. We back up over the CR that \INCCODE just read.") + + (\BACKCCODE STREAM)))] + + (* ;; "Got the CRLF, it's an EOL") + + (CHARCODE EOL)) + (T (CHARCODE CR] + ((EQ (CHARCODE LF) + (\PEEKCCODE STREAM T 'NOEOLC)) + + (* ;; "Since we aren't peeking, the CR has actually been read, and we are entitled to read the LF that we just peeked at.") + + (IF COUNTP + THEN (LET (NUMLFBYTES) + (DECLARE (SPECVARS NUMLFBYTES)) + (\INCCODE STREAM 'NUMLFBYTES 0) + (ADD *BYTECOUNTER* NUMLFBYTES)) + ELSE (\INCCODE STREAM)) + (CHARCODE EOL)) + (T (CHARCODE CR] + CH]) +) +(DECLARE%: DOEVAL@COMPILE DONTCOPY +(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE + +(PUTPROPS \CHECKEOLC MACRO [OPENLAMBDA (CH EOLC STRM PEEKBINFLG COUNTP) + (COND + ((EQ EOLC 'NOEOLC) + CH) + (T (SELCHARQ CH + (LF (SELECTC (OR EOLC (FFETCH (STREAM + EOLCONVENTION + ) + OF STRM)) + ((LIST LF.EOLC ANY.EOLC) + (CHARCODE EOL)) + (CHARCODE LF))) + (CR (SELECTC (OR EOLC (FFETCH (STREAM + EOLCONVENTION + ) + OF STRM)) + (CR.EOLC (CHARCODE EOL)) + ((LIST ANY.EOLC CRLF.EOLC) + (\CHECKEOLC.CRLF STRM PEEKBINFLG + COUNTP)) + (CHARCODE CR))) + CH]) +) + +(* "END EXPORTED DEFINITIONS") + +) + + + +(* ;; "Also from FILEIO, but not clear that this is or ever has been used.") + +(DEFINEQ + +(\CREATE.THROUGH.EXTERNALFORMAT + [LAMBDA NIL (* ; "Edited 23-Jun-2021 13:34 by rmk:") + +(* ;;; "Create an instance of EXTERNALFORMAT datatype and install it with :THROUGH as its name. EOL is adjusted to CR so as not to do any eol conversion on this stream.") + + (\INSTALL.EXTERNALFORMAT (create EXTERNALFORMAT + NAME _ :THROUGH + INCCODEFN _ (FUNCTION \THROUGHIN) + PEEKCCODEFN _ (FUNCTION \PEEKBIN) + BACKCCODEFN _ (FUNCTION \THROUGHBACKCCODE) + OUTCHARFN _ (FUNCTION \THROUGHOUTCHARFN) + EOL _ CR.EOLC]) + +(\THROUGHIN + [LAMBDA (STREAM COUNTP) (* ; "Edited 6-Aug-2021 16:13 by rmk:") + +(* ;;; "Read in a single byte from STREAM and returns it without any character conversion, just through as if.") + +(* ;;; "If COUNTP is non-NIL, the byte counter is always set to 1.") + + (DECLARE (USEDFREE *BYTECOUNTER*)) + (CL:WHEN COUNTP (SETQ *BYTECOUNTER* 1)) + (\BIN STREAM]) + +(\THROUGHBACKCCODE + [LAMBDA (STREAM COUNTP) (* ; "Edited 6-Aug-2021 16:14 by rmk:") + (DECLARE (USEDFREE *BYTECOUNTER*)) + (CL:WHEN (\BACKFILEPTR STREAM) + (CL:WHEN COUNTP (SETQ *BYTECOUNTER* -1)) + T)]) + +(\THROUGHOUTCHARFN + [LAMBDA (OUTSTREAM CHARCODE) (* ; "Edited 26-Feb-91 13:44 by nm") + +(* ;;; "Encoder for THROUGH format.") + + (COND + ((> CHARCODE 255) + (\BOUT OUTSTREAM (\CHARSET CHARCODE)) + (\BOUT OUTSTREAM (\CHAR8CODE CHARCODE))) + (T (\BOUT OUTSTREAM CHARCODE]) +) +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(\CREATE.THROUGH.EXTERNALFORMAT) +) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (5657 12044 (\EXTERNALFORMAT 5667 . 10729) (MAKE-EXTERNALFORMAT 10731 . 12042)) (12045 +15158 (\INSTALL.EXTERNALFORMAT 12055 . 13504) (\REMOVE.EXTERNALFORMAT 13506 . 14337) (FIND-FORMAT +14339 . 15156)) (15488 27986 (\OUTCHAR 15498 . 16634) (\INCCODE 16636 . 17822) (\BACKCCODE 17824 . +18718) (\BACKCCODE.EOLC 18720 . 21483) (\PEEKCCODE 21485 . 21801) (\PEEKCCODE.NOEOLC 21803 . 22065) ( +\INCCODE.EOLC 22067 . 23926) (\FORMATBYTESTREAM 23928 . 25418) (\CHECKEOLC.CRLF 25420 . 27984)) (29929 + 31772 (\CREATE.THROUGH.EXTERNALFORMAT 29939 . 30741) (\THROUGHIN 30743 . 31163) (\THROUGHBACKCCODE +31165 . 31432) (\THROUGHOUTCHARFN 31434 . 31770))))) +STOP diff --git a/sources/EXTERNALFORMAT.LCOM b/sources/EXTERNALFORMAT.LCOM new file mode 100644 index 0000000000000000000000000000000000000000..4526a7602d144dd463e9f70c42ad7262b146425a GIT binary patch literal 7957 zcmb_hO>AS;74}aWg3E+B6QEO6dgY4hC2fMAe_|(0)AwvYkKe@h^Vm+vNKr*%dnQgi z@yO1gB0yq6Rf$!nwCWE?RjX1VRjNW}vVbnU=qha3P^m1asH(2IiPT*;)9>8-e*F9c zMPdZ;edpeH?>*;y=ey_JCuOv(Uep$|dR|-9i&=v`RZ`RI>J^QJ^kP*j=k-b{#GWc^ zYNo2D@&n?OTG5yso)1VgK^mi~T84$>mBmWq_F^O)ky$vo8edtBMM6vp)!MgiH(QN5 zYag-@3%r!6tiN)3quc0o*A8}Ww{{NK^6lDAYwcE}-fFxUU5c;WY#uF&r?qbTPN&xB zu4!A?R#DAojdDS)EV_VM|^wtE|FHIocTB_^|N4xsWzNdTwB!VE)& z+nA04MeRB9^h{ALXb^>2r3wrcSe8XtMcvdgyd%q^;t60?H}d8bW><`5jg4YPOf=6t z|MmGjK4sE_f8y_1fIpo1Y7=h3UTw184A8*ZlzMu>>|8sWn)wR}f31r5rgnY3;EYG* z!Z*~dNeH9o*CRhh{;$k)a(*vupQQE+-!D_8Xa&$GQ>9he`QE!BmG_CJhW_r=-4Ks=iM8cask7p_?p!#;UesKOq@8I}5 z_VYfT_m7_x&wt3)TRsR{z90W~@3kqy=I$fU)6X~S%G^}1uFiRS_0*iNS5MDP^y-

?Di? zTOwH8xF;5ZsE?Rn%3EHK$44Y^5>-S5TjX$lZ_#SL$pe^oA3q_4xw)y=m0h1nBwIZ} zA}5dM_^6)BE&TN-$j-0xw^bhgDj6pnH={QhX4_@0U~FoGMnV*tp)Rw+x>_{~(0wJ! z7Th`^{E~?gLgELv^2QwEpRv6OM;eF;ufqBEmnKC|{YbcU*TcOL z40?0^)49D_{>0tE{WIfzPti?Bp8s4w{YUfo?>XPr@n1bsEWt9uL4-ov5hIKl8Q}#u zaoAsAuVJA)?41Dza_ILnz1tu-at#3(%Q!H}I!xjdCb_H3jIhOHd$Xqt>b-9(9HHDI zgU0x@dHe|(gru14Q1Ia>ESOwrWgcOshGiL~ zh~Os99F6U=(OFu|F0>c1BBdK9(g%S|H&i+Vml{|h?d3~Q|s;cG-0 zd~DAR1329l=SufMp}h7T|p08|o93-5ZPA8#CD)8~dK$>+!26i~F>#v*fA2 z67+f%PT4J=K0T|ZPN(XeOL8A`$Mj~bVLs*H>NI%+xsz69(Pg%+VH2A&OiHG=H-fEl z*lgQ}j9baLtz_)WRMK7zYOV-1=Y^V=O*NZ?D*nw@Q4FzEjIIb3ahg~vT5hvfS;Bdn zwiHW{&m!crW!{p}it|<&tr+*{3R+R#N}?tFoj{9{2(?@-85KMTs4ag{S0`;(+xtVx zyJAc2;~i3@OBP@qT-=}X0~hx%xwFh7q2wSpJxd@tyL>wF+)U8RjWm0IOAP(sks!|b z6J0r5MK=cem4o%^*;e5EByPVlp&aC=XYW645BiF7P{5!I=YJw}O*}Uj^iC=V#p#Pp zVAH{%KD3>OlmlaWdiG<>b2!!#%iLLVEarF%nShm}A?q|l)oICQN@rzs0@%Ib z8s*Lq*_E5`YzhEQObW2)00?(|h&58#U$#krESVA+(p`Ni6}Q z|NN(|3p1_249s)#iPg1#e(&GZ_coo=PD`&7B9|z4p@@tT zHA66<+meu4z~y+uSYAE#QMs*}!*2bmK?~wHsOIq7NP2TciHL}0z??@!L=XXI)KO%I zEY)H^L3S?oBeFxTMM3DQ^FT|cFKl#sJ(FI~MCy0%dVUd9{ONa6oZxmRdz{)fgWd@R z)BuEDPv<_~o!sBjRpF37zrQYgb?@3$?y7I}*4?i9S+8~BINoaoj>F`x1*?1iocBCQ zE`v{f=fCPHdrj`K*YL`#S5sKZW*_h{b|HeoTsr9Un`_^_IwKapG`M&_PMn1YaI#mo za1x2*L~sKIMHz}GusM}o!+re$m5i8xVhF8%XbsjI7PL&~kY~**ksL-YHNoY$4Z-pg zKavKOJLWBM9&zj3o8u1Pf4Bg(vq=hTHUR}^eX1yPb(s6D98aoH-=c1KPo&K{N?moI zPoO#za>IzxXMx{XjrZxezWOMg*OCmTfO+UHir-}+2Q?o{)iOg7F?d%IMWI#FP=WAU z2b8GWx=}#NK*xa)mJpC~bSMdyafG@v6;!y$H+8yAqRhRRF|uL?qeQi>xkO?x!C?-~ z(Mc^ff)qPtRC5fG{!-D%=;gFg)?Q)AGDs{aVgMN?2g2(cg?yH~jUQGcE@9F+PLVuM zDe^4=4Hmk8HqQf~oBXFJ5C&SYgouGJJ z={E|Jb(2$(0Q3ijxV>De=E}y#mE2&dMfQbvnMWZSf1dt)Q(Oa4bQ@+YJsKu536t7 zdQkH;VK$(Fl&1hkM9mL&S8y&T_&|V&6`c!M73U|Yjw_j#(Zd= zNf|AjSIZhMfini>#R_c@mScg8QLLto(sd?jTP34hWl|YsOF2^+*x&p-rqPQ!SZQQ8 zlPcFMWBUTxVr7VNM_iC$4L)+rjm?-+KhRg^VumYuBZcaQ?!||z$}#ttxEC4I1FDk( zq&S~Y8lDkUfFWbv#=O$C4Wp{TxA?@tR=3jW3T#P}j(KIl9>g3t5FV~H4jY|jjX4gd zt4RB!M*DW-a1a9dJYAb|2ynZaQDIYJKW_#c4i&jyAB#FoD+{$q)f_sMN(`hVr0-Y| z4r8#Orpu_RoJoYq?C2nKsI6|B-RQJ$nLz(8+r5L!S29VfvD3kA5$P(48!*(JZlk_Lp+R;DY=1W6_mQd9bcolI*o=co9aVXN@sP_KY6jsaf~~}) z&t8)ho(CyEV@{P(t14Y{T5xic1C}&Vmd&eIn3U416&9Ii{HbK{uPi>?0?k*z!M3*tHZDmho50`r zK0#KaZQ$F1kaplan>Local>medley3.5>git-medley>sources>FILEIO.;92 178421 +(FILECREATED "25-Sep-2021 21:02:29"  +{DSK}kaplan>Local>medley3.5>git-medley>sources>FILEIO.;99 162362 - changes to%: (RECORDS FDEV) + changes to%: (VARS FILEIOCOMS) + (RECORDS FDEV) - previous date%: "13-Aug-2021 18:39:18" -{DSK}kaplan>Local>medley3.5>git-medley>sources>FILEIO.;91) + previous date%: "25-Sep-2021 17:25:04" +{DSK}kaplan>Local>medley3.5>git-medley>sources>FILEIO.;98) (* ; " @@ -51,20 +52,6 @@ Copyright (c) 1981-1993, 1999, 2020-2021 by Venue & Xerox Corporation. (RECORDS FDEV FILEGENOBJ))) (INITRECORDS FDEV) (SYSRECORDS FDEV)) - [COMS (* ; - "EXTERNALFORMAT declaration and related functions") - (DECLARE%: DOEVAL@COMPILE DONTCOPY (EXPORT (RECORDS EXTERNALFORMAT))) - (FNS MAKE-EXTERNALFORMAT) - (INITRECORDS EXTERNALFORMAT) - (SYSRECORDS EXTERNALFORMAT) - (FNS \INSTALL.EXTERNALFORMAT \REMOVE.EXTERNALFORMAT FIND-FORMAT \EXTERNALFORMAT) - (INITVARS [*DEFAULT-EXTERNALFORMATS* '((DSK :XCCS] - (*EXTERNALFORMATS* NIL)) - (GLOBALVARS *EXTERNALFORMATS* *DEFAULT-EXTERNALFORMATS* *DEFAULT-EXTERNALFORMAT*) - (EXPORT (INITVARS (*DEFAULT-EXTERNALFORMAT* :XCCS))) - (COMS (FNS \CREATE.THROUGH.EXTERNALFORMAT \THROUGHIN \THROUGHBACKCCODE - \THROUGHOUTCHARFN) - (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\CREATE.THROUGH.EXTERNALFORMAT] (COMS (* ; "Device operations") (FNS \DEFINEDEVICE \GETDEVICEFROMNAME \GETDEVICEFROMHOSTNAME \REMOVEDEVICE \REMOVEDEVICE.NAMES) @@ -573,9 +560,9 @@ Copyright (c) 1981-1993, 1999, 2020-2021 by Venue & Xerox Corporation. (DEFINEQ (STREAMPROP - [LAMBDA X (* rda%: "22-Aug-84 14:24") + [LAMBDA X (* rda%: "22-Aug-84 14:24") - (* ;; "general top level entry for both fetching and setting stream properties.") + (* ;; "general top level entry for both fetching and setting stream properties.") (COND ((IGREATERP X 2) @@ -588,24 +575,24 @@ Copyright (c) 1981-1993, 1999, 2020-2021 by Venue & Xerox Corporation. (T (\ILLEGAL.ARG NIL]) (GETSTREAMPROP - [LAMBDA (STREAM PROP) (* ; "Edited 29-Jun-2021 17:06 by rmk:") - (* rda%: "22-Aug-84 16:17") + [LAMBDA (STREAM PROP) (* ; "Edited 29-Jun-2021 17:06 by rmk:") + (* rda%: "22-Aug-84 16:17") (SELECTQ PROP ((FORMAT EXTERNALFORMAT) - (\EXTERNALFORMAT STREAM)) + (\EXTERNALFORMAT STREAM)) (ENDOFSTREAMOP (FETCH (STREAM ENDOFSTREAMOP) OF STREAM)) (LISTGET (fetch (STREAM OTHERPROPS) of STREAM) PROP]) (PUTSTREAMPROP - [LAMBDA (STREAM PROP VALUE) (* ; "Edited 29-Jun-2021 17:06 by rmk:") - (* rda%: "22-Aug-84 16:11") + [LAMBDA (STREAM PROP VALUE) (* ; "Edited 29-Jun-2021 17:06 by rmk:") + (* rda%: "22-Aug-84 16:11") (SELECTQ PROP ((FORMAT EXTERNALFORMAT) - (* ;; "Return the old name (=VALUE), not the format datum. Better design: the format should have it's name, and not have name as a separate property.") + (* ;; "Return the old name (=VALUE), not the format datum. Better design: the format should have it's name, and not have name as a separate property.") - (PROG1 (\EXTERNALFORMAT STREAM NIL) - (AND VALUE (\EXTERNALFORMAT STREAM VALUE)))) + (PROG1 (\EXTERNALFORMAT STREAM NIL) + (AND VALUE (\EXTERNALFORMAT STREAM VALUE)))) (ENDOFSTREAMOP (PROG1 (fetch (STREAM ENDOFSTREAMOP) of STREAM) (replace (STREAM ENDOFSTREAMOP) of STREAM with VALUE))) (PROG ((OLDDATA (fetch OTHERPROPS of STREAM)) @@ -614,7 +601,7 @@ Copyright (c) 1981-1993, 1999, 2020-2021 by Venue & Xerox Corporation. (OLDDATA (SETQ OLDVALUE (LISTGET OLDDATA PROP)) [COND (VALUE (LISTPUT OLDDATA PROP VALUE)) - (OLDVALUE (* ; "Remove the property") + (OLDVALUE (* ; "Remove the property") (COND ((EQ (CAR OLDDATA) PROP) @@ -629,7 +616,7 @@ Copyright (c) 1981-1993, 1999, 2020-2021 by Venue & Xerox Corporation. OLDVALUE) (VALUE (replace OTHERPROPS of STREAM with (LIST PROP VALUE)) - (* ; "know old value is NIL") + (* ; "know old value is NIL") NIL]) (STREAMP @@ -957,8 +944,7 @@ Copyright (c) 1981-1993, 1999, 2020-2021 by Venue & Xerox Corporation. OPENP _ (FUNCTION NILL) UNREGISTERFILE _ (FUNCTION NILL) CHARSETFN _ (FUNCTION \GENERIC.CHARSET) - BREAKCONNECTION _ (FUNCTION NILL) - DEFAULTEXTERNALFORMAT _ *DEFAULT-EXTERNALFORMAT*) + BREAKCONNECTION _ (FUNCTION NILL)) (RECORD FILEGENOBJ (NEXTFILEFN FILEINFOFN . GENFILESTATE)) ) @@ -1182,288 +1168,6 @@ Copyright (c) 1981-1993, 1999, 2020-2021 by Venue & Xerox Corporation. -(* ; "EXTERNALFORMAT declaration and related functions") - -(DECLARE%: DOEVAL@COMPILE DONTCOPY -(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE - -(DATATYPE EXTERNALFORMAT ((EOLVALID FLAG) (* ; "If true, the value of EOL field will replace the EOLCONVENTION field of the resulted stream. (Can't test EOL because it is always something)") - (EOL BITS 2) - (NIL BITS 1) - (INCCODEFN POINTER) (* ; - "Called with STREAM and 2 optional arguments, BYTECOUNTVAR and BYTECOUNTVAL") - (PEEKCCODEFN POINTER) (* ; - "Called with three arguments -- STREAM, NOERROR, and EOL") - (BACKCCODEFN POINTER) (* ; - "Called with STREAM and optional BYTECOUNTVAR and BYTECOUNTVAL") - (OUTCHARFN POINTER) (* ; - "Called with two arguments -- STREAM and CHARCODE") - (NAME POINTER) (* ; - "keyword name of this format, provided to \INSTALL.EXTERNALFORMAT") - (FORMATBYTESTREAMFN POINTER) (* ; "Function to copy the format state of a given stream to an IO stream that allows formatted byte sequences to be examined") - (EF1 POINTER) (* ; - "Extra fields for use of particular formats. Possibly to hold standardized translation tables") - (EF2 POINTER))) -) - -(/DECLAREDATATYPE 'EXTERNALFORMAT '(FLAG (BITS 2) - (BITS 1) - POINTER POINTER POINTER POINTER POINTER POINTER POINTER - POINTER) - '((EXTERNALFORMAT 0 (FLAGBITS . 0)) - (EXTERNALFORMAT 0 (BITS . 17)) - (EXTERNALFORMAT 0 (BITS . 48)) - (EXTERNALFORMAT 0 POINTER) - (EXTERNALFORMAT 2 POINTER) - (EXTERNALFORMAT 4 POINTER) - (EXTERNALFORMAT 6 POINTER) - (EXTERNALFORMAT 8 POINTER) - (EXTERNALFORMAT 10 POINTER) - (EXTERNALFORMAT 12 POINTER) - (EXTERNALFORMAT 14 POINTER)) - '16) - -(* "END EXPORTED DEFINITIONS") - -) -(DEFINEQ - -(MAKE-EXTERNALFORMAT - [LAMBDA (NAME INCCODEFN PEEKCCODEFN BACKCCODEFN OUTCHARFN FORMATBYTESTREAMFN EOL) - (* ; "Edited 1-Aug-2021 23:13 by rmk:") - - (* ;; "Compiled creator for EXTERNALFORMAT so that declaration (EXPORTS.ALL) is not needed. If EOL is not specified, then EOLVALID is also NIL") - - (SETQ EOL (SELECTC EOL - ((LIST 'LF LF.EOLC) - LF.EOLC) - ((LIST 'CR CR.EOLC) - CR.EOLC) - ((LIST 'CRLF CRLF.EOLC) - CRLF.EOLC) - (NIL) - (SHOULDNT))) - (\INSTALL.EXTERNALFORMAT (CREATE EXTERNALFORMAT - NAME _ NAME - INCCODEFN _ INCCODEFN - PEEKCCODEFN _ PEEKCCODEFN - BACKCCODEFN _ BACKCCODEFN - OUTCHARFN _ OUTCHARFN - FORMATBYTESTREAMFN _ FORMATBYTESTREAMFN - EOLVALID _ EOL - EOL _ (OR EOL LF.EOLC]) -) - -(/DECLAREDATATYPE 'EXTERNALFORMAT '(FLAG (BITS 2) - (BITS 1) - POINTER POINTER POINTER POINTER POINTER POINTER POINTER - POINTER) - '((EXTERNALFORMAT 0 (FLAGBITS . 0)) - (EXTERNALFORMAT 0 (BITS . 17)) - (EXTERNALFORMAT 0 (BITS . 48)) - (EXTERNALFORMAT 0 POINTER) - (EXTERNALFORMAT 2 POINTER) - (EXTERNALFORMAT 4 POINTER) - (EXTERNALFORMAT 6 POINTER) - (EXTERNALFORMAT 8 POINTER) - (EXTERNALFORMAT 10 POINTER) - (EXTERNALFORMAT 12 POINTER) - (EXTERNALFORMAT 14 POINTER)) - '16) -(ADDTOVAR SYSTEMRECLST - -(DATATYPE EXTERNALFORMAT ((EOLVALID FLAG) - (EOL BITS 2) - (NIL BITS 1) - (INCCODEFN POINTER) - (PEEKCCODEFN POINTER) - (BACKCCODEFN POINTER) - (OUTCHARFN POINTER) - (NAME POINTER) - (FORMATBYTESTREAMFN POINTER) - (EF1 POINTER) - (EF2 POINTER))) -) -(DEFINEQ - -(\INSTALL.EXTERNALFORMAT - [LAMBDA (EXTFORMAT/NAME EXTERNALFORMAT) (* ; "Edited 5-Aug-2021 14:22 by rmk:") - -(* ;;; "Register an instance of the datatype EXTERNALFORMAT.") - -(* ;;; "For backward compatibility, the first argument can be a NAME with the second argument being the format. If so, the NAME must match the name inside the format") - - (LET (NAME) - (IF EXTERNALFORMAT - THEN - - (* ;; "Backwards compatibility") - - (SETQ NAME (MKATOM EXTFORMAT/NAME)) - (IF (EQ NAME (FETCH (EXTERNALFORMAT NAME) OF EXTERNALFORMAT)) - ELSEIF (FETCH (EXTERNALFORMAT NAME) OF EXTERNALFORMAT) - THEN (ERROR "Mismatch of specified name and name of the external format") - ELSE (REPLACE (EXTERNALFORMAT NAME) OF EXTERNALFORMAT WITH - NAME)) - ELSE (SETQ EXTERNALFORMAT EXTFORMAT/NAME) - (SETQ NAME (FETCH (EXTERNALFORMAT NAME) OF EXTERNALFORMAT))) - (IF (type? EXTERNALFORMAT EXTERNALFORMAT) - THEN (\REMOVE.EXTERNALFORMAT NAME) - (push *EXTERNALFORMATS* EXTERNALFORMAT) - ELSE (ERROR "INVALID EXTERNALFORMAT " EXTERNALFORMAT)) - EXTERNALFORMAT]) - -(\REMOVE.EXTERNALFORMAT - [LAMBDA (NAME/EXTFORMAT) (* ; "Edited 5-May-2021 15:42 by rmk:") - -(* ;;; "Deregisters external format EXTERNALFORMAT .") - - (SETQ NAME/EXTFORMAT (IF (TYPE? EXTERNALFORMAT NAME/EXTFORMAT) - THEN (FETCH (EXTERNALFORMAT NAME) OF NAME/EXTFORMAT) - ELSE (MKATOM NAME/EXTFORMAT))) - (SETQ *EXTERNALFORMATS* (DREMOVE (FIND EF IN *EXTERNALFORMATS* - SUCHTHAT (EQ NAME/EXTFORMAT (FETCH (EXTERNALFORMAT - NAME) - OF EF))) - *EXTERNALFORMATS*]) - -(FIND-FORMAT - [LAMBDA (NAME NOERROR) (* ; "Edited 7-Aug-2021 09:29 by rmk:") - (IF (TYPE? EXTERNALFORMAT NAME) - THEN NAME - ELSE (SETQ NAME (MKATOM NAME)) (* ; - "The EQMEMB allows for synonyms, the first of which should be canonical. E.g. (:UTF-8 :UTF8)") - (OR (FIND EF IN *EXTERNALFORMATS* SUCHTHAT (EQ NAME (FETCH ( - EXTERNALFORMAT - NAME) - OF EF))) - (CL:UNLESS NOERROR (ERROR NAME "is not an external format"]) - -(\EXTERNALFORMAT - [LAMBDA (STREAM NEWFORMAT/NAME) (* ; "Edited 8-Aug-2021 14:30 by rmk:") - (* ; "Edited 26-Feb-91 13:20 by nm") - -(* ;;; ";;; RMK July 2020: Added interface for per-device default external format. \DO.PARAMS.AT.OPEN will make that call even if it is not specified from the open. STREAMPROP is fixed to call \EXTERNALFORMAT to set the property EXTERNALFORMAT, to export a user-level way of manipulating this.") - -(* ;;; "") - -(* ;;; "If NEWFORMAT/NAME is nil, just returns the current external format name of STREAM. If NEWFORMAT/NAME is supplied and it is or names an external format, then the external format of STREAM is set to that format.") - -(* ;;; "") - -(* ;;; ":DEFAULT means the default external format for STREAM's filedevice") - -(* ;;; "The all-device default is in *DEFAULT-EXTERNALFORMAT* or the DEFAULTEXTERNALFORMAT field of the file device. The list currently has priority since that makes it easier for a user without EXPORTS.ALL to systematically override. That may or may not be a useful capability. ") - - (\DTEST STREAM 'STREAM) - (CL:WHEN NEWFORMAT/NAME - (CL:WHEN (type? READER-ENVIRONMENT NEWFORMAT/NAME) - (SETQ NEWFORMAT/NAME (fetch (READER-ENVIRONMENT REFORMAT) of NEWFORMAT/NAME))) - [LET (EXTFORMAT) - [COND - ((type? EXTERNALFORMAT NEWFORMAT/NAME) - (SETQ EXTFORMAT NEWFORMAT/NAME)) - (T (CL:WHEN (EQ NEWFORMAT/NAME :DEFAULT) - (SETQ NEWFORMAT/NAME (OR (CADR (ASSOC (fetch DEVICENAME - of (fetch DEVICE of - STREAM)) - *DEFAULT-EXTERNALFORMATS*)) - (fetch (FDEV DEFAULTEXTERNALFORMAT) - of (fetch DEVICE of STREAM)) - *DEFAULT-EXTERNALFORMAT*))) - (SETQ EXTFORMAT (FIND-FORMAT NEWFORMAT/NAME)) - (CL:UNLESS EXTFORMAT (ERROR NEWFORMAT/NAME - "is not a registered external format name")) - (CL:UNLESS (type? EXTERNALFORMAT EXTFORMAT) - (ERROR "INVALID EXTERNALFORMAT " EXTFORMAT] - (UNINTERRUPTABLY - (freplace (STREAM EXTERNALFORMAT) of STREAM with EXTFORMAT) - (CL:WHEN (ffetch (EXTERNALFORMAT EOLVALID) of EXTFORMAT) - (freplace (STREAM EOLCONVENTION) of STREAM with (ffetch - (EXTERNALFORMAT - EOL) of - EXTFORMAT - ))) - (freplace (STREAM OUTCHARFN) of STREAM with (ffetch (EXTERNALFORMAT - OUTCHARFN) - of EXTFORMAT)) - (freplace (STREAM INCCODEFN) of STREAM with (ffetch (EXTERNALFORMAT - INCCODEFN) - of EXTFORMAT)) - (freplace (STREAM PEEKCCODEFN) of STREAM with (ffetch ( - EXTERNALFORMAT - PEEKCCODEFN) - of EXTFORMAT)) - (freplace (STREAM BACKCCODEFN) of STREAM with (ffetch ( - EXTERNALFORMAT - BACKCCODEFN) - of EXTFORMAT)))]) - (ffetch (EXTERNALFORMAT NAME) of (fetch (STREAM EXTERNALFORMAT) of STREAM]) -) - -(RPAQ? *DEFAULT-EXTERNALFORMATS* '((DSK :XCCS))) - -(RPAQ? *EXTERNALFORMATS* NIL) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS *EXTERNALFORMATS* *DEFAULT-EXTERNALFORMATS* *DEFAULT-EXTERNALFORMAT*) -) -(* "FOLLOWING DEFINITIONS EXPORTED") -(RPAQ? *DEFAULT-EXTERNALFORMAT* :XCCS) - -(* "END EXPORTED DEFINITIONS") - -(DEFINEQ - -(\CREATE.THROUGH.EXTERNALFORMAT - [LAMBDA NIL (* ; "Edited 23-Jun-2021 13:34 by rmk:") - -(* ;;; "Create an instance of EXTERNALFORMAT datatype and install it with :THROUGH as its name. EOL is adjusted to CR so as not to do any eol conversion on this stream.") - - (\INSTALL.EXTERNALFORMAT (create EXTERNALFORMAT - NAME _ :THROUGH - INCCODEFN _ (FUNCTION \THROUGHIN) - PEEKCCODEFN _ (FUNCTION \PEEKBIN) - BACKCCODEFN _ (FUNCTION \THROUGHBACKCCODE) - OUTCHARFN _ (FUNCTION \THROUGHOUTCHARFN) - EOL _ CR.EOLC]) - -(\THROUGHIN - [LAMBDA (STREAM COUNTP) (* ; "Edited 6-Aug-2021 16:13 by rmk:") - -(* ;;; "Read in a single byte from STREAM and returns it without any character conversion, just through as if.") - -(* ;;; "If COUNTP is non-NIL, the byte counter is always set to 1.") - - (DECLARE (USEDFREE *BYTECOUNTER*)) - (CL:WHEN COUNTP (SETQ *BYTECOUNTER* 1)) - (\BIN STREAM]) - -(\THROUGHBACKCCODE - [LAMBDA (STREAM COUNTP) (* ; "Edited 6-Aug-2021 16:14 by rmk:") - (DECLARE (USEDFREE *BYTECOUNTER*)) - (CL:WHEN (\BACKFILEPTR STREAM) - (CL:WHEN COUNTP (SETQ *BYTECOUNTER* -1)) - T)]) - -(\THROUGHOUTCHARFN - [LAMBDA (OUTSTREAM CHARCODE) (* ; "Edited 26-Feb-91 13:44 by nm") - -(* ;;; "Encoder for THROUGH format.") - - (COND - ((> CHARCODE 255) - (\BOUT OUTSTREAM (\CHARSET CHARCODE)) - (\BOUT OUTSTREAM (\CHAR8CODE CHARCODE))) - (T (\BOUT OUTSTREAM CHARCODE]) -) -(DECLARE%: DONTEVAL@LOAD DOCOPY - -(\CREATE.THROUGH.EXTERNALFORMAT) -) - - - (* ; "Device operations") (DEFINEQ @@ -3396,44 +3100,40 @@ update the map") (PUTPROPS FILEIO COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1999 2020 2021)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (28396 31886 (STREAMPROP 28406 . 28840) (GETSTREAMPROP 28842 . 29315) (PUTSTREAMPROP -29317 . 31734) (STREAMP 31736 . 31884)) (31929 34448 (\DEFPRINT.BY.NAME 31939 . 33091) ( -\STREAM.DEFPRINT 33093 . 34141) (\FDEV.DEFPRINT 34143 . 34446)) (34706 39747 (\GETACCESS 34716 . 35170 -) (\SETACCESS 35172 . 39745)) (63132 64385 (MAKE-EXTERNALFORMAT 63142 . 64383)) (65618 73447 ( -\INSTALL.EXTERNALFORMAT 65628 . 67077) (\REMOVE.EXTERNALFORMAT 67079 . 67910) (FIND-FORMAT 67912 . -68729) (\EXTERNALFORMAT 68731 . 73445)) (73770 75633 (\CREATE.THROUGH.EXTERNALFORMAT 73780 . 74582) ( -\THROUGHIN 74584 . 75008) (\THROUGHBACKCCODE 75010 . 75281) (\THROUGHOUTCHARFN 75283 . 75631)) (75741 -81710 (\DEFINEDEVICE 75751 . 78067) (\GETDEVICEFROMNAME 78069 . 78542) (\GETDEVICEFROMHOSTNAME 78544 - . 79588) (\REMOVEDEVICE 79590 . 80713) (\REMOVEDEVICE.NAMES 80715 . 81708)) (81750 106410 (\CLOSEFILE - 81760 . 82585) (\DELETEFILE 82587 . 82881) (\DEVICEEVENT 82883 . 84653) (\GENERATEFILES 84655 . 85133 -) (\GENERATENEXTFILE 85135 . 85786) (\GENERATEFILEINFO 85788 . 86249) (\GETFILENAME 86251 . 86640) ( -\GENERIC.OUTFILEP 86642 . 87112) (\OPENFILE 87114 . 89692) (\DO.PARAMS.AT.OPEN 89694 . 92247) ( -\RENAMEFILE 92249 . 92673) (\REVALIDATEFILE 92675 . 95277) (\PAGED.REVALIDATEFILELST 95279 . 96837) ( -\PAGED.REVALIDATEFILES 96839 . 98558) (\PAGED.REVALIDATEFILE 98560 . 100843) (\BUFFERED.REVALIDATEFILE - 100845 . 103131) (\BUFFERED.REVALIDATEFILELST 103133 . 104317) (\PRINT-REVALIDATION-RESULT 104319 . -104734) (\TRUNCATEFILE 104736 . 105127) (\FILE-CONFLICT 105129 . 106408)) (106446 111109 ( -\GENERATENOFILES 106456 . 108552) (\NULLFILEGENERATOR 108554 . 108798) (\NOFILESNEXTFILEFN 108800 . -110791) (\NOFILESINFOFN 110793 . 111107)) (111228 113136 (\FILE.NOT.OPEN 111238 . 111751) ( -\FILE.WONT.OPEN 111753 . 112081) (\ILLEGAL.DEVICEOP 112083 . 112365) (\IS.NOT.RANDACCESSP 112367 . -112813) (\STREAM.NOT.OPEN 112815 . 113134)) (113271 115569 (\FDEVINSTANCE 113281 . 115567)) (117119 -124493 (CNDIR 117129 . 118434) (DIRECTORYNAME 118436 . 122619) (DIRECTORYNAMEP 122621 . 123237) ( -HOSTNAMEP 123239 . 124046) (\ADD.CONNECTED.DIR 124048 . 124491)) (124538 151925 (\BACKFILEPTR 124548 - . 124736) (\BACKPEEKBIN 124738 . 125099) (\BACKBIN 125101 . 125452) (BIN 125454 . 125671) (\BIN -125673 . 125950) (\BINS 125952 . 126238) (BOUT 126240 . 126602) (\BOUT 126604 . 126919) (\BOUTS 126921 - . 127232) (COPYBYTES 127234 . 130566) (COPYCHARS 130568 . 134234) (COPYFILE 134236 . 135033) ( -\COPYOPENFILE 135035 . 138108) (\INFER.FILE.TYPE 138110 . 139064) (EOFP 139066 . 139363) (FORCEOUTPUT -139365 . 139612) (\FLUSH.OPEN.STREAMS 139614 . 139970) (CHARSET 139972 . 141636) (ACCESS-CHARSET -141638 . 141855) (GETEOFPTR 141857 . 142107) (GETFILEINFO 142109 . 145302) (\TYPE.FROM.FILETYPE 145304 - . 145774) (\FILETYPE.FROM.TYPE 145776 . 145955) (GETFILEPTR 145957 . 146209) (SETFILEINFO 146211 . -149824) (SETFILEPTR 149826 . 151545) (BOUT16 151547 . 151732) (BIN16 151734 . 151923)) (152028 157233 -(\GENERIC.BINS 152038 . 152318) (\GENERIC.BOUTS 152320 . 152585) (\GENERIC.RENAMEFILE 152587 . 154418) - (\GENERIC.OPENP 154420 . 155735) (\GENERIC.READP 155737 . 156778) (\GENERIC.CHARSET 156780 . 157231)) - (157234 157573 (\MAP-OPEN-STREAMS 157244 . 157571)) (159443 161523 (\EOF.ACTION 159453 . 159704) ( -\EOSERROR 159706 . 159899) (\GETEOFPTR 159901 . 160083) (\INCFILEPTR 160085 . 160435) (\PEEKBIN 160437 - . 160628) (\SETCLOSEDFILELENGTH 160630 . 160964) (\SETEOFPTR 160966 . 161154) (\SETFILEPTR 161156 . -161521)) (161524 162066 (\FIXPOUT 161534 . 161834) (\FIXPIN 161836 . 162064)) (162067 162633 (\BOUTEOL - 162077 . 162631)) (165725 175589 (\BUFFERED.BIN 165735 . 166587) (\BUFFERED.PEEKBIN 166589 . 167371) -(\BUFFERED.BOUT 167373 . 168233) (\BUFFERED.BINS 168235 . 171920) (\BUFFERED.BOUTS 171922 . 173723) ( -\BUFFERED.COPYBYTES 173725 . 175587)) (175618 177970 (\NULLDEVICE 175628 . 177646) (\NULL.OPENFILE -177648 . 177968))))) + (FILEMAP (NIL (27462 30940 (STREAMPROP 27472 . 27906) (GETSTREAMPROP 27908 . 28377) (PUTSTREAMPROP +28379 . 30788) (STREAMP 30790 . 30938)) (30983 33502 (\DEFPRINT.BY.NAME 30993 . 32145) ( +\STREAM.DEFPRINT 32147 . 33195) (\FDEV.DEFPRINT 33197 . 33500)) (33760 38801 (\GETACCESS 33770 . 34224 +) (\SETACCESS 34226 . 38799)) (59682 65651 (\DEFINEDEVICE 59692 . 62008) (\GETDEVICEFROMNAME 62010 . +62483) (\GETDEVICEFROMHOSTNAME 62485 . 63529) (\REMOVEDEVICE 63531 . 64654) (\REMOVEDEVICE.NAMES 64656 + . 65649)) (65691 90351 (\CLOSEFILE 65701 . 66526) (\DELETEFILE 66528 . 66822) (\DEVICEEVENT 66824 . +68594) (\GENERATEFILES 68596 . 69074) (\GENERATENEXTFILE 69076 . 69727) (\GENERATEFILEINFO 69729 . +70190) (\GETFILENAME 70192 . 70581) (\GENERIC.OUTFILEP 70583 . 71053) (\OPENFILE 71055 . 73633) ( +\DO.PARAMS.AT.OPEN 73635 . 76188) (\RENAMEFILE 76190 . 76614) (\REVALIDATEFILE 76616 . 79218) ( +\PAGED.REVALIDATEFILELST 79220 . 80778) (\PAGED.REVALIDATEFILES 80780 . 82499) (\PAGED.REVALIDATEFILE +82501 . 84784) (\BUFFERED.REVALIDATEFILE 84786 . 87072) (\BUFFERED.REVALIDATEFILELST 87074 . 88258) ( +\PRINT-REVALIDATION-RESULT 88260 . 88675) (\TRUNCATEFILE 88677 . 89068) (\FILE-CONFLICT 89070 . 90349) +) (90387 95050 (\GENERATENOFILES 90397 . 92493) (\NULLFILEGENERATOR 92495 . 92739) (\NOFILESNEXTFILEFN + 92741 . 94732) (\NOFILESINFOFN 94734 . 95048)) (95169 97077 (\FILE.NOT.OPEN 95179 . 95692) ( +\FILE.WONT.OPEN 95694 . 96022) (\ILLEGAL.DEVICEOP 96024 . 96306) (\IS.NOT.RANDACCESSP 96308 . 96754) ( +\STREAM.NOT.OPEN 96756 . 97075)) (97212 99510 (\FDEVINSTANCE 97222 . 99508)) (101060 108434 (CNDIR +101070 . 102375) (DIRECTORYNAME 102377 . 106560) (DIRECTORYNAMEP 106562 . 107178) (HOSTNAMEP 107180 . +107987) (\ADD.CONNECTED.DIR 107989 . 108432)) (108479 135866 (\BACKFILEPTR 108489 . 108677) ( +\BACKPEEKBIN 108679 . 109040) (\BACKBIN 109042 . 109393) (BIN 109395 . 109612) (\BIN 109614 . 109891) +(\BINS 109893 . 110179) (BOUT 110181 . 110543) (\BOUT 110545 . 110860) (\BOUTS 110862 . 111173) ( +COPYBYTES 111175 . 114507) (COPYCHARS 114509 . 118175) (COPYFILE 118177 . 118974) (\COPYOPENFILE +118976 . 122049) (\INFER.FILE.TYPE 122051 . 123005) (EOFP 123007 . 123304) (FORCEOUTPUT 123306 . +123553) (\FLUSH.OPEN.STREAMS 123555 . 123911) (CHARSET 123913 . 125577) (ACCESS-CHARSET 125579 . +125796) (GETEOFPTR 125798 . 126048) (GETFILEINFO 126050 . 129243) (\TYPE.FROM.FILETYPE 129245 . 129715 +) (\FILETYPE.FROM.TYPE 129717 . 129896) (GETFILEPTR 129898 . 130150) (SETFILEINFO 130152 . 133765) ( +SETFILEPTR 133767 . 135486) (BOUT16 135488 . 135673) (BIN16 135675 . 135864)) (135969 141174 ( +\GENERIC.BINS 135979 . 136259) (\GENERIC.BOUTS 136261 . 136526) (\GENERIC.RENAMEFILE 136528 . 138359) +(\GENERIC.OPENP 138361 . 139676) (\GENERIC.READP 139678 . 140719) (\GENERIC.CHARSET 140721 . 141172)) +(141175 141514 (\MAP-OPEN-STREAMS 141185 . 141512)) (143384 145464 (\EOF.ACTION 143394 . 143645) ( +\EOSERROR 143647 . 143840) (\GETEOFPTR 143842 . 144024) (\INCFILEPTR 144026 . 144376) (\PEEKBIN 144378 + . 144569) (\SETCLOSEDFILELENGTH 144571 . 144905) (\SETEOFPTR 144907 . 145095) (\SETFILEPTR 145097 . +145462)) (145465 146007 (\FIXPOUT 145475 . 145775) (\FIXPIN 145777 . 146005)) (146008 146574 (\BOUTEOL + 146018 . 146572)) (149666 159530 (\BUFFERED.BIN 149676 . 150528) (\BUFFERED.PEEKBIN 150530 . 151312) +(\BUFFERED.BOUT 151314 . 152174) (\BUFFERED.BINS 152176 . 155861) (\BUFFERED.BOUTS 155863 . 157664) ( +\BUFFERED.COPYBYTES 157666 . 159528)) (159559 161911 (\NULLDEVICE 159569 . 161587) (\NULL.OPENFILE +161589 . 161909))))) STOP diff --git a/sources/FILEIO.LCOM b/sources/FILEIO.LCOM index b2af608bc4cd3f190cdefa153dc7c390cfc868d3..053ba1b6f8d42535b6b824cc11590e34d72dc6c2 100644 GIT binary patch delta 376 zcmeBcV!rfwX`7{5>-9~aj!PiI$!%sd4pHy~F5*$h2BJtc*d z#1f!RY-U?1X>w_}dHT3I2f4~PhPb+*sWP-OFtReTR8p8&Yp-Fcz-4G=WNc=nkerd2 zm!4XzP?8UHgGQKRP_P2X5Kn(+f8Suu$-5a9Q9NmAZe?U@WneP-1EUk8#bnu?(wqI5 zHVSPnkaI0$G@ZPy|Mlcm69R+{%oJi=T-`kVTp>OJI&HGpL@P-@PmrgKO%-C?UHx2x qJe~ENJ%CoahHS2#xR-tM%h^(VTqqhRZ&VZ6tUBkn%;uSUN?8DvziW{I delta 4141 zcmb7HPi!M+6(3JlyXj~tNjjTST4^6fi^i_vdi*~IZ9TSU)}xGPobe=NMGl+T-nEl# zvLvarprWZz#iAZsqG>Cr5VS}wNN~s|!}7jw#?JU( zSL6_X-+SNpzW09b@BHp#_VsU0d}o=5%v`;7Z!Qr}h#+S2VmcpB9c-9VA_Cz)UOJzi zM|K$2cUz5}yZ1U zXpjbvT)b(?bqn>WDmtXVSh7kL$;5RMic)EzR5Hpk?h;Uw<=##NRqt}*pi5Ob5&`Dh zEW=zDE%w2C?N=wsnf1%J$j{Yg zfuD4n63@8JBG0&mEYvH;l2+C&^hqWKFJGAGKVsdi$)A52l36I3ngZyEl8LBk z3Z9Q}qk7qRUS!?4p+jC7PLpxO+xB3&dur;}&LF{$aVzwho4 zB0X?8ONkYJ^0mS`>mOKgrQeVfN3#`r$hDs_ZVT47{ROi2+bw9_ z-*4@1uWiBYon5?xDLMv|ZvJ=y|3c53B=l<-`k_LTdf|I+!S)^VDs{&?bBkaqM-U0&fZc_KI$C)rNXWp{(%uvIVgJ$f<)rn5hJin_IY6)^BsMY z>Zf|d#C+dTk0_$Q`>O@UNFRYly`t*nIWLBt#rze!8^;T1KI@x*P?#FF`bvA|Bq|+$ zp+IAi+CFIZUpt3?CT9P>jWL?)hA1l5i@)@sPBzKP;gB3WMq(x&noBiHDrz!D!V!gnx>GutESz3Hot&a!@s@Nt zxz4&I+r2n>)0I{Z4X+v=LE)4;Wocy0vZ0eF$+mrRi4xY?S0oDQ%E_mta{%3nO$Gmy zk}4Eb6dx*7`0H-vw+yp!_LBnsPJeiL+AUO0FY*HUVfY;RVfj4yxxjzvsiz)3`U;i> zalV`Lm|uQ@$Uwm5h@%+K2I9h|eI=WPDE0_xNwWr8P82fnaXb>9S%lfU2+2XG0jh&t zsVtjwvc9aEhF+C*3k$FhKdA$@nEZr7FrPkmIqbIXboMaOu?h?%Jgo{O>%FENvnr;s zbfYp@5lQyzss>Df!9VJkt9Fxmk8~?aEuu0 zO$ak0v+C;+Xvn!9(eKQ5Sq4n!RnnS^DmLkO?*#6!bmx5`*x1MPH=5SnxA0Q8$YHlL zmUOEYh<63oQ8F%2j%-FFHZU9$Vpz%9Y%p#CrWizsphP>Q|8{SR`2S=BGfhN$ZSm(% zNY33y4W@&@rD2tbBx98G#l=tALpTLYz)6P8FQ_=e=m!qwXc#@nN?VWqeRQQD{f#D0 z0k?nm>QcdLmH1Q=eN@DokibELE->KeBGR++c;ZU=tD);oPGa&PI2t%_KgiFm-jH?KR7){3Z`Eb;NP1kdM34XR;Fp(*TzH^LHCv6X zwcWM-&dxUNYrCy2I(*)KX}dv)d*KKOWx1qDri`;|*>E1debwenbfHezV@?as4{_G6VCH-8YqvX|{o~1FJ(4Iik!m!Un>a(u3ti zSX?qJ83dtRUx55dsZ>V`Q5}1@W1v?E=Z0n!C5_7Eh7XN@X$&WdBIT8uVOkz~p2D0x z?s!j05K2ZBZ6nTjOj!z~F4tY3XIz)kD_=FFC8@VjyNm^1JL*ZX~;A(2ng%wu7@Ke&Y0a13`@S^PD%JQD!_V zH=ZTNfkTl2U4p8JL0tyk!-=S?3o+2cT6A9j@ik@Oq#)pjo;M{EREf#>;n(vA2EDft zk#qh%$2sr(Fys8`2RxnbdT(K*jQC*eYJ#E_F>qE^&Mm+Y;smoMExtIeyp2xQcJN}q aX?TI8>|?}6{ekaplan>Local>medley3.5>git-medley>sources>FILESETS.;6 6395 - - changes to%: (VARS 0LISPSET) - - previous date%: "19-Jun-2021 12:13:31" -{DSK}kaplan>Local>medley3.5>git-medley>sources>FILESETS.;5) - - -(* ; " -Copyright (c) 1981-1990, 1998, 2021 by Xerox Corporation. -") - -(PRETTYCOMPRINT FILESETSCOMS) - -(RPAQQ FILESETSCOMS - ( - -(* ;;; "contains all of the lists of files which are used in various ways") - - - (* ;; "I took out the EXPORT of the filesets because it led to inconsistency when one had loaded ABC. -- Pavel") - - - (* ;; "The file with the default EXTERNALFORMAT should come right after FILEIO, and particularly before ATERM.") - - (VARS * FILESETS) - (VARS EXPORTFILES) - (VARS MAKEINITFILES MAKEINITTYPES RENAMETYPES ABCFILES READSYSFILES DATABASEFILES) - (VARS DEADFNS))) - - - -(* ;;; "contains all of the lists of files which are used in various ways") - - - - -(* ;; -"I took out the EXPORT of the filesets because it led to inconsistency when one had loaded ABC. -- Pavel" -) - - - - -(* ;; -"The file with the default EXTERNALFORMAT should come right after FILEIO, and particularly before ATERM." -) - - -(RPAQQ FILESETS (0LISPSET 1LISPSET 2LISPSET 3LISPSET)) - -(RPAQQ 0LISPSET (PACKAGE-CONVERSION-TABLE LLFAULT LLSUBRS LLBFS LLNEW FILEIO IMAGEIO LLBASIC LLGC - LLARRAYELT LLINTERP LLMVS DEFSTRUCT-RUN-TIME SETF-RUNTIME CMLSEQBASICS - LLARITH LLFLOAT LLBIGNUM LLREAD XCCS LLCHAR LLSTK LLDATATYPE IOCHAR LLKEY - LLTIMER)) - -(RPAQQ 1LISPSET - (ASTACK DTDECLARE ATBL LLCODE ACODE COREIO AOFD ADIR PMAP VANILLADISK ATERM APRINT ABASIC - AERROR AINTERRUPT MISC BOOTSTRAP CMLMACROS CMLEVAL CMLPROGV CMLSPECIALFORMS LLRESTART - LLERROR LLSYMBOL LLPACKAGE PACKAGE-STARTUP CONDITION-PACKAGE XCL-PACKAGE PROC CMLARRAY - DSK UFS UFSCALLC PASSWORDS FONT LLDISPLAY APUTDQ COMPATIBILITY DMISC CMLMACROS CMLLIST - CMLCHARACTER CMLREADTABLE MAIKOLOADUPFNS MAIKOBITBLT MAIKOINIT)) - -(RPAQQ 2LISPSET (MACHINEINDEPENDENT POSTLOADUP)) - -(RPAQQ 3LISPSET (MACROS DLAP BYTECOMPILER COMPILE)) - -(RPAQQ EXPORTFILES - (MODARITH LLPARAMS LLCODE AERROR AOFD APRINT ATERM LLARRAYELT LLDATATYPE LLNEW LLBASIC LLCHAR - LLSTK PMAP LLGC ATBL FILEIO LLARITH LLFLOAT FONT LLKEY LLDISPLAY ADISPLAY AINTERRUPT - RENAMEMACROS HLDISPLAY WINDOW MACROAUX ADDARITH LLFAULT LLTIMER IMAGEIO PROC XCCS - LLREAD PASSWORDS INTERPRESS HARDCOPY CMLARRAY LLSUBRS)) - -(RPAQQ MAKEINITFILES (MAKEINIT MEM I-NEW)) - -(RPAQQ MAKEINITTYPES - ((NIL INIT (0 1) - 2LISPSET 1600) - (SMALLINIT SMALLINIT (LLFAULT LLSUBRS LLNEW FILEIO LLBASIC LLGC LLINTERP LLARITH LLREAD - LLCHAR TINYPATCH)) - (MACROTEST MACROTEST ((MACROTEST) - 0 1) - 2LISPSET) - (MICROTEST MICROTEST ((MICROTEST LLFAULT LLSTK LLSUBRS LLKEY LLBFS))) - (NANOTEST NANOTEST ((MICROTEST LLSUBRS))) - (NULL NULL ((DUMMY))) - (MILLITEST MILLITEST - ((MACROTEST LLFAULT LLSUBRS LLNEW LLBASIC LLGC LLINTERP LLARITH LLFLOAT LLARRAYELT - LLSTK LLDATATYPE LLKEY ABASIC LLCHAR ASTACK MISC APUTDQ))) - (CHECKARRAYS CHECKARRAYS (CHECKARRAYSPACE 0 1) - 2LISPSET))) - -(RPAQQ RENAMETYPES - ((I (FILES LLPARAMS LLCODE LLARRAYELT LLCHAR LLNEW LLBASIC LLDATATYPE LLGC LLSTK RENAMEMACROS - MODARITH LLFAULT LLKEY LLBFS LLTIMER) - (RENAMEDFILE . I-NEW) - (SUBNAME . MKI.SUBFNS) - (COMSNAME . INEWCOMS) - (EXTRACOMS (VARS INITPTRS INITVALUES) - (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) - MAKEINIT))) - (MKI.SUBFNS) - (INEWCOMS) - (VALUES . INITVALUES) - (PTRS . INITPTRS) - (PREFIX . I.) - (VAG2FN . I.VAG2)) - (R (FILES LLCODE LLPARAMS LLBASIC LLDATATYPE LLNEW ACODE LLARRAYELT LLCHAR LLINTERP LLSTK - RENAMEMACROS MODARITH LLFAULT) - (RENAMEDFILE . RDSYS) - (SUBNAME . RD.SUBFNS) - (COMSNAME . RDCOMS) - (EXTRACOMS - - (* ;; "YOU MUST REMAKE THIS FILE using (DORENAME 'R) (after CONNing to library) whenever the SYSOUT layout changes in LLPARAMS (e.g., if MDSTypeTable moves)") - - (FILES VMEM) - (VARS RDVALS RDPTRS) - (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) - VMEM))) - (RD.SUBFNS (\CALLME . *)) - (RDCOMS) - (PTRS . RDPTRS) - (PREFIX . V) - (VAG2FN . VVAG2) - (VALUES . RDVALS) - (RDPTRS) - (RDVALUES)))) - -(RPAQQ ABCFILES (LOADABC COMPILEBANG SAMEDIR WHEREIS COMPILEFORMSLIST CHECKSET CMACROS DCODEFOR10 - DTDECLARE BYTECOMPILER DLAP LLCODE ACODE MACROAUX)) - -(RPAQQ READSYSFILES (RDSYS READSYS VMEM REMOTEVMEM)) - -(RPAQQ DATABASEFILES (0LISPSET 1LISPSET (2LISPSET ACODE) - (3LISPSET DLAP) - (4LISPSET DFILE DMISC) - 7LISPSET - (8LISPSET MAKEINIT MEM) - 9LISPSET - (10LISPSET LLPARAMS) - (NIL CHECKARRAYSPACE MAKEINEW PMEMSTATS PPAGESTATS LLFCOMPILE))) - -(RPAQQ DEADFNS - ((PUTBASE \PUTBASE) - (GETBASE \GETBASE) - (ADDBASE \ADDBASE) - (GETBASEBYTE \GETBASEBYTE) - (PUTBASEBYTE \PUTBASEBYTE) - (PUTBASEPTR \PUTBASEPTR) - (HILOC \HILOC) - (LOLOC \LOLOC) - (VAG2 \VAG2) - (PAGEBASE NIL) - (PAGELOC NIL) - (WordsPerPage WORDSPERPAGE) - (ALTOMACRO DMACRO) - (\STACKSPACE ??) - (GETBASEPTR \GETBASEPTR) - (FPLUS2) - (FTIMES2) - (CREATECELL \CREATECELL))) -(PUTPROPS FILESETS COPYRIGHT ("Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 -1998 2021)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL))) -STOP diff --git a/sources/LLREAD b/sources/LLREAD deleted file mode 100644 index 32e8b723..00000000 --- a/sources/LLREAD +++ /dev/null @@ -1,1965 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "24-Aug-2021 10:04:18"  -{DSK}kaplan>Local>medley3.5>git-medley>sources>LLREAD.;103 105490 - - changes to%: (FNS CHARCODE.DECODE) - - previous date%: "24-Aug-2021 08:32:13" -{DSK}kaplan>Local>medley3.5>git-medley>sources>LLREAD.;101) - - -(* ; " -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 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) - (FNS HEXNUM? OCTALNUM?) - (VARS CHARACTERNAMES CHARACTERSETNAMES)) - (DECLARE%: DOEVAL@COMPILE DONTCOPY (CONSTANTS * READTYPES) - (MACROS .CALL.SUBREAD. FIXDOT RBCONTEXT PROPRB \RDCONC) - (SPECVARS *READ-NEWLINE-SUPPRESS* \RefillBufferFn) - (GLOBALVARS *KEYWORD-PACKAGE* *INTERLISP-PACKAGE*)) - (COMS - (* ;; "Generic functions not compiled open") - - (FNS \OUTCHAR \INCCODE \BACKCCODE \BACKCCODE.EOLC \PEEKCCODE \PEEKCCODE.NOEOLC - \INCCODE.EOLC \FORMATBYTESTREAM \CHECKEOLC.CRLF) - (MACROS \CHECKEOLC)) - (COMS (INITVARS (*REPLACE-NO-FONT-CODE* T) - (*DEFAULT-NOT-CONVERTED-FAT-CODE* 8739)) - (GLOBALVARS *REPLACE-NO-FONT-CODE* *DEFAULT-NOT-CONVERTED-FAT-CODE*)) - (INITVARS (*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 CL:PARSE-INTEGER CL:READ-DELIMITED-LIST CL:READ-PRESERVING-WHITESPACE - CL:READ]) - - - -(* ; "Reader entrypoints") - -(DEFINEQ - -(LASTC - [LAMBDA (FILE) (* ; "Edited 3-May-2021 16:45 by rmk:") - (LET [(LASTCCODE (FETCH (STREAM LASTCCODE) OF (\GETSTREAM FILE 'INPUT] - (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) (* ; "Edited 3-May-2021 16:47 by rmk:") - (LET ((\RefillBufferFn (FUNCTION \PEEKREFILL))) - (DECLARE (SPECVARS \RefillBufferFn)) - (\PEEKCCODE (\GETSTREAM FILE 'INPUT) - 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-Aug-2021 21:38 by rmk:") - (SETQ FILE (\GETSTREAM FILE 'INPUT)) - (LET ((*READTABLE* (\GTREADTABLE RDTBL)) - (\RefillBufferFn (FUNCTION \READCREFILL)) - (CODE (\INCCODE.EOLC FILE))) - (DECLARE (SPECVARS *READTABLE* \RefillBufferFn)) - (CL:WHEN (\CHARCODEP CODE) (* ; - "If not a charcode, we must have run off the end with an ENDOFSTREAMOP") - (freplace (STREAM LASTCCODE) of FILE with CODE) - (FCHARACTER CODE))]) - -(READCCODE - [LAMBDA (STREAM RDTBL) (* ; "Edited 6-Aug-2021 21:39 by rmk:") - -(* ;;; "returns a 16 bit character code. \INCHAR does the EOL conversion. Saves the character for LASTC as well.") - - (SETQ STREAM (\GETSTREAM STREAM 'INPUT)) - (LET ((*READTABLE* (\GTREADTABLE RDTBL)) - (\RefillBufferFn (FUNCTION \READCREFILL)) - (CODE (\INCCODE.EOLC STREAM))) - (DECLARE (SPECVARS *READTABLE* \RefillBufferFn)) - (CL:WHEN (\CHARCODEP CODE) (* ; - "If not a charcode, we must have run off the end with an ENDOFSTREAMOP") - (freplace (STREAM LASTCCODE) of STREAM with CODE)) - CODE]) - -(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 18-Jun-2021 11:38 by rmk:") - - (* ;; "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.") - - (* ;; "Assumes that CR and LF are both seprs so that no EOL processing is needed.") - - (bind PREVC C (STRM _ (\GETSTREAM FILE 'INPUT)) - (SA _ (fetch (READTABLEP READSA) of (\GTREADTABLE RDTBL))) - (\RefillBufferFn _ '\PEEKREFILL) declare (SPECVARS \RefillBufferFn) - while [EQ SEPRCHAR.RC (\SYNCODE SA (SETQ C (OR (\PEEKCCODE STRM T) - (RETURN] do (SETQ PREVC C) - (\INCCODE STRM) - finally (AND PREVC (replace (STREAM LASTCCODE) of STRM with PREVC)) - (RETURN C]) - -(SKIPSEPRS - [LAMBDA (FILE RDTBL) (* ; "Edited 18-Jun-2021 11:39 by rmk:") - - (* ;; "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.") - - (LET (C) - (AND (SETQ C (SKIPSEPRCODES FILE RDTBL)) - (FCHARACTER C]) - -(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 20-Aug-2021 00:02 by rmk:") - (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 (STRM RDTBL ESCAPE-ALLOWED-P) (* ; "Edited 6-Aug-2021 21:39 by rmk:") - - (* ;; "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)) - (J 0) - (SA (fetch READSA of RDTBL)) - CH SNX ANSLIST ANSTAIL ESCAPE-APPEARED ESCAPING FATSEEN) - LP (if (\EOFP STRM) - then (* ; - "end of file terminates string just like a sepr/break") - (GO FINISH)) - (SETQ CH (\INCCODE STRM)) (* ; "NOTE: This should really be (\INCHAR --) --), 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 (\INCCODE.EOLC STRM)) - (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) - (\BACKCCODE STRM) - (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 (STRM SA RSFLG PNSTR) (* ; "Edited 13-Aug-2021 13:35 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 STRM)) - (PBASE (ffetch (STRINGP XBASE) of PNSTR)) - (J 0) - CH SNX ANSLIST ANSTAIL LASTC FATSEEN SKIPPING) - RS2LP - (SETQ CH (\INCCODE.EOLC STRM)) - [COND - ((EQ CH (CHARCODE EOL)) - - (* ;; "We have eaten a CR, LF, or CRLF depending on the EOL convention of STRM, and recognized it as an EOL. If EOL is a stopatom character, we terminate the read and backup over the just read character(s) so they can be read again.") - - (* ;; "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 EOL] - - (* ;; - "From RSTRING, eol terminates read, but EOL character(s) is/are left to be read again. ") - - (\BACKCCODE.EOLC STRM) - (GO FINISH] - (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 (\INCCODE STRM)) - (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 STRM)) - (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) - (\BACKCCODE STRM) - (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 STRM))) (* ; "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 (freplace (STREAM LASTCCODE) of STRM 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 (STRM SA READTYPE PNSTR CASEBASE EOF-SUPPRESS EOF-VALUE CHAR PRESERVE-WHITESPACE) - (* ; "Edited 6-Aug-2021 21:40 by rmk:") - - (* ;; "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)) - (PBASE (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 STRM))) - 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 STRM))) - then (* ; - "caller specified eof-error-p of NIL. Happens only on top-level calls") - (RETURN EOF-VALUE)) (* ; "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 (\INCCODE STRM] - SEPRCHAR.RC)) - (COND - ((EQ CH CHAR) (* ; - "Read desired terminating char. TOPLEVELP is always false here") - (freplace (STREAM LASTCCODE) of STRM 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 (\PEEKCCODE STRM] - - (* ;; "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 (\PEEKCCODE STRM)))) - 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 (\INCCODE.EOLC STRM)) - (* ; - "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 (\INCCODE.EOLC STRM)) - (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 STRM))) - then (* ; - "EOF terminates atoms at top level") - (GO FINISHATOM) - elseif (EQ [SETQ SNX (\SYNCODE SA (SETQ CH (\INCCODE STRM] - 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 (freplace (STREAM LASTCCODE) of STRM 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] - (freplace (STREAM LASTCCODE) of STRM 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") - (freplace (STREAM LASTCCODE) of STRM - with (OR LASTC CH 65535)) - (* ; - "And LASTC will return the last REAL char read.") - (\BACKCCODE STRM))) - (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") - (freplace (STREAM LASTCCODE) of STRM 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*)) - (freplace (STREAM LASTCCODE) of STRM 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") - - (freplace (STREAM LASTCCODE) of STRM 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 STRM 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 STRM 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 STRM 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 - STRM 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 STRM 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 - STRM 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 24-Aug-2021 10:03 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") - - (* ;; "RMK 2021: Moved single chars above atom test to be more precise about digits.") - - (* ;; "Moved Unicode up, out of comma testing, allowed lower-case u.") - - (* ;; "Also disallowed unknown junk in the parse-integer strings and substrings so we know what's happening") - - (COND - ((NOT C) - NIL) - ((LISTP C) - (CONS (CHARCODE.DECODE (CAR C) - NOERROR) - (CHARCODE.DECODE (CDR C) - NOERROR))) - ((EQ (NCHARS C) - 1) (* ; - "Includes singleton digits 0-9, the only FIXP's allowed. 0 is 0, not 48") - (CHCON1 C)) - ((NOT (OR (LITATOM C) - (STRINGP C))) (* ; - "LITATOM instead of ATOM stops numbers right here. ") - (AND (NOT NOERROR) - (ERROR "BAD CHARACTER SPECIFICATION" C))) - ((HEXNUM? C T)) - (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") - - (* ;; "RMK: I don't understand that comment: %"X,#a%" would map to the high panel corresponding to %"a%" in any character set X, including Meta or Function, wherever they happen to be. Won't adding and orring be the same?") - - (AND (SETQ C (CHARCODE.DECODE (SUBSTRING C 2 -1) - NOERROR)) - (IPLUS C 128))) - (for X in CHARACTERNAMES when (STRING.EQUAL (CAR X) - C) - do (RETURN (OR (NUMBERP (CADR X)) - (CHARCODE.DECODE (CADR X) - NOERROR))) - finally (RETURN - (LET ([POS (find I from 1 - suchthat (FMEMB (OR (NTHCHARCODE C I) - (RETURN)) - (CHARCODE (%, - %. %|] - CH CSET SSTR) (* ; "In the form charset,char") - - (* ;; - "Don't use STRPOSL because CHARTABLE is not available in loadup sequence.") - - (* ;; "The character set loop is like the character loop with a different search list and no recursion for character sets.") - - (COND - ((AND POS (SETQ CH (OR [OCTALNUM? (SETQ SSTR - (SUBSTRING C (ADD1 POS] - (CHARCODE.DECODE SSTR NOERROR))) - (< CH 256) - (>= CH 0) - (SETQ CSET (OR [OCTALNUM? (SETQ SSTR - (SUBSTRING C 1 (SUB1 POS] - (CADR (find PAIR in - CHARACTERSETNAMES - suchthat - - (* ;; - "No recursion. If not a number the list is bad even if C is OK") - - (STRING.EQUAL (CAR PAIR) - SSTR))) - (HEXNUM? SSTR T))) - (< CSET 256) - (>= CSET 0)) (* ; - "parsed the charset part as an octal, standard charset name, or hex") - (LOGOR (LLSH CSET 8) - CH)) - ((NOT NOERROR) - (ERROR "BAD CHARACTER SPECIFICATION" C]) -) -(DEFINEQ - -(HEXNUM? - [LAMBDA (STR PREFIXED?) (* ; "Edited 24-Aug-2021 08:31 by rmk:") - - (* ;; "Returns the number encoded as a hex representation in STR, NIL if it is not an unsigned hex string. The hex digits can be upper or lower case.") - - (* ;; "If PREFIXED?, then hex ending must follow one of 0x, 0X, u+, U+ prefixes") - - (* ;; "CL:PARSE-INTEGER with JUNK-ALLOWED would also return NIL, but it would trim commonlisp seprs...and also depends on CHARTABLE which is not available at the right place in the loadup.") - - (CL:WHEN [OR (NOT PREFIXED?) - (AND (SELCHARQ (CHCON1 STR) - (0 (* ; "Hex? 0X or 0x") - (FMEMB (NTHCHARCODE STR 2) - (CHARCODE (x X)))) - ((U u) (* ; "Unicode U+ or u+") - (EQ (NTHCHARCODE STR 2) - (CHARCODE +))) - NIL) - (SETQ STR (SUBSTRING STR 3 NIL (CONSTANT (CONCAT] - (FOR I C (NUM _ 0) FROM 1 WHILE (SETQ C (NTHCHARCODE STR I)) - DO [SETQ C (IDIFFERENCE C (IF (AND (IGEQ C (CHARCODE 0)) - (ILEQ C (CHARCODE 9))) - THEN (CHARCODE 0) - ELSEIF (IF (AND (IGEQ C (CHARCODE a)) - (ILEQ C (CHARCODE f))) - THEN (IDIFFERENCE (CHARCODE a) - 10) - ELSEIF (AND (IGEQ C (CHARCODE A)) - (ILEQ C (CHARCODE F))) - THEN (IDIFFERENCE (CHARCODE A) - 10)) - ELSE (RETURN NIL] - (SETQ NUM (IPLUS (LLSH NUM 4) - C)) FINALLY (RETURN NUM)))]) - -(OCTALNUM? - [LAMBDA (STR) (* ; "Edited 24-Aug-2021 08:25 by rmk:") - - (* ;; "Returns the number encoded as an octal representation in STR, NIL if it is not an unsigned octal string.") - - (* ;; "CL:PARSE-INTEGER with JUNK-ALLOWED would also return NIL, but it would trim commonlisp seprs...and also depends on CHARTABLE which is not available at the right place in the loadup.") - - (FOR I C (NUM _ 0) FROM 1 WHILE (SETQ C (NTHCHARCODE STR I)) - DO (IF (AND (IGEQ C (CHARCODE 0)) - (ILEQ C (CHARCODE 7))) - THEN [SETQ NUM (IPLUS (LLSH NUM 3) - (IDIFFERENCE C (CHARCODE 0] - ELSE (RETURN NIL)) FINALLY (RETURN NUM]) -) - -(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 (("Meta" 1) - ("Function" 2) - ("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]) -) - -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(SPECVARS *READ-NEWLINE-SUPPRESS* \RefillBufferFn) -) - -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS *KEYWORD-PACKAGE* *INTERLISP-PACKAGE*) -) -) - - - -(* ;; "Generic functions not compiled open") - -(DEFINEQ - -(\OUTCHAR - [LAMBDA (STREAM CODE) (* ; "Edited 10-Aug-2021 10:29 by rmk:") - - (* ;; "We can't do the EOL stuff here because we don't know whether BOUTs are legit.") - - (* ;; "Maybe the implementation function does something else, like move the X and Y positions. At best we could convert the EOL into either CR or LF, or into a CR-LF sequence that we pass by two calls to the lower implementation function.") - - (* ;; "") - - (* ;; "This would make CHARPOSITION generic:") - (* (FREPLACE (STREAM CHARPOSITION) - OF STREAM WITH (CL:IF - (EQ CODE (CHARCODE EOL)) 0 - (IPLUS16 1 (FFETCH - (STREAM CHARPOSITION) OF STREAM))))) - (CL:FUNCALL (OR (ffetch (STREAM OUTCHARFN) of STREAM) - \DEFAULTOUTCHAR) - STREAM CODE) - CODE]) - -(\INCCODE - [LAMBDA (STREAM BYTECOUNTVAR BYTECOUNTVAL) (* ; "Edited 7-Aug-2021 00:11 by rmk:") - - (* ;; "Calling functions pass the name of the BYTECOUNTVAR, or NIL. If non-NIL, implementing functions are required to SETQ *BYTECOUNTER* to the number of bytes read (positive) or backed up (negative).") - - (* ;; "Caller must bind BYTECOUNTVAR as a SPECVAR. BYTECOUNTVAL can be passed as the current value of BYTECOUNTVAR, to save a call to \EVALV1.") - - (IF BYTECOUNTVAR - THEN [LET ((*BYTECOUNTER* 0)) - (DECLARE (SPECVARS *BYTECOUNTER*)) - (PROG1 (CL:FUNCALL (OR (ffetch (STREAM INCCODEFN) of STREAM) - \DEFAULTINCCODE) - STREAM - '*BYTECOUNTER*) - (SET BYTECOUNTVAR (IDIFFERENCE (OR BYTECOUNTVAL (\EVALV1 BYTECOUNTVAR)) - *BYTECOUNTER*)))] - ELSE (CL:FUNCALL (OR (ffetch (STREAM INCCODEFN) of STREAM) - \DEFAULTINCCODE) - STREAM]) - -(\BACKCCODE - [LAMBDA (STREAM BYTECOUNTVAR BYTECOUNTVAL) (* ; "Edited 14-Aug-2021 00:26 by rmk:") - - (* ;; -"Format function returns T if the backup succeed, NIL otherwise (e.g at the beginning of the file)") - - (IF BYTECOUNTVAR - THEN [LET ((*BYTECOUNTER* 0)) - (DECLARE (SPECVARS *BYTECOUNTER*)) - (PROG1 (CL:FUNCALL (OR (ffetch (STREAM BACKCCODEFN) of STREAM) - \DEFAULTBACKCCODE) - STREAM T) - (SET BYTECOUNTVAR (IPLUS (OR BYTECOUNTVAL (\EVALV1 BYTECOUNTVAR)) - *BYTECOUNTER*)))] - ELSE (CL:FUNCALL (OR (ffetch (STREAM BACKCCODEFN) of STREAM) - \DEFAULTBACKCCODE) - STREAM]) - -(\BACKCCODE.EOLC - [LAMBDA (STREAM BYTECOUNTVAR BYTECOUNTVAL) (* ; "Edited 14-Aug-2021 00:27 by rmk:") - - (* ;; "If the EOLCONVENTION is CRLF, and the first backup is over an LF encoding, this looks to see whether the preceding bytes encode a CR and if so, backs up over those.") - - (* ;; "Within this we operate at the external-format implementation level.") - - (* ;; "Counting is unusual in general (mostly just COPYCHARS and PFCOPYBYTES) , and counting while backing up is even rarer. So for simplicity here we just count by looking at the byte pointer.") - - (LET [(STARTPOS (CL:WHEN BYTECOUNTVAR (\GETFILEPTR STREAM] - - (* ;; "In almost all cases, we just execute the first backup") - - (PROG1 (CL:WHEN (CL:FUNCALL (OR (ffetch (STREAM BACKCCODEFN) of STREAM) - \DEFAULTBACKCCODE) - STREAM) - (IF (AND (EQ CRLF.EOLC (FETCH (STREAM EOLCONVENTION) OF STREAM)) - (EQ (CHARCODE LF) - (CL:FUNCALL (OR (ffetch (STREAM PEEKCCODEFN) of STREAM) - \DEFAULTPEEKCCODE) - STREAM))) - THEN - - (* ;; - "We just backed over an LF in a CRLF file. If we go one more, do we get a CR?") - - (CL:WHEN (CL:FUNCALL (OR (ffetch (STREAM BACKCCODEFN) of STREAM - ) - \DEFAULTBACKCCODE) - STREAM) - (CL:UNLESS (EQ (CHARCODE CR) - (CL:FUNCALL (OR (ffetch (STREAM PEEKCCODEFN) - of STREAM) - \DEFAULTPEEKCCODE) - STREAM)) - - (* ;; "Not a preceding CR, reread it.") - - (CL:FUNCALL (OR (ffetch (STREAM INCCODEFN) of STREAM) - \DEFAULTINCCODE) - STREAM)) - T) - ELSE T)) - (CL:WHEN BYTECOUNTVAR - [SET BYTECOUNTVAR (IPLUS (OR BYTECOUNTVAL (\EVALV1 BYTECOUNTVAR)) - (IDIFFERENCE STARTPOS (\GETFILEPTR STREAM]))]) - -(\PEEKCCODE - [LAMBDA (STREAM NOERROR EOL) (* ; "Edited 14-Jun-2021 12:40 by rmk:") - (\CHECKEOLC (CL:FUNCALL (OR (ffetch (STREAM PEEKCCODEFN) of STREAM) - \DEFAULTPEEKCCODE) - STREAM NOERROR) - EOL STREAM T]) - -(\PEEKCCODE.NOEOLC - [LAMBDA (STREAM NOERROR) (* ; "Edited 27-Jun-2021 23:26 by rmk:") - (CL:FUNCALL (OR (ffetch (STREAM PEEKCCODEFN) of STREAM) - \DEFAULTPEEKCCODE) - STREAM NOERROR]) - -(\INCCODE.EOLC - [LAMBDA (STREAM EOLC BYTECOUNTVAR BYTECOUNTVAL) (* ; "Edited 8-Aug-2021 14:52 by rmk:") - - (* ;; - "EOL conversion around essentially a copy of \INCCODE but avoids the extra function call.") - - (* ;; " EOLC of NIL means all patterns go to EOL") - - (IF BYTECOUNTVAR - THEN [LET (*BYTECOUNTER* CODE) - (DECLARE (SPECVARS *BYTECOUNTER*)) - - (* ;; "The INCCODEFN first sets *BYTECOUNTER*") - - (CL:UNLESS BYTECOUNTVAL - (SETQ BYTECOUNTVAL (\EVALV1 BYTECOUNTVAR))) - (SETQ CODE (CL:FUNCALL (OR (ffetch (STREAM INCCODEFN) of STREAM) - \DEFAULTINCCODE) - STREAM T)) - - (* ;; "Update according to the number of first-char (CR or LF) bytes") - - (SETQ BYTECOUNTVAL (IDIFFERENCE BYTECOUNTVAL *BYTECOUNTER*)) - (SETQ *BYTECOUNTER* 0) - - (* ;; - "*BYTECOUNTER* will now be reset to the number of LF-after-CR bytes, if any") - - (PROG1 (\CHECKEOLC CODE (OR EOLC (FFETCH (STREAM EOLCONVENTION) - OF STREAM)) - STREAM NIL T) - - (* ;; "Post the results") - - (SET BYTECOUNTVAR (IDIFFERENCE BYTECOUNTVAL *BYTECOUNTER*)))] - ELSE (\CHECKEOLC (CL:FUNCALL (OR (ffetch (STREAM INCCODEFN) of STREAM) - \DEFAULTINCCODE) - STREAM) - (OR EOLC (FFETCH (STREAM EOLCONVENTION) OF STREAM)) - STREAM]) - -(\FORMATBYTESTREAM - [LAMBDA (STREAM BYTESTREAM) (* ; "Edited 24-Jun-2021 17:26 by rmk:") - - (* ;; "Create or modify a stream that will simulate the current character input/output byte sequences of STREAM. The set up here does what is common to all formats: an IO stream starting with STREAM external format and EOL.") - - (* ;; "If the format has its own FORMATBYTESTREAMFN function, that is applied to copy any other state. (Currently that function is a property of the format, not carried over into a stream field that can be changed dynamically.)") - - (CL:UNLESS (AND (STREAMP BYTESTREAM) - (\IOMODEP STREAM 'BOTH)) - (SETQ BYTESTREAM (OPENSTREAM '{NODIRCORE} 'BOTH))) - (LET ((FORMAT (FETCH (STREAM EXTERNALFORMAT) OF STREAM)) - (EOLC (FETCH (STREAM EOLCONVENTION) OF STREAM))) - (\EXTERNALFORMAT BYTESTREAM FORMAT) - (CL:WHEN (EQ EOLC ANY.EOLC) - (SETQ EOLC (OR (FETCH (EXTERNALFORMAT EOL) OF FORMAT) - LF.EOLC))) - (REPLACE (STREAM EOLCONVENTION) OF BYTESTREAM WITH EOLC) - (SETFILEPTR BYTESTREAM 0) - (SETFILEINFO BYTESTREAM 'ENDOFSTREAMOP (FUNCTION NILL)) - (CL:WHEN (FETCH (EXTERNALFORMAT FORMATBYTESTREAMFN) OF FORMAT) - (APPLY* (FETCH (EXTERNALFORMAT FORMATBYTESTREAMFN) OF FORMAT) - STREAM BYTESTREAM)) - BYTESTREAM]) - -(\CHECKEOLC.CRLF - [LAMBDA (STREAM PEEKBINFLG COUNTP) (* ; "Edited 6-Aug-2021 23:30 by rmk:") - - (* ;; "This is called only when a CR has been read and EOLC is either any or CRLF. This returns EOL if the next code is an LF") - - (* ;; "If COUNTP, that sets *BYTECOUNTER* freely with the number of LF bytes.") - - (DECLARE (USEDFREE *BYTECOUNTER*)) - (LET (CH) - [SETQ CH (COND - [PEEKBINFLG - - (* ;; - "T from PEEKC. In this case, must leave the fileptr where it was.") - - (* ;; "The CR itself hasn't been read, just peeked. So here we have to read it, then peek at the next character to see if it is an LF, and then back out the CR") - - (COND - ([EQ (CHARCODE LF) - (UNINTERRUPTABLY - - (* ;; " Since we are going to \BACKCCODE back the peeked character, we don't need to update the counter variable") - - (\INCCODE STREAM) - (PROG1 (\PEEKCCODE STREAM T 'NOEOLC) - - (* ;; - "This has to be a call to \PEEKCODE that doesn't itself to the checkeolc") - - (* ;; - "LF must be the next char after the CR. We back up over the CR that \INCCODE just read.") - - (\BACKCCODE STREAM)))] - - (* ;; "Got the CRLF, it's an EOL") - - (CHARCODE EOL)) - (T (CHARCODE CR] - ((EQ (CHARCODE LF) - (\PEEKCCODE STREAM T 'NOEOLC)) - - (* ;; "Since we aren't peeking, the CR has actually been read, and we are entitled to read the LF that we just peeked at.") - - (IF COUNTP - THEN (LET (NUMLFBYTES) - (DECLARE (SPECVARS NUMLFBYTES)) - (\INCCODE STREAM 'NUMLFBYTES 0) - (ADD *BYTECOUNTER* NUMLFBYTES)) - ELSE (\INCCODE STREAM)) - (CHARCODE EOL)) - (T (CHARCODE CR] - CH]) -) -(DECLARE%: EVAL@COMPILE - -(PUTPROPS \CHECKEOLC MACRO [OPENLAMBDA (CH EOLC STRM PEEKBINFLG COUNTP) - (COND - ((EQ EOLC 'NOEOLC) - CH) - (T (SELCHARQ CH - (LF (SELECTC (OR EOLC (FFETCH (STREAM - EOLCONVENTION - ) - OF STRM)) - ((LIST LF.EOLC ANY.EOLC) - (CHARCODE EOL)) - (CHARCODE LF))) - (CR (SELECTC (OR EOLC (FFETCH (STREAM - EOLCONVENTION - ) - OF STRM)) - (CR.EOLC (CHARCODE EOL)) - ((LIST ANY.EOLC CRLF.EOLC) - (\CHECKEOLC.CRLF STRM PEEKBINFLG - COUNTP)) - (CHARCODE CR))) - CH]) -) - -(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*) -) - -(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 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 (3516 11745 (LASTC 3526 . 3832) (PEEKC 3834 . 4222) (PEEKCCODE 4224 . 4517) (RATOM 4519 - . 5600) (READ 5602 . 6162) (READC 6164 . 6805) (READCCODE 6807 . 7566) (READP 7568 . 8120) ( -SETREADMACROFLG 8122 . 8421) (SKIPSEPRCODES 8423 . 9406) (SKIPSEPRS 9408 . 9794) (SKREAD 9796 . 11743) -) (11791 20400 (CL:READ 11801 . 12350) (CL:READ-PRESERVING-WHITESPACE 12352 . 13074) ( -CL:READ-DELIMITED-LIST 13076 . 13991) (CL:PARSE-INTEGER 13993 . 20398)) (20493 32970 (RSTRING 20503 . -21235) (READ-EXTENDED-TOKEN 21237 . 25109) (\RSTRING2 25111 . 32968)) (33006 64146 (\TOP-LEVEL-READ -33016 . 34999) (\SUBREAD 35001 . 60562) (\SUBREADCONCAT 60564 . 61187) (\ORIG-READ.SYMBOL 61189 . -62257) (\ORIG-INVALID.SYMBOL 62259 . 63158) (\APPLYREADMACRO 63160 . 63576) (INREADMACROP 63578 . -64144)) (64305 64480 (READQUOTE 64315 . 64478)) (64505 76409 (READVBAR 64515 . 65846) (READHASHMACRO -65848 . 71658) (DEFMACRO-LAMBDA-LIST-KEYWORD-P 71660 . 71880) (DIGITBASEP 71882 . 72616) ( -READNUMBERINBASE 72618 . 74504) (ESTIMATE-DIMENSIONALITY 74506 . 74831) (SKIP.HASH.COMMENT 74833 . -75801) (CMLREAD.FEATURE.PARSER 75803 . 76407)) (76453 82797 (CHARACTER.READ 76463 . 77717) ( -CHARCODE.DECODE 77719 . 82795)) (82798 85968 (HEXNUM? 82808 . 85151) (OCTALNUM? 85153 . 85966)) (90440 - 102934 (\OUTCHAR 90450 . 91586) (\INCCODE 91588 . 92774) (\BACKCCODE 92776 . 93670) (\BACKCCODE.EOLC -93672 . 96435) (\PEEKCCODE 96437 . 96753) (\PEEKCCODE.NOEOLC 96755 . 97017) (\INCCODE.EOLC 97019 . -98878) (\FORMATBYTESTREAM 98880 . 100366) (\CHECKEOLC.CRLF 100368 . 102932))))) -STOP diff --git a/sources/LLREAD.LCOM b/sources/LLREAD.LCOM deleted file mode 100644 index 10fbf4f7b76464cf2349aea9161e5429dcaf7158..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 25465 zcmd^odvIIVnI8a3mW@~pNGq}|EAlaH$s}Vkc<~vpgNp}+#|16~fO^=BX-I$t5Lcv@ zr2NRMw&U$KNz+*?e#LR(MzLdOH=6}Pv9s30n7I8TO6#f9C>guc&N|)AbS9nILaXge z9uup-@0|MtDJg09kIqyx2Jb!h+;h(No$vj9=ejQzpG;=sgOf=)KA6l-Dr{#?il(JK zapp~Ci}AdiEabdwXFe{)ic&=GXpTsQIP?4Z-F-Ab6upY^81n`~gVOOMg8^T_kEav9 z(1d^7%lf>B=Z_w%sg*LDpJQI;{!FZp{@guNi}&T2ueheXR8%qs75P~{R*cA&)nIe&JAhsBvjI&q4e&i0FhtS- zn*`kU`(d*;cJE6YTn?A?tW>VGpKcX7Z60!!%lzU;4$o}+RZez~Pw^e@xv7iat}5!~ zYPoi!1OLug;7{=P&O7R9arGmYZ?;`+pX%msX%DOAa&0pwj`YnmK+97Ve;fbC(dYM% zv+2TAgg{_K$_8n(5g(IeS&4#bli5AkL4PpFrl)gRDH9iMLwjT;B0&fil&O3a;x_<- zxM~OAD3kJe=^&8k3$UqNE}oAip4DqjomKMbIpMZQ_|3-)%1bctnedv13n&btqupLjVb zgvZ3`grvGs-JXOYYC{kLd*a!6J{cV%bP+3C#0KaR=$(wk_t_9zh?BmIWu$0cp*83n z1zjiaA+?Q_IGiAXY*Kd9f6$GEbTU_n=eVU*Fy2_peQRa(Bpd0V;)k!ZQ?X9N`#78e zScj0g!Hvm8jVqRNGkW%%3{#=`(TwQw_{*|>#e1x7ntd`OzokCdeo;P?;7rhJyp?`I zh~xCz!!owh?*oD~LS|!r1`(T(3JDg%Hd_>~4U3y0nf`rjTup-%;`BfWdW+V^F!>0P8CTW@5-j4_BBIw4 z%hy0GU7Q#q&qlbW7Gz@Ol;B2bwKv6ge0pVvxbW~>{*&V5abM$ojgcI`7agTcq2DU2 zi|uFmB0TEx_Q~|AP2vXh1P1HS2H?RlgRY<}qw+*XO2-GIN;V2dC`-=Jpb%he1lFwf zSksW)VACHDkFZQy!{{(*GOkPx!SYQiSq3}Uwu?k>roliO2`}vW6!SxX?dr#xgxxIY zcHDY1YLmbqRADpvZ8|@M*=X;$9>$VwG~i={rG+DlgZ)rhFtIFq%=fcUl(I1?AA=_e zQ=9bIiyK`oM+Np{J#q2reNWU&J^l@<3)i(LRafb>+J(#NlWJG#jJiQwZYVWp9)wtO zSk14qNxltyd#5zHQI*BjmCUcQFu&wZ^DCLEw$mS?8AwWy(_q)}FsQ&JhIIyUVX@AJ z*H~xQu#Egc?B>->C%->nT4$r3*4en#G-6}6I~a~)1Bb6}AzF8GkSwHlejjYh!TpJ3 zFGK?av|kqYzXs$3hw zbXV;Fb)h?5h=O%EU4FP^hVaa>4ldXEdgSVS%|c_kdu9oh=-i%@@&yX%72|slKQS#o zO@Q~auDfRDXBc`jSdTxx!*Rh{W>;eMvKHREY1y=BF7 zsX5(J-7{Nw^S0K^)|RrZtZWsXx3@${WTiS!+n?kj+mkMrIB~RJRb3bEZ+yM}ZmIEg zt?Ah;zsusu1C6g}jn65))cTUri{_c$#+QutZPfmvvW?oeHNN;D&7x_9Wcf!fa^|@$ z@WgpXQr*C(x3~YW%Xa_dk6eGM#@ao9@=;~W%no=3FSqK-j*G7;JId;v7oTq_JNR$_ zSLu_#HT&gR`O~U(SrQ!~|s} z@ViURKuZ~DE^CW!{G~F~+^Lo@;;TwXWj}pF2`NK-^tbuw=kYtyQpTE}R<^Gs6rU1k zuSn?0!SkBng%th91kbC42)u7qzbxj*yUp8bO&{hSQzn!VL0rlfWneQOsIh$wHbaf) zmF-`vV&1-=53aGh>PB?OiselV}XE>a1@iDOdiOwfZu#q z3)K6V006>}*3V;1IY^9AEM<_5Xn_FDJ+zMs^X?Lw^TV&SzwDx3$?i;6YTQ^gziU2#`ONBh05GrORO~a7%SJ1 zNT4^a{HB|QAcno!c{VpcH~2`kwp3X>Rytgv0Q^Gf@Dh>~^#0mOy=kyf;bmocNZ zBt~mO!a$3O8A2GIRDt}Y^_*%E(z1rKexLA>E&K_yd;bPYcuNF4Ig9joySTty4VYSa zz0hW4wX2rqs`&^TJNsk@BecmxEUOMmSS-LSSq^4W^ zx#x{=J=wi-f0)1XfIWheT^m8kz6I4DY2K`Km(|I3b8kz$_-1Wp%gP~T>&gR4x5|Do z+g?eD2Q9f;R#X8|ik5e`6yb%RRkk!$xd!>#cu3vTZk|!LR@*QTFl1}_ zav}9X7OVPpD*M)(2=KIQ+RbrwGm-yo z8m~Owyh+`xUkj_^`q?i?>gKmNfxj*WSayCR&6!5;`Epvn67L}FD5c+;F3+}4EIT)V zXHG6VzOsLt#>B8ZPb@qBUR#Xnrn|pO2+L$;Z@P?@=0{tJ)$0h1a=raZS?y{+(^5A# zhG9-Oe6;!j{qd}Lax3*gM_2o6E#xM+QSuaCc|3h4B1S&-xinrp^~h{vDYDuvtAE@+ zRZq`!FFP&(4L8Yxfe&Z^I?ifuHN$clU7u_5uHS`eb!u4YZSJ74PA-42tn}jT-N{t_ zy?4@Jz1haie3qUX7*b_tzIZ*1ZU|pp|1oSO@$wCz1w@QQ%f~nRH!SOLxNGMZs zEL(*2hT%-{5CBt6M-%aAnvy0%(Yy>Q9)$$aL(mjI)XhQ|4CbpM%K}BHKPACr&%oH_ z3HU5Dj-(hx`$J3KJDd(DC)*rnD016<5Fo|Lyh2HR zV8uTA6=xKaQBIT3_Xa-aVa~M8=O?~86*a=CwxV^ ztU*ISm!Ta=I6M+De_SBc8BOLf7Ec25unLVeVnTH4l4UuHz z&~F)N32Wf6#Tsxr^86vkj7ajGcN8f)k`Q<6nhAUN758_G@Q9`gdl77%dRAmb5=PSb zBv9=iWt0J-kn>cuIF(1nl++~yRU1(f@=+}2972=!Wc0Oj&DYRupjS=zjQKis52_tZ zZNlJwSnd!7*G#`_#ZzH%+NsDwqodkpUx~2bpHOKF5w0S~2IER$P|0C$^`sEC^F{A1n_Go>@V!Y7qEOv$-3N1^IUD!YYwh5^4RKd|h2fg3a51(+w7yZ+_!hVP)zA>M9&q*aGUzy&JzG$9v()Lt^6w@%wPC?eaJw+=QLw6}SJ}C;Q|U(VRM}Q2Ca>{70 z>_ZHDTdUzywyjJO!H7OPSMN;DDjscdH=5TVC1Ml+)~I)2AN#zs@pJw@`L(f^II_PJ z11`ZW*tbuJeY;KZ=;dRxQOz_~c5VmD(a4<}DAuzBw(fYR9X!+u*Oj5}neBME10MG6 z9SFiu$~FaLB640>0;o`XoUv*=NXR<8-<#;o>>0ih|-JS zlCllI_v^cf>$|vAU;g0s#L9ozKXzjIw`XWCrk8))6yt$N7TV23tH*O|SelK-#8S>F zBfY2GFz;74)(+p3{wlWmONpn=tvtE>+r{iRvo6<*_|Nrfw(N2_Z%KR9CAdOisb&n5 zehzP9vUuXe^5qPl{}bB$ffQ2quVMP*ZG_PiC^OyD-MpIzb%D~re^R^Kr#7jZl)#Vo zbkBs0+t80WL!~|0mofF%Y5MPo>02ob^&Gh*v}6z5q-I}Osz$j>b52{yZ_Z#PAN*Td z$#0g$N`CWtN-m2U05^DfSv_c_a4 zp|+dH38hgH<_L=d2fh`2yj8DhK_0rUWk+{rb#sI1k)ywLp5y5MGOhawos~{5|N7E8 z_}Axt*fw{%{ItBCV@=F$i6O3;JAvYzuI6nSSM%0P*_Cm&|IFz$jM1NDoM$qwvzYwh zbtc!~{`4BK#jLm5ApX=%84UCB#MhU9J)nd7%S_kz)2BYf$HCTYKPSIQ`}FG@2m!Y| zk-5Jm+{9_u$>m@Dqx=BxD7&iLr?=m-{Hy=QecR<<{byLrVLxI%pk`~mH`aHSER zr?jMPLLXHS>3Iun730)qb*9HLxE0PZBm-c_6i|#xrO0Dc>TI8BOmjxas)Esnk_8k% z03A565F66$;URAGWhI%7qN>_-s@VuUWXtd)qp-PnN_0repp1+HOTZ$H&eJ6$!{Y|@ zT1sU^0A`8#4WpBedcIM*dmlojjb*+NT<;EWLa5KtUky?brOn3=0y6z+fZ_vYjamSK zO#P9ckZ(S+1{G+l^wl7d(@`^Iri%z*7{C58nB=>Ln12lMMEW~A4!XN)P;!*^=;}SL zQHp|DsGKP$C#i6G)CV}PI^GCU+}G%F&H9=V_`NvUf@GS1_}Xz-s{Og@l7!yV47184e;qv&-IAY0~!!tULDvfmf;C=-KR)#w`Vz1sBwkPcn z@-o6Vh;LcL$RWIFJ_|yCnZ6MV!bPz>gb*_C0$_o)>)?q#BW&cy`pq{wqfJN&>ODb- z2=*cZ;hma0T3R|>#krf$ORO??c>XxjdkeTlDo(Aig-WT6EFX@+Aief^30buc_R>AL z087E&%5hf=;im(|Jm`H-CY~)8sN(ewhXaM*vk_tO9dd7{qfP1>vZ!U?5H~rYWEL^&;A7C7;~GgGIVj)|WSeh+GyTh$?xhJd`p| zdC0FEx%Jw~E9|{gq`-iTT$G<_!pO%s=K_Xtz_2N{dh6t$hoy+HOIA12rC#(Df7X)P zHu`YYEnIO;mXjxL1AvOOk;>-BGawdh5>o??AsOMFnDCM-?wz20;IMXxe;wSAeFqSu z(18pv;8Rv`o(WnNaGKyf0Pr?)0QgUI^&|Xm1TpjGt`@&;+|7-F_R4>cmidN#wH0l= z&#xNqAzE&QKNglaKy{JwL{!&3+E!DYa0gi-LxPUlq6c}z5o$@OBg&jZd#_;z zB5G(iua_Z~%5epU9=L+UqefgO=N>MpwK7|L?C7C+6@TWIN{>={d6)O|(k}F&j50`m z3Hj;@t30~2P-2JY)%m%;#eP;oqWK|u@ECi9^5T`n!=+=DGHpeNrJ(Nu!g$$2G>#&C zKS?H>`J?zKkE8GmrZw6C`uebw5|}PJ^|LpE63q{H+bYD9S;NT5@z|OX`UT%91q_|l zg1_8Mh{bco1V;5B`m2?_!y?bs-#v^bUUUw{t!aK>uHS7PUyq$>HjX~lU5LRsj$TFz zl^bt-;}3qT>fv{yXhW1CC5V$L^eq>PX{wyfNVyo$Kw+db7K;fHl_ zOL)L#^{)0e#HCgqjuUl#?eCV=&rpu&f%bFaAzJTfe^Yat&7Pave_lo`7?>k*a@^S3JVL3H7sg@MamNi(*!+cKoR|o2-s0pLU*Fiuz7mTkbd?dO(KNd7KawL zX3zzcuAgltsjNj;7)rSKMn1)Vd!D{Q1LELm)rUhax214;aOD=%D9ozvpJ~rj-%l?b z+R$qJED4k}`@?lm?U~5xmNcggK9E-Q%Nx>M)_b&<3A4?cM7fjJM0;08^y=&Iy)hJj z2@Q9z-*3A8yoPV|8E7{j>G9ndE{hs|F0lA?D}RIvu->zg)!Re?8DEvmfBBDAvT8PP zktK_ziotM@kYX2GS2ru$kRacR_(S6bW!r9qD;j@RRwvpoY3tV)tPp9;Q~FT7UJO)L zBh+??w+U|(i#|YYkMcH;-Y-vW3+)$L;fUTO5&e|f%^d6$HA4V_56VG!O}l9k!BSP4{qghm$DeJ#s5OZ0 z_t19n4Y(eBB#x$H6xLq(DDlF|&6G3#tFn3{@y2FaV1K*0MZ6&dhyYym5@I=&0!Z=j z2d?wt_{v?YoB1q4^dJ}(#sMCsmjowjs}PUpKF-LPFvrA^))Cak=#@cKd8PG%(@544 z9oQI}0>kigQ6mso+H>UUI8P4a;2zodL&Us8Q6)nr4jYD7qe&Y!3}1n2ufVHAlQ@}; zj1Sx<*e!WBtnoPtx-gwq#Xw$zzm>vA<6>q+32L&;6CIK;gSYmyz2uAPy!>skPSGh!-Ms*rx!ss*gii$ z?O|IHj*M#y!r!sSM&X*lk0|5t_8c6CYH6{0v~+l3o|o{!7=y#>O{!|;NJ-`X zgl>1?5j;`v9rwV-nnN|=@xx10%6EKDq}4_+}RCfcqR0M2~hjzP&Ok&NH=FhV+YF`o#|Y;wJ6lb?qs;eASiivohmV<2zvfa2KgJ(BRen3F5-Aazm6-nZFcr3Xm z$vqhBc|}o?3CREcbA^Q-=BIUs%E}hErl=rMOgjxrSF7~ zzJKA6qoqpWODkK$>V22Kue!sk1jXz?(3pN{3wigM#y_S2JH)IeXdtCHbo#>K<)Dmqp@dr9hv3F{y6~li zh0UvclLkGr~7|7Xpkbuc>K(h7gY*6|heYvU6e+(v1?ru~KW z>T+@hskS}BtO<+#-n)Yf6@IKykR}~{y#h$22-i0ZNY}3W1oD_p;AWK~LnL;B{z4x? zt0F)(fj^L@I4j67=LG(e^!5i3ScsI$>>>EQ$H}k7cUvlpi=cK8ONRl{d2 zBQl=Y=mPFJMtY62l)&X=&4!llm3!NC%HoNs$u%UgCb9ObV)- z(m(d>dtMA$_0+}AiCg{_pKY3VzE0gF|Cq}SQCG#SJk7@QqgFwS%iz;5oDe$%14D$? z8bXJv=Kyw8FC%1Ogo`ci8AQK9+`u1#P;_r4(SOjb87H=sShApnOuY9B>A#*8AX^l>`En5AR zKq$GnO>l|oI(nH4a4~eb`R>t|f8inSzGdyRv+CpTiVw?R&l6pggLZtmep<_>l}{`? zPWJe(MFF!~Uej20zX+##%u2#)9tO9?K3?!suqO*ss+KLv};{>TZ~l%iidUSg#0l%+wr(X?jtHT(+32*8V? zj@-1z5gh)F7GxR3;&>}>BI!oqc5ehWzwrXnAn|B&GKr(&FvnnnA})Bf4*hN&4wL;* z2!_N)JoZTu&m-mj629r+lA5y4FFtaC!4sUSxyIkoKw0q=QPJ`COU5JEOQ5GyrLfv1 zXoTmx4>?XL^;vxAC@jRKFdH@vd4*U3@L2 zK6LS6s%_uffc>3}KEOHP< zt;$rk$UQ~tEq%cWgiIEa_&|!$HJ+yeRir?*C1{C3EMbCw`KCEAi{NSa{Mc$&{te+} zsIFwU6j{Aq$mqm-oM2iW(Wl4hq{Ah^2s~9fZAO__{B zAYY{IhvAE(74xszrIVYw5D-0ei@g*mOGHyobocg@t|MqR?C<7heokdXKO8JT@}qfg z`1}N(c}|Dxsct%UFsOAt6RxMbPciNB*>GL%M%3$jw8b0t_nw0`>u%MgX1|3DIu`I| zxSs8PPsb?u10s-+$Uk$SW3dl;PVI;a>_b7IbXZxt!bi?{Zc}d%)M8@9#5PLT5iT}u z42{;Y??>>RlrDl}6W6x}Gg0-kcE;i9geSodUEI=&*biNtP&a#2w+Em%|EvB8$DIBL z9kxIS5Ey*Fg&=;JOF$9=^eGv8Z9mowv7;5&n;U2V(E-zt)>8*<9iTu6ro=GEVGa;1 z$&3lB%ve`s*l88v8mru}i4mCJC|||5ovtoEke69Qn7`ZTbZm&gn0clrw;}p^gd4Xg z|KVa{>U0>)m+C$kO}uyLy4eFsNg)3084=}fo9AF;`<8T`gV7(adk&_?EiQ2mCW5J~ zl4?rh?_O={9+yjeb)fxp(v#HaA!VQ3N)P&@HT0mJz5zJ|sN%*>4v4RS&^aGK=5{^< z9!=I59oNYQXDb9*2x6fl3R00aP2&@jSS*dkj)4hIa8=KD;G1FL@o`kFY!#^t?hEpk zL#~#_$oCqO0!m#HN<9g>e@Xk6oug;9tNw;a#U%gZjXlyVA3)+`nE`Oo`@H*Q{o*t! zv($%4oAIa!kb%f$oPSc3f|S~Q4hO-gibPL)3!oW9v64ezSd@0dRGLmI87NfBkc&og zMEo$(I$rd{Lg;Klyd82Jk^|9Foa$62#Rw?mhr^^zfnaCHYlvHG&k(iLu25B^Aj^ifC&DPNij01Ysi49j6BKrmTPaQ ze$)cwr*gt4BlT_9s?2e}P7>{{2-csS3o;; zgJEe|j@uiZKYDb2POdE;6Cq~4FlJww9>3Q9Ug4WO`qP;Gb1rVQ+rI6A1&A*~?jzrY zqA~QDF8jK?dijhvD{tUP&p&Y_bVeJD8p4jTqVovO%<~Ea4r66OM|sDw4kNA4I*WDI z*2k<{MbeRjx8>;pHhfE2%E$4=TX&4|6fj4_lv!XgC932Ovc4Sa%P9Nc9rcOK^_poh zi1vi`QmfS=aBZ)xTjFBAYA=21r+-$O;3UdKA_B2oc9)JVno?8)pugKf(|3s8)_%NB zfL<_D^-#@M%RyM;(R_EohWK!VmSVe7*m!M7^a{~E8-#8SB2{NuzLoGuZK=xcnAU+X z++L9aqg#uAkKyRc#=3)RIB{s_RP8oi7e2Oe3uYBAHhP-m5K}lUkUW770y$)hf*{~L z@_bW)4Tu;QPUjTxDo132xrd^NuMNQ+<>Y|e+kqGYm-z_ZD?(r3aFCMAM^OG6LrWAd zk`K>UD6$i4KSkPcmdW3F_VJtkJo2PPzxU*ve}1LATr zzCkvaRd7lZNkt-y0aheT4QS>ko>6-iRd@7RD^$m6y--Aqbev59USYgzjzz=RR<+)j zWznZ&LqWKD+7f5q!JyjbPPq^u4dwP0=Z`V9@^D3EDEcD7**V0~N(q~YZ;UXtR<8)X zG&uN3g&jS?aO$8XsKK+%6rs$sXuQm;&Cu9dZRF$s5wBw2$-<;E)a(U^t3*6sV zPOtk~hd4GQd`G)sSs1cJh?c%SZ?1F%315EzfO{vAeKW2n^{f2xL-WU%=x&rc#VV?C zojtDN#z&jtjq}PpM5uT#-07E*3U%VG#nK^^1kxyx(&0M)&u&|ES1oYUYOKm5CEgwJqwje9fR}rM;}|jN7QQo8cd3Z ziP{2Q3y$F0&2NsB=JW<{x*o|Nmykmu-lLNUGgWWny;^qAApr7H6bcx5ArKojiwN3 zL@p-vdwG(Jl4$<_cw#pnFE8d?Gm%)5z7iDlXsg4TOazPX8C(IC=;=0=AI;Npfjjyq zsOXcFx?f+$8y$WxL2vXXIlK0=-^O&E^3@d4b_wn7GiXV893YO|K~!!hue0L_fpyGeSS3^fQJZc${whQg56Jp#LET JutHJB{|%QAFz5gP From 6b66665e9dad1d6cdf65fcc2fb5b7d8f96753c1c Mon Sep 17 00:00:00 2001 From: rmkaplan Date: Sun, 26 Sep 2021 23:41:52 -0700 Subject: [PATCH 4/7] BOOTSTRAP: Read initial DEFINE-FILE-INFO as a string, not an atom If it is ead with RATOM, then e.g. LISPSOURCEFILEP gives an error if the first line of the file begins with something like (Author: --- sources/BOOTSTRAP | 62 ++++++++++++++++++++--------------------- sources/BOOTSTRAP.LCOM | Bin 14608 -> 14584 bytes 2 files changed, 31 insertions(+), 31 deletions(-) diff --git a/sources/BOOTSTRAP b/sources/BOOTSTRAP index 35c66e41..95c549e1 100644 --- a/sources/BOOTSTRAP +++ b/sources/BOOTSTRAP @@ -1,11 +1,11 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "17-Aug-2021 00:08:39"  -{DSK}kaplan>Local>medley3.5>git-medley>sources>BOOTSTRAP.;58 47657 +(FILECREATED "26-Sep-2021 23:38:02"  +{DSK}kaplan>Local>medley3.5>git-medley>sources>BOOTSTRAP.;59 47644 - changes to%: (FNS \DO-DEFINE-FILE-INFO PRINT-READER-ENVIRONMENT) + changes to%: (FNS READ-READER-ENVIRONMENT) - previous date%: "15-Aug-2021 21:21:35" -{DSK}kaplan>Local>medley3.5>git-medley>sources>BOOTSTRAP.;57) + previous date%: "17-Aug-2021 00:08:39" +{DSK}kaplan>Local>medley3.5>git-medley>sources>BOOTSTRAP.;58) (* ; " @@ -15,14 +15,14 @@ Copyright (c) 1983-1990, 1992, 2021 by Venue & Xerox Corporation. (PRETTYCOMPRINT BOOTSTRAPCOMS) (RPAQQ BOOTSTRAPCOMS - [(COMS (* ; "Some basic fns. Note that several are redefined later. E.g., RPAQQ et al real definitions are on UNDO") + [(COMS (* ; "Some basic fns. Note that several are redefined later. E.g., RPAQQ et al real definitions are on UNDO") (FNS GETPROP SETATOMVAL RPAQQ RPAQ RPAQ? MOVD MOVD? SELECTQ SELECTQ1 NCONC1 PUTPROP PROPNAMES ADDPROP REMPROP MEMB CLOSEF?)) - (COMS (* ; - "Need these in order to load even compiled files SYSLOAD") + (COMS (* ; + "Need these in order to load even compiled files SYSLOAD") (FNS LOAD \LOAD-STREAM FILECREATED FILECREATED1 PRETTYCOMPRINT BOOTSTRAP-NAMEFIELD PUTPROPS DECLARE%: DECLARE%:1 ROOTFILENAME)) - [COMS (* ; "For DEFINE-FILE-INFO") + [COMS (* ; "For DEFINE-FILE-INFO") (FNS DEFINE-FILE-INFO \DO-DEFINE-FILE-INFO PRINT-READER-ENVIRONMENT READ-READER-ENVIRONMENT MAKE-DEFINE-FILE-INFO-ENV) (INITVARS (*DEFINE-FILE-INFO-ENV* (MAKE-DEFINE-FILE-INFO-ENV] @@ -76,7 +76,7 @@ Copyright (c) 1983-1990, 1992, 2021 by Venue & Xerox Corporation. (AND (CCODEP 'BOOTSTRAP-NAMEFIELD) (PUTD 'BOOTSTRAP-NAMEFIELD] (P (RADIX 10))) - (DECLARE%: DOEVAL@COMPILE DONTCOPY (* ; "eventually imported from FASL") + (DECLARE%: DOEVAL@COMPILE DONTCOPY (* ; "eventually imported from FASL") (CONSTANTS FASL:SIGNATURE)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA DEFINE-FILE-INFO DECLARE%: PUTPROPS FILECREATED SELECTQ) @@ -810,11 +810,11 @@ Copyright (c) 1983-1990, 1992, 2021 by Venue & Xerox Corporation. (FETCH (READER-ENVIRONMENT REREADTABLE) OF *DEFINE-FILE-INFO-ENV*))))]) (READ-READER-ENVIRONMENT - [LAMBDA (STREAM DEFAULTENV RETURNFORM) (* ; "Edited 30-Jul-2021 09:58 by rmk:") + [LAMBDA (STREAM DEFAULTENV RETURNFORM) (* ; "Edited 26-Sep-2021 23:31 by rmk:") - (* ;; "Starting environment is the old interlisp file, just for the seprchar scans.") + (* ;; "Starting environment is the old interlisp file, just for the seprchar scans.") - (* ;; "RETURNFORM=T means return the DEFINE-FILE-INFO as a second value, for READFILE") + (* ;; "RETURNFORM=T means return the DEFINE-FILE-INFO as a second value, for READFILE") (CL:UNLESS DEFAULTENV (SETQ DEFAULTENV *OLD-INTERLISP-READ-ENVIRONMENT*)) (LET ((START (GETFILEPTR STREAM)) @@ -825,32 +825,32 @@ Copyright (c) 1983-1990, 1992, 2021 by Venue & Xerox Corporation. ))) (DECLARE (SPECVARS *READTABLE*)) (SELCHARQ (SKIPSEPRCODES STREAM) - (";" (* ; "Assume it's a common lisp file") + (";" (* ; "Assume it's a common lisp file") (\EXTERNALFORMAT STREAM (FETCH (READER-ENVIRONMENT REFORMAT) OF *COMMON-LISP-READ-ENVIRONMENT* )) *COMMON-LISP-READ-ENVIRONMENT*) ("(" (\EXTERNALFORMAT STREAM (FETCH (READER-ENVIRONMENT REFORMAT) OF *DEFINE-FILE-INFO-ENV* - )) (* ; - "Should we reset the format if we fail?") + )) (* ; + "Should we reset the format if we fail?") (READCCODE STREAM) (WITH-READER-ENVIRONMENT *DEFINE-FILE-INFO-ENV* - (IF (EQ 'DEFINE-FILE-INFO (RATOM STREAM)) + (IF (STREQUAL "DEFINE-FILE-INFO" (RSTRING STREAM)) THEN - (* ;; - "After the \DO-DEFINE-FILE-INFO, we have the new environment and we have set the new format.") + (* ;; + "After the \DO-DEFINE-FILE-INFO, we have the new environment and we have set the new format.") [SETQ ENV (\DO-DEFINE-FILE-INFO STREAM (SETQ ARGS (CL:READ-DELIMITED-LIST (CHARCODE ")") STREAM] - ELSE (* ; "Hope we are RANDACCESSP") + ELSE (* ; "Hope we are RANDACCESSP") (SETFILEPTR STREAM START)) - (* ;; - "If we didn't see ARGS, then we didn't see a DEFINE-FILE-INFO, no form to return.") + (* ;; + "If we didn't see ARGS, then we didn't see a DEFINE-FILE-INFO, no form to return.") (CL:IF (AND RETURNFORM ARGS) (CL:VALUES ENV (CONS 'DEFINE-FILE-INFO ARGS)) @@ -981,13 +981,13 @@ Copyright (c) 1983-1990, 1992, 2021 by Venue & Xerox Corporation. (PUTPROPS BOOTSTRAP COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 1992 2021)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (4748 14420 (GETPROP 4758 . 5330) (SETATOMVAL 5332 . 5461) (RPAQQ 5463 . 5516) (RPAQ -5518 . 5830) (RPAQ? 5832 . 6202) (MOVD 6204 . 8068) (MOVD? 8070 . 8500) (SELECTQ 8502 . 8689) ( -SELECTQ1 8691 . 9033) (NCONC1 9035 . 9231) (PUTPROP 9233 . 10717) (PROPNAMES 10719 . 10910) (ADDPROP -10912 . 12975) (REMPROP 12977 . 13831) (MEMB 13833 . 14092) (CLOSEF? 14094 . 14418)) (14493 35057 ( -LOAD 14503 . 15672) (\LOAD-STREAM 15674 . 28748) (FILECREATED 28750 . 30168) (FILECREATED1 30170 . -31278) (PRETTYCOMPRINT 31280 . 31765) (BOOTSTRAP-NAMEFIELD 31767 . 32727) (PUTPROPS 32729 . 33097) ( -DECLARE%: 33099 . 33231) (DECLARE%:1 33233 . 34105) (ROOTFILENAME 34107 . 35055)) (35095 45489 ( -DEFINE-FILE-INFO 35105 . 35540) (\DO-DEFINE-FILE-INFO 35542 . 39888) (PRINT-READER-ENVIRONMENT 39890 - . 41443) (READ-READER-ENVIRONMENT 41445 . 44211) (MAKE-DEFINE-FILE-INFO-ENV 44213 . 45487))))) + (FILEMAP (NIL (4726 14398 (GETPROP 4736 . 5308) (SETATOMVAL 5310 . 5439) (RPAQQ 5441 . 5494) (RPAQ +5496 . 5808) (RPAQ? 5810 . 6180) (MOVD 6182 . 8046) (MOVD? 8048 . 8478) (SELECTQ 8480 . 8667) ( +SELECTQ1 8669 . 9011) (NCONC1 9013 . 9209) (PUTPROP 9211 . 10695) (PROPNAMES 10697 . 10888) (ADDPROP +10890 . 12953) (REMPROP 12955 . 13809) (MEMB 13811 . 14070) (CLOSEF? 14072 . 14396)) (14471 35035 ( +LOAD 14481 . 15650) (\LOAD-STREAM 15652 . 28726) (FILECREATED 28728 . 30146) (FILECREATED1 30148 . +31256) (PRETTYCOMPRINT 31258 . 31743) (BOOTSTRAP-NAMEFIELD 31745 . 32705) (PUTPROPS 32707 . 33075) ( +DECLARE%: 33077 . 33209) (DECLARE%:1 33211 . 34083) (ROOTFILENAME 34085 . 35033)) (35073 45476 ( +DEFINE-FILE-INFO 35083 . 35518) (\DO-DEFINE-FILE-INFO 35520 . 39866) (PRINT-READER-ENVIRONMENT 39868 + . 41421) (READ-READER-ENVIRONMENT 41423 . 44198) (MAKE-DEFINE-FILE-INFO-ENV 44200 . 45474))))) STOP diff --git a/sources/BOOTSTRAP.LCOM b/sources/BOOTSTRAP.LCOM index e93e61bb1e7c3ae9c3f83da5614433f22e6c26bb..faf5fb5bf52e35c3d447885572b47e8c9b214f6f 100644 GIT binary patch delta 368 zcmZus!A`vq`Da7L7-QiW0O4d|hll*o0vdE?|c^<#bvUSbFQ?-g0QhB(4WEh49)A2?S4~exkU9JZ_Wc`@+QsxWN zfiy@;?7Ra`%XOT8KiK3o59&dbfQ*W&;&G{hPtwC~T^e6XpZHVnN^?BZuax{qRJUAA zxfnRmZKVkbOAF)MGzQCdajUD;HlZJSB8g9Y7V-fXiAczk6fCO)NgA`^s22+0Kr9fC muJK#Hmt1T$7FDp!HfTNzc*IDdOn4OBi2qPAs=Kd7eDVi}gj`_& delta 327 zcmexSIH71ln24ddu48Gsu91O}p@M;dm4StovE{_9Py-811tmjMgq)Fqm5HI1iKUVP zS5i@Ga(-?>W=?8~LUKl8UV3V=s@3HC@?w*Z>q@$2<|!z-h5Gm?AnVrC(^FDNNh|^C z;KE|8sfm&%mxi0CkE?T#t7C|(%j8##F%k+U=4PhmFe?;F@>Q)AG~E1xCvVWzpL~;1 zL>Sq5hE_&~R>r22m|PjnH@h(Ufo4Q(C=P6i-I2N548t7sYv7%Bw2 zhJY*#2nkX!G&TY`pV`pJY;uF9B!_{eLXcyKzwhJ?n&Dzb3NEg0o_?;nAl15_es2B> RhK44SIka*%cWdSH0RUlhSV8~* From 1d4c9ed6eec4a001aa433de9dd3327361d50f387 Mon Sep 17 00:00:00 2001 From: rmkaplan Date: Mon, 27 Sep 2021 10:28:50 -0700 Subject: [PATCH 5/7] BOOTSTRAP: PRINT-READER-ENVIRONMENT puts out an extra EOL To separate the DEFINE-FILE-INFO header from the actual contents, when using TEDIT-SEE (in Medley) or lsee --- sources/BOOTSTRAP | 31 ++++++++++++++++--------------- sources/BOOTSTRAP.LCOM | Bin 14584 -> 14652 bytes 2 files changed, 16 insertions(+), 15 deletions(-) diff --git a/sources/BOOTSTRAP b/sources/BOOTSTRAP index 95c549e1..c81fa655 100644 --- a/sources/BOOTSTRAP +++ b/sources/BOOTSTRAP @@ -1,8 +1,8 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "26-Sep-2021 23:38:02"  -{DSK}kaplan>Local>medley3.5>git-medley>sources>BOOTSTRAP.;59 47644 +(FILECREATED "27-Sep-2021 10:25:31"  +{DSK}kaplan>Local>medley3.5>git-medley>sources>BOOTSTRAP.;60 47698 - changes to%: (FNS READ-READER-ENVIRONMENT) + changes to%: (FNS PRINT-READER-ENVIRONMENT READ-READER-ENVIRONMENT) previous date%: "17-Aug-2021 00:08:39" {DSK}kaplan>Local>medley3.5>git-medley>sources>BOOTSTRAP.;58) @@ -784,9 +784,9 @@ Copyright (c) 1983-1990, 1992, 2021 by Venue & Xerox Corporation. REREADTABLEFORM _ READTABLEFORM]) (PRINT-READER-ENVIRONMENT - [LAMBDA (ENV STREAM) (* ; "Edited 16-Aug-2021 23:51 by rmk:") + [LAMBDA (ENV STREAM) (* ; "Edited 27-Sep-2021 10:24 by rmk:") -(* ;;; "If ENV is not the old default interlisp reader environment, writes a DEFINE-FILE-INFO expression on STREAM that will produce this environment when the file is loaded.") +(* ;;; "If ENV is not the old default interlisp reader environment, writes a DEFINE-FILE-INFO expression on STREAM that will produce this environment when the file is loaded.") (CL:UNLESS (EQUAL-READER-ENVIRONMENT ENV *OLD-INTERLISP-READ-ENVIRONMENT*) (LET ((*PACKAGE* *INTERLISP-PACKAGE*) @@ -807,7 +807,8 @@ Copyright (c) 1983-1990, 1992, 2021 by Venue & Xerox Corporation. ,@(CL:UNLESS (EQ :XCCS (FETCH REFORMAT OF ENV)) `(:FORMAT ,(FETCH REFORMAT OF ENV)))] STREAM - (FETCH (READER-ENVIRONMENT REREADTABLE) OF *DEFINE-FILE-INFO-ENV*))))]) + (FETCH (READER-ENVIRONMENT REREADTABLE) OF *DEFINE-FILE-INFO-ENV*)) + (TERPRI STREAM)))]) (READ-READER-ENVIRONMENT [LAMBDA (STREAM DEFAULTENV RETURNFORM) (* ; "Edited 26-Sep-2021 23:31 by rmk:") @@ -981,13 +982,13 @@ Copyright (c) 1983-1990, 1992, 2021 by Venue & Xerox Corporation. (PUTPROPS BOOTSTRAP COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 1992 2021)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (4726 14398 (GETPROP 4736 . 5308) (SETATOMVAL 5310 . 5439) (RPAQQ 5441 . 5494) (RPAQ -5496 . 5808) (RPAQ? 5810 . 6180) (MOVD 6182 . 8046) (MOVD? 8048 . 8478) (SELECTQ 8480 . 8667) ( -SELECTQ1 8669 . 9011) (NCONC1 9013 . 9209) (PUTPROP 9211 . 10695) (PROPNAMES 10697 . 10888) (ADDPROP -10890 . 12953) (REMPROP 12955 . 13809) (MEMB 13811 . 14070) (CLOSEF? 14072 . 14396)) (14471 35035 ( -LOAD 14481 . 15650) (\LOAD-STREAM 15652 . 28726) (FILECREATED 28728 . 30146) (FILECREATED1 30148 . -31256) (PRETTYCOMPRINT 31258 . 31743) (BOOTSTRAP-NAMEFIELD 31745 . 32705) (PUTPROPS 32707 . 33075) ( -DECLARE%: 33077 . 33209) (DECLARE%:1 33211 . 34083) (ROOTFILENAME 34085 . 35033)) (35073 45476 ( -DEFINE-FILE-INFO 35083 . 35518) (\DO-DEFINE-FILE-INFO 35520 . 39866) (PRINT-READER-ENVIRONMENT 39868 - . 41421) (READ-READER-ENVIRONMENT 41423 . 44198) (MAKE-DEFINE-FILE-INFO-ENV 44200 . 45474))))) + (FILEMAP (NIL (4751 14423 (GETPROP 4761 . 5333) (SETATOMVAL 5335 . 5464) (RPAQQ 5466 . 5519) (RPAQ +5521 . 5833) (RPAQ? 5835 . 6205) (MOVD 6207 . 8071) (MOVD? 8073 . 8503) (SELECTQ 8505 . 8692) ( +SELECTQ1 8694 . 9036) (NCONC1 9038 . 9234) (PUTPROP 9236 . 10720) (PROPNAMES 10722 . 10913) (ADDPROP +10915 . 12978) (REMPROP 12980 . 13834) (MEMB 13836 . 14095) (CLOSEF? 14097 . 14421)) (14496 35060 ( +LOAD 14506 . 15675) (\LOAD-STREAM 15677 . 28751) (FILECREATED 28753 . 30171) (FILECREATED1 30173 . +31281) (PRETTYCOMPRINT 31283 . 31768) (BOOTSTRAP-NAMEFIELD 31770 . 32730) (PUTPROPS 32732 . 33100) ( +DECLARE%: 33102 . 33234) (DECLARE%:1 33236 . 34108) (ROOTFILENAME 34110 . 35058)) (35098 45530 ( +DEFINE-FILE-INFO 35108 . 35543) (\DO-DEFINE-FILE-INFO 35545 . 39891) (PRINT-READER-ENVIRONMENT 39893 + . 41475) (READ-READER-ENVIRONMENT 41477 . 44252) (MAKE-DEFINE-FILE-INFO-ENV 44254 . 45528))))) STOP diff --git a/sources/BOOTSTRAP.LCOM b/sources/BOOTSTRAP.LCOM index faf5fb5bf52e35c3d447885572b47e8c9b214f6f..a431b0c730486e8a08286a079d2fa4b64677958e 100644 GIT binary patch delta 183 zcmexSxTk1BxUjiyaB6|Bk%5t+f}w$xk*Srj;l!*ECNqPH2MpK(f;{~~bSFEi2~U2Y zD>0daQJ#@&;z7~LHjKj9G)`i2Q8F`7Ffli?v`|RSNX$!5EmkPWSG7{maPtdR;6gD@ zeDh64M`eLiEKCec4k26&Krm?|!~V%ys$0bzIYC^33;_lWLrZgo5Z54}R)x(^R7HdV DM6fVs delta 150 zcmdl}^rLV>xUiXSaB6|Bk%5t+f|0S6v4xd^(Zs9}CR59a2Mkz(Tpe8|KV%e{tjH)o z*^yBLo9f9mj4leMmI@~3W+o;I$r*`x>8ZsECHbmW3L0*H!3tbZLxeZ;FgYp<9ARN% fU~&lIVgQ0k8yR*^j#b^tDv%+-ps`s)O+**~U&JSh From 09fec6ac5684151c0b6a7f62ee559a6b8afc5add Mon Sep 17 00:00:00 2001 From: rmkaplan Date: Fri, 1 Oct 2021 12:22:02 -0700 Subject: [PATCH 6/7] Add FILESETS back For some reason, in going back and forth, the hard link between the versioned and the unversioned got lost, and the unversioned was effectively deleted. I did a copyfile to get things back in order --- sources/FILESETS | 169 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 169 insertions(+) create mode 100644 sources/FILESETS diff --git a/sources/FILESETS b/sources/FILESETS new file mode 100644 index 00000000..42828dca --- /dev/null +++ b/sources/FILESETS @@ -0,0 +1,169 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(FILECREATED "11-Sep-2021 00:01:52"  +{DSK}kaplan>Local>medley3.5>git-medley>sources>FILESETS.;10 6469 + + changes to%: (VARS MAKEINITTYPES 0LISPSET EXPORTFILES) + + previous date%: "10-Sep-2021 19:53:14" +{DSK}kaplan>Local>medley3.5>git-medley>sources>FILESETS.;8) + + +(* ; " +Copyright (c) 1981-1990, 1998, 2021 by Xerox Corporation. +") + +(PRETTYCOMPRINT FILESETSCOMS) + +(RPAQQ FILESETSCOMS + ( + +(* ;;; "contains all of the lists of files which are used in various ways") + + + (* ;; "I took out the EXPORT of the filesets because it led to inconsistency when one had loaded ABC. -- Pavel") + + + (* ;; "The file with the default EXTERNALFORMAT should come right after FILEIO, and particularly before ATERM.") + + (VARS * FILESETS) + (VARS EXPORTFILES) + (VARS MAKEINITFILES MAKEINITTYPES RENAMETYPES ABCFILES READSYSFILES DATABASEFILES) + (VARS DEADFNS))) + + + +(* ;;; "contains all of the lists of files which are used in various ways") + + + + +(* ;; +"I took out the EXPORT of the filesets because it led to inconsistency when one had loaded ABC. -- Pavel" +) + + + + +(* ;; +"The file with the default EXTERNALFORMAT should come right after FILEIO, and particularly before ATERM." +) + + +(RPAQQ FILESETS (0LISPSET 1LISPSET 2LISPSET 3LISPSET)) + +(RPAQQ 0LISPSET (PACKAGE-CONVERSION-TABLE LLFAULT LLSUBRS LLBFS LLNEW FILEIO EXTERNALFORMAT + IMAGEIO LLBASIC LLGC LLARRAYELT LLINTERP LLMVS DEFSTRUCT-RUN-TIME + SETF-RUNTIME CMLSEQBASICS LLARITH LLFLOAT LLBIGNUM LLREAD XCCS LLCHAR + LLSTK LLDATATYPE IOCHAR LLKEY LLTIMER)) + +(RPAQQ 1LISPSET + (ASTACK DTDECLARE ATBL LLCODE ACODE COREIO AOFD ADIR PMAP VANILLADISK ATERM APRINT ABASIC + AERROR AINTERRUPT MISC BOOTSTRAP CMLMACROS CMLEVAL CMLPROGV CMLSPECIALFORMS LLRESTART + LLERROR LLSYMBOL LLPACKAGE PACKAGE-STARTUP CONDITION-PACKAGE XCL-PACKAGE PROC CMLARRAY + DSK UFS UFSCALLC PASSWORDS FONT LLDISPLAY APUTDQ COMPATIBILITY DMISC CMLMACROS CMLLIST + CMLCHARACTER CMLREADTABLE MAIKOLOADUPFNS MAIKOBITBLT MAIKOINIT)) + +(RPAQQ 2LISPSET (MACHINEINDEPENDENT POSTLOADUP)) + +(RPAQQ 3LISPSET (MACROS DLAP BYTECOMPILER COMPILE)) + +(RPAQQ EXPORTFILES + (MODARITH LLPARAMS LLCODE AERROR AOFD APRINT ATERM LLARRAYELT LLDATATYPE LLNEW LLBASIC LLCHAR + LLSTK PMAP LLGC ATBL FILEIO EXTERNALFORMAT LLARITH LLFLOAT FONT LLKEY LLDISPLAY + ADISPLAY AINTERRUPT RENAMEMACROS HLDISPLAY WINDOW MACROAUX ADDARITH LLFAULT LLTIMER + IMAGEIO PROC XCCS LLREAD PASSWORDS INTERPRESS HARDCOPY CMLARRAY LLSUBRS)) + +(RPAQQ MAKEINITFILES (MAKEINIT MEM I-NEW)) + +(RPAQQ MAKEINITTYPES + ((NIL INIT (0 1) + 2LISPSET 1600) + (SMALLINIT SMALLINIT (LLFAULT LLSUBRS LLNEW FILEIO EXTERNALFORMAT LLBASIC LLGC LLINTERP + LLARITH LLREAD LLCHAR TINYPATCH)) + (MACROTEST MACROTEST ((MACROTEST) + 0 1) + 2LISPSET) + (MICROTEST MICROTEST ((MICROTEST LLFAULT LLSTK LLSUBRS LLKEY LLBFS))) + (NANOTEST NANOTEST ((MICROTEST LLSUBRS))) + (NULL NULL ((DUMMY))) + (MILLITEST MILLITEST + ((MACROTEST LLFAULT LLSUBRS LLNEW LLBASIC LLGC LLINTERP LLARITH LLFLOAT LLARRAYELT + LLSTK LLDATATYPE LLKEY ABASIC LLCHAR ASTACK MISC APUTDQ))) + (CHECKARRAYS CHECKARRAYS (CHECKARRAYSPACE 0 1) + 2LISPSET))) + +(RPAQQ RENAMETYPES + ((I (FILES LLPARAMS LLCODE LLARRAYELT LLCHAR LLNEW LLBASIC LLDATATYPE LLGC LLSTK RENAMEMACROS + MODARITH LLFAULT LLKEY LLBFS LLTIMER) + (RENAMEDFILE . I-NEW) + (SUBNAME . MKI.SUBFNS) + (COMSNAME . INEWCOMS) + (EXTRACOMS (VARS INITPTRS INITVALUES) + (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) + MAKEINIT))) + (MKI.SUBFNS) + (INEWCOMS) + (VALUES . INITVALUES) + (PTRS . INITPTRS) + (PREFIX . I.) + (VAG2FN . I.VAG2)) + (R (FILES LLCODE LLPARAMS LLBASIC LLDATATYPE LLNEW ACODE LLARRAYELT LLCHAR LLINTERP LLSTK + RENAMEMACROS MODARITH LLFAULT) + (RENAMEDFILE . RDSYS) + (SUBNAME . RD.SUBFNS) + (COMSNAME . RDCOMS) + (EXTRACOMS + + (* ;; "YOU MUST REMAKE THIS FILE using (DORENAME 'R) (after CONNing to library) whenever the SYSOUT layout changes in LLPARAMS (e.g., if MDSTypeTable moves)") + + (FILES VMEM) + (VARS RDVALS RDPTRS) + (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) + VMEM))) + (RD.SUBFNS (\CALLME . *)) + (RDCOMS) + (PTRS . RDPTRS) + (PREFIX . V) + (VAG2FN . VVAG2) + (VALUES . RDVALS) + (RDPTRS) + (RDVALUES)))) + +(RPAQQ ABCFILES (LOADABC COMPILEBANG SAMEDIR WHEREIS COMPILEFORMSLIST CHECKSET CMACROS DCODEFOR10 + DTDECLARE BYTECOMPILER DLAP LLCODE ACODE MACROAUX)) + +(RPAQQ READSYSFILES (RDSYS READSYS VMEM REMOTEVMEM)) + +(RPAQQ DATABASEFILES (0LISPSET 1LISPSET (2LISPSET ACODE) + (3LISPSET DLAP) + (4LISPSET DFILE DMISC) + 7LISPSET + (8LISPSET MAKEINIT MEM) + 9LISPSET + (10LISPSET LLPARAMS) + (NIL CHECKARRAYSPACE MAKEINEW PMEMSTATS PPAGESTATS LLFCOMPILE))) + +(RPAQQ DEADFNS + ((PUTBASE \PUTBASE) + (GETBASE \GETBASE) + (ADDBASE \ADDBASE) + (GETBASEBYTE \GETBASEBYTE) + (PUTBASEBYTE \PUTBASEBYTE) + (PUTBASEPTR \PUTBASEPTR) + (HILOC \HILOC) + (LOLOC \LOLOC) + (VAG2 \VAG2) + (PAGEBASE NIL) + (PAGELOC NIL) + (WordsPerPage WORDSPERPAGE) + (ALTOMACRO DMACRO) + (\STACKSPACE ??) + (GETBASEPTR \GETBASEPTR) + (FPLUS2) + (FTIMES2) + (CREATECELL \CREATECELL))) +(PUTPROPS FILESETS COPYRIGHT ("Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 +1998 2021)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL))) +STOP From b85084ce31f02bbebf9356691891aa8b24c321fe Mon Sep 17 00:00:00 2001 From: rmkaplan Date: Tue, 5 Oct 2021 19:46:07 -0700 Subject: [PATCH 7/7] LLREAD and LLREAD.LCOM: restore unversioned files --- sources/LLREAD | 1688 +++++++++++++++++++++++++++++++++++++++++++ sources/LLREAD.LCOM | Bin 0 -> 22440 bytes 2 files changed, 1688 insertions(+) create mode 100644 sources/LLREAD create mode 100644 sources/LLREAD.LCOM diff --git a/sources/LLREAD b/sources/LLREAD new file mode 100644 index 00000000..56adef25 --- /dev/null +++ b/sources/LLREAD @@ -0,0 +1,1688 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(FILECREATED "10-Sep-2021 19:41:58"  +{DSK}kaplan>Local>medley3.5>git-medley>sources>LLREAD.;101 90912 + + changes to%: (VARS LLREADCOMS) + + previous date%: "24-Aug-2021 10:04:18" +{DSK}kaplan>Local>medley3.5>git-medley>sources>LLREAD.;100) + + +(* ; " +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 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) + (FNS HEXNUM? OCTALNUM?) + (VARS CHARACTERNAMES CHARACTERSETNAMES)) + (DECLARE%: DOEVAL@COMPILE DONTCOPY (CONSTANTS * READTYPES) + (MACROS .CALL.SUBREAD. FIXDOT RBCONTEXT PROPRB \RDCONC) + (SPECVARS *READ-NEWLINE-SUPPRESS* \RefillBufferFn) + (GLOBALVARS *KEYWORD-PACKAGE* *INTERLISP-PACKAGE*)) + (COMS (INITVARS (*REPLACE-NO-FONT-CODE* T) + (*DEFAULT-NOT-CONVERTED-FAT-CODE* 8739)) + (GLOBALVARS *REPLACE-NO-FONT-CODE* *DEFAULT-NOT-CONVERTED-FAT-CODE*)) + (INITVARS (*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 CL:PARSE-INTEGER CL:READ-DELIMITED-LIST CL:READ-PRESERVING-WHITESPACE + CL:READ]) + + + +(* ; "Reader entrypoints") + +(DEFINEQ + +(LASTC + [LAMBDA (FILE) (* ; "Edited 3-May-2021 16:45 by rmk:") + (LET [(LASTCCODE (FETCH (STREAM LASTCCODE) OF (\GETSTREAM FILE 'INPUT] + (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) (* ; "Edited 3-May-2021 16:47 by rmk:") + (LET ((\RefillBufferFn (FUNCTION \PEEKREFILL))) + (DECLARE (SPECVARS \RefillBufferFn)) + (\PEEKCCODE (\GETSTREAM FILE 'INPUT) + 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-Aug-2021 21:38 by rmk:") + (SETQ FILE (\GETSTREAM FILE 'INPUT)) + (LET ((*READTABLE* (\GTREADTABLE RDTBL)) + (\RefillBufferFn (FUNCTION \READCREFILL)) + (CODE (\INCCODE.EOLC FILE))) + (DECLARE (SPECVARS *READTABLE* \RefillBufferFn)) + (CL:WHEN (\CHARCODEP CODE) (* ; + "If not a charcode, we must have run off the end with an ENDOFSTREAMOP") + (freplace (STREAM LASTCCODE) of FILE with CODE) + (FCHARACTER CODE))]) + +(READCCODE + [LAMBDA (STREAM RDTBL) (* ; "Edited 6-Aug-2021 21:39 by rmk:") + +(* ;;; "returns a 16 bit character code. \INCHAR does the EOL conversion. Saves the character for LASTC as well.") + + (SETQ STREAM (\GETSTREAM STREAM 'INPUT)) + (LET ((*READTABLE* (\GTREADTABLE RDTBL)) + (\RefillBufferFn (FUNCTION \READCREFILL)) + (CODE (\INCCODE.EOLC STREAM))) + (DECLARE (SPECVARS *READTABLE* \RefillBufferFn)) + (CL:WHEN (\CHARCODEP CODE) (* ; + "If not a charcode, we must have run off the end with an ENDOFSTREAMOP") + (freplace (STREAM LASTCCODE) of STREAM with CODE)) + CODE]) + +(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 18-Jun-2021 11:38 by rmk:") + + (* ;; "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.") + + (* ;; "Assumes that CR and LF are both seprs so that no EOL processing is needed.") + + (bind PREVC C (STRM _ (\GETSTREAM FILE 'INPUT)) + (SA _ (fetch (READTABLEP READSA) of (\GTREADTABLE RDTBL))) + (\RefillBufferFn _ '\PEEKREFILL) declare (SPECVARS \RefillBufferFn) + while [EQ SEPRCHAR.RC (\SYNCODE SA (SETQ C (OR (\PEEKCCODE STRM T) + (RETURN] do (SETQ PREVC C) + (\INCCODE STRM) + finally (AND PREVC (replace (STREAM LASTCCODE) of STRM with PREVC)) + (RETURN C]) + +(SKIPSEPRS + [LAMBDA (FILE RDTBL) (* ; "Edited 18-Jun-2021 11:39 by rmk:") + + (* ;; "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.") + + (LET (C) + (AND (SETQ C (SKIPSEPRCODES FILE RDTBL)) + (FCHARACTER C]) + +(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 20-Aug-2021 00:02 by rmk:") + (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 (STRM RDTBL ESCAPE-ALLOWED-P) (* ; "Edited 6-Aug-2021 21:39 by rmk:") + + (* ;; "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)) + (J 0) + (SA (fetch READSA of RDTBL)) + CH SNX ANSLIST ANSTAIL ESCAPE-APPEARED ESCAPING FATSEEN) + LP (if (\EOFP STRM) + then (* ; + "end of file terminates string just like a sepr/break") + (GO FINISH)) + (SETQ CH (\INCCODE STRM)) (* ; "NOTE: This should really be (\INCHAR --) --), 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 (\INCCODE.EOLC STRM)) + (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) + (\BACKCCODE STRM) + (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 (STRM SA RSFLG PNSTR) (* ; "Edited 13-Aug-2021 13:35 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 STRM)) + (PBASE (ffetch (STRINGP XBASE) of PNSTR)) + (J 0) + CH SNX ANSLIST ANSTAIL LASTC FATSEEN SKIPPING) + RS2LP + (SETQ CH (\INCCODE.EOLC STRM)) + [COND + ((EQ CH (CHARCODE EOL)) + + (* ;; "We have eaten a CR, LF, or CRLF depending on the EOL convention of STRM, and recognized it as an EOL. If EOL is a stopatom character, we terminate the read and backup over the just read character(s) so they can be read again.") + + (* ;; "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 EOL] + + (* ;; + "From RSTRING, eol terminates read, but EOL character(s) is/are left to be read again. ") + + (\BACKCCODE.EOLC STRM) + (GO FINISH] + (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 (\INCCODE STRM)) + (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 STRM)) + (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) + (\BACKCCODE STRM) + (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 STRM))) (* ; "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 (freplace (STREAM LASTCCODE) of STRM 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 (STRM SA READTYPE PNSTR CASEBASE EOF-SUPPRESS EOF-VALUE CHAR PRESERVE-WHITESPACE) + (* ; "Edited 6-Aug-2021 21:40 by rmk:") + + (* ;; "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)) + (PBASE (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 STRM))) + 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 STRM))) + then (* ; + "caller specified eof-error-p of NIL. Happens only on top-level calls") + (RETURN EOF-VALUE)) (* ; "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 (\INCCODE STRM] + SEPRCHAR.RC)) + (COND + ((EQ CH CHAR) (* ; + "Read desired terminating char. TOPLEVELP is always false here") + (freplace (STREAM LASTCCODE) of STRM 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 (\PEEKCCODE STRM] + + (* ;; "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 (\PEEKCCODE STRM)))) + 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 (\INCCODE.EOLC STRM)) + (* ; + "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 (\INCCODE.EOLC STRM)) + (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 STRM))) + then (* ; + "EOF terminates atoms at top level") + (GO FINISHATOM) + elseif (EQ [SETQ SNX (\SYNCODE SA (SETQ CH (\INCCODE STRM] + 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 (freplace (STREAM LASTCCODE) of STRM 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] + (freplace (STREAM LASTCCODE) of STRM 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") + (freplace (STREAM LASTCCODE) of STRM + with (OR LASTC CH 65535)) + (* ; + "And LASTC will return the last REAL char read.") + (\BACKCCODE STRM))) + (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") + (freplace (STREAM LASTCCODE) of STRM 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*)) + (freplace (STREAM LASTCCODE) of STRM 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") + + (freplace (STREAM LASTCCODE) of STRM 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 STRM 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 STRM 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 STRM 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 + STRM 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 STRM 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 + STRM 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 24-Aug-2021 10:03 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") + + (* ;; "RMK 2021: Moved single chars above atom test to be more precise about digits.") + + (* ;; "Moved Unicode up, out of comma testing, allowed lower-case u.") + + (* ;; "Also disallowed unknown junk in the parse-integer strings and substrings so we know what's happening") + + (COND + ((NOT C) + NIL) + ((LISTP C) + (CONS (CHARCODE.DECODE (CAR C) + NOERROR) + (CHARCODE.DECODE (CDR C) + NOERROR))) + ((EQ (NCHARS C) + 1) (* ; + "Includes singleton digits 0-9, the only FIXP's allowed. 0 is 0, not 48") + (CHCON1 C)) + ((NOT (OR (LITATOM C) + (STRINGP C))) (* ; + "LITATOM instead of ATOM stops numbers right here. ") + (AND (NOT NOERROR) + (ERROR "BAD CHARACTER SPECIFICATION" C))) + ((HEXNUM? C T)) + (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") + + (* ;; "RMK: I don't understand that comment: %"X,#a%" would map to the high panel corresponding to %"a%" in any character set X, including Meta or Function, wherever they happen to be. Won't adding and orring be the same?") + + (AND (SETQ C (CHARCODE.DECODE (SUBSTRING C 2 -1) + NOERROR)) + (IPLUS C 128))) + (for X in CHARACTERNAMES when (STRING.EQUAL (CAR X) + C) + do (RETURN (OR (NUMBERP (CADR X)) + (CHARCODE.DECODE (CADR X) + NOERROR))) + finally (RETURN + (LET ([POS (find I from 1 + suchthat (FMEMB (OR (NTHCHARCODE C I) + (RETURN)) + (CHARCODE (%, - %. %|] + CH CSET SSTR) (* ; "In the form charset,char") + + (* ;; + "Don't use STRPOSL because CHARTABLE is not available in loadup sequence.") + + (* ;; "The character set loop is like the character loop with a different search list and no recursion for character sets.") + + (COND + ((AND POS (SETQ CH (OR [OCTALNUM? (SETQ SSTR + (SUBSTRING C (ADD1 POS] + (CHARCODE.DECODE SSTR NOERROR))) + (< CH 256) + (>= CH 0) + (SETQ CSET (OR [OCTALNUM? (SETQ SSTR + (SUBSTRING C 1 (SUB1 POS] + (CADR (find PAIR in + CHARACTERSETNAMES + suchthat + + (* ;; + "No recursion. If not a number the list is bad even if C is OK") + + (STRING.EQUAL (CAR PAIR) + SSTR))) + (HEXNUM? SSTR T))) + (< CSET 256) + (>= CSET 0)) (* ; + "parsed the charset part as an octal, standard charset name, or hex") + (LOGOR (LLSH CSET 8) + CH)) + ((NOT NOERROR) + (ERROR "BAD CHARACTER SPECIFICATION" C]) +) +(DEFINEQ + +(HEXNUM? + [LAMBDA (STR PREFIXED?) (* ; "Edited 24-Aug-2021 08:31 by rmk:") + + (* ;; "Returns the number encoded as a hex representation in STR, NIL if it is not an unsigned hex string. The hex digits can be upper or lower case.") + + (* ;; "If PREFIXED?, then hex ending must follow one of 0x, 0X, u+, U+ prefixes") + + (* ;; "CL:PARSE-INTEGER with JUNK-ALLOWED would also return NIL, but it would trim commonlisp seprs...and also depends on CHARTABLE which is not available at the right place in the loadup.") + + (CL:WHEN [OR (NOT PREFIXED?) + (AND (SELCHARQ (CHCON1 STR) + (0 (* ; "Hex? 0X or 0x") + (FMEMB (NTHCHARCODE STR 2) + (CHARCODE (x X)))) + ((U u) (* ; "Unicode U+ or u+") + (EQ (NTHCHARCODE STR 2) + (CHARCODE +))) + NIL) + (SETQ STR (SUBSTRING STR 3 NIL (CONSTANT (CONCAT] + (FOR I C (NUM _ 0) FROM 1 WHILE (SETQ C (NTHCHARCODE STR I)) + DO [SETQ C (IDIFFERENCE C (IF (AND (IGEQ C (CHARCODE 0)) + (ILEQ C (CHARCODE 9))) + THEN (CHARCODE 0) + ELSEIF (IF (AND (IGEQ C (CHARCODE a)) + (ILEQ C (CHARCODE f))) + THEN (IDIFFERENCE (CHARCODE a) + 10) + ELSEIF (AND (IGEQ C (CHARCODE A)) + (ILEQ C (CHARCODE F))) + THEN (IDIFFERENCE (CHARCODE A) + 10)) + ELSE (RETURN NIL] + (SETQ NUM (IPLUS (LLSH NUM 4) + C)) FINALLY (RETURN NUM)))]) + +(OCTALNUM? + [LAMBDA (STR) (* ; "Edited 24-Aug-2021 08:25 by rmk:") + + (* ;; "Returns the number encoded as an octal representation in STR, NIL if it is not an unsigned octal string.") + + (* ;; "CL:PARSE-INTEGER with JUNK-ALLOWED would also return NIL, but it would trim commonlisp seprs...and also depends on CHARTABLE which is not available at the right place in the loadup.") + + (FOR I C (NUM _ 0) FROM 1 WHILE (SETQ C (NTHCHARCODE STR I)) + DO (IF (AND (IGEQ C (CHARCODE 0)) + (ILEQ C (CHARCODE 7))) + THEN [SETQ NUM (IPLUS (LLSH NUM 3) + (IDIFFERENCE C (CHARCODE 0] + ELSE (RETURN NIL)) FINALLY (RETURN NUM]) +) + +(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 (("Meta" 1) + ("Function" 2) + ("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]) +) + +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(SPECVARS *READ-NEWLINE-SUPPRESS* \RefillBufferFn) +) + +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS *KEYWORD-PACKAGE* *INTERLISP-PACKAGE*) +) +) + +(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*) +) + +(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 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 (3236 11465 (LASTC 3246 . 3552) (PEEKC 3554 . 3942) (PEEKCCODE 3944 . 4237) (RATOM 4239 + . 5320) (READ 5322 . 5882) (READC 5884 . 6525) (READCCODE 6527 . 7286) (READP 7288 . 7840) ( +SETREADMACROFLG 7842 . 8141) (SKIPSEPRCODES 8143 . 9126) (SKIPSEPRS 9128 . 9514) (SKREAD 9516 . 11463) +) (11511 20120 (CL:READ 11521 . 12070) (CL:READ-PRESERVING-WHITESPACE 12072 . 12794) ( +CL:READ-DELIMITED-LIST 12796 . 13711) (CL:PARSE-INTEGER 13713 . 20118)) (20213 32690 (RSTRING 20223 . +20955) (READ-EXTENDED-TOKEN 20957 . 24829) (\RSTRING2 24831 . 32688)) (32726 63866 (\TOP-LEVEL-READ +32736 . 34719) (\SUBREAD 34721 . 60282) (\SUBREADCONCAT 60284 . 60907) (\ORIG-READ.SYMBOL 60909 . +61977) (\ORIG-INVALID.SYMBOL 61979 . 62878) (\APPLYREADMACRO 62880 . 63296) (INREADMACROP 63298 . +63864)) (64025 64200 (READQUOTE 64035 . 64198)) (64225 76129 (READVBAR 64235 . 65566) (READHASHMACRO +65568 . 71378) (DEFMACRO-LAMBDA-LIST-KEYWORD-P 71380 . 71600) (DIGITBASEP 71602 . 72336) ( +READNUMBERINBASE 72338 . 74224) (ESTIMATE-DIMENSIONALITY 74226 . 74551) (SKIP.HASH.COMMENT 74553 . +75521) (CMLREAD.FEATURE.PARSER 75523 . 76127)) (76173 82517 (CHARACTER.READ 76183 . 77437) ( +CHARCODE.DECODE 77439 . 82515)) (82518 85688 (HEXNUM? 82528 . 84871) (OCTALNUM? 84873 . 85686))))) +STOP diff --git a/sources/LLREAD.LCOM b/sources/LLREAD.LCOM new file mode 100644 index 0000000000000000000000000000000000000000..4f248e2751f31f69f7c75bb26087548eb11b2f27 GIT binary patch literal 22440 zcmd^nYj7Lal_mg6md%(9C@ZooEAlmL$s}Vkc#UJvt( zjr%?0fuM`^yN=8sJ6=`GB{o0DT&(*u(R}K2_f9RA7Z&fU6_2aMx%=e#BSrPTW95=s ze!@2#xbJ9nX-M4Nw>W=d;YfM$K3S&44Bz8%dj>Gdm}RN}&E{f<7s|$5-A5|LxufO9 zJ>zU{eyLKOJIbnEQjYb`H{b5l4tAS$OW9~7JmubspOY>NH z|9&Z#X9DzylFkpX;|t|StMexo`I6DY<@FCqCyr`JcaOXM;~pUWUyWpJt}NvX5jGwT zcK6Gy-_2;R2L_leZMWI%p`$kZ>!zRU=;w!lKD#Ymn!9}YgW1-z6=zAkeCdT7=!sJu zyY$M#bQM>-KX}iny5pDLh^y`ooTBkPr>)=bVUf6$lOiBJ5Eh%Bj1}?)YjAN8_n zWv(2l6c?nW`D5YYVwnXz>)Sj5Cf;EImdIqM3V3&*I~$9o+E94dggnVKSXdTU)4B2^ zRaFh2c;u1t!o(clo9wdL92`6okbPSn2@cK!8$p)TAWL3)BWXaEB*=UL6J%aLA= zvI)R#y$`f|WB0za$zgLyFG!_o>)B?3)8=7Esl+dSWOL58-sEKW%Mqi~tC#cVdMW`$P`{x}?0`&)D-XzkmHbBZ;Wg6- zDB?DU-PWa3M2_!SxX)n^@on2o8%FdEs0&JVNRI7~$$&_T^8MIov1Vz~NzD*T>!{gn zUJvLOXfjYRi1i)qvfCUcnmcUM7n|pc6{3jKS6`PSx!HbtY&Lmm#TQDx8%X{!(x?JB zN6hlbH_E0H8P3wfF-4B76TM>_$fVH?WRj2I2F_p#kT7E25fkDp;+Xg95K%f3h4dcS zfaN<;HvY$%GUz?j{_)cl5Zycg1sFkU1HkXzS|w~3*CnJu>raSdMBc>{T9ULW27&mX(^IZXbn0? zLD$KXq_(jVn;j&ONyy#wAG$H0N@Vk~Y>xILZ@jUd`_{|o2{zI}#gATRrDC0i_j5P} zur?uceVY^UDpxF}M&#Ui8Ky$x<7v_5$=784iuYLEGW&E|en)+{^@@Bp&Y7TDe<$^_ z5XY%^12VSL;|78>LS{h^gNThw`8e}qn@tMWg2f(4W{++#jQY8j7N+iq`NjthXlq&K z9WxU)lp^7rzm_$2qo;qMN5||Hv5F13hjebA(-smtf3VaT+K8L4Y&Cg(Cfj0+>2vbk z9O&r}KxKCt52Ro^+R&5MOMn<80FlkrG)N&v4}_pMX>AOX3lo`fWo;nAB#uoYdOfjx z6~xlTi6Q(#m}_c5CT33YZI)KICi#v}uj~>RPJYXOlAJsqsQ+AJB- z)(dLWA*NeOZqtU4YB6_~`Z&LA#K)>&Yk zb#@KQ$m7FqUd?p!z`rxBv(ZlLY|LyLv7qG+hNIZPz|}28^G*(tg%r!}hiy4@Af711 z^03Kb29N*I`}_6(NB6fyeC$omkv~bcd9-;h)j0An@z`pDcA8 zxVr);%N4=N=?+eAKyb_4J0nJhhF-VJJ}{@w$UzGu!(cVJS&TTy;BqcfVcuMoYyFt+ zsvV#%bhbw5tHbH?z$G(;XO?wvxz5)kSLbWy59;ojDO93!dlpe5isKbxlZcqZ)%R~du56px1+U<>W=+|3=`CefNxk#ZOHE}L9}eIu z{qpOxU!IlMUX*#$lk&wGH(Hh6)$5eK^^Ylg*WQ>_de>f3dc_Kq-itHdrs`I_JmWt-Z)cDh@YsOA4$oEdH^-jd=5&YOx$8GK2(Q*podL)$a-_njHmoY~z}7+J!% zE4wvQxUo%P#tnyV^@iDJl-&v=d-!F=U86)!-f4F@`F1SZZxLhr zmAltgvRImb?b}LlJAdgNM;$D2y9@o8n}N?dU(-qwnQ zo*X<^8$7?F-?YJVDSiU)^~#sU{CKx#*sszohK^ zY6bK5|CI2d1mEN+d4~VW-&A@VHznlNF6`jyCS@--5S|p|OFnYY4Z~U<7jd&u_`tY< zXvxR+A%Fw#H=WX1Z3KGRa5ns7#6M#V?&v#bQt{XMZ`sKS0*Ol=rONXNH_|_Pb3aznb*^PSBuWO znE(L7kk-#*Oj$^bQ7mPMjc9=Y&E*MrO%6~13;6^KAow`M{C@KjKkQKo)QY#fFh5O_ z%|n<<%bMpf>SN={sZ45!WbXl_2Ry*fxPa7yXv=skgElwXpp9}At7W5b!(4?*d7;dz zi){A9T#Z8Zh}|#Z?^5|_d4Vl1Eg+IV&OV<<)P8g%sP``}l;`eRV#T>9SgDHa0ljhM zH@lf1V%U|LM`~bh=&?$5sl0f+c%)3h_l4q-C1fV({q>U~L%^3vD_W$y0xN1uVzegY z3bdG*A%x*c<;hRl$f*_~EpsUA4+$Sx!k;j^4{S1pw?x2`vq+z-iwn$EZ(A#G6xs~0 zc2!ecwRT1?e}Zrkw5kS@myxq#Xif%&Yf`J&zu-0WD0cU%Y7|swq9#zEuz1NAyQ=o3 zC2kat+&I)Y6gvoaEeeaNprm3M(?-Se5eZzU(d!U-wx-Bbn*1OPX>x=HnEiNmw+ccc9wCjhmI;k~-09>}!e_zh9l%wsKh6zVeXLtFm9twpNnj zK~t`jlpUNZX5+%}I;S|HqUF6!MR?)olx+=Fu0p=nA5kY;jkC)3N(%-8hHNfh&L>~a zU{&8tX5RTe0z9q8T^o-0JdOB_T-iC}gw-*7E+xO0dDjLb<86BTx$4Z0rd)gf-16lv zd23v=2@$?SpR zb6_+uY6y3dUPiPDezq=~x!gs7#WXOu!bisHRp}RO)t0Fq2z%2V2#!bkJnj)aRt3dj zViUNDR~;R(2+cGFdv#c*5bdUsfRd|@1hvub4ZsGv+mb;yIejdf!IrSL)XPhV8lg$B zj~>Qv%RKN@N4(xK{1Jz3Q|L!G_C-2uyxG1lbPMu)u%!018lh&m+G>ocJw*PuX}t1e z<0iF7zZO=-^|N1))Sh=Zfxj&VShjyX#hFI$`C3Z967L}FD5c(+F3q-1F55SOXHG5K zzH(rP#>B8ZPcGa3Nn4ECO?Uqo7naG&zElY)jw^WuBB#r zmu(k;hMQ!;zy~z|ZRfPN8X>uat}ixu*KfnLIvr59Hg?fir6e8w;|0T$z%inF6dg z4A&M9UNF^kBp!>TC}}br$;qJNQAiLy1WoZn-7JK`(0)~9S)d5@rzDuH85pZP0iXHD zkQAe6zdvXsxP1^o6ewg~jKwcJK|iH>c@igJkr0%CG)WX#T8RjE@gaWey}VQ3SV?LM&1kWC;>5^dKU~q|8)yXhO-Qkr>3D@D=H@1`S?a zhIS<3@JPh`ae+{0B$2~dJPF9dDm2ze8#>&LGA*_iGey<__0#q(Hv7J>izFk5e%oME zSOZ5))_~oX;}1DzM3V1JKq6~Wf27erPhZX}&g0o9&S zMi~$aIZs6jQ#oWzNnJ8fwGkyDAH`(OAv9@CMqfMEd=1S8dewAK(A}wfQ0>sxCJgR} z=?+nF&GfrgJQWtFm5NL>I;w5Z$!|q;dwi9Lvt2~NCR{PG|1BneW#^Ex{TW6(uD%!h5i!#-IUAE(P|5k_h@6 zq@}3dAv`rPtV~1)*p}R`O|~1t&xdQR(_Ph01F7$yoqhjdXZ+>Rf%{tDtj_Fe&O+%{ zW_HYMpV>OI4H2eTW4ka9zBA!O6sq@~2Vf2~MkLV)Z9U_H@+HIQAB@NhqENlYjWCY> z%WVCJO7CPZ%pS*|CSfBra`f6TG`r*P^}+TwXYOn&dug!Sl{(7@reG7#Su~y?_%^ExcE>O9rv31#TMjiWQNxi=H zT(eq_t2dy({ZI5I3^r%_5w{Xc=x;A!P|R>?hW|ZTMiqqk46G@4pRCk_0&ylgROz+alw^kz&Px~vfZAYHK3|==d*yovf-9?v zlPs(4%I<{Xmcv#uaDWkQrA2IA5 z&AMCJu`)pfBl_%Ky)!YZIJL#y*uDlS5u*UGdaVQd*yr8#U-0+IuZ_OSk^QYGa0za~ zzTG4C?KZ`!mygXxG}Bnwy%Q`)BX@3~SkErlx?`Po@NhF!Q-*tIcH-eKc-XghAP7S# zI~0(K$a!H2s7AX*(P6_AphDT&vjs-G?Yyv}6&mc{rJXu#6l&gna{0rf%2xaql^ytf zP~S~l-^Hc+@`ty_SN`jP;K}9Rou$2)UjAJ}j0YlFXf@)^KIg3=X*LoSOF6HMY(3o# z^L}-6^~k-c=djgZia*=l%2Ug~Tg-eT<8Zu!|Bg2^C5OX)OUkJ(!4(QgRb!aci+B^0 z#o{NIFQ@tZ_h|EblStXWh3QYU5Jr!q%yhE1aW@a@0;S&nruMc@Z&9}>-XBl)&iIX6 z|BpFCrJR}9F!k4H`frKpn@J4yBDo~AWGCFDMt?}EM7T?HUR%j;&tfGX{wG?=ZL2ogGV4F8iNVWqlwvCm6M@{6@ju8cHlIJ>$k_0UhTaL4$hqq*h^fYwi+i0 zr4bS42#Ep*z7>4DRae`BJbYc#ithAkPo3$JqkpiU=ji`3t@|mRl};`HW^Duf>vKP9 znLAZ_R^G|6CgwK95ZBEeNAXTqS;acjEdNZVU~X}253=ugu2vuVdUO#bKwlWTB) zdL7te)>|zQf9j?*hWTXtYs;K7p+vQ*XcUa895meCV4j;TJ52N~L_;o0gG#SQd zAn#AgX5~X{dkx^g?SftT;x@06UWBzM`@3)-s2jjD42!H znX+<%3YSOSfb**3jUdH+jULymuNi^gi{mUvrg;L_j=NIr&sCQcK-Bf>Jt&W)i2%Q~ zp4#JwU$dc`;PQQ2Wjc7FfRyp6D~eMjouc{YGcB2`NFnCkPS2UPK^V zQ*+0POGhd=a`SnKmFJGkpFnzV0k=rSsb#iME|%!L&eA;6YoC{pRqJ3c-GlS8B>b%` zcf}BXI#|eo-Y3(sOd(GduXosNDEyuc3ybftBedEjQWsKXC)d1Oxx!)fA;)RT7C?Mt z=-!J{Ou*Fs7^*86h!c$2mQMqE5$&{+OHA@$kuH_><&7XBmw^bPN?s}trOZ{FRdoL9zFd!or1kfMEBSkI`LN_DJ<-g)gHRki=JXHm{QwDAFjHE zE3V0M^299wP?0uL+5C70#DYa)YQQlhBV6O-E^@_P>mF^ZsZO|qtdJo=M{UtVJmLtoB-9aQ&Y`{6F#{1bw42Mt z5KHB_fQ7S(ErEk1GV@VtsYb4$g?DZRYM^?7Lz`cOt0B)^1wb(xhP zUs@=#BlGI~T>s(#DWKQK4YZ605booP0XKGt1`!P$;oMhcZ1Z+znq zyu&Zebo6lkC@QVNU3gb4DRXA}^DF|4@cDiS#XE~%fP9MMCq7sW%g-qHGo<~Fx`_O$-0gjmR%C6%=rzq->-<*%?4 zXkio<78)xcYJo+{6A9BeJ!U`={S6D)QC32CqEDcGdd-l2)*;(O2)iu?Eo{!93n(2w z>mjMEMOPR~xcEjs!+-mpy+H%w&>7W@LoT-^ae8p&7St%rs@*@+o~iDiUOc?1S^rrA zC}|9YYM|P);ni&^P8)n6t>~9Gq`0hiYA+LJ8#jq^C#{M0u7v2-*Wi0&DE<-}?%ufH zbn7Jz-{>>gYCP8GzA;o1HT+y)@#$9n1QlRg&xKcS69r^^RWkqOKU&FZyMc==Su9ly zhJ%C@yV$BF zdhn4rnu<|aYvtp_3oAEM&iHRj>W#!3J+#1qR%4rZLkJK7xauOrawr9m;^7Y*7sTk8-hN1~9Gmm2psBtSC!r2BPON39B$Z)I82Sb-8vo^wkTi=KZjP;H1v-A~c&ZrNN zQNPYQA1}-RY8Rr+3!jZnstxT&4iPS?7sk6jkO0Ly0t{JzqdGiTFO!8h>hJt49ZT;+ z-JRt~FIB){L;0rjvs-YvDC-Hi>cM8mkR63S(pyk*(O!`U*fy_-%7(4;^V1%d6^$7S z!r<+pfC0m8g!UPM$xVbq9fag351D6;{Wu{tp2#E$2}!1-EU1hseT&;}wa#M3Fy1y1nBG6v+CKJQztGt7R8}0;hUMP z1MYK35Ix%A_}0p(IM38t8P+fM=oh>6i<`8Ix3#}W>*%IZknKGXSMc!#gnjmgl_>EL z+bc~SgwKY*R988q6ymWQEeG4?V|#Hy2G3rc{D6R9dzCDmE0VKCt#(wL7FrP|P+oopw-FhUugs?V*LobxQ#(z>8naHY$8y>fcV2VOgKuLKY=g z6ScnFbq9J8{EgSR#6~{l6RnlIxWc%%S^ZRfS5p0C>v{Q9YW1UBQcH0m$j?ZQr>&E{x3qX@G%fvweX1zZlko`(*DAFb=WzBR9a49 z)`Y}<@7u+N3P08;NRy7fUI8Rhgc}X#~(;j zoE2o4a~yw3dV9PGEQE_C_6Ypm6Xe%Ejt`qGE`r)YEFCJejpVi)yTO6Pbt2=b%?{w6 zW28^o6smG$9BKsgLxpD&lo=?%Oo){5cj6E7WRg$alKQc8|4U-f zinAtmPTcah_-xa>^L6SL`Nv#th`K6nd2o^h(jRXyi^_g5N5`gL?VzZ_P++KkSv=j z&aTF`kX^7{$RYmjbcRH*re^Y%d?DE4TKme!ni4XX!j#tNRNJD}Ukikio7(`FsE%Wo zxd0bKmm2RMd+nD_;_h44KRc&B`M&tD4E8+UMLB5OmuqLVY+C8$vh7r#=XxZPY(EdB zYwz<-n-NjL)ow*s0(ks`IlC>hhKs+O&8*?IhyAea zrsWUof5`(gAUE*U9E zvbaN78xb7Q8$wOym^+jX-0#fdmO>x-)KRW zK`f59@+OjQ6mEBgVe=a=APo|WBqkC#Dh_iDHYnnPSL-m)t;5k~KNNx?u@Q^jFXDNm z++W2v9UM|a*7?OvE--k4Q#IH4yXq(_o+2tb(R$T*1bYeebh;Q)y9AB!eD`77X{9!c z4;_VsSbJb~Q^LukFgr^Wh1rIH#F@m;@h|!Q_u{pSe^-BBEhaC$l~fP2;m3E)ocSH1=-#=SheP7Fkj8Lgl^hY-O!-$DlGFLgBo+=OE$2~+eD^g ziCd9`8T#&q-2%+(8Z0*_)zM3TOJLBKnlwQE2bl@r0n-8u)!z@q7Yc{S6GmRLVE!6c zcYiJ`?b~N+V*UN}oi5ft$nIgT91&z~#Pv~rz_UH&2TLQ}f8^TbQaxr|OtvgDN zHC+D?xxy@}M3n3y)}LklX=OjyxnG1@*G-E-v?sKeT5^fNwY;`rPNw~;HCHo0|I9SO zNt6lC8O{g0OUD*XDZI6cz`6&28B_Ea#DQpub)RB@~nF}0)ucE@{^MTf<*_Tu(Wew zyjOr(h-y|Pn+t<8qG*ZWMN&F^g~FX)|Lv@f>SMgpZQ|B-xvq`U*==&7FcP1wAJb)J zd}?ASqo5ccu_My%gRDT~4}vnJDY<}W)Sf|dmA+npB&gO4wIYbRSj5H^#=GWNG>m0c z8+||weLB#9?bf4HIN}7d*1l@RS%>6$x2rIJoT=qU%PK=|kHk&q5XZ{JxkZMfq)e^W z%0ikC4Lw$7$4)FRvBPCnf;u>g^!7sWF~r(3tRKur>HydG4-j2;@wQD>$g zt3275o-_i>i9L~`QE`z$7)!$V^j98W__ibNDa>Y(+j`t>s6)W(a$l=T@A$Nc_LNJR zZmXF3L#5k>uXPA9LoRl-!}b#T*x*3Hkp2CxZ1E`KdLAzTcTFJ3Vq8z?SGg01=T9ur z-6(a6mQ~|Ab3(<9n>NK2;|W+8BD@#w^viIWI`P&*@h~#KG)lO5q{dGcyI7FlFKQQ= z@?$Cjmzcsw?U9^*g%dpZdZ%d3mEjxD=}!vfx$@)Xc}(KN7f}0M`QtdTj2jM9{>GS$qu78vF`d025NY?e;v!Vx!%h3-TnB!5y@8lL#*)JvxiXg5ibA(`^$4D%4{z? zSYDWaoWc4yJ};tnz~&fA4Ddr`B=Ah|