From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!.POSTED!not-for-mail From: Mark H Weaver Newsgroups: gmane.lisp.guile.bugs Subject: bug#33036: Bug with the procedure nil? inside a specific code Date: Sun, 14 Oct 2018 00:05:21 -0400 Message-ID: <87r2gtuq9q.fsf@netris.org> References: <2cf0a45c-e973-79f5-6ab8-6794a68495d0@disroot.org> <87va65uyb3.fsf@netris.org> NNTP-Posting-Host: blaine.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: blaine.gmane.org 1539489849 25336 195.159.176.226 (14 Oct 2018 04:04:09 GMT) X-Complaints-To: usenet@blaine.gmane.org NNTP-Posting-Date: Sun, 14 Oct 2018 04:04:09 +0000 (UTC) User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/26.1 (gnu/linux) Cc: 33036@debbugs.gnu.org To: calcium Original-X-From: bug-guile-bounces+guile-bugs=m.gmane.org@gnu.org Sun Oct 14 06:04:05 2018 Return-path: Envelope-to: guile-bugs@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by blaine.gmane.org with esmtp (Exim 4.84_2) (envelope-from ) id 1gBXdJ-0006Q0-Rq for guile-bugs@m.gmane.org; Sun, 14 Oct 2018 06:04:02 +0200 Original-Received: from localhost ([::1]:47016 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1gBXfQ-00088z-0P for guile-bugs@m.gmane.org; Sun, 14 Oct 2018 00:06:12 -0400 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:40880) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1gBXfK-00088i-9r for bug-guile@gnu.org; Sun, 14 Oct 2018 00:06:07 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1gBXfH-00026m-2y for bug-guile@gnu.org; Sun, 14 Oct 2018 00:06:06 -0400 Original-Received: from debbugs.gnu.org ([208.118.235.43]:44430) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1gBXfG-00026e-Sp for bug-guile@gnu.org; Sun, 14 Oct 2018 00:06:02 -0400 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1gBXfG-0005Sj-HK for bug-guile@gnu.org; Sun, 14 Oct 2018 00:06:02 -0400 X-Loop: help-debbugs@gnu.org Resent-From: Mark H Weaver Original-Sender: "Debbugs-submit" Resent-CC: bug-guile@gnu.org Resent-Date: Sun, 14 Oct 2018 04:06:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 33036 X-GNU-PR-Package: guile X-GNU-PR-Keywords: Original-Received: via spool by 33036-submit@debbugs.gnu.org id=B33036.153948994620972 (code B ref 33036); Sun, 14 Oct 2018 04:06:02 +0000 Original-Received: (at 33036) by debbugs.gnu.org; 14 Oct 2018 04:05:46 +0000 Original-Received: from localhost ([127.0.0.1]:48688 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1gBXez-0005SC-Oj for submit@debbugs.gnu.org; Sun, 14 Oct 2018 00:05:46 -0400 Original-Received: from world.peace.net ([64.112.178.59]:36630) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1gBXex-0005Rz-Ps for 33036@debbugs.gnu.org; Sun, 14 Oct 2018 00:05:44 -0400 Original-Received: from mhw by world.peace.net with esmtpsa (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.89) (envelope-from ) id 1gBXer-0000wd-37; Sun, 14 Oct 2018 00:05:37 -0400 In-Reply-To: <87va65uyb3.fsf@netris.org> (Mark H. Weaver's message of "Sat, 13 Oct 2018 21:11:44 -0400") X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 208.118.235.43 X-BeenThere: bug-guile@gnu.org List-Id: "Bug reports for GUILE, GNU's Ubiquitous Extension Language" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-guile-bounces+guile-bugs=m.gmane.org@gnu.org Original-Sender: "bug-guile" Xref: news.gmane.org gmane.lisp.guile.bugs:9183 Archived-At: --=-=-= Content-Type: text/plain Mark H Weaver writes: > calcium writes: >> Here is the bug that I found : >> >> ;;; -START- code with the bug -START- ;;; >> >> (define (strange lst) >> (let loop ((lst lst) >> (is-empty '())) >> (cond ((nil? lst) >> (if (nil? is-empty) 'works >> (list 'should-not-occur is-empty))) >> (else >> (loop (cdr lst) >> is-empty))))) >> >> (strange '()) >> => (should-not-occur ()) >> >> (strange #nil) >> => (should-not-occur ()) > > Indeed, this certainly indicates a bug. > > I believe the bug is in 'local-type-fold' in (language cps type-fold). > It contains a local procedure 'scalar-value' which, if I understand > correctly, seems to incorrectly assume that (nil? x) returns #t if and > only if X is 'eq?' to #nil. The bug actually wasn't in 'local-type-fold', but it's true that the type inferencer assumed in a few places that if (nil? X) returned #t that X must be #nil, and similarly for 'null?' and (). I've attached a proposed fix. Andy, does this fix look right to you? Thanks, Mark --=-=-= Content-Type: text/x-patch Content-Disposition: inline; filename=0001-Fix-type-inferencing-for-nil-and-null-predicates.patch Content-Description: [PATCH] Fix type inferencing for 'nil?' and 'null?' predicates >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 --=-=-=--