* 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.
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.
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
changes in sbcl-1.0.28 relative to 1.0.27:
* a number of bugs in cross-compilation have been fixed, with the ultimate
;; :VARIABLE :TYPE is in the db only if it is declared, so no need to
;; check.
(let ((type (info :variable :type symbol)))
;; :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.)"
(let ((spec (type-specifier type)))
(error 'simple-type-error
:format-control "Cannot ~@? to ~S (not of type ~S.)"
(if (ctype-p specifier)
specifier
(specifier-type specifier))))
(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
(declare (type ctype type))
(etypecase type
(named-type
#+sb-xc-host (ctypep object type)
#-sb-xc-host (classoid-typep (layout-of object) type object))
(union-type
#+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)
(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)
(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))
(character-set-type
(and (characterp object)
(let ((code (char-code object))
(if (typep reparse 'unknown-type)
(error "unknown type specifier: ~S"
(unknown-type-specifier reparse))
(if (typep reparse 'unknown-type)
(error "unknown type specifier: ~S"
(unknown-type-specifier reparse))
- (%%typep object reparse))))
+ (%%typep object reparse strict))))
- (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
(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
(rest hairy-spec)))
;; Note: it should be safe to skip OR here, because union
;; types can always be represented as UNION-TYPE in general
(not
(unless (proper-list-of-length-p hairy-spec 2)
(error "invalid type specifier: ~S" hairy-spec))
(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))
(satisfies
(unless (proper-list-of-length-p hairy-spec 2)
(error "invalid type specifier: ~S" hairy-spec))
(alien-type-type
(sb!alien-internals:alien-typep object (alien-type-type-alien-type type)))
(fun-type
(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.
;;; Do a type test from a class cell, allowing forward reference and
;;; redefinition.
(setf *mystery* :mystery)
(assert (eq :ok (test-mystery (make-thing :slot :mystery))))
(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*))))
;;; 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".)
;;; 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".)