1.0.21.1: address TYPE-WARNING in CLOS allocator for funcallable structures

	... parallel %make-funcallable-structure-allocator;
	... make FUNCTION-classoid-subclasses into CLOS classes in FIXUP
	... also make !DEFSTRUCT-W-A-M respect *DEFSTRUCT-HOOKS* just
		in case.
	... test.

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 2cb78b8..f5e22ab 100644 (file)
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -1231,6 +1231,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                "%LOG1P"
                #!+long-float "%LONG-FLOAT"
                "%MAKE-COMPLEX" "%MAKE-FUNCALLABLE-INSTANCE"
+               "%MAKE-FUNCALLABLE-STRUCTURE-INSTANCE-ALLOCATOR"
                "%MAKE-RATIO" "%MAKE-LISP-OBJ"
                "%MAKE-INSTANCE"
                "%MAKE-STRUCTURE-INSTANCE"

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index dc18208..9743b65 100644 (file)
--- a/src/code/defstruct.lisp
+++ b/src/code/defstruct.lisp
@@ -47,12 +47,25 @@
                                    ,@slot-vars))))))
 
 (declaim (ftype (sfunction (defstruct-description list) function)
-                %Make-structure-instance-allocator))
+                %make-structure-instance-allocator))
 (defun %make-structure-instance-allocator (dd slot-specs)
   (let ((vars (make-gensym-list (length slot-specs))))
     (values (compile nil `(lambda (,@vars)
                             (%make-structure-instance-macro ,dd ',slot-specs ,@vars))))))
 
+(defun %make-funcallable-structure-instance-allocator (dd slot-specs)
+  (when slot-specs
+    (bug "funcallable-structure-instance allocation with slots unimplemented"))
+  (let ((name (dd-name dd))
+        (length (dd-length dd))
+        (nobject (gensym "OBJECT")))
+    (values
+     (compile nil `(lambda ()
+                     (let ((,nobject (%make-funcallable-instance ,length)))
+                       (setf (%funcallable-instance-layout ,nobject)
+                             (%delayed-get-compiler-layout ,name))
+                       ,nobject))))))
+
 ;;; Delay looking for compiler-layout until the constructor is being
 ;;; compiled, since it doesn't exist until after the EVAL-WHEN
 ;;; (COMPILE) stuff is compiled. (Or, in the oddball case when
@@ -1701,6 +1714,8 @@
       (eval-when (:compile-toplevel :load-toplevel :execute)
         (%compiler-set-up-layout ',dd ',(inherits-for-structure dd))))))
 
+(sb!xc:proclaim '(special *defstruct-hooks*))
+
 (sb!xc:defmacro !defstruct-with-alternate-metaclass
     (class-name &key
                 (slot-names (missing-arg))
@@ -1795,7 +1810,11 @@
              ;; code, which knows how to generate inline type tests
              ;; for the whole CMU CL INSTANCE menagerie.
              `(defun ,predicate (,object-gensym)
-                (typep ,object-gensym ',class-name)))))))
+                (typep ,object-gensym ',class-name)))
+
+         (when (boundp '*defstruct-hooks*)
+           (dolist (fun *defstruct-hooks*)
+             (funcall fun (find-classoid ',(dd-name dd)))))))))
 \f
 ;;;; finalizing bootstrapping
 

diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp
index bf3dc71..674519e 100644 (file)
--- a/src/pcl/defs.lisp
+++ b/src/pcl/defs.lisp
@@ -680,15 +680,9 @@
 (defclass condition-class (slot-class) ())
 
 (defclass structure-class (slot-class)
-  ((defstruct-form
-     :initform ()
-     :accessor class-defstruct-form)
-   (defstruct-constructor
-     :initform nil
-     :accessor class-defstruct-constructor)
-   (from-defclass-p
-    :initform nil
-    :initarg :from-defclass-p)))
+  ((defstruct-form :initform () :accessor class-defstruct-form)
+   (defstruct-constructor :initform nil :accessor class-defstruct-constructor)
+   (from-defclass-p :initform nil :initarg :from-defclass-p)))
 
 (defclass definition-source-mixin (standard-object)
   ((source

diff --git a/src/pcl/fixup.lisp b/src/pcl/fixup.lisp
index 6244ebb..2ea6fb9 100644 (file)
--- a/src/pcl/fixup.lisp
+++ b/src/pcl/fixup.lisp
@@ -26,7 +26,7 @@
 (!fix-early-generic-functions)
 (!fix-ensure-accessor-specializers)
 (compute-standard-slot-locations)
-(dolist (s '(condition structure-object))
+(dolist (s '(condition function structure-object))
   (dohash ((k v) (classoid-subclasses (find-classoid s)))
     (find-class (classoid-name k))))
 (setq *boot-state* 'complete)
@@ -34,4 +34,3 @@
 (defun print-std-instance (instance stream depth)
   (declare (ignore depth))
   (print-object instance stream))
-

diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index 675d115..ab1406f 100644 (file)
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -658,7 +658,11 @@
 (defun make-defstruct-allocation-function (name)
   ;; FIXME: Why don't we go class->layout->info == dd
   (let ((dd (find-defstruct-description name)))
-    (%make-structure-instance-allocator dd nil)))
+    (ecase (dd-type dd)
+      (structure
+       (%make-structure-instance-allocator dd nil))
+      (funcallable-structure
+       (%make-funcallable-structure-instance-allocator dd nil)))))
 
 (defmethod shared-initialize :after
     ((class structure-class) slot-names &key

diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp
index e1e0b73..b5e981f 100644 (file)
--- a/tests/type.impure.lisp
+++ b/tests/type.impure.lisp
@@ -435,6 +435,12 @@
 (with-test (:name (:ctor :functionp))
   (assert (functionp (sb-pcl::ensure-ctor
                       (list 'sb-pcl::ctor (gensym)) nil nil nil))))
+;;; some new (2008-10-03) ways of going wrong...
+(with-test (:name (:ctor-allocate-instance :typep-function))
+  (assert (eval '(typep (allocate-instance (find-class 'sb-pcl::ctor))
+                        'function))))
+(with-test (:name (:ctor-allocate-instance :functionp))
+  (assert (functionp (allocate-instance (find-class 'sb-pcl::ctor)))))
 \f
 ;;; from PFD ansi-tests
 (let ((t1 '(cons (cons (cons (real -744833699 -744833699) cons)

diff --git a/version.lisp-expr b/version.lisp-expr
index fd5c34c..f045380 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.21"
+"1.0.21.1"