[PATCH] Make ir-macro-transformer retain more of line-number information

[megane]

Hi,

a small patch to make the compiler maintain more fine grained line number
info.

>From 98f76b162d7c4984092f5db42cad2648d992ceea Mon Sep 17 00:00:00 2001
From: megane <meganeka@gmail.com>
Date: Sat, 10 Apr 2021 07:46:01 +0300
Subject: [PATCH] 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))))

--- Before:

    Warning: Invalid argument
      In file `mini-line.scm:7',
      In procedure `foo',
      In procedure call:

        (scheme#+ 'a)

--- After:

    Warning: Invalid argument
      In file `mini-line.scm:9',
      In procedure `foo',
      In procedure call:

        (scheme#+ 'a)
---
 distribution/manifest            |  2 ++
 expand.scm                       | 15 +++++++++++++--
 tests/runtests.bat               |  8 ++++++++
 tests/runtests.sh                |  5 +++++
 tests/test-line-numbers.expected | 23 +++++++++++++++++++++++
 tests/test-line-numbers.scm      | 19 +++++++++++++++++++
 6 files changed, 70 insertions(+), 2 deletions(-)
 create mode 100644 tests/test-line-numbers.expected
 create mode 100644 tests/test-line-numbers.scm

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..a901128a 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)))
+          (let* ((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)))
-- 
2.17.1