~ chicken-core (chicken-5) 7f1fd58a30dd5402ca0b75b4fffa962575a4fecb

commit 7f1fd58a30dd5402ca0b75b4fffa962575a4fecb
Author:     Evan Hanson <evhan@foldling.org>
AuthorDate: Mon Feb 15 22:05:42 2016 +1300
Commit:     Peter Bex <peter@more-magic.net>
CommitDate: Sat Jun 18 16:43:43 2016 +0200

    Track source nodes for better scrutiny output
    
    Adds a map from specialized nodes back to their original source nodes so
    that the scrutinizer can (a) print line numbers for parts of the program
    that started out as ##core#call nodes but ended up being specialized to
    something without line number information, and (b) print program
    fragments as they appeared in the user's source, pre-specialization.
    
    Signed-off-by: Peter Bex <peter@more-magic.net>

diff --git a/scrutinizer.scm b/scrutinizer.scm
index 433ed2ed..3eafa1a5 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -129,16 +129,6 @@
 (define (walked-result n)
   (first (node-parameters n)))		; assumes ##core#the/result node
 
-(define (node-line-number n)
-  (case (node-class n)
-    ((##core#call)
-     (let ((params (node-parameters n)))
-       (and (pair? (cdr params))
-	    (pair? (cadr params)) ; debug-info has line-number information?
-	    (source-info->line (cadr params)))))
-    ((##core#typecase)
-     (car (node-parameters n)))
-    (else #f)))
 
 (define (scrutinize node db complain specialize strict block-compilation)
   (let ((blist '())			; (((VAR . FLOW) TYPE) ...)
@@ -274,7 +264,7 @@
 
     (define (node-source-prefix n)
       (let ((line (node-line-number n)))
-       (if (not line) "" (sprintf "(~a) " line))))
+	(if (not line) "" (sprintf "(~a) " line))))
 
     (define (location-name loc)
       (define (lname loc1)
@@ -293,7 +283,7 @@
     (define add-loc cons)
 
     (define (fragment x)
-      (let ((x (build-expression-tree x)))
+      (let ((x (build-expression-tree (source-node-tree x))))
 	(let walk ((x x) (d 0))
 	  (cond ((atom? x) (strip-syntax x))
 		((>= d +fragment-max-depth+) '...)
@@ -844,7 +834,7 @@
 					  (append (type-typeenv (car types)) typeenv)
 					  #t)
 			     ;; drops exp
-			     (copy-node! (car subs) n)
+			     (mutate-node! n (car subs))
 			     (walk n e loc dest tail flow ctags))
 			    (else
 			     (trail-restore trail0 typeenv)
@@ -1846,6 +1836,47 @@
        db)
       (print "; END OF FILE"))))
 
+;;
+;; Source node tracking
+;;
+;; Nodes are mutated in place during specialization, which may lose line
+;; number information if, for example, a node is changed from a
+;; ##core#call to a class without debug info. To preserve line numbers
+;; and allow us to print fragments of the original source, we maintain a
+;; side table of mappings from mutated nodes to copies of the originals.
+;;
+
+(define node-mutations '())
+
+(define (mutate-node! node expr)
+  (set! node-mutations (alist-update! node (copy-node node) node-mutations))
+  (copy-node! (build-node-graph expr) node))
+
+(define (source-node n #!optional (k values))
+  (let ((orig (alist-ref n node-mutations eq?)))
+    (if (not orig) (k n) (source-node orig k))))
+
+(define (source-node-tree n)
+  (source-node
+   n
+   (lambda (n*)
+     (make-node (node-class n*)
+		(node-parameters n*)
+		(map source-node (node-subexpressions n*))))))
+
+(define (node-line-number n)
+  (node-debug-info (source-node n)))
+
+(define (node-debug-info n)
+  (case (node-class n)
+    ((##core#call)
+     (let ((params (node-parameters n)))
+       (and (pair? (cdr params))
+	    (pair? (cadr params)) ; debug-info has line-number information?
+	    (source-info->line (cadr params)))))
+    ((##core#typecase)
+     (car (node-parameters n)))
+    (else #f)))
 
 ;; Mutate node for specialization
 
@@ -1873,8 +1904,7 @@
 	    ((not (pair? x)) x)
 	    ((eq? 'quote (car x)) x)	; to handle numeric constants
 	    (else (cons (subst (car x)) (subst (cdr x))))))
-    (let ((spec (subst template)))
-      (copy-node! (build-node-graph spec) node))))
+    (mutate-node! node (subst template))))
 
 
 ;;; Type-validation and -normalization
diff --git a/support.scm b/support.scm
index a7396c08..b129f252 100644
--- a/support.scm
+++ b/support.scm
@@ -45,7 +45,7 @@
      node-parameters node-parameters-set!
      node-subexpressions node-subexpressions-set! varnode qnode
      build-node-graph build-expression-tree fold-boolean inline-lambda-bindings
-     tree-copy copy-node! emit-global-inline-file load-inline-file
+     tree-copy copy-node! copy-node emit-global-inline-file load-inline-file
      match-node expression-has-side-effects? simple-lambda-node?
      dump-undefined-globals dump-defined-globals dump-global-refs
      make-foreign-callback-stub foreign-callback-stub?
@@ -733,6 +733,11 @@
 	(cons (rec (car t)) (rec (cdr t)))
 	t) ) )
 
+(define (copy-node n)
+  (make-node (node-class n)
+             (node-parameters n)
+             (node-subexpressions n)))
+
 (define (copy-node! from to)
   (node-class-set! to (node-class from))
   (node-parameters-set! to (node-parameters from))