diff --git a/clos/clos-env.DFASL b/clos/clos-env.DFASL index c0562b23..dd9c96f1 100644 Binary files a/clos/clos-env.DFASL and b/clos/clos-env.DFASL differ diff --git a/clos/clos-env.lisp b/clos/clos-env.lisp index be366810..ba1ec3f1 100644 --- a/clos/clos-env.lisp +++ b/clos/clos-env.lisp @@ -1505,7 +1505,7 @@ window" (setf (sedit:get-format 'call-next-method) '(:indent (1) :args (:keyword nil))) -(setf (sedit:get-format 'symbol-macrolet) 'let) +(setf (sedit:get-format 'cl:symbol-macrolet) 'let) (setf (sedit:get-format 'with-accessors) '(:indent ((1) 1) diff --git a/clos/pkg.dfasl b/clos/pkg.dfasl index b67004b2..854aef96 100644 Binary files a/clos/pkg.dfasl and b/clos/pkg.dfasl differ diff --git a/clos/pkg.lisp b/clos/pkg.lisp index 7491df0d..0ba5ec32 100644 --- a/clos/pkg.lisp +++ b/clos/pkg.lisp @@ -1,16 +1,12 @@ ;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*- - ;;; File converted on 26-Mar-91 10:23:29 from source pkg ;;;. Original source {dsk}local>users>welch>lisp>clos>rev4>il-format>pkg.;4 created 1-Mar-91 10:10:26 ;;;. Copyright (c) 1991 by Venue - (in-package "CLOS") - - ;;; Some CommonLisps have more symbols in the Lisp package than the ones that are explicitly ;;; specified in CLtL. This causes trouble. Any Lisp that has extra symbols in the Lisp package ;;; should shadow those symbols in the CLOS package. @@ -31,7 +27,7 @@ no-applicable-method no-next-method print-object reinitialize-instance remove-method shared-initialize slot-boundp slot-exists-p slot-makunbound slot-missing slot-unbound slot-value standard standard-class standard-generic-function standard-method - standard-object structure-class symbol-macrolet update-instance-for-different-class + standard-object structure-class update-instance-for-different-class update-instance-for-redefined-class with-accessors with-added-methods with-slots)) (import '(xcl:false xcl:destructuring-bind xcl:true) *the-clos-package*) diff --git a/internal/loadups/LOADUP-LISP b/internal/loadups/LOADUP-LISP index 006b3fc7..5000cbff 100644 --- a/internal/loadups/LOADUP-LISP +++ b/internal/loadups/LOADUP-LISP @@ -1,13 +1,13 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) -(FILECREATED "14-Mar-2024 12:16:33" |{DSK}larry>il>medley>internal>loadups>LOADUP-LISP.;2| 5426 +(FILECREATED "21-Mar-2024 10:56:13" |{DSK}larry>il>medley>internal>loadups>LOADUP-LISP.;4| 5586 :EDIT-BY "lmm" :CHANGES-TO (FNS LOADUP-LISP) - :PREVIOUS-DATE "31-Jul-2023 18:22:53" -|{DSK}larry>il>medley>internal>loadups>LOADUP-LISP.;1|) + :PREVIOUS-DATE "14-Mar-2024 12:16:33" +|{DSK}larry>il>medley>internal>loadups>LOADUP-LISP.;3|) (PRETTYCOMPRINT LOADUP-LISPCOMS) @@ -20,7 +20,8 @@ (DEFINEQ (LOADUP-LISP - (LAMBDA (DRIBBLEFILE) (* \; "Edited 14-Mar-2024 12:16 by lmm") + (LAMBDA (DRIBBLEFILE) (* \; "Edited 21-Mar-2024 10:55 by lmm") + (* \; "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") @@ -110,9 +111,9 @@ (PACKAGE-ENABLE) - (* |;;| " Added late") + (* |;;| " Added late, LOAD late to avoid any dependencies") - (LOADUP '(XCL-LOOP)) + (LOADUP '(XCL-LOOP XCL-HASH-LOOP)) (* |;;| " networking code -- should make it optional but too many cross dependencies") @@ -130,5 +131,5 @@ (GLOBALVARS MAKESYSFILENAME MEDLEY-INIT-VARS MEDLEYDIR SYSTEMINITVARS USERRECLST) ) (DECLARE\: DONTCOPY - (FILEMAP (NIL (673 5220 (LOADUP-LISP 683 . 5218))))) + (FILEMAP (NIL (673 5380 (LOADUP-LISP 683 . 5378))))) STOP diff --git a/internal/loadups/LOADUP-LISP.LCOM b/internal/loadups/LOADUP-LISP.LCOM index b76af649..d83abfd5 100644 Binary files a/internal/loadups/LOADUP-LISP.LCOM and b/internal/loadups/LOADUP-LISP.LCOM differ diff --git a/sources/PACKAGE-STARTUP b/sources/PACKAGE-STARTUP index 24d8e66c..dad817d4 100644 --- a/sources/PACKAGE-STARTUP +++ b/sources/PACKAGE-STARTUP @@ -1,12 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) -(FILECREATED "16-Mar-2024 08:28:55" |{DSK}larry>il>medley>sources>PACKAGE-STARTUP.;2| 36546 +(FILECREATED "21-Mar-2024 10:21:14" |{DSK}larry>il>medley>sources>PACKAGE-STARTUP.;9| 36658 :EDIT-BY "lmm" - :CHANGES-TO (VARIABLES CMLSYMBOLS.MACROS) + :CHANGES-TO (VARIABLES CMLSYMBOLS.DECLARATORS CMLSYMBOLS.SHARED) - :PREVIOUS-DATE " 1-Aug-2021 18:08:23" |{DSK}larry>il>medley>sources>PACKAGE-STARTUP.;1| + :PREVIOUS-DATE "20-Mar-2024 23:34:56" |{DSK}larry>il>medley>sources>PACKAGE-STARTUP.;8| ) @@ -311,8 +311,8 @@ "VECTOR-PUSH-EXTEND" "VECTORP" "WARN" "WRITE" "WRITE-BYTE" "WRITE-CHAR" "WRITE-LINE" "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")) +(CL:DEFPARAMETER CMLSYMBOLS.DECLARATORS '("DECLARATION" "FTYPE" "FUNCTION" "IGNORE" "IGNORABLE" + "INLINE" "NOTINLINE" "OPTIMIZE" "SPECIAL" "TYPE")) (CL:DEFPARAMETER CMLSYMBOLS.TYPENAMES '("ARRAY" "ATOM" "BIGNUM" "BIT" "BIT-VECTOR" "CHARACTER" "COMMON" "COMPILED-FUNCTION" "COMPLEX" @@ -327,10 +327,11 @@ "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" "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")) + "WITH-HASH-TABLE-ITERATOR" "WITH-PACKAGE-ITERATOR" "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" @@ -353,12 +354,12 @@ "CADADR" "CADAR" "CADDAR" "CADDDR" "CADDR" "CADR" "CAR" "CASE" "CDAAAR" "CDAADR" "CDAAR" "CDADAR" "CDADDR" "CDADR" "CDAR" "CDDAAR" "CDDADR" "CDDAR" "CDDDAR" "CDDDDR" "CDDDR" "CDDR" "CDR" "CLRHASH" "COERCE" "COMPLEX" "COND" "CONS" "DECLARE" "DEFMACRO" "DPB" "DRIBBLE" "ED" - "EQ" "EQL" "EVENP" "EXPORT" "FLOAT" "GET" "GO" "IGNORE" "IMPORT" "INSPECT" "INTEGER" "LAST" - "LDB" "LET" "LET*" "LIST" "LIST*" "LOGAND" "LOGNOT" "LOGXOR" "MAX" "MIN" "MINUSP" "NCONC" - "NIL" "NOT" "NULL" "ODDP" "OPEN" "OR" "PACKAGE" "PATHNAME" "PROG" "PROG*" "PROG1" "PROG2" - "PROGN" "QUOTE" "RANDOM-STATE" "RATIO" "READTABLEP" "REMHASH" "REMPROP" "RETURN" "ROUND" - "RPLACA" "RPLACD" "SATISFIES" "SEQUENCE" "SET" "STRING" "STRING-EQUAL" "STREAM" "STREAMP" - "T" "TAILP" "THE" "TIME" "TRACE" "TYPE" "TYPEP" "UNTRACE" "WRITE") + "EQ" "EQL" "EVENP" "EXPORT" "FLOAT" "GET" "GO" "IGNORE" "IGNORABLE" "IMPORT" "INSPECT" + "INTEGER" "LAST" "LDB" "LET" "LET*" "LIST" "LIST*" "LOGAND" "LOGNOT" "LOGXOR" "MAX" "MIN" + "MINUSP" "NCONC" "NIL" "NOT" "NULL" "ODDP" "OPEN" "OR" "PACKAGE" "PATHNAME" "PROG" "PROG*" + "PROG1" "PROG2" "PROGN" "QUOTE" "RANDOM-STATE" "RATIO" "READTABLEP" "REMHASH" "REMPROP" + "RETURN" "ROUND" "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.") @@ -643,14 +644,14 @@ (PACKAGE-INIT) ) (DECLARE\: DONTCOPY - (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))))) + (FILEMAP (NIL (3038 3133 (RETURN-FIRST-OF-THREE 3038 . 3133)) (3135 3273 ( +ERROR-MISSING-EXTERNAL-SYMBOL 3135 . 3273)) (3880 4848 (CHECK-SYMBOL-NAMESTRING 3880 . 4848)) (4850 +8008 (\\NEW.READ.SYMBOL 4850 . 8008)) (8010 9720 (\\NEW.MKATOM 8010 . 9720)) (23549 23631 ( +LITATOM.EXISTS 23549 . 23631)) (24311 25317 (NAMESTRING-CONVERSION-CLAUSE 24311 . 25317)) (25319 26574 + (CONVERT-LITATOM 25319 . 26574)) (26576 28649 (CONCOCT-SYMBOL 26576 . 28649)) (28651 28945 ( +TRANSFER-SYMBOL 28651 . 28945)) (28947 29655 (INTERN-LITATOM 28947 . 29655)) (29657 30336 ( +\\LITATOM.EATCHARS 29657 . 30336)) (30338 30615 (PACKAGE-INIT 30338 . 30615)) (30617 31190 ( +PACKAGE-CLEAR 30617 . 31190)) (31192 32583 (PACKAGE-MAKE 31192 . 32583)) (32585 33897 ( +PACKAGE-HIERARCHY-INIT 32585 . 33897)) (33899 35508 (PACKAGE-ENABLE 33899 . 35508)) (35510 36153 ( +PACKAGE-DISABLE 35510 . 36153)) (36200 36226 (ID 36200 . 36226))))) STOP diff --git a/sources/PACKAGE-STARTUP.LCOM b/sources/PACKAGE-STARTUP.LCOM index 65dd880d..49f479dc 100644 Binary files a/sources/PACKAGE-STARTUP.LCOM and b/sources/PACKAGE-STARTUP.LCOM differ diff --git a/sources/XCL-HASH-LOOP b/sources/XCL-HASH-LOOP new file mode 100644 index 00000000..27e64685 --- /dev/null +++ b/sources/XCL-HASH-LOOP @@ -0,0 +1,102 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) + +(FILECREATED "21-Mar-2024 13:31:40" {DSK}larry>il>medley>sources>XCL-HASH-LOOP.;9 4865 + + :EDIT-BY "lmm" + + :CHANGES-TO (FUNCTIONS TEST-HASH-LOOP) + + :PREVIOUS-DATE "21-Mar-2024 11:19:24" {DSK}larry>il>medley>sources>XCL-HASH-LOOP.;8) + + +(PRETTYCOMPRINT XCL-HASH-LOOPCOMS) + +(RPAQQ XCL-HASH-LOOPCOMS ((FUNCTIONS HASH-TABLE-ITERATOR HASH-TABLE-ITERATOR-1 TEST-HASH-LOOP + CL:WITH-HASH-TABLE-ITERATOR) + (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) + LLARRAYELT)) + (PROP FILETYPE XCL-HASH-LOOP))) + +(CL:DEFUN HASH-TABLE-ITERATOR (HASH-TABLE-LIST) (* ; "Edited 21-Mar-2024 09:49 by lmm") + [LET ((TABLES (MKLIST HASH-TABLE-LIST))) + (COND + ((NULL TABLES) + NIL) + ((NULL (CDR TABLES)) + (HASH-TABLE-ITERATOR-1 (CAR TABLES))) + (T (LET [(ITERATOR (HASH-TABLE-ITERATOR-1 (CL:POP TABLES] + #'(CL:LAMBDA NIL (CL:LOOP (CL:MULTIPLE-VALUE-BIND + (MORE KEY VALUE) + (CL:FUNCALL ITERATOR) + (COND + (MORE (RETURN (CL:VALUES MORE KEY VALUE))) + [TABLES (CL:SETQ ITERATOR (HASH-TABLE-ITERATOR-1 + (CL:POP TABLES] + (T (RETURN NIL]) + +(CL:DEFUN HASH-TABLE-ITERATOR-1 (TABLE) (* ; "Edited 19-Mar-2024 12:31 by lmm") + [LET* ((SLOT (fetch HARRAYPBASE of TABLE)) + [LASTSLOT (fetch (HASHSLOT NEXTSLOT) of (\HASHSLOT SLOT (fetch (HARRAYP LASTINDEX) + of TABLE] + (NULLVALUE \HASH.NULL.VALUE) + K V) + #'(CL:LAMBDA NIL (CL:BLOCK ITERATOR + (CL:LOOP (SETQ K (fetch (HASHSLOT KEY) of SLOT)) + (SETQ V (fetch (HASHSLOT VALUE) of SLOT)) + (CL:WHEN V + + (* ;; "first non-empty slot") + + (RETURN)) + (SETQ SLOT (fetch (HASHSLOT NEXTSLOT) of SLOT)) + (CL:WHEN (EQ SLOT LASTSLOT) + + (* ;; "Out of slots to scan") + + (CL:RETURN-FROM ITERATOR NIL))) + + (* ;; "SLOT is set and not at end") + + [CL:RETURN-FROM ITERATOR (CL:MULTIPLE-VALUE-PROG1 + (CL:VALUES T K (AND (NEQ NULLVALUE V) + V)) + (SETQ SLOT (fetch (HASHSLOT NEXTSLOT) + of SLOT])]) + +(CL:DEFUN TEST-HASH-LOOP (&OPTIONAL HA) (* ; "Edited 21-Mar-2024 10:39 by lmm") + [IF (NOT HA) + THEN (SETQ HA (HARRAY 7)) + (LET [(TRIALDATA '(1 2 A B "C" "D" 'EEEE 'FFFF (G) + (H] + (CL:LOOP FOR X ON TRIALDATA BY #'CDDR DO (CL:SETF (GETHASH (CL:FIRST X) + HA) + (CL:SECOND X] + (LET (RESULT LOOPRESULT) + [MAPHASH HA #'(LAMBDA (V K) + (PUSH RESULT (LIST K V] + (SETQ RESULT (REVERSE RESULT)) + (SETQ LOOPRESULT (CL:LOOP FOR X BEING EACH HASH-KEY OF HA USING (HASH-VALUE V) + COLLECT + (LIST X V))) + (OR (EQUAL RESULT LOOPRESULT) + (COMPARELISTS RESULT LOOPRESULT)))) + +(DEFMACRO CL:WITH-HASH-TABLE-ITERATOR ((NAME HASH-TABLE-FORM) + &BODY BODY) (* ; "Edited 18-Mar-2024 09:38 by larry") + [LET ((ITERATOR (CL:GENSYM))) + `(LET [(,ITERATOR (HASH-TABLE-ITERATOR ,HASH-TABLE-FORM] + (DECLARE (IGNORABLE ,ITERATOR)) + (CL:MACROLET [(,NAME NIL '(CL:FUNCALL ,ITERATOR] + ,@BODY]) +(DECLARE%: EVAL@COMPILE DONTCOPY + +(FILESLOAD (LOADCOMP) + LLARRAYELT) +) + +(PUTPROPS XCL-HASH-LOOP FILETYPE CL:COMPILE-FILE) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (755 1731 (HASH-TABLE-ITERATOR 755 . 1731)) (1733 3354 (HASH-TABLE-ITERATOR-1 1733 . +3354)) (3356 4284 (TEST-HASH-LOOP 3356 . 4284)) (4286 4705 (CL:WITH-HASH-TABLE-ITERATOR 4286 . 4705))) +)) +STOP diff --git a/sources/XCL-HASH-LOOP.DFASL b/sources/XCL-HASH-LOOP.DFASL new file mode 100644 index 00000000..4773c1f0 Binary files /dev/null and b/sources/XCL-HASH-LOOP.DFASL differ diff --git a/sources/XCL-LOOP b/sources/XCL-LOOP index 99a519fa..a6e6ac56 100644 --- a/sources/XCL-LOOP +++ b/sources/XCL-LOOP @@ -1,12 +1,13 @@ (DEFINE-FILE-INFO PACKAGE (DEFPACKAGE "LOOP" (USE "LISP" "XCL")) READTABLE "XCL" BASE 10) -(il:filecreated "16-Mar-2024 17:53:42" il:|{DSK}larry>il>medley>sources>XCL-LOOP.;23| 61443 +(il:filecreated " 8-Apr-2024 19:38:27" il:|{DSK}larry>il>medley>sources>XCL-LOOP.;13| 61862 :edit-by "lmm" - :changes-to (il:functions with-temporaries) + :changes-to (il:vars il:xcl-loopcoms) + (il:functions cl::symbol-macrolet with-list-accumulator) - :previous-date "16-Mar-2024 11:13:11" il:|{DSK}larry>il>medley>sources>XCL-LOOP.;22|) + :previous-date " 2-Apr-2024 15:08:27" il:|{DSK}larry>il>medley>sources>XCL-LOOP.;12|) (il:prettycomprint il:xcl-loopcoms) @@ -39,8 +40,8 @@ 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 + simple-var-p simple-var1 stray-of-type-error cl::symbol-macrolet 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) @@ -1152,15 +1153,11 @@ (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 repeat-clause () (il:* il:\; "Edited 2-Apr-2024 12:55 by lmm") + (let ((form (form1))) + (lp :for (gensym) + :downfrom form :to 1) + (clause*))) (defun return-clause () (lp :do `(return-from ,*loop-name* ,(form-or-it)))) @@ -1196,6 +1193,14 @@ (defun stray-of-type-error () (loop-error "OF-TYPE keyword should be followed by a type spec.")) +(defmacro cl::symbol-macrolet (vardefs &body body) (il:* il:\; "Edited 24-Mar-2024 21:46 by lmm") + + (il:* il:|;;| "") + + `(progn ,@(il:subpair (cons 'setq (mapcar vardefs #'car)) + (cons 'setf (mapcar vardefs #'cadr)) + body))) + (defun type-spec? () (let ((type t) (supplied-p nil)) @@ -1288,7 +1293,7 @@ iterator-forms `(,iterator-macro ,spec ,(with-iterator-forms rest form))))) -(defun with-list-accumulator (accumulator-spec form) +(defun with-list-accumulator (accumulator-spec form) (il:* il:\; "Edited 8-Apr-2024 19:28 by lmm") (destructuring-bind (name &key var splice &allow-other-keys) accumulator-spec (let* ((anonymous-p (null name)) @@ -1301,7 +1306,7 @@ '(list nil))) (form (if (and (not anonymous-p) (not (globally-special-p var))) - `(symbol-macrolet ((,var (cdr ,list-var))) + `(cl::symbol-macrolet ((,var (cdr ,list-var))) ,form) form))) `(let ((,list-var ,value-form)) @@ -1347,8 +1352,9 @@ (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))) +(defun with-temporaries (temporary-specs form) (il:* il:\; "Edited 21-Mar-2024 11:50 by lmm") + (il:* il:\; "Edited 16-Mar-2024 14:22 by lmm") + (destructuring-bind (temporaries &key ((:ignorable ignorable))) temporary-specs (if temporaries `(let ,temporaries ,@(when ignorable @@ -1411,55 +1417,56 @@ ;; (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:filemap (nil (6825 6910 (%keyword 6825 . 6910)) (6912 7095 (%list 6912 . 7095)) (7097 8354 ( +accumulate-in-list 7097 . 8354)) (8356 10036 (accumulation-clause 8356 . 10036)) (10038 10272 ( +accumulator-kind 10038 . 10272)) (10274 12163 (accumulator-spec 10274 . 12163)) (12165 12634 ( +along-with 12165 . 12634)) (12636 13128 (always-never-thereis-clause 12636 . 13128)) (13130 13489 ( +ambiguous-loop-result-error 13130 . 13489)) (13491 13706 (append-context 13491 . 13706)) (13785 14162 +(bindings 13785 . 14162)) (14164 14504 (bound-variables 14164 . 14504)) (14506 14596 (by-step-fun +14506 . 14596)) (14598 14704 (car-type 14598 . 14704)) (14706 14812 (cdr-type 14706 . 14812)) (14814 +15211 (check-multiple-bindings 14814 . 15211)) (15213 15433 (cl-external-p 15213 . 15433)) (15435 +15564 (clause* 15435 . 15564)) (15566 15966 (clause1 15566 . 15966)) (15968 16125 (compound-forms* +15968 . 16125)) (16127 16251 (compound-forms+ 16127 . 16251)) (16253 17511 (conditional-clause 16253 + . 17511)) (17513 18224 (constant-bindings 17513 . 18224)) (18226 18597 (constant-function-p 18226 . +18597)) (18599 18793 (constant-vector 18599 . 18793)) (18795 18886 (constant-vector-p 18795 . 18886)) +(18888 19080 (d-var-spec-p 18888 . 19080)) (19082 19312 (d-var-spec1 19082 . 19312)) (19314 19639 ( +d-var-type-spec 19314 . 19639)) (19641 20201 (declarations 19641 . 20201)) (20203 20313 ( +default-binding 20203 . 20313)) (20315 20928 (default-bindings 20315 . 20928)) (20930 21391 ( +default-type 20930 . 21391)) (21393 21914 (default-value 21393 . 21914)) (21916 23406 ( +destructuring-multiple-value-bind 21916 . 23406)) (23408 24693 (destructuring-multiple-value-setq +23408 . 24693)) (24695 25222 (dispatch-for-as-subclause 24695 . 25222)) (25224 25293 (do-clause 25224 + . 25293)) (25295 25471 (empty-p 25295 . 25471)) (25473 25747 (enumerate 25473 . 25747)) (25749 27475 +(extended-loop 25749 . 27475)) (27477 27648 (fill-in 27477 . 27648)) (27650 27727 (finally-clause +27650 . 27727)) (27729 27847 (for 27729 . 27847)) (27849 29205 (for-as-across-subclause 27849 . 29205) +) (29207 30129 (for-as-arithmetic-possible-prepositions 29207 . 30129)) (30131 30847 ( +for-as-arithmetic-step-and-test-functions 30131 . 30847)) (30849 32794 (for-as-arithmetic-subclause +30849 . 32794)) (32796 33246 (for-as-being-subclause 32796 . 33246)) (33248 34464 (for-as-clause 33248 + . 34464)) (34466 35994 (for-as-equals-then-subclause 34466 . 35994)) (35996 36274 (for-as-fill-in +35996 . 36274)) (36276 38242 (for-as-hash-subclause 36276 . 38242)) (38244 38490 ( +for-as-in-list-subclause 38244 . 38490)) (38492 39985 (for-as-on-list-subclause 38492 . 39985)) (39987 + 41689 (for-as-package-subclause 39987 . 41689)) (41691 41922 (for-as-parallel-p 41691 . 41922)) ( +41924 42072 (form-or-it 41924 . 42072)) (42074 42193 (form1 42074 . 42193)) (42195 42295 ( +gensym-ignorable 42195 . 42295)) (42297 42408 (globally-special-p 42297 . 42408)) (42410 42589 ( +hash-d-var-spec 42410 . 42589)) (42591 42672 (initially-clause 42591 . 42672)) (42674 42831 ( +invalid-accumulator-combination-error 42674 . 42831)) (42833 43450 (keyword1 42833 . 43450)) (43452 +43922 (keyword? 43452 . 43922)) (43924 44033 (let-form 43924 . 44033)) (44035 44189 (loop-error 44035 + . 44189)) (44191 44382 (loop-finish-test-forms 44191 . 44382)) (44384 44536 (loop-warn 44384 . 44536) +) (44538 44742 (lp 44538 . 44742)) (44744 45181 (main-clause* 44744 . 45181)) (45183 45279 (mapappend +45183 . 45279)) (45281 45811 (multiple-value-list-argument-form 45281 . 45811)) (45813 46206 ( +multiple-value-list-form-p 45813 . 46206)) (46208 46546 (name-clause? 46208 . 46546)) (46548 46827 ( +one 46548 . 46827)) (46829 48474 (ordinary-bindings 46829 . 48474)) (48476 48693 (preposition1 48476 + . 48693)) (48695 48896 (preposition? 48695 . 48896)) (48898 49058 (psetq-forms 48898 . 49058)) (49060 + 49240 (quoted-form-p 49060 . 49240)) (49242 49497 (quoted-object 49242 . 49497)) (49499 50303 ( +reduce-redundant-code 49499 . 50303)) (50305 50534 (repeat-clause 50305 . 50534)) (50536 50626 ( +return-clause 50536 . 50626)) (50628 51463 (selectable-clause 50628 . 51463)) (51465 51616 ( +simple-loop 51465 . 51616)) (51618 51696 (simple-var-p 51618 . 51696)) (51698 51882 (simple-var1 51698 + . 51882)) (51884 51991 (stray-of-type-error 51884 . 51991)) (51993 52278 (cl::symbol-macrolet 51993 + . 52278)) (52280 52714 (type-spec? 52280 . 52714)) (52716 52782 (until-clause 52716 . 52782)) (52784 +53365 (using-other-var 52784 . 53365)) (53367 53561 (variable-clause* 53367 . 53561)) (53563 53667 ( +while-clause 53563 . 53667)) (53669 53848 (with 53669 . 53848)) (53850 54295 (with-accumulators 53850 + . 54295)) (54297 54547 (with-binding-forms 54297 . 54547)) (54549 55780 (with-clause 54549 . 55780)) +(55782 56041 (with-iterator-forms 55782 . 56041)) (56043 57190 (with-list-accumulator 56043 . 57190)) +(57192 57629 (with-loop-context 57192 . 57629)) (57631 58869 (with-numeric-accumulator 57631 . 58869)) + (58871 59392 (with-temporaries 58871 . 59392)) (59394 59674 (zero 59394 . 59674)) (59676 59809 (loop +59676 . 59809))))) il:stop diff --git a/sources/XCL-LOOP.DFASL b/sources/XCL-LOOP.DFASL index b2bb4c40..ff0bfa60 100644 Binary files a/sources/XCL-LOOP.DFASL and b/sources/XCL-LOOP.DFASL differ diff --git a/sources/XCLC-ALPHA b/sources/XCLC-ALPHA index 783fdbc2..a1442828 100644 --- a/sources/XCLC-ALPHA +++ b/sources/XCLC-ALPHA @@ -1,17 +1,19 @@ -(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "COMPILER" (USE "LISP" "XCL"))) -(il:filecreated "20-Jul-90 17:07:06" il:|{PELE:MV:ENVOS}SOURCES>XCLC-ALPHA.;3| 84829 +(DEFINE-FILE-INFO PACKAGE (DEFPACKAGE "COMPILER" (USE "LISP" "XCL")) READTABLE "XCL" BASE 10) - il:|changes| il:|to:| (il:functions alpha-form) +(il:filecreated "10-Apr-2024 19:21:49" il:|{DSK}larry>il>medley>sources>XCLC-ALPHA.;2| 84407 - il:|previous| il:|date:| "18-May-90 01:20:54" il:|{PELE:MV:ENVOS}SOURCES>XCLC-ALPHA.;2| -) + :edit-by "lmm" + :changes-to (il:functions alpha-compiler-let alpha-flet alpha-lambda alpha-let alpha-let* + alpha-macrolet alpha-progn alpha-setq alpha-tagbody completely-expand + expand-openlambda-call print-node) + + :previous-date "21-Mar-2024 10:27:05" il:|{DSK}larry>il>medley>sources>XCLC-ALPHA.;1|) -; Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (il:prettycomprint il:xclc-alphacoms) -(il:rpaqq il:xclc-alphacoms +(il:rpaqq il:xclc-alphacoms ( (il:* il:|;;;| "Alphatization") @@ -60,17 +62,17 @@ (il:specvars il:specvars) (il:localvars il:localvars) (il:globalvars il:globalvars)) - (declare (special *new-specials* *new-globals* *new-inlines* *new-notinlines* - il:specvars il:localvars il:globalvars)) - (process-declarations ,declarations) + (declare (special *new-specials* *new-globals* *new-inlines* *new-notinlines* il:specvars + il:localvars il:globalvars)) + (process-declarations ,declarations) ,@body)) -(defun process-declarations (decls) +(defun process-declarations (decls) (il:* il:\; "Edited 21-Mar-2024 10:26 by lmm") (il:* il:|;;;| "Step through the given declarations, storing the information found therein into various special variables.") (declare (special *new-specials* *new-globals* *new-inlines* *new-notinlines* il:specvars - il:localvars il:globalvars)) + il:localvars il:globalvars)) (flet ((check-var-1 (var) (cond ((symbolp var) @@ -124,7 +126,7 @@ "Illegal GLOBALVARS declaration: ~S" spec ))) ((type ftype function) (il:* il:\; - "We don't handle type declarations yet.") + "We don't handle type declarations yet.") nil) ((inline) (dolist (var (cdr spec)) (check-var var) @@ -132,13 +134,13 @@ ((notinline) (dolist (var (cdr spec)) (check-var var) (push var *new-notinlines*))) - ((ignore optimize) (il:* il:\; - "We don't handle IGNORE or OPTIMIZE declarations yet.") + ((ignore optimize ignorable) (il:* il:\; + "We don't handle IGNORE or OPTIMIZE declarations yet.") nil) ((declaration) (il:* il:\; "Add new declaration specifiers right away so that they can be used in later declarations in the same cluster. It's a picky point, but who cares?") (env-add-decls *environment* (cdr spec))) ((il:usedfree) (il:* il:\; - "Ignored Interlisp declarations") + "Ignored Interlisp declarations") nil) (otherwise (unless (or (eq (car spec) t) @@ -181,7 +183,7 @@ (setq il:globalvars (union il:globalvars (cdr spec))) (cerror "Ignore it" "Illegal GLOBALVARS declaration: ~S" spec))) ((il:usedfree) (il:* il:\; - "Ignored Interlisp declarations") + "Ignored Interlisp declarations") nil) (otherwise (return-from process-il-declarations nil)))))) @@ -243,7 +245,7 @@ (defun alpha-argument-form (form) (let ((*context* *argument-context*)) - (alpha-form form))) + (alpha-form form))) (defun alpha-atom (form) @@ -252,7 +254,7 @@ (if (or (not (symbolp form)) (eq form t) (eq form nil)) - (alpha-literal form) + (alpha-literal form) (resolve-variable-reference *environment* form))) (defun alpha-block (name body) @@ -260,13 +262,13 @@ (*block-stack* (cons (cons name new-block) *block-stack*))) (setf (block-stmt new-block) - (alpha-progn body)) + (alpha-progn body)) new-block)) (defun alpha-catch (tag forms) - (make-catch :tag (alpha-argument-form tag) + (make-catch :tag (alpha-argument-form tag) :stmt - (alpha-progn forms))) + (alpha-progn forms))) (defun alpha-combination (fn args) (declare (special il:nlama il:nlaml)) @@ -277,7 +279,7 @@ ((and (eq fn 'funcall) (not (env-inline-disallowed *environment* fn))) (multiple-value-bind (real-fn not-inline?) - (alpha-functional-form (first args)) + (alpha-functional-form (first args)) (make-call :fn real-fn :args (mapcar #'alpha-argument-form (rest args)) :not-inline not-inline?))) @@ -286,13 +288,13 @@ ((and (consp fn) (eq (first fn) 'il:openlambda)) - (alpha-form (expand-openlambda-call fn args))) + (alpha-form (expand-openlambda-call fn args))) (il:* il:|;;| "Lexical functions and non-symbol functions can't be NLambda's.") ((or (not (symbolp fn)) (env-fboundp *environment* fn)) - (make-call :fn (alpha-function fn *context*) + (make-call :fn (alpha-function fn *context*) :args (mapcar #'alpha-argument-form args) :not-inline @@ -300,21 +302,21 @@ (env-inline-disallowed *environment* fn)))) ((or (eq 3 (il:argtype fn)) (member fn il:nlama :test 'eq)) (il:* il:\; - "It's an NLambda no-spread. Funcall it on a single literal argument, the CDR of the form.") - (make-call :fn (alpha-function fn) + "It's an NLambda no-spread. Funcall it on a single literal argument, the CDR of the form.") + (make-call :fn (alpha-function fn) :args - (alpha-literal args) + (alpha-literal args) :not-inline (env-inline-disallowed *environment* fn))) ((or (eq 1 (il:argtype fn)) (member fn il:nlaml :test 'eq)) (il:* il:\; - "It's an NLambda spread. Funcall it on the quoted versions of its arguments.") - (make-call :fn (alpha-function fn) + "It's an NLambda spread. Funcall it on the quoted versions of its arguments.") + (make-call :fn (alpha-function fn) :args (mapcar #'alpha-literal args) :not-inline (env-inline-disallowed *environment* fn))) - (t (make-call :fn (alpha-function fn *context*) + (t (make-call :fn (alpha-function fn *context*) :args (mapcar #'alpha-argument-form args) :not-inline @@ -324,15 +326,15 @@ (let ((vars nil) (vals nil)) (il:for binding il:in bindings il:do (cond - ((consp binding) - (push (car binding) - vars) - (push (eval (cadr binding)) - vals)) - (t (push binding vars) - (push nil vals)))) + ((consp binding) + (push (car binding) + vars) + (push (eval (cadr binding)) + vals)) + (t (push binding vars) + (push nil vals)))) (progv vars vals - (alpha-progn body)))) + (alpha-progn body)))) (defun alpha-eval-when (times forms) @@ -343,7 +345,7 @@ (mapc #'eval forms)) (if (or (member 'load times :test #'eq) (member 'il:load times :test #'eq)) - (alpha-progn forms) + (alpha-progn forms) *literally-nil*)) (defun alpha-flet (bindings body) @@ -355,14 +357,14 @@ (multiple-value-bind (forms decls) (parse-body body *environment* nil) - (binding-contour + (binding-contour decls - (update-environment *environment*) + (update-environment *environment*) (let ((new-labels (make-labels)) names) (setq names (with-collection (setf (labels-funs new-labels) (mapcar #'(lambda (binding) - (unless (check-arg (car binding)) + (unless (check-arg (car binding)) (setq binding (cons '%lose% (cdr binding)) )) @@ -372,13 +374,12 @@ (symbol-name (car binding)) :scope :lexical :kind :function :binder new-labels) - (alpha-lambda - (binding-to-lambda binding) + (alpha-lambda + (binding-to-lambda binding) :name - (il:* il:|;;| -  - "Really want name to be \"Foo in Bar\"") + (il:* il:|;;| + "Really want name to be \"Foo in Bar\"") (symbol-name (car binding))))) bindings)))) @@ -390,7 +391,7 @@ (il:* il:|;;| "Now we can alphatize the body.") - (setf (labels-body new-labels (alpha-progn forms))) + (setf (labels-body new-labels (alpha-progn forms))) new-labels))))) (defun alpha-form (form) @@ -401,77 +402,77 @@ (il:* il:|;;;| "NOTE NOTE NOTE::: If anything is added to this CASE statement, be sure to add it also to the list in COMPLETELY-EXPAND.") (if (atom form) - (alpha-atom form) + (alpha-atom form) (case (car form) - ((block) (alpha-block (second form) + ((block) (alpha-block (second form) (cddr form))) - ((catch) (alpha-catch (second form) + ((catch) (alpha-catch (second form) (cddr form))) - ((compiler-let) (alpha-compiler-let (second form) + ((compiler-let) (alpha-compiler-let (second form) (cddr form))) ((declare) - (or (process-il-declarations (cdr form)) + (or (process-il-declarations (cdr form)) (cerror "Replace the declaration with NIL" "DECLARE found in executable position: ~S" form)) *literally-nil*) - ((eval-when) (alpha-eval-when (second form) + ((eval-when) (alpha-eval-when (second form) (cddr form))) - ((flet) (alpha-flet (second form) + ((flet) (alpha-flet (second form) (cddr form))) - ((il:function) (alpha-il-function (second form) + ((il:function) (alpha-il-function (second form) (third form))) - ((function) (alpha-function (second form))) - ((go) (alpha-go (second form))) - ((if) (alpha-if (second form) + ((function) (alpha-function (second form))) + ((go) (alpha-go (second form))) + ((if) (alpha-if (second form) (third form) (fourth form))) ((labels) (il:* il:\; - "Rely on the macro expansion for now.") - (return-from alpha-form (alpha-labels (second form) + "Rely on the macro expansion for now.") + (return-from alpha-form (alpha-labels (second form) (cddr form))) - (return-from alpha-form (alpha-form (optimize-and-macroexpand-1 form)))) - ((let) (alpha-let (second form) + (return-from alpha-form (alpha-form (optimize-and-macroexpand-1 form)))) + ((let) (alpha-let (second form) (cddr form))) - ((let*) (alpha-let* (second form) + ((let*) (alpha-let* (second form) (cddr form))) - ((macrolet si::%macrolet) (alpha-macrolet (second form) + ((macrolet si::%macrolet) (alpha-macrolet (second form) (cddr form))) - ((multiple-value-call) (alpha-mv-call (second form) + ((multiple-value-call) (alpha-mv-call (second form) (cddr form))) - ((multiple-value-prog1) (alpha-mv-prog1 (cdr form))) - ((progn) (alpha-progn (cdr form))) + ((multiple-value-prog1) (alpha-mv-prog1 (cdr form))) + ((progn) (alpha-progn (cdr form))) ((progv) (il:* il:\; - "Rely on the macro expansion for now.") + "Rely on the macro expansion for now.") (return-from alpha-form (destructuring-bind (vars-expr vals-expr . body) (cdr form) - (alpha-form `(il:\\do.progv ,vars-expr ,vals-expr + (alpha-form `(il:\\do.progv ,vars-expr ,vals-expr #'(lambda nil ,@body))))) - (alpha-progv (second form) + (alpha-progv (second form) (third form) (cdddr form))) - ((quote) (alpha-literal (second form))) - ((return-from) (alpha-return-from (second form) + ((quote) (alpha-literal (second form))) + ((return-from) (alpha-return-from (second form) (third form))) - ((setq il:setq) (alpha-setq (car form) + ((setq il:setq) (alpha-setq (car form) (rest form))) - ((tagbody) (alpha-tagbody (cdr form))) + ((tagbody) (alpha-tagbody (cdr form))) ((the) (il:* il:\; - "Ignore the THE construct for now.") - (alpha-form (third form))) - ((throw) (alpha-throw (second form) + "Ignore the THE construct for now.") + (alpha-form (third form))) + ((throw) (alpha-throw (second form) (third form))) - ((unwind-protect) (alpha-unwind-protect (second form) + ((unwind-protect) (alpha-unwind-protect (second form) (cddr form))) (otherwise (multiple-value-bind (new-form changed-p) (optimize-and-macroexpand-1 form) (if (null changed-p) - (alpha-combination (car form) + (alpha-combination (car form) (cdr form)) - (alpha-form new-form))))))) + (alpha-form new-form))))))) (defun alpha-function (form &optional (context (or (context-applied-context *context*) - *null-context*))) + *null-context*))) (il:* il:|;;;| "If it's a symbol, then turn this into either the FLET/LABELS-bound VARIABLE structure or a structure for the global symbol. Otherwise, it must be either a LAMBDA-form or OPCODES-form and is treated as such. Note that the internal representation of programs treats LAMBDA as a value-producing special form.") @@ -500,19 +501,19 @@ (when (not (null *current-block*)) (let ((lookup (assoc form (block-decl-fn-name-map *current-block*)))) (when (not (null lookup)) (il:* il:\; - "This function is to be renamed.") + "This function is to be renamed.") (setq form (cdr lookup))))) (check-for-unknown-function form) (values (make-reference-to-variable :name form :scope :global :kind :function) (env-inline-disallowed *environment* form)))))) (t (case (car form) - ((lambda il:lambda il:nlambda il:openlambda) (alpha-lambda form :context context)) + ((lambda il:lambda il:nlambda il:openlambda) (alpha-lambda form :context context)) ((il:opcodes :opcodes) (make-opcodes :bytes (cdr form))) (otherwise (cerror "Use (LAMBDA () NIL) instead" "The form ~S, appearing in a functional context, is neither a symbol nor a LAMBDA-form" form) - (alpha-lambda '(lambda nil nil) + (alpha-lambda '(lambda nil nil) :context context)))))) (defun alpha-functional-form (form) @@ -520,9 +521,9 @@ (or (eq 'quote (first form)) (eq 'il:function (first form))) (symbolp (second form))) - (alpha-function (second form)) + (alpha-function (second form)) (let ((*context* (make-context :values-used 1 :applied-context *context*))) - (alpha-form form)))) + (alpha-form form)))) (defun alpha-go (tag) (let ((dest (assoc tag *tagbody-stack*))) @@ -543,11 +544,11 @@ (defun alpha-if (pred-form then-form else-form) (make-if :pred (let ((*context* *predicate-context*)) - (alpha-form pred-form)) + (alpha-form pred-form)) :then - (alpha-form then-form) + (alpha-form then-form) :else - (alpha-form else-form))) + (alpha-form else-form))) (defun alpha-il-function (fn close-p-form) @@ -561,21 +562,21 @@ (not (null *current-block*))) (let ((lookup (assoc fn (block-decl-fn-name-map *current-block*)))) (when (not (null lookup)) (il:* il:\; - "This function is to be renamed.") + "This function is to be renamed.") (setq fn (cdr lookup))))) (if (null close-p-form) (cond ((and (symbolp fn) (not (env-fboundp *environment* fn))) (check-for-unknown-function fn) - (alpha-literal fn)) - (t (alpha-function fn))) + (alpha-literal fn)) + (t (alpha-function fn))) (make-call :fn (make-reference-to-variable :name 'il:function :scope :global :kind :function) :args (list (if (symbolp fn) - (alpha-literal fn) - (alpha-function fn)) - (alpha-literal close-p-form))))) + (alpha-literal fn) + (alpha-function fn)) + (alpha-literal close-p-form))))) (defun alpha-labels (bindings body) @@ -584,7 +585,7 @@ (let* ((*environment* (make-child-env *environment*)) (labels (make-labels)) (structs (mapcar #'(lambda (binding) - (unless (check-arg (car binding)) + (unless (check-arg (car binding)) (setq binding (cons '%lose% (cdr binding)))) (let ((struct (make-variable :name (symbol-name (car binding)) :scope :lexical :kind :function :binder @@ -595,30 +596,30 @@ bindings))) (multiple-value-bind (forms decls) (parse-body body *environment* nil) - (binding-contour decls (update-environment *environment*) + (binding-contour decls (update-environment *environment*) (setf (labels-funs labels) (mapcar #'(lambda (binding struct) - (cons struct (alpha-lambda (binding-to-lambda binding) + (cons struct (alpha-lambda (binding-to-lambda binding) :name (il:* il:|;;| - "Really want name to be \"Foo in Bar\"") + "Really want name to be \"Foo in Bar\"") (symbol-name (car binding))))) bindings structs)) (setf (labels-body labels) - (alpha-progn forms)))) + (alpha-progn forms)))) labels)) (defun alpha-lambda (original-form &key ((:context *context*) - *null-context*) - name) + *null-context*) + name) (il:* il:|;;| "Check for something other than a CL:LAMBDA and coerce if necessary.") (multiple-value-bind (form arg-type) - (convert-to-cl-lambda original-form) + (convert-to-cl-lambda original-form) (il:* il:|;;| "Crack the argument list, applying any declarations that might be present.") @@ -627,21 +628,21 @@ (*environment* (make-child-env *environment*))) (multiple-value-bind (code decls) (parse-body body *environment* t) - (binding-contour decls (il:* il:\; "Process the declarations") - (update-environment *environment*) + (binding-contour decls (il:* il:\; "Process the declarations") + (update-environment *environment*) (let* ((node (make-lambda :name name :arg-type arg-type)) - (auxes (alpha-lambda-list arg-list node)) - (body-node (alpha-progn code))) + (auxes (alpha-lambda-list arg-list node)) + (body-node (alpha-progn code))) (il:* il:|;;| "AUXES is now the list of values representing the &aux variables IN REVERSE ORDER. We must bind them around the body one-by-one and then wrap that in the lambda node we've already created.") (il:for aux il:in auxes il:do (let ((binder (make-lambda :required (list (car aux)) - :body body-node))) - (setf (variable-binder (car aux)) - binder) - (setq body-node (make-call :fn binder :args - (list (cdr aux)))))) + :body body-node))) + (setf (variable-binder (car aux)) + binder) + (setq body-node (make-call :fn binder :args + (list (cdr aux)))))) (setf (lambda-body node) body-node) @@ -668,13 +669,13 @@ (setq state :rest) (cerror "Ignore it." "Misplaced &rest in lambda-list"))) ((&ignore-rest) (il:* il:\; - "Internal keyword used in translation of Interlisp spread functions.") + "Internal keyword used in translation of Interlisp spread functions.") (assert (eq state :optional) nil "BUG: Misplaced &IGNORE-REST keyword.") (setf (lambda-rest binder) (make-variable :binder binder)) (return) (il:* il:\; - "Nothing is supposed to follow an &IGNORE-REST") + "Nothing is supposed to follow an &IGNORE-REST") ) ((&key) (if (and (il:neq state :aux) (il:neq state :key)) @@ -690,38 +691,38 @@ (cerror "Ignore it." "Misplaced &aux in lambda-list."))) (otherwise (ecase state - ((:required) (when (check-arg arg) - (push (bind-parameter arg binder *environment*) + ((:required) (when (check-arg arg) + (push (bind-parameter arg binder *environment*) required))) ((:optional) (if (atom arg) - (when (check-arg arg) - (push (list (bind-parameter arg binder *environment*) + (when (check-arg arg) + (push (list (bind-parameter arg binder *environment*) *literally-nil*) optional)) (destructuring-bind (var &optional (init-form nil) (svar nil sv-given)) arg - (when (check-arg var) - (let ((init-struct (alpha-argument-form init-form))) - (push `(,(bind-parameter var binder *environment*) + (when (check-arg var) + (let ((init-struct (alpha-argument-form init-form))) + (push `(,(bind-parameter var binder *environment*) ,init-struct - ,@(and sv-given (check-arg svar) - (list (bind-parameter svar binder *environment*))) + ,@(and sv-given (check-arg svar) + (list (bind-parameter svar binder *environment*))) ) optional)))))) - ((:rest) (when (check-arg arg) + ((:rest) (when (check-arg arg) (setf (lambda-rest binder) - (bind-parameter arg binder *environment*)) + (bind-parameter arg binder *environment*)) (setq state :after-rest))) ((:after-rest) (cerror "Ignore it." "Stray argument ~S found after &rest var.")) ((:key) (if (atom arg) - (when (check-arg arg) + (when (check-arg arg) (push (list (intern (string arg) "KEYWORD") - (bind-parameter arg binder *environment*) + (bind-parameter arg binder *environment*) *literally-nil*) keyword)) (destructuring-bind @@ -731,22 +732,22 @@ arg (cond ((atom key&var) - (when (check-arg key&var) + (when (check-arg key&var) (il:* il:|;;| -"This is not the real legality test; that's below. This just makes sure that the intern will work.") + "This is not the real legality test; that's below. This just makes sure that the intern will work.") (setq key (intern (string key&var) "KEYWORD"))) (setq var key&var)) (t (setq key (first key&var)) (setq var (second key&var)))) - (when (check-arg var) - (let ((init-struct (alpha-argument-form init-form))) - (push `(,key ,(bind-parameter var binder *environment*) + (when (check-arg var) + (let ((init-struct (alpha-argument-form init-form))) + (push `(,key ,(bind-parameter var binder *environment*) ,init-struct - ,@(and sv-given (check-arg svar) - (list (bind-parameter svar binder + ,@(and sv-given (check-arg svar) + (list (bind-parameter svar binder *environment*)))) keyword)))))) ((:aux) (let (var val) @@ -756,9 +757,9 @@ (setq val nil)) (t (setq var (first arg)) (setq val (second arg)))) - (when (check-arg var) - (let ((tree (alpha-argument-form val))) - (push (cons (bind-parameter var binder *environment*) + (when (check-arg var) + (let ((tree (alpha-argument-form val))) + (push (cons (bind-parameter var binder *environment*) tree) aux))))))))) (setf (lambda-required binder) @@ -775,11 +776,11 @@ (multiple-value-bind (body decls) (parse-body body *environment* nil) - (binding-contour decls (let ((*environment* (make-child-env *environment*))) + (binding-contour decls (let ((*environment* (make-child-env *environment*))) (il:* il:|;;| "The standard is losing and wants us to install the environment before alphatizing the init-forms so that SPECIAL declarations will have bigger scope. Ugh.") - (update-environment *environment*) + (update-environment *environment*) (let ((vars nil) (vals nil) (new-lambda (make-lambda))) @@ -788,30 +789,27 @@ (il:for binding il:in bindings il:do (cond - ((consp binding) - (push (first binding) - vars) - (push (alpha-argument-form (second - binding - )) - vals)) - (t (push binding vars) - (push *literally-nil* vals)))) + ((consp binding) + (push (first binding) + vars) + (push (alpha-argument-form (second binding)) + vals)) + (t (push binding vars) + (push *literally-nil* vals)))) (il:* il:|;;| "Bind all of the variables") (setf (lambda-required new-lambda) (il:for var il:in (nreverse vars) - il:collect (bind-parameter - (if (check-arg var) - var - '%lose%) - new-lambda *environment*))) + il:collect (bind-parameter (if (check-arg var) + var + '%lose%) + new-lambda *environment*))) (il:* il:|;;| "Alphatize the body") (setf (lambda-body new-lambda) - (alpha-progn body)) + (alpha-progn body)) (make-call :fn new-lambda :args (nreverse vals))))))) (defun alpha-let* (bindings body) @@ -821,39 +819,39 @@ (multiple-value-bind (body decls) (parse-body body *environment* nil) - (binding-contour + (binding-contour decls (let ((*environment* (make-child-env *environment*)) (binding-list nil)) - (update-environment *environment*) + (update-environment *environment*) (il:* il:|;;| "First, alphatize each of the init-forms in the correct environment.") (il:for binding il:in bindings il:do (if (consp binding) - (let ((init-struct (alpha-argument-form (second binding)))) - (push (cons (bind-parameter (if (check-arg (first binding)) - (first binding) - '%lose%) - nil *environment*) - init-struct) - binding-list)) - (push (cons (bind-parameter (if (check-arg binding) - binding - '%lose%) - nil *environment*) - *literally-nil*) - binding-list))) + (let ((init-struct (alpha-argument-form (second binding)))) + (push (cons (bind-parameter (if (check-arg (first binding)) + (first binding) + '%lose%) + nil *environment*) + init-struct) + binding-list)) + (push (cons (bind-parameter (if (check-arg binding) + binding + '%lose%) + nil *environment*) + *literally-nil*) + binding-list))) (il:* il:|;;| -"BINDING-LIST is now in reverse order, so we can construct the nested lambdas from the inside out.") + "BINDING-LIST is now in reverse order, so we can construct the nested lambdas from the inside out.") - (il:bind (body-struct il:_ (alpha-progn body)) il:for pair il:in binding-list + (il:bind (body-struct il:_ (alpha-progn body)) il:for pair il:in binding-list il:do (let ((binder (make-lambda :required (list (car pair)) - :body body-struct))) - (setq body-struct (make-call :fn binder :args (list (cdr pair)))) - (setf (variable-binder (car pair)) - binder)) il:finally (return body-struct)))))) + :body body-struct))) + (setq body-struct (make-call :fn binder :args (list (cdr pair)))) + (setf (variable-binder (car pair)) + binder)) il:finally (return body-struct)))))) (defun alpha-literal (value) @@ -883,30 +881,29 @@ (let ((new-env (make-child-env *environment*))) (il:for macro il:in bindings il:do (env-bind-function new-env (car macro) - :macro - (crack-defmacro (cons 'defmacro macro)) - )) + :macro + (crack-defmacro (cons 'defmacro macro)))) (let ((*environment* new-env)) (multiple-value-bind (forms decls) (parse-body body *environment* nil) - (binding-contour decls (update-environment *environment*) - (alpha-progn forms)))))) + (binding-contour decls (update-environment *environment*) + (alpha-progn forms)))))) (defun alpha-mv-call (fn-form arg-forms) (let (values-used) (multiple-value-bind (fn not-inline?) - (alpha-functional-form fn-form) + (alpha-functional-form fn-form) (cond ((and (null (cdr arg-forms)) (lambda-p fn) (not (or (lambda-optional fn) (lambda-rest fn) (lambda-keyword fn)))) (il:* il:\; - "In this very common case, we can tell how many values are expected.") + "In this very common case, we can tell how many values are expected.") (setq values-used (length (lambda-required fn)))) (t (setq values-used :unknown))) (if (null arg-forms) (il:* il:\; - "This is silly, but we'd better handle it correctly.") + "This is silly, but we'd better handle it correctly.") (make-call :fn fn :args nil :not-inline not-inline?) (make-mv-call :fn fn :arg-exprs (let ((*context* (make-context :values-used values-used))) @@ -917,32 +914,32 @@ (let ((vals-used (context-values-used *context*))) (cond ((null (cdr forms)) - (alpha-form (car forms))) + (alpha-form (car forms))) ((and (numberp vals-used) (< vals-used 2)) (il:* il:\; - "The multiple values aren't wanted. Make this a normal PROG1.") - (alpha-form (cons 'prog1 forms))) - (t (make-mv-prog1 :stmts (cons (alpha-form (first forms)) + "The multiple values aren't wanted. Make this a normal PROG1.") + (alpha-form (cons 'prog1 forms))) + (t (make-mv-prog1 :stmts (cons (alpha-form (first forms)) (let ((*context* *effect-context*)) (mapcar #'alpha-form (rest forms))))))))) (defun alpha-progn (forms) (if (null (cdr forms)) - (alpha-form (car forms)) + (alpha-form (car forms)) (make-progn :stmts (let ((old-context *context*) (*context* *effect-context*)) (il:for tail il:on forms il:collect (if (null (cdr tail)) - (let ((*context* old-context)) - (alpha-form (car tail))) - (alpha-form (car tail)))))))) + (let ((*context* old-context)) + (alpha-form (car tail))) + (alpha-form (car tail)))))))) (defun alpha-progv (syms-expr vals-expr body-forms) - (make-progv :syms-expr (alpha-argument-form syms-expr) + (make-progv :syms-expr (alpha-argument-form syms-expr) :vals-expr - (alpha-argument-form vals-expr) + (alpha-argument-form vals-expr) :stmt - (alpha-progn body-forms))) + (alpha-progn body-forms))) (defun alpha-return-from (name form) (let ((dest (assoc name *block-stack*))) @@ -951,7 +948,7 @@ ((null *block-stack*) (cerror "Treat (RETURN-FROM name value-form) as simply value-form" "~S, found in a RETURN-FROM, is not the name of any enclosing BLOCK" name) - (return-from alpha-return-from (alpha-form form))) + (return-from alpha-return-from (alpha-form form))) (t (cerror "Use the name ~*~S instead" "~S, found in a RETURN-FROM, is not the name of any enclosing BLOCK" name (caar *block-stack*)) @@ -959,18 +956,18 @@ (make-return :block (cdr dest) :value (let ((*context* (block-context (cdr dest)))) - (alpha-form form))))) + (alpha-form form))))) (defun alpha-setq (kind forms) (let ((setqs (il:for tail il:on forms il:by (cddr tail) il:collect (when (and (eq kind 'setq) - (null (cdr tail))) - (cerror "Add an extra NIL on the end of the form" - "Odd number of forms given to SETQ.")) + (null (cdr tail))) + (cerror "Add an extra NIL on the end of the form" + "Odd number of forms given to SETQ.")) (make-setq :var (resolve-variable-reference *environment* (car tail) t) :value - (alpha-argument-form (cadr tail)))))) + (alpha-argument-form (cadr tail)))))) (if (null (cdr setqs)) (car setqs) (make-progn :stmts setqs)))) @@ -987,11 +984,10 @@ (il:* il:|;;| "Make a first pass down the body to find all of the tags") (il:for form il:in body il:do (when (atom form) - (push (cons form tagbody) - *tagbody-stack*))) + (push (cons form tagbody) + *tagbody-stack*))) - (il:* il:|;;| - "On the second pass, put together the segments and alphatize all of the forms") + (il:* il:|;;| "On the second pass, put together the segments and alphatize all of the forms") (do ((*context* *effect-context*) (segment-list nil)) @@ -1009,25 +1005,25 @@ (atom (car body))) (setf (segment-stmts segment) (nreverse form-list))) - (push (alpha-form (pop body)) + (push (alpha-form (pop body)) form-list)) (push segment segment-list))) tagbody)) (defun alpha-throw (tag value) - (make-throw :tag (alpha-argument-form tag) + (make-throw :tag (alpha-argument-form tag) :value (let ((*context* *null-context*)) - (alpha-form value)))) + (alpha-form value)))) (defun alpha-unwind-protect (body cleanups) - (make-unwind-protect :stmt (alpha-lambda (let ((cleanup-var (gensym))) + (make-unwind-protect :stmt (alpha-lambda (let ((cleanup-var (gensym))) `(lambda (,cleanup-var) (multiple-value-prog1 ,body (funcall ,cleanup-var)))) :context *context* :name 'si::*unwind-protect*) :cleanup - (alpha-lambda `(lambda nil ,@cleanups) + (alpha-lambda `(lambda nil ,@cleanups) :context *effect-context* :name "Clean-up forms"))) (defun convert-to-cl-lambda (form) @@ -1061,7 +1057,7 @@ ((il:nlambda) (if (listp (second form)) (il:* il:|;;| - "NLAMBDA spread. Just like the LAMBDA-spread case but we have a different ARG-TYPE.") + "NLAMBDA spread. Just like the LAMBDA-spread case but we have a different ARG-TYPE.") (values `(lambda (&optional ,@(second form) &ignore-rest) @@ -1069,7 +1065,7 @@ 1) (il:* il:|;;| - "NLAMBDA no-spread. We take exactly one argument and are otherwise entirely normal.") + "NLAMBDA no-spread. We take exactly one argument and are otherwise entirely normal.") (values `(lambda (,(second form)) ,@(cddr form)) @@ -1089,43 +1085,40 @@ (let ((new-form form) changed-p) (il:until (member (car new-form) - '(block catch - compiler-let - declare - eval-when - flet - il:function - function - go - if - labels - let - let* - macrolet - si::%macrolet - multiple-value-call - multiple-value-prog1 - progn - progv - quote - setq - il:setq - tagbody - the - throw - unwind-protect) - :test - 'eq) il:do (multiple-value-setq (new-form changed-p) - (optimize-and-macroexpand-1 new-form)) - (when (null changed-p) - (if (and (consp (car new-form)) - (eq 'il:openlambda (caar new-form))) - (setq new-form (expand-openlambda-call - (car new-form) - (cdr new-form))) - (return new-form))) il:finally (return - new-form - ))))) + '(block catch + compiler-let + declare + eval-when + flet + il:function + function + go + if + labels + let + let* + macrolet + si::%macrolet + multiple-value-call + multiple-value-prog1 + progn + progv + quote + setq + il:setq + tagbody + the + throw + unwind-protect) + :test + 'eq) il:do (multiple-value-setq (new-form changed-p) + (optimize-and-macroexpand-1 new-form)) + (when (null changed-p) + (if (and (consp (car new-form)) + (eq 'il:openlambda (caar new-form))) + (setq new-form (expand-openlambda-call (car new-form) + (cdr new-form))) + (return new-form))) il:finally (return new-form))))) (defun expand-openlambda-call (fn args) @@ -1150,7 +1143,7 @@ (setq extra-args args)) (il:* il:|;;| - "For each pair, if the argument is a constant, add it to the substitution we'll later apply.") + "For each pair, if the argument is a constant, add it to the substitution we'll later apply.") (cond ((or (constantp arg) @@ -1166,8 +1159,7 @@ (t (push (car params) unsubbed-params) (push arg unsubbed-args)))) - (when (null unsubbed-args) (il:* il:\; - "We got rid of all of them.") + (when (null unsubbed-args) (il:* il:\; "We got rid of all of them.") (return-from expand-openlambda-call `(progn ,@extra-args ,@(sublis subst-alist (cddr fn) :test @@ -1200,8 +1192,8 @@ (il:while (and unsubbed-args (symbolp (first unsubbed-args))) il:do (push (cons (pop unsubbed-params) - (pop unsubbed-args)) - subst-alist)) + (pop unsubbed-args)) + subst-alist)) (cond ((null unsubbed-args) (il:* il:\; "All substituted in.") `(progn ,@(sublis subst-alist (cddr fn) @@ -1253,9 +1245,9 @@ "Used by the parse-tree pretty-printer") (defun test-alpha (fn) - (let ((tree (test-alpha-2 fn))) + (let ((tree (test-alpha-2 fn))) (unwind-protect - (print-tree tree) + (print-tree tree) (release-tree tree)))) (defun test-alpha-2 (fn) @@ -1271,12 +1263,12 @@ (*current-function* nil) (*automatic-special-declarations* nil)) (declare (special il:specvars il:localvars il:localfreevars il:globalvars)) - (alpha-lambda (cond + (alpha-lambda (cond ((consp fn) fn) ((consp (il:getd fn)) (il:getd fn)) - (t (parse-defun (il:getdef fn 'il:functions))))))) + (t (parse-defun (il:getdef fn 'il:functions))))))) (defun parse-defun (form) (destructuring-bind (ignore name arg-list &body body) @@ -1289,7 +1281,7 @@ (let ((*node-hash* (make-hash-table)) (*node-number* 0) (*print-case* :upcase)) - (print-node tree 0)) + (print-node tree 0)) (terpri) (values)) @@ -1318,73 +1310,73 @@ (prin1 (block-name node)) (print-blipper-info) (new-line) - (print-node (block-stmt node) + (print-node (block-stmt node) nested-indent)) (call-node (when (caller-not-inline node) (princ "(not inline)")) (new-line) (princ "Func: ") - (print-node (call-fn node) + (print-node (call-fn node) (+ nested-indent 6)) (when (call-args node) (new-line) (princ "Args: ") (il:for arg-tail il:on (call-args node) - il:do (print-node (car arg-tail) - (+ nested-indent 6)) + il:do (print-node (car arg-tail) + (+ nested-indent 6)) (when (not (null (cdr arg-tail))) (new-line 6))))) (catch-node (new-line) (princ "Tag: ") - (print-node (catch-tag node) + (print-node (catch-tag node) (+ nested-indent 6)) (new-line) (princ "Stmt: ") - (print-node (catch-stmt node) + (print-node (catch-stmt node) (+ nested-indent 6))) (go-node (format t "to ~S" (go-tag node)) (new-line) (princ "Tagbody: ") - (print-node (go-tagbody node) + (print-node (go-tagbody node) (+ nested-indent 9))) (if-node (new-line) (princ "Pred: ") - (print-node (if-pred node) + (print-node (if-pred node) (+ nested-indent 6)) (new-line) (princ "Then: ") - (print-node (if-then node) + (print-node (if-then node) (+ nested-indent 6)) (new-line) (princ "Else: ") - (print-node (if-else node) + (print-node (if-else node) (+ nested-indent 6))) (labels-node (new-line) (princ "Funs: ") (il:for tail il:on (labels-funs node) - il:do (print-node (caar tail) - (+ nested-indent 6)) + il:do (print-node (caar tail) + (+ nested-indent 6)) (new-line 10) - (print-node (cdar tail) + (print-node (cdar tail) (+ nested-indent 10)) (when (not (null (cdr tail))) (new-line 6))) (new-line) (princ "Body: ") - (print-node (labels-body node) + (print-node (labels-body node) (+ nested-indent 6))) (lambda-node (new-line) (when (lambda-required node) (princ "&req: ") (il:for vars il:on (lambda-required node) - il:do (print-node (car vars) - (+ nested-indent 6)) + il:do (print-node (car vars) + (+ nested-indent 6)) (if (null (cdr vars)) (new-line) (new-line 6)))) @@ -1392,49 +1384,48 @@ (princ "&opt: ") (il:for vars il:on (lambda-optional node) il:do (destructuring-bind (var &optional (init nil i-given) - (svar nil sv-given)) - (car vars) - (cond - ((symbolp var) - (print-node (car vars) - (+ nested-indent 6))) - ((not i-given) - (print-node var (+ nested-indent 6))) - (t (princ "(") - (print-node var (+ nested-indent 7)) - (new-line 7) - (print-node init (+ nested-indent 7)) - (new-line 7) - (when sv-given - (print-node svar (+ nested-indent 7)) - (new-line 7)) - (princ ")")))) + (svar nil sv-given)) + (car vars) + (cond + ((symbolp var) + (print-node (car vars) + (+ nested-indent 6))) + ((not i-given) + (print-node var (+ nested-indent 6))) + (t (princ "(") + (print-node var (+ nested-indent 7)) + (new-line 7) + (print-node init (+ nested-indent 7)) + (new-line 7) + (when sv-given + (print-node svar (+ nested-indent 7)) + (new-line 7)) + (princ ")")))) (if (null (cdr vars)) (new-line) (new-line 6)))) (when (lambda-rest node) (princ "&rest: ") - (print-node (lambda-rest node) + (print-node (lambda-rest node) (+ nested-indent 7)) (new-line)) (when (lambda-keyword node) (princ "&key: ") (il:for vars il:on (lambda-keyword node) - il:do (destructuring-bind (key var &optional (init nil - i-given) - (svar nil sv-given)) - (car vars) - (format t "((~S " key) - (new-line 8) - (print-node var (+ nested-indent 8)) - (princ ")") - (new-line 7) - (print-node init (+ nested-indent 7)) - (new-line 7) - (when sv-given - (print-node svar (+ nested-indent 7)) - (new-line 7)) - (princ ")")) + il:do (destructuring-bind (key var &optional (init nil i-given) + (svar nil sv-given)) + (car vars) + (format t "((~S " key) + (new-line 8) + (print-node var (+ nested-indent 8)) + (princ ")") + (new-line 7) + (print-node init (+ nested-indent 7)) + (new-line 7) + (when sv-given + (print-node svar (+ nested-indent 7)) + (new-line 7)) + (princ ")")) (cond ((null (cdr vars)) (when (lambda-allow-other-keys node) @@ -1445,12 +1436,12 @@ (princ "Closed-over:") (new-line 10) (il:for vars il:on (lambda-closed-over-vars node) - il:do (print-node (car vars) - (+ nested-indent 10)) + il:do (print-node (car vars) + (+ nested-indent 10)) (if (null (cdr vars)) (new-line) (new-line 10)))) - (print-node (lambda-body node) + (print-node (lambda-body node) nested-indent)) (literal-node (prin1 (literal-value node))) (mv-call-node @@ -1458,79 +1449,79 @@ (princ "(not inline)")) (new-line) (princ "Func: ") - (print-node (mv-call-fn node) + (print-node (mv-call-fn node) (+ nested-indent 6)) (new-line) (princ "Args: ") (il:for arg-tail il:on (mv-call-arg-exprs node) - il:do (print-node (car arg-tail) - (+ nested-indent 6)) + il:do (print-node (car arg-tail) + (+ nested-indent 6)) (when (not (null (cdr arg-tail))) (new-line 6)))) (mv-prog1-node (il:for stmt il:in (mv-prog1-stmts node) il:do (new-line) - (print-node stmt nested-indent))) + (print-node stmt nested-indent))) (opcodes-node (prin1 (opcodes-bytes node))) (progn-node (il:for stmt il:in (progn-stmts node) il:do (new-line) - (print-node stmt nested-indent))) + (print-node stmt nested-indent))) (progv-node (new-line) (princ "Vars: ") - (print-node (progv-syms-expr node) + (print-node (progv-syms-expr node) (+ nested-indent 6)) (new-line) (princ "Vals: ") - (print-node (progv-vals-expr node) + (print-node (progv-vals-expr node) (+ nested-indent 6)) (new-line) (princ "Body: ") - (print-node (progv-stmt node) + (print-node (progv-stmt node) (+ nested-indent 6))) (return-node (new-line) (princ "From: ") - (print-node (return-block node) + (print-node (return-block node) (+ nested-indent 7)) (new-line) (princ "Value: ") - (print-node (return-value node) + (print-node (return-value node) (+ nested-indent 7))) (setq-node (new-line) (princ "Var: ") - (print-node (setq-var node) + (print-node (setq-var node) (+ nested-indent 7)) (new-line) (princ "Value: ") - (print-node (setq-value node) + (print-node (setq-value node) (+ nested-indent 7))) (tagbody-node (print-blipper-info) (il:for segment il:in (tagbody-segments node) il:do (il:for tag il:in (segment-tags segment) - il:do (new-line) - (princ tag)) + il:do (new-line) + (princ tag)) (il:for stmt il:in (segment-stmts segment) il:do (new-line 4) - (print-node stmt (+ nested-indent 4))))) + (print-node stmt (+ nested-indent 4))))) (throw-node (new-line) (princ "Tag: ") - (print-node (throw-tag node) + (print-node (throw-tag node) (+ nested-indent 7)) (new-line) (princ "Value: ") - (print-node (throw-value node) + (print-node (throw-value node) (+ nested-indent 7))) (unwind-protect-node (new-line) (princ "Stmt: ") - (print-node (unwind-protect-stmt node) + (print-node (unwind-protect-stmt node) (+ nested-indent 9)) (new-line) (princ "Cleanup: ") - (print-node (unwind-protect-cleanup node) + (print-node (unwind-protect-cleanup node) (+ nested-indent 9))) ((or variable-struct var-ref-node) (let ((var (if (variable-p node) @@ -1545,39 +1536,39 @@ ((gethash (variable-binder var) *node-hash*) (princ "Binder: ") - (print-node (variable-binder var) + (print-node (variable-binder var) 0)) (t (new-line) (princ "Binder: ") - (print-node (variable-binder var) + (print-node (variable-binder var) (+ nested-indent 8)))))))))))))) (defparameter context-test-form - '(progn (ctxt) - (list (if (ctxt) - (ctxt)) - (multiple-value-list (ctxt)) + '(progn (ctxt) + (list (if (ctxt) + (ctxt)) + (multiple-value-list (ctxt)) (multiple-value-call #'(lambda (a b) (bar a b)) - (ctxt)) + (ctxt)) (multiple-value-call #'(lambda (a &rest b) (bar a b)) - (ctxt)) + (ctxt)) (multiple-value-call #'(lambda (a b) (bar a b)) - (ctxt) - (ctxt)) - (let ((x (ctxt))) - (setq x (ctxt))) - ((lambda (a &optional (b (ctxt))) - (ctxt)) - (ctxt)) + (ctxt) + (ctxt)) + (let ((x (ctxt))) + (setq x (ctxt))) + ((lambda (a &optional (b (ctxt))) + (ctxt)) + (ctxt)) (multiple-value-call #'(lambda (a b) (bar a b)) ((lambda (c) - (ctxt)) + (ctxt)) 17))) - (ctxt)) + (ctxt)) "Form for testing the alphatizer's manipulation of context information.") (defmacro ctxt () @@ -1588,17 +1579,36 @@ (il:* il:|;;| "Arrange to use the correct compiler.") -(il:putprops il:xclc-alpha il:filetype compile-file) +(il:putprops il:xclc-alpha il:filetype compile-file) (il:* il:|;;| "Arrange for the correct makefile environment") -(il:putprops il:xclc-alpha il:makefile-environment (:readtable "XCL" :package - (defpackage "COMPILER" (:use "LISP" - "XCL")))) -(il:putprops il:xclc-alpha il:copyright ("Venue & Xerox Corporation" 1986 1987 1988 1990)) +(il:putprops il:xclc-alpha il:makefile-environment (:readtable "XCL" :package (defpackage + "COMPILER" + (:use "LISP" "XCL")))) (il:declare\: il:dontcopy - (il:filemap (nil))) + (il:filemap (nil (2233 3038 (binding-contour 2233 . 3038)) (3040 8964 (process-declarations 3040 . +8964)) (8966 11026 (process-il-declarations 8966 . 11026)) (11028 11535 (update-environment 11028 . +11535)) (11537 12140 (bind-parameter 11537 . 12140)) (12142 12502 (check-arg 12142 . 12502)) (12504 +12928 (binding-to-lambda 12504 . 12928)) (13256 13366 (alpha-argument-form 13256 . 13366)) (13368 +13692 (alpha-atom 13368 . 13692)) (13694 13992 (alpha-block 13694 . 13992)) (13994 14130 (alpha-catch +13994 . 14130)) (14132 16373 (alpha-combination 14132 . 16373)) (16375 17062 (alpha-compiler-let 16375 + . 17062)) (17064 17553 (alpha-eval-when 17064 . 17553)) (17555 20327 (alpha-flet 17555 . 20327)) ( +20329 24486 (alpha-form 20329 . 24486)) (24488 27220 (alpha-function 24488 . 27220)) (27222 27574 ( +alpha-functional-form 27222 . 27574)) (27576 28406 (alpha-go 27576 . 28406)) (28408 28675 (alpha-if +28408 . 28675)) (28677 30009 (alpha-il-function 28677 . 30009)) (30011 32028 (alpha-labels 30011 . +32028)) (32030 34370 (alpha-lambda 32030 . 34370)) (34372 40922 (alpha-lambda-list 34372 . 40922)) ( +40924 43514 (alpha-let 40924 . 43514)) (43516 45751 (alpha-let* 43516 . 45751)) (45753 47296 ( +alpha-literal 45753 . 47296)) (47298 48049 (alpha-macrolet 47298 . 48049)) (48051 49316 (alpha-mv-call + 48051 . 49316)) (49318 50004 (alpha-mv-prog1 49318 . 50004)) (50006 50597 (alpha-progn 50006 . 50597) +) (50599 50840 (alpha-progv 50599 . 50840)) (50842 51682 (alpha-return-from 50842 . 51682)) (51684 +52433 (alpha-setq 51684 . 52433)) (52435 53970 (alpha-tagbody 52435 . 53970)) (53972 54158 ( +alpha-throw 53972 . 54158)) (54160 54759 (alpha-unwind-protect 54160 . 54759)) (54761 57418 ( +convert-to-cl-lambda 54761 . 57418)) (57420 59389 (completely-expand 57420 . 59389)) (59391 65540 ( +expand-openlambda-call 59391 . 65540)) (65879 66037 (test-alpha 65879 . 66037)) (66039 66836 ( +test-alpha-2 66039 . 66836)) (66838 67095 (parse-defun 66838 . 67095)) (67097 67284 (print-tree 67097 + . 67284)) (67286 82651 (print-node 67286 . 82651)) (83840 83893 (ctxt 83840 . 83893))))) il:stop diff --git a/sources/XCLC-ALPHA.DFASL b/sources/XCLC-ALPHA.DFASL new file mode 100644 index 00000000..f1110203 Binary files /dev/null and b/sources/XCLC-ALPHA.DFASL differ diff --git a/sources/XCLC-ALPHA.LCOM b/sources/XCLC-ALPHA.LCOM deleted file mode 100644 index 7ddacd78..00000000 Binary files a/sources/XCLC-ALPHA.LCOM and /dev/null differ