From 5717c2c48ca5c5d32fc69a6c474e0c20569f1a09 Mon Sep 17 00:00:00 2001
From: Kris Katterjohn <katterjohn@gmail.com>
Date: Mon, 2 May 2022 18:03:25 -0400
Subject: [PATCH] Support RETURN-FROM in DEF%TR forms

Also go ahead and use this in a couple of places.

No problems with the test suite, share test suite or rtest_translator.
---
 src/transl.lisp | 32 ++++++++++++++++----------------
 src/transm.lisp |  3 ++-
 2 files changed, 18 insertions(+), 17 deletions(-)

diff --git a/src/transl.lisp b/src/transl.lisp
index 5958f1f04..cb2dde17c 100644
--- a/src/transl.lisp
+++ b/src/transl.lisp
@@ -860,11 +860,11 @@ APPLY means like APPLY.")
   (punt-to-meval form))
 
 (def%tr $local (form)
-  (cond (local
-	 (tr-format (intl:gettext "error: there is already a 'local' in this block.~%"))
-	 (setq tr-abort t))
-	(t
-	 (setq local t)))
+  (when local
+    (tr-format (intl:gettext "error: there is already a 'local' in this block.~%"))
+    (setq tr-abort t)
+    (return-from $local nil))
+  (setq local t)
   ; We can't just translate to a call to MLOCAL here (which is
   ; what used to happen).  That would push onto LOCLIST and bind
   ; MLOCP at the "wrong time".  The push onto LOCLIST and the
@@ -1009,17 +1009,17 @@ 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)))
-    (unless tr-abort
-      (setq form
-	    (tr-lambda
-	     ;; [2] call the lambda translator.
-	     `((lambda) ((mlist) ,@arglist) ,@body)
-	     ;; [3] supply our own body translator.
-	     #'tr-mprog-body
-	     val-list
-	     arglist))
-      (cons (car form) `(,(cdr form) ,@val-list)))))
+        (setq tr-abort t)
+        (return-from mprog nil)))
+    (setq form
+	  (tr-lambda
+	   ;; [2] call the lambda translator.
+	   `((lambda) ((mlist) ,@arglist) ,@body)
+	   ;; [3] supply our own body translator.
+	   #'tr-mprog-body
+	   val-list
+	   arglist))
+    (cons (car form) `(,(cdr form) ,@val-list))))
 
 (defun tr-mprog-body (body val-list arglist
 		      &aux 
diff --git a/src/transm.lisp b/src/transm.lisp
index b614cc0ff..233c4b51e 100644
--- a/src/transm.lisp
+++ b/src/transm.lisp
@@ -18,7 +18,8 @@
   (setq definition
 	(if (and (null body) (symbolp lambda-list))
 	    `(def-same%tr ,name ,lambda-list)
-	    `(defun-prop (,name translate) ,lambda-list ,@body)))
+	    `(defun-prop (,name translate) ,lambda-list
+	       (block ,name ,@body))))
   `(eval-when (:compile-toplevel :execute :load-toplevel)
     ,definition))
 
-- 
2.11.4.GIT