[PATCH 1/1] Preserve source properties in unparse-tree-il

[Holger Peters <holger.peters@posteo.de>]

* module/language/tree-il.scm (unparse-tree-il): Add source properties if available.
* module/language/tree-il.scm (add-src-loc): New procedure.
---
 module/language/tree-il.scm | 75 +++++++++++++++++++++----------------
 1 file changed, 42 insertions(+), 33 deletions(-)

diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index 974fce29e..732edaf19 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -256,84 +256,93 @@
      (else
       (error "unrecognized tree-il" exp)))))
 
+(define (add-src-loc src-loc expr)
+  "Annotate expression with source location"
+  (when src-loc
+    (set-source-properties! expr src-loc))
+  expr)
+
 (define (unparse-tree-il tree-il)
   (match tree-il
     (($ <void> src)
      '(void))
 
     (($ <call> src proc args)
-     `(call ,(unparse-tree-il proc) ,@(map unparse-tree-il args)))
+     (add-src-loc src `(call ,(unparse-tree-il proc) ,@(map unparse-tree-il args))))
 
     (($ <primcall> src name args)
-     `(primcall ,name ,@(map unparse-tree-il args)))
+     (add-src-loc src  `(primcall ,name ,@(map unparse-tree-il args))))
 
     (($ <conditional> src test consequent alternate)
-     `(if ,(unparse-tree-il test)
-          ,(unparse-tree-il consequent)
-          ,(unparse-tree-il alternate)))
+     (add-src-loc src `(if ,(unparse-tree-il test)
+                         ,(unparse-tree-il consequent)
+                         ,(unparse-tree-il alternate))))
 
     (($ <primitive-ref> src name)
-     `(primitive ,name))
+     (add-src-loc src `(primitive ,name)))
 
     (($ <lexical-ref> src name gensym)
-     `(lexical ,name ,gensym))
+     (add-src-loc src `(lexical ,name ,gensym)))
 
     (($ <lexical-set> src name gensym exp)
-     `(set! (lexical ,name ,gensym) ,(unparse-tree-il exp)))
+     (add-src-loc `(set! (lexical ,name ,gensym) ,(unparse-tree-il exp))))
 
     (($ <module-ref> src mod name public?)
-     `(,(if public? '@ '@@) ,mod ,name))
+     (add-src-loc `(,(if public? '@ '@@) ,mod ,name)))
 
     (($ <module-set> src mod name public? exp)
-     `(set! (,(if public? '@ '@@) ,mod ,name) ,(unparse-tree-il exp)))
+     (add-src-loc `(set! (,(if public? '@ '@@) ,mod ,name) ,(unparse-tree-il exp)) ))
 
     (($ <toplevel-ref> src mod name)
-     `(toplevel ,name))
+     (add-src-loc src `(toplevel ,name) ))
 
     (($ <toplevel-set> src mod name exp)
-     `(set! (toplevel ,name) ,(unparse-tree-il exp)))
+     (add-src-loc src `(set! (toplevel ,name) ,(unparse-tree-il exp))))
 
     (($ <toplevel-define> src mod name exp)
-     `(define ,name ,(unparse-tree-il exp)))
+     (add-src-loc src `(define ,name ,(unparse-tree-il exp))))
 
     (($ <lambda> src meta body)
-     (if body
-         `(lambda ,meta ,(unparse-tree-il body))
-         `(lambda ,meta (lambda-case))))
+     (let ((res (if body
+                  `(lambda ,meta ,(unparse-tree-il body))
+                  `(lambda ,meta (lambda-case)))))
+       (add-src-loc src res)))
 
     (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
-     `(lambda-case ((,req ,opt ,rest ,kw ,(map unparse-tree-il inits) ,gensyms)
-                    ,(unparse-tree-il body))
-                   . ,(if alternate (list (unparse-tree-il alternate)) '())))
-
+     (let ((res `(lambda-case ((,req ,opt ,rest ,kw ,(map unparse-tree-il inits) ,gensyms)
+                               ,(unparse-tree-il body))
+                              . ,(if alternate (list (unparse-tree-il alternate)) '()))))
+       (add-src-loc src res)))
+    
     (($ <const> src exp)
-     `(const ,exp))
+     (add-src-loc src  `(const ,exp)))
 
     (($ <seq> src head tail)
-     `(seq ,(unparse-tree-il head) ,(unparse-tree-il tail)))
+     (add-src-loc src `(seq ,(unparse-tree-il head) ,(unparse-tree-il tail))))
     
     (($ <let> src names gensyms vals body)
-     `(let ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
+     (add-src-loc `(let ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body)) ))
 
     (($ <letrec> src in-order? names gensyms vals body)
-     `(,(if in-order? 'letrec* 'letrec) ,names ,gensyms
-       ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
+     (add-src-loc src `(,(if in-order? 'letrec* 'letrec) ,names ,gensyms
+                        ,(map unparse-tree-il vals) ,(unparse-tree-il body))))
 
     (($ <fix> src names gensyms vals body)
-     `(fix ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
+     (add-src-loc src `(fix ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body))))
 
     (($ <let-values> src exp body)
-     `(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body)))
+     (add-src-loc src `(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body))))
 
     (($ <prompt> src escape-only? tag body handler)
-     `(prompt ,escape-only?
-              ,(unparse-tree-il tag)
-              ,(unparse-tree-il body)
-              ,(unparse-tree-il handler)))
+     (add-src-loc src `(prompt ,escape-only?
+                               ,(unparse-tree-il tag)
+                               ,(unparse-tree-il body)
+                               ,(unparse-tree-il handler))))
 
     (($ <abort> src tag args tail)
-     `(abort ,(unparse-tree-il tag) ,(map unparse-tree-il args)
-             ,(unparse-tree-il tail)))))
+     (add-src-loc `(abort ,(unparse-tree-il tag)
+                          ,(map unparse-tree-il args)
+                          ,(unparse-tree-il tail))))))
 
 (define* (tree-il->scheme e #:optional (env #f) (opts '()))
   (values ((@ (language scheme decompile-tree-il)
-- 
2.28.0