From: Christophe Rhodes Date: Fri, 28 Jul 2006 14:47:21 +0000 (+0000) Subject: 0.9.15.3: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=c70ef5922e4e5290fab52b90c3614be83c0b8f8b;p=sbcl.git 0.9.15.3: Implement the READER-METHOD-CLASS/WRITER-METHOD-CLASS protocol. In the process, note that the accessor methods generated for (slot-value x 'a) [ on generic functions of names like (SB-PCL::SLOT-ACCESSOR :GLOBAL A SB-PCL::READER) ] are not standard accessor methods, as they do not correspond to a given slot definition. So implement GLOBAL-{READER,WRITER,BOUNDP}-METHOD classes for those, which have a slot name but no slot definition. Some rearrangements of early methods to support the new functionality. REAL-MAKE-A-METHOD has to work moderately hard to separate out all the various ways it can be called. Include a test file for two ways of overriding the default methods. --- diff --git a/NEWS b/NEWS index 7d2ef39..88cc61e 100644 --- a/NEWS +++ b/NEWS @@ -1,5 +1,8 @@ ;;;; -*- coding: utf-8; -*- changes in sbcl-0.9.16 relative to sbcl-0.9.15: + * feature: implemented the READER-METHOD-CLASS and + WRITER-METHOD-CLASS portion of the Class Initialization Protocol + as specified by AMOP. * optimization: faster LOGCOUNT implementation on x86 and x86-64 (thanks to Lutz Euler) diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 4dc4049..562ad47 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -1829,16 +1829,20 @@ bootstrapping. (class (if (or (eq *boot-state* 'complete) (not (consp method))) (class-of method) (early-method-class method))) - (new-type (when (and class - (or (not (eq *boot-state* 'complete)) - (eq (generic-function-method-combination gf) - *standard-method-combination*))) - (cond ((eq class *the-class-standard-reader-method*) - 'reader) - ((eq class *the-class-standard-writer-method*) - 'writer) - ((eq class *the-class-standard-boundp-method*) - 'boundp))))) + (new-type + (when (and class + (or (not (eq *boot-state* 'complete)) + (eq (generic-function-method-combination gf) + *standard-method-combination*))) + (cond ((or (eq class *the-class-standard-reader-method*) + (eq class *the-class-global-reader-method*)) + 'reader) + ((or (eq class *the-class-standard-writer-method*) + (eq class *the-class-global-writer-method*)) + 'writer) + ((or (eq class *the-class-standard-boundp-method*) + (eq class *the-class-global-boundp-method*)) + 'boundp))))) (setq metatypes (mapcar #'raise-metatype metatypes specializers)) (setq type (cond ((null type) new-type) ((eq type new-type) type) @@ -2115,7 +2119,7 @@ bootstrapping. arg-info))) (defun early-make-a-method (class qualifiers arglist specializers initargs doc - &optional slot-name) + &key slot-name object-class method-class-function) (initialize-method-function initargs) (let ((parsed ()) (unparsed ())) @@ -2145,26 +2149,40 @@ bootstrapping. ;into play when there is more than one ;early method on an early gf. - (list class ;A list to which real-make-a-method - qualifiers ;can be applied to make a real method - arglist ;corresponding to this early one. - unparsed - initargs - doc - slot-name)))) + (append + (list class ;A list to which real-make-a-method + qualifiers ;can be applied to make a real method + arglist ;corresponding to this early one. + unparsed + initargs + doc) + (when slot-name + (list :slot-name slot-name :object-class object-class + :method-class-function method-class-function)))))) (defun real-make-a-method (class qualifiers lambda-list specializers initargs doc - &optional slot-name) + &rest args &key slot-name object-class method-class-function) (setq specializers (parse-specializers specializers)) - (apply #'make-instance class - :qualifiers qualifiers - :lambda-list lambda-list - :specializers specializers - :documentation doc - :slot-name slot-name - :allow-other-keys t - initargs)) + (if method-class-function + (let* ((object-class (if (classp object-class) object-class + (find-class object-class))) + (slots (class-direct-slots object-class)) + (slot-definition (find slot-name slots + :key #'slot-definition-name))) + (aver slot-name) + (aver slot-definition) + (let ((initargs (list* :qualifiers qualifiers :lambda-list lambda-list + :specializers specializers :documentation doc + :slot-definition slot-definition + :slot-name slot-name initargs))) + (apply #'make-instance + (apply method-class-function object-class slot-definition + initargs) + initargs))) + (apply #'make-instance class :qualifiers qualifiers + :lambda-list lambda-list :specializers specializers + :documentation doc (append args initargs)))) (defun early-method-function (early-method) (values (cadr early-method) (caddr early-method))) @@ -2179,7 +2197,7 @@ bootstrapping. (eq class 'standard-boundp-method)))) (defun early-method-standard-accessor-slot-name (early-method) - (seventh (fifth early-method))) + (eighth (fifth early-method))) ;;; Fetch the specializers of an early method. This is basically just ;;; a simple accessor except that when the second argument is t, this @@ -2203,14 +2221,14 @@ bootstrapping. (setf (fourth early-method) (mapcar #'find-class (cadddr (fifth early-method)))))) (t - (cadddr (fifth early-method)))) + (fourth (fifth early-method)))) (error "~S is not an early-method." early-method))) (defun early-method-qualifiers (early-method) - (cadr (fifth early-method))) + (second (fifth early-method))) (defun early-method-lambda-list (early-method) - (caddr (fifth early-method))) + (third (fifth early-method))) (defun early-add-named-method (generic-function-name qualifiers diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index e18daee..008eb02 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -430,7 +430,9 @@ (funcall make-method-function class-name slot-name) doc - slot-name)))))) + :slot-name slot-name + :object-class class-name + :method-class-function (constantly (find-class accessor-class)))))))) (defun !bootstrap-accessor-definitions1 (class-name slot-name diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index dbed28c..e94c009 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -389,10 +389,12 @@ :reader method-fast-function) (%documentation :initform nil :initarg :documentation))) -(defclass standard-accessor-method (standard-method) +(defclass accessor-method (standard-method) ((slot-name :initform nil :initarg :slot-name - :reader accessor-method-slot-name) - (%slot-definition :initform nil :initarg :slot-definition + :reader accessor-method-slot-name))) + +(defclass standard-accessor-method (accessor-method) + ((%slot-definition :initform nil :initarg :slot-definition :reader accessor-method-slot-definition))) (defclass standard-reader-method (standard-accessor-method) ()) @@ -400,6 +402,13 @@ ;;; an extension, apparently. (defclass standard-boundp-method (standard-accessor-method) ()) +;;; for (SLOT-VALUE X 'FOO) / ACCESSOR-SLOT-VALUE optimization, which +;;; can't be STANDARD-READER-METHOD because there is no associated +;;; slot definition. +(defclass global-reader-method (accessor-method) ()) +(defclass global-writer-method (accessor-method) ()) +(defclass global-boundp-method (accessor-method) ()) + (defclass method-combination (metaobject) ((%documentation :initform nil :initarg :documentation))) @@ -694,10 +703,14 @@ (forward-referenced-class forward-referenced-class-p) (method method-p) (standard-method standard-method-p) + (accessor-method accessor-method-p) (standard-accessor-method standard-accessor-method-p) (standard-reader-method standard-reader-method-p) (standard-writer-method standard-writer-method-p) (standard-boundp-method standard-boundp-method-p) + (global-reader-method global-reader-method-p) + (global-writer-method global-writer-method-p) + (global-boundp-method global-boundp-method-p) (generic-function generic-function-p) (standard-generic-function standard-generic-function-p) (method-combination method-combination-p) diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index d6f2d08..3117264 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -885,23 +885,29 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (generic-function-methods gf)))) (cond ((every (lambda (method) (if (consp method) - (eq *the-class-standard-reader-method* - (early-method-class method)) - (standard-reader-method-p method))) + (let ((class (early-method-class method))) + (or (eq class *the-class-standard-reader-method*) + (eq class *the-class-global-reader-method*))) + (or (standard-reader-method-p method) + (global-reader-method-p method)))) methods) 'reader) ((every (lambda (method) (if (consp method) - (eq *the-class-standard-boundp-method* - (early-method-class method)) - (standard-boundp-method-p method))) + (let ((class (early-method-class method))) + (or (eq class *the-class-standard-boundp-method*) + (eq class *the-class-global-boundp-method*))) + (or (standard-boundp-method-p method) + (global-boundp-method-p method)))) methods) 'boundp) ((every (lambda (method) (if (consp method) - (eq *the-class-standard-writer-method* - (early-method-class method)) - (standard-writer-method-p method))) + (let ((class (early-method-class method))) + (or (eq class *the-class-standard-writer-method*) + (eq class *the-class-global-writer-method*))) + (or (standard-writer-method-p method) + (global-writer-method-p method)))) methods) 'writer)))) @@ -1272,7 +1278,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (if early-p (not (eq *the-class-standard-method* (early-method-class meth))) - (standard-accessor-method-p meth)) + (accessor-method-p meth)) (if early-p (early-accessor-method-slot-name meth) (accessor-method-slot-name meth)))))) diff --git a/src/pcl/early-low.lisp b/src/pcl/early-low.lisp index e80284a..7fca8d3 100644 --- a/src/pcl/early-low.lisp +++ b/src/pcl/early-low.lisp @@ -104,6 +104,9 @@ *the-class-standard-reader-method* *the-class-standard-writer-method* *the-class-standard-boundp-method* + *the-class-global-reader-method* + *the-class-global-writer-method* + *the-class-global-boundp-method* *the-class-standard-generic-function* *the-class-standard-effective-slot-definition* diff --git a/src/pcl/generic-functions.lisp b/src/pcl/generic-functions.lisp index 73462f1..498c72d 100644 --- a/src/pcl/generic-functions.lisp +++ b/src/pcl/generic-functions.lisp @@ -233,8 +233,6 @@ ;;;; 1 argument -(defgeneric accessor-method-class (method)) - (defgeneric accessor-method-slot-name (m)) (defgeneric class-default-initargs (class)) diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index adb89d8..4acbaae 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -40,12 +40,6 @@ (setf (slot-value method '%function) (method-function-from-fast-function fmf))))) -(defmethod accessor-method-class ((method standard-accessor-method)) - (car (slot-value method 'specializers))) - -(defmethod accessor-method-class ((method standard-writer-method)) - (cadr (slot-value method 'specializers))) - ;;; initialization ;;; ;;; Error checking is done in before methods. Because of the simplicity of @@ -184,19 +178,6 @@ (setf (slot-value method 'closure-generator) (method-function-closure-generator (slot-value method '%function)))) -(defmethod shared-initialize :after ((method standard-accessor-method) - slot-names - &key) - (declare (ignore slot-names)) - (with-slots (slot-name %slot-definition) method - (unless %slot-definition - (let ((class (accessor-method-class method))) - (when (slot-class-p class) - (setq %slot-definition (find slot-name (class-direct-slots class) - :key #'slot-definition-name))))) - (when (and %slot-definition (null slot-name)) - (setq slot-name (slot-definition-name %slot-definition))))) - (defmethod method-qualifiers ((method standard-method)) (plist-value method 'qualifiers)) @@ -827,16 +808,17 @@ (setf (gf-info-simple-accessor-type arg-info) (let* ((methods (generic-function-methods gf)) (class (and methods (class-of (car methods)))) - (type (and class - (cond ((eq class - *the-class-standard-reader-method*) - 'reader) - ((eq class - *the-class-standard-writer-method*) - 'writer) - ((eq class - *the-class-standard-boundp-method*) - 'boundp))))) + (type + (and class + (cond ((or (eq class *the-class-standard-reader-method*) + (eq class *the-class-global-reader-method*)) + 'reader) + ((or (eq class *the-class-standard-writer-method*) + (eq class *the-class-global-writer-method*)) + 'writer) + ((or (eq class *the-class-standard-boundp-method*) + (eq class *the-class-global-boundp-method*)) + 'boundp))))) (when (and (gf-info-c-a-m-emf-std-p arg-info) type (dolist (method (cdr methods) t) diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp index aee9ea0..121b97a 100644 --- a/src/pcl/slots-boot.lisp +++ b/src/pcl/slots-boot.lisp @@ -30,20 +30,21 @@ ;; FIXME: change SLOT-OBJECT here to T to get SLOT-MISSING ;; behaviour for non-slot-objects too? (reader - (values '(object) '(slot-object) 'standard-reader-method + (values '(object) '(slot-object) 'global-reader-method (make-std-reader-method-function 'slot-object slot-name) "automatically-generated reader method")) (writer - (values '(new-value object) '(t slot-object) 'standard-writer-method + (values '(new-value object) '(t slot-object) 'global-writer-method (make-std-writer-method-function 'slot-object slot-name) "automatically-generated writer method")) (boundp - (values '(object) '(slot-object) 'standard-boundp-method + (values '(object) '(slot-object) 'global-boundp-method (make-std-boundp-method-function 'slot-object slot-name) "automatically-generated boundp method"))) (let ((gf (ensure-generic-function fun-name :lambda-list lambda-list))) - (add-method gf (make-a-method method-class () lambda-list specializers - initargs doc slot-name))))) + (add-method gf (make-a-method method-class + () lambda-list specializers + initargs doc :slot-name slot-name))))) t) (defmacro accessor-slot-value (object slot-name) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index ab9f9b3..8d9dde3 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -757,16 +757,16 @@ ;;; or reinitialized. The class may or may not be finalized. (defun update-class (class finalizep) (without-package-locks - (when (or finalizep (class-finalized-p class)) - (update-cpl class (compute-class-precedence-list class)) - ;; This invocation of UPDATE-SLOTS, in practice, finalizes the - ;; class. - (update-slots class (compute-slots class)) - (update-gfs-of-class class) - (update-initargs class (compute-default-initargs class)) - (update-ctors 'finalize-inheritance :class class)) - (dolist (sub (class-direct-subclasses class)) - (update-class sub nil)))) + (when (or finalizep (class-finalized-p class)) + (update-cpl class (compute-class-precedence-list class)) + ;; This invocation of UPDATE-SLOTS, in practice, finalizes the + ;; class. + (update-slots class (compute-slots class)) + (update-gfs-of-class class) + (update-initargs class (compute-default-initargs class)) + (update-ctors 'finalize-inheritance :class class)) + (dolist (sub (class-direct-subclasses class)) + (update-class sub nil)))) (define-condition cpl-protocol-violation (reference-condition error) ((class :initarg :class :reader cpl-protocol-violation-class) @@ -1115,7 +1115,9 @@ (list class) (make-reader-method-function class slot-name) "automatically generated reader method" - slot-name))) + :slot-name slot-name + :object-class class + :method-class-function #'reader-method-class))) (defmethod writer-method-class ((class slot-class) direct-slot &rest initargs) (declare (ignore direct-slot initargs)) @@ -1129,11 +1131,14 @@ (list *the-class-t* class) (make-writer-method-function class slot-name) "automatically generated writer method" - slot-name))) + :slot-name slot-name + :object-class class + :method-class-function #'writer-method-class))) (defmethod add-boundp-method ((class slot-class) generic-function slot-name) (add-method generic-function - (make-a-method 'standard-boundp-method + (make-a-method (constantly (find-class 'standard-boundp-method)) + class () (list (or (class-name class) 'object)) (list class) diff --git a/tests/mop-19.impure-cload.lisp b/tests/mop-19.impure-cload.lisp new file mode 100644 index 0000000..31f4e51 --- /dev/null +++ b/tests/mop-19.impure-cload.lisp @@ -0,0 +1,76 @@ +;;;; 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 tests the accessor method class portion of the protocol +;;; for Initialization of Class Metaobjects. + +(defpackage "MOP-19" + (:use "CL" "SB-MOP")) + +(in-package "MOP-19") + +(defclass my-class (standard-class) ()) +(defmethod validate-superclass ((a my-class) (b standard-class)) t) + +(defclass my-reader (standard-reader-method) ()) +(defclass my-writer (standard-writer-method) ()) + +(defvar *calls* nil) + +(defmethod reader-method-class ((c my-class) s &rest initargs) + (push (cons (slot-definition-name s) 'reader) *calls*) + (find-class 'my-reader)) +(defmethod writer-method-class ((c my-class) s &rest initargs) + (push (cons (slot-definition-name s) 'writer) *calls*) + (find-class 'my-writer)) + +(defclass foo () + ((a :reader a) + (b :writer b) + (c :accessor c)) + (:metaclass my-class)) + +(assert (= (length *calls*) 4)) +(assert (= (count 'a *calls* :key #'car) 1)) +(assert (= (count 'b *calls* :key #'car) 1)) +(assert (= (count 'c *calls* :key #'car) 2)) +(assert (= (count 'reader *calls* :key #'cdr) 2)) +(assert (= (count 'writer *calls* :key #'cdr) 2)) +(let ((method (find-method #'a nil (list (find-class 'foo))))) + (assert (eq (class-of method) (find-class 'my-reader)))) +(let ((method (find-method #'b nil (list (find-class t) (find-class 'foo))))) + (assert (eq (class-of method) (find-class 'my-writer)))) + +(defclass my-other-class (my-class) ()) +(defmethod validate-superclass ((a my-other-class) (b standard-class)) t) + +(defclass my-other-reader (standard-reader-method) ()) + +(defclass my-direct-slot-definition (standard-direct-slot-definition) ()) + +(defmethod direct-slot-definition-class ((c my-other-class) &rest args) + (find-class 'my-direct-slot-definition)) + +(defmethod reader-method-class :around + (class (s my-direct-slot-definition) &rest initargs) + (find-class 'my-other-reader)) + +(defclass bar () + ((d :reader d) + (e :writer e)) + (:metaclass my-other-class)) + +(let ((method (find-method #'d nil (list (find-class 'bar))))) + (assert (eq (class-of method) (find-class 'my-other-reader)))) +(let ((method (find-method #'e nil (list (find-class t) (find-class 'bar))))) + (assert (eq (class-of method) (find-class 'my-writer)))) diff --git a/version.lisp-expr b/version.lisp-expr index bba8efa..b016bb5 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.15.2" +"0.9.15.3"