~ chicken-core (chicken-5) bd0aa1c6088d865988cf5afc2f53dad36cbe2d3b
commit bd0aa1c6088d865988cf5afc2f53dad36cbe2d3b
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Sat Mar 18 14:15:35 2017 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Wed Mar 22 11:15:54 2017 +0100
Add expander hook so compiler can track line numbers.
This restores (and even improves) precision of line number reporting
in let bodies. Now that ##sys#canonicalize-body is performing macro
expansion, we need a way for the compiler to update its line number
database. This information got lost in the preceding commit.
Signed-off-by: felix <felix@call-with-current-continuation.org>
diff --git a/core.scm b/core.scm
index b24e5caa..8fc8fc2a 100644
--- a/core.scm
+++ b/core.scm
@@ -509,6 +509,18 @@
(##sys#put! alias '##core#macro-alias (lookup var se))
alias) )
+ (define (handle-expansion-result outer-ln)
+ (lambda (input output)
+ (and-let* (((not (eq? input output)))
+ (ln (or (get-line input) outer-ln)))
+ (update-line-number-database! output ln))
+ output))
+
+ (define (canonicalize-body/ln ln body se cs?)
+ (fluid-let ((expansion-result-hook
+ (handle-expansion-result ln)))
+ (##sys#canonicalize-body body se cs?)))
+
(define (set-real-names! as ns)
(for-each (lambda (a n) (set-real-name! a n)) as ns) )
@@ -601,8 +613,10 @@
(set! ##sys#syntax-error-culprit x)
(let* ((name0 (lookup (car x) se))
(name (or (and (symbol? name0) (##sys#get name0 '##core#primitive)) name0))
- (xexpanded (expand x se compiler-syntax-enabled)))
- (when ln (update-line-number-database! xexpanded ln))
+ (xexpanded
+ (fluid-let ((expansion-result-hook
+ (handle-expansion-result ln)))
+ (expand x se compiler-syntax-enabled))))
(cond ((not (eq? x xexpanded))
(walk xexpanded e se dest ldest h ln tl?))
@@ -690,14 +704,15 @@
(let* ((bindings (cadr x))
(vars (unzip1 bindings))
(aliases (map gensym vars))
- (se2 (##sys#extend-se se vars aliases)))
+ (se2 (##sys#extend-se se vars aliases))
+ (ln (or (get-line x) outer-ln)))
(set-real-names! aliases vars)
`(let
,(map (lambda (alias b)
(list alias (walk (cadr b) e se (car b) #t h ln #f)) )
aliases bindings)
- ,(walk (##sys#canonicalize-body
- (cddr x) se2 compiler-syntax-enabled)
+ ,(walk (canonicalize-body/ln
+ ln (cddr x) se2 compiler-syntax-enabled)
(append aliases e)
se2 dest ldest h ln #f) ) ) )
@@ -745,9 +760,10 @@
llist
(lambda (vars argc rest)
(let* ((aliases (map gensym vars))
+ (ln (or (get-line x) outer-ln))
(se2 (##sys#extend-se se vars aliases))
- (body0 (##sys#canonicalize-body
- obody se2 compiler-syntax-enabled))
+ (body0 (canonicalize-body/ln
+ ln obody se2 compiler-syntax-enabled))
(body (walk
(if emit-debug-info
`(##core#begin
@@ -787,11 +803,12 @@
(##sys#eval/meta (cadr b))
(strip-syntax (car b)))))
(cadr x) )
- se) ) )
+ se) )
+ (ln (or (get-line x) outer-ln)))
(walk
- (##sys#canonicalize-body (cddr x) se2 compiler-syntax-enabled)
- e se2
- dest ldest h ln #f) ) )
+ (canonicalize-body/ln
+ ln (cddr x) se2 compiler-syntax-enabled)
+ e se2 dest ldest h ln #f) ) )
((##core#letrec-syntax)
(let* ((ms (map (lambda (b)
@@ -802,13 +819,15 @@
(##sys#eval/meta (cadr b))
(strip-syntax (car b)))))
(cadr x) ) )
- (se2 (append ms se)) )
+ (se2 (append ms se))
+ (ln (or (get-line x) outer-ln)) )
(for-each
(lambda (sb)
(set-car! (cdr sb) se2) )
ms)
(walk
- (##sys#canonicalize-body (cddr x) se2 compiler-syntax-enabled)
+ (canonicalize-body/ln
+ ln (cddr x) se2 compiler-syntax-enabled)
e se2 dest ldest h ln #f)))
((##core#define-syntax)
@@ -882,7 +901,8 @@
(strip-syntax (car b)))
se))
(##sys#get name '##compiler#compiler-syntax) ) ) )
- (cadr x))))
+ (cadr x)))
+ (ln (or (get-line x) outer-ln)))
(dynamic-wind
(lambda ()
(for-each
@@ -891,8 +911,8 @@
bs) )
(lambda ()
(walk
- (##sys#canonicalize-body
- (cddr x) se compiler-syntax-enabled)
+ (canonicalize-body/ln
+ ln (cddr x) se compiler-syntax-enabled)
e se dest ldest h ln tl?) )
(lambda ()
(for-each
@@ -1010,15 +1030,16 @@
body))))
((##core#loop-lambda) ;XXX is this really needed?
- (let* ([vars (cadr x)]
- [obody (cddr x)]
- [aliases (map gensym vars)]
+ (let* ((vars (cadr x))
+ (obody (cddr x))
+ (aliases (map gensym vars))
(se2 (##sys#extend-se se vars aliases))
- [body
+ (ln (or (get-line x) outer-ln))
+ (body
(walk
- (##sys#canonicalize-body obody se2 compiler-syntax-enabled)
+ (canonicalize-body/ln ln obody se2 compiler-syntax-enabled)
(append aliases e)
- se2 #f #f dest ln #f) ] )
+ se2 #f #f dest ln #f) ) )
(set-real-names! aliases vars)
`(##core#lambda ,aliases ,body) ) )
diff --git a/expand.scm b/expand.scm
index b1a91ebb..d1d8ee34 100644
--- a/expand.scm
+++ b/expand.scm
@@ -48,7 +48,8 @@
;; assigned to.
define-definition
define-syntax-definition
- define-values-definition)
+ define-values-definition
+ expansion-result-hook)
(import scheme chicken
chicken.keyword)
@@ -259,7 +260,7 @@
"' returns original form, which would result in endless expansion")
exp))
(dx `(,name --> ,exp2))
- exp2)))
+ (expansion-result-hook exp exp2) ) ) )
(define (expand head exp mdef)
(dd `(EXPAND:
,head
@@ -316,7 +317,7 @@
(define ##sys#compiler-syntax-hook #f)
(define ##sys#enable-runtime-macros #f)
-
+(define expansion-result-hook (lambda (input output) output))
;;; User-level macroexpansion
diff --git a/tests/scrutiny-2.expected b/tests/scrutiny-2.expected
index 4cabcc4b..412e7a5b 100644
--- a/tests/scrutiny-2.expected
+++ b/tests/scrutiny-2.expected
@@ -1,18 +1,18 @@
Note: at toplevel:
- (scrutiny-tests-2.scm:14) in procedure call to `pair?', the predicate is called with an argument of type `pair' and will always return true
+ (scrutiny-tests-2.scm:20) in procedure call to `pair?', the predicate is called with an argument of type `pair' and will always return true
Note: at toplevel:
- (scrutiny-tests-2.scm:14) in procedure call to `pair?', the predicate is called with an argument of type `null' and will always return false
+ (scrutiny-tests-2.scm:20) in procedure call to `pair?', the predicate is called with an argument of type `null' and will always return false
Note: at toplevel:
- (scrutiny-tests-2.scm:14) in procedure call to `pair?', the predicate is called with an argument of type `null' and will always return false
+ (scrutiny-tests-2.scm:20) in procedure call to `pair?', the predicate is called with an argument of type `null' and will always return false
Note: at toplevel:
- (scrutiny-tests-2.scm:14) in procedure call to `pair?', the predicate is called with an argument of type `fixnum' and will always return false
+ (scrutiny-tests-2.scm:20) in procedure call to `pair?', the predicate is called with an argument of type `fixnum' and will always return false
Note: at toplevel:
- (scrutiny-tests-2.scm:14) in procedure call to `pair?', the predicate is called with an argument of type `float' and will always return false
+ (scrutiny-tests-2.scm:20) in procedure call to `pair?', the predicate is called with an argument of type `float' and will always return false
Note: at toplevel:
(scrutiny-tests-2.scm:21) in procedure call to `list?', the predicate is called with an argument of type `null' and will always return true
Trap