From: Mattias Engdegård <mattiase@acm.org>
Date: Mon, 1 Mar 2021 19:52:39 +0000 (+0100)
Subject: Fix multiple Calc defmath errors (bug#46750)
X-Git-Tag: emacs-28.0.90~3470
X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=08b11a02f49da5ca0e4e58a32fa853df0c5e0214;p=emacs.git

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