From d904d5233582e51a4be06d2c08ccdd15a66b8d77 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Sat, 13 Oct 2018 23:02:05 -0400 Subject: [PATCH] Fix type inferencing for 'nil?' and 'null?' predicates. Fixes . Reported by . * 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*): Add &nil to the set of possible types. (*type-inferrers*): Add &false and &null to the set the possible types. * module/language/cps/type-fold.scm (*branch-folders*): Add &nil to the set of possible types. (*branch-folders*): Add &false and &null to the set the possible types. * test-suite/tests/compiler.test: Add tests. --- module/language/cps/type-fold.scm | 6 ++-- module/language/cps/types.scm | 13 ++++---- test-suite/tests/compiler.test | 51 ++++++++++++++++++++++++++++++- 3 files changed, 60 insertions(+), 10 deletions(-) diff --git a/module/language/cps/type-fold.scm b/module/language/cps/type-fold.scm index fc37fac50..163ef659d 100644 --- 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 5c1d71299..61de971fe 100644 --- 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 4f644f339..64bb976fa 100644 --- 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 ())))) -- 2.19.1