From 9ce24dc604859d2670a989da2a9015b67c37e00f Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Sun, 18 Sep 2005 10:55:11 +0000 Subject: [PATCH] 0.9.4.75: Remove one more AMOP incompatibility ... COMPUTE-SLOTS on FUNCALLABLE-STANDARD-CLASS doesn't need to be different from the method on STANDARD-CLASS. --- NEWS | 21 +++++++----- doc/manual/beyond-ansi.texinfo | 27 ++++++--------- src/pcl/std-class.lisp | 62 ++++++--------------------------- tests/mop-6.impure-cload.lisp | 74 ++++++++++++++++++++++++++++++++++++++++ tests/run-tests.sh | 2 +- version.lisp-expr | 2 +- 6 files changed, 111 insertions(+), 77 deletions(-) create mode 100644 tests/mop-6.impure-cload.lisp diff --git a/NEWS b/NEWS index 0249283..72be4c3 100644 --- a/NEWS +++ b/NEWS @@ -28,14 +28,6 @@ changes in sbcl-0.9.5 relative to sbcl-0.9.4: 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) @@ -43,6 +35,19 @@ changes in sbcl-0.9.5 relative to sbcl-0.9.4: 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 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 diff --git a/doc/manual/beyond-ansi.texinfo b/doc/manual/beyond-ansi.texinfo index 9cc2a9e..2cde567 100644 --- a/doc/manual/beyond-ansi.texinfo +++ b/doc/manual/beyond-ansi.texinfo @@ -47,18 +47,11 @@ are: @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 @@ -75,12 +68,14 @@ argument defining the declarations to be stored and returned by @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 diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 783cb88..fc53ebd 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -975,7 +975,7 @@ ;;; 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. @@ -995,11 +995,12 @@ (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) @@ -1033,53 +1034,12 @@ (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) diff --git a/tests/mop-6.impure-cload.lisp b/tests/mop-6.impure-cload.lisp new file mode 100644 index 0000000..06254d8 --- /dev/null +++ b/tests/mop-6.impure-cload.lisp @@ -0,0 +1,74 @@ +;;;; 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 diff --git a/tests/run-tests.sh b/tests/run-tests.sh index 14e8488..08f5665 100644 --- a/tests/run-tests.sh +++ b/tests/run-tests.sh @@ -40,7 +40,7 @@ echo /running tests on SBCL=\'$SBCL\' # 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\' diff --git a/version.lisp-expr b/version.lisp-expr index 34c868e..d347e12 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.9.4.74" +"0.9.4.75" -- 1.7.10.4