compiler: regressions in source loc propagation

* share/txr/stdlib/compiler.tl (reduce-lisp, reduce-constant):
Propagate source location to rewritten forms.

1 files changed, 27 insertions, 25 deletions

diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl
index 1ab48537..fe796218 100644
--- a/share/txr/stdlib/compiler.tl
+++ b/share/txr/stdlib/compiler.tl
@@ -1686,29 +1686,31 @@
 
 (defun reduce-lisp (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))))
+    (rlcp
+      (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)))
 
 (defun reduce-constant (env form)
   (if (consp form)
@@ -1717,8 +1719,8 @@
                (not env.(lookup-fun op)))
         (let ((cargs [mapcar (op reduce-constant env) args]))
           (if [all cargs constantp]
-            ^(quote ,(eval ^(,op ,*cargs)))
-            ^(,op ,*cargs)))
+            ^(quote ,(eval (rlcp ^(,op ,*cargs) form)))
+            (rlcp ^(,op ,*cargs) form)))
         form))
     form))