* 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
