Update of /cvsroot/sbcl/sbcl/src/pcl
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv14073/src/pcl
Modified Files:
boot.lisp braid.lisp defs.lisp dfun.lisp early-low.lisp
generic-functions.lisp methods.lisp slots-boot.lisp
std-class.lisp
Log Message:
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.
Index: boot.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/boot.lisp,v
retrieving revision 1.115
retrieving revision 1.116
diff -u -d -r1.115 -r1.116
--- boot.lisp 19 Jul 2006 11:13:01 -0000 1.115
+++ boot.lisp 28 Jul 2006 14:47:23 -0000 1.116
@@ -1829,16 +1829,20 @@
(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 @@
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 @@
;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 @@
(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 @@
(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
Index: braid.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/braid.lisp,v
retrieving revision 1.58
retrieving revision 1.59
diff -u -d -r1.58 -r1.59
--- braid.lisp 17 Jul 2006 12:28:13 -0000 1.58
+++ braid.lisp 28 Jul 2006 14:47:23 -0000 1.59
@@ -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
Index: defs.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/defs.lisp,v
retrieving revision 1.51
retrieving revision 1.52
diff -u -d -r1.51 -r1.52
--- defs.lisp 16 Mar 2006 18:57:18 -0000 1.51
+++ defs.lisp 28 Jul 2006 14:47:23 -0000 1.52
@@ -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)
Index: dfun.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/dfun.lisp,v
retrieving revision 1.49
retrieving revision 1.50
diff -u -d -r1.49 -r1.50
--- dfun.lisp 17 Jul 2006 12:28:13 -0000 1.49
+++ dfun.lisp 28 Jul 2006 14:47:23 -0000 1.50
@@ -885,23 +885,29 @@
(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 @@
(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))))))
Index: early-low.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/early-low.lisp,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -d -r1.11 -r1.12
--- early-low.lisp 9 Sep 2005 16:09:51 -0000 1.11
+++ early-low.lisp 28 Jul 2006 14:47:23 -0000 1.12
@@ -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*
Index: generic-functions.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/generic-functions.lisp,v
retrieving revision 1.30
retrieving revision 1.31
diff -u -d -r1.30 -r1.31
--- generic-functions.lisp 13 Feb 2006 15:59:16 -0000 1.30
+++ generic-functions.lisp 28 Jul 2006 14:47:23 -0000 1.31
@@ -233,8 +233,6 @@
;;;; 1 argument
-(defgeneric accessor-method-class (method))
-
(defgeneric accessor-method-slot-name (m))
(defgeneric class-default-initargs (class))
Index: methods.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/methods.lisp,v
retrieving revision 1.58
retrieving revision 1.59
diff -u -d -r1.58 -r1.59
--- methods.lisp 25 Jul 2006 16:06:31 -0000 1.58
+++ methods.lisp 28 Jul 2006 14:47:23 -0000 1.59
@@ -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)
Index: slots-boot.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/slots-boot.lisp,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -d -r1.26 -r1.27
--- slots-boot.lisp 27 Feb 2006 13:12:35 -0000 1.26
+++ slots-boot.lisp 28 Jul 2006 14:47:23 -0000 1.27
@@ -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)
Index: std-class.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/std-class.lisp,v
retrieving revision 1.101
retrieving revision 1.102
diff -u -d -r1.101 -r1.102
--- std-class.lisp 25 Jul 2006 16:06:31 -0000 1.101
+++ std-class.lisp 28 Jul 2006 14:47:23 -0000 1.102
@@ -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)
|