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.

diff --git a/NEWS b/NEWS
index bcb7628..cde12de 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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))))
 \f
+;;; 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))))
+\f
 ;;; success

diff --git a/version.lisp-expr b/version.lisp-expr
index 92349cf..3b2e5ff 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".)
-"0.9.4.28"
+"0.9.4.29"