(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