funcallable-instances. (reported by Cyrus Harmon)
* bug fix: FUNCTIONP and (LAMBDA (X) (TYPEP X 'FUNCTION)) are now
consistent, even on internal alternate-metaclass objects.
- * bug fix: SB-MOP:FUNCALLABLE-STANDARD-OBJECT is now a subclass of
- STANDARD-OBJECT, as required by AMOP.
- * bug fix: the classes STANDARD-CLASS and
- SB-MOP:FUNCALLABLE-STANDARD-CLASS are now compatible in the
- SB-MOP:VALIDATE-SUPERCLASS sense; there remains a constraint about
- finalized classes and the FUNCTION class.
- * bug fix: the SB-MOP:METAOBJECT class is now implemented as
- specified by AMOP.
* bug fix: flush closure information collected by physical
environment analysis prepass before the main pass. (bug reported
by Vasile Rotaru)
iterated. (reported by Bryan O'Connor, fixed by Rob MacLachlan)
* bug fix: backquote does not optimize (LIST* x y) to CONS when x
may be expanded. (reported by Alexander <malishev> on c.l.l)
+ * fixed some incompatibilities between SBCL's MOP and the MOP
+ specified by AMOP:
+ ** the METAOBJECT class is now implemented;
+ ** FUNCALLABLE-STANDARD-OBJECT is now a subclass of
+ STANDARD-OBJECT, as required;
+ ** the classes STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS are
+ now compatible (as required by VALIDATE-SUPERCLASS); there
+ remains a consistency requirement over the presence or absence
+ of the FUNCTION class in the superclass list of finalized
+ classes; see the manual for more details;
+ ** the :AROUND method for COMPUTE-SLOTS on
+ FUNCALLABLE-STANDARD-CLASS now honours the primary method's
+ requested slot ordering.
* threads
** bug fix: parent thread now can be gc'ed even with a live
child thread
@item
@findex compute-effective-method
@findex sb-mop:compute-effective-method
-@code{compute-effective-method} only returns one value, not two;
+@code{compute-effective-method} only returns one value, not two.
+There is no record of what the second return value was meant to
+indicate, and apparently no clients for it.
@item
-@findex compute-slots
-@findex sb-mop:compute-slots
-@tindex funcallable-standard-class
-@tindex sb-mop:funcallable-standard-class
-the system-supplied @code{:around} method for @code{compute-slots}
-specialized on @code{funcallable-standard-class} does not respect the
-requested order from a user-supplied primary method.
-
-@item
@findex ensure-generic-function
@findex generic-function-declarations
@findex sb-mop:generic-function-declarations
@tindex standard-class
@tindex funcallable-standard-class
@tindex sb-mop:funcallable-standard-class
-although we obey the requirement in AMOP for @code{validate-superclass}
-for @code{standard-class} and @code{funcallable-standard-class} to be
-compatible metaclasses, we impose an additional requirement at class
-finalization time: a class of metaclass
-@code{funcallable-standard-class} must have @code{function} in its
-superclasses, and a class of metaclass @code{standard-class} must not.
+@tindex function
+although SBCL obeys the requirement in AMOP for
+@code{validate-superclass} for @code{standard-class} and
+@code{funcallable-standard-class} to be compatible metaclasses, we
+impose an additional requirement at class finalization time: a class
+of metaclass @code{funcallable-standard-class} must have
+@code{function} in its superclasses, and a class of metaclass
+@code{standard-class} must not.
@end itemize
;;; the slots predictably, but maybe it would be good to compute some
;;; kind of optimal slot layout by looking at locations of slots in
;;; superclasses?
-(defmethod compute-slots ((class std-class))
+(defun std-compute-slots (class)
;; As specified, we must call COMPUTE-EFFECTIVE-SLOT-DEFINITION once
;; for each different slot name we find in our superclasses. Each
;; call receives the class and a list of the dslotds with that name.
(nreverse name-dslotds-alist))))
(defmethod compute-slots ((class standard-class))
- (call-next-method))
+ (std-compute-slots class))
+(defmethod compute-slots ((class funcallable-standard-class))
+ (std-compute-slots class))
-(defmethod compute-slots :around ((class standard-class))
- (let ((eslotds (call-next-method))
- (location -1))
+(defun std-compute-slots-around (class eslotds)
+ (let ((location -1))
(dolist (eslotd eslotds eslotds)
(setf (slot-definition-location eslotd)
(case (slot-definition-allocation eslotd)
(setf (slot-definition-class eslotd) class))
(initialize-internal-slot-functions eslotd))))
-(defmethod compute-slots ((class funcallable-standard-class))
- (call-next-method))
-
+(defmethod compute-slots :around ((class standard-class))
+ (let ((eslotds (call-next-method)))
+ (std-compute-slots-around class eslotds)))
(defmethod compute-slots :around ((class funcallable-standard-class))
- (labels ((instance-slot-names (slotds)
- (let (collect)
- (dolist (slotd slotds (nreverse collect))
- (when (eq (slot-definition-allocation slotd) :instance)
- (push (slot-definition-name slotd) collect)))))
- ;; This sorts slots so that slots of classes later in the CPL
- ;; come before slots of other classes. This is crucial for
- ;; funcallable instances because it ensures that the slots of
- ;; FUNCALLABLE-STANDARD-OBJECT, which includes the slots of
- ;; KERNEL:FUNCALLABLE-INSTANCE, come first, which in turn
- ;; makes it possible to treat FUNCALLABLE-STANDARD-OBJECT as
- ;; a funcallable instance.
- (compute-layout (eslotds)
- (let ((first ())
- (names (instance-slot-names eslotds)))
- (dolist (class
- (reverse (class-precedence-list class))
- (nreverse (nconc names first)))
- (dolist (ss (class-slots class))
- (let ((name (slot-definition-name ss)))
- (when (member name names)
- (push name first)
- (setq names (delete name names)))))))))
- (let ((all-slotds (call-next-method))
- (instance-slots ())
- (class-slots ()))
- (dolist (slotd all-slotds)
- (case (slot-definition-allocation slotd)
- (:instance (push slotd instance-slots))
- (:class (push slotd class-slots))))
- (let ((layout (compute-layout instance-slots)))
- (dolist (slotd instance-slots)
- (setf (slot-definition-location slotd)
- (position (slot-definition-name slotd) layout))
- (initialize-internal-slot-functions slotd)))
- (dolist (slotd class-slots)
- (let ((name (slot-definition-name slotd))
- (from-class (slot-definition-allocation-class slotd)))
- (setf (slot-definition-location slotd)
- (assoc name (class-slot-cells from-class)))
- (aver (consp (slot-definition-location slotd)))
- (initialize-internal-slot-functions slotd)))
- all-slotds)))
+ (let ((eslotds (call-next-method)))
+ (std-compute-slots-around class eslotds)))
(defmethod compute-slots ((class structure-class))
(mapcan (lambda (superclass)
--- /dev/null
+;;;; miscellaneous side-effectful tests of the MOP
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+;;; This file contains simple tests for COMPUTE-SLOTS :AROUND
+;;; respecting the order requested by the primary method.
+
+(defpackage "MOP-6"
+ (:use "CL" "SB-MOP" "TEST-UTIL"))
+(in-package "MOP-6")
+
+;;; COMPUTE-SLOTS :AROUND respecting requested order
+(defclass slot-rearrangement-class (standard-class)
+ ())
+(defmethod compute-slots ((c slot-rearrangement-class))
+ (reverse (call-next-method)))
+(defmethod validate-superclass ((c slot-rearrangement-class)
+ (s standard-class))
+ t)
+(defclass rearranged-class ()
+ ((a :initarg :a :initform 1)
+ (b :initarg :b :initform 2))
+ (:metaclass slot-rearrangement-class))
+
+(with-test (:name (compute-slots standard-class :order))
+ (let ((class (find-class 'rearranged-class)))
+ (finalize-inheritance class)
+ (assert (equal (mapcar #'slot-definition-name (class-slots class))
+ '(b a)))))
+(with-test (:name (compute-slots standard-class :slots))
+ (let ((r (make-instance 'rearranged-class))
+ (r2 (make-instance 'rearranged-class :a 3 :b 4)))
+ (assert (eql (slot-value r 'a) 1))
+ (assert (eql (slot-value r 'b) 2))
+ (assert (eql (slot-value r2 'a) 3))
+ (assert (eql (slot-value r2 'b) 4))))
+
+(defclass funcallable-slot-rearrangement-class (funcallable-standard-class)
+ ())
+(defmethod compute-slots ((c funcallable-slot-rearrangement-class))
+ (reverse (call-next-method)))
+(defmethod validate-superclass ((c funcallable-slot-rearrangement-class)
+ (s funcallable-standard-class))
+ t)
+(defclass funcallable-rearranged-class ()
+ ((a :initarg :a :initform 1)
+ (b :initarg :b :initform 2))
+ (:metaclass funcallable-slot-rearrangement-class))
+
+(with-test (:name (compute-slots funcallable-standard-class :order))
+ (let ((class (find-class 'funcallable-rearranged-class)))
+ (finalize-inheritance class)
+ (assert (equal (mapcar #'slot-definition-name (class-slots class))
+ '(b a)))))
+(with-test (:name (compute-slots funcallable-standard-class :slots))
+ (let ((r (make-instance 'funcallable-rearranged-class))
+ (r2 (make-instance 'funcallable-rearranged-class :a 3 :b 4)))
+ (assert (eql (slot-value r 'a) 1))
+ (assert (eql (slot-value r 'b) 2))
+ (assert (eql (slot-value r2 'a) 3))
+ (assert (eql (slot-value r2 'b) 4))))
+(with-test (:name (compute-slots funcallable-standard-clas :function))
+ (let ((r (make-instance 'funcallable-rearranged-class)))
+ (set-funcallable-instance-function r (lambda (x) (list "Hello, World!" x)))
+ (assert (equal (funcall r 3) '("Hello, World!" 3)))))
\ No newline at end of file
# magic can be done once and only once.). Not used in this file, but
# exists for the benefit of the *.test.sh files that can be started by
# run-tests.lisp
-SBCL_ALLOWING_CORE=${1:-$sbclstem}
+SBCL_ALLOWING_CORE=$sbclstem
export SBCL_ALLOWING_CORE
echo /with SBCL_ALLOWING_CORE=\'$SBCL_ALLOWING_CORE\'
;;; 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.74"
+"0.9.4.75"
projects / sbcl.git / commitdiff