[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 01/01: Fix type inferencing for 'nil?' and 'null?' predi
From: |
Mark H. Weaver |
Subject: |
[Guile-commits] 01/01: Fix type inferencing for 'nil?' and 'null?' predicates. |
Date: |
Fri, 19 Oct 2018 21:10:03 -0400 (EDT) |
mhw pushed a commit to branch stable-2.2
in repository guile.
commit c3e14b74e81d0fd3266b97e6bd629cd4e2f98803
Author: Mark H Weaver <address@hidden>
Date: Sat Oct 13 23:02:05 2018 -0400
Fix type inferencing for 'nil?' and 'null?' predicates.
Fixes <https://bugs.gnu.org/33036>.
Reported by <address@hidden>.
* 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.
---
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 fc37fac..163ef65 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 5c1d712..61de971 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 4f644f3..64bb976 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 ()))))