From 75f37cd646778cc8d4bed86d79309b7161bd41dc Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Fri, 1 May 2009 10:54:28 +0000 Subject: [PATCH] 1.0.28.3: ABOUT-TO-MODIFY-SYMBOL-VALUE doesn't choke on FUNCTION subtypes MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit * 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. --- NEWS | 3 +++ src/code/early-extensions.lisp | 2 +- src/code/typep.lisp | 25 ++++++++++++++----------- tests/compiler.impure.lisp | 14 ++++++++++++++ version.lisp-expr | 2 +- 5 files changed, 33 insertions(+), 13 deletions(-) diff --git a/NEWS b/NEWS index f727ecf..b7a366b 100644 --- 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 --- 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 --- 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 --- 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 --- 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" -- 1.7.10.4