[Maxima-commits] [git] Maxima CAS branch dodier-iterate-over-hash-tables created. branch-5_48-base-298-g89d7b7a46

[<ap...@us...>]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "Maxima CAS".

The branch, dodier-iterate-over-hash-tables has been created
        at  89d7b7a46acdb7e1fcbfd52cffe422958aa826d7 (commit)

- Log -----------------------------------------------------------------
commit 89d7b7a46acdb7e1fcbfd52cffe422958aa826d7
Author: Robert Dodier <rob...@so...>
Date:   Fri Nov 28 21:17:11 2025 -0800

    Extend "for" loop syntax to iterate over hash tables.
    
    The basic syntax is: for [k, v] in hh do ...
    where hh is a undeclared array, "fast" array (i.e., a hash table created
    with use_fast_arrays: true), or created by make_array(hashed, ...).
    
    [k, v] is a key/value pair. The pairs are processed in the order
    of keys as returned by arrayinfo.
    
    k is always a list, even if the hash table has only one key
    and therefore the list has exactly one element.
    
    Destructuring assignment is recognized, e.g.:
    
      for [[k], v] in hh1 do ...
      for [[k1, k2], v] in hh2 do ...
      for [[k1, k2, k3], v] in hh3 do ...
    
    where hh1, hh2, and hh3 are hash tables which have,
    respectively, one, two, and three keys.
    
    Destructuring assignment also applies to the existing loop syntax
    for iterating over lists, e.g.:
    
      for [x, y] in [[11, 12], [13, 9], [19, 29]] do ...
    
    This is a freebie -- it would be more work to apply destructuring
    assignment only to hash tables, so I let it stand.
    
    There is one bug of which I'm aware: when destructuring assignment is
    applied and one of the loop variables is restricted by an ASSIGN helper
    to non-symbol values (e.g., linel, which has an ASSIGN helper to
    restrict assigned values to integers), *and* the variable is unbound
    in the Lisp sense (i.e., BOUNDP returns NIL) before starting the
    iteration, then there is an error at the end of the iteration.
    
    From what I can tell, there are no such variables in Maxima, and it's
    not easy to create one. Such a variable can be created by Lisp
    programming (to create an assignment helper and attach it via the
    ASSIGN property), or the following Maxima incantation:
    
      define_variable (foo, 1111, integer);
      remvalue (foo);
    
    foo has an ASSIGN property (created by define_variable) and it is
    unbound by remvalue. Now the following loop triggers the bug:
    
      for [foo] in [[11], [22], [33]] do print (foo);
    
    From reading the reference manual, it appears that mode_declare plus
    mode_checkp, and followed by remvalue, might also work, although it
    appears mode_checkp has no effect, from what I can tell.
    
    I will devote time to fixing the bug, but it seems like a not too
    serious problem, given the obscurity of the way to trigger it.

diff --git a/src/mlisp.lisp b/src/mlisp.lisp
index e9a0bcdc0..8bdf53d20 100644
--- a/src/mlisp.lisp
+++ b/src/mlisp.lisp
@@ -448,6 +448,18 @@ is EQ to FNNAME if the latter is non-NIL."
 ;; option variable $errormsg is used as a local variable in a block.
 (defvar *$errormsg-value* nil)
 
+(defun symbol-values-in (expr)
+  (if (atom expr)
+    (if (symbolp expr)
+      (if (boundp expr)
+        ;; Do not take the actual value of $errormsg. It is
+        ;; always NIL at this point, but the value which
+        ;; is stored in *$errormsg-value*.
+        (if (eq expr '$errormsg) *$errormsg-value* (symbol-value expr))
+        munbound)
+      expr)
+    (cons (car expr) (mapcar 'symbol-values-in (cdr expr)))))
+
 (defun mbind-doit (lamvars fnargs fnname)
   "Makes a new frame where the variables in the list LAMVARS are bound
 to the corresponding elements in FNARGS.  Note that these elements are
@@ -471,16 +483,9 @@ wrapper for this."
 			    (cons (ncons fnname) lamvars))
 			(cons '(mlist) fnargs)))))
     (let ((var (car vars)))
-      (if (not (symbolp var))
+      (when (not (every 'symbolp (cdr ($listofvars var))))
 	  (merror (intl:gettext "Only symbols can be bound; found: ~M") var))
-      (let ((value (if (boundp var)
-                       (if (eq var '$errormsg)
-                           ;; Do not take the actual value of $errormsg. It is
-                           ;; always NIL at this point, but the value which
-                           ;; is stored in *$errormsg-value*.
-                           *$errormsg-value*
-                           (symbol-value var))
-                       munbound)))
+      (let ((value (symbol-values-in var)))
 	(mset var (car args))
 	(psetq bindlist (cons var bindlist)
 	       mspeclist (cons value mspeclist))))))
@@ -493,7 +498,7 @@ wrapper for this."
         ;; At this point store the value of $errormsg in a global. The macro
         ;; with-$error sets the value of $errormsg to NIL, but we need the
         ;; actual value in the routine mbind-doit.
-        (setq *$errormsg-value* $errormsg)
+        (setq *$errormsg-value* (if (boundp '$errormsg) $errormsg munbound))
 	(unwind-protect
 	     (prog1
 		 (with-$error (mbind-doit lamvars fnargs fnname))
@@ -522,13 +527,33 @@ wrapper for this."
   (finish-output)
   (values))
 
+(defun munbind-makunbound (var)
+  (makunbound var)
+  (setf $values (delete var $values :count 1 :test #'eq)))
+
 (defun munbind (vars)
-  (dolist (var (reverse vars))
-    (cond ((eq (car mspeclist) munbound)
-	   (makunbound var)
-	   (setf $values (delete var $values :count 1 :test #'eq)))
-	  (t (let ((munbindp t)) (mset var (car mspeclist)))))
-    (setq mspeclist (cdr mspeclist) bindlist (cdr bindlist))))
+  (let ((foo))
+    (dolist (var (reverse vars))
+      ;; This is a bit of a mess. We should avoid assigning MUNBOUND
+      ;; and instead call MUNBIND-MAKUNBOUND, because some variables
+      ;; cannot be assigned MUNBOUND due to declarations or custom setters.
+      ;; It is easy to detect these cases when VAR is just a symbol,
+      ;; but I don't see a straightforward way to handle it when VAR is
+      ;; a nonatomic expression, so the code for the non-symbol branch
+      ;; will fail if the expression contains a symbol for which
+      ;; MUNBOUND cannot be assigned.
+      (if (symbolp var)
+        (if (eq (car mspeclist) munbound)
+          (munbind-makunbound var)
+          (mset var (car mspeclist)))
+        (progn
+          (let ((munbindp t))
+            (mset var (car mspeclist)))
+          (mapcar (lambda (x) (push x foo)) (cdr ($listofvars var)))))
+      (setq mspeclist (cdr mspeclist) bindlist (cdr bindlist)))
+    (dolist (var foo)
+      (when (and (boundp var) (eq (symbol-value var) munbound))
+        (munbind-makunbound var)))))
 
 ;;This takes the place of something like
 ;; (DELETE (ASSOC (NCONS VAR) $DEPENDENCIES) $DEPENDENCIES 1)
@@ -2229,11 +2254,31 @@ wrapper for this."
                        (merror (intl:gettext "do loop: illegal 'return': ~M") (car val)))
                       (t (return (car val))))))))
 
+(defun key-value-pairs-given-key-lists (x key-lists)
+  (mapcar (lambda (l) (list '(mlist) l (mfuncall '$arrayapply x l))) key-lists))
+
+(defun key-value-pairs-for-hashed-array (x)
+  (let*
+    ((1-d-hash-table (gethash 'dim1 x))
+     (info (mfuncall '$arrayinfo x))
+     (keys-raw (cdddr info))
+     (key-lists (if 1-d-hash-table (mapcar (lambda (y) (cons '(mlist) (list y))) keys-raw) keys-raw)))
+    (key-value-pairs-given-key-lists x key-lists)))
+
+(defun key-value-pairs-for-undeclared-array (x)
+  (let*
+    ((info (mfuncall '$arrayinfo x))
+     (key-lists (cdddr info)))
+    (key-value-pairs-given-key-lists x key-lists)))
+
 (defmspec mdoin (form)
   (setq form (cdr form))
   (funcall #'(lambda  (mdop my-var set test action)
 	       (setq set (if ($atom (setq set (format1 (meval (cadr form)))))
-			     (merror (intl:gettext "do loop: 'in' argument must be a nonatomic expression; found: ~M") set)
+			     (cond
+			       ((hash-table-p set) (key-value-pairs-for-hashed-array set))
+			       ((safe-mget set 'hashar) (key-value-pairs-for-undeclared-array set))
+			       (t (merror (intl:gettext "do loop: atomic 'in' argument must be a hashed or undeclared array; found: ~M") set)))
 			     (margs set))
 		     test (list '(mor)
 				(if (car (cddddr form))
diff --git a/tests/rtest6.mac b/tests/rtest6.mac
index ac4fe99c1..531dad995 100644
--- a/tests/rtest6.mac
+++ b/tests/rtest6.mac
@@ -228,3 +228,370 @@ chain weld bucket;
 
 subst (f = "foo", f(x));
 foo(x);
+
+/* tests for iterating over hash tables
+ * verify both value hash tables ("fast arrays" or created by make_array)
+ * and named hash tables ("undeclared arrays").
+ */
+
+kill (all);
+done;
+
+/* value hash tables: "fast arrays" */
+
+use_fast_arrays: true;
+true;
+
+/* one key */
+
+(aa1["baz"]: 333, aa1["bar"]: 222, aa1["quux"]: 444, aa1["foo"]: 111, 0);
+0;
+
+?hash\-table\-p (aa1);
+true;
+
+a: 100;
+100;
+
+block ([L: []], for [a, b] in aa1 do push ([b, a], L), sort (L));
+[[111, ["foo"]], [222, ["bar"]], [333, ["baz"]], [444, ["quux"]]];
+
+[a, b];
+[100, b];
+
+block ([L: []], for [[a], b] in aa1 do push ([b, a], L), sort (L));
+[[111, "foo"], [222, "bar"], [333, "baz"], [444, "quux"]];
+
+[a, b];
+[100, b];
+
+/* two keys */
+
+(aa2[xx, 99]: %pi, aa2[cc, 1099]: %phi, aa2[jj, 543]: %e, 0);
+0;
+
+?hash\-table\-p (aa2);
+true;
+
+block ([L: []], for [a, b] in aa2 do push ([b, a], L), sort (L));
+[[%e, [jj, 543]], [%phi, [cc, 1099]], [%pi, [xx, 99]]];
+
+[a, b];
+[100, b];
+
+(a2: 300, b: -2);
+-2;
+
+block ([L: []], for [[a1, a2], b] in aa2 do push ([b, a2, a1], L), sort (L));
+[[%e, 543, jj], [%phi, 1099, cc], [%pi, 99, xx]];
+
+[a1, a2, b];
+[a1, 300, -2];
+
+/* three keys */
+
+(aa3["mno", "pqr", 1 - 2*u]: bessel_j (2, 1 - sqrt(x)),
+ aa3["fgh", 3*u*v, giraffe]: rhino*elephant,
+ aa3["glorble", 7*x, emu]: 6/cricket,
+ 0);
+0;
+
+?hash\-table\-p (aa3);
+true;
+
+[b, a];
+[-2, 100];
+
+block ([L: []], for [b, a] in aa3 do push ([b, a], L), sort (L));
+[[["fgh", 3*u*v, giraffe], rhino*elephant],
+ [["glorble", 7*x, emu], 6/cricket],
+ [["mno", "pqr", 1 - 2*u], bessel_j (2, 1 - sqrt(x))]];
+
+[b, a];
+[-2, 100];
+
+block ([L: []], for [[a1, a2, b], a] in aa3 do push ([a1, a2, b, a], L), sort (L));
+[["fgh", 3*u*v, giraffe, rhino*elephant],
+ ["glorble", 7*x, emu, 6/cricket],
+ ["mno", "pqr", 1 - 2*u, bessel_j (2, 1 - sqrt(x))]];
+
+[a1, a2, b, a];
+[a1, 300, -2, 100];
+
+arrays;
+[];
+
+(reset (use_fast_arrays), kill (all));
+done;
+
+/* value hash tables: created by make_array */
+
+/* one key */
+
+(hh1: make_array (hashed, 1), 0);
+0;
+
+?hash\-table\-p (hh1);
+true;
+
+(hh1[1 + x]: sin(z), hh1[3 - y]: cos(w), hh1[1/(1 + z)]: tan(x), 0);
+0;
+
+(f: 199, g: 200);
+200;
+
+block ([L: []], for [f, g] in hh1 do push ([g, f], L), sort (L));
+[[cos(w), [3 - y]], [tan(x), [1/(1 + z)]], [sin(z), [1 + x]]];
+
+[f, g];
+[199, 200];
+
+block ([L: []], for [[f], g] in hh1 do push ([g, f], L), sort (L));
+[[cos(w), 3 - y], [tan(x), 1/(1 + z)], [sin(z), 1 + x]];
+
+[f, g];
+[199, 200];
+
+/* two keys */
+
+(hh2: make_array (hashed, 1, 1), 0);
+0;
+
+?hash\-table\-p (hh2);
+true;
+
+(hh2[678, "blurf"]: 876 - mumble,
+ hh2[987, "sdf"]: 777*zxy,
+ hh2[456, cos(w)]: sin(u) - cos(v),
+ 0);
+0;
+
+block ([L: []], for [x, y] in hh2 do push ([x, y], L), sort (L));
+[[[456, cos(w)], sin(u) - cos(v)],
+ [[678, "blurf"], 876 - mumble],
+ [[987, "sdf"], 777*zxy]];
+
+[x, y];
+[x, y];
+
+block ([L: []], for [[x1, x2], y] in hh2 do push ([x1, x2, y], L), sort (L));
+[[456, cos(w), sin(u) - cos(v)],
+ [678, "blurf", 876 - mumble],
+ [987, "sdf", 777*zxy]];
+
+[x1, x2, y];
+[x1, x2, y];
+
+/* three keys */
+
+(hh3: make_array (hashed, 1, 1, 1), 0);
+0;
+
+?hash\-table\-p (hh3);
+true;
+
+(hh3[hgf, fds, jhg]: cos(trwq),
+ hh3[asdfg, 1 - rewq, 2*treww]: sin(poiur) - cos(kjghds),
+ hh3[ewq, 2 - jdssaaq, 3*cxmmz]: sqrt(ytre),
+ 0);
+0;
+
+block ([L: []], for [p, q] in hh3 do push ([p, q], L), sort (L));
+[[[asdfg, 1 - rewq, 2*treww], sin(poiur) - cos(kjghds)],
+ [[ewq, 2 - jdssaaq, 3*cxmmz], sqrt(ytre)],
+ [[hgf, fds, jhg], cos(trwq)]];
+
+[p, q];
+[p, q];
+
+block ([L: []], for [[p1, p2, p3], q] in hh3 do push ([p1, p2, p3, q], L), sort (L));
+[[asdfg, 1 - rewq, 2*treww, sin(poiur) - cos(kjghds)],
+ [ewq, 2 - jdssaaq, 3*cxmmz, sqrt(ytre)],
+ [hgf, fds, jhg, cos(trwq)]];
+
+[p1, p2, p3, q];
+[p1, p2, p3, q];
+
+arrays;
+[];
+
+kill (all);
+done;
+
+/* named hash tables: "undeclared arrays" */
+
+/* one key */
+
+(bb1["mumble"]: 123, bb1["blarf"]: 234, bb1["blurf"]: 999, bb1["blarg"]: 345, 0);
+0;
+
+?hash\-table\-p (bb1);
+false;
+
+arrays;
+[bb1];
+
+block ([L: []], for [u, v] in bb1 do push ([v, u], L), sort (L));
+[[123, ["mumble"]], [234, ["blarf"]], [345, ["blarg"]], [999, ["blurf"]]];
+
+[u, v];
+[u, v];
+
+block ([L: []], for [[u], v] in bb1 do push ([v, u], L), sort (L));
+[[123, "mumble"], [234, "blarf"], [345, "blarg"], [999, "blurf"]];
+
+[u, v];
+[u, v];
+
+/* two keys */
+
+(bb2["pqr", 1 + %pi]: sin(k*%pi), bb2["zxy", 2*%pi]: cos(m*%pi), bb2["hgfedc", 3 - blurf]: tan(n*%pi), 0);
+0;
+
+arrays;
+[bb1, bb2];
+
+w: 321;
+321;
+
+block ([L: []], for [v, w] in bb2 do push ([v, w], L), sort (L));
+[[["hgfedc", 3 - blurf], tan(n*%pi)], [["pqr", 1 + %pi], sin(k*%pi)], [["zxy", 2*%pi], cos(m*%pi)]];
+
+[v, w];
+[v, 321];
+
+v2: 432;
+432;
+
+block ([L: []], for [[v1, v2], w] in bb2 do push ([v1, v2, w], L), sort (L));
+[["hgfedc", 3 - blurf, tan(n*%pi)], ["pqr", 1 + %pi, sin(k*%pi)], ["zxy", 2*%pi, cos(m*%pi)]];
+
+[v1,v2, w];
+[v1, 432, 321];
+
+/* three keys */
+
+(bb3[zxy, "blah", cos(a) + cos(b)]: tan(a + b),
+ bb3[hjk, "mumble", cos(y) - x]: cot(a - b),
+ bb3[uvw, "qwerty", foo(z) + q]: sec(2*b - a),
+ 0);
+0;
+
+arrays;
+[bb1, bb2, bb3];
+
+block ([L: []], for [w, v] in bb3 do push ([w, v], L), sort (L));
+[[[hjk, "mumble", cos(y) - x], cot(a - b)],
+ [[uvw, "qwerty", foo(z) + q], sec(2*b - a)],
+ [[zxy, "blah", cos(a) + cos(b)], tan(a + b)]];
+
+[w, v];
+[321, v];
+
+block ([L: []], for [[v1, v2, w], v] in bb3 do push ([v1, v2, w, v], L), sort (L));
+[[hjk, "mumble", cos(y) - x, cot(a - b)],
+ [uvw, "qwerty", foo(z) + q, sec(2*b - a)],
+ [zxy, "blah", cos(a) + cos(b), tan(a + b)]];
+
+
+[v1, v2, w, v];
+[v1, 432, 321, v];
+
+/* additional tests for MUNBIND */
+
+kill (all);
+done;
+
+(a: "foo", b: "bar", c: "baz", 0);
+0;
+
+(blurf (a, b, c, d, e, f) := (a + b + c)*(d + e + f),
+ blurf (1, 2, 3, 4, 5, 6));
+90;
+
+[a, b, c, d, e, f];
+["foo", "bar", "baz", d, e, f];
+
+(x1: 123,
+ mumble (a, b, [L]) := (a + b) * lsum (x1, x1, L),
+ mumble (7, 8, 9, 10, 11));
+450;
+
+[a, b, L, x1];
+["foo", "bar", L, 123];
+
+(harrumph (b, 'c, d) := b*c*d,
+ harrumph (111, x1, %pi));
+111*x1*%pi;
+
+[b, c, d];
+["bar", "baz", d];
+
+(blarg[x, b] := x^b,
+ blarg[1 - u, 1 - k]);
+(1 - u)^(1 - k);
+
+[b, x];
+["bar", x];
+
+(y: 999,
+ hurfgh[c](x, y) := (x + y)*c,
+ hurfgh[n](4, 2*w));
+n*(2*w + 4);
+
+[c, x, y];
+["baz", x, 999];
+
+block ([L: []], for b: 10 thru 20 do push (b, L), L);
+[20, 19, 18, 17, 16, 15, 14, 13, 12, 11, 10];
+
+[L, b];
+[L, "bar"];
+
+sum (b^2, b, 3, 5);
+50;
+
+b;
+"bar";
+
+product (c/2, c, 6, 8);
+42;
+
+c;
+"baz";
+
+'sum (b^2, b, 3, 5);
+'sum (b^2, b, 3, 5);
+
+b;
+"bar";
+
+'product (c/2, c, 6, 8);
+'product (c/2, c, 6, 8);
+
+c;
+"baz";
+
+block ([d, c, b, a: 111], b: 2, c: 3, a*b*c*d);
+666*d;
+
+[a, b, c, d];
+["foo", "bar", "baz", d];
+
+lambda ([c, f, g, b], (c + f)*(g + b))(x1, 1 - u, %e, %pi);
+(124 - u)*(%e + %pi);
+
+[b, c, f, g];
+["bar", "baz", f, g];
+
+lambda ([a,'b], a^b)(11, x1);
+11^x1;
+
+[a, b, x1];
+["foo", "bar", 123];
+
+lambda ([a,b,[c]], lsum(c1^2, c1, c)^(a^b))(%pi, %e, x1, y, u);
+(u^2  + 1013130)^(%pi^%e);
+
+[a, b, c, c1];
+["foo", "bar", "baz", c1];

-----------------------------------------------------------------------


hooks/post-receive
-- 
Maxima CAS