From 8e07e25b9a1b24440ee898f95bb61513c7a48ef1 Mon Sep 17 00:00:00 2001 From: Larry Masinter Date: Sat, 16 Mar 2024 19:57:20 -0700 Subject: [PATCH] import an LOOP macro (#1579) * import an LOOP macro * add to loadup * change CML-LOOP to XCL-LOOP finish * Change package to LOOP, no nickname; 'loop' and 'loop-finish' are in LISP package Install copyright/acknowledgement --- internal/loadups/LOADUP-LISP | 17 +- internal/loadups/LOADUP-LISP.LCOM | Bin 3508 -> 3562 bytes sources/CMLSPECIALFORMS | 54 +- sources/CMLSPECIALFORMS.LCOM | Bin 9799 -> 9473 bytes sources/PACKAGE-STARTUP | 154 ++- sources/PACKAGE-STARTUP.LCOM | Bin 27650 -> 27447 bytes sources/XCL-LOOP | 1465 +++++++++++++++++++++++++++++ sources/XCL-LOOP.DFASL | Bin 0 -> 40392 bytes 8 files changed, 1577 insertions(+), 113 deletions(-) create mode 100644 sources/XCL-LOOP create mode 100644 sources/XCL-LOOP.DFASL diff --git a/internal/loadups/LOADUP-LISP b/internal/loadups/LOADUP-LISP index 140f17a9..006b3fc7 100644 --- a/internal/loadups/LOADUP-LISP +++ b/internal/loadups/LOADUP-LISP @@ -1,11 +1,13 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) -(FILECREATED "31-Jul-2023 18:22:53" |{DSK}frank>il>medley>gmedley>sources>LOADUP-LISP.;2| 5235 +(FILECREATED "14-Mar-2024 12:16:33" |{DSK}larry>il>medley>internal>loadups>LOADUP-LISP.;2| 5426 + + :EDIT-BY "lmm" :CHANGES-TO (FNS LOADUP-LISP) - :PREVIOUS-DATE "27-Feb-2023 17:15:53" -|{DSK}frank>il>medley>gmedley>sources>LOADUP-LISP.;1|) + :PREVIOUS-DATE "31-Jul-2023 18:22:53" +|{DSK}larry>il>medley>internal>loadups>LOADUP-LISP.;1|) (PRETTYCOMPRINT LOADUP-LISPCOMS) @@ -18,7 +20,8 @@ (DEFINEQ (LOADUP-LISP - (LAMBDA (DRIBBLEFILE) (* \; "Edited 26-Feb-2023 12:17 by lmm") + (LAMBDA (DRIBBLEFILE) (* \; "Edited 14-Mar-2024 12:16 by lmm") + (* \; "Edited 26-Feb-2023 12:17 by lmm") (* \; "Edited 13-Jul-2022 14:09 by rmk") (* \; "Edited 4-Mar-2022 19:13 by larry") (* \; "Edited 29-Apr-2021 22:30 by rmk:") @@ -107,6 +110,10 @@ (PACKAGE-ENABLE) + (* |;;| " Added late") + + (LOADUP '(XCL-LOOP)) + (* |;;| " networking code -- should make it optional but too many cross dependencies") (LOADUP '(PUP 10MBDRIVER LEAF LLETHER DPUPFTP LOCALFILE DSKDISPLAY COURIER LLNS TRSERVER SPP @@ -123,5 +130,5 @@ (GLOBALVARS MAKESYSFILENAME MEDLEY-INIT-VARS MEDLEYDIR SYSTEMINITVARS USERRECLST) ) (DECLARE\: DONTCOPY - (FILEMAP (NIL (649 5029 (LOADUP-LISP 659 . 5027))))) + (FILEMAP (NIL (673 5220 (LOADUP-LISP 683 . 5218))))) STOP diff --git a/internal/loadups/LOADUP-LISP.LCOM b/internal/loadups/LOADUP-LISP.LCOM index 46a716e563eadef79e7c50efe17e315594777aa3..b76af649cb541a66fdc64936f1ff4be6f9337c10 100644 GIT binary patch delta 466 zcmdlY{YrX5popP~u5V(Iu91O}iGrb#m7$rHvGK%I`TCs1qM}N>%pAMi)Rdf5AS>Z z^^_Wgn#{Z!1uiAGP#+%!WW{=VdO&q4i6yB(MG#}^VNQaWW1*zUrQzo3KNkc z0#t>?-9SUCU4p%9Z8Gw6Q|(Cgfr6=tk(mOQm8*+qh%Tp7q=HgTZmyETEz_&s$gPZqyP!P&A*tZF$x-* zEBHEky9P%F`#Jgor41)9WX)l;oXp2Ijn~3lK_kN1N7u*SKR|QxBDQEDE(K#_BZ#1D PL`aZhu;yld_N8n9C1Ht; delta 444 zcmaDQy+wLLpop=du2*S}u91O}v4Ww6m65TPp~1vd`TDe?#Jp^~%pAMi)RdgmO1pF@ zU7TN9l$=^@=i~3_5*ncE;~5;FXKhrYsi1^rl7WSlp@ot{O-XWoZb6QEN{vEIW?qc~ zmy%;ZK(GR`Vm&=Qpt_XAl2o7~s4?|$7Xi&NGFH;$(s1+iadi%IbqsNJfvJKkGBUC< zH3k||?Go%=Ymy@AgCm3e9DQ9C tObjNUV9jB)m~6^6ZSpO)NFfDdVlocal>lde>lispcore>sources>CMLSPECIALFORMS.;2| 20313 +(DEFINE-FILE-INFO PACKAGE "LISP" READTABLE "XCL" BASE 10) - IL:|changes| IL:|to:| (IL:VARS IL:CMLSPECIALFORMSCOMS) +(IL:FILECREATED "15-Mar-2024 20:39:04" IL:|{DSK}larry>il>medley>sources>CMLSPECIALFORMS.;4| 19873 - IL:|previous| IL:|date:| "13-Jun-88 18:25:25" -IL:|{DSK}local>lde>lispcore>sources>CMLSPECIALFORMS.;1|) + :EDIT-BY "lmm" + :CHANGES-TO (IL:VARS IL:CMLSPECIALFORMSCOMS) + + :PREVIOUS-DATE "15-Mar-2024 10:39:44" IL:|{DSK}larry>il>medley>sources>CMLSPECIALFORMS.;2| +) -; Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:CMLSPECIALFORMSCOMS) (IL:RPAQQ IL:CMLSPECIALFORMSCOMS - ((IL:COMS (IL:FUNCTIONS LOOP) - (IL:COMS (IL:FUNCTIONS IDENTITY) - (XCL:OPTIMIZERS IDENTITY)) + ((IL:COMS (IL:COMS (IL:FUNCTIONS IDENTITY) + (XCL:OPTIMIZERS IDENTITY)) (IL:FUNCTIONS UNLESS WHEN)) (IL:FUNCTIONS FLET LABELS IL:SELECTQ) (IL:COMS @@ -31,8 +31,7 @@ IL:|{DSK}local>lde>lispcore>sources>CMLSPECIALFORMS.;1|) (IL:COMS - (IL:* IL:|;;| - "Hacks for Interlisp NLAMBDAs that should look like functions") + (IL:* IL:|;;| "Hacks for Interlisp NLAMBDAs that should look like functions") (IL:PROP IL:MACRO IL:FRPTQ IL:SETN IL:SUB1VAR IL:*)) (IL:COMS (IL:FNS IL:BQUOTIFY) @@ -53,13 +52,6 @@ IL:|{DSK}local>lde>lispcore>sources>CMLSPECIALFORMS.;1|) (IL:NLAML) (IL:LAMA))))) -(DEFMACRO LOOP (&REST FORMS) - (LET ((TAG (GENSYM))) - `(PROG NIL - ,TAG - ,@FORMS - (GO ,TAG)))) - (DEFUN IDENTITY (THING) (IL:* IL:|;;| "Returns what was passed to it. Default for :key options.") @@ -67,7 +59,7 @@ IL:|{DSK}local>lde>lispcore>sources>CMLSPECIALFORMS.;1|) THING) (XCL:DEFOPTIMIZER IDENTITY (X) - X) + X) (DEFMACRO UNLESS (TEST &BODY BODY) `(COND @@ -223,10 +215,10 @@ IL:|{DSK}local>lde>lispcore>sources>CMLSPECIALFORMS.;1|) (DEFMACRO DO (VARS END-TEST &BODY BODY &ENVIRONMENT ENV) - (%DO-TRANSLATE VARS END-TEST BODY NIL ENV)) + (%DO-TRANSLATE VARS END-TEST BODY NIL ENV)) (DEFMACRO DO* (BINDS END-TEST &REST BODY &ENVIRONMENT ENV) - (%DO-TRANSLATE BINDS END-TEST BODY T ENV)) + (%DO-TRANSLATE BINDS END-TEST BODY T ENV)) (DEFUN %DO-TRANSLATE (VARS END-TEST BODY SEQUENTIALP ENV) (LET ((VARS-AND-INITIAL-VALUES (MAPCAR #'(LAMBDA (X) @@ -263,7 +255,7 @@ IL:|{DSK}local>lde>lispcore>sources>CMLSPECIALFORMS.;1|) (GO ,TAG))))) (DEFMACRO DOLIST ((VAR LISTFORM &OPTIONAL RESULTFORM) - &BODY BODY &ENVIRONMENT ENV) + &BODY BODY &ENVIRONMENT ENV) (LET ((TAIL (GENSYM))) (MULTIPLE-VALUE-BIND (BODY DECL) @@ -278,7 +270,7 @@ IL:|{DSK}local>lde>lispcore>sources>CMLSPECIALFORMS.;1|) (SETQ ,TAIL (CDR ,TAIL))))))) (DEFMACRO DOTIMES ((VAR COUNTFORM &OPTIONAL RESULTFORM) - &BODY BODY &ENVIRONMENT ENV) + &BODY BODY &ENVIRONMENT ENV) (LET ((MAX (GENSYM))) (MULTIPLE-VALUE-BIND (BODY DECLS) (XCL:PARSE-BODY BODY ENV) @@ -298,7 +290,7 @@ IL:|{DSK}local>lde>lispcore>sources>CMLSPECIALFORMS.;1|) (CLAUSES (MAPCAR #'(LAMBDA - (CASE) + (CASE) (LET ((KEY-LIST (CAR CASE)) (CONSEQUENTS (OR (CDR CASE) (LIST NIL)))) @@ -341,10 +333,10 @@ IL:|{DSK}local>lde>lispcore>sources>CMLSPECIALFORMS.;1|) (IL:PUTPROPS IL:SETN IL:MACRO (= . IL:SETQ)) (IL:PUTPROPS IL:SUB1VAR IL:MACRO ((IL:X) - (IL:SETQ IL:X (IL:SUB1 IL:X)))) + (IL:SETQ IL:X (IL:SUB1 IL:X)))) (IL:PUTPROPS IL:* IL:MACRO ((IL:X . IL:Y) - 'IL:X)) + 'IL:X)) (IL:DEFINEQ (il:bquotify @@ -479,9 +471,11 @@ IL:|{DSK}local>lde>lispcore>sources>CMLSPECIALFORMS.;1|) (IL:ADDTOVAR IL:LAMA ) ) -(IL:PUTPROPS IL:CMLSPECIALFORMS IL:COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 -1988 1990)) (IL:DECLARE\: IL:DONTCOPY - (IL:FILEMAP (NIL (13354 18024 (IL:BQUOTIFY 13367 . 18022)) (19227 19633 (IL:CLEAR-CLISPARRAY 19240 . -19631))))) + (IL:FILEMAP (NIL (2492 2613 (IDENTITY 2492 . 2613)) (2681 2773 (UNLESS 2681 . 2773)) (2775 2845 (WHEN +2775 . 2845)) (2847 4614 (FLET 2847 . 4614)) (4616 6669 (LABELS 4616 . 6669)) (6671 8466 (IL:SELECTQ +6671 . 8466)) (8513 8624 (DO 8513 . 8624)) (8626 8738 (DO* 8626 . 8738)) (8740 10291 (%DO-TRANSLATE +8740 . 10291)) (10293 10883 (DOLIST 10293 . 10883)) (10885 11388 (DOTIMES 10885 . 11388)) (11390 12562 + (CASE 11390 . 12562)) (13026 17696 (IL:BQUOTIFY 13039 . 17694)) (18899 19305 (IL:CLEAR-CLISPARRAY +18912 . 19303))))) IL:STOP diff --git a/sources/CMLSPECIALFORMS.LCOM b/sources/CMLSPECIALFORMS.LCOM index 6c63702b9b7f9f45ad0eed68ee8b9653b1f740db..bcd68bffa122a3c1a595e81d8fa9f74a6dc68302 100644 GIT binary patch delta 1518 zcma)6U2h^)7!F^ho$lgN3Z)e6VW4JcN;|-`&`E7NWe(ff9cCyq)S$g67K}AOH;qOc zX-qdU-ng30i8tzI?^jKXnCuVO7~}dMywKZqz0mBfz6Z)c)fngE$$QSc&+~qrbG}#4 zZ$vp67ZeRA3yO-9idN9k^Cc;NQ@V~3t13o`z3cTIY)b}4DL%n4oT7@yhH|O2m`RJPJd4=8UM$fBY3TZe+)=xO*g{2B(I{zod6`8t zTD|sWqYfUUKQ9zBY~r7V2!E?2vo7*NU+TXTj|&~dq}FrU3=*-dn91!bVwGKb!vt(t0_b^;)73FnJhG~P+xqF^`IDvc? z>7^a4jZmIVpns#}nJ`2FII5#c+gKeIA&@(h?(QScJ*rl_c6*?Ph}%0qOB*;yz`$@J&0Q;pweDM9 zgR*{@dSiy+P%7ISDh$WOMYCGM(DGh8j(nWgDnr&SfnD;uFFb5G?cCaQaB9SL(eiCw z_WNTxfGVE3p;82eA;jA7gqJm3|PLdrsEPMfz;*@9!@y!*pzMdhBQ8FSBrpbM#N1 pzQ$6yELG9EweFwnPvWcK4EGT5sf!1EabdlOG4km`&egk2e*x*%j%WY? delta 1816 zcma)7U1%d!6wdGVcXpG_+9qjgZYEKZ(rGjKX_DEsb~c%$(@tj6%%r>3J{X&68)=i6 zwz8`!ML`f31oyrOf?D)dScoV->61U;tN0}JX~8EI!Dr8%^e2TrIFN7dx%WHgeCOOd zH*YWfC^^G9Auq}TlNTj{5#_w{VZe2-#AlcJf`DjAR7-S(3X2j)2-&j0YeEjuu_Uup zZ7`WMVp)#OaLG80!t_RSw^iTKYpB^kGy$qz69_`R$G6g-aI&6BI-Esq}e#LbkJbZ(5^HW1BJ=|m)8c( zqHxGEi|4JwHc3%Rc-HC}6?1~DiP~BOg(>{H#e*MNiq|Q~KV>MoeY=D3Q%l8|%2(v9 zCMvRuuxPzwrtrJgDg4ChhS5(}aRQu*e739*$9%b@t&o8#XfmSkv`riX3j!#`A`i*H zSmnzqEd6fd@h>)q3udP7u2d9FU<}d}to>=LID6!rkd^qdu+G73#a?j&yM)4}vI5g$ z5yU?ZCGlVO0A39_Ko5OQ1DX>??_FE*16krBEqSPp{-9ND)ELr&4&riY3ZHo9R!w1x z$z)luIGyG}6FlE;5!@CRjkmb%^=^BI$&}aYb(q5O1ma62LC&EJDhRT=R)nJ+i=%>q z*dzj71+byvP6yhAL{NlL8oHDn)SUI-5JI{lp>Pywi=teJM3Bh}3C#-*lPpRU`9a7| zv$bE}t-q-=XTGOZumjxS842$VY(nuz15tN>%@tV^RP~~2e1DL=PK7~nR*`dOiv9TO zLF77b)V)PP?sM@E1+H@09rC%)UGkEk@zH3MJ@q>t`WV!_FdQ8-DmdK%!a5I}=zcR? zG6QRHbk}y;IzRqs)aN~qD)Dy(Nxd?zyFYG^*BALI^#zIi=*Bx|kzWLJ#W4FGNISzZ-- zHFQrrn4h8Z1p)r^{4v|v8Udbw@wX#@P)Ziaz yRc{>V=y`NsZ#N&HY_r{JwyXQ~W`jm-CLJe`Adn<5M<9hLK)9GQ8PY}az5WNy$lGoJ diff --git a/sources/PACKAGE-STARTUP b/sources/PACKAGE-STARTUP index 8f6c1055..24d8e66c 100644 --- a/sources/PACKAGE-STARTUP +++ b/sources/PACKAGE-STARTUP @@ -1,24 +1,24 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10 FORMAT XCCS) -(FILECREATED " 1-Aug-2021 18:08:23"  -|{DSK}kaplan>Local>medley3.5>git-medley>sources>PACKAGE-STARTUP.;9| 36725 +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) - |changes| |to:| (FUNCTIONS PACKAGE-ENABLE) +(FILECREATED "16-Mar-2024 08:28:55" |{DSK}larry>il>medley>sources>PACKAGE-STARTUP.;2| 36546 - |previous| |date:| "29-Jul-2021 20:33:07" -|{DSK}kaplan>Local>medley3.5>git-medley>sources>PACKAGE-STARTUP.;8|) + :EDIT-BY "lmm" + :CHANGES-TO (VARIABLES CMLSYMBOLS.MACROS) + + :PREVIOUS-DATE " 1-Aug-2021 18:08:23" |{DSK}larry>il>medley>sources>PACKAGE-STARTUP.;1| +) -; Copyright (c) 1986-1988, 1990-1991, 2021 by Venue & Xerox Corporation. (PRETTYCOMPRINT PACKAGE-STARTUPCOMS) (RPAQQ PACKAGE-STARTUPCOMS ( -(* |;;;| "Initialize the package system (LLPACKAGE must be loaded)") +(* |;;;| "Initialize the package system (LLPACKAGE must be loaded)") - (* |;;| "Simple definitions for the init. Improved in CMLPACKAGE") + (* |;;| "Simple definitions for the init. Improved in CMLPACKAGE") (FUNCTIONS RETURN-FIRST-OF-THREE ERROR-MISSING-EXTERNAL-SYMBOL) (P (MOVD? 'ERROR-MISSING-EXTERNAL-SYMBOL 'RESOLVE-MISSING-EXTERNAL-SYMBOL) @@ -29,20 +29,20 @@ (MOVD? 'ERROR 'RESOLVE-IMPORT-CONFLICT) (MOVD? 'ERROR 'RESOLVE-UNINTERN-CONFLICT) (MOVD? 'RETURN-FIRST-OF-THREE 'RESOLVE-READER-CONFLICT) - (* \; - "In pre-package init all symbols are prefixed, thus the INTERLISP symbol is always default") + (* \; + "In pre-package init all symbols are prefixed, thus the INTERLISP symbol is always default") ) - (* |;;| "Reader changes") + (* |;;| "Reader changes") (FUNCTIONS CHECK-SYMBOL-NAMESTRING \\NEW.READ.SYMBOL \\NEW.MKATOM) (VARIABLES LITATOM-PACKAGE-CONVERSION-ENABLED) - (* |;;| "Initialization tables and functions") + (* |;;| "Initialization tables and functions") (VARIABLES CMLSYMBOLS.VARS CMLSYMBOLS.FNNAMES CMLSYMBOLS.DECLARATORS CMLSYMBOLS.TYPENAMES CMLSYMBOLS.MACROS CMLSYMBOLS.SPECIALFORMS CMLSYMBOLS.LAMBDA.LIST.KEYWORDS) - (VARIABLES (* \; "Be very careful with this.") + (VARIABLES (* \; "Be very careful with this.") CMLSYMBOLS.SHARED) (FUNCTIONS LITATOM.EXISTS) (VARIABLES LITATOM-PACKAGE-CONVERSION-TABLE) @@ -51,13 +51,13 @@ (FUNCTIONS PACKAGE-INIT PACKAGE-CLEAR PACKAGE-MAKE PACKAGE-HIERARCHY-INIT PACKAGE-ENABLE PACKAGE-DISABLE) - (* |;;| "A hack for initialization") + (* |;;| "A hack for initialization") (FUNCTIONS ID) (PROP (FILETYPE MAKEFILE-ENVIRONMENT) PACKAGE-STARTUP) - (* |;;| "Initialize package system, plus functions needed in llpackage at init time") + (* |;;| "Initialize package system, plus functions needed in llpackage at init time") (DECLARE\: DONTEVAL@LOAD DOCOPY (P (MOVD? 'EQ 'EQL) (MOVD? 'LENGTH 'CL:LENGTH) @@ -98,8 +98,8 @@ (MOVD? 'RETURN-FIRST-OF-THREE 'RESOLVE-READER-CONFLICT) - (* \; - "In pre-package init all symbols are prefixed, thus the INTERLISP symbol is always default") + (* \; + "In pre-package init all symbols are prefixed, thus the INTERLISP symbol is always default") @@ -126,12 +126,12 @@ (CL:DEFUN \\NEW.READ.SYMBOL (BASE OFFSET LEN FATP PACKAGE EXTERNALP NONNUMERICP) "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 (unless it was a keyword). NONNUMERICP is true if we know the symbol is not a number, e.g., some characters in it were escaped." - (DECLARE (CL:SPECIAL LITATOM-PACKAGE-CONVERSION-ENABLED *READTABLE* FILERDTBL CODERDTBL - *PACKAGE* *LISP-PACKAGE* *INTERLISP-PACKAGE*)) + (DECLARE (CL:SPECIAL LITATOM-PACKAGE-CONVERSION-ENABLED *READTABLE* FILERDTBL CODERDTBL *PACKAGE* + *LISP-PACKAGE* *INTERLISP-PACKAGE*)) (OR (AND (NOT NONNUMERICP) (\\PARSE.NUMBER BASE OFFSET LEN FATP)) (AND - (* |;;| "The reader conversion feature is contained in this expression") + (* |;;| "The reader conversion feature is contained in this expression") LITATOM-PACKAGE-CONVERSION-ENABLED (NULL PACKAGE) @@ -142,13 +142,13 @@ (FIND-SYMBOL* BASE OFFSET LEN FATP *LISP-PACKAGE*) (LET ((ILSYM (FIND-SYMBOL* BASE OFFSET LEN FATP *INTERLISP-PACKAGE*))) (COND - ((NULL ILSYM) (* \; "No IL symbol, try CL") + ((NULL ILSYM) (* \; "No IL symbol, try CL") CLSYM) - ((NULL CLSYM) (* \; "No CL symbol, use IL") + ((NULL CLSYM) (* \; "No CL symbol, use IL") ILSYM) - ((EQ ILSYM CLSYM) (* \; "SAME") + ((EQ ILSYM CLSYM) (* \; "SAME") ILSYM) - (T (* \; "Both symbols exist, resolve. During the INIT where packages are turned off this is defined to return its first argument.") + (T (* \; "Both symbols exist, resolve. During the INIT where packages are turned off this is defined to return its first argument.") (RESOLVE-READER-CONFLICT ILSYM CLSYM CLSYMWHERE))))))) (COND ((STRINGP PACKAGE) @@ -164,8 +164,8 @@ (COND ((EQ ACCESSIBLE :EXTERNAL) CL:SYMBOL) - ((CL::%PACKAGE-EXTERNAL-ONLY PACKAGE) (* \; - "External only packages don't error creating external symbols on read") + ((CL::%PACKAGE-EXTERNAL-ONLY PACKAGE) (* \; + "External only packages don't error creating external symbols on read") (INTERN* BASE OFFSET LEN FATP (\\FATCHARSEENP BASE OFFSET LEN FATP) (OR PACKAGE *PACKAGE*) T)) @@ -182,20 +182,20 @@ (UNLESSRDSYS (COND ((AND (EQ LEN 1) (ILEQ FIRSTCHAR \\MAXTHINCHAR) - |\\OneCharAtomBase|) (* \; - "The one-character atoms live in well known places, no need to hash") + |\\OneCharAtomBase|) (* \; + "The one-character atoms live in well known places, no need to hash") (RETURN (COND ((IGREATERP FIRSTCHAR (CHARCODE "9")) (\\ADDBASE |\\OneCharAtomBase| (IDIFFERENCE FIRSTCHAR 10))) ((IGEQ FIRSTCHAR (CHARCODE "0")) - (* \; - "These one-character atoms are integers") + (* \; + "These one-character atoms are integers") (IDIFFERENCE FIRSTCHAR (CHARCODE "0"))) (T (\\ADDBASE |\\OneCharAtomBase| FIRSTCHAR))))) ((AND (ILEQ FIRSTCHAR (CHARCODE "9")) (SETQ TEMP (\\PARSE.NUMBER BASE OFFST LEN FATP))) - (* |;;| "\\PARSE.NUMBER returns a number or NIL") + (* |;;| "\\PARSE.NUMBER returns a number or NIL") (RETURN TEMP)))) (RETURN (CL:VALUES (INTERN* BASE OFFST LEN FATP FATCHARSEENP *INTERLISP-PACKAGE* T))))) @@ -312,7 +312,7 @@ "WRITE-STRING" "WRITE-TO-STRING" "Y-OR-N-P" "YES-OR-NO-P" "ZEROP")) (CL:DEFPARAMETER CMLSYMBOLS.DECLARATORS '("DECLARATION" "FTYPE" "FUNCTION" "IGNORE" "INLINE" - "NOTINLINE" "OPTIMIZE" "SPECIAL" "TYPE")) + "NOTINLINE" "OPTIMIZE" "SPECIAL" "TYPE")) (CL:DEFPARAMETER CMLSYMBOLS.TYPENAMES '("ARRAY" "ATOM" "BIGNUM" "BIT" "BIT-VECTOR" "CHARACTER" "COMMON" "COMPILED-FUNCTION" "COMPLEX" @@ -326,20 +326,19 @@ '("AND" "ASSERT" "CASE" "CCASE" "CHECK-TYPE" "COND" "CTYPECASE" "DECF" "DEFCONSTANT" "DEFINE-MODIFY-MACRO" "DEFINE-SETF-METHOD" "DEFMACRO" "DEFPARAMETER" "DEFSETF" "DEFSTRUCT" "DEFTYPE" "DEFUN" "DEFVAR" "DO" "DO*" "DO-ALL-SYMBOLS" "DO-EXTERNAL-SYMBOLS" "DO-SYMBOLS" - "DOLIST" "DOTIMES" "ECASE" "ETYPECASE" "INCF" "LOCALLY" "LOOP" "MULTIPLE-VALUE-BIND" - "MULTIPLE-VALUE-LIST" "MULTIPLE-VALUE-SETQ" "OR" "POP" "PROG" "PROG*" "PROG1" "PROG2" - "PSETF" "PSETQ" "PUSH" "PUSHNEW" "REMF" "RETURN" "ROTATEF" "SETF" "SHIFTF" "STEP" "TIME" - "TRACE" "TYPECASE" "UNLESS" "UNTRACE" "WHEN" "WITH-INPUT-FROM-STRING" "WITH-OPEN-FILE" - "WITH-OPEN-STREAM" "WITH-OUTPUT-TO-STRING")) + "DOLIST" "DOTIMES" "ECASE" "ETYPECASE" "INCF" "LOCALLY" "LOOP" "LOOP-FINISH" + "MULTIPLE-VALUE-BIND" "MULTIPLE-VALUE-LIST" "MULTIPLE-VALUE-SETQ" "OR" "POP" "PROG" + "PROG*" "PROG1" "PROG2" "PSETF" "PSETQ" "PUSH" "PUSHNEW" "REMF" "RETURN" "ROTATEF" "SETF" + "SHIFTF" "STEP" "TIME" "TRACE" "TYPECASE" "UNLESS" "UNTRACE" "WHEN" + "WITH-INPUT-FROM-STRING" "WITH-OPEN-FILE" "WITH-OPEN-STREAM" "WITH-OUTPUT-TO-STRING")) (CL:DEFPARAMETER CMLSYMBOLS.SPECIALFORMS '("BLOCK" "CATCH" "COMPILER-LET" "DECLARE" "EVAL-WHEN" "FLET" "FUNCTION" "GO" "IF" "LABELS" "LAMBDA" "LET" "LET*" "MACROLET" "MULTIPLE-VALUE-CALL" "MULTIPLE-VALUE-PROG1" "PROGN" "PROGV" "QUOTE" "RETURN-FROM" "SETQ" "TAGBODY" "THE" "THROW" "UNWIND-PROTECT")) -(CL:DEFPARAMETER CMLSYMBOLS.LAMBDA.LIST.KEYWORDS '("&ALLOW-OTHER-KEYS" "&AUX" "&BODY" - "&ENVIRONMENT" "&KEY" "&OPTIONAL" - "&REST" "&WHOLE")) +(CL:DEFPARAMETER CMLSYMBOLS.LAMBDA.LIST.KEYWORDS '("&ALLOW-OTHER-KEYS" "&AUX" "&BODY" "&ENVIRONMENT" + "&KEY" "&OPTIONAL" "&REST" "&WHOLE")) (CL:DEFPARAMETER CMLSYMBOLS.SHARED '("+" "-" "/" "<" "<=" "=" ">" ">=" "&ALLOW-OTHER-KEYS" "&AUX" "&BODY" "&ENVIRONMENT" "&KEY" @@ -361,7 +360,7 @@ "RPLACA" "RPLACD" "SATISFIES" "SEQUENCE" "SET" "STRING" "STRING-EQUAL" "STREAM" "STREAMP" "T" "TAILP" "THE" "TIME" "TRACE" "TYPE" "TYPEP" "UNTRACE" "WRITE") -(* |;;;| "Symbols shared by the Interlisp and Lisp packages.") +(* |;;;| "Symbols shared by the Interlisp and Lisp packages.") ) @@ -388,7 +387,7 @@ (CL:DEFUN NAMESTRING-CONVERSION-CLAUSE (BASE OFFSET LEN FATP) -(* |;;;| "Check whether a given namestring has a prefix that would indicate membership in a package. If so, return the first clause out of the conversion table that matched. Otherwise, return NIL.") +(* |;;;| "Check whether a given namestring has a prefix that would indicate membership in a package. If so, return the first clause out of the conversion table that matched. Otherwise, return NIL.") (DECLARE (CL:SPECIAL LITATOM-PACKAGE-CONVERSION-TABLE)) (CL:DOLIST (CONVERSION-LIST LITATOM-PACKAGE-CONVERSION-TABLE NIL) @@ -399,13 +398,13 @@ (COND ((AND (IGREATERP LEN PREFIX-LENGTH) (\\STRING-EQUALBASE PREFIX BASE OFFSET PREFIX-LENGTH FATP) - (NOT (|for| X |in| EXCEPTIONS - |suchthat| (\\STRING-EQUALBASE X BASE OFFSET LEN FATP)))) + (NOT (|for| X |in| EXCEPTIONS |suchthat| (\\STRING-EQUALBASE X BASE OFFSET LEN + FATP)))) (RETURN CONVERSION-LIST)))))) (CL:DEFUN CONVERT-LITATOM (ATOM) - (* |;;| "Conditionally move an INTERLISP litatom into a package based on the naming conventions in LITATOM-PACKAGE-CONVERSION-TABLE.") + (* |;;| "Conditionally move an INTERLISP litatom into a package based on the naming conventions in LITATOM-PACKAGE-CONVERSION-TABLE.") (LET* ((BASE (|ffetch| (CL:SYMBOL PNAMEBASE) |of| ATOM)) (LEN (|ffetch| (CL:SYMBOL PNAMELENGTH) |of| ATOM)) @@ -417,17 +416,17 @@ (WHERE (CL:FOURTH CLAUSE)) (PREFIX-LENGTH (|ffetch| (STRINGP LENGTH) PREFIX))) - (\\LITATOM.EATCHARS ATOM PREFIX-LENGTH) (* \; "Take off the pseudo-package prefix. This makes the symbol inaccessible in INTERLISP (because not rehashed).") + (\\LITATOM.EATCHARS ATOM PREFIX-LENGTH) (* \; "Take off the pseudo-package prefix. This makes the symbol inaccessible in INTERLISP (because not rehashed).") (COND - (CL:PACKAGE-NAME (* \; - " Symbol is interned, put it in the package.") + (CL:PACKAGE-NAME (* \; + " Symbol is interned, put it in the package.") (INTERN-LITATOM ATOM (CL:FIND-PACKAGE CL:PACKAGE-NAME) :WHERE WHERE))) T)) (CL:DEFUN CONCOCT-SYMBOL (STRING) - (* |;;| "Create a symbol in the LISP package. Conflicting symbols must already have been converted and defined by CONVERT-LITATOM. Given a string, if a symbol by that name exists in INTERLISP (and doesn't conflict) we INTERN-LITATOM it into the LISP package, making that its home. Otherwise, we create a new one.") + (* |;;| "Create a symbol in the LISP package. Conflicting symbols must already have been converted and defined by CONVERT-LITATOM. Given a string, if a symbol by that name exists in INTERLISP (and doesn't conflict) we INTERN-LITATOM it into the LISP package, making that its home. Otherwise, we create a new one.") (DECLARE (CL:SPECIAL *LISP-PACKAGE* *INTERLISP-PACKAGE* CMLSYMBOLS.SHARED)) (LET (ILSYM CLSYM) @@ -437,27 +436,27 @@ (CL:WHEN (EQ WHERE :INTERNAL) (EXPORT SYM *LISP-PACKAGE*)) (SETQ CLSYM SYM) - WHERE) (* \; - "The CL symbol already exists. Make it external. If the symbol is shared, import it into IL.") + WHERE) (* \; + "The CL symbol already exists. Make it external. If the symbol is shared, import it into IL.") (CL:WHEN (CL:MEMBER STRING CMLSYMBOLS.SHARED :TEST 'STREQUAL) (IMPORT CLSYM *INTERLISP-PACKAGE*))) - (* |;;| "From this point down, the CL symbol doesn't yet exist.") + (* |;;| "From this point down, the CL symbol doesn't yet exist.") ((CL:MEMBER STRING CMLSYMBOLS.SHARED :TEST 'STREQUAL) - (* \; "The symbol is shared. Create it in CL and import it to IL. NOTE that the symbol should never be found in IL.") + (* \; "The symbol is shared. Create it in CL and import it to IL. NOTE that the symbol should never be found in IL.") (COND ((CL:FIND-SYMBOL STRING *INTERLISP-PACKAGE*) (CL:ERROR "Shared symbol found in IL: ~S" STRING) - (* |;;| "(intern-litatom ilsym *lisp-package* :where :external)") + (* |;;| "(intern-litatom ilsym *lisp-package* :where :external)") ) (T (LET ((SYM (CL:INTERN STRING *LISP-PACKAGE*))) (EXPORT SYM *LISP-PACKAGE*) (IMPORT SYM *INTERLISP-PACKAGE*))))) - (T (* \; - "Symbol doesn't exist, so just create it in LISP.") + (T (* \; + "Symbol doesn't exist, so just create it in LISP.") (EXPORT (CL:INTERN STRING *LISP-PACKAGE*) *LISP-PACKAGE*))))) @@ -491,8 +490,8 @@ (COND ((|fetch| (LITATOM FATPNAMEP) |of| LITATOM) (ERROR (CONCAT "Can't move fat LITATOM |" LITATOM "| into LISP package"))) - (T (|for| I |from| 0 |to| LEN |as| J |from| N - |do| (\\PUTBASETHIN PNBASE I (\\GETBASETHIN PNBASE J))))) + (T (|for| I |from| 0 |to| LEN |as| J |from| N |do| (\\PUTBASETHIN PNBASE I + (\\GETBASETHIN PNBASE J))))) (|replace| (PNAMEBASE PNAMELENGTH) |of| PNBASE |with| LEN)) LITATOM) @@ -507,7 +506,7 @@ (CL:DEFUN PACKAGE-CLEAR () "Clear the global package data (used by FIND-PACKAGE) and reset the globals that hold the existing packages." (DECLARE (CL:SPECIAL *PACKAGE-FROM-NAME* *PACKAGE-FROM-INDEX* *PACKAGE* *LISP-PACKAGE* - *KEYWORD-PACKAGE* *INTERLISP-PACKAGE*)) + *KEYWORD-PACKAGE* *INTERLISP-PACKAGE*)) (CLRHASH *PACKAGE-FROM-NAME*) (CL:DOTIMES (I (ADD1 *TOTAL-PACKAGES-LIMIT*)) (CL:SETF (CL:AREF *PACKAGE-FROM-INDEX* I) @@ -521,7 +520,7 @@ (CL:DEFUN PACKAGE-MAKE () "Create, but do not fill with symbols, the base packages that need to exist. Also enables the package qualifier characters in the readtables and saves the old definitions of \\READ.SYMBOL and \\MKATOM." (DECLARE (CL:SPECIAL *LISP-PACKAGE* *KEYWORD-PACKAGE* *INTERLISP-PACKAGE* *PACKAGE* - HASHTABLE-SIZE-LIMIT)) + HASHTABLE-SIZE-LIMIT)) (SETQ *INTERLISP-PACKAGE* (CL:MAKE-PACKAGE "INTERLISP" :USE NIL :NICKNAMES '("IL") :PREFIX-NAME "IL" :EXTERNAL-ONLY T :EXTERNAL-SYMBOLS 32749)) (SETQ *LISP-PACKAGE* (CL:MAKE-PACKAGE "LISP" :USE NIL :NICKNAMES '("CL" "COMMON-LISP") @@ -545,20 +544,20 @@ (CL:DEFUN PACKAGE-HIERARCHY-INIT (&OPTIONAL (CONVERT? NIL)) -(* |;;;| "Fill all the initial system packages with their proper symbols, moving litatoms into appropriate places and such. If convert? is non-nil then symbols whose pnames have fake package qualifiers, like cl:length, will be converted IN PLACE to remove the qualifier. If conversion takes place you cannot fully disable the package system.") +(* |;;;| "Fill all the initial system packages with their proper symbols, moving litatoms into appropriate places and such. If convert? is non-nil then symbols whose pnames have fake package qualifiers, like cl:length, will be converted IN PLACE to remove the qualifier. If conversion takes place you cannot fully disable the package system.") (DECLARE (CL:SPECIAL *INTERLISP-PACKAGE* *KEYWORD-PACKAGE* CMLSYMBOLS.LAMBDA.LIST.KEYWORDS - CMLSYMBOLS.SPECIALFORMS CMLSYMBOLS.MACROS CMLSYMBOLS.TYPENAMES - CMLSYMBOLS.FNNAMES CMLSYMBOLS.DECLARATORS CMLSYMBOLS.VARS)) + CMLSYMBOLS.SPECIALFORMS CMLSYMBOLS.MACROS CMLSYMBOLS.TYPENAMES CMLSYMBOLS.FNNAMES + CMLSYMBOLS.DECLARATORS CMLSYMBOLS.VARS)) - (* |;;| "Fill the INTERLISP package with its symbols.") + (* |;;| "Fill the INTERLISP package with its symbols.") (MAPATOMS #'(CL:LAMBDA (ATOM) (CL:IF (OR (NULL CONVERT?) (NULL (CONVERT-LITATOM ATOM))) (INTERN-LITATOM ATOM *INTERLISP-PACKAGE* :WHERE :EXTERNAL)))) - (* |;;| "Fill the LISP package with its symbols.") + (* |;;| "Fill the LISP package with its symbols.") (CL:DOLIST (I (APPEND CMLSYMBOLS.VARS CMLSYMBOLS.FNNAMES CMLSYMBOLS.DECLARATORS CMLSYMBOLS.TYPENAMES CMLSYMBOLS.MACROS CMLSYMBOLS.SPECIALFORMS @@ -569,7 +568,7 @@ (CL:DEFUN PACKAGE-ENABLE (&OPTIONAL (PACKAGE *INTERLISP-PACKAGE*)) "Turn on the package system, making PACKAGE the current one and redefining \\READ.SYMBOL and \\MKATOM appropriatly." (DECLARE (CL:SPECIAL *INTERLISP-PACKAGE* *PACKAGE* *OLD-INTERLISP-READ-ENVIRONMENT* - *PER-EXEC-VARIABLES*)) + *PER-EXEC-VARIABLES*)) (|replace| REPACKAGE |of| *OLD-INTERLISP-READ-ENVIRONMENT* |with| *INTERLISP-PACKAGE*) (|replace| REPACKAGE |of| *DEFINE-FILE-INFO-ENV* |with| *INTERLISP-PACKAGE*) (COND @@ -643,16 +642,15 @@ (PACKAGE-INIT) ) -(PUTPROPS PACKAGE-STARTUP COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991 2021)) (DECLARE\: DONTCOPY - (FILEMAP (NIL (3123 3218 (RETURN-FIRST-OF-THREE 3123 . 3218)) (3220 3358 ( -ERROR-MISSING-EXTERNAL-SYMBOL 3220 . 3358)) (3963 4931 (CHECK-SYMBOL-NAMESTRING 3963 . 4931)) (4933 -8094 (\\NEW.READ.SYMBOL 4933 . 8094)) (8096 9802 (\\NEW.MKATOM 8096 . 9802)) (23600 23682 ( -LITATOM.EXISTS 23600 . 23682)) (24362 25328 (NAMESTRING-CONVERSION-CLAUSE 24362 . 25328)) (25330 26579 - (CONVERT-LITATOM 25330 . 26579)) (26581 28650 (CONCOCT-SYMBOL 26581 . 28650)) (28652 28946 ( -TRANSFER-SYMBOL 28652 . 28946)) (28948 29656 (INTERN-LITATOM 28948 . 29656)) (29658 30285 ( -\\LITATOM.EATCHARS 29658 . 30285)) (30287 30564 (PACKAGE-INIT 30287 . 30564)) (30566 31143 ( -PACKAGE-CLEAR 30566 . 31143)) (31145 32540 (PACKAGE-MAKE 31145 . 32540)) (32542 33863 ( -PACKAGE-HIERARCHY-INIT 32542 . 33863)) (33865 35478 (PACKAGE-ENABLE 33865 . 35478)) (35480 36123 ( -PACKAGE-DISABLE 35480 . 36123)) (36170 36196 (ID 36170 . 36196))))) + (FILEMAP (NIL (3015 3110 (RETURN-FIRST-OF-THREE 3015 . 3110)) (3112 3250 ( +ERROR-MISSING-EXTERNAL-SYMBOL 3112 . 3250)) (3857 4825 (CHECK-SYMBOL-NAMESTRING 3857 . 4825)) (4827 +7985 (\\NEW.READ.SYMBOL 4827 . 7985)) (7987 9697 (\\NEW.MKATOM 7987 . 9697)) (23437 23519 ( +LITATOM.EXISTS 23437 . 23519)) (24199 25205 (NAMESTRING-CONVERSION-CLAUSE 24199 . 25205)) (25207 26462 + (CONVERT-LITATOM 25207 . 26462)) (26464 28537 (CONCOCT-SYMBOL 26464 . 28537)) (28539 28833 ( +TRANSFER-SYMBOL 28539 . 28833)) (28835 29543 (INTERN-LITATOM 28835 . 29543)) (29545 30224 ( +\\LITATOM.EATCHARS 29545 . 30224)) (30226 30503 (PACKAGE-INIT 30226 . 30503)) (30505 31078 ( +PACKAGE-CLEAR 30505 . 31078)) (31080 32471 (PACKAGE-MAKE 31080 . 32471)) (32473 33785 ( +PACKAGE-HIERARCHY-INIT 32473 . 33785)) (33787 35396 (PACKAGE-ENABLE 33787 . 35396)) (35398 36041 ( +PACKAGE-DISABLE 35398 . 36041)) (36088 36114 (ID 36088 . 36114))))) STOP diff --git a/sources/PACKAGE-STARTUP.LCOM b/sources/PACKAGE-STARTUP.LCOM index 5bae00caaebf16b4d3d8c138c38ff387f88652f2..65dd880dc64d11dac92567e4167de6269222d9f9 100644 GIT binary patch delta 1522 zcmah|OK;;;6pqs(P|6GxTG~;096UUdbR2yBwl#FdiJit1J9ce1Z8crcHYSOhOh;`; zXhfheD;6w3S4eCSV#kKpM57TP4S#?oLM#xEEeiy{0IrjC+9X0mitfGVo_oG?zVGv` zpQyV(Qtw@MGO1L$XxV1LH}%jofJPGIZ0$1~%L%|L8mDNYNJE<5*=t{KwxSyBT>~0Y zo!5<^{Kmz`UOQT9ZSC*hTxzzK-v11axK4%?5l@P6NE1X&y*zm(4J*2WAlZR%ID@qL)<(O}~-_PGHHsQ?;!i z1dbP>XjKfR-z>T1*!!7CWWhHB*RGn3V+8@J#CUq4tS_5@gmDzab1>CM^Z+3hPd_mK z5~%7hf*d~_z)K@{f`YG~oyUJp&n*aW48@58Xy$s{y>1iTRs6}-$CE0LfA?memUzgL zNxb96vP32*xQ6K)VczaueT=#=WxK9NY*n#>Qg>tN`E#?kXM6m8YkkuwU%C68wfn=@ zU;csLTAP0~kyfE#`z1Xn5ywb9jHD>Xh-ndxLUA%=2VF8n-*p(mq`BTbv;JCYF$0O8 zlat9rG)*OTOMidRLwtL8Ynq~h-hL(#4p#inc9HzgV{_-liMd1qe_RLr?#@F;hzG~5 z8h}(~u#pjIPt%Pnu2msa5Pdv-X7Asx)*Y`2($bw>%g7C&>x% zg14guO2%(Smnae6i#~jrLqM+=Y#I=&4t9zJbnhFA?M4H!@#!Nm2i?EmRh(@u;(M?D zLe=p{^%s(j8T@N~5&u@7oomJhQ%5LQ6#Qh3eoj6izR$ZTk0c5bZZys>@mg?0z^v)T0)d~nCDB) zomQ)b^v43&Ek@ zjsPzS(ba=`Ke3b`VnWm~5pTNL95xVTU6grf*BWi$Q-w?h22aFdG4z#-`#~AqgC5e& zB}x3hPNEEr@_$4N{!1<%2 zBj-}z-87cW@ezEUoVovqlh+>KNj|9-wwUFwZwu?Mb?&_`b0JBkk0!393EaNDZ23z@ z-pc!)?JR?YIN6SGdCmfel8XN9TE@=%xDg>`JIQE%GrQzw&`Z?gNFuBB^D{GV1CdXs zB%%(z>^UGrq3>UqjVZ&qRCcOgNIBt?<3Jyd&(LQVrUh~YGl+2l32TEjYGi=K68mKGy8{X zdiCj#_T68;fB5srybfl@TQTx0D6=@Bf2?2RWGwOKJCgR2@(9>a;m+UdABRVgH-%Qq zZ;eG@Gq`r-EUkuf!cl4d0=4=?JP?YU0Ya!}lQ*NM=)#7Wr6 zsWBW2KZaBYZg2{11>ank2=E(b2EUd>@4x8^@ZHIz=B;rs)@z*n33iweo^WT{>puh>(-4sr?(uX6POSMLa<)s&=Y+#n6VJ zQPrU>-laj{P}`?Lq1#pKlGdMEQHREqmCp0(UWkf!X49sd+w|<^6(9c|YeC~6fH~L* ocAKAo+1zb4cZ>VAW&;t_HH9rITQppBfh`0zFOolarry>il>medley>sources>XCL-LOOP.;23| 61443 + + :edit-by "lmm" + + :changes-to (il:functions with-temporaries) + + :previous-date "16-Mar-2024 11:13:11" il:|{DSK}larry>il>medley>sources>XCL-LOOP.;22|) + + +(il:prettycomprint il:xcl-loopcoms) + +(il:rpaqq il:xcl-loopcoms + ((file-environments il:loop) + (il:structures simple-program-error) + (il:variables *accumulators* *anonymous-accumulator* *boolean-terminator* *current-clause* + *current-keyword* *environment* *for-as-components* *for-as-subclauses* + *hash-group* *for-as-prepositions* *ignorable* *it-symbol* *it-visible-p* + *list-end-test* *loop-clauses* *loop-components* *loop-name* *loop-tokens* + *message-prefix* *symbol-group* *temporaries*) + (il:functions %keyword %list accumulate-in-list accumulation-clause accumulator-kind + accumulator-spec along-with always-never-thereis-clause ambiguous-loop-result-error + append-context appendf bindings bound-variables by-step-fun car-type cdr-type + check-multiple-bindings cl-external-p clause* clause1 compound-forms* + compound-forms+ conditional-clause constant-bindings constant-function-p + constant-vector constant-vector-p d-var-spec-p d-var-spec1 d-var-type-spec + declarations default-binding default-bindings default-type default-value + destructuring-multiple-value-bind destructuring-multiple-value-setq + dispatch-for-as-subclause do-clause empty-p enumerate extended-loop fill-in + finally-clause for for-as-across-subclause for-as-arithmetic-possible-prepositions + for-as-arithmetic-step-and-test-functions for-as-arithmetic-subclause + for-as-being-subclause for-as-clause for-as-equals-then-subclause for-as-fill-in + for-as-hash-subclause for-as-in-list-subclause for-as-on-list-subclause + for-as-package-subclause for-as-parallel-p form-or-it form1 gensym-ignorable + globally-special-p hash-d-var-spec initially-clause + invalid-accumulator-combination-error keyword1 keyword? let-form loop-error + loop-finish-test-forms loop-warn lp main-clause* mapappend + multiple-value-list-argument-form multiple-value-list-form-p name-clause? one + ordinary-bindings preposition1 preposition? psetq-forms quoted-form-p quoted-object + reduce-redundant-code repeat-clause return-clause selectable-clause simple-loop + simple-var-p simple-var1 stray-of-type-error type-spec? until-clause + using-other-var variable-clause* while-clause with with-accumulators + with-binding-forms with-clause with-iterator-forms with-list-accumulator + with-loop-context with-numeric-accumulator with-temporaries zero) + (il:functions loop) + (il:prop (il:filetype il:makefile-environment il:copyright il:license) + il:xcl-loop))) + +(define-file-environment il:loop :package (defpackage "LOOP" (:use "LISP" "XCL")) + :readtable "XCL") + +(define-condition simple-program-error (simple-condition program-error) + nil) + +(defvar *accumulators* nil) + +(defvar *anonymous-accumulator* nil) + +(defvar *boolean-terminator* nil) + +(defvar *current-clause* nil) + +(defvar *current-keyword* nil) + +(defvar *environment*) + +(defvar *for-as-components*) + +(defvar *for-as-subclauses* + (let ((table (make-hash-table))) + (mapc #'(lambda (spec) + (destructuring-bind (subclause-name . keywords) + spec + (dolist (key keywords) + (setf (gethash key table) + subclause-name)))) + '((for-as-arithmetic-subclause :from :downfrom :upfrom :to :downto :upto :below :above + :by) + (for-as-in-list-subclause :in) + (for-as-on-list-subclause :on) + (for-as-equals-then-subclause :=) + (for-as-across-subclause :across) + (for-as-being-subclause :being))) + table) + "A table mapping for-as prepositions to their processor function-designator.") + +(defvar *hash-group* '(:hash-key :hash-keys :hash-value :hash-values)) + +(defvar *for-as-prepositions* + (let ((prepositions nil)) + (maphash #'(lambda (key value) + (declare (ignore value)) + (push key prepositions)) + *for-as-subclauses*) + prepositions)) + +(defvar *ignorable* nil + "Ignorable temporary variables in *temporaries*.") + +(defvar *it-symbol* nil) + +(defvar *it-visible-p* nil) + +(defvar *list-end-test* 'atom) + +(defvar *loop-clauses* + (let ((table (make-hash-table))) + (mapc #'(lambda (spec) + (destructuring-bind (clause-name . keywords) + spec + (dolist (key keywords) + (setf (gethash key table) + clause-name)))) + '((for-as-clause :for :as) + (with-clause :with) + (do-clause :do :doing) + (return-clause :return) + (initially-clause :initially) + (finally-clause :finally) + (accumulation-clause :collect :collecting :append :appending :nconc :nconcing :count + :counting :sum :summing :maximize :maximizing :minimize :minimizing) + (conditional-clause :if :when :unless) + (repeat-clause :repeat) + (always-never-thereis-clause :always :never :thereis) + (while-clause :while) + (until-clause :until))) + table) + "A table mapping loop keywords to their processor function-designator.") + +(defvar *loop-components* nil) + +(defvar *loop-name* nil) + +(defvar *loop-tokens*) + +(defvar *message-prefix* "") + +(defvar *symbol-group* '(:symbol :symbols :present-symbol :present-symbols :external-symbol + :external-symbols)) + +(defvar *temporaries* nil + "Temporary variables used in with-clauses and for-as-clauses.") + +(defun %keyword (designator) + (intern (string designator) + "KEYWORD")) + +(defun %list (designator) (il:* il:\; "Edited 14-Mar-2024 11:46 by lmm") + (if (listp designator) + designator + (list designator))) + +(defun accumulate-in-list (form accumulator-spec) + (destructuring-bind (name &key var splice &allow-other-keys) + accumulator-spec + (declare (ignore name)) + (let* ((copy-f (ecase *current-keyword* + ((:collect :collecting) 'list) + ((:append :appending) 'copy-list) + ((:nconc :nconcing) 'identity))) + (collecting-p (member *current-keyword* '(:collect :collecting))) + (last-f (if collecting-p + 'cdr + 'last)) + (splicing-form (if collecting-p + `(rplacd ,splice (setq ,splice (list ,form))) + `(setf (cdr ,splice) + (,copy-f ,form) + ,splice + (,last-f ,splice))))) + (if (globally-special-p var) + (lp :do `(if ,splice + ,splicing-form + (setq ,splice (,last-f (setq ,var (,copy-f ,form)))))) + (lp :do splicing-form))))) + +(defun accumulation-clause () + (let* ((form (form-or-it)) + (name (if (preposition? :into) + (simple-var1) + (progn (setq *anonymous-accumulator* *current-keyword*) + (when *boolean-terminator* (ambiguous-loop-result-error)) + nil))) + (accumulator-spec (accumulator-spec name))) + (destructuring-bind (name &rest plist &key var &allow-other-keys) + accumulator-spec + (declare (ignore name)) + (ecase *current-keyword* + ((:collect :collecting :append :appending :nconc :nconcing) (accumulate-in-list + form + accumulator-spec)) + ((:count :counting) (lp :if form :do `(incf ,var))) + ((:sum :summing) (lp :do `(incf ,var ,form))) + ((:maximize :maximizing :minimize :minimizing) + (let ((first-p (getf plist :first-p)) + (fun (if (member *current-keyword* '(:maximize :maximizing)) + '< + '>))) + (lp :do `(let ((value ,form)) + (cond + (,first-p (setq ,first-p nil ,var value)) + ((,fun ,var value) + (setq ,var value))))))))))) + +(defun accumulator-kind (key) + (ecase key + ((:collect :collecting :append :appending :nconc :nconcing) :list) + ((:sum :summing :count :counting) :total) + ((:maximize :maximizing :minimize :minimizing) :limit))) + +(defun accumulator-spec (name) + (let* ((kind (accumulator-kind *current-keyword*)) + (spec (assoc name *accumulators*)) + (plist (cdr spec))) + (if spec + (if (not (eq kind (getf plist :kind))) + (invalid-accumulator-combination-error (reverse (getf plist :keys))) + (progn (pushnew *current-keyword* (getf plist :keys)) + (when (member kind '(:total :limit)) + (multiple-value-bind (type supplied-p) + (type-spec?) + (when supplied-p + (push type (getf plist :types))))))) + (let ((var (or name (gensym "ACCUMULATOR-")))) + (setq plist `(:var ,var :kind ,kind :keys (,*current-keyword*))) + (ecase kind + (:list + (setf (getf plist :splice) + (gensym "SPLICE-")) + (unless name + (fill-in :results `((cdr ,var))))) + ((:total :limit) + (multiple-value-bind (type supplied-p) + (type-spec?) + (when supplied-p + (push type (getf plist :types)))) + (when (eq kind :limit) + (let ((first-p (gensym "FIRST-P-"))) + (setf (getf plist :first-p) + first-p) + (with first-p t := t))) + (unless name + (fill-in :results `(,var))))) + (push (setq spec `(,name ,@plist)) + *accumulators*))) + spec)) + +(defun along-with (var type &key equals (then equals)) + (for-as-fill-in :bindings (apply #'bindings type var (when (quoted-form-p equals) + `(,equals)))) + (unless (quoted-form-p equals) + (for-as-fill-in :after-head `((setq ,@(mapappend #'cdr (bindings type var equals)))))) + (for-as-fill-in :after-tail `((setq ,@(mapappend #'cdr (bindings type var then)))))) + +(defun always-never-thereis-clause () + (setq *boolean-terminator* *current-keyword*) + (when *anonymous-accumulator* (ambiguous-loop-result-error)) + (ecase *current-keyword* + (:always + (lp :unless (form1) + :return nil :end) + (fill-in :results '(t))) + (:never (lp :always `(not ,(form1)))) + (:thereis + (lp :if (form1) + :return :it :end) + (fill-in :results '(nil))))) + +(defun ambiguous-loop-result-error () + (error 'simple-program-error :format-control (append-context + "~S cannot be used without `into' preposition with ~S" + ) + :format-arguments + `(,*anonymous-accumulator* ,*boolean-terminator*))) + +(defun append-context (message) + (concatenate 'string message (let ((clause (ldiff *current-clause* *loop-tokens*))) + (format nil "~%Current LOOP context:~{ ~S~}" clause)))) + +(define-modify-macro appendf (&rest args) append + "Append onto list") + +(defun bindings (d-type-spec d-var-spec &optional (value-form "NEVER USED" value-form-p)) + (cond + ((null value-form-p) + (default-bindings d-type-spec d-var-spec)) + ((quoted-form-p value-form) + (constant-bindings d-type-spec d-var-spec (quoted-object value-form))) + (t (ordinary-bindings d-type-spec d-var-spec value-form)))) + +(defun bound-variables (binding-form) + (let ((operator (first binding-form)) + (second (second binding-form))) + (ecase operator + ((let let* symbol-macrolet) (mapcar #'first second)) + ((multiple-value-bind) second) + ((with-package-iterator with-hash-table-iterator) `(,(first second)))))) + +(defun by-step-fun () + (if (preposition? :by) + (form1) + '#'cdr)) + +(defun car-type (d-type-spec) + (if (consp d-type-spec) + (car d-type-spec) + d-type-spec)) + +(defun cdr-type (d-type-spec) + (if (consp d-type-spec) + (cdr d-type-spec) + d-type-spec)) + +(defun check-multiple-bindings (variables) + (mapl #'(lambda (vars) + (when (member (first vars) + (rest vars)) + (loop-error 'simple-program-error :format-control + "Variable ~S is bound more than once." :format-arguments + (list (first vars))))) + variables)) + +(defun cl-external-p (symbol) + (multiple-value-bind (cl-symbol status) + (find-symbol (symbol-name symbol) + "CL") + (and (eq symbol cl-symbol) + (eq status :external)))) + +(defun clause* () + (loop (let ((key (keyword?))) + (unless key (return)) + (clause1)))) + +(defun clause1 () + (multiple-value-bind (clause-function-designator present-p) + (gethash *current-keyword* *loop-clauses*) + (unless present-p + (loop-error "Unknown loop keyword ~S encountered." (car *current-clause*))) + (let ((*message-prefix* (format nil "LOOP ~A clause: " *current-keyword*))) + (funcall clause-function-designator)))) + +(defun compound-forms* () + (when (and *loop-tokens* (consp (car *loop-tokens*))) + (cons (pop *loop-tokens*) + (compound-forms*)))) + +(defun compound-forms+ () + (or (compound-forms*) + (loop-error "At least one compound form is needed."))) + +(defun conditional-clause () + (let* ((*it-symbol* nil) + (middle (gensym "MIDDLE-")) + (bottom (gensym "BOTTOM-")) + (test-form (if (eq *current-keyword* :unless) + `(not ,(form1)) + (form1))) + (condition-form `(unless ,test-form + (go ,middle)))) + (lp :do condition-form) + (let ((*it-visible-p* t)) + (selectable-clause)) + (loop (unless (preposition? :and) + (return)) + (selectable-clause)) + (cond + ((preposition? :else) + (lp :do `(go ,bottom)) + (fill-in :body `(,middle)) + (let ((*it-visible-p* t)) + (selectable-clause)) + (loop (unless (preposition? :and) + (return)) + (selectable-clause)) + (fill-in :body `(,bottom))) + (t (fill-in :body `(,middle)))) + (preposition? :end) + (when *it-symbol* + (with *it-symbol*) + (setf (second condition-form) + `(setq ,*it-symbol* ,(second condition-form)))))) + +(defun constant-bindings (d-type-spec d-var-spec value) + (let ((bindings nil)) + (labels ((dig (type var value) + (cond + ((null var) + nil) + ((simple-var-p var) + (appendf bindings `((,type ,var ',value)))) + (t (dig (car-type type) + (car var) + (car value)) + (dig (cdr-type type) + (cdr var) + (cdr value)))))) + (dig d-type-spec d-var-spec value) + bindings))) + +(defun constant-function-p (form) + (let ((expansion (macroexpand form *environment*))) + (and (consp expansion) + (eq (first expansion) + 'function) + (symbolp (second expansion)) + (let ((symbol (second expansion))) + (and (cl-external-p symbol) + (fboundp symbol)))))) + +(defun constant-vector (form) + (cond + ((quoted-form-p form) + (quoted-object form)) + ((vectorp form) + form) + (t (error "~S is not a vector form." form)))) + +(defun constant-vector-p (form) + (or (quoted-form-p form) + (vectorp form))) + +(defun d-var-spec-p (spec) + (or (simple-var-p spec) + (null spec) + (and (consp spec) + (d-var-spec-p (car spec)) + (d-var-spec-p (cdr spec))))) + +(defun d-var-spec1 () + (unless (and *loop-tokens* (d-var-spec-p (car *loop-tokens*))) + (loop-error "A destructured-variable-spec is missing.")) + (let ((d-var-spec (pop *loop-tokens*))) + d-var-spec)) + +(defun d-var-type-spec () + (let ((var (d-var-spec1)) + (type (type-spec?))) + (when (empty-p var) + (unless (member type '(nil t)) + (loop-warn "Type spec ~S is ignored." type)) + (setq var (gensym) + type t)) + (values var type))) + +(defun declarations (bindings) + (let ((declarations (mapcan #'(lambda (binding) + (destructuring-bind (type var . rest) + binding + (declare (ignore rest)) + (unless (eq type 't) + `((type ,type ,var))))) + bindings))) + (when declarations + `((declare ,@declarations))))) + +(defun default-binding (type var) + `(,(default-type type) + ,var + ,(default-value type))) + +(defun default-bindings (d-type-spec d-var-spec) + (let ((bindings nil)) + (labels ((dig (type var) + (cond + ((null var) + nil) + ((simple-var-p var) + (appendf bindings `(,(default-binding type var)))) + (t (dig (car-type type) + (car var)) + (dig (cdr-type type) + (cdr var)))))) + (dig d-type-spec d-var-spec) + bindings))) + +(defun default-type (type) + (if (eq type t) + t + (let ((value (default-value type))) + (if (typep value type) + type + (let ((default-type (type-of value))) + (if (subtypep type default-type) + default-type + (if (null value) + `(or null ,type) + `(or ,default-type ,type)))))))) + +(defun default-value (type) + (cond + ((subtypep type 'bignum) + (1+ most-positive-fixnum)) + ((subtypep type 'integer) + 0) + ((subtypep type 'ratio) + 1/10) + ((subtypep type 'float) + 0.0) + ((subtypep type 'number) + 0) + ((subtypep type 'character) + #\Space) + ((subtypep type 'string) + "") + ((subtypep type 'bit-vector) + #*0) + ((subtypep type 'vector) + #()) + ((subtypep type 'package) + *package*) + (t nil))) + +(defun destructuring-multiple-value-bind (d-type-spec d-var-spec value-form) + (let ((mv-bindings nil) + (d-bindings nil) + (padding-temps nil) + temp) + (do ((vars d-var-spec (cdr vars)) + (types d-type-spec (cdr-type types))) + ((endp vars)) + (if (listp (car vars)) + (progn (setq temp (gensym)) + (appendf mv-bindings `((t ,temp))) + (appendf d-bindings `((,(car-type types) + ,(car vars) + ,temp))) + (when (empty-p (car vars)) + (push temp padding-temps))) + (appendf mv-bindings `((,(car-type types) + ,(car vars)))))) + (fill-in :binding-forms + `((multiple-value-bind ,(mapcar #'second mv-bindings) + ,(multiple-value-list-argument-form value-form) + ,@(declarations mv-bindings) + ,@(when padding-temps + `((declare (ignore ,@padding-temps))))))) + (let ((bindings (mapappend #'(lambda (d-binding) + (apply #'bindings d-binding)) + d-bindings))) + (when bindings + (fill-in :binding-forms `(,(let-form bindings))))))) + +(defun destructuring-multiple-value-setq (d-var-spec value-form &key iterator-p) + (let (d-bindings mv-vars temp) + (do ((vars d-var-spec (cdr vars))) + ((endp vars)) + (if (listp (car vars)) + (progn (setq temp (or (pop *temporaries*) + (gensym-ignorable))) + (appendf mv-vars `(,temp)) + (appendf d-bindings `((t ,(car vars) + ,temp)))) + (appendf mv-vars `(,(car vars))))) + (let ((mv-setq-form `(multiple-value-setq ,mv-vars ,value-form)) + (bindings nil)) + (do ((d-bindings d-bindings (cdr d-bindings))) + ((endp d-bindings)) + (destructuring-bind (type var temp) + (car d-bindings) + (declare (ignore type var)) + (push temp *temporaries*) + (appendf bindings (apply #'bindings (car d-bindings))))) + (when iterator-p + (setq mv-setq-form `(unless ,mv-setq-form (loop-finish)))) + (if bindings + `(progn ,mv-setq-form (setq ,@(mapappend #'cdr bindings))) + mv-setq-form)))) + +(defun dispatch-for-as-subclause (var type) + (unless *loop-tokens* (loop-error "A preposition is missing.")) + (let ((preposition (preposition1 *for-as-prepositions*))) + (multiple-value-bind (subclause-function-designator present-p) + (gethash preposition *for-as-subclauses*) + (unless present-p (loop-error "Unknown preposition ~S is supplied." preposition)) + (push preposition *loop-tokens*) + (funcall subclause-function-designator var type)))) + +(defun do-clause () + (fill-in :body (compound-forms+))) + +(defun empty-p (d-var-spec) + (or (null d-var-spec) + (and (consp d-var-spec) + (empty-p (car d-var-spec)) + (empty-p (cdr d-var-spec))))) + +(defun enumerate (items) + (case (length items) + (1 (format nil "~S" (first items))) + (2 (format nil "~S and ~S" (first items) + (second items))) + (t (format nil "~{~S, ~}and ~S" (butlast items) + (first (last items)))))) + +(defmacro extended-loop (&rest tokens &environment environment) + (let + ((*environment* environment)) + (with-loop-context + tokens + (let + ((body-tag (gensym "LOOP-BODY-")) + (epilogue-tag (gensym "LOOP-EPILOGUE-"))) + (name-clause?) + (variable-clause*) + (main-clause*) + (when *loop-tokens* (error "Loop form tail ~S remained unprocessed." *loop-tokens*)) + (reduce-redundant-code) + (destructuring-bind + (&key binding-forms iterator-forms initially head neck body tail finally results) + *loop-components* + (check-multiple-bindings (append *temporaries* (mapappend #'bound-variables binding-forms) + (mapcar #'(lambda (spec) + (getf (cdr spec) + :var)) + *accumulators*))) + `(block ,*loop-name* + ,(with-temporaries + `(,*temporaries* :ignorable ,*ignorable*) + (with-accumulators + *accumulators* + (with-binding-forms + binding-forms + (with-iterator-forms + iterator-forms + `(macrolet ((loop-finish nil '(go ,epilogue-tag))) + (tagbody ,@head ,@initially ,body-tag ,@neck ,@body ,@tail + (go ,body-tag) + ,epilogue-tag + ,@finally + ,@(when results + `((return-from ,*loop-name* ,(car results)))))))))))))))) + +(defun fill-in (&rest args) + (when args + (appendf (getf *loop-components* (first args)) + (second args)) + (apply #'fill-in (cddr args)))) + +(defun finally-clause () + (fill-in :finally (compound-forms+))) + +(defun for (var type &rest rest) + (let ((*loop-tokens* rest)) + (dispatch-for-as-subclause var type))) + +(defun for-as-across-subclause (var type) + (preposition1 :across) + (let* ((form (form1)) + (vector (if (constant-vector-p form) + form + (gensym "VECTOR-"))) + (length (if (constant-vector-p form) + (length (constant-vector form)) + (gensym "LENGTH-"))) + (i (gensym "INDEX-")) + (at-least-one-iteration-p (and (constant-vector-p form) + (plusp length)))) + (unless (constant-vector-p form) + (for-as-fill-in :bindings `((t ,vector ,form)) + :bindings2 + `((fixnum ,length (length ,vector))))) + (for-as-fill-in :bindings `((fixnum ,i 0)) + :head-tests + (unless at-least-one-iteration-p + `((= ,i ,length))) + :tail-psetq + `(,i (1+ ,i)) + :tail-tests + `((= ,i ,length))) + (along-with var type :equals (if at-least-one-iteration-p + `',(aref (constant-vector form) + 0) + `(aref ,vector ,i)) + :then + `(aref ,vector ,i)))) + +(defun for-as-arithmetic-possible-prepositions (used-prepositions) + (append (cond + ((intersection '(:from :downfrom :upfrom) + used-prepositions) + nil) + ((intersection '(:downto :above) + used-prepositions) + '(:from :downfrom)) + ((intersection '(:upto :below) + used-prepositions) + '(:from :upfrom)) + (t '(:from :downfrom :upfrom))) + (cond + ((intersection '(:to :downto :upto :below :above) + used-prepositions) + nil) + ((find :upfrom used-prepositions) + '(:to :upto :below)) + ((find :downfrom used-prepositions) + '(:to :downto :above)) + (t '(:to :downto :upto :below :above))) + (unless (find :by used-prepositions) + '(:by)))) + +(defun for-as-arithmetic-step-and-test-functions (used-prepositions) + (let ((up-p (subsetp used-prepositions '(:below :upto :upfrom :from :to :by)))) + (values (if up-p + '+ + '-) + (cond + ((member :to used-prepositions) + (if up-p + '> + '<)) + ((member :upto used-prepositions) + '>) + ((member :below used-prepositions) + '>=) + ((member :downto used-prepositions) + '<) + ((member :above used-prepositions) + '<=) + (t nil))))) + +(defun for-as-arithmetic-subclause (var type) + (unless (simple-var-p var) + (loop-error "Destructuring on a number is invalid.")) + (multiple-value-bind (subtype-p valid-p) + (subtypep type 'real) + (when (and (not subtype-p) + valid-p) + (setq type 'real))) + (let (from to by preposition used candidates bindings) + (loop (setq candidates (or (for-as-arithmetic-possible-prepositions used) + (return))) + (push (or (setq preposition (preposition? candidates)) + (return)) + used) + (let ((value-form (form1))) + (if (member preposition '(:from :downfrom :upfrom)) + (progn (setq from value-form) + (appendf bindings `((,type ,var ,from)))) + (progn (when (not (constantp value-form *environment*)) + (let ((temp (gensym))) + (appendf bindings `((number ,temp ,value-form))) + (setq value-form temp))) + (ecase preposition + ((:to :downto :upto :below :above) (setq to value-form)) + (:by (setq by value-form))))))) + (unless (intersection used '(:from :downfrom :upfrom)) + (appendf bindings `((,type ,var ,(zero type))))) + (multiple-value-bind (step test) + (for-as-arithmetic-step-and-test-functions used) + (let ((tests (when test + `((,test ,var ,to))))) + (for-as-fill-in :bindings bindings :head-tests tests :tail-psetq + `(,var (,step ,var ,(or by (one type)))) + :tail-tests tests))))) + +(defun for-as-being-subclause (var type) + (preposition1 :being) + (preposition1 '(:each :the)) + (let* ((kind (preposition1 (append *hash-group* *symbol-group*)))) + (cond + ((find kind *hash-group*) + (for-as-hash-subclause var type kind)) + ((find kind *symbol-group*) + (for-as-package-subclause var type kind)) + (t (loop-error "Internal logic error"))))) + +(defun for-as-clause () + (let ((*for-as-components* nil)) + (loop (multiple-value-bind (var type) + (d-var-type-spec) + (dispatch-for-as-subclause var type)) + (unless (preposition? :and) + (return))) + (destructuring-bind (&key bindings bindings2 before-head head-psetq head-tests after-head + before-tail tail-psetq tail-tests after-tail) + *for-as-components* + (fill-in :binding-forms `(,@(when bindings + `(,(let-form bindings))) + ,@(when bindings2 + `(,(let-form bindings2)))) + :head + `(,@before-head ,@(psetq-forms head-psetq) + ,@(loop-finish-test-forms head-tests) + ,@after-head) + :tail + `(,@before-tail ,@(psetq-forms tail-psetq) + ,@(loop-finish-test-forms tail-tests) + ,@after-tail))))) + +(defun for-as-equals-then-subclause (var type) + (preposition1 :=) + (let* ((first (form1)) + (then (if (preposition? :then) + (form1) + first)) + (parallel-p (for-as-parallel-p))) + (for-as-fill-in :bindings (apply #'bindings type var (when (quoted-form-p first) + `(,first)))) + (if (and (not parallel-p) + (consp var) + (multiple-value-list-form-p first)) + (for-as-fill-in :before-head `(,(destructuring-multiple-value-setq var ( + multiple-value-list-argument-form + first)))) + (unless (quoted-form-p first) + (for-as-fill-in :head-psetq (mapappend #'cdr (bindings type var first))))) + (if (and (not parallel-p) + (consp var) + (multiple-value-list-form-p then)) + (for-as-fill-in :before-tail `(,(destructuring-multiple-value-setq var ( + multiple-value-list-argument-form + then)))) + (for-as-fill-in :tail-psetq (mapappend #'cdr (bindings type var then)))))) + +(defun for-as-fill-in (&rest key-list-pairs) + (when key-list-pairs + (destructuring-bind (key list . rest) + key-list-pairs + (appendf (getf *for-as-components* key) + list) + (apply #'for-as-fill-in rest)))) + +(defun for-as-hash-subclause (var type kind) + (let* ((hash-table (progn (preposition1 '(:in :of)) + (form1))) + (other-var (using-other-var kind)) + (for-as-parallel-p (for-as-parallel-p)) + (returned-p (or (pop *temporaries*) + (gensym-ignorable))) + (iterator (gensym)) + narrow-typed-var narrow-type) + (when (and (simple-var-p var) + (not (typep 'nil type))) + (setq narrow-typed-var var narrow-type type) + (setq var (gensym) + type + `(or null ,type)) + (for-as-fill-in :bindings `(,(default-binding narrow-type narrow-typed-var)))) + (flet ((iterator-form nil `(with-hash-table-iterator (,iterator ,hash-table)))) + (if for-as-parallel-p + (progn (unless (constantp hash-table *environment*) + (let ((temp (gensym "HASH-TABLE-"))) + (for-as-fill-in :bindings `((t ,temp ,hash-table))) + (setq hash-table temp))) + (fill-in :iterator-forms `(,(iterator-form)))) + (fill-in :binding-forms `(,(iterator-form))))) + (let* ((d-var-spec (hash-d-var-spec returned-p var other-var kind)) + (d-mv-setq (destructuring-multiple-value-setq d-var-spec `(,iterator) + :iterator-p t)) + (setters `(,d-mv-setq ,@(when narrow-typed-var + `((setq ,narrow-typed-var ,var)))))) + (push returned-p *temporaries*) + (for-as-fill-in :bindings `(,@(bindings type var) + ,@(when other-var (bindings t other-var))) + :after-head setters :after-tail setters)))) + +(defun for-as-in-list-subclause (var type) + (preposition1 :in) + (let ((*list-end-test* 'endp)) + (for `(,var) + `(,type) + :on + (form1) + :by + (by-step-fun)))) + +(defun for-as-on-list-subclause (var type) + (preposition1 :on) + (let* ((form (form1)) + (by-step-fun (by-step-fun)) + (test *list-end-test*) + (list-var (if (simple-var-p var) + var + (gensym "LIST-"))) + (list-type (if (simple-var-p var) + type + t)) + (at-least-one-iteration-p (and (quoted-form-p form) + (not (funcall test (quoted-object form)))))) + (for-as-fill-in :bindings `((,list-type ,list-var ,form) + ,@(unless (constant-function-p by-step-fun) + (let ((temp (gensym "STEPPER-"))) + (prog1 `((t ,temp ,by-step-fun)) + (setq by-step-fun temp))))) + :head-tests + (unless at-least-one-iteration-p + `((,test ,list-var))) + :tail-psetq + `(,list-var (funcall ,by-step-fun ,list-var)) + :tail-tests + `((,test ,list-var))) + (unless (simple-var-p var) + (along-with var type :equals (if at-least-one-iteration-p + form + list-var) + :then list-var)))) + +(defun for-as-package-subclause (var type kind) + (let* ((package (if (preposition? '(:in :of)) + (form1) + '*package*)) + (for-as-parallel-p (for-as-parallel-p)) + (returned-p (or (pop *temporaries*) + (gensym-ignorable))) + (iterator (gensym)) + (kinds (ecase kind + ((:symbol :symbols) '(:internal :external :inherited)) + ((:present-symbol :present-symbols) '(:internal :external)) + ((:external-symbol :external-symbols) '(:external))))) + (unless (typep 'nil type) + (setq type `(or null ,type))) + (flet ((iterator-form nil `(with-package-iterator (,iterator ,package ,@kinds)))) + (if for-as-parallel-p + (progn (unless (constantp package *environment*) + (let ((temp (gensym "PACKAGE-"))) + (for-as-fill-in :bindings `((t ,temp ,package))) + (setq package temp))) + (fill-in :iterator-forms `(,(iterator-form)))) + (fill-in :binding-forms `(,(iterator-form))))) + (let* ((d-var-spec `(,returned-p ,var)) + (d-mv-setq (destructuring-multiple-value-setq d-var-spec `(,iterator) + :iterator-p t))) + (push returned-p *temporaries*) + (for-as-fill-in :bindings (bindings type var) + :after-head + `(,d-mv-setq) + :after-tail + `(,d-mv-setq))))) + +(defun for-as-parallel-p () + (or *for-as-components* (and *loop-tokens* (symbolp (car *loop-tokens*)) + (string= (symbol-name (car *loop-tokens*)) + "AND")))) + +(defun form-or-it () + (if (and *it-visible-p* (preposition? :it)) + (or *it-symbol* (setq *it-symbol* (gensym))) + (form1))) + +(defun form1 () + (unless *loop-tokens* (loop-error "A normal lisp form is missing.")) + (pop *loop-tokens*)) + +(defun gensym-ignorable () + (let ((var (gensym))) + (push var *ignorable*) + var)) + +(defun globally-special-p (symbol) + (assert (symbolp symbol)) + (il:variable-globally-special-p symbol)) + +(defun hash-d-var-spec (returned-p var other-var kind) + (if (find kind '(:hash-key :hash-keys)) + `(,returned-p ,var ,other-var) + `(,returned-p ,other-var ,var))) + +(defun initially-clause () + (fill-in :initially (compound-forms+))) + +(defun invalid-accumulator-combination-error (keys) + (loop-error "Accumulator ~S cannot be mixed with ~S." *current-keyword* (enumerate keys))) + +(defun keyword1 (keyword-list-designator &key prepositionp) + (let ((keywords (%list keyword-list-designator))) + (or (keyword? keywords) + (let ((length (length keywords)) + (kind (if prepositionp + "preposition" + "keyword"))) + (case length + (0 (loop-error "A loop ~A is missing." kind)) + (1 (loop-error "Loop ~A ~S is missing." kind (car keywords))) + (t (loop-error "One of the loop ~As ~S must be supplied." kind keywords))))))) + +(defun keyword? (&optional keyword-list-designator) + (and *loop-tokens* (symbolp (car *loop-tokens*)) + (let ((keyword-list (%list keyword-list-designator)) + (keyword (%keyword (car *loop-tokens*)))) + (and (or (null keyword-list) + (find keyword keyword-list)) + (setq *current-clause* *loop-tokens* *loop-tokens* (rest *loop-tokens*) + *current-keyword* keyword))))) + +(defun let-form (bindings) + `(let ,(mapcar #'cdr bindings) + ,@(declarations bindings))) + +(defun loop-error (datum &rest arguments) + (when (stringp datum) + (setq datum (append-context datum))) + (apply #'error datum arguments)) + +(defun loop-finish-test-forms (tests) + (case (length tests) + (0 nil) + (1 `((when ,@tests (loop-finish)))) + (t `((when (or ,@tests) + (loop-finish)))))) + +(defun loop-warn (datum &rest arguments) + (when (stringp datum) + (setq datum (append-context datum))) + (apply #'warn datum arguments)) + +(defun lp (&rest tokens) + (let ((*loop-tokens* tokens) + *current-keyword* *current-clause*) + (clause*) + (when *loop-tokens* (error "~S remained after lp." *loop-tokens*)))) + +(defun main-clause* () + (loop (if (keyword? '(:do :doing :return :if :when :unless :initially :finally :while :until + :repeat :always :never :thereis :collect :collecting :append :appending + :nconc :nconcing :count :counting :sum :summing :maximize :maximizing + :minimize :minimizing)) + (clause1) + (return)))) + +(defun mapappend (function &rest lists) + (apply #'append (apply #'mapcar function lists))) + +(defun multiple-value-list-argument-form (form) + (let ((expansion form) + (expanded-p nil)) + (loop (when (and (consp expansion) + (eq (first expansion) + 'multiple-value-list)) + (return (second expansion))) + (multiple-value-setq (expansion expanded-p) + (macroexpand-1 expansion *environment*)) + (unless expanded-p (error "~S is not expanded into a multiple-value-list form." form))) + )) + +(defun multiple-value-list-form-p (form) + (let (expanded-p) + (loop (when (and (consp form) + (eq (first form) + 'multiple-value-list)) + (return t)) + (multiple-value-setq (form expanded-p) + (macroexpand-1 form *environment*)) + (unless expanded-p (return nil))))) + +(defun name-clause? () + (when (keyword? :named) + (unless *loop-tokens* (loop-error "A loop name is missing.")) + (let ((name (pop *loop-tokens*))) + (unless (symbolp name) + (loop-error "~S cannot be a loop name which must be a symbol." name)) + (setq *loop-name* name)))) + +(defun one (type) + (cond + ((subtypep type 'short-float) + 1.0) + ((subtypep type 'single-float) + 1.0) + ((subtypep type 'double-float) + 1.0) + ((subtypep type 'long-float) + 1.0) + ((subtypep type 'float) + 1.0) + (t 1))) + +(defun ordinary-bindings (d-type-spec d-var-spec value-form) + (let ((temporaries *temporaries*) + (bindings nil)) + (labels ((dig (type var form temp) + (cond + ((empty-p var) + nil) + ((simple-var-p var) + (when temp (push temp temporaries)) + (appendf bindings `((,type ,var ,form)))) + ((empty-p (car var)) + (dig (cdr-type type) + (cdr var) + `(cdr ,form) + temp)) + ((empty-p (cdr var)) + (when temp (push temp temporaries)) + (dig (car-type type) + (car var) + `(car ,form) + nil)) + (t (unless temp + (setq temp (or (pop temporaries) + (gensym)))) + (dig (car-type type) + (car var) + `(car (setq ,temp ,form)) + nil) + (dig (cdr-type type) + (cdr var) + `(cdr ,temp) + temp))))) + (dig d-type-spec d-var-spec value-form nil) + (setq *temporaries* temporaries) + bindings))) + +(defun preposition1 (&optional keyword-list-designator) + (let ((*current-keyword* *current-keyword*) + (*current-clause* *current-clause*)) + (keyword1 keyword-list-designator :prepositionp t))) + +(defun preposition? (&optional keyword-list-designator) + (let ((*current-keyword* *current-keyword*) + (*current-clause* *current-clause*)) + (keyword? keyword-list-designator))) + +(defun psetq-forms (args) + (assert (evenp (length args))) + (case (length args) + (0 nil) + (2 `((setq ,@args))) + (t `((psetq ,@args))))) + +(defun quoted-form-p (form) + (let ((expansion (macroexpand form *environment*))) + (and (consp expansion) + (eq (first expansion) + 'quote)))) + +(defun quoted-object (form) + (let ((expansion (macroexpand form *environment*))) + (destructuring-bind (quote-special-operator object) + expansion + (assert (eq quote-special-operator 'quote)) + object))) + +(defun reduce-redundant-code () + (when (null (getf *loop-components* :initially)) + (let ((rhead (reverse (getf *loop-components* :head))) + (rtail (reverse (getf *loop-components* :tail))) + (neck nil)) + (loop (when (or (null rhead) + (null rtail) + (not (equal (car rhead) + (car rtail)))) + (return)) + (push (pop rhead) + neck) + (pop rtail)) + (setf (getf *loop-components* :head) + (nreverse rhead) + (getf *loop-components* :neck) + neck + (getf *loop-components* :tail) + (nreverse rtail))))) + +(defun repeat-clause () + (let* ((form (form1)) + (type (typecase (if (quoted-form-p form) + (quoted-object form) + form) + (fixnum 'fixnum) + (t 'real)))) + (lp :for (gensym) + :of-type type :downfrom form :to 1))) + +(defun return-clause () + (lp :do `(return-from ,*loop-name* ,(form-or-it)))) + +(defun selectable-clause () + (let ((*current-keyword* *current-keyword*) + (*current-clause* *current-clause*)) + (unless (keyword? '(:if :when :unless :do :doing :return :collect :collecting :append + :appending :nconc :nconcing :count :counting :sum :summing :maximize + :maximizing :minimize :minimizing)) + (loop-error "A selectable-clause is missing.")) + (ecase *current-keyword* + ((:if :when :unless) (conditional-clause)) + ((:do :doing) (do-clause)) + ((:return) (return-clause)) + ((:collect :collecting :append :appending :nconc :nconcing :count :counting :sum :summing + :maximize :maximizing :minimize :minimizing) (accumulation-clause))))) + +(defmacro simple-loop (&rest compound-forms) + (let ((top (gensym))) + `(block nil + (tagbody ,top ,@compound-forms (go ,top))))) + +(defun simple-var-p (var) + (and (not (null var)) + (symbolp var))) + +(defun simple-var1 () + (unless (and *loop-tokens* (simple-var-p (car *loop-tokens*))) + (loop-error "A simple variable name is missing.")) + (pop *loop-tokens*)) + +(defun stray-of-type-error () + (loop-error "OF-TYPE keyword should be followed by a type spec.")) + +(defun type-spec? () + (let ((type t) + (supplied-p nil)) + (when (or (and (preposition? :of-type) + (or *loop-tokens* (stray-of-type-error))) + (and *loop-tokens* (member (car *loop-tokens*) + '(fixnum float t nil)))) + (setq type (pop *loop-tokens*) + supplied-p t)) + (values type supplied-p))) + +(defun until-clause () + (lp :while `(not ,(form1)))) + +(defun using-other-var (kind) + (let ((using-phrase (when (preposition? :using) + (pop *loop-tokens*))) + (other-key-name (if (find kind '(:hash-key :hash-keys)) + "HASH-VALUE" + "HASH-KEY"))) + (when using-phrase + (destructuring-bind (other-key other-var) + using-phrase + (unless (string= other-key other-key-name) + (loop-error "Keyword ~A is missing." other-key-name)) + other-var)))) + +(defun variable-clause* () + (loop (let ((key (keyword? '(:with :initially :finally :for :as)))) + (if key + (clause1) + (return))))) + +(defun while-clause () + (lp :unless (form1) + :do + '(loop-finish) + :end)) + +(defun with (var &optional (type t) + &key + (= (default-value type))) + (fill-in :binding-forms `(,(let-form `((,type ,var ,=)))))) + +(defun with-accumulators (accumulator-specs form) + (if (null accumulator-specs) + form + (destructuring-bind (spec . rest) + accumulator-specs + (ecase (getf (cdr spec) + :kind) + (:list (with-list-accumulator spec (with-accumulators rest form))) + ((:total :limit) (with-numeric-accumulator spec (with-accumulators rest form))))))) + +(defun with-binding-forms (binding-forms form) + (if (null binding-forms) + form + (destructuring-bind (binding-form0 . rest) + binding-forms + (append binding-form0 (list (with-binding-forms rest form)))))) + +(defun with-clause () + (let ((d-bindings nil)) + (loop (multiple-value-bind (var type) + (d-var-type-spec) + (let ((rest (when (preposition? :=) + `(,(form1))))) + (appendf d-bindings `((,type ,var ,@rest))))) + (unless (preposition? :and) + (return))) + (destructuring-bind (d-binding0 . rest) + d-bindings + (if (and (null rest) + (cddr d-binding0) + (destructuring-bind (type var form) + d-binding0 + (declare (ignore type)) + (and (consp var) + (multiple-value-list-form-p form)))) + (apply #'destructuring-multiple-value-bind d-binding0) + (let ((bindings (mapappend #'(lambda (d-binding) + (apply #'bindings d-binding)) + d-bindings))) + (fill-in :binding-forms `(,(let-form bindings)))))))) + +(defun with-iterator-forms (iterator-forms form) + (if (null iterator-forms) + form + (destructuring-bind ((iterator-macro spec) . rest) + iterator-forms + `(,iterator-macro ,spec ,(with-iterator-forms rest form))))) + +(defun with-list-accumulator (accumulator-spec form) + (destructuring-bind (name &key var splice &allow-other-keys) + accumulator-spec + (let* ((anonymous-p (null name)) + (list-var (if (or anonymous-p (globally-special-p var)) + var + (gensym "LIST-"))) + (value-form (if (and (not anonymous-p) + (globally-special-p var)) + nil + '(list nil))) + (form (if (and (not anonymous-p) + (not (globally-special-p var))) + `(symbol-macrolet ((,var (cdr ,list-var))) + ,form) + form))) + `(let ((,list-var ,value-form)) + (declare (type list ,list-var)) + (let ((,splice ,list-var)) + (declare (type list ,splice)) + ,form))))) + +(defmacro with-loop-context (tokens &body body) + `(let ((*loop-tokens* ,tokens) + (*loop-name* nil) + (*current-keyword* nil) + (*current-clause* nil) + (*loop-components* nil) + (*temporaries* nil) + (*ignorable* nil) + (*accumulators* nil) + (*anonymous-accumulator* nil) + (*boolean-terminator* nil) + (*message-prefix* "LOOP: ")) + ,@body)) + +(defun with-numeric-accumulator (accumulator-spec form) + (destructuring-bind (name &key var types &allow-other-keys) + accumulator-spec + (labels ((type-eq (a b) + (and (subtypep a b) + (subtypep b a)))) + (when (null types) + (setq types '(number))) + (destructuring-bind (type0 . rest) + types + (when (and rest (notevery #'(lambda (type) + (type-eq type0 type)) + types)) + (warn "Different types ~A are declared for ~A accumulator." (enumerate + types) + (or name "the anonymous"))) + (let ((type (if rest + `(or ,type0 ,@rest) + type0))) + `(let ((,var ,(zero type))) + (declare (type ,type ,var)) + ,form)))))) + +(defun with-temporaries (temporary-specs form) (il:* il:\; "Edited 16-Mar-2024 14:22 by lmm") + (destructuring-bind (temporaries &key ((:ignorable ignorable-vars))) + temporary-specs + (if temporaries + `(let ,temporaries ,@(when ignorable + `((declare (ignorable ,@ignorable)))) + ,form) + form))) + +(defun zero (type) + (cond + ((subtypep type 'short-float) + 0.0) + ((subtypep type 'single-float) + 0.0) + ((subtypep type 'double-float) + 0.0) + ((subtypep type 'long-float) + 0.0) + ((subtypep type 'float) + 0.0) + (t 0))) + +(defmacro loop (&rest forms) + (if (every #'consp forms) + `(simple-loop ,@forms) + `(extended-loop ,@forms))) + +(il:putprops il:xcl-loop il:filetype :compile-file) + +(il:putprops il:xcl-loop il:makefile-environment (:readtable "XCL" :package (defpackage "LOOP" + (:use "LISP" "XCL" + )))) + +(il:putprops il:xcl-loop il:copyright (("Interlisp.org" 2004) + ("Yuji Minejima ") + 2002 2004)) + +(il:putprops il:xcl-loop il:license "See COPYRIGHT and LICENSE in the repository +;; $Id: loop.lisp,v 1.38 2005/04/16 07:34:27 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; 'AS IS' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.") +(il:declare\: il:dontcopy + (il:filemap (nil (6736 6821 (%keyword 6736 . 6821)) (6823 7006 (%list 6823 . 7006)) (7008 8265 ( +accumulate-in-list 7008 . 8265)) (8267 9947 (accumulation-clause 8267 . 9947)) (9949 10183 ( +accumulator-kind 9949 . 10183)) (10185 12074 (accumulator-spec 10185 . 12074)) (12076 12545 ( +along-with 12076 . 12545)) (12547 13039 (always-never-thereis-clause 12547 . 13039)) (13041 13400 ( +ambiguous-loop-result-error 13041 . 13400)) (13402 13617 (append-context 13402 . 13617)) (13696 14073 +(bindings 13696 . 14073)) (14075 14415 (bound-variables 14075 . 14415)) (14417 14507 (by-step-fun +14417 . 14507)) (14509 14615 (car-type 14509 . 14615)) (14617 14723 (cdr-type 14617 . 14723)) (14725 +15122 (check-multiple-bindings 14725 . 15122)) (15124 15344 (cl-external-p 15124 . 15344)) (15346 +15475 (clause* 15346 . 15475)) (15477 15877 (clause1 15477 . 15877)) (15879 16036 (compound-forms* +15879 . 16036)) (16038 16162 (compound-forms+ 16038 . 16162)) (16164 17422 (conditional-clause 16164 + . 17422)) (17424 18135 (constant-bindings 17424 . 18135)) (18137 18508 (constant-function-p 18137 . +18508)) (18510 18704 (constant-vector 18510 . 18704)) (18706 18797 (constant-vector-p 18706 . 18797)) +(18799 18991 (d-var-spec-p 18799 . 18991)) (18993 19223 (d-var-spec1 18993 . 19223)) (19225 19550 ( +d-var-type-spec 19225 . 19550)) (19552 20112 (declarations 19552 . 20112)) (20114 20224 ( +default-binding 20114 . 20224)) (20226 20839 (default-bindings 20226 . 20839)) (20841 21302 ( +default-type 20841 . 21302)) (21304 21825 (default-value 21304 . 21825)) (21827 23317 ( +destructuring-multiple-value-bind 21827 . 23317)) (23319 24604 (destructuring-multiple-value-setq +23319 . 24604)) (24606 25133 (dispatch-for-as-subclause 24606 . 25133)) (25135 25204 (do-clause 25135 + . 25204)) (25206 25382 (empty-p 25206 . 25382)) (25384 25658 (enumerate 25384 . 25658)) (25660 27386 +(extended-loop 25660 . 27386)) (27388 27559 (fill-in 27388 . 27559)) (27561 27638 (finally-clause +27561 . 27638)) (27640 27758 (for 27640 . 27758)) (27760 29116 (for-as-across-subclause 27760 . 29116) +) (29118 30040 (for-as-arithmetic-possible-prepositions 29118 . 30040)) (30042 30758 ( +for-as-arithmetic-step-and-test-functions 30042 . 30758)) (30760 32705 (for-as-arithmetic-subclause +30760 . 32705)) (32707 33157 (for-as-being-subclause 32707 . 33157)) (33159 34375 (for-as-clause 33159 + . 34375)) (34377 35905 (for-as-equals-then-subclause 34377 . 35905)) (35907 36185 (for-as-fill-in +35907 . 36185)) (36187 38153 (for-as-hash-subclause 36187 . 38153)) (38155 38401 ( +for-as-in-list-subclause 38155 . 38401)) (38403 39896 (for-as-on-list-subclause 38403 . 39896)) (39898 + 41600 (for-as-package-subclause 39898 . 41600)) (41602 41833 (for-as-parallel-p 41602 . 41833)) ( +41835 41983 (form-or-it 41835 . 41983)) (41985 42104 (form1 41985 . 42104)) (42106 42206 ( +gensym-ignorable 42106 . 42206)) (42208 42319 (globally-special-p 42208 . 42319)) (42321 42500 ( +hash-d-var-spec 42321 . 42500)) (42502 42583 (initially-clause 42502 . 42583)) (42585 42742 ( +invalid-accumulator-combination-error 42585 . 42742)) (42744 43361 (keyword1 42744 . 43361)) (43363 +43833 (keyword? 43363 . 43833)) (43835 43944 (let-form 43835 . 43944)) (43946 44100 (loop-error 43946 + . 44100)) (44102 44293 (loop-finish-test-forms 44102 . 44293)) (44295 44447 (loop-warn 44295 . 44447) +) (44449 44653 (lp 44449 . 44653)) (44655 45092 (main-clause* 44655 . 45092)) (45094 45190 (mapappend +45094 . 45190)) (45192 45722 (multiple-value-list-argument-form 45192 . 45722)) (45724 46117 ( +multiple-value-list-form-p 45724 . 46117)) (46119 46457 (name-clause? 46119 . 46457)) (46459 46738 ( +one 46459 . 46738)) (46740 48385 (ordinary-bindings 46740 . 48385)) (48387 48604 (preposition1 48387 + . 48604)) (48606 48807 (preposition? 48606 . 48807)) (48809 48969 (psetq-forms 48809 . 48969)) (48971 + 49151 (quoted-form-p 48971 . 49151)) (49153 49408 (quoted-object 49153 . 49408)) (49410 50214 ( +reduce-redundant-code 49410 . 50214)) (50216 50570 (repeat-clause 50216 . 50570)) (50572 50662 ( +return-clause 50572 . 50662)) (50664 51499 (selectable-clause 50664 . 51499)) (51501 51652 ( +simple-loop 51501 . 51652)) (51654 51732 (simple-var-p 51654 . 51732)) (51734 51918 (simple-var1 51734 + . 51918)) (51920 52027 (stray-of-type-error 51920 . 52027)) (52029 52463 (type-spec? 52029 . 52463)) +(52465 52531 (until-clause 52465 . 52531)) (52533 53114 (using-other-var 52533 . 53114)) (53116 53310 +(variable-clause* 53116 . 53310)) (53312 53416 (while-clause 53312 . 53416)) (53418 53597 (with 53418 + . 53597)) (53599 54044 (with-accumulators 53599 . 54044)) (54046 54296 (with-binding-forms 54046 . +54296)) (54298 55529 (with-clause 54298 . 55529)) (55531 55790 (with-iterator-forms 55531 . 55790)) ( +55792 56875 (with-list-accumulator 55792 . 56875)) (56877 57314 (with-loop-context 56877 . 57314)) ( +57316 58554 (with-numeric-accumulator 57316 . 58554)) (58556 58973 (with-temporaries 58556 . 58973)) ( +58975 59255 (zero 58975 . 59255)) (59257 59390 (loop 59257 . 59390))))) +il:stop diff --git a/sources/XCL-LOOP.DFASL b/sources/XCL-LOOP.DFASL new file mode 100644 index 0000000000000000000000000000000000000000..b2bb4c40c6fa2922f23c05bac340665b2660a055 GIT binary patch literal 40392 zcmc(|3wT`Bl_q-5sgmS}B+Ig~jciO|`~X>HY-7L}LsXK=u98Z1WR+xDU}I!ib`_Q- zBgueyMPObb3LqPd4ww)i&q=x?M7qZ|wskX^{wDNvx)YMzPT&5zzjV4Y1EfhjlkYZ@ zOcUbEZx3RQV{g9DC&1q0$Y> zRJ^u19&3r$rQBM_8hL7{tTNLQOV`Dk>!QhYQ)^4*$WYm;$UyJDXm{70UER|Cy$*^P zd3tEdhSqd#OVUk`9JU9YOHg20U3^0_9gj-6$iBfXLy2LxDV}zwBSWFv+JYhr5u93= zY>qRtGjHUuK#H1TwGFY2@sY!!kwZh%P?8TA9vPasCEo0AiPpM}jcz)cN@kiyhQfkU zN&WOts5KK80O28^TWUbR>RMtoDa061xF(i~PqRmc3hzzt@9w_e0=BHn@`xgWh^=u3 z=PIsH{pzzY&@VAwNIGtpq2op9R#UUv6q=8ZVt>5R+)N<=Qw1M&z;Z^gE>uNwaOOzQ z4?F1YOkyma-kfZ9(~a?TOU9dyq^64wg3~fB&8@X9tsn9y1mhD%|rvS8acbN z#&uKiSUTDgZ*EMcC7;HWRo1pPH=~Ww+EfgPSLnSB`dsalIwML6J5yh2>SSAtO*zC48Y0``QGMbv>O>QPBRA>@UuS{-CyUo&Z zO$$IvG}GQ#H=SL zYZLL>hA5^&OH!uLq~c33HPMQAb2^raHZgZmkjl-+D#pwp0ZVg0(2a&Z&H^rH%5wCs zjzo%L1K61fxUk!n$*q_*0rp4Sv;~Em^qavv4F>atDA1%WCYGWybOtg#4>283fFO$L z*w*5@I9k{ohK`5LMM=4;zKsaQmr~3m(^j0DKo>k=0}1l zSP5(R_+*)Q%O)nfxDH%D)>500Q4qE=!95r~wayJAH9wNtL;az?V~)M*M)d1X-logXM)#DI@2a+GDlNZszPpEb}9qF>xB>ElCUsQYixp za4?p1<++JT+>pxTO+w|AoQm@K=SlAKPnI{wB&dlCwkKn!#KZ+?a)ANGH?_u68JW}R zvoe*M6hYivWME{}lk1pgq6{-St1v%S#X1=Eq_+F9Min?KcBU!03FMke#r+vO4dBKo zh#{%$q(Huv;>$LI8@D$`Cqx7>RK79g)^KEHwj?K}{tWgeKWmt{ESbhkKAR4fB-0?@ zWL;2@ih#qE;Y?*sdx*y3BRV1W#)P19DaielaPiYrj+q8?Nr9K z#hR5?os@E~;>H;89%Nxt8)Hq%UzzW+2}Y>Xk76*^yb%)vY)LT3WEJO2Mm(E(MDm$> zv@0Qqc4nOkWdK-cZuj|zVHE+Oxs1#7trz)&TVi z=m@BuqCVBSP3_Iejfoa~6s3~2Uje1qQt033Wf@l}=jzunjk}4Y|Ogh5&x^(OpPDNr6;4o^LTjx(s5FOGb@1tH+U{ zC8i&py*)c~1G(OwNPlkcKJ;l{U+?a|j=j;YzP{eRd~XU`Fm?;UvY?j>_rkp1fK>-X zn%mTpY)oR1Gf5y3N!7Hla0kF zWj2bBLMmjyDkd^balIvV-jeGPe-Yp?#?q z=S?s7me}5s&;p@E48;;lh;U1jn}inIOo%Mnih_VJ$MT1BC00iDFZElWMI(pjp$?b$-9ON`zjL6sPbP${ljlYA?T^;AHa0>NPPr}7D2x3*Qj`dn2FF7; z!A-ENM1Ks(XY;byd}?TlkIX^l{lUo4Mdxcp6!V1%{?9@5uxv>aiWLTHP%}7a4NB7v zE9w5V7WS79GRt2fO5r~nd{99@LVFgSx1P!EMt?Qu-}pJ-Le3>0mowkJ#e>?6pP+sR zqddi@EwK|o>eMA`p#%=1?MJn1BS-A5r2U2VpA=<}Wse{1IF>t}hn&d1aj@e=?v2}o z!Y@5Jv#cQ1bH+-2-}+_tt)3Yl{_>xGV2!74-}AE{W`B&(tmHGP#B680;h9wZ?C^LB z=9dECu5>G@rMb0a6=1AsD%*}f~qW z{IT^RQskp>mEU`n7g*o&k)gSMeVzOJ`XGg(o!uS#`@252uI0hHmS139RU3DiLJ@}Npy)>E9 zd6#xhkG@y$oEZJY3MG!AFxaO+3Tomhw@m`E8h3LX z0jH*2X2pI9CSjy@ygMZ*_G-uLL(slaLfr@z>atxv_u&&|K~@Il)KwhfMS0Q-s6)c9 z7-4wU%8{X2J}qTC`m@p9eZBkleJq);bSgxTMVC1S%I>H7;S3_C@q&#y%t#o2N5J_9qf_*kQwht%EvWX97TjP?5t)6W`G&N5XA{|e>X>}HYz#I&4$Xhis zw7~C(nH0gHt#llp2Zyc^g2KX5+BH{+r}2IKahG;??A@`m zBa-Whd|V|UWs%r0ytx?|zeQOGM;{6aj)n?|5NSH}Cm#!|oTVW8GBM7H*&T}_<`mQW z)U8b|&571@!)lQNtIj{1uR{2I)XcNJ)gwdYetSW@y?rtR0)rb`F8#LWo;8IoBeY_H zx4PI{jRp=~mGm=52D-p$`a1d!L?GvKQeMAcrP7Dzy80_u1crGviSd(#=heZc4n+G8 z?A_7Z9cZdExs8xpR|mP|)fZUJnt+VX4MgwE_27arnvtP7 zKK{FN{R3D;?Sz=@ANc5wVRAu44`wZ-1G!i?i*Gh-<|Vr1;6VZ+6;KDh%^PE4D4IkAjCw_e33?Fy2l zOXBLtdF!z3+2|*F7VttfsR-x+d`_J(nF-`}Kwwv;DRt!V46jDMYh4)dYFiMTW`a_r zFlKHKAT(7&3NA=P;j9I83IhgMi@gCUVhRHa3}sqHmK5QIT`VbbN@HvbSDXk>Ghsgl z4VAShV>B!=Sa`PrK~EJ2>)6kL_HDDghA#j-4Kmmc5Zk6BwxdEW%G0uH zEL59`WfzSM6&b5N3a&=MbE}85gE^>vk5q?-bA#F8>ayx=1xl}m!gBu7MNK*C#h`eI zg0L>;Y&o7iLD80A({4UgZx3eQAS4-poNOy6?98^|#>f2d5rRfj{`Yy}R(?#}>@4%Q zl@l|?(zH|NW5KP@GVWnMWr;GTE)ppM^ohP!;2-}+7coL(0c@1Wlv|oIX(}qVmyI`Y z9LClLlDcJ@#VzH#f%#0K=2cOlgT@4InHj;*RIkd5O|>n@j3V^Gu-Hc6suHj%b4#;O zaJ`27?okOYn+RHGy!(U=4nZ%R7O#b8NOVIinYt98#gI;QQ8VBrl(eVkNp4!z?41%6 zQVGlMgnZDnXOBy9{|Yz+g#_PcPDyS32+&Y%U9*J$!sKL{%a|?E$w%(guX7m?%0YbTD|E7&`RLGBwxL% zU3~9)e)VX__Fhbe(A_PNN^Epz@Ge$budo{Vh9y10xAEw3fxsOlN7SMdn$dM4T z*x%z)_!vi%^zbYJPqxkLtQc=wpkL$JcE;W8+;TE|N=btQzwJ;X=Ev!_d4!$WUV7Lq z9gRMz5XtEI;g)k1m_|oPF4xJvwjVbIu`m&SU=9bBTJTEFZAF^pIOR5k0nm z6(;!PBMtK8oGJT=9NI)pn-E$)yL@SSzHw}NzH#M;-129X-D+dFWn6!V%_ zC9gvg$q8on=Y!ocE5!0BksYvn>Uz*yEZ;)>A#4gsxQ%&aCfY8*_DvF!?FM_jgsuav zLnCd*hH8_1uVC_fBp6}vfCQ<5+jmQlOHKPO1g+ml8al*o;GL4>Ck*bF z;P)8(i3CsQ(;j1x+-Q`+0ZH%*gZ&a5X0T6!2N}F$fUkWz(R(-Zt7ju$d#~o}O_{-H zS&LhMeD<-C!=)OnY5DBsbJBDrL~*Qj>?h<-KJVi5Zaxq2NhFP!Edl$lq^8eL`nqq@ zSB=j|Oi5r4wUDOLvD4Kg#xq+EB}UhpaQmU;Xq5>=JdQ?8_?ANrqq9wT>u~B(6V!Q8 zX1=5#KZ6wHXSjK|{@JykB@KLU+P1S!<|Dh8+^ zg#`zh|4S42w4PA}OOD4Gy!$@B?h;d0L5tfGOZ5;i(8*W7()XPW{Muh911~b=Mt=9L z=If57eC?~?t5=DkM=5zPTl)H^A(0?i1j*$*B!WS%gIx;Uv47K6PUe2Bx^4FScIQO$ zmDj9S6ZIVVWoPj5VEr3yzFAF zy4|BD2n+@KxXnJ<=-9W8Ri*qMLP*qqQ9s;L?c@+kh6oTnY@&VFURe7YbIhG1^B=E% zeX-w6ZR4oXBXtB!qWX&Vw%HY(v&WOLBtlgSP4mFvr#ive5f*omSwaziM{=adc+<-X zgcHX4k_5j9Wehv@8SxsH@29|Q3)O{3K2;leTY^bRxwUb#QKjrUDb{*HqL#2&>kq6* z5?jAv@Er*%7iREV-e(2!HPlhmEdGp{xP0pjd|Nr~ySHh%wOUxntDTQDwroX))pb%n zzl#ZoBE-`%Bj008T`9q@F!*B$j^u+6G5B+V4seQNtByH$G2+(}p%xzo*X5I6#o#|k z0-e~R7TOmP`kn*}82mnh*8j){RXY7bpg$CD0iGoFS%1!tBqgf#ADRA5fxpb)ZzQO) zNZMg(vwy8q{@3-IMw!lUuF$W!e4U{P`k9!Gkk8iI|AAq4`iT+o;Gq1CO2O}9y_KOF z%Fp8?L&ZVGezPw{Oc7u(aU(_kxNFaEzuxU+l|D(W3qyZWkUjQbhw7d3l{o%jhi>LF z0jG7WI>Gm0=xc*nlCqYe;Mc2|H2?53ags45ctD`mb5bVHO$n(HcP8)m7QnO(ts4s( z*{&4~S---V6sk9#jE*?ul?wdpUcbD)#6*uv@CC14UWY-!Gjz>A;Vbxn*G~~{J${E* zpCjf!$S~({%In{V90jnirP|jkY>lRv0=h2sx6zI7lGO11Y4UuMiG<*+&oRiA%fo2o zwAcph^I|V4ncAs|wrhf$^N|U-=U?U3R{}EO;=6#Uey_6Wcd}gGpi2kqkDFkWZ#FB0 zCL;ID*b2VM^BKzW8T4l%m*c3E`I%HR&gTSQoSa~FK8~UM<0DGeYMWS>uO(aHd$w1J zos=uR4c3H~OuT)ay%d&b9Z}x&s6ebo@9^%~rlD5vp7ma?N>XGoG4sSaC1 zEJ5ZsoGq|UgV*Z4cst1!)zfx&Gr@g|{D+$`yrHz)qWZx@%DfJ$TJRp#0;fO~-Q9DT z@c|uyhh)`ez3NX}o$d#j;$evyhHf`_9Uc#2q&7mtFU{jBFJB02+5|i+{vZ`BtRH|K zZ=>b->jx(yG)P~^GA|J#2eaN23z)c@iUSK2{g!4o1@8g)LJh5XAQS2A=;`Sli0tT! z&_pEmAso_)+?MMZ=v@}vhNS5z@<0a7OrV)+y{yI#k#Y-@t^lMl4e_LgJpuJ;o5 zB)L^&Jos_Wwdvp`oKHcbS zFSTJ|aZ8=;<@Wa3<8HZQZ=a((SgGyv#?#v?#1bb;0=z2=gS)KiI^|O zF?J#X%Il5D-WjGtJxDAAnfXjtcj&iXx6>U`jCFN8e{=hpuXcyT@98m45O_f)$08~Y zU#yO4K<5j-`~b6K{OivWY~hh1oIjv>VWKf-g=8S zBU+tqeSi3TTnb2>b(WL1R2e}YUm4)+!!+?0lf62Tse(!Shfq4zxz7F}DUx*U+{7@| zIfrV2a|3Xj0&dm3MJ}WgS^Xc-=~RA#IK|#QByj5~!v`1JZOBu9Og-XQXUt1uB|>+eLVScqAYnLX(ydajA5IDM-peK z9wTZbebPBT`XkG8A-@9+${(z=x!G?W3|&T&e2?0$Q!37(3r2<(Z#LWc;P8=Le`H7R z{+^wYy}f;1aEa;Y!948jT7m8~p=ry{-l!mU$@T3M)yXr@>7wpTSr!Otn%o|VUG7G2N(x!ig|npmO;;L9(~u)TYpkO=w0rm8mT+XUiBEAN_BZw+TBM zzR%w@58it+2_NJ@G>;q!U(?dcIUi{7&EFz6H`~ffRKB*5L(H^8wk}!xKtU_)1dVMbrkZgHz|>i8sF(@%8#9_Z z!1Z1xzlUYd@iOdn3lMdYBFcCDVdpV2EdgB3AfgW1$YoE1$8>BU0-wJA0gQVW#6NsK zgdBvs3vu*xb?wx)wF0Tq%@Sg`7NK9%bWbz#(R(#bkLKE~U$^MjCcYkB<=u0Ich7A3u-{RB z`VLj~|C=B#iGD6YN7lgBTbO&{8n>=pKE6lzE(v}c@DMy_C43|gehftKY;*;x+V@Uz zVGGAonfMN-+O0bMPG!^C>yX|!CS1<=B3)8F;LO01y2fpR6HFAMxTrB%2QS?yro!gu zK+X%*XG~qgs$(_XAyQr&>9+kP&8~kCWtimn_5d6As(aUyfR~#Ku};9PzQs zQEqjNBv50h)R0NLaS>C77_)2ad}9pEsd09M$9Fj6JFM~1KLTxF(Oj3@=tvuZD!Up> z5-eKGBHCY3>*heX#!Ij88dbzCq;QIDpFZU*#dyjf;U={1Db*Zq0 zd%a^-3DteifNULm=hf9`#x6oY_pOd3*+Y=5{x9BiQLoLhgCd06m7x{F(l)5;@-lFB zd`_o~){_Zvos*_46_K|E=v%DaKccTPePQF7LsiW=hN0R5S_ud%))ZdIl1k(_evzIM zZ6d8&hd4aeuw~DK`l)hC)>IvlJGy?Z}}1OmJs;H#?IH7tPUG2(XlIjo|O7cMHa+ zYLnTGe`1psBcIRbndkTfd*5RC`Yn0B?#yRt2aCO%Eql($&=oN_BwN2|cN?0vp&G-MGc#?A&Tq_irLg1GN>s8ad4Z#q6t{~C)eH#GZ_B&wtVty835&I5 z3eMWfN0Xd9D&o@2-7o{;0z#*F9iba!Fw?E6)U^mWasvb=p7R|U+75MOvA(I>ZN%HN z92&C$N67H)!LM`U&xL&Y9OssCE@Ze#C^;lIoJ_4WtEWn@!TCdg%mu| zze_UPV{%$LRJ>*^$S&yLxcs^CO>wP!uQgVjOPe>0aqB*axzgw5G)g3f|H+?JaQ|iKfNs>RWkS zFFt5ncfkE^`;(E+Jd7f(=%eREoTOcyxctzExN; z9V#A4tMt?Z5pN`Nf!(fKk0l$KCuIxNH>KZtJf-}6?2?B1iW8%A6MiZrGL!VyV=3pf zf={JSjy_7-=Ob|n3wxfjXnZ9#dRZf_WMwdpL9Ki??UpV*{fKOf-HJ`LQ=@-h!}@i0 z)sM~27gLX#@NZD}6!MJ=y3p%n+%|R*vuSHg`^Z6epzsURp902@GQsO?Dx`La(1rDo zJU(QQ2LJa|Tm45;+(L=`zPC+Y|AA>f_gODJpmABRvEAF%q#re2qmt}Gu3znUN4B|&oqw}yU-G=)4jAD0@`Qt-S4pJb^wO7L?G{@9lA`=AWFU7qk$lQJn4?$jKqnJ3G4fcSU#PdUm25HKM9c2Yn zLYU=kb1I|`CS`P5*U&6y`|MM4Jm}4YuKQACwkWJ|OwaGBqfkC?BXbG$R+Qn)VQ9Ly z-s_xhPdZ&9^c|n~DYYFN`4po*|+?5a|CQL5D=hRhIn+fpV2) zGr_Y=@Yda$P8sP!WuyyT@7^UEt*iYH$-I6gAa!*6FAVBx3WQi72V>Jx!Cx`k?GpU9 zZht+D__Hlx;;2V^q4Renke_meU?b&pu_EBYD!Eeu>})6Yn_?~hj;Q4TjJNW&Wiye< zaJzjX>DafZZl}JRTI)1bM|d9M`Ut1Ypb1Ov6;4=APLPp6gaMkeUm(0VMB%EFzH$U z0u!h^qKR?K&AtuC&Mj9~5IO8d;0?Kbky=dLg_FUH&ktUDe()9N2UngSTy=i%it~e4 zo*%q=+|>h2Z1=eF1?DKbiwH|^UxV$cYw@=hf9uBGHLtqYj;?Um*xT1T#Kkg!UOVEh zb=NILqQ~8J*r{5JEbbZynMePMgvByVBj%ZU=nYemb{Dzo(8A)>h_6^)K#@<@>AO;1 z;VyM6+)B5~)oo{2V%-JqN_X{`TGHHk?rPet0?Go3xPlE~Y3$lr4>D*A(rm3W-K%n@ zdCRc|y3Uybm-r$a7Ay3wfZgj#C+t;<)zrbZq+`RRAk_A+m*VlMcGwn3Hsw2Cmmn9O z*2@xHOvdwy1TSUq%M#SB0^#cpITKkt8YcjO+QXjMr)=&?E2NIOML^g(35EaLE3q3^ z3`Y~W9FDiw2$0IMeOiLLZjzv-jGw`uNLfr^oyrHlnh#Pxw@*{7*rz)*qCsBPVdVrR zx^MK@DgwW_oUhMwscpZb8{Y5CmRkNr zlz0xEA^(IKejyn~kpZWTu;pp|P`?DtYASUoIb|zJoC)Y9xwsQu|VCd#lAW=Yhk*PT>y06mv0eo{&Y5Xaad*Tl9^t%kdS}1y{tW7PHste zAaV=!@DV?8GJkqtD;1I~2feZ;+jY5pEHQR{!am-TTm}Om+jpYHYf09#RpXB*#c+NL zGy}GmtSI3)Ovm+T*t^clg(s_IoCnf`Ft&~}VRiQUgL-RxaEUa?ep@Yr3vnPJCxZ3% z^ULuQoCr8p8r#_mx&&i*wnI^?9#< ztJm&&?FkabJIZh0A+>El`<-&Hz1ZK9eNuKzX!Qn>#l?3Wr`+WEdwEa+ z3@t+thh*?1W3%37g5L@BEpRQH3%(zKp-dA_M2^md;&&10tXeMV-k6BxMP35>V<{zc zg#^DMvBIG8d5<7(A+E-R`9f0A*U)k9V-Qh=^c4`oNI0-r}19=$jKQrptQgap8n zk%Ow`_!$GBV8#G=IICqDKIZL34+1*vOz~-u3qvQaIh`VXe3ac@cmVhc%Ug@tnVKdOmTVZWT?rp?h{M9#?Pl4SIX}eUgdjyDs0T_wyPsx^hN_WP*n%3FEO8&npiF9 z$w^;>S+)H4OkOLUJI2_RhpqwpEEcX!C0+P%*59~I@!iJPTO4XTl90HYZmcG75zRXG zkErR`mvOmczonYak5tvVRIG(|R4hLBa@+A8KXfb=o7^n26;nEZkC+d>jnl=|n00NBZW`=B`6WKXNHg?7P*UbB9>jrnfzzyB;%agr<*raI-% z3&twk(qn0O=_*%dW!uY6zh)hAOWWr0^Yvw#r))gUO5HNm^Nks1d--X%ObTS=ne9Av zwc7vUd9lU*7mth0@xSD>*rVp-8MpNK=wteK9HyMJB zFEvPD*C%}VU<7*JEw2`N1>u7g-fWdsrb}vxb(f2^MNje9cx_1RF##)(E}D zlTJwnM9M7TmoHO@*k2Ihv4#Y~U2Xea38uUrdDTj!>h)`x?i&K-@*}iXf=Vu@5L9aq z(}G|mj*j)ug4S>hQE#r516Drw%6j)~W|2>A^!92o?~+QL(GtQBa#C9(;_qyG0t#Iz z!Ot=%BF3iPAF7gIpFkZ)g0rwrpB`YEdL)dhp1l|etlvpm`*I2XGlPpH`1cH6CPCUa z?T7^b1EH5n@GBB@POn7q(05`fZ!vfNL#-ls>?_X8WhCZef1U+-)nn0azNu$boP*|HD*t?KGbx(Zkv#*M$LPSH&y&5;Su zy@c*?=K+*$Obc4Fy_ML;zQNmPLl?}iHv{xEwO)E)9sG=U*R>J~UAMv;SfU{gt@Wf1 zE%v=6;gcK;>q)aGx5B|5+3civ==5}S!+mFWt~0_r1aTjQTmTb}$7&OJhv5GX;=03d zqnqI*!&%Rks%7qt`UZ9`pmcxf!O_1>T;OqQvWMUSY(0b;gq%Jn4fx8rFmp6Bm~(si zdD59FJ}I4X;GG1UH?G^tf!;NY=*F$Eiqwd5)d}+hThyp_X1A0Wa?8k}7~__^vlTc; zU-KB}>!WbAS>fGLg0bR&4_+*U+@jkNX&FOh3L80`4@)G4koB|#RRN`aK-b$$u$XC? zU|zliniaUWVN*!!HV6G@LbTTYgQQg(zz_1lx zqR6wJn(OV<_3XQ0Zz~xM%>^N`Ktt!oGc*+si_354#}fQofjZn*`%g?DOi52~hp6|; z(tCPM9P8^i4?#%u=b6dAiy5lq_7v59sTs?C4SojEh+|B(;wt9BO?y(`ZsOw1$YEV_ zTTG&g9Z?+WVltcXDn57dxtmYgd>jXJr_boUACL+-^u{+K4^Y3(!NhS+t`m&N$A08t znfl@Elj_lNL{~q9*|AHQ&m6BI=^BANK3ZiKZviVDn}hPH4l}hutCZ5wPgJc zmK@jxH{}IR-!LJTTYYdiJU=h1knwt77g+yYkY_zEkN0$c;g>f|b^$*)Rivvtpxiak@g7}I2 zYsYkp*N}8uxs9WyPG|Xe102H5mL91cX`!w{O;t_zg{)dbWKR%8x2F1J>=e_%Q7Jz! zxUUB_mykyFwe;z{ek=vwlD65Tyw|VHw@u|pE{)iLW;mW^Ygy9mOq_`NMUBoqFSwyP zSwrT1YvN7ESTgj`=JwLmi_DUuKZwW%-pA2aUV*MNCZXM7w)Lk6muX^@hl}M^~dg(v`3;#PQhQdhYz@G~=#3@I!2D9N#4nQ4;i)-ig z9)5jCXcH%?%*}o3*k9x?QkR1JJFb6RNIfP)_ezfc3RbO~3m8|W5)g_wJeEwd;)*YZ zR7AIZ83RB+Oi}hsc6-2)Cma-IjHQuROob~sC=CE$#P1ja-Lg(P*6W9h8 z8_XH&-%ItURFdpzEFI21glVceTdIM}MHLXR&|DIjdbzY&V?lLGA9qW&=Z(YJM`d4s zvf)n+cYv~;Cf+yt5sSmwGGqN~98L`C^02|j8_ed{cz42G`TTe*k&*tHTK7)LC|V=( z_*1W+#ACm6o7YxH_@Nv48eXZXDE#erxKg)9%Dq(a1nOxd`jI4~NzbC5V*gIc{f0of zjj z)o|#^BT+|q+%Wam1CBmE3r~(UV5;ece~??NYkf{4K?TP_zqQ;Du zH}LCAsxka&q2ziCbnKs@lJDpJ_4${W_GQh_=c{~vna{6C+96{bbvF0u(sYX67zS$q zqMglK%o;w#Ryv!(+;IUSe!~GAyDrc3C2{BgZo~^*OS;A(RJ^L-iHuVw9C&5@i8sSS za~I6~*Bj<9g{jY2=*6Sn-B6RRXg=0FoG9Bgws4a=ug^AK)0`rz9@D1-%l_-J>|f#C zjb*>TiM9|tqtx6luJ@zeNI~heikX9l7{Cw?pq|Ce&$Inxkb~J5HyzuAYB|kunJ3>g zEnJN{)_4crzcWP;f)iw17&_P~IqKa5p)qe$(Ed2#-Ob{z_wLC%ciURP zLCc1J%)(d%7q;#d`$DeYY*kKnlDQXUm$GGBHdV-RAeOk=yEjmx%CC3OtfSt27^F+8 zcW_RGO+>*?fzdOT<3nt&$0Lq%{`!!G?=5G{a zL*)X8;BVVB73By&xK&@qa>gaQ^Zp_NA6(#7bA;><)%P)j<+YU>fV z2V(t#s=fPht_To>(7+&d^fH6T0pq?=vM{HF7H@JOoNu#R(TY|1cM4_uok3n8VT& z4@0B784K29qi<`Yg^jZMhr*L)XZ~ozmEJaEn*5<(%|TSNCP;8t3_HiPz!81#3w32voZG7b4guzGtO&BEQ{A2=oY&(7}%SYd% zAnu4-H)dWIq6ipIDsRwLG3ZxLtyaPRYB}8^gnAzhPaagokhqWN4?jApbd*f;b3nzHv1atEJ%eCkH> z0K@zFypvBFJ9Uf39C^RTP{QNr>(%GXB~mLppAQ91frdyQKbH_Du2qnFWj1kXk|~I? z9e=n&UzhRq0j*~C2Zk1$1)zmOTwaeKjU**I3w@&a97NiU!c!9T10V6v{S9Uh!}?X0 z$WU2ggKxHv)#C`DIt8miWqkC{EnK6|CRm>fO+IQOzE`+ILRwqGnQXr+C#OmR=l`Os zY}uwg+m~5HjEx_FxLWzToYqs1RNj({s~tKZ4kkI$%Uur>2l<3-pFqD>Wsj+)cBI;z zX2dPFIBul-Kas58jX; z)Ug%kSKzjYDy2B|9jiOTGV_coN*kc{`GBfO6S;MeDyVhPObN^gT$Cq=-Rm6ulFLe9 zDz8j*sPL29sv~!0bDh}<>Ddv{`H7$ZngEnID7;j)V{98%o>)E#k1KMjm6tMzKJ zUaw%IP_@yW&Dx!3jh*qbn5r;ii&TEb98#)i*|j?g$Ma{6UyV7O7-Lrji#3^a7V$K5 zFw<)v_SC+93EBXQ`J0x*h9q(FRjnRKIVn3UuBCpD+5^a&)Uw*MTlU(AQ}c(Q!-83J z01>N!zyU;j2;UJHeg~C?%fI!~g1A5N=y3HdW_{;QuW^UBE9RxI_jXm1uoh0|aE&rBcS zEgRx>Ic$wpSQl1-fs(?lC$V?sPX!gTAEPLm^HPIml{4f)R;H)2R1p9V4BaJvrJo?ix5hVLoNsAo9upyzC>CzLXVRMtN|SrMZzXo!N#dB0SU z82Xm3iQk99EC*ubh|4mGuqS#uj9FPxtvmgCbbUgC8J?=LX&95xM=jQ2q!F{?9@J}Z zoqK!?9zvOySF7Oj{d`EYfqtH;2gCLS-=XseKDdbndVrr$m(P41hfxOr*6GbGc^Rg& z331Sl1wXK<&xHrCgcXmY94>@?JYgs8zmSiopG??qK=GI3gGt=x^3%=6d-SA#p{Uug z(&N$orq$*bwGQLQtC8x`4zPj`&ZnK{t z+rqX8cvD^@589lx%O7>Gl(`nkPn5qeYI4NnubU6ozh-^QCwAQSZ_qX-T$J0+gAUJ{%vXhi~eoZ{@0wt?wrxp{@1+2?!3{( z{#V6ew_ z_mlkqg_eE4&fNP#D8pVca+qqWeeR-+-M51aH_l!Af7`MPKOB2$EYjcAjaxnB7pBaQ zW(4g&Q~rN!9uL-)n}c=6xGZNtcm?7L9I4~fR_3DwmsFBezkbelTE~qYBfQ>$Kq0k> zjeh6?t{!w2$@n=7ReO5J$l5GLQwTfWhz!C0EI(Rv!ADZ$#|iaFiurZi3pkL1daUQj znZoO-Uo?w+#5(GEv^#J_(lq*cX`=E9^8=1B z;6pQ6ZKQ(#yH=5YT=?0&Q!Jmmdb_)O@4^yz#{n#W2mISoeA~(k=;=*4tmMh9s7831 z;fyNbgISm@Kc5-ND6d~In0+B*pP=co9@ih5`&yvUT+hzG0FB0%Cc5r?p5%dTiULUx zzS@R=I_W4B6@WAT;Gn_yQS|p>wt){{Vi|$O;*aJ#@600P(dphjDy*C$UH3fdk08j= z)_c0NPc8Pb76*3M#2}XUS{^=jJE1-FLB8>kxM05hw8F+5o{ z6vvJ*^?K_dS8$=1xbP2MN0ODh{$%ORUoH>VzzE%-zw#M@9Xhaz#)+zlpE|@oa^Tku z;VG-Ci7ErK8zFS{Mc_?;hl2gw5-^VaN(udo7!-e0N+uh}I4brIDaa0*zqS){o2lX@ zRB>5;R2U)#8PXd84Sl{87^3-X-=l@zJ$h-aQ!t&y?$nWb0GGe|CQ(z-mrzk6X#48g zgS$4r-0gH6doVX~OZ7DMXqdRFI^p|-69HxcYufXrvrcH4Tco8OVov7@kj?xRn^uWS zuyX23@X%tfgNm5_p`*0=WA)ak^eOCRw02wdSbMeHrwJQ6v9auCzRtXuFjvwl0h>z- zW#iri&q|=Dx$6VULdmN9Y>|apvwa++BzK``UG+NWv0}5R{j2i|w_$2sUar2hSy~Rv)#th&q zK*@sYv3Uk11_l0*_&s{Xnbf1nH)@#PIOHGBLMk)XDyhj$0#ZYWwckLYzJat)$6 zxWMcec4i|nWl!dDogzt5%3x#H$5sFNgW8Bc z*hSzIH}dt=DtS2z;Y37b-+F3_0C4@Iw>2!~Jj3`O-{I|`YVYhO2JK2N7-7Ue|CJ*b z<*ytG{E8Tg(@FZNE*E)-4Z`Ij(wr}&#z^(pf@<5ps}p-p^$qGVC`*wtpB%nCnZVCF zh3l`n*&FN2C|S$@iXnuzNo(!6Ux&l5gM&3M?f}r+9n}R>A*Z+^mitT0ohGTkK}vCV z8qWGL=I|Nrj|T8_COOv4#%ouv6yY%%F-M7mSVhHP%=cn!D~%?9 zKAs_5uuGNA#m{GGXku6HD-k*G=M{Wj$!8^>>!g&>j8CTn%kNaH z4$PS+8Zdrao0p#h<-Wu|-_dLtlCP>JJfxcNS49)XcDp&8Eq1S^a%LR#u%mb90W)X5 z25U6A=P9*FSKG&{ottsXGf}G(W$U37rjB|Es$a4~Zv6@|j(ebKs7>Q?^|84@9yr@c zljnh1E@0BMa!VL=`AHKdE@MB+%3$$@XJN%dcw>qw*}G-Tan`(X%l!GkIp*)jehq0a zWF`o%Mr3%bZwzph{&APLyG>k5mf+%l`8AXFsM`5;E9|uT*PJetEMJoxIx${hkQ3u+ z3EDrTEy?+gPOV?-)Os`A3lCIrLg?t}?K!ZwcYptF*pRBr?b?MKc6$b>f5R~$7U{rc z$2+@lLoaSplr1R2@@^h0gvmNMmzF3q3xZ;yQ$@% zHx`bNGRisas0DhXrcCe^{&o@SoMn!Y%Cz{82)N- zKZjsyG^8&iQ!f2=XyNJeap*Tx)gi^;mfI_pC|ZKoi?x8Q;@@Bvya zlC`;OC$`J`ay#}9kn8Ed@3j+0RqB`q-e!J)L`vZ= zIOIAzq>L(Z!F^qQdvgN=V1u{{<<1vu^W#T`$4CFeys!%nS zkag#o1a4MA6T?g!2&D*m^(1%qOGB<1hy?Sz=< z86eK34_9GGdJ)qX+1mk6n_NeCe;)UACPbtuAUNjIMFF=Yl9@=x-O$p8J2D~&gJw75 zmsaZ{HSLIu2M99Zrt0v6VG-Qm4Jdx6CW#xz+~$lFvn-ZD=4FhFrQ0L8+!`d63C)TUxdxJ;}- z8&GcqY%1Ln$s}+%U~+e*9JehUZ+N(^l8T{y#{H$#(6{(9g#x}+?kt;qKI~b(e)@ELCDkzaV6!6Qq ztu67$M%S$)+TnD&8QdcSw7N178{~&W*cdqE#aKN`0pgGX-KY_3mY|S+-p#H2p^_^j z3Aarcd89TbS9B29Zd&>*y#jf-&FxaO;De)46~QmZ1CC)&E7owiYgI(N`f6K($xtO| zhr^!lZzLVxm`dWe?`q@HCc5*sB{T6WF?dPQ?4(pdcv}qBf^bl^&?wr*;gYWaIRo7o z-AHmnBv!W>#nk!fK@XXvAs?czHes;80xE*fmPh3#Suw1a@W{3>*%iHgyTPi9ej+N< z(BgLCtBtt)>Gs^-j>!7myLYTywd&e6)jhdg0|!?0bgj63-%XPIE#|=?Z@=hoi|G{G z6`?J)DQ~L4ara)B;u+ym2`4k+*Nk{x>!E_;kHyKh)@{U{Qt)lT!xAMn{9iu&@c#jC CH7