~ chicken-core (chicken-5) 91f78aaf7ed1a9975eb93663b4a8cb44ccc10c0b

commit 91f78aaf7ed1a9975eb93663b4a8cb44ccc10c0b
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Tue Feb 14 13:15:28 2012 +0100
Commit:     Peter Bex <peter.bex@xs4all.nl>
CommitDate: Mon Feb 20 21:34:23 2012 +0100

    possible fix for flow-analysis bug reported by JW: assignment now also destructively modifies blist entries for all sub- (outer) flows
    
    Signed-off-by: Peter Bex <peter.bex@xs4all.nl>

diff --git a/scrutinizer.scm b/scrutinizer.scm
index 50f7b546..dd2d0a00 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -456,8 +456,8 @@
 	    (class (node-class n)) )
 	(dd "walk: ~a ~s (loc: ~a, dest: ~a, tail: ~a, flow: ~a)"
 	    class params loc dest tail flow)
-	;;(dd "walk: ~a ~s (loc: ~a, dest: ~a, tail: ~a, flow: ~a, blist: ~a, e: ~a)"
-	;;    class params loc dest tail flow blist e)
+	#;(dd "walk: ~a ~s (loc: ~a, dest: ~a, tail: ~a, flow: ~a, blist: ~a, e: ~a)"
+	    class params loc dest tail flow blist e)
 	(set! d-depth (add1 d-depth))
 	(let ((results
 	       (case class
@@ -639,14 +639,22 @@
 				    var ot rt)
 				  #t)))))
 		      ;; don't use "add-to-blist" since the current operation does not affect aliases
-		      (set! blist
-			(alist-cons
-			 (cons var (car flow)) 
-			 (if (or strict-variable-types
-				 (not (get db var 'captured)))
-			     rt 
-			     '*)
-			 blist)))
+		      (let ((t (if (or strict-variable-types
+				       (not (get db var 'captured)))
+				   rt 
+				   '*))
+			    (fl (car flow)))
+			(let loop ((bl blist) (f #f))
+			  (cond ((null? bl)
+				 (unless f
+				   (set! blist (alist-cons (cons var fl) t blist))))
+				((eq? (caaar bl) var)
+				 (let ((t (simplify-type `(or ,t ,(cdar bl)))))
+				   (dd "assignment modifies blist entry ~s -> ~a"
+				       (caar bl) t)
+				   (set-cdr! (car bl) t)
+				   (loop (cdr bl) (eq? fl (cdaar bl)))))
+				(else (loop (cdr bl) f))))))
 		    '(undefined)))
 		 ((##core#primitive ##core#inline_ref) '*)
 		 ((##core#call)
diff --git a/tests/scrutiny-tests.scm b/tests/scrutiny-tests.scm
index 42c3b273..717ad7fd 100644
--- a/tests/scrutiny-tests.scm
+++ b/tests/scrutiny-tests.scm
@@ -109,3 +109,22 @@
   (the * (values 1 2))				; 1 + 2
   (the * (values))				; 3
   (the fixnum (* x y)))				; nothing (but warns about "x" being string)
+
+
+;; Reported by Joerg Wittenberger:
+;
+; - assignment inside first conditional does not invalidate blist
+;;  entries for "ins"/"del" in outer flow.
+
+(define (write-blob-to-sql sql identifier last blob c-c)
+ (define ins '())
+ (define del '())
+ (if (vector? blob)
+     (begin
+	(set! ins (vector-ref blob 1))
+	(set! del (vector-ref blob 2))
+	(set! blob (vector-ref blob 0))))
+ (if (or (pair? ins)
+	 (pair? del))
+     (<handle-ins-and-del>))
+ (<do-some-more>))
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
index b77bedb0..bca7f13e 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -37,7 +37,7 @@ Warning: at toplevel:
   scrutiny-tests.scm:28: in procedure call to `+', expected argument #2 of type `number', but was given an argument of type `symbol'
 
 Warning: at toplevel:
-  assignment of value of type `fixnum' to toplevel variable `car' does not match declared type `(forall (a105) (procedure car ((pair a105 *)) a105))'
+  assignment of value of type `fixnum' to toplevel variable `car' does not match declared type `(forall (a123) (procedure car ((pair a123 *)) a123))'
 
 Warning: at toplevel:
   expected in `let' binding of `g8' a single result, but were given 2 results