~ chicken-core (chicken-5) ae6af2c1894b8ab8178f21f8169a98c3b5e0327a

commit ae6af2c1894b8ab8178f21f8169a98c3b5e0327a
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Tue Jun 19 19:46:26 2012 +0200
Commit:     Peter Bex <peter.bex@xs4all.nl>
CommitDate: Thu Jun 21 20:56:53 2012 +0200

    smash types in implicit global type-declarations; added test
    
    Signed-off-by: Peter Bex <peter.bex@xs4all.nl>

diff --git a/distribution/manifest b/distribution/manifest
index 6c02c346..d4b641b9 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -143,6 +143,7 @@ tests/module-tests-compiled.scm
 tests/scrutiny-tests.scm
 tests/typematch-tests.scm
 tests/scrutiny-tests-2.scm
+tests/scrutiny-tests-3.scm
 tests/scrutiny.expected
 tests/syntax-rule-stress-test.scm
 tests/syntax-tests.scm
diff --git a/scrutinizer.scm b/scrutinizer.scm
index dbf64814..8069ac60 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -614,12 +614,15 @@
 				   (or (not (variable-visible? var))
 				       (not (eq? (variable-mark var '##compiler#inline) 
 						 'no))))
-			  (debugging '|I| (sprintf "(: ~s ~s)" var rt))
-			  ;; [2] sets property, but lambda has already been walked,
-			  ;; so no type-checks are generated (see also [1], above)
-			  ;; note that implicit declarations are not enforcing
-			  (mark-variable var '##compiler#declared-type)
-			  (mark-variable var '##compiler#type rt))))
+			  (let ((rtlst (list (cons #f (tree-copy rt)))))
+			    (smash-component-types! rtlst "global")
+			    (let ((rt (cdar rtlst)))
+			      (debugging '|I| (sprintf "(: ~s ~s)" var rt))
+			      ;; [2] sets property, but lambda has already been walked,
+			      ;; so no type-checks are generated (see also [1], above)
+			      ;; note that implicit declarations are not enforcing
+			      (mark-variable var '##compiler#declared-type)
+			      (mark-variable var '##compiler#type rt))))))
 		    (when b
 		      (cond ((eq? 'undefined (cdr b)) (set-cdr! b rt))
 			    #;(strict-variable-types
@@ -834,6 +837,7 @@
 ;;  into "pair", since mutation may take place
 
 (define (smash-component-types! lst where)
+  ;; assumes list of the form "((_ . T1) ...)"
   (do ((lst lst (cdr lst)))
       ((null? lst))
     (let loop ((t (cdar lst))
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 9f9f7ee5..d21b7044 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -96,6 +96,9 @@ fi
 
 diff -bu scrutiny-2.expected scrutiny-2.out
 
+$compile scrutiny-tests-3.scm -specialize -block -ignore-repository -types $TYPESDB
+./a.out
+
 echo "======================================== specialization tests ..."
 rm -f foo.types foo.import.*
 $compile specialization-test-1.scm -emit-type-file foo.types -specialize \
diff --git a/tests/scrutiny-tests-3.scm b/tests/scrutiny-tests-3.scm
new file mode 100644
index 00000000..41b46fb7
--- /dev/null
+++ b/tests/scrutiny-tests-3.scm
@@ -0,0 +1,12 @@
+;;;; scrutiny-tests-3.scm - scrutinizer-tests, compiled in block mode and executed
+
+
+;;; ensure implicit global type-declarations are "smashed" (i.e. have
+;;; their component types invalidated, due to possible mutation)
+
+(define vec (make-vector 10 #f))
+(vector-set! vec 0 99)
+(assert
+ (compiler-typecase vec
+   ((vector-of boolean) #f)
+   (vector #t)))