~ chicken-core (chicken-5) 7172bde28499d8114d70b60099299c4c73527e16

commit 7172bde28499d8114d70b60099299c4c73527e16
Author:     Peter Bex <peter@more-magic.net>
AuthorDate: Fri Jun 23 13:53:39 2023 +0200
Commit:     Peter Bex <peter@more-magic.net>
CommitDate: Fri Jun 23 14:05:38 2023 +0200

    Improve line number tracking in interpreter after syntax expansion
    
    Track syntax expansion results in the line number database, just like
    the compiler does.  To do this, we move update-line-number-database!
    into expand.scm and prefix it with ##sys# to make it globally
    accessible without having to export it from the user-visible module.
    Then, we call it from eval.scm in the same way we call it from
    core.scm.

diff --git a/core.scm b/core.scm
index c5b48370..0d1a5c88 100644
--- a/core.scm
+++ b/core.scm
@@ -544,7 +544,7 @@
     (lambda (input output)
       (and-let* (((not (eq? input output)))
 		 (ln (or (get-line-number input) outer-ln)))
-	(update-line-number-database! output ln))
+	(##sys#update-line-number-database! output ln))
       output))
 
   (define (canonicalize-body/ln ln body cs?)
@@ -1905,26 +1905,6 @@
     (create-foreign-stub rtype #f argtypes argnames body #f #t) ) )
 
 
-;;; Traverse expression and update line-number db with all contained calls:
-
-(define (update-line-number-database! exp ln)
-  (define (mapupdate xs)
-    (let loop ((xs xs))
-      (when (pair? xs)
-	(walk (car xs))
-	(loop (cdr xs)) ) ) )
-  (define (walk x)
-    (cond ((not (pair? x)))
-	  ((symbol? (car x))
-	   (let* ((name (car x))
-		  (old (or (hash-table-ref ##sys#line-number-database name) '())))
-	     (unless (assq x old)
-	       (hash-table-set! ##sys#line-number-database name (alist-cons x ln old)))
-	     (mapupdate (cdr x)) ) )
-	  (else (mapupdate x)) ) )
-  (walk exp) )
-
-
 ;;; Convert canonicalized node-graph into continuation-passing-style:
 
 (define (perform-cps-conversion node)
diff --git a/eval.scm b/eval.scm
index 86792a7a..18f496ed 100644
--- a/eval.scm
+++ b/eval.scm
@@ -130,6 +130,13 @@
       (define (decorate p ll h cntr)
 	(eval-decorator p ll h cntr))
 
+      (define (handle-expansion-result outer-ln)
+	(lambda (input output)
+	  (and-let* (((not (eq? input output)))
+		     (ln (or (get-line-number input) outer-ln)))
+	    (##sys#update-line-number-database! output ln))
+	  output))
+
       (define (compile x e h tf cntr tl?)
 	(cond ((keyword? x) (lambda v x))
 	      ((symbol? x)
@@ -195,7 +202,10 @@
 	       (##sys#syntax-error/context "illegal non-atomic object" x)]
 	      [(symbol? (##sys#slot x 0))
 	       (emit-syntax-trace-info tf x cntr)
-	       (let ((x2 (expand x (##sys#current-environment))))
+	       (let* ((ln (get-line-number x))
+		      (x2 (fluid-let ((chicken.syntax#expansion-result-hook
+				       (handle-expansion-result ln)))
+			    (expand x (##sys#current-environment)))))
 		 (d `(EVAL/EXPANDED: ,x2))
 		 (if (not (eq? x2 x))
 		     (compile x2 e h tf cntr tl?)
diff --git a/expand.scm b/expand.scm
index d809c4f8..8966923c 100644
--- a/expand.scm
+++ b/expand.scm
@@ -779,6 +779,25 @@
 	 (##sys#print "\n" #f port))) )
    ##sys#line-number-database) )
 
+;;; Traverse expression and update line-number db with all contained calls:
+
+(define (##sys#update-line-number-database! exp ln)
+  (define (mapupdate xs)
+    (let loop ((xs xs))
+      (when (pair? xs)
+	(walk (car xs))
+	(loop (cdr xs)) ) ) )
+  (define (walk x)
+    (cond ((not (pair? x)))
+	  ((symbol? (car x))
+	   (let* ((name (car x))
+		  (old (or (hash-table-ref ##sys#line-number-database name) '())))
+	     (unless (assq x old)
+	       (hash-table-set! ##sys#line-number-database name (alist-cons x ln old)))
+	     (mapupdate (cdr x)) ) )
+	  (else (mapupdate x)) ) )
+  (walk exp) )
+
 
 (define-constant +default-argument-count-limit+ 99999)