From 24be91dafa28deb810ad667a01c82f34bd94bb46 Mon Sep 17 00:00:00 2001
From: Kris Katterjohn <katterjohn@gmail.com>
Date: Mon, 2 May 2022 18:10:07 -0400
Subject: [PATCH] Add a TR-ABORT function for setting TR-ABORT when translation
 fails

This provides something to trace or break on, which is useful when
translation silently fails.  This would also be a useful place to put
a throw or signal if we want to immediately bail when translation
fails instead of continuing like we currently do (although I have no
current plans to make that sort of change).

No problems with the test suite, share test suite or rtest_translator.
---
 src/trans1.lisp |  2 +-
 src/trans3.lisp |  8 ++++----
 src/trans5.lisp |  2 +-
 src/transl.lisp | 16 ++++++++++------
 4 files changed, 16 insertions(+), 12 deletions(-)

diff --git a/src/trans1.lisp b/src/trans1.lisp
index 70a5dc1f9..3dde8df83 100644
--- a/src/trans1.lisp
+++ b/src/trans1.lisp
@@ -254,7 +254,7 @@
     (t
      (tr-format (intl:gettext "makelist: maximum 5 arguments allowed; found: ~M.~%makelist: to create a list with sublists, use nested makelist commands.~%")
                 (length form))
-     (setq tr-abort t)
+     (tr-abort)
      '($any . '$**error**))))
 
 (def%tr $kill (form)
diff --git a/src/trans3.lisp b/src/trans3.lisp
index 9300c89c8..ad1394054 100644
--- a/src/trans3.lisp
+++ b/src/trans3.lisp
@@ -312,11 +312,11 @@
 (defun gen-tr-lambda (form &aux arg-info frees t-form dup)
   (unless ($listp (cadr form))
     (tr-format (intl:gettext "error: first argument of lambda expression must be a list; found ~M") (cadr form))
-    (setq tr-abort t)
+    (tr-abort)
     (return-from gen-tr-lambda nil))
   (when (null (cddr form))
     (tr-format (intl:gettext "error: empty body in lambda expression.~%"))
-    (setq tr-abort t)
+    (tr-abort)
     (return-from gen-tr-lambda nil))
   (setq arg-info (mapcar #'(lambda (v)
 			     (cond ((mdefparam v) nil)
@@ -330,11 +330,11 @@
 	     (and (member t arg-info :test #'eq)
 		  (cdr (member t arg-info :test #'eq)))) ;;; the &REST is not the last one.
 	 (tr-format (intl:gettext "error: unsupported argument list ~:M in lambda expression.~%") (cadr form))
-	 (setq tr-abort t)
+	 (tr-abort)
 	 nil)
 	((setq dup (find-duplicate (cdadr form) :test #'eq :key #'mparam))
 	 (tr-format (intl:gettext "error: ~M occurs more than once in lambda expression parameter list") (mparam dup))
-	 (setq tr-abort t)
+	 (tr-abort)
 	 nil)
 	(t
 	 (setq arg-info (member t arg-info :test #'eq) ;; &RESTP
diff --git a/src/trans5.lisp b/src/trans5.lisp
index 2ac8f1283..f151d6e9c 100644
--- a/src/trans5.lisp
+++ b/src/trans5.lisp
@@ -173,7 +173,7 @@
 		     `(cons ',var ,(dtranslate var)))
 		    ((eq (caar var) 'msetq)
 		     `(cons ',(cadr var) ,(dtranslate (caddr var))))
-		    (t (setq tr-abort t)
+		    (t (tr-abort)
 		       (tr-format (intl:gettext "error: found unhandled variable ~:M in 'buildq'.~%") var))))
 					;right thing to do here??
 					;how much error checking does transl do now?
diff --git a/src/transl.lisp b/src/transl.lisp
index cb2dde17c..8539566b8 100644
--- a/src/transl.lisp
+++ b/src/transl.lisp
@@ -184,13 +184,16 @@ APPLY means like APPLY.")
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
+(defun tr-abort ()
+  (setq tr-abort t)
+  nil)
 
 (defun barfo (msg)
   (tr-format (intl:gettext "Internal translator error: ~M~%") msg)
   (cond (*transl-debug*
 	 (break "transl barfo"))
 	(t
-	 (setq tr-abort t)
+	 (tr-abort)
 	 nil)))
 
 (defun specialp (var)
@@ -370,7 +373,7 @@ APPLY means like APPLY.")
 (defun tr-mfun (name &aux (*transl-backtrace* nil))
   (let ((def-form (consfundef name nil nil)))
     (cond ((null def-form)
-	   (setq tr-abort t))
+	   (tr-abort))
 	  (t
 	   (tr-mdefine-toplevel def-form)))))
 
@@ -419,7 +422,7 @@ APPLY means like APPLY.")
 	  ((member tr-unique a-args :test #'eq)
 	   ;; WHAT IS "BAD" ABOUT THE ARGUMENT LIST HERE ??
 	   (tr-format (intl:gettext "error: unhandled argument list in function definition: ~:M~%") `((mlist),@args))
-	   (setq tr-abort t)
+	   (tr-abort)
 	   nil)
 	  ((member (caar form) '(mdefine mdefmacro) :test #'eq)
 	   (setq kind (cond ((eq (caar form) 'mdefmacro) 'macro)
@@ -491,6 +494,7 @@ APPLY means like APPLY.")
 					; ERRSET is crude, but...
 		   (errset (apply 'eval (list lisp-def-form)))))
 	      (cond ((not lisp-action)
+		     (tr-abort)
 		     (trfail name))
 		    (t name))))))))
 
@@ -847,7 +851,7 @@ APPLY means like APPLY.")
 (def%tr $eval_when (form)
   (tr-format (intl:gettext "error: found 'eval_when' in a function or expression: ~:M~%") form)
   (tr-format (intl:gettext "note: 'eval_when' can appear only at the top level in a file.~%"))
-  (setq tr-abort t)
+  (tr-abort)
   '($any . nil))
 
 (def%tr mdefmacro (form)
@@ -862,7 +866,7 @@ APPLY means like APPLY.")
 (def%tr $local (form)
   (when local
     (tr-format (intl:gettext "error: there is already a 'local' in this block.~%"))
-    (setq tr-abort t)
+    (tr-abort)
     (return-from $local nil))
   (setq local t)
   ; We can't just translate to a call to MLOCAL here (which is
@@ -1009,7 +1013,7 @@ APPLY means like APPLY.")
     (let ((dup (find-duplicate arglist :test #'eq)))
       (when dup
         (tr-format (intl:gettext "error: ~M occurs more than once in block variable list") dup)
-        (setq tr-abort t)
+        (tr-abort)
         (return-from mprog nil)))
     (setq form
 	  (tr-lambda
-- 
2.11.4.GIT