1.0.18.1: correct handling of SATISFIES types in the compiler

 * CTYPEP used to retur a secondary value of true in cases where the
   function in question was not foldable.

 * Slightly sleazily extent SB-C::CONSTANT-FUNCTION-CALL-P (part of
   CONSTANTP) to return the primary result of the call as the
   secondary value, so CTYPEP can use it.

 * Test-case.

diff --git a/NEWS b/NEWS
index 71373b6..48e1ed6 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -1,4 +1,8 @@
 ;;;; -*- coding: utf-8; -*-
+changes in sbcl-1.0.19 relative to 1.0.18:
+  * bug fix: compiler no longer makes erronous assumptions in the
+    presense of non-foldable SATISFIES types.
+
 changes in sbcl-1.0.18 relative to 1.0.17:
   * minor incompatible change: SB-SPROF:WITH-PROFILING now by default
     profiles only the current thread.

diff --git a/src/code/target-type.lisp b/src/code/target-type.lisp
index 665b453..a3775fb 100644 (file)
--- a/src/code/target-type.lisp
+++ b/src/code/target-type.lisp
@@ -85,30 +85,11 @@
                 (values (not res) t)
                 (values nil nil))))
          (satisfies
-          (let ((predicate-name (second hairy-spec)))
-            (declare (type symbol predicate-name)) ; by ANSI spec of SATISFIES
-            (if (fboundp predicate-name)
-                (let* (;; "Is OBJ of the SATISFIES type?" represented
-                       ;; as a generalized boolean.
-                       ;;
-                       ;; (Why IGNORE-ERRORS? This code is used to try to
-                       ;; check type relationships at compile time.
-                       ;; Passing only-slightly-twisted types like
-                       ;; (AND INTEGER (SATISFIES ODDP)) into the
-                       ;; rather-significantly-twisted type dispatch
-                       ;; system can easily give rise to oddities like
-                       ;; calling predicates like ODDP on values they
-                       ;; don't like. (E.g. on OBJ=#\NEWLINE when the
-                       ;; above type is tested for TYPE= against
-                       ;; STANDARD-CHAR, represented as a
-                       ;; MEMBER-TYPE.) In such cases, NIL seems to be
-                       ;; an appropriate answer to "is OBJ of the
-                       ;; SATISFIES type?")
-                       (gbool (ignore-errors (funcall predicate-name obj)))
-                       ;; RAW coerced to a pure BOOLEAN value
-                       (bool (not (not gbool))))
-                  (values bool t))
-                (values nil nil)))))))))
+          ;; If the SATISFIES function is not foldable, we cannot answer!
+          (let* ((form `(,(second hairy-spec) ',obj)))
+            (multiple-value-bind (ok result)
+                (sb!c::constant-function-call-p form nil nil)
+              (values (not (null result)) ok)))))))))
 \f
 ;;; Return the layout for an object. This is the basic operation for
 ;;; finding out the "type" of an object, and is used for generic

diff --git a/src/compiler/constantp.lisp b/src/compiler/constantp.lisp
index 29252c2..85bb5b8 100644 (file)
--- a/src/compiler/constantp.lisp
+++ b/src/compiler/constantp.lisp
@@ -40,7 +40,7 @@
       (list
        (or (constant-special-form-p form environment envp)
            #-sb-xc-host
-           (constant-function-call-p form environment envp)))
+           (values (constant-function-call-p form environment envp))))
       (t t))))
 
 (defun %constant-form-value (form environment envp)
@@ -76,21 +76,21 @@
 ;;; too.
 (defun constant-function-call-p (form environment envp)
   (let ((name (car form)))
-    (and (legal-fun-name-p name)
-         (eq :function (info :function :kind name))
-         (let ((info (info :function :info name)))
-           (and info (ir1-attributep (fun-info-attributes info)
-                                     foldable)))
-         (and (every (lambda (arg)
-                       (%constantp arg environment envp))
-                     (cdr form))
-              ;; Even though the function may be marked as foldable
-              ;; the call may still signal an error -- eg: (CAR 1).
-              (handler-case
-                  (progn
-                    (constant-function-call-value form environment envp)
-                    t)
-                (error () nil))))))
+    (if (and (legal-fun-name-p name)
+             (eq :function (info :function :kind name))
+             (let ((info (info :function :info name)))
+               (and info (ir1-attributep (fun-info-attributes info)
+                                         foldable)))
+             (and (every (lambda (arg)
+                           (%constantp arg environment envp))
+                         (cdr form))))
+        ;; Even though the function may be marked as foldable
+        ;; the call may still signal an error -- eg: (CAR 1).
+        (handler-case
+            (values t (constant-function-call-value form environment envp))
+          (error ()
+            (values nil nil)))
+        (values nil nil))))
 
 (defun constant-function-call-value (form environment envp)
   (apply (fdefinition (car form))

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index 21b4171..84dd848 100644 (file)
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -1669,4 +1669,13 @@
       (test f1 f2)
       (test f1 c2))))
 
+;;; user-defined satisfies-types cannot be folded
+(deftype mystery () '(satisfies mysteryp))
+(defvar *mystery* nil)
+(defun mysteryp (x) (eq x *mystery*))
+(defstruct thing (slot (error "missing") :type mystery))
+(defun test-mystery (m) (when (eq :mystery (thing-slot m)) :ok))
+(setf *mystery* :mystery)
+(assert (eq :ok (test-mystery (make-thing :slot :mystery))))
+
 ;;; success

diff --git a/version.lisp-expr b/version.lisp-expr
index dce91e1..1071b41 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.18"
+"1.0.18.1"