~ chicken-core (chicken-5) 8fb1176ff3bad8dd10a29ba87f979aeebd1dbc98

commit 8fb1176ff3bad8dd10a29ba87f979aeebd1dbc98
Author:     Evan Hanson <evhan@foldling.org>
AuthorDate: Mon Feb 15 22:13:35 2016 +1300
Commit:     Peter Bex <peter@more-magic.net>
CommitDate: Sat Jun 18 16:30:33 2016 +0200

    Drop consequent branch for conditionals that are always false
    
    Also, add a line number prefix to the scrutiny messages for the
    always-true and always-false situations, just in case we have enough
    info to print them.
    
    Signed-off-by: Peter Bex <peter@more-magic.net>

diff --git a/distribution/manifest b/distribution/manifest
index 4ce955ff..67dd43db 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -179,9 +179,11 @@ tests/test.scm
 tests/loopy-test.scm
 tests/loopy-loop.scm
 tests/r5rs_pitfalls.scm
+tests/specialization-tests.scm
 tests/specialization-test-1.scm
 tests/specialization-test-2.scm
 tests/specialization-test-2.types
+tests/specialization.expected
 tests/test-irregex.scm
 tests/re-tests.txt
 tests/lolevel-tests.scm
diff --git a/scrutinizer.scm b/scrutinizer.scm
index d2ce3582..2221cf98 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -210,15 +210,20 @@
 	    ((memq t '(* boolean false undefined noreturn)) #f)
 	    (else #t)))
 
-    (define (always-true t loc x)
-      (let ((f (always-true1 t)))
-	(when f
-	  (report-notice
-	   loc
-	   "expected a value of type boolean in conditional, but \
-	    was given a value of type `~a' which is always true:~%~%~a"
-	   t (pp-fragment x)))
-	f))
+    (define (always-true if-node test-node t loc)
+      (and-let* ((_ (always-true1 t)))
+	(report-notice
+	 loc "~aexpected a value of type boolean in conditional, but \
+	 was given a value of type `~a' which is always true:~%~%~a"
+	 (node-source-prefix test-node) t (pp-fragment if-node))
+	#t))
+
+    (define (always-false if-node test-node t loc)
+      (and-let* ((_ (eq? t 'false)))
+	(report-notice
+	 loc "~ain conditional, test expression will always return false:~%~%~a"
+	 (node-source-prefix test-node) (pp-fragment if-node))
+	#t))
 
     (define (single node what tv loc)
       (if (eq? '* tv)
@@ -483,10 +488,13 @@
 			   (a (third subs))
 			   (nor0 noreturn))
 		      (cond
-			((and (always-true rt loc n) specialize)
-			 ;; drop branch and re-walk updated node
+			((and (always-true n tst rt loc) specialize)
 			 (set! dropped-branches (add1 dropped-branches))
-			 (copy-node! (build-node-graph `(let ((,(gensym) ,tst)) ,c)) n)
+			 (mutate-node! n `(let ((,(gensym) ,tst)) ,c))
+			 (walk n e loc dest tail flow ctags))
+			((and (always-false n tst rt loc) specialize)
+			 (set! dropped-branches (add1 dropped-branches))
+			 (mutate-node! n `(let ((,(gensym) ,tst)) ,a))
 			 (walk n e loc dest tail flow ctags))
 			(else
 			 (let* ((r1 (walk c e loc dest tail (cons (car tags) flow) #f))
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 3f548dd2..d5d6f8e3 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -82,16 +82,22 @@ $compile inlining-tests.scm -optimize-level 3
 ./a.out
 
 echo "======================================== scrutiny tests ..."
-$compile typematch-tests.scm -specialize -w
+$compile typematch-tests.scm -specialize -no-warnings
 ./a.out
-$compile scrutiny-tests.scm -A -scrutinize 2>scrutiny.out -verbose
 
-# this is sensitive to gensym-names, so make it optional
+$compile scrutiny-tests.scm -analyze-only -verbose 2>scrutiny.out
+$compile specialization-tests.scm -analyze-only -verbose -specialize 2>specialization.out
+
+# these are sensitive to gensym-names, so make them optional
 if test \! -f scrutiny.expected; then
     cp scrutiny.out scrutiny.expected
 fi
+if test \! -f specialization.expected; then
+    cp specialization.out specialization.expected
+fi
 
 diff $DIFF_OPTS scrutiny.expected scrutiny.out
+diff $DIFF_OPTS specialization.expected specialization.out
 
 $compile scrutiny-tests-2.scm -A -scrutinize -analyze-only 2>scrutiny-2.out -verbose
 
diff --git a/tests/specialization-tests.scm b/tests/specialization-tests.scm
new file mode 100644
index 00000000..667b65c7
--- /dev/null
+++ b/tests/specialization-tests.scm
@@ -0,0 +1,4 @@
+;; both arms of if branches are dropped
+
+(let ((a "yep")) (if (string? a) 'ok 'no))
+(let ((a 'nope)) (if (string? a) 'ok 'no))
diff --git a/tests/specialization.expected b/tests/specialization.expected
new file mode 100644
index 00000000..9ae2fc56
--- /dev/null
+++ b/tests/specialization.expected
@@ -0,0 +1,16 @@
+
+Note: at toplevel:
+  (specialization-tests.scm:3) in procedure call to `string?', the predicate is called with an argument of type `string' and will always return true
+
+Note: at toplevel:
+  (specialization-tests.scm:3) expected a value of type boolean in conditional, but was given a value of type `true' which is always true:
+
+(if (string? a) 'ok 'no)
+
+Note: at toplevel:
+  (specialization-tests.scm:4) in procedure call to `string?', the predicate is called with an argument of type `symbol' and will always return false
+
+Note: at toplevel:
+  (specialization-tests.scm:4) in conditional, test expression will always return false:
+
+(if (string? a) 'ok 'no)