From 436eaa9c50f82c00d02a83039f0d5adaf3be149d Mon Sep 17 00:00:00 2001 From: Kris Katterjohn Date: Sun, 13 Nov 2022 16:48:42 -0500 Subject: [PATCH] Translated if now honors prederror Commit 74c138c9 changed the translator so that prederror was bound to true around translated MCONDs. Prior to that commit, the generated code was generally incorrect when prederror was false. See bug #3412 for more. Now a translated `if` behaves the same as an interpreted `if` when prederror is false. If the predicate can't be evaluated to a boolean value, then an `if` expression is returned. See also bug #4008. No problems with the test suite, share test suite or rtest_translator. New tests have been added to rtest_translator. --- src/acall.lisp | 9 ++ src/mlisp.lisp | 11 +- src/transl.lisp | 94 +++++++------ src/trpred.lisp | 2 +- tests/rtest_translator.mac | 331 ++++++++++++++++++++++++++++++++++++++++++++- 5 files changed, 390 insertions(+), 57 deletions(-) diff --git a/src/acall.lisp b/src/acall.lisp index a54071efb..418533df7 100644 --- a/src/acall.lisp +++ b/src/acall.lisp @@ -304,6 +304,15 @@ (setf (get '$maybe 'tr-boole-verify) '$maybe-boole-verify) (setf (get '$maybe 'tr-boole-eval) '$maybe-boole-eval) +(defun mcond-boole-verify (form) + (boole-verify form $prederror nil)) + +(defun mcond-boole-eval (form) + (boole-eval form $prederror nil)) + +(setf (get 'mcond 'tr-boole-verify) 'mcond-boole-verify) +(setf (get 'mcond 'tr-boole-eval) 'mcond-boole-eval) + (defun mevalp_tr (pat error?) (boole-verify (mevalp1_tr pat error?) error? nil)) diff --git a/src/mlisp.lisp b/src/mlisp.lisp index c9638d7ee..a9bd165c5 100644 --- a/src/mlisp.lisp +++ b/src/mlisp.lisp @@ -2235,15 +2235,18 @@ wrapper for this." (do ((u form (cddr u)) (v)) ((null u) nil) (cond ((eq (setq v (mevalp (car u))) t) (return (meval (cadr u)))) - (v (return (list* '(mcond) v (mapcar #'meval-atoms (cdr u)))))))) + (v (return (list* '(mcond) v + (mapcar (lambda (x) (mcond-eval-symbols #'meval1 x)) + (cdr u)))))))) -(defun meval-atoms (form) - (cond ((atom form) (meval1 form)) +(defun mcond-eval-symbols (ev form) + (cond ((symbolp form) (funcall ev form)) + ((atom form) form) ((eq (caar form) 'mquote) (cadr form)) ((and (getl (caar form) '(mfexpr*)) (not (member (caar form) '(mcond mand mor mnot mprogn mdo mdoin) :test #'eq))) form) - (t (recur-apply #'meval-atoms form)))) + (t (recur-apply (lambda (x) (mcond-eval-symbols ev x)) form)))) (defmspec mdo (form) (setq form (cdr form)) diff --git a/src/transl.lisp b/src/transl.lisp index b133a524d..850b1aa61 100644 --- a/src/transl.lisp +++ b/src/transl.lisp @@ -1127,56 +1127,54 @@ APPLY means like APPLY.") (warn-meval form) (punt-to-meval form))))) - +(defun mcond-eval-symbols-tr (form) + (mcond-eval-symbols #'maybe-msymeval form)) (def%tr mcond (form) - (prog (dummy mode nl) - (setq dummy (translate (caddr form)) - mode (car dummy) - nl (list dummy (cdr (translate-predicate (cadr form))))) - (do ((l (cdddr form) (cddr l))) ((null l)) - ; Optimize the else-if case: if we're at the else case at the end - ; and the body is just another conditional, then we just continue - ; directly with the clauses of the inner conditional instead of - ; nesting. - (when (and (null (cddr l)) - (eq (car l) t) - (consp (cadr l)) - (eq (caaadr l) 'mcond)) - (setq l (cdadr l))) - (setq dummy (translate (cadr l)) - mode (*union-mode mode (car dummy)) - nl (cons dummy - (cons (cdr (translate-predicate (car l))) - nl)))) - ; We leave off the final clause if the condition is true - ; and the consequent is false. - (when (and (eq t (cadr nl)) (null (cdar nl))) - (setq nl (cddr nl))) - (setq form nil) - (do ((l nl (cddr l))) ((null l)) - (setq form - (cons (cons (cadr l) - (cond ((and (not (atom (cdar l))) - (cddar l) - (eq (cadar l) 'progn)) - (nreverse - (cons (dconv (cons (caar l) - (car (reverse (cddar l)))) - mode) - (cdr (reverse (cddar l)))))) - ((and (equal (cdar l) (cadr l)) - (atom (cdar l))) nil) - (t (list (cdr (car l)))))) - form))) - ;; Wrap (LET (($PREDERROR T)) ...) around translation of MCOND. - ;; Nested MCOND expressions (e.g. if x > 0 then if y > 0 then ...) - ;; will therefore yield nested (LET (($PREDERROR T)) ... (LET (($PREDERROR T)) ...)). - ;; I suppose only the topmost one is needed, but there is very little harm - ;; in the redundant ones, so I'll let it stand. - (return (cons mode (list 'let '(($prederror t)) (cons 'cond form)))))) - - + (let ((g (tr-gensym)) + (nl nil) + (mode nil)) + (do ((l (cdr form) (cddr l))) ((null l)) + ; Optimize the else-if case: if we're at the else case at the end + ; and the body is just another conditional, then we just continue + ; directly with the clauses of the inner conditional instead of + ; nesting. + (when (and (null (cddr l)) + (eq (car l) t) + (consp (cadr l)) + (eq (caaadr l) 'mcond)) + (setq l (cdadr l))) + (let ((wrap-a-pred 'mcond)) + (declare (special wrap-a-pred)) + (destructuring-let (((pred-mode . pred-tr) (translate-predicate (car l))) + ((body-mode . body-tr) (translate (cadr l)))) + (setq mode (*union-mode mode body-mode)) + (if (eq pred-mode '$boolean) + (setq nl (list* body-tr pred-tr nl)) + (setq nl (list* `(list* '(mcond) ,g (mapcar #'mcond-eval-symbols-tr ',(cdr l))) + `(not (null ,g)) + body-tr + `(eq t (setq ,g ,pred-tr)) + nl)))))) + ; We leave off the final clause if the condition is true + ; and the consequent is false. + (when (and (eq t (cadr nl)) (null (car nl))) + (setq nl (cddr nl))) + (setq form nil) + (do ((l nl (cddr l))) ((null l)) + (setq form + (cons (cons (cadr l) + (cond ((and (not (atom (car l))) + (cdr l) + (eq (caar l) 'progn)) + (cdar l)) + ((and (equal (car l) (cadr l)) + (atom (car l))) nil) + (t (list (car l))))) + form))) + (if (among g form) + (cons '$any `(let (,g) (cond ,@form))) + (cons mode `(cond ,@form))))) ;; The MDO and MDOIN translators should be changed to use the TR-LAMBDA. ;; Perhaps a mere expansion into an MPROG would be best. diff --git a/src/trpred.lisp b/src/trpred.lisp index b5abcc22c..1be5891d0 100644 --- a/src/trpred.lisp +++ b/src/trpred.lisp @@ -12,7 +12,7 @@ (macsyma-module trpred) -; $is or $maybe +; $is, $maybe or mcond (defvar wrap-a-pred '$is) (defun wrap-pred (form &optional (evalp t)) diff --git a/tests/rtest_translator.mac b/tests/rtest_translator.mac index 62eabc457..ec57fa876 100644 --- a/tests/rtest_translator.mac +++ b/tests/rtest_translator.mac @@ -703,6 +703,7 @@ define_variable (zorble, 0, fixnum); 0; /* SF bug #3412: "Bug when translating functions that contain an \"if\" (in my case an implicit if)" */ +/* Bug #4008: translator and prederror */ (f(x):=if cabs(1/(x+1)) < 1 then 1/(x+1) else 1, f(x + %i*y)); @@ -711,8 +712,15 @@ if 1/sqrt(y^2+(x+1)^2) < 1 then 1/(%i*y+x+1) else 1; makelist (f(xy[1] + %i*xy[2]), xy, [[0, 0], [0, 1], [1, 1], [1, 0], [0, 2], [2, 2], [2, 0]]); [1, 1/(%i+1), 1/(%i+2), 1/2, 1/(2*%i+1), 1/(2*%i+3), 1/3]$ -(compile_or_lose (f), - errcatch (f(x + %i*y))); +compile_or_lose (f); +[f]; + +block ([prederror : false], + f(x + %i*y)); +if 1 - 1/sqrt(y^2+(x+1)^2) > 0 then 1/(%i*y+x+1) else 1; + +block ([prederror : true], + errcatch (f(x + %i*y))); []; '(f(x + %i*y)); @@ -753,7 +761,12 @@ makelist (f(xy[1] + %i*xy[2]), xy, [[0, 0], [0, 1], [1, 1], [1, 0], [0, 2], [2, map (g, aa, bb, cc)); [3/2,9/8,false,3/4,false,0,5,false,-4,9/8,13/2,31/4]$ -errcatch (g(1, 1, z)); +block ([prederror : false], + g (1, 1, z)); +''(if 2 - z > 0 then (if 1 > z then (if 1 > z then z + 2 elseif 1 > z / 2 then -z else -z) else 1/2)); + +block ([prederror : true], + errcatch (g (1, 1, z))); []; /* SF bug #3556: "5.43.0 translate / compile error" @@ -785,7 +798,12 @@ true; [f(y, 2), f(y, -2)]; [[y^2, 4*y^2, 9*y^2], [false, false, false]]; -errcatch (f(10, n)); +block ([prederror : false], + f(10, n)); +''([if n > 0 then 10^n, if n > 0 then 20^n, if n > 0 then 30^n]); + +block ([prederror : true], + errcatch (f(10, n))); []; /* apply2 was translated incorrectly for several years. applyb2 @@ -2736,6 +2754,311 @@ true; (kill (foo, bar), 0); 0; +block ([translate : false, l1, l2], + local (test), + + foo (x, q, prederror) := + block ([r], + [if x then 0, + if not x then 0, + if not not x then 0, + if not not not x then 0, + if x then q + r, + if not x then q + r, + if not not x then q + r, + if not not not x then q + r, + if x then 1 else 2, + if not x then 1 else 2, + if not not x then 1 else 2, + if not not not x then 1 else 2, + if x then x else q + r, + if not x then x else q + r, + if not not x then x else q + r, + if not not not x then x else q + r, + if x = 1 then x else q + r, + if x # 1 then x else q + r, + if not x = 1 then x else q + r, + if not x # 1 then x else q + r, + if not not x = 1 then x else q + r, + if not not x # 1 then x else q + r, + if not not not x = 1 then x else q + r, + if not not not x # 1 then x else q + r]), + + test () := + block ([l : [true, false, 1, 2.0, 3.0b0, 'z, 'z ()], + res : []], + push (errcatch (foo (1, 2, true)), res), + for x in l do + for q in l do + push (foo (x, q, false), res), + res), + + l1 : test (), + + translate_or_lose (foo), + + l2 : test (), + + is (l1 = l2)); +true; + +(kill (foo), 0); +0; + +block ([translate : false, l1, l2], + local (rewritehack, eqhack, test), + + /* Take a relational expr and potentially rewrite it in some + * equivalent way, e.g. x<1 => 1-x>0 + */ + rewritehack (r) := + eval_string_lisp ("(apply #'mevalp2 $r (mop $r) (margs $r))")[1], + + /* Translated code can produce relational exprs that are in a + * different, but equivalent, form compared to the exprs produce + * by interpreted code. + * + * Compare two conditionals by requiring that everything matches + * exactly, except possibly the first (only) test. The tests + * should match exactly after applying rewritehack to them. + */ + eqhack (interp, transl) := + if atom (interp) or atom (transl) or op (interp) # "if" or op (transl) # "if" then + is (interp = transl) + else + is (rest (interp) = rest (transl) + and + rewritehack (first (interp)) = rewritehack (first (transl))), + + foo (x) := + block ([r], + [if x < 1 then x else r, + if x <= 1 then x else r, + if x > 1 then x else r, + if x >= 1 then x else r, + + if not (x < 1) then x else r, + if not (x <= 1) then x else r, + if not (x > 1) then x else r, + if not (x >= 1) then x else r, + + if not not (x < 1) then x else r, + if not not (x <= 1) then x else r, + if not not (x > 1) then x else r, + if not not (x >= 1) then x else r, + + if x = 1 then x else r, + if x # 1 then x else r, + if not (x = 1) then x else r, + if not (x # 1) then x else r, + if not not (x = 1) then x else r, + if not not (x # 1) then x else r, + + if equal (x, 1) then x else r, + if notequal (x, 1) then x else r, + if not equal (x, 1) then x else r, + if not notequal (x, 1) then x else r, + if not not equal (x, 1) then x else r, + if not not notequal (x, 1) then x else r]), + + test () := + block ([res : []], + block ([prederror : true], + push (errcatch (foo ('z)), res)), + block ([prederror : false, + l : [0, 0.0, 0.0b0, + 1, 1.0, 1.0b0, + 2, 2.0, 2.0b0, + %i, 1.0 * %i, 1.0b0 * %i, + 2 * %i, 2.0 * %i, 2.0b0 * %i, + true, false, + 'z, 'z ()]], + for x in l do + res : append (foo (x), res)), + res), + + l1 : test (), + + translate_or_lose (foo), + + l2 : test (), + + every (eqhack, l1, l2)); +true; + +(kill (foo), 0); +0; + +block ([translate : false, l1, l2], + local (test), + + foo (x, y, z) := + block ([r], + [if x > 0 and y > 0 and z > 0 then x + y = z else r, + if x > 0 or y > 0 or z > 0 then x + y = z else r, + if x >= 1 and y >= 1 and z >= 1 then x + y = z else r, + if x >= 1 or y >= 1 or z >= 1 then x + y = z else r, + if x <= 2 and y <= 2 and z <= 2 then x + y = z else r, + if x <= 2 or y <= 2 or z <= 2 then x + y = z else r, + if x < 3 and y < 3 and z < 3 then x + y = z else r, + if x < 3 or y < 3 or z < 3 then x + y = z else r]), + + test () := + block ([l : [1, 2.0, 3.0b0, %i], + res : []], + for x in l do + for y in l do + for z in l do + push (foo (x, y, z), res), + res), + + l1 : test (), + + translate_or_lose (foo), + + l2 : test (), + + is (l1 = l2)); +true; + +(kill (foo), 0); +0; + +block ([translate : false, l1, l2], + local (test), + + foo (p, x, y, z) := + (modedeclare (p, boolean, x, fixnum, y, flonum, z, number), + block ([r], + [if p and x > 0 and y > 0 and z > 0 then x + y - z else r, + if p or x > 0 or y > 0 or z > 0 then x + y - z else r, + if p and x >= 1 and y >= 1 and z >= 1 then x + y - z else r, + if p or x >= 1 or y >= 1 or z >= 1 then x + y - z else r, + if p and x <= 2 and y <= 2 and z <= 2 then x + y - z else r, + if p or x <= 2 or y <= 2 or z <= 2 then x + y - z else r, + if p and x < 3 and y < 3 and z < 3 then x + y - z else r, + if p or x < 3 or y < 3 or z < 3 then x + y - z else r, + + if p and x > y and y > z and z > 3 then x + y + z else r, + if p or x > y or y > z or z > 3 then x + y + z else r, + if p and x >= y and y >= z and z >= 2 then x + y + z else r, + if p or x >= y or y >= z or z >= 2 then x + y + z else r, + if p and x <= y and y <= z and z <= 1 then x + y + z else r, + if p or x <= y or y <= z or z <= 1 then x + y + z else r, + if p and x < y and y < z and z < 0 then x + y + z else r, + if p or x < y or y < z or z < 0 then x + y + z else r])), + + test () := + block ([bool : [true, false], + fixl : [0, 1, 2, 3, 4], + flol : [0.0, 1.0, 2.0, 3.0, 4.0], + numl : [0, 1.0, 2, 3.0, 4], + res : []], + for p in bool do + for x in fixl do + for y in flol do + for z in numl do + push (foo (p, x, y, z), res), + res), + + l1 : test (), + + translate_or_lose (foo), + + l2 : test (), + + is (l1 = l2)); +true; + +(kill (foo, p, x, y, z), 0); +0; + +block ([translate : false, l1, l2], + local (test), + + foo (p, x, y, z) := + block ([r], + [if p and x and y and z then x + y = z else r, + if p or x or y or z then x + y = z else r, + + if p and equal (x, 1) and equal (y, 1) and equal (z, 1) then x + y = z else r, + if p or equal (x, 1) or equal (y, 1) or equal (z, 1) then x + y = z else r, + + if not p and not equal (x, 1) and not equal (y, 1) and not equal (z, 1) then x + y = z else r, + if not p or not equal (x, 1) or not equal (y, 1) or not equal (z, 1) then x + y = z else r, + + if p and notequal (x, 1) and notequal (y, 1) and notequal (z, 1) then x + y = z else r, + if p or notequal (x, 1) or notequal (y, 1) or notequal (z, 1) then x + y = z else r, + + if not p and not notequal (x, 1) and not notequal (y, 1) and not notequal (z, 1) then x + y = z else r, + if not p or not notequal (x, 1) or not notequal (y, 1) or not notequal (z, 1) then x + y = z else r]), + + test () := + block ([prederror : false, + l : [true, false, 1, 2.0, 3.0b0, %i, 'z, 'z ()], + res : []], + for p in [true, false] do + for x in l do + for y in l do + for z in l do + push (foo (p, x, y, z), res), + res), + + l1 : test (), + + translate_or_lose (foo), + + l2 : test (), + + is (l1 = l2)); +true; + +(kill (foo), 0); +0; + +block ([translate : false, l1, l2], + local (test), + + pred (a, b) := equal (a, b), + + foo (x, q) := + block ([r, var1, var2, v1 : 'var1, v2 : 'var2], + [if pred (x, 1) then x, + if not pred (x, 1) then x, + if pred (x, 1) or pred (x, 2) then x, + if pred (x, 1) then x else q + r, + if not pred (x, 1) then x else q + r, + if pred (x, 1) or pred (x, 2) then x else q + r, + if pred (x, 1) then f (x + q) elseif pred (x, 2) then g (x + q) elseif pred (x, q) then v1 :: r * x else var1 : q * r, + if pred (x, 1) then f (x + q) else if pred (x, 2) then g (x + q) else if pred (x, q) then v2 :: r * x else var2 : q * r, + if pred (x, 1) and q then f (x + q) elseif pred (x, 2) or q then g (x + q) elseif not pred (x, q) then v1 :: r * x else var1 : q * r, + if pred (x, 1) and q then f (x + q) else if pred (x, 2) or q then g (x + q) else if not pred (x, q) then v2 :: r * x else var2 : q * r, + if pred (x, 1) and not q then f (x + q) elseif pred (x, 2) or not q then g (x + q) elseif not pred (x, q) then v1 :: r * x else var1 : q * r, + if pred (x, 1) and not q then f (x + q) else if pred (x, 2) or not q then g (x + q) else if not pred (x, q) then v2 :: r * x else var2 : q * r]), + + test () := + block ([res : []], + block ([prederror : false], + push (errcatch (foo (true, false)), res)), + block ([prederror : false, + l : [true, false, 1, 2.0, 3.0b0, %i, 'z, 'z ()]], + for x in l do + for q in l do + push (foo (x, q), res)), + res), + + l1 : test (), + + translate_or_lose (pred, foo), + + l2 : test (), + + is (l1 = l2)); +true; + +(kill (pred, foo), 0); +0; + -- 2.11.4.GIT