From 34664ac9b1d27f0dff2514c388cf10813a9b1108 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Tue, 6 Sep 2005 15:58:55 +0000 Subject: [PATCH] 0.9.4.29: Make FUNCTIONP and (TYPEP x 'FUNCTION) consistent ... alternate-metaclasses with dd-type funcallable-structure had better have FUNCTION somewhere in their INHERITS. ... we don't support inheritance in alternate-metaclasses, so BUG if we ask for it. --- NEWS | 2 ++ src/code/defstruct.lisp | 27 ++++++++++++++++++++------- src/pcl/ctor.lisp | 2 +- tests/type.impure.lisp | 11 +++++++++++ version.lisp-expr | 2 +- 5 files changed, 35 insertions(+), 9 deletions(-) diff --git a/NEWS b/NEWS index bcb7628..cde12de 100644 --- a/NEWS +++ b/NEWS @@ -26,6 +26,8 @@ changes in sbcl-0.9.5 relative to sbcl-0.9.4: * bug fix: the logic for getting names of functions gets less confused when confronded with alternate-metaclass funcallable-instances. (reported by Cyrus Harmon) + * bug fix: FUNCTIONP and (LAMBDA (X) (TYPEP X 'FUNCTION)) are now + consistent, even on internal alternate-metaclass objects. * threads ** bug fix: parent thread now can be gc'ed even with a live child thread diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 10a1a40..5b6004d 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -931,12 +931,16 @@ ;;; !DEFSTRUCT-WITH-ALTERNATE-METACLASS weirdosities (defun %compiler-set-up-layout (dd &optional - ;; Several special cases (STRUCTURE-OBJECT - ;; itself, and structures with alternate - ;; metaclasses) call this function directly, - ;; and they're all at the base of the - ;; instance class structure, so this is - ;; a handy default. + ;; Several special cases + ;; (STRUCTURE-OBJECT itself, and + ;; structures with alternate + ;; metaclasses) call this function + ;; directly, and they're all at the + ;; base of the instance class + ;; structure, so this is a handy + ;; default. (But note + ;; FUNCALLABLE-STRUCTUREs need + ;; assistance here) (inherits (vector (find-layout t) (find-layout 'instance)))) @@ -1522,6 +1526,15 @@ reversed-result) (incf index)) (nreverse reversed-result)))) + (case dd-type + ;; We don't support inheritance of alternate metaclass stuff, + ;; and it's not a general-purpose facility, so sanity check our + ;; own code. + (structure + (aver (eq superclass-name 'instance))) + (funcallable-structure + (aver (eq superclass-name 'funcallable-instance))) + (t (bug "Unknown DD-TYPE in ALTERNATE-METACLASS: ~S" dd-type))) (setf (dd-alternate-metaclass dd) (list superclass-name metaclass-name metaclass-constructor) @@ -1580,7 +1593,7 @@ `(progn (eval-when (:compile-toplevel :load-toplevel :execute) - (%compiler-set-up-layout ',dd)) + (%compiler-set-up-layout ',dd ',(inherits-for-structure dd))) ;; slot readers and writers (declaim (inline ,@(mapcar #'dsd-accessor-name dd-slots))) diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp index b37beaf..39c1129 100644 --- a/src/pcl/ctor.lisp +++ b/src/pcl/ctor.lisp @@ -109,7 +109,7 @@ (!defstruct-with-alternate-metaclass ctor :slot-names (function-name class-name class initargs) :boa-constructor %make-ctor - :superclass-name pcl-funcallable-instance + :superclass-name funcallable-instance :metaclass-name random-pcl-classoid :metaclass-constructor make-random-pcl-classoid :dd-type funcallable-structure diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp index 0b7bb17..b2ac327 100644 --- a/tests/type.impure.lisp +++ b/tests/type.impure.lisp @@ -11,6 +11,7 @@ (load "assertoid.lisp") (use-package "ASSERTOID") +(use-package "TEST-UTIL") (defmacro assert-nil-nil (expr) `(assert (equal '(nil nil) (multiple-value-list ,expr)))) @@ -429,4 +430,14 @@ (assert-t-t (subtypep `(not ,t2) `(not ,t1))) (assert-nil-t (subtypep `(not ,t1) `(not ,t2)))) +;;; not easily visible to user code, but this used to be very +;;; confusing. +(with-test (:name (:ctor :typep-function)) + (assert (eval '(typep (sb-pcl::ensure-ctor + (list 'sb-pcl::ctor (gensym)) nil nil) + 'function)))) +(with-test (:name (:ctor :functionp)) + (assert (functionp (sb-pcl::ensure-ctor + (list 'sb-pcl::ctor (gensym)) nil nil)))) + ;;; success diff --git a/version.lisp-expr b/version.lisp-expr index 92349cf..3b2e5ff 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".) -"0.9.4.28" +"0.9.4.29" -- 1.7.10.4