From 25201a0bef7c1e5988b804bbb160fd06de67a468 Mon Sep 17 00:00:00 2001 From: jgarcia Date: Mon, 28 Apr 2008 15:23:12 +0000 Subject: [PATCH] Implement standard-accessor-method --- src/CHANGELOG | 4 ++ src/clos/fixup.lsp | 42 ++++++++++++++------ src/clos/kernel.lsp | 14 ++++--- src/clos/method.lsp | 11 ++++-- src/clos/standard.lsp | 89 +++++++++++++++++++++++++++--------------- src/clos/stdmethod.lsp | 9 +++++ src/lsp/config.lsp.in | 2 +- 7 files changed, 117 insertions(+), 54 deletions(-) diff --git a/src/CHANGELOG b/src/CHANGELOG index 72a537f37..fceae51e3 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -78,6 +78,10 @@ ECL 0.9k: - When caching generic function calls, ECL now uses a thread-local hash table instead of one hash table per generic function. + - The classes STANDARD-ACCESSOR-METHOD, STANDARD-READER-METHOD and + STANDARD-WRITER-METHOD have been implemented. These methods are created + to access the slots of a standard class. + * Bugs fixed: - ASDF:MAKE-BUILD now handles better the case of a monolithic FASL that diff --git a/src/clos/fixup.lsp b/src/clos/fixup.lsp index 5329eee50..3a4bc1be3 100644 --- a/src/clos/fixup.lsp +++ b/src/clos/fixup.lsp @@ -65,6 +65,16 @@ (make-instances-obsolete (find-class 't)) (convert-one-class (find-class 't))) +(defmethod reader-method-class ((class standard-class) + (direct-slot direct-slot-definition) + &rest initargs) + (find-class 'standard-reader-method)) + +(defmethod writer-method-class ((class standard-class) + (direct-slot direct-slot-definition) + &rest initargs) + (find-class 'standard-writer-method)) + ;;; ---------------------------------------------------------------------- ;;; Fixup @@ -81,7 +91,14 @@ ) (dolist (method (cdr method-info)) ;; complete the method object - (si::instance-class-set method (find-class 'standard-method)) + (let ((old-class (si::instance-class method))) + (si::instance-class-set method + (cond ((null old-class) + (find-class 'standard-method)) + ((symbolp old-class) + (find-class old-class)) + (t + old-class)))) (si::instance-sig-set gfun) ) (makunbound '*EARLY-METHODS*))) @@ -92,17 +109,18 @@ (defun method-p (method) (typep method 'METHOD)) -(defun make-method (qualifiers specializers arglist - function plist options gfun method-class) - (declare (ignore options)) - (make-instance method-class - :generic-function nil - :qualifiers qualifiers - :lambda-list arglist - :specializers specializers - :function function - :plist plist - :allow-other-keys t)) +(defun make-method (method-class qualifiers specializers arglist + function plist options) + (apply #'make-instance + method-class + :generic-function nil + :qualifiers qualifiers + :lambda-list arglist + :specializers specializers + :function function + :plist plist + :allow-other-keys t + options)) (defun all-keywords (l) (declare (si::c-local)) diff --git a/src/clos/kernel.lsp b/src/clos/kernel.lsp index 32aa9f8a5..d8332fb91 100644 --- a/src/clos/kernel.lsp +++ b/src/clos/kernel.lsp @@ -170,8 +170,8 @@ ;;; ---------------------------------------------------------------------- ;;; Methods -(defun install-method (name qualifiers specializers lambda-list doc plist - fun &rest options) +(defun install-method (name qualifiers specializers lambda-list doc plist fun + &optional method-class &rest options) (declare (ignore doc) (notinline ensure-generic-function)) ; (record-definition 'method `(method ,name ,@qualifiers ,specializers)) @@ -182,9 +182,10 @@ ((si::instancep x) x) (t (find-class x)))) specializers)) - (method (make-method qualifiers specializers lambda-list - fun plist options gf - (generic-function-method-class gf)))) + (method (make-method (or method-class + (generic-function-method-class gf)) + qualifiers specializers lambda-list + fun plist options))) (add-method gf method) method)) @@ -205,7 +206,8 @@ (generic-function-lambda-list gfun) lambda-list (generic-function-method-combination gfun) '(standard) (generic-function-methods gfun) nil - (generic-function-spec-list gfun) nil) + (generic-function-spec-list gfun) nil + (generic-function-method-class gfun) 'standard-method) (when l-l-p (setf (generic-function-argument-precedence-order gfun) (rest (si::process-lambda-list lambda-list t)))) diff --git a/src/clos/method.lsp b/src/clos/method.lsp index b7c54c8f8..a456cd854 100644 --- a/src/clos/method.lsp +++ b/src/clos/method.lsp @@ -271,10 +271,13 @@ have disappeared." ;;; ---------------------------------------------------------------------- ;;; operations -(defun make-method (qualifiers specializers lambda-list - fun plist options gf method-class) - (let ((method (si:allocate-raw-instance nil (find-class 'standard-method nil) - #.(length +standard-method-slots+)))) +(defun make-method (method-class qualifiers specializers lambda-list + fun plist options) + (declare (ignore options)) + (let* ((instance-size (+ #.(length +standard-method-slots+) + (if (eq method-class 'standard-method) + 0 2))) + (method (si:allocate-raw-instance nil method-class instance-size))) (setf (method-generic-function method) nil (method-lambda-list method) lambda-list (method-function method) fun diff --git a/src/clos/standard.lsp b/src/clos/standard.lsp index cb6043a4a..1fc105087 100644 --- a/src/clos/standard.lsp +++ b/src/clos/standard.lsp @@ -394,8 +394,36 @@ because it contains a reference to the undefined class~% ~A" ;;; ---------------------------------------------------------------------- ;;; Optional accessors +;;; +;;; The following does not work. We have a problem with optimized +;;; accessors that memoize the position of a slot. The problem is that +;;; the AMOP specifies that slot accessors are created from the direct +;;; slots, without knowing the slot position. This semantics is +;;; required for working standard-reader- and +;;; standard-writer-method. OTOH if we want to have memoized slot +;;; positions we have to work from the effective slots and we have to +;;; create methods for all slots, not only the direct ones in this +;;; class. Both semantics are incompatible, but we currently have no +;;; safe way to choose one or another +;;; +#| +(defun std-class-optimized-accessors (slotd) + (declare (si::c-local)) + (values #'(lambda (self) + (standard-instance-get self slotd)) + #'(lambda (value self) + (standard-instance-set value self slotd)))) +|# -(defun std-class-generate-accessors (standard-class) +(defun std-class-accessors (slot-name) + (declare (si::c-local)) + ;; The following are very slow. We do not optimize for the slot position. + (values #'(lambda (self) + (slot-value self slot-name)) + #'(lambda (value self) + (setf (slot-value self slot-name) value)))) + +(defun std-class-generate-accessors (standard-class &aux optimizable) (declare (si::c-local)) ;; ;; The accessors are closures, which are generated every time the @@ -404,36 +432,35 @@ because it contains a reference to the undefined class~% ~A" ;; the liberty of using SI:INSTANCE-REF because they know the class of ;; the instance. ;; - (dolist (slotd (class-slots standard-class)) - (let* ((slot-name (slot-definition-name slotd)) - (index (slot-definition-location slotd)) - reader setter) - (declare (fixnum index)) - (if (and (eql (slot-definition-allocation slotd) :instance) - (si:fixnump index) - (slot-value standard-class 'optimize-slot-access)) - (setf reader #'(lambda (self) - (let ((value (si:instance-ref self index))) - (if (si:sl-boundp value) - value - (values (slot-unbound (class-of self) self slot-name))))) - setter #'(lambda (value self) - (si:instance-set self index value))) - (let ((slotd slotd)) - ;; Note that in order to save this value in the closure we have to copy - ;; the variable, because the value of SLOTD is going to change! - (setf reader #'(lambda (self) - (slot-value-using-class (si:instance-class self) - self slotd)) - setter #'(lambda (value self) - (setf (slot-value-using-class (si:instance-class self) - self slotd) value))))) - (dolist (fname (slot-definition-readers slotd)) - (install-method fname nil `(,standard-class) '(self) nil nil - reader)) - (dolist (fname (slot-definition-writers slotd)) - (install-method fname nil `(,(find-class t) ,standard-class) '(value self) - nil nil setter))))) + (dolist (slotd (class-direct-slots standard-class)) + (multiple-value-bind (reader writer) + (std-class-accessors (slot-definition-name slotd)) + (let* ((reader-args (list :function reader + :generic-function nil + :qualifiers nil + :lambda-list '(object) + :specializers `(,standard-class) + :slot-definition slotd)) + (reader-class (if (boundp '*early-methods*) + 'standard-reader-method + (apply #'reader-method-class standard-class slotd + reader-args))) + (writer-args (list :function writer + :generic-function nil + :qualifiers nil + :lambda-list '(value object) + :specializers `(,(find-class t) ,standard-class) + :slot-definition slotd)) + (writer-class (if (boundp '*early-methods*) + 'standard-reader-method + (apply #'writer-method-class standard-class slotd + writer-args)))) + (dolist (fname (slot-definition-readers slotd)) + (install-method fname nil `(,standard-class) '(self) nil nil + reader reader-class :slot-definition slotd)) + (dolist (fname (slot-definition-writers slotd)) + (install-method fname nil `(,(find-class t) ,standard-class) '(value self) + nil nil writer writer-class :slot-definition slotd)))))) ;;; ====================================================================== ;;; STANDARD-OBJECT diff --git a/src/clos/stdmethod.lsp b/src/clos/stdmethod.lsp index f3d85d328..5fadf4e0d 100644 --- a/src/clos/stdmethod.lsp +++ b/src/clos/stdmethod.lsp @@ -40,3 +40,12 @@ ((endp l) output) (push (first l) output))))) + +(defclass standard-accessor-method (standard-method) + ((slot-definition :initarg :slot-definition + :initform nil + :reader accessor-method-slot-definition))) + +(defclass standard-reader-method (standard-accessor-method) ()) + +(defclass standard-writer-method (standard-accessor-method) ()) diff --git a/src/lsp/config.lsp.in b/src/lsp/config.lsp.in index 78e560996..1f87b4511 100644 --- a/src/lsp/config.lsp.in +++ b/src/lsp/config.lsp.in @@ -46,7 +46,7 @@ Returns, as a string, the location of the machine on which ECL runs." (defun lisp-implementation-version () "Args:() Returns the version of your ECL as a string." - "@PACKAGE_VERSION@ (CVS 2008-04-24 12:45)") + "@PACKAGE_VERSION@ (CVS 2008-04-28 17:22)") (defun machine-type () "Args: ()