~ chicken-core (chicken-5) 37d3cd16bc1e15771b1fdb08b16fd78cc89fdc9f
commit 37d3cd16bc1e15771b1fdb08b16fd78cc89fdc9f
Author: megane <meganeka@gmail.com>
AuthorDate: Sat Apr 10 07:46:01 2021 +0300
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Sat Apr 10 15:08:02 2021 +0200
Make ir-macro-transformer retain more of line-number information
Presently, if you have errors inside code expanded by an
ir-macro-transformer, the error's reported line numbers are often very
inaccurate. Most often the reported line number is for the form
defining the current function.
Line numbers are lost whenever a macro transformer renames a pair.
This can be due to user (using the rename / inject facility of er/ir
transformers) or the automatic renaming done by ir macro trasformer.
This is a smaller problem with er-macro-transformer as most such
macros don't rename pairs, but only plain identifiers. But,
ir-macro-transformer does 2 complete renamigs of the input form, one
before transformation, and one after.
A new pair is created whenever a pair is renamed. This new pair
doesn't have any line number entry. This patch adds to the new pair
the old pair's line number, if any.
Given this input:
1 (define-syntax baz
2 (ir-macro-transformer
3 (lambda (e inj cmp)
4 (cadr e))))
5
6 (define (foo)
7 (baz
8 (baz
9 (+ 'a))))
Signed-off-by: Peter Bex <peter@more-magic.net>
diff --git a/distribution/manifest b/distribution/manifest
index cf2dc045..5416eff7 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -184,6 +184,8 @@ tests/scrutiny-2.expected
tests/redact-gensyms.scm
tests/test-scrutinizer-message-format.scm
tests/scrutinizer-message-format.expected
+tests/test-line-numbers.scm
+tests/test-line-numbers.expected
tests/syntax-rule-stress-test.scm
tests/syntax-tests.scm
tests/syntax-tests-2.scm
diff --git a/expand.scm b/expand.scm
index 3dea8407..8da8b2c0 100644
--- a/expand.scm
+++ b/expand.scm
@@ -51,6 +51,7 @@
chicken.platform)
(include "common-declarations.scm")
+(include "mini-srfi-1.scm")
(define-syntax d (syntax-rules () ((_ . _) (void))))
@@ -833,10 +834,19 @@
'transformer
(lambda (form se dse)
(let ((renv '())) ; keep rename-environment for this expansion
+ (define (inherit-pair-line-numbers old new)
+ (and-let* ((name (car new))
+ ((symbol? name))
+ (ln (get-line-number old))
+ (cur (or (hash-table-ref ##sys#line-number-database name) '())) )
+ (unless (assq new cur)
+ (hash-table-set! ##sys#line-number-database name
+ (alist-cons new ln cur))))
+ new)
(assert (list? se) "not a list" se) ;XXX remove later
(define (rename sym)
(cond ((pair? sym)
- (cons (rename (car sym)) (rename (cdr sym))))
+ (inherit-pair-line-numbers sym (cons (rename (car sym)) (rename (cdr sym)))))
((vector? sym)
(list->vector (rename (vector->list sym))))
((or (not (symbol? sym)) (keyword? sym)) sym)
@@ -898,7 +908,8 @@
(else (assq-reverse s (cdr l)))))
(define (mirror-rename sym)
(cond ((pair? sym)
- (cons (mirror-rename (car sym)) (mirror-rename (cdr sym))))
+ (inherit-pair-line-numbers
+ sym (cons (mirror-rename (car sym)) (mirror-rename (cdr sym)))))
((vector? sym)
(list->vector (mirror-rename (vector->list sym))))
((or (not (symbol? sym)) (keyword? sym)) sym)
diff --git a/tests/runtests.bat b/tests/runtests.bat
index e1803727..bca2691f 100644
--- a/tests/runtests.bat
+++ b/tests/runtests.bat
@@ -144,6 +144,14 @@ if errorlevel 1 exit /b 1
a.out
if errorlevel 1 exit /b 1
+echo ======================================== line number database ...
+%compile% -O3 test-line-numbers.scm 2>test-line-numbers.out
+if errorlevel 1 exit /b 1
+fc /lb%FCBUFSIZE% /w test-line-numbers.expected test-line-numbers.out
+if errorlevel 1 exit /b 1
+a.out
+if errorlevel 1 exit /b 1
+
echo ======================================== specialization tests ...
del /f /q foo.types foo.import.*
%compile% specialization-test-1.scm -emit-types-file foo.types -specialize -debug ox -emit-import-library foo
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 92fd961f..b1e9205f 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -141,6 +141,11 @@ $compile scrutiny-tests-3.scm -specialize -block
$compile scrutiny-tests-strict.scm -strict-types -specialize
./a.out
+echo "======================================== line number database ..."
+$compile -O3 test-line-numbers.scm 2> test-line-numbers.out
+diff $DIFF_OPTS test-line-numbers.expected test-line-numbers.out
+./a.out
+
echo "======================================== specialization tests ..."
rm -f foo.types foo.import.*
$compile specialization-test-1.scm -emit-types-file foo.types -specialize \
diff --git a/tests/test-line-numbers.expected b/tests/test-line-numbers.expected
new file mode 100644
index 00000000..a01add0d
--- /dev/null
+++ b/tests/test-line-numbers.expected
@@ -0,0 +1,23 @@
+
+Warning: Invalid argument
+ In file `test-line-numbers.scm:19',
+ In procedure `f',
+ In procedure call:
+
+ (scheme#+ 'a)
+
+ Argument #1 to procedure `+' has an invalid type:
+
+ symbol
+
+ The expected type is:
+
+ number
+
+ This is the expression:
+
+ 'a
+
+ Procedure `+' from module `scheme' has this type:
+
+ (#!rest number -> number)
diff --git a/tests/test-line-numbers.scm b/tests/test-line-numbers.scm
new file mode 100644
index 00000000..15f995de
--- /dev/null
+++ b/tests/test-line-numbers.scm
@@ -0,0 +1,19 @@
+(define-syntax bar
+ (er-macro-transformer
+ (lambda (e inj cmp) (get-line-number (cadr e)))))
+
+(define-syntax foo
+ (ir-macro-transformer
+ (lambda (e inj cmp) (get-line-number (cadr e)))))
+
+(assert (equal? "test-line-numbers.scm:9" (the * (foo (hello-ir)))))
+(assert (equal? "test-line-numbers.scm:10" (the * (bar (hello-er)))))
+
+(define-syntax baz
+ (ir-macro-transformer
+ (lambda (e inj cmp)
+ (cadr e))))
+
+(define (f)
+ (baz
+ (+ 'a)))
Trap