From 35889595b88a07fe68599b5d9a27f8f27af7cb03 Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Thu, 18 Feb 2021 07:56:33 -0800
Subject: compiler: use fixed-point macro for reduce-lisp.

* share/txr/stdlib/compiler.tl (fixed-point): New macro.
(reduce-lisp): Hide irrelevant iteration details by using
fixed-point macro.
---
 share/txr/stdlib/compiler.tl | 59 ++++++++++++++++++++++++--------------------
 1 file changed, 32 insertions(+), 27 deletions(-)

diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl
index ebc2bda3..cd602573 100644
--- a/share/txr/stdlib/compiler.tl
+++ b/share/txr/stdlib/compiler.tl
@@ -1468,34 +1468,39 @@
 (defun simplify-or (form)
   (reduce-or (flatten-or form)))
 
+(defmacro fixed-point (eqfn sym exp)
+  (with-gensyms (osym)
+    ^(let (,osym)
+       (while* (not (,eqfn ,osym ,sym))
+         (set ,osym ,sym
+              ,sym ,exp))
+       ,sym)))
+
 (defun reduce-lisp (form)
-  (let (oform)
-    (while* (nequal oform form)
-      (set oform form
-           form (match-case form
-                  ((append (list . @largs) . @aargs)
-                   ^(list* ,*largs (append ,*aargs)))
-                  ((@(or append list*) @arg) arg)
-                  (@(require (list* . @(listp @args))
-                             (equal '(nil) (last args)))
-                    ^(list ,*(butlastn 1 args)))
-                  (@(with (list* . @(listp @args))
-                          ((@(and @op @(or list list*)) . @largs)) (last args))
-                    ^(,op ,*(butlast args) ,*largs))
-                  (@(with (list* . @(listp @args))
-                          ((append . @aargs)) (last args))
-                    ^(list* ,*(butlast args) ,(reduce-lisp ^(append ,*aargs))))
-                  ((@(or append list list*)) nil)
-                  ((cons @a @b)
-                   (let* ((lstar ^(list* ,a ,b))
-                          (rstar (reduce-lisp lstar)))
-                     (if (eq lstar rstar) form rstar)))
-                  ((cons @a (cons @b @c))
-                   ^(list* ,a ,b ,c))
-                  ((cons @a (@(and @op @(or list list*)) . @args))
-                   ^(,op ,a ,*args))
-                  (@else else))))
-    form))
+  (fixed-point equal form
+    (match-case form
+      ((append (list . @largs) . @aargs)
+       ^(list* ,*largs (append ,*aargs)))
+      ((@(or append list*) @arg) arg)
+      (@(require (list* . @(listp @args))
+                 (equal '(nil) (last args)))
+        ^(list ,*(butlastn 1 args)))
+      (@(with (list* . @(listp @args))
+              ((@(and @op @(or list list*)) . @largs)) (last args))
+        ^(,op ,*(butlast args) ,*largs))
+      (@(with (list* . @(listp @args))
+              ((append . @aargs)) (last args))
+        ^(list* ,*(butlast args) ,(reduce-lisp ^(append ,*aargs))))
+      ((@(or append list list*)) nil)
+      ((cons @a @b)
+       (let* ((lstar ^(list* ,a ,b))
+              (rstar (reduce-lisp lstar)))
+         (if (eq lstar rstar) form rstar)))
+      ((cons @a (cons @b @c))
+       ^(list* ,a ,b ,c))
+      ((cons @a (@(and @op @(or list list*)) . @args))
+       ^(,op ,a ,*args))
+      (@else else))))
 
 (defun expand-quasi-mods (obj mods : form)
   (let (plist num sep rng-ix scalar-ix-p flex gens)
-- 
cgit v1.2.3