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.
;;;; -*- 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)
(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)
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 ()))
;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)))
(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
(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
(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
: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) ())
;;; 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)))
(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)
(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))))
(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))))))
*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*
\f
;;;; 1 argument
-(defgeneric accessor-method-class (method))
-
(defgeneric accessor-method-slot-name (m))
(defgeneric class-default-initargs (class))
(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
(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))
\f
(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)
;; 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)
;;; 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)
(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))
(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)
--- /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 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))))
+\f
+(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))))
;;; 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"
projects / sbcl.git / commitdiff