Implement standard-accessor-method

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

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))

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))))

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

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

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) ())

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: ()