From b3b4928dfd6f19e3cb4fafe16873ea14a5ef9a4d Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Sun, 18 May 2003 14:42:33 +0000 Subject: [PATCH] 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. --- NEWS | 3 +++ src/pcl/std-class.lisp | 47 +++++++++++++++++++++++++++++++---------------- tests/clos.impure.lisp | 6 ++++++ version.lisp-expr | 2 +- 4 files changed, 41 insertions(+), 17 deletions(-) diff --git a/NEWS b/NEWS index 6363d6c..891ee67 100644 --- 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 --- 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 --- 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))) +;;; 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)) + ;;;; success (sb-ext:quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index 837cf82..4d38a4c 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.8alpha.0.33" +"0.8alpha.0.34" -- 1.7.10.4