0.8alpha.0.34:

	Make ALLOCATE-INSTANCE work on all structure classes
	... if we're defined by a DEFSTRUCT, then make a closure to
		allocate an instance.

diff --git a/NEWS b/NEWS
index 6363d6c..891ee67 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -1739,6 +1739,9 @@ changes in sbcl-0.8.0 relative to sbcl-0.8alpha.0
        no method was removed.
     ** SHARED-INITIALIZE now initializes the values of the requested
        slots, including those with :ALLOCATION :CLASS.
+    ** ALLOCATE-INSTANCE now works on structure classes defined via
+       DEFSTRUCT (and not just by those from DEFCLASS :METACLASS
+       STRUCTURE-CLASS).
 
 planned incompatible changes in 0.8.x:
   * (not done yet, but planned:) When the profiling interface settles

diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index a653842..5ac2608 100644 (file)
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -678,6 +678,19 @@
                (cons nil nil))))
     (values defstruct-form constructor reader-names writer-names)))
 
+(defun make-defstruct-allocation-function (class)
+  (let ((dd (get-structure-dd (class-name class))))
+    (lambda ()
+      (let ((instance (%make-instance (dd-length dd)))
+           (raw-index (dd-raw-index dd)))
+       (setf (%instance-layout instance)
+             (sb-kernel::compiler-layout-or-lose (dd-name dd)))
+       (when raw-index
+         (setf (%instance-ref instance raw-index)
+               (make-array (dd-raw-length dd)
+                           :element-type '(unsigned-byte 32))))
+       instance))))
+
 (defmethod shared-initialize :after
       ((class structure-class)
        slot-names
@@ -712,22 +725,24 @@
                              (make-direct-slotd class pl))
                            direct-slots)))
        (setq direct-slots (slot-value class 'direct-slots)))
-    (when defstruct-p
-      (let ((include (car (slot-value class 'direct-superclasses))))
-        (multiple-value-bind (defstruct-form constructor reader-names writer-names)
-            (make-structure-class-defstruct-form name direct-slots include)
-          (unless (structure-type-p name) (eval defstruct-form))
-          (mapc (lambda (dslotd reader-name writer-name)
-                 (let* ((reader (gdefinition reader-name))
-                        (writer (when (gboundp writer-name)
-                                  (gdefinition writer-name))))
-                   (setf (slot-value dslotd 'internal-reader-function)
-                         reader)
-                   (setf (slot-value dslotd 'internal-writer-function)
-                         writer)))
-                direct-slots reader-names writer-names)
-          (setf (slot-value class 'defstruct-form) defstruct-form)
-          (setf (slot-value class 'defstruct-constructor) constructor))))
+    (if defstruct-p
+       (let ((include (car (slot-value class 'direct-superclasses))))
+         (multiple-value-bind (defstruct-form constructor reader-names writer-names)
+             (make-structure-class-defstruct-form name direct-slots include)
+           (unless (structure-type-p name) (eval defstruct-form))
+           (mapc (lambda (dslotd reader-name writer-name)
+                   (let* ((reader (gdefinition reader-name))
+                          (writer (when (gboundp writer-name)
+                                    (gdefinition writer-name))))
+                     (setf (slot-value dslotd 'internal-reader-function)
+                           reader)
+                     (setf (slot-value dslotd 'internal-writer-function)
+                           writer)))
+                 direct-slots reader-names writer-names)
+           (setf (slot-value class 'defstruct-form) defstruct-form)
+           (setf (slot-value class 'defstruct-constructor) constructor)))
+       (setf (slot-value class 'defstruct-constructor)
+             (make-defstruct-allocation-function class)))
     (add-direct-subclasses class direct-superclasses)
     (setf (slot-value class 'class-precedence-list)
             (compute-class-precedence-list class))

diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index 2f642b5..07e1cdc 100644 (file)
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -610,5 +610,11 @@
   (assert (= (slot-value x 'name) 1))
   (assert (= (slot-value x 'cl-user::name) 2)))
 \f
+;;; ALLOCATE-INSTANCE should work on structures, even if defined by
+;;; DEFSTRUCT (and not DEFCLASS :METACLASS STRUCTURE-CLASS).
+(defstruct allocatable-structure a)
+(assert (typep (allocate-instance (find-class 'allocatable-structure))
+              'allocatable-structure))
+\f
 ;;;; success
 (sb-ext:quit :unix-status 104)

diff --git a/version.lisp-expr b/version.lisp-expr
index 837cf82..4d38a4c 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.8alpha.0.33"
+"0.8alpha.0.34"