From 59adc2c4c793b2a8c62f7e8a628e2817e56ff8e9 Mon Sep 17 00:00:00 2001 From: Kris Katterjohn Date: Thu, 18 Jul 2024 12:45:56 -0400 Subject: [PATCH] MFUNCTION-CALL: fix incorrect number of argument evaluations These are very old Maxima bugs (present in 5.0) that were not present in Macsyma. MFUNCTION-CALL-AUX has been receiving a list of unevaluated args and a list of the corresponding evaluated args. Presumably the idea is that the args will be evaluated once before function entry, so MFUNCTION-CALL-AUX wouldn't need to EVAL args itself when, say, applying a lisp function or Maxima lambda expression. The old MFUNCTION-CALL-AUX in Macsyma wasn't like that; it would only receive a list of unevaluated args and it would EVAL them itself when necessary. One problem with the Maxima approach is that the args are always evaluated, even when evaluation should be controlled by the Maxima special form, mfexpr or lisp macro we are MFUNCTION-CALLing: (%i1) tr_warn_bad_function_calls : false$ (%i2) foo () := bar (print (0), print (1))$ (%i3) bar ('x, 'y) := 123$ (%i4) foo (); (%o4) 123 (%i5) translate (foo)$ (%i6) foo (); /* wrong */ 0 1 (%o6) 123 or (%i1) foo () := bar (print (0), print (1))$ (%i2) translate (foo)$ (%i3) :lisp (defmspec $bar (x) (declare (ignore x)) 123) # (%i3) foo (); /* wrong */ 0 1 (%o3) 123 (%i4) transrun : false$ (%i5) foo (); (%o5) 123 And what received evaluated or unevaluated args was inconsistent: Maxima special forms and mfexprs would receive the unevaluated args (after they were already evaluated separately), but the case of lisp macros has been totally bogus because they would receive the already evaluated args! Another problem has been with bound vars: when applying the value of a var to args, the args were being re-evaluated: (%i1) tr_warn_bad_function_calls : false$ (%i2) foo () := block ([n : 0], bar (print (n : n + 1)))$ (%i3) bar : lambda ([x], x)$ (%i4) foo (); 1 (%o4) 1 (%i5) translate (foo)$ (%i6) foo (); /* wrong */ 1 2 (%o6) 2 Now MFUNCTION-CALL-AUX handles arg evaluations itself, much like it used to in Macsyma. No problems with the test suite, share test suite or rtest_translator. New tests have been added to rtest_translator. --- src/fcall.lisp | 15 +++---- src/transq.lisp | 3 +- tests/rtest_translator.mac | 104 +++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 112 insertions(+), 10 deletions(-) diff --git a/src/fcall.lisp b/src/fcall.lisp index 8671ffe87..52c3e6225 100644 --- a/src/fcall.lisp +++ b/src/fcall.lisp @@ -73,14 +73,14 @@ ;;loses if the argl could not be evaluated but macsyma "e functions ;;but the translator should be fixed so that if (mget f 'mfexprp) is t ;;then it doesn't translate as an mfunction-call. - `(mfunction-call-aux ',f ',argl (list ,@ argl) nil))) + `(mfunction-call-aux ',f ',argl nil))) -(defun mfunction-call-aux (f argl list-argl autoloaded-already? &aux f-prop) +(defun mfunction-call-aux (f argl autoloaded-already? &aux f-prop) (cond ((functionp f) - (apply f list-argl)) + (apply f (mapcar-eval argl))) ((macro-function f) (mfunction-call-warn f 'macro) - (eval (cons f list-argl))) + (eval (cons f argl))) ((not (symbolp f)) (merror (intl:gettext "apply: expected symbol or function; found: ~M") f)) ((setq f-prop (get f 'mfexpr*)) (funcall f-prop (cons nil argl))) @@ -89,20 +89,19 @@ (mfunction-call-warn f 'mfexpr) (meval (cons (list f) argl))) (t - (mlambda f-prop list-argl f t nil)))) + (mlambda f-prop (mapcar-eval argl) f t nil)))) ((setq f-prop (get f 'autoload)) (cond (autoloaded-already? (merror (intl:gettext "apply: function ~:@M undefined after loading file ~A") f (namestring (get f 'autoload)))) (t (funcall autoload (cons f f-prop)) - (mfunction-call-aux f argl list-argl t)))) - + (mfunction-call-aux f argl t)))) ((boundp f) (mfunction-call-warn f 'punt-nil) (mapply (eval f) (mapcar-eval argl) f)) (t (mfunction-call-warn f 'undefined) - `((,f) ,@ list-argl)))) + `((,f) ,@(mapcar-eval argl))))) (defquote trd-msymeval (&rest l) (let ((a-var? (car l))) diff --git a/src/transq.lisp b/src/transq.lisp index 7931557e2..534fc3e39 100644 --- a/src/transq.lisp +++ b/src/transq.lisp @@ -37,8 +37,7 @@ (get f 'once-translated) (get f 'translated)) (cons f l1)) - (t `(mfunction-call-aux ',f ', l1 (list ,@ l1) nil)))) - + (t `(mfunction-call-aux ',f ',l1 nil)))) ;;; macros for compiled environments. diff --git a/tests/rtest_translator.mac b/tests/rtest_translator.mac index 9276f70c4..4f7a9d6c8 100644 --- a/tests/rtest_translator.mac +++ b/tests/rtest_translator.mac @@ -3229,6 +3229,110 @@ true; (kill (foo), 0); 0; +/* We had cases of incorrect number of argument evaluations when going + * through MFUNCTION-CALL internally. + */ + +(eval_string_lisp (" + (makunbound '$bar) + (fmakunbound '$bar) + (setf (symbol-plist '$bar) '())"), + 0); +0; + +block ([translate : false, v1, v2], + foo () := block ([n : 0], bar (n : n + 1)), + + v1 : foo (), + + translate_or_lose (foo), + + v2 : foo (), + + [v2, is (v1 = v2)]); +[bar (1), true]; + +(kill (foo), 0); +0; + +block ([translate : false, v1, v2], + local (bar), + + foo () := block ([n : 0], bar (n : n + 1)), + + bar (q) := q, + + v1 : foo (), + + translate_or_lose (foo), + + v2 : foo (), + + [v2, is (v1 = v2)]); +[1, true]; + +(kill (foo), 0); +0; + +block ([translate : false, bar, v1, v2], + foo () := block ([n : 0], bar (n : n + 1)), + + bar : lambda ([q], q), + + v1 : foo (), + + translate_or_lose (foo), + + v2 : foo (), /* this used to yield 2 */ + + [v2, is (v1 = v2)]); +[1, true]; + +(kill (foo), 0); +0; + +block ([translate : false, transrun : true, v1, v2], + local (bar), + + foo () := block ([n : 0], bar (n : n + 1), n), + + translate_or_lose (foo), + + bar ('q) := 123, + + v1 : foo (), /* this used to yield 1 */ + + transrun : false, + + v2 : foo (), + + [v1, is (v1 = v2)]); +[0, true]; + +(kill (foo), 0); +0; + +block ([translate : false, transrun : true, v1, v2], + foo () := block ([n : 0], bar (n : n + 1), n), + + translate_or_lose (foo), + + eval_string_lisp ("(defmspec $bar (q) (declare (ignore q)) 123)"), + + v1 : foo (), /* this used to yield 1 */ + + transrun : false, + + v2 : foo (), + + [v1, is (v1 = v2)]); +[0, true]; + +(kill (foo, bar), + eval_string_lisp ("(setf (symbol-plist '$bar) '())"), + 0); +0; + -- 2.11.4.GIT