Re: [Chicken-hackers] [PATCH] fix handling of assignment in different flow when scrutinizing

[Felix]

From: Peter Bex <address@hidden>
Subject: Re: [Chicken-hackers] [PATCH] fix handling of assignment in different 
flow when scrutinizing
Date: Sat, 18 Feb 2012 20:44:08 +0100

> On Sat, Feb 18, 2012 at 01:10:40PM +0100, Felix wrote:
>> The attached patch fixes a problem with the flow-analysis of assignments
>> in the scrutinizer (as reported by Joerg)
> 
> Patch does not apply; it's corrupted somehow.
> 

Ok, try this one instead, please.


cheers,
felix

>From bd5fb2758985b8afa944ad1626ef56b130a4810c Mon Sep 17 00:00:00 2001
From: felix <address@hidden>
Date: Tue, 14 Feb 2012 13:15:28 +0100
Subject: [PATCH] possible fix for flow-analysis bug reported by JW: assignment 
now also destructively modifies blist entries for all sub- (outer) flows

---
 scrutinizer.scm          |   28 ++++++++++++++++++----------
 tests/scrutiny-tests.scm |   19 +++++++++++++++++++
 tests/scrutiny.expected  |    2 +-
 3 files changed, 38 insertions(+), 11 deletions(-)

diff --git a/scrutinizer.scm b/scrutinizer.scm
index 50f7b54..dd2d0a0 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 42c3b27..717ad7f 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 b77bedb..bca7f13 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
-- 
1.6.0.4