Add support for cl: loop for hash tables (#1605)

* Add support for cl: loop for hash tables
* fix subtle package problems setting up LISP package & conflicts with CLOS
* include fix for 'repeat n' clause
* remake in lower-case p make diffs legible, dfasl for defuns

Author: masinter

clos/clos-env.DFASL

@@ -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)

clos/clos-env.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}<usr>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*)

clos/pkg.dfasl

@@ -1,13 +1,13 @@
 (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
 
-
(FILECREATED "14-Mar-2024 12:16:33" |{DSK}<home>larry>il>medley>internal>loadups>LOADUP-LISP.;2|
 5426   
+
(FILECREATED "21-Mar-2024 10:56:13" |{DSK}<home>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}<home>larry>il>medley>internal>loadups>LOADUP-LISP.;1|)
+      :PREVIOUS-DATE "14-Mar-2024 12:16:33" 
+|{DSK}<home>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

clos/pkg.lisp

@@ -1,12 +1,12 @@
 (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
 
-
(FILECREATED "16-Mar-2024 08:28:55" |{DSK}<home>larry>il>medley>sources>PACKAGE-STARTUP.;2|
 36546  
+
(FILECREATED "21-Mar-2024 10:21:14" |{DSK}<home>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}<home>larry>il>medley>sources>PACKAGE-STARTUP.;1|
+      :PREVIOUS-DATE "20-Mar-2024 23:34:56" |{DSK}<home>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

internal/loadups/LOADUP-LISP

@@ -0,0 +1,102 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+
+
(FILECREATED "21-Mar-2024 13:31:40" {DSK}<home>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}<home>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