~ chicken-core (chicken-5) 523cdeae141e59d7afe9d6fabeebafc135513f52

commit 523cdeae141e59d7afe9d6fabeebafc135513f52
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Tue Mar 29 12:40:35 2011 -0400
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Tue Mar 29 12:40:35 2011 -0400

    only assume if enforcing

diff --git a/scrutinizer.scm b/scrutinizer.scm
index 24d5b6e4..d43d3ac6 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -63,6 +63,7 @@
 ;   ##compiler#declared-type   ->  BOOL
 ;   ##compiler#predicate       ->  TYPESPEC
 ;   ##compiler#specializations -> (SPECIALIZATION ...)
+;   ##compiler#enforce-argument-types -> BOOL
 ;
 ; specialization specifiers:
 ;
@@ -713,6 +714,7 @@
 				  (iota len)))
 		       (fn (car args))
 		       (pn (procedure-name fn))
+		       (enforces (and pn (##sys#get pn '##compiler#enforce-argument-types)))
 		       (pt (and pn (##sys#get pn '##compiler#predicate))))
 		  (let ((r (call-result n args e loc params)))
 		    (invalidate-blist)
@@ -728,13 +730,13 @@
 				  (set! blist 
 				    (alist-cons (cons var (car ctags)) pt blist)))
 				 (a
-				  ;;XXX do this only if declared "enforce-argument-types"
-				  (let ((ar (cond ((get db var 'assigned) '*)
-						  ((eq? '* argr) (cdr a))
-						  (else argr))))
-				    (d "assuming: ~a -> ~a (flow: ~a)" var ar (car flow))
-				    (set! blist 
-				      (alist-cons (cons var (car flow)) ar blist))))))))
+				  (when enforces
+				    (let ((ar (cond ((get db var 'assigned) '*)
+						    ((eq? '* argr) (cdr a))
+						    (else argr))))
+				      (d "assuming: ~a -> ~a (flow: ~a)" var ar (car flow))
+				      (set! blist 
+					(alist-cons (cons var (car flow)) ar blist)))))))))
 		     subs
 		     (cons fn (procedure-argument-types fn (sub1 len))))
 		    r)))