From 8c82e9a24f17ff9754e74484d51db2fb0dfe418e Mon Sep 17 00:00:00 2001
From: Kris Katterjohn <katterjohn@gmail.com>
Date: Sun, 10 Oct 2021 16:32:11 -0400
Subject: [PATCH] Fix bug #2837: ev causes bogus WNA checks for sum, product,
 define and ":"

MEVALATOMS assumed that the correct number of args were present in
sum, product, define and MSETQ forms.  NIL would be passed for any
missing args and any extra args were ignored.

Now we check the number of args in MEVALATOMS.

No problems with the test suite or share test suite.  New tests have
been added to rtest2 and rtestsum.
---
 src/mlisp.lisp     |  2 ++
 src/testsuite.lisp |  2 +-
 tests/rtest2.mac   | 24 +++++++++++++++++++
 tests/rtestsum.mac | 70 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
 4 files changed, 97 insertions(+), 1 deletion(-)

diff --git a/src/mlisp.lisp b/src/mlisp.lisp
index 1e715abed..e5b5bab37 100644
--- a/src/mlisp.lisp
+++ b/src/mlisp.lisp
@@ -1067,6 +1067,7 @@ wrapper for this."
 	       exp1)))
 	((eq (caar exp) 'mquote) (cadr exp))
 	((member (caar exp) '(msetq $define) :test #'eq)
+	 (twoargcheck exp)
 	 (list (car exp) (cadr exp) (mevalatoms (caddr exp))))
 	((or (and (eq (caar exp) '$ev)
 		  (cdr exp)
@@ -1074,6 +1075,7 @@ wrapper for this."
 	     (eq (caar exp) 'mprogn))
 	 (cons (car exp) (cons (mevalatoms (cadr exp)) (cddr exp))))
 	((member (caar exp) '($sum $product %sum %product) :test #'eq)
+	 (arg-count-check 4 exp)
 	 (if msump
 	     (meval exp)
 	     (list (car exp) (cadr exp) (caddr exp)
diff --git a/src/testsuite.lisp b/src/testsuite.lisp
index 64fa35b69..f583d85a5 100644
--- a/src/testsuite.lisp
+++ b/src/testsuite.lisp
@@ -84,7 +84,7 @@
                 ((mlist simp) 16 17 40 52 53 57 97 109))
         "rtestconjugate"
         ((mlist simp) "rtestsum"
-	 ((mlist simp) 3 4 18 75))
+	 ((mlist simp) 23 24 38 95))
 	;; Tested with acl 10.1
 	((mlist simp) "rtest_trig"
 	 #+allegro ((mlist simp) 58))
diff --git a/tests/rtest2.mac b/tests/rtest2.mac
index e595bc2fe..1bd0dd0f8 100644
--- a/tests/rtest2.mac
+++ b/tests/rtest2.mac
@@ -676,6 +676,30 @@ errcatch (block ([x, x], x))$
 errcatch (block ([x, x:foo], x))$
 [];
 
+/* Verify some WNA checks
+ *
+ * The ev tests are significant.  Previously missing args were
+ * effectively replaced with false and extra args were ignored.
+ */
+
+errcatch (define ());
+[];
+
+errcatch (ev (define ()));
+[];
+
+errcatch (define (f (x)));
+[];
+
+errcatch (ev (define (f (x))));
+[];
+
+errcatch (define (f (x), foo, bar, baz));
+[];
+
+errcatch (ev (define (f (x), foo, bar, baz)));
+[];
+
 /* try to verify that save(...) handles arrays correctly */
 
 (kill (all),
diff --git a/tests/rtestsum.mac b/tests/rtestsum.mac
index 033963d96..e3542c8dd 100644
--- a/tests/rtestsum.mac
+++ b/tests/rtestsum.mac
@@ -4,6 +4,76 @@ done;
 (assume_pos_save: assume_pos, assume_pos: true);
 true;
 
+/* Verify that we at least get errors when passing the wrong number
+ * of arguments to sum and product.
+ *
+ * The ev tests are significant.  In the 2 and 3 arg cases, we used
+ * to get bogus results.  In the case of more than 4 args, the extra
+ * args used to be effectively ignored.  (In the 0 and 1 arg cases,
+ * we got obscure error messages about assigning to false.  The tests
+ * below don't do any checking about *why* we got an error.)
+ */
+
+errcatch (sum ());
+[];
+
+errcatch (ev (sum ()));
+[];
+
+errcatch (sum (f (x)));
+[];
+
+errcatch (ev (sum (f (x))));
+[];
+
+errcatch (sum (f (x), x));
+[];
+
+errcatch (ev (sum (f (x), x)));
+[];
+
+errcatch (sum (f (x), x, 0));
+[];
+
+errcatch (ev (sum (f (x), x, 0)));
+[];
+
+errcatch (sum (f (x), x, 0, 1, 2));
+[];
+
+errcatch (ev (sum (f (x), x, 0, 1, 2)));
+[];
+
+errcatch (product ());
+[];
+
+errcatch (ev (product ()));
+[];
+
+errcatch (product (f (x)));
+[];
+
+errcatch (ev (product (f (x))));
+[];
+
+errcatch (product (f (x), x));
+[];
+
+errcatch (ev (product (f (x), x)));
+[];
+
+errcatch (product (f (x), x, 1));
+[];
+
+errcatch (ev (product (f (x), x, 1)));
+[];
+
+errcatch (product (f (x), x, 1, 2, 3));
+[];
+
+errcatch (ev (product (f (x), x, 1, 2, 3)));
+[];
+
 /* Known failure: concat (q, k) => gensym
  */
 sum (concat (q, k), k, a, b);
-- 
2.11.4.GIT