From a33f5e5d7ce9273767783d117fc7f10562149358 Mon Sep 17 00:00:00 2001
From: Kris Katterjohn <katterjohn@gmail.com>
Date: Sat, 16 Nov 2024 13:48:50 -0500
Subject: [PATCH] Consolidate some code for translating args and unioning modes

No functional changes.

No problems with the test suite, share test suite or rtest_translator.
---
 src/transl.lisp | 14 ++++++++++++++
 src/troper.lisp | 27 +++++++++------------------
 2 files changed, 23 insertions(+), 18 deletions(-)

diff --git a/src/transl.lisp b/src/transl.lisp
index 4fe261f29..ee47fdfbe 100644
--- a/src/transl.lisp
+++ b/src/transl.lisp
@@ -343,6 +343,20 @@ APPLY means like APPLY.")
 	  (exp (car (last loc))))
       (cons mode exp))))
 
+; Returns (UNION-MODE . TARGS) where TARGS are the translated ARGS
+; (with individual mode info present) and UNION-MODE is the union
+; of their modes as determined by *UNION-MODE.
+;
+; If ARGS is NIL then both UNION-MODE and TARGS will be NIL.
+(defun translate-args/union-mode (args)
+  (do ((l args (cdr l))
+       (args '())
+       (mode nil))
+      ((null l)
+       (cons mode (nreverse args)))
+    (setq args (cons (translate (car l)) args)
+          mode (*union-mode (car (car args)) mode))))
+
 (defun tr-args (form)
   (mapcar #'(lambda (x) (dconvx (translate x))) form))
 
diff --git a/src/troper.lisp b/src/troper.lisp
index 91cb4f5ac..a6f9bcb1b 100644
--- a/src/troper.lisp
+++ b/src/troper.lisp
@@ -29,11 +29,7 @@
 	(t `($any . (*mminus ,(cdr form))))))
 
 (def%tr mplus (form)
-  (let   (args mode)
-    (do ((l (cdr form) (cdr l))) ((null l))
-      (setq args (cons (translate (car l)) args)
-	    mode (*union-mode (car (car args)) mode)))
-    (setq args (nreverse args))
+  (destructuring-bind (mode . args) (translate-args/union-mode (cdr form))
     (cond ((eq '$fixnum mode) `($fixnum + . ,(mapcar #'cdr args)))
 	  ((eq '$float mode) `($float + . ,(mapcar #'dconv-$float args)))
 	  ((eq '$rational mode) `($rational rplus . ,(mapcar #'cdr args)))
@@ -41,19 +37,14 @@
 	  (t `($any add* . ,(mapcar #'dconvx args))))))
 
 (def%tr mtimes (form)
-  (let (args mode)
-    (cond ((equal -1 (cadr form))
-	   (translate `((mminus) ((mtimes) . ,(cddr form)))))
-	  (t
-	   (do ((l (cdr form) (cdr l)))
-	       ((null l))
-	     (setq args (cons (translate (car l)) args)
-		   mode (*union-mode (car (car args)) mode)))
-	   (setq args (nreverse args))
-	   (cond ((eq '$fixnum mode) `($fixnum * . ,(mapcar #'cdr args)))
-		 ((eq '$float mode) `($float * . ,(mapcar #'dconv-$float args)))
-		 ((eq '$rational mode) `($rational rtimes . ,(mapcar #'cdr args)))
-		 ((eq '$number mode) `($number * . ,(mapcar #'cdr args)))
+  (cond ((equal -1 (cadr form))
+         (translate `((mminus) ((mtimes) . ,(cddr form)))))
+        (t
+         (destructuring-bind (mode . args) (translate-args/union-mode (cdr form))
+           (cond ((eq '$fixnum mode) `($fixnum * . ,(mapcar #'cdr args)))
+                 ((eq '$float mode) `($float * . ,(mapcar #'dconv-$float args)))
+                 ((eq '$rational mode) `($rational rtimes . ,(mapcar #'cdr args)))
+                 ((eq '$number mode) `($number * . ,(mapcar #'cdr args)))
 		 (t `($any mul* . ,(mapcar #'dconvx args))))))))
 
 
-- 
2.11.4.GIT