Final changes to make all accessors generic functions, including the MOP standard ones, avoiding infinite recursion.

src/clos/boot.lsp

@@ -371,7 +371,7 @@
 
 (defun canonical-slots (slots)
   (declare (optimize speed (safety 0)))
-  (loop for s in (parse-slots (remove-accessors slots))
+  (loop for s in (parse-slots slots)
      collect (canonical-slot-to-direct-slot nil s)))
 
 (defun add-slots (class slots)

src/clos/combin.lsp

@@ -129,43 +129,44 @@
 	(funcall (first primary) .combined-method-args. (rest primary)))))
 
 (defun standard-compute-effective-method (gf methods)
-  (let* ((before ())
-	 (primary ())
-	 (after ())
-	 (around ()))
-    (dolist (m methods)
-      (let* ((qualifiers (method-qualifiers m))
-	     (f (method-function m)))
-	(cond ((null qualifiers) (push f primary))
-	      ((rest qualifiers) (error-qualifier m qualifiers))
-	      ((eq (setq qualifiers (first qualifiers)) :BEFORE)
-	       (push f before))
-	      ((eq qualifiers :AFTER) (push f after))
-	      ((eq qualifiers :AROUND) (push f around))
-	      (t (error-qualifier m qualifiers)))))
-    ;; When there are no primary methods, an error is to be signaled,
-    ;; and we need not care about :AROUND, :AFTER or :BEFORE methods.
-    (when (null primary)
-      (return-from standard-compute-effective-method
-	#'(lambda (&rest args)
-	    (apply 'no-primary-method gf args))))
-    ;; PRIMARY, BEFORE and AROUND are reversed because they have to
-    ;; be on most-specific-first order (ANSI 7.6.6.2), while AFTER
-    ;; may remain as it is because it is least-specific-order.
-    (setf primary (nreverse primary)
-	  before (nreverse before))
-    (if around
-	(let ((main (if (or before after)
-			(list
-			 (standard-main-effective-method before primary after))
-			primary)))
-	  (setf around (nreverse around))
-	  (combine-method-functions (first around)
-				    (nconc (rest around) main)))
-	(if (or before after)
-	    (standard-main-effective-method before primary after)
-	    (combine-method-functions (first primary) (rest primary))))
-    ))
+  (with-early-accessors (+standard-method-slots+)
+    (let* ((before ())
+	   (primary ())
+	   (after ())
+	   (around ()))
+      (dolist (m methods)
+	(let* ((qualifiers (method-qualifiers m))
+	       (f (method-function m)))
+	  (cond ((null qualifiers) (push f primary))
+		((rest qualifiers) (error-qualifier m qualifiers))
+		((eq (setq qualifiers (first qualifiers)) :BEFORE)
+		 (push f before))
+		((eq qualifiers :AFTER) (push f after))
+		((eq qualifiers :AROUND) (push f around))
+		(t (error-qualifier m qualifiers)))))
+      ;; When there are no primary methods, an error is to be signaled,
+      ;; and we need not care about :AROUND, :AFTER or :BEFORE methods.
+      (when (null primary)
+	(return-from standard-compute-effective-method
+	  #'(lambda (&rest args)
+	      (apply 'no-primary-method gf args))))
+      ;; PRIMARY, BEFORE and AROUND are reversed because they have to
+      ;; be on most-specific-first order (ANSI 7.6.6.2), while AFTER
+      ;; may remain as it is because it is least-specific-order.
+      (setf primary (nreverse primary)
+	    before (nreverse before))
+      (if around
+	  (let ((main (if (or before after)
+			  (list
+			   (standard-main-effective-method before primary after))
+			  primary)))
+	    (setf around (nreverse around))
+	    (combine-method-functions (first around)
+				      (nconc (rest around) main)))
+	  (if (or before after)
+	      (standard-main-effective-method before primary after)
+	      (combine-method-functions (first primary) (rest primary))))
+      )))
 
 ;; ----------------------------------------------------------------------
 ;; DEFINE-METHOD-COMBINATION
@@ -334,11 +335,12 @@
   (declare (type method-combination method-combination)
 	   (type generic-function gf)
 	   (optimize speed (safety 0)))
-  (let* ((compiler (method-combination-compiler method-combination))
-	 (options (method-combination-options method-combination)))
-    (if options
-	(apply compiler gf applicable-methods options)
-	(funcall compiler gf applicable-methods))))
+  (with-early-accessors (+method-combination-slots+)
+    (let* ((compiler (method-combination-compiler method-combination))
+	   (options (method-combination-options method-combination)))
+      (if options
+	  (apply compiler gf applicable-methods options)
+	  (funcall compiler gf applicable-methods)))))
 
 (defun compute-effective-method-function (gf method-combination applicable-methods)
   ;; Cannot be inlined because it will be a method

src/clos/fixup.lsp

@@ -45,9 +45,7 @@
     (map-into direct-slots #'identity new-direct-slots)
     (map-into effective-slots #'identity new-effective-slots)
     (when (typep class 'std-class)
-      (std-create-slots-table class)
-      )
-    (std-class-generate-accessors class))
+      (std-create-slots-table class)))
   (mapc #'convert-one-class (class-direct-subclasses class)))
 
 ;;;
@@ -241,6 +239,13 @@ their lambda lists ~A and ~A are not congruent."
 (function-to-method 'find-method '((gf standard-generic-function)
 				   qualifiers specializers &optional error))
 
+(labels ((create-accessors (class)
+	   (when (typep class 'standard-class)
+	     (std-class-generate-accessors class))
+	   (loop for i in (class-direct-subclasses class)
+	      do (create-accessors i))))
+  (create-accessors (find-class 't)))
+
 ;;; COMPUTE-APPLICABLE-METHODS is used by the core in various places,
 ;;; including instance initialization. This means we cannot just redefine it.
 ;;; Instead, we create an auxiliary function and move definitions from one to

src/clos/kernel.lsp

@@ -168,30 +168,33 @@
       ;; function, where we can replace the output of COMPUTE-DISCRIMINATING-FUNCTION with
       ;; a similar implementation in C
       (compute-discriminating-function gfun)
-    (set-funcallable-instance-function
-     gfun
-     (cond
-       ;; Case 1*
-       ((or (not optimizable)
-	    (> (length (generic-function-spec-list gfun))
-	       si::c-arguments-limit))
-	default-function)
-       ;; Case 2*
-       ((and (not (eq (class-id (class-of gfun)) 'standard-generic-function))
-	     *clos-booted*)
-	t)
-       ;; Cases 3*
-       ((loop with class = (find-class 'standard-reader-method nil)
-	   for m in (generic-function-methods gfun)
-	   always (eq class (class-of m)))
-	'standard-reader-method)
-       ((loop with class = (find-class 'standard-writer-method nil)
-	   for m in (generic-function-methods gfun)
-	   always (eq class (class-of m)))
-	'standard-writer-method)
-       ;; Case 4*
-       (t
-	'standard-generic-function)))))
+    (let ((methods (generic-function-methods gfun)))
+      (set-funcallable-instance-function
+       gfun
+       (cond
+	 ;; Case 1*
+	 ((or (not optimizable)
+	      (> (length (generic-function-spec-list gfun))
+		 si::c-arguments-limit))
+	  default-function)
+	 ;; Case 2*
+	 ((and (not (eq (class-id (class-of gfun)) 'standard-generic-function))
+	       *clos-booted*)
+	  t)
+	 ((null methods)
+	  'standard-generic-function)
+	 ;; Cases 3*
+	 ((loop with class = (find-class 'standard-reader-method nil)
+	     for m in (generic-function-methods gfun)
+	     always (eq class (class-of m)))
+	  'standard-reader-method)
+	 ((loop with class = (find-class 'standard-writer-method nil)
+	     for m in (generic-function-methods gfun)
+	     always (eq class (class-of m)))
+	  'standard-writer-method)
+	 ;; Case 4*
+	 (t
+	  'standard-generic-function))))))
 
 ;;; ----------------------------------------------------------------------
 ;;; COMPUTE-APPLICABLE-METHODS
@@ -218,7 +221,10 @@
 (defun applicable-method-list (gf args)
   (declare (optimize (speed 3))
 	   (si::c-local))
-  (with-early-accessors (+standard-method-slots+ +standard-generic-function-slots+)
+  (with-early-accessors (+standard-method-slots+
+			 +standard-generic-function-slots+
+			 +eql-specializer-slots+
+			 +standard-class-slots+)
     (flet ((applicable-method-p (method args)
 	     (loop for spec in (method-specializers method)
 		for arg in args

src/clos/method.lsp

@@ -39,7 +39,7 @@
 (defun generic-function-method-class (generic-function)
   (if *clos-booted*
       (slot-value generic-function 'method-class)
-      'standard-method))
+      (find-class 'standard-method)))
 
 (defmacro defmethod (&whole whole name &rest args &environment env)
   (let* ((*print-length* 3)
@@ -344,8 +344,12 @@ have disappeared."
 
 (defun make-method (method-class qualifiers specializers lambda-list fun options)
   (declare (ignore options))
-  (with-early-make-instance +standard-method-slots+
-    (method method-class
+  (with-early-make-instance
+      ;; We choose the largest list of slots
+      +standard-accessor-method-slots+
+    (method (if (si::instancep method-class)
+		method-class
+		(find-class method-class))
 	    :generic-function nil
 	    :lambda-list lambda-list
 	    :function fun
@@ -360,7 +364,7 @@ have disappeared."
 
 ;;; early version used during bootstrap
 (defun add-method (gf method)
-  (with-early-accessors (+standard-method-slots+ +standard-generic-function-slots+)
+  (with-early-accessors (+standard-method-slots+ +standard-generic-function-slots+ +standard-class-slots+)
     (let* ((name (generic-function-name gf))
 	   (method-entry (assoc name *early-methods*)))
       (unless method-entry

src/clos/slotvalue.lsp

@@ -32,26 +32,49 @@
       (find slot-name (class-slots class) :key #'slot-definition-name)))
 
 (defun slot-value (self slot-name)
-  (let* ((class (class-of self))
-	 (slotd (find-slot-definition class slot-name)))
-    (if slotd
-	(slot-value-using-class class self slotd)
-	(values (slot-missing class self slot-name 'SLOT-VALUE)))))
+  (let* ((class (class-of self)))
+    (if (or (eq (si:instance-class class) +the-standard-class+)
+	    (eq (si:instance-class class) +the-funcallable-standard-class+))
+	(with-early-accessors (+standard-class-slots+)
+	  (let ((slotd (gethash slot-name (slot-table class) nil)))
+	    (if slotd
+		(let ((value (standard-instance-get self slotd)))
+		  (if (sl:sl-boundp value)
+		      value
+		      (values (slot-unbound class self (slot-definition-name slotd)))))
+		(slot-missing class self slot-name 'SLOT-VALUE))))
+	(let ((slotd (find slot-name (class-slots class) :key #'slot-definition-name)))
+	  (if slotd
+	      (slot-value-using-class class self slotd)
+	      (values (slot-missing class self slot-name 'SLOT-VALUE)))))))
 
 (defun slot-boundp (self slot-name)
-  (let* ((class (class-of self))
-	 (slotd (find-slot-definition class slot-name)))
-    (if slotd
-	(slot-boundp-using-class class self slotd)
-	(values (slot-missing class self slot-name 'SLOT-BOUNDP)))))
+  (let* ((class (class-of self)))
+    (if (or (eq (si:instance-class class) +the-standard-class+)
+	    (eq (si:instance-class class) +the-funcallable-standard-class+))
+	(with-early-accessors (+standard-class-slots+)
+	  (let ((slotd (gethash slot-name (slot-table class) nil)))
+	    (if slotd
+		(si::sl-boundp (standard-instance-get self slotd))
+		(values (slot-missing class self slot-name 'SLOT-BOUNDP)))))
+	(let ((slotd (find slot-name (class-slots class) :key #'slot-definition-name)))
+	  (if slotd
+	      (slot-boundp-using-class class self slotd)
+	      (values (slot-missing class self slot-name 'SLOT-BOUNDP)))))))
 
 (defun (setf slot-value) (value self slot-name)
-  (let* ((class (class-of self))
-	 (slotd (find-slot-definition class slot-name)))
-    (if slotd
-	(funcall #'(setf slot-value-using-class) value class self slotd)
-	(slot-missing class self slot-name 'SETF value))
-    value))
+  (let* ((class (class-of self)))
+    (if (or (eq (si:instance-class class) +the-standard-class+)
+	    (eq (si:instance-class class) +the-funcallable-standard-class+))
+	(with-early-accessors (+standard-class-slots+)
+	  (let ((slotd (gethash slot-name (slot-table class) nil)))
+	    (if slotd
+		(standard-instance-set value self slotd)
+		(slot-missing class self slot-name 'SETF value))))
+	(let ((slotd (find slot-name (class-slots class) :key #'slot-definition-name)))
+	  (if slotd
+	      (setf (slot-value-using-class class self slotd) value)
+	      (slot-missing class self slot-name 'SETF value))))))
 
 (defun slot-makunbound (self slot-name)
   (let* ((class (class-of self))
@@ -70,31 +93,33 @@
 ;;;
 
 (defun standard-instance-get (instance slotd)
-  (ensure-up-to-date-instance instance)
-  (let* ((class (si:instance-class instance))
-	 (location (slot-definition-location slotd)))
-    (cond ((ext:fixnump location)
-	   ;; local slot
-	   (si:instance-ref instance (truly-the fixnum location)))
-	  ((consp location)
-	   ;; shared slot
-	   (car location))
-	  (t
-	   (invalid-slot-definition instance slotd)))))
+  (with-early-accessors (+standard-class-slots+)
+    (ensure-up-to-date-instance instance)
+    (let* ((class (si:instance-class instance))
+	   (location (slot-definition-location slotd)))
+      (cond ((ext:fixnump location)
+	     ;; local slot
+	     (si:instance-ref instance (truly-the fixnum location)))
+	    ((consp location)
+	     ;; shared slot
+	     (car location))
+	    (t
+	     (invalid-slot-definition instance slotd))))))
 
 (defun standard-instance-set (val instance slotd)
-  (ensure-up-to-date-instance instance)
-  (let* ((class (si:instance-class instance))
-	 (location (slot-definition-location slotd)))
-    (cond ((ext:fixnump location)
-	   ;; local slot
-	   (si:instance-set instance (truly-the fixnum location) val))
-	  ((consp location)
-	   ;; shared slot
-	   (setf (car location) val))
-	  (t
-	   (invalid-slot-definition instance slotd))))
-  val)
+  (with-early-accessors (+standard-class-slots+)
+    (ensure-up-to-date-instance instance)
+    (let* ((class (si:instance-class instance))
+	   (location (slot-definition-location slotd)))
+      (cond ((ext:fixnump location)
+	     ;; local slot
+	     (si:instance-set instance (truly-the fixnum location) val))
+	    ((consp location)
+	     ;; shared slot
+	     (setf (car location) val))
+	    (t
+	     (invalid-slot-definition instance slotd))))
+    val))
 
 (defun invalid-slot-definition (instance slotd)
   (error "Effective slot definition lacks a valid location.
@@ -138,12 +163,10 @@ Slot name: ~A"
 (defmethod slot-missing ((class t) object slot-name operation 
 			 &optional new-value)
   (declare (ignore operation new-value class))
-  (print (list 'slot-missing slot-name (class-id class)))
   (error "~A is not a slot of ~A" slot-name object))
 
 (defmethod slot-unbound ((class t) object slot-name)
   (declare (ignore class))
-  (print (list 'slot-unbound (class-id class) (print slot-name)))
   (error 'unbound-slot :instance object :name slot-name))
 
 ;;;

src/clos/standard.lsp

@@ -111,9 +111,9 @@
   ;; be (:allow-other-keys t), which disables the checking of the arguments.
   ;; (Paul Dietz's ANSI test suite, test CLASS-24.4)
   (setf initargs (add-default-initargs class initargs))
-  (let ((keywords (class-valid-initargs class)))
-    (when (eq keywords (si::unbound))
-      (setf keywords (precompute-valid-initarg-keywords class)))
+  (let ((keywords (if (slot-boundp class 'valid-initargs)
+		      (class-valid-initargs class)
+		      (precompute-valid-initarg-keywords class))))
     (check-initargs class initargs nil (class-slots class) keywords))
   (let ((instance (apply #'allocate-instance class initargs)))
     (apply #'initialize-instance instance initargs)
@@ -304,7 +304,8 @@ because it contains a reference to the undefined class~%  ~A"
     ;; their locations. This may imply adding _new_ direct slots.
     ;;
     (when (class-sealedp class)
-      (let* ((free-slots (delete-duplicates (mapcar #'slot-definition-name (class-slots class)))))
+      (let* ((free-slots (delete-duplicates (mapcar #'slot-definition-name (class-slots class))))
+	     (all-slots (class-slots class)))
 	;;
 	;; We first search all slots that belonged to unsealed classes and which
 	;; therefore have no fixed position.
@@ -318,9 +319,10 @@ because it contains a reference to the undefined class~%  ~A"
 	;; the class direct slots.
 	;;
 	(loop for slotd in (class-direct-slots class)
-	   do (let ((name (slot-definition-name slotd)))
+	   do (let* ((name (slot-definition-name slotd))
+		     (other-slotd (find name all-slots :key #'slot-definition-name)))
 		(setf (slot-definition-location slotd)
-		      (slot-definition-location (find-slot-definition class name))
+		      (slot-definition-location other-slotd)
 		      free-slots (delete name free-slots))))
 	;;
 	;; And finally we add one direct slot for each inherited slot that did
@@ -328,7 +330,7 @@ because it contains a reference to the undefined class~%  ~A"
 	;;
 	(loop for name in free-slots
 	   with direct-slots = (class-direct-slots class)
-	   do (let* ((effective-slotd (find-slot-definition class name))
+	   do (let* ((effective-slotd (find name all-slots :key #'slot-definition-name))
 		     (def (loop for (name . rest) in +slot-definition-slots+
 			     nconc (list (getf rest :initarg)
 					 (funcall (getf rest :accessor) effective-slotd)))))
@@ -710,9 +712,9 @@ because it contains a reference to the undefined class~%  ~A"
 				: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))))
+			       'standard-writer-method
+			       (apply #'writer-method-class standard-class slotd
+				      writer-args))))
 	(dolist (fname (slot-definition-readers slotd))
 	  (safe-add-method fname
 			   (make-method reader-class nil `(,standard-class) '(self)