Fix type inferencing for 'nil?' and 'null?' predicates.

Fixes <https://bugs.gnu.org/33036>.
Reported by <calcium@disroot.org>.

* module/language/cps/types.scm (define-simple-type-inferrer):
Apply (logand (&type val) <>) uniformly.  Previously, this was done only
in the false branch.  Rename local variable to 'type*', to allow the
macro operand 'type' to be an arbitrary expression.
(*type-inferrers*)<null?>: Add &nil to the set of possible types.
(*type-inferrers*)<nil?>: Add &false and &null to the set the possible
types.
* module/language/cps/type-fold.scm (*branch-folders*)<null?>: Add &nil
to the set of possible types.
(*branch-folders*)<nil?>: Add &false and &null to the set the possible
types.
* test-suite/tests/compiler.test: Add tests.

diff --git a/module/language/cps/type-fold.scm b/module/language/cps/type-fold.scm
index fc37fac50f60c21ce76dde8d14a384533bf798cd..163ef659d0d11ccb63d46274d7f77a26ba56391d 100644 (file)
--- a/module/language/cps/type-fold.scm
+++ b/module/language/cps/type-fold.scm
@@ -1,5 +1,5 @@
 ;;; Abstract constant folding on CPS
-;;; Copyright (C) 2014, 2015 Free Software Foundation, Inc.
+;;; Copyright (C) 2014, 2015, 2018 Free Software Foundation, Inc.
 ;;;
 ;;; This library is free software: you can redistribute it and/or modify
 ;;; it under the terms of the GNU Lesser General Public License as
@@ -69,8 +69,8 @@
 
 ;; All the cases that are in compile-bytecode.
 (define-unary-type-predicate-folder pair? &pair)
-(define-unary-type-predicate-folder null? &null)
-(define-unary-type-predicate-folder nil? &nil)
+(define-unary-type-predicate-folder null? (logior &nil &null))
+(define-unary-type-predicate-folder nil? (logior &false &nil &null))
 (define-unary-type-predicate-folder symbol? &symbol)
 (define-unary-type-predicate-folder variable? &box)
 (define-unary-type-predicate-folder vector? &vector)

diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 5c1d712991b66ee5d0a3a304237ef6caf5cc1eb5..61de971fe1718240a389a662bd025b853f31e50c 100644 (file)
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -529,13 +529,14 @@ minimum, and maximum."
 
 (define-syntax-rule (define-simple-predicate-inferrer predicate type)
   (define-predicate-inferrer (predicate val true?)
-    (let ((type (if true?
-                    type
-                    (logand (&type val) (lognot type)))))
-      (restrict! val type -inf.0 +inf.0))))
+    (let ((type* (logand (&type val)
+                         (if true?
+                             type
+                             (lognot type)))))
+      (restrict! val type* -inf.0 +inf.0))))
 (define-simple-predicate-inferrer pair? &pair)
-(define-simple-predicate-inferrer null? &null)
-(define-simple-predicate-inferrer nil? &nil)
+(define-simple-predicate-inferrer null? (logior &nil &null))
+(define-simple-predicate-inferrer nil? (logior &false &nil &null))
 (define-simple-predicate-inferrer symbol? &symbol)
 (define-simple-predicate-inferrer variable? &box)
 (define-simple-predicate-inferrer vector? &vector)

diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test
index 4f644f339113ebb09ad66c77c97f2f8b315746c1..64bb976fa7eccd09708aab4be0d49f6b0189ecab 100644 (file)
--- a/test-suite/tests/compiler.test
+++ b/test-suite/tests/compiler.test
@@ -1,5 +1,5 @@
 ;;;; compiler.test --- tests for the compiler      -*- scheme -*-
-;;;; Copyright (C) 2008, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
+;;;; Copyright (C) 2008-2014, 2018 Free Software Foundation, Inc.
 ;;;; 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -251,3 +251,52 @@
 
   (pass-if-equal "test flonum" 0.0 (test-proc #t))
   (pass-if-equal "test complex" 0.0+0.0i (test-proc #f)))
+
+(with-test-prefix "null? and nil? inference"
+  (pass-if-equal "nil? after null?"
+      '((f . f)  ; 3
+        (f . f)  ; #t
+        (f . t)  ; #f
+        (t . t)  ; #nil
+        (t . t)) ; ()
+    (map (compile '(lambda (x)
+                     (if (null? x)
+                         (cons 't (if (nil? x) 't 'f))
+                         (cons 'f (if (nil? x) 't 'f)))))
+         '(3 #t #f #nil ())))
+
+  (pass-if-equal "nil? after truth test"
+      '((t . f)  ; 3
+        (t . f)  ; #t
+        (f . t)  ; #f
+        (f . t)  ; #nil
+        (t . t)) ; ()
+    (map (compile '(lambda (x)
+                     (if x
+                         (cons 't (if (nil? x) 't 'f))
+                         (cons 'f (if (nil? x) 't 'f)))))
+         '(3 #t #f #nil ())))
+
+  (pass-if-equal "null? after nil?"
+      '((f . f)  ; 3
+        (f . f)  ; #t
+        (t . f)  ; #f
+        (t . t)  ; #nil
+        (t . t)) ; ()
+    (map (compile '(lambda (x)
+                     (if (nil? x)
+                         (cons 't (if (null? x) 't 'f))
+                         (cons 'f (if (null? x) 't 'f)))))
+         '(3 #t #f #nil ())))
+
+  (pass-if-equal "truth test after nil?"
+      '((f . t)  ; 3
+        (f . t)  ; #t
+        (t . f)  ; #f
+        (t . f)  ; #nil
+        (t . t)) ; ()
+    (map (compile '(lambda (x)
+                     (if (nil? x)
+                         (cons 't (if x 't 'f))
+                         (cons 'f (if x 't 'f)))))
+         '(3 #t #f #nil ()))))