Fix multiple Calc defmath errors (bug#46750)

Fix incorrect variable scoping in `let*`, `for` and `foreach`.
Fix loop variable value in `foreach` (should be element, not tail).
Fix function quoting, as in ('cons x y) -- didn't work at all.

Reported by Stephan Neuhaus.

* lisp/calc/calc-prog.el (math-define-exp, math-handle-foreach):
* test/lisp/calc/calc-tests.el: (var-g, test1, test2, test3, test4)
(test5, test6, test7, calc-defmath): Test various defmath forms.

2 files changed, 114 insertions, 27 deletions

diff --git a/lisp/calc/calc-prog.el b/lisp/calc/calc-prog.el
index 3097b09b013..dd221457f83 100644
--- a/lisp/calc/calc-prog.el
+++ b/lisp/calc/calc-prog.el
@@ -1985,22 +1985,37 @@ Redefine the corresponding command."
                       (cons 'quote
                             (math-define-lambda (nth 1 exp) math-exp-env))
                     exp))
-                 ((memq func '(let let* for foreach))
-                  (let ((head (nth 1 exp))
-                        (body (cdr (cdr exp))))
-                    (if (memq func '(let let*))
-                        ()
-                      (setq func (cdr (assq func '((for . math-for)
-                                                   (foreach . math-foreach)))))
-                      (if (not (listp (car head)))
-                          (setq head (list head))))
-                    (macroexpand
-                     (cons func
-                           (cons (math-define-let head)
-                                 (math-define-body body
-                                                   (nconc
-                                                    (math-define-let-env head)
-                                                    math-exp-env)))))))
+                 ((eq func 'let)
+                  (let ((bindings (nth 1 exp))
+                        (body (cddr exp)))
+                    `(let ,(math-define-let bindings)
+                       ,@(math-define-body
+                          body (append (math-define-let-env bindings)
+                                       math-exp-env)))))
+                 ((eq func 'let*)
+                  ;; Rewrite in terms of `let'.
+                  (let ((bindings (nth 1 exp))
+                        (body (cddr exp)))
+                    (math-define-exp
+                     (if (> (length bindings) 1)
+                         `(let ,(list (car bindings))
+                            (let* ,(cdr bindings) ,@body))
+                       `(let ,bindings ,@body)))))
+                 ((memq func '(for foreach))
+                  (let ((bindings (nth 1 exp))
+                        (body (cddr exp)))
+                    (if (> (length bindings) 1)
+                        ;; Rewrite as nested loops.
+                        (math-define-exp
+                         `(,func ,(list (car bindings))
+                                 (,func ,(cdr bindings) ,@body)))
+                      (let ((mac (cdr (assq func '((for . math-for)
+                                                   (foreach . math-foreach))))))
+                        (macroexpand
+                         `(,mac ,(math-define-let bindings)
+                                ,@(math-define-body
+                                   body (append (math-define-let-env bindings)
+                                                math-exp-env))))))))
                  ((and (memq func '(setq setf))
                        (math-complicated-lhs (cdr exp)))
                   (if (> (length exp) 3)
@@ -2017,7 +2032,7 @@ Redefine the corresponding command."
                         (math-define-cond (cdr exp))))
                  ((and (consp func)   ; ('spam a b) == force use of plain spam
                        (eq (car func) 'quote))
-                  (cons func (math-define-list (cdr exp))))
+                  (cons (cadr func) (math-define-list (cdr exp))))
                  ((symbolp func)
                   (let ((args (math-define-list (cdr exp)))
                         (prim (assq func math-prim-funcs)))
@@ -2276,20 +2291,16 @@ Redefine the corresponding command."
 
 (defun math-handle-foreach (head body)
   (let ((var (nth 0 (car head)))
+        (loop-var (gensym "foreach"))
         (data (nth 1 (car head)))
         (body (if (cdr head)
                   (list (math-handle-foreach (cdr head) body))
                 body)))
-    (cons 'let
-          (cons (list (list var data))
-                (list
-                 (cons 'while
-                       (cons var
-                             (append body
-                                     (list (list 'setq
-                                                 var
-                                                 (list 'cdr var)))))))))))
-
+    `(let ((,loop-var ,data))
+       (while ,loop-var
+         (let ((,var (car ,loop-var)))
+           ,@(append body
+                     `((setq ,loop-var (cdr ,loop-var)))))))))
 
 (defun math-body-refers-to (body thing)
   (or (equal body thing)
diff --git a/test/lisp/calc/calc-tests.el b/test/lisp/calc/calc-tests.el
index bdcf78e020a..c5aa5a31eb2 100644
--- a/test/lisp/calc/calc-tests.el
+++ b/test/lisp/calc/calc-tests.el
@@ -707,6 +707,82 @@ An existing calc stack is reused, otherwise a new one is created."
                             (var c var-c))))))
     (calc-set-language nil)))
 
+(defvar var-g)
+
+;; Test `let'.
+(defmath test1 (x)
+  (let ((x (+ x 1))
+        (y (+ x 3)))
+    (let ((z (+ y 6)))
+      (* x y z g))))
+
+;; Test `let*'.
+(defmath test2 (x)
+  (let* ((y (+ x 1))
+         (z (+ y 3)))
+    (let* ((u (+ z 6)))
+      (* x y z u g))))
+
+;; Test `for'.
+(defmath test3 (x)
+  (let ((s 0))
+    (for ((ii 1 x)
+          (jj 1 ii))
+      (setq s (+ s (* ii jj))))
+    s))
+
+;; Test `for' with non-unit stride.
+(defmath test4 (x)
+  (let ((l nil))
+    (for ((ii 1 x 1)
+          (jj 1 10 ii))
+      (setq l ('cons jj l)))       ; Use Lisp `cons', not `calcFunc-cons'.
+    (reverse l)))
+
+;; Test `foreach'.
+(defmath test5 (x)
+  (let ((s 0))
+    (foreach ((a x)
+              (b a))
+      (setq s (+ s b)))
+    s))
+
+;; Test `break'.
+(defmath test6 (x)
+  (let ((a (for ((ii 1 10))
+             (when (= ii x)
+               (break (* ii 2)))))
+        (b (foreach ((e '(9 3 6)))
+             (when (= e x)
+               (break (- e 1))))))
+    (* a b)))
+
+;; Test `return' from `for'.
+(defmath test7 (x)
+  (for ((ii 1 10))
+    (when (= ii x)
+      (return (* ii 2))))
+  5)
+
+(ert-deftest calc-defmath ()
+  (let ((var-g 17))
+    (should (equal (calcFunc-test1 2) (* 3 5 11 17)))
+    (should (equal (calcFunc-test2 2) (* 2 3 6 12 17))))
+  (should (equal (calcFunc-test3 3)
+                 (+ (* 1 1)
+                    (* 2 1) (* 2 2)
+                    (* 3 1) (* 3 2) (* 3 3))))
+  (should (equal (calcFunc-test4 5)
+                 '( 1 2 3 4 5 6 7 8 9 10
+                    1 3 5 7 9
+                    1 4 7 10
+                    1 5 9
+                    1 6)))
+  (should (equal (calcFunc-test5 '((2 3) (5) (7 11 13)))
+                 (+ 2 3 5 7 11 13)))
+  (should (equal (calcFunc-test6 3) (* (* 3 2) (- 3 1))))
+  (should (equal (calcFunc-test7 3) (* 3 2))))
+
 (provide 'calc-tests)
 ;;; calc-tests.el ends here