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.

diff --git a/lisp/calc/calc-prog.el b/lisp/calc/calc-prog.el
index 3097b09b01328ada290e22a6bf1acf1b7a193dc8..dd221457f83e5c6f5064d9f55a11dca1296d0cc9 100644 (file)
--- 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 bdcf78e020a9eb3344e7b2729eba7c2f111bd537..c5aa5a31eb20bf040491adaa49164e0c611528e4 100644 (file)
--- 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