>From 6ca2c189742d3cc66f14bfb0a48cef9d81cd23c0 Mon Sep 17 00:00:00 2001
From: Evan Hanson <address@hidden>
Date: Mon, 15 Feb 2016 22:13:35 +1300
Subject: [PATCH 2/4] 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.
---
 distribution/manifest          |  2 ++
 scrutinizer.scm                | 32 ++++++++++++++++++++------------
 tests/runtests.sh              | 12 +++++++++---
 tests/specialization-tests.scm |  4 ++++
 tests/specialization.expected  | 16 ++++++++++++++++
 5 files changed, 51 insertions(+), 15 deletions(-)
 create mode 100644 tests/specialization-tests.scm
 create mode 100644 tests/specialization.expected

diff --git a/distribution/manifest b/distribution/manifest
index 0160f89..6646237 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -174,9 +174,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 4d4cf5b..9734d2e 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -216,15 +216,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)
@@ -488,10 +493,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 b02b716..7813d79 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -95,16 +95,22 @@ $compile null.scm -profile -profile-name TEST.profile
 $CHICKEN_PROFILE TEST.profile
 
 echo "======================================== scrutiny tests ..."
-$compile typematch-tests.scm -specialize -w
+$compile typematch-tests.scm -specialize -no-warnings
 ./a.out
-$compile scrutiny-tests.scm -A 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 2>scrutiny-2.out -verbose
 
diff --git a/tests/specialization-tests.scm b/tests/specialization-tests.scm
new file mode 100644
index 0000000..667b65c
--- /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 0000000..9ae2fc5
--- /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)
-- 
2.7.0.rc3