1.0.28.3: ABOUT-TO-MODIFY-SYMBOL-VALUE doesn't choke on FUNCTION subtypes

 * Evaluating eg. a SET when the type of the variable as been
   proclaimed to be a subtype of FUNCTION used to break, since
   ABOUT-TO-MODIFY-SYMBOL-VALUE uses %%TYPEP to check the type, and
   function subtypes are not normally acceptable type specifiers to
   TYPEP.

   SBCL is, however, able to reason about such types, so we add an
   optional STRICT argument to %%TYPEP defaulting to T, which
   A-T-M-S-V give as NIL to allow checking of function subtypes.

   Reported by Lorenz Mösenlechner.

diff --git a/NEWS b/NEWS
index f727ecf..b7a366b 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -3,6 +3,9 @@
     not just x86-64. (reported by Ken Olum)
   * bug fix: #201; type inference for CONS and ARRAY types could derive
     wrong results in the presence of eg. RPLACA or ADJUST-ARRAY.
+  * bug fix: special variables with a proclaimed specific subtype of FUNCTION
+    could not be assigned to or bound with PROGV. (reported by Lorenz
+    Mösenlechner)
 
 changes in sbcl-1.0.28 relative to 1.0.27:
   * a number of bugs in cross-compilation have been fixed, with the ultimate

diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp
index 3d1a9b7..0e1d52a 100644 (file)
--- a/src/code/early-extensions.lisp
+++ b/src/code/early-extensions.lisp
@@ -789,7 +789,7 @@
       ;; :VARIABLE :TYPE is in the db only if it is declared, so no need to
       ;; check.
       (let ((type (info :variable :type symbol)))
-        (unless (sb!kernel::%%typep new-value type)
+        (unless (sb!kernel::%%typep new-value type nil)
           (let ((spec (type-specifier type)))
             (error 'simple-type-error
                    :format-control "Cannot ~@? to ~S (not of type ~S.)"

diff --git a/src/code/typep.lisp b/src/code/typep.lisp
index 43acfdf..ccd6641 100644 (file)
--- a/src/code/typep.lisp
+++ b/src/code/typep.lisp
@@ -31,7 +31,7 @@
            (if (ctype-p specifier)
                specifier
                (specifier-type specifier))))
-(defun %%typep (object type)
+(defun %%typep (object type &optional (strict t))
   (declare (type ctype type))
   (etypecase type
     (named-type
@@ -111,16 +111,16 @@
      #+sb-xc-host (ctypep object type)
      #-sb-xc-host (classoid-typep (layout-of object) type object))
     (union-type
-     (some (lambda (union-type-type) (%%typep object union-type-type))
+     (some (lambda (union-type-type) (%%typep object union-type-type strict))
            (union-type-types type)))
     (intersection-type
      (every (lambda (intersection-type-type)
-              (%%typep object intersection-type-type))
+              (%%typep object intersection-type-type strict))
             (intersection-type-types type)))
     (cons-type
      (and (consp object)
-          (%%typep (car object) (cons-type-car-type type))
-          (%%typep (cdr object) (cons-type-cdr-type type))))
+          (%%typep (car object) (cons-type-car-type type) strict)
+          (%%typep (cdr object) (cons-type-cdr-type type) strict)))
     (character-set-type
      (and (characterp object)
          (let ((code (char-code object))
@@ -137,16 +137,16 @@
        (if (typep reparse 'unknown-type)
            (error "unknown type specifier: ~S"
                   (unknown-type-specifier reparse))
-           (%%typep object reparse))))
+           (%%typep object reparse strict))))
     (negation-type
-     (not (%%typep object (negation-type-type type))))
+     (not (%%typep object (negation-type-type type) strict)))
     (hairy-type
      ;; Now the tricky stuff.
      (let* ((hairy-spec (hairy-type-specifier type))
             (symbol (car hairy-spec)))
        (ecase symbol
          (and
-          (every (lambda (spec) (%%typep object (specifier-type spec)))
+          (every (lambda (spec) (%%typep object (specifier-type spec) strict))
                  (rest hairy-spec)))
          ;; Note: it should be safe to skip OR here, because union
          ;; types can always be represented as UNION-TYPE in general
@@ -155,7 +155,7 @@
          (not
           (unless (proper-list-of-length-p hairy-spec 2)
             (error "invalid type specifier: ~S" hairy-spec))
-          (not (%%typep object (specifier-type (cadr hairy-spec)))))
+          (not (%%typep object (specifier-type (cadr hairy-spec)) strict)))
          (satisfies
           (unless (proper-list-of-length-p hairy-spec 2)
             (error "invalid type specifier: ~S" hairy-spec))
@@ -163,8 +163,11 @@
     (alien-type-type
      (sb!alien-internals:alien-typep object (alien-type-type-alien-type type)))
     (fun-type
-     (error "Function types are not a legal argument to TYPEP:~%  ~S"
-            (type-specifier type)))))
+     (if strict
+         (error "Function types are not a legal argument to TYPEP:~%  ~S"
+                (type-specifier type))
+         (and (functionp object)
+              (csubtypep (specifier-type (sb!impl::%fun-type object)) type))))))
 
 ;;; Do a type test from a class cell, allowing forward reference and
 ;;; redefinition.

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index 87c2265..ef9d8b0 100644 (file)
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -1820,4 +1820,18 @@
 (setf *mystery* :mystery)
 (assert (eq :ok (test-mystery (make-thing :slot :mystery))))
 
+;;; PROGV compilation and type checking when the declared type
+;;; includes a FUNCTION subtype.
+(declaim (type (or (function (t) (values boolean &optional)) string)
+               *hairy-progv-var*))
+(defvar *hairy-progv-var* #'null)
+(with-test (:name :hairy-progv-type-checking)
+  (assert (eq :error
+              (handler-case
+                  (progv '(*hairy-progv-var*) (list (eval 42))
+                    *hairy-progv-var*)
+                (type-error () :error))))
+  (assert (equal "GOOD!"
+                 (progv '(*hairy-progv-var*) (list (eval "GOOD!"))
+                    *hairy-progv-var*))))
 ;;; success

diff --git a/version.lisp-expr b/version.lisp-expr
index 7cc4d15..c3678a9 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.28.2"
+"1.0.28.3"