X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fslots-boot.lisp;h=dc46d563899cf100a661810350e6636867ea4293;hb=937a46e64983862cb9e21761db95e58700341940;hp=a73b7b790cb0ac50301e21beef0d2f1d3279c2cf;hpb=872175cd9cb5b4966a36d4bd92421cc407a0355b;p=sbcl.git

diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp
index a73b7b7..dc46d56 100644
--- a/src/pcl/slots-boot.lisp
+++ b/src/pcl/slots-boot.lisp
@@ -23,54 +23,81 @@
 
 (in-package "SB-PCL")
 
-(defmacro slot-symbol (slot-name type)
-  `(if (and (symbolp ,slot-name) (symbol-package ,slot-name))
-       (or (get ,slot-name ',(ecase type
-			       (reader 'reader-symbol)
-			       (writer 'writer-symbol)
-			       (boundp 'boundp-symbol)))
-	   (intern (format nil "~A ~A slot ~A"
-			   (package-name (symbol-package ,slot-name))
-			   (symbol-name ,slot-name)
-			   ,(symbol-name type))
-		   *slot-accessor-name-package*))
-       (progn
-	 (error "Non-symbol and non-interned symbol slot name accessors~
-		 are not yet implemented.")
-	 ;;(make-symbol (format nil "~A ~A" ,slot-name ,type))
-	 )))
-
-(defun slot-reader-symbol (slot-name)
-  (slot-symbol slot-name reader))
-
-(defun slot-writer-symbol (slot-name)
-  (slot-symbol slot-name writer))
-
-(defun slot-boundp-symbol (slot-name)
-  (slot-symbol slot-name boundp))
-
-(defmacro asv-funcall (sym slot-name type &rest args)
-  (declare (ignore type))
-  `(if (fboundp ',sym)
-       (,sym ,@args)
-       (no-slot ',sym ',slot-name)))
-
-(defun no-slot (sym slot-name)
-  (error "No class has a slot named ~S (~S has no function binding)."
-	 slot-name sym))
+(defun ensure-accessor (type fun-name slot-name)
+  (labels ((slot-missing-fun (slot-name type)
+	     (let* ((method-type (ecase type
+				   (slot-value 'reader-method)
+				   (setf 'writer-method)
+				   (slot-boundp 'boundp-method)))
+		    (initargs
+		     (copy-tree
+		      (ecase type
+			(slot-value
+			 (make-method-function
+			  (lambda (obj)
+			    (values
+			     (slot-missing (class-of obj) obj slot-name
+					   'slot-value)))))
+			(slot-boundp
+			 (make-method-function
+			  (lambda (obj)
+			    (not (not
+				  (slot-missing (class-of obj) obj slot-name
+						'slot-boundp))))))
+			(setf
+			 (make-method-function
+			  (lambda (val obj)
+			    (slot-missing (class-of obj) obj slot-name
+					  'setf val)
+			    val)))))))
+	       (setf (getf (getf initargs :plist) :slot-name-lists)
+		     (list (list nil slot-name)))
+	       (setf (getf (getf initargs :plist) :pv-table-symbol)
+                     (gensym))
+	       (list* :method-spec (list method-type 'slot-object slot-name)
+                      initargs)))
+	   (add-slot-missing-method (gf slot-name type)
+	     (multiple-value-bind (class lambda-list specializers)
+                 (ecase type
+                   (slot-value
+                    (values 'standard-reader-method
+                            '(object)
+                            (list *the-class-slot-object*)))
+                   (slot-boundp
+                    (values 'standard-boundp-method
+                            '(object)
+                            (list *the-class-slot-object*)))
+                   (setf
+                    (values 'standard-writer-method
+                            '(new-value object)
+                            (list *the-class-t* *the-class-slot-object*))))
+               (add-method gf (make-a-method class
+                                             ()
+                                             lambda-list
+                                             specializers
+                                             (slot-missing-fun slot-name type)
+                                             "generated slot-missing method"
+                                             slot-name)))))
+        (unless (fboundp fun-name)
+      (let ((gf (ensure-generic-function fun-name)))
+        (ecase type
+          (reader (add-slot-missing-method gf slot-name 'slot-value))
+          (boundp (add-slot-missing-method gf slot-name 'slot-boundp))
+          (writer (add-slot-missing-method gf slot-name 'setf)))
+        (setf (plist-value gf 'slot-missing-method) t))
+      t)))
 
 (defmacro accessor-slot-value (object slot-name)
-  (unless (constantp slot-name)
-    (error "~S requires its slot-name argument to be a constant"
-	   'accessor-slot-value))
+  (aver (constantp slot-name))
   (let* ((slot-name (eval slot-name))
-	 (sym (slot-reader-symbol slot-name)))
-    `(asv-funcall ,sym ,slot-name reader ,object)))
+	 (reader-name (slot-reader-name slot-name)))
+    `(let ((.ignore. (load-time-value
+		      (ensure-accessor 'reader ',reader-name ',slot-name))))
+      (declare (ignore .ignore.))
+      (funcall #',reader-name ,object))))
 
 (defmacro accessor-set-slot-value (object slot-name new-value &environment env)
-  (unless (constantp slot-name)
-    (error "~S requires its slot-name argument to be a constant"
-	   'accessor-set-slot-value))
+  (aver (constantp slot-name))
   (setq object (macroexpand object env))
   (setq slot-name (macroexpand slot-name env))
   (let* ((slot-name (eval slot-name))
@@ -78,159 +105,196 @@
 		     (let ((object-var (gensym)))
 		       (prog1 `((,object-var ,object))
 			 (setq object object-var)))))
-	 (sym (slot-writer-symbol slot-name))
-	 (form `(asv-funcall ,sym ,slot-name writer ,new-value ,object)))
+	 (writer-name (slot-writer-name slot-name))
+	 (form
+	  `(let ((.ignore.
+		  (load-time-value
+		   (ensure-accessor 'writer ',writer-name ',slot-name)))
+		 (.new-value. ,new-value))
+	    (declare (ignore .ignore.))
+	    (funcall #',writer-name .new-value. ,object)
+	    .new-value.)))
     (if bindings
 	`(let ,bindings ,form)
 	form)))
 
 (defmacro accessor-slot-boundp (object slot-name)
-  (unless (constantp slot-name)
-    (error "~S requires its slot-name argument to be a constant"
-	   'accessor-slot-boundp))
-  (let* ((slot-name (eval slot-name)))
-    `(slot-boundp-normal ,object ',slot-name)))
-
-(defun structure-slot-boundp (object)
-  (declare (ignore object))
-  t)
+  (aver (constantp slot-name))
+  (let* ((slot-name (eval slot-name))
+	 (boundp-name (slot-boundp-name slot-name)))
+    `(let ((.ignore. (load-time-value
+		      (ensure-accessor 'boundp ',boundp-name ',slot-name))))
+      (declare (ignore .ignore.))
+      (funcall #',boundp-name ,object))))
 
 (defun make-structure-slot-boundp-function (slotd)
-  (let* ((reader (slot-definition-internal-reader-function slotd))
-	 (fun #'(lambda (object)
-		  (not (eq (funcall reader object) +slot-unbound+)))))
-    (declare (type function reader))
-    fun))
+  (declare (ignore slotd))
+  (lambda (object)
+    (declare (ignore object))
+    t))
 
 (defun get-optimized-std-accessor-method-function (class slotd name)
-  (if (structure-class-p class)
-      (ecase name
-	(reader (slot-definition-internal-reader-function slotd))
-	(writer (slot-definition-internal-writer-function slotd))
-	(boundp (make-structure-slot-boundp-function slotd)))
-      (let* ((fsc-p (cond ((standard-class-p class) nil)
-			  ((funcallable-standard-class-p class) t)
-			  ((std-class-p class)
-			   ;; Shouldn't be using the optimized-std-accessors
-			   ;; in this case.
-			   #+nil (format t "* warning: ~S ~S~%   ~S~%"
-				   name slotd class)
-			   nil)
-			  (t (error "~S is not a STANDARD-CLASS." class))))
-	     (slot-name (slot-definition-name slotd))
-	     (index (slot-definition-location slotd))
-	     (function (ecase name
-			 (reader #'make-optimized-std-reader-method-function)
-			 (writer #'make-optimized-std-writer-method-function)
-			 (boundp #'make-optimized-std-boundp-method-function)))
-	     (value (funcall function fsc-p slot-name index)))
-	(declare (type function function))
-	(values value index))))
+  (cond
+    ((structure-class-p class)
+     (ecase name
+       (reader (slot-definition-internal-reader-function slotd))
+       (writer (slot-definition-internal-writer-function slotd))
+       (boundp (make-structure-slot-boundp-function slotd))))
+    ((condition-class-p class)
+     (ecase name
+       (reader (slot-definition-reader-function slotd))
+       (writer (slot-definition-writer-function slotd))
+       (boundp (slot-definition-boundp-function slotd))))
+    (t
+     (let* ((fsc-p (cond ((standard-class-p class) nil)
+			 ((funcallable-standard-class-p class) t)
+			 ((std-class-p class)
+			  ;; Shouldn't be using the optimized-std-accessors
+			  ;; in this case.
+			  #+nil (format t "* warning: ~S ~S~%   ~S~%"
+					name slotd class)
+			  nil)
+			 (t (error "~S is not a STANDARD-CLASS." class))))
+	    (slot-name (slot-definition-name slotd))
+	    (index (slot-definition-location slotd))
+	    (function (ecase name
+			(reader #'make-optimized-std-reader-method-function)
+			(writer #'make-optimized-std-writer-method-function)
+			(boundp #'make-optimized-std-boundp-method-function)))
+	    (value (funcall function fsc-p slot-name index)))
+       (declare (type function function))
+       (values value index)))))
 
 (defun make-optimized-std-reader-method-function (fsc-p slot-name index)
   (declare #.*optimize-speed*)
-  (set-function-name
+  (set-fun-name
    (etypecase index
-     (fixnum (if fsc-p
-		 (lambda (instance)
-		   (let ((value (clos-slots-ref (fsc-instance-slots instance)
-						index)))
-		     (if (eq value +slot-unbound+)
-			 (slot-unbound (class-of instance) instance slot-name)
-			 value)))
-		 (lambda (instance)
-		   (let ((value (clos-slots-ref (std-instance-slots instance)
-					      index)))
-		     (if (eq value +slot-unbound+)
-			 (slot-unbound (class-of instance) instance slot-name)
-			 value)))))
-     (cons   (lambda (instance)
-	       (let ((value (cdr index)))
-		 (if (eq value +slot-unbound+)
-		     (slot-unbound (class-of instance) instance slot-name)
-		     value)))))
+     (fixnum
+      (if fsc-p
+	  (lambda (instance)
+	    (check-obsolete-instance instance)
+	    (let ((value (clos-slots-ref (fsc-instance-slots instance) index)))
+	      (if (eq value +slot-unbound+)
+		  (values
+		   (slot-unbound (class-of instance) instance slot-name))
+		  value)))
+	  (lambda (instance)
+	    (check-obsolete-instance instance)
+	    (let ((value (clos-slots-ref (std-instance-slots instance) index)))
+	      (if (eq value +slot-unbound+)
+		  (values
+		   (slot-unbound (class-of instance) instance slot-name))
+		  value)))))
+     (cons
+      (lambda (instance)
+	(check-obsolete-instance instance)
+	(let ((value (cdr index)))
+	  (if (eq value +slot-unbound+)
+	      (values (slot-unbound (class-of instance) instance slot-name))
+	      value)))))
    `(reader ,slot-name)))
 
 (defun make-optimized-std-writer-method-function (fsc-p slot-name index)
   (declare #.*optimize-speed*)
-  (set-function-name
+  (set-fun-name
    (etypecase index
      (fixnum (if fsc-p
 		 (lambda (nv instance)
+		   (check-obsolete-instance instance)
 		   (setf (clos-slots-ref (fsc-instance-slots instance) index)
 			 nv))
 		 (lambda (nv instance)
+		   (check-obsolete-instance instance)
 		   (setf (clos-slots-ref (std-instance-slots instance) index)
 			 nv))))
      (cons   (lambda (nv instance)
-	       (declare (ignore instance))
+	       (check-obsolete-instance instance)
 	       (setf (cdr index) nv))))
    `(writer ,slot-name)))
 
 (defun make-optimized-std-boundp-method-function (fsc-p slot-name index)
   (declare #.*optimize-speed*)
-  (set-function-name
+  (set-fun-name
    (etypecase index
      (fixnum (if fsc-p
-		 #'(lambda (instance)
-		     (not (eq (clos-slots-ref (fsc-instance-slots instance)
-					     index)
-			      +slot-unbound+)))
-		 #'(lambda (instance)
-		     (not (eq (clos-slots-ref (std-instance-slots instance)
-					     index)
-			      +slot-unbound+)))))
-     (cons   #'(lambda (instance)
-		 (declare (ignore instance))
-		 (not (eq (cdr index) +slot-unbound+)))))
+		 (lambda (instance)
+		   (check-obsolete-instance instance)
+		   (not (eq (clos-slots-ref (fsc-instance-slots instance)
+					    index)
+			    +slot-unbound+)))
+		 (lambda (instance)
+		   (check-obsolete-instance instance)
+		   (not (eq (clos-slots-ref (std-instance-slots instance)
+					    index)
+			    +slot-unbound+)))))
+     (cons (lambda (instance)
+	     (check-obsolete-instance instance)
+	     (not (eq (cdr index) +slot-unbound+)))))
    `(boundp ,slot-name)))
 
 (defun make-optimized-structure-slot-value-using-class-method-function (function)
   (declare (type function function))
   (lambda (class object slotd)
-    (let ((value (funcall function object)))
-      (if (eq value +slot-unbound+)
-	  (slot-unbound class object (slot-definition-name slotd))
-	  value))))
+    (declare (ignore class slotd))
+    (funcall function object)))
 
 (defun make-optimized-structure-setf-slot-value-using-class-method-function (function)
   (declare (type function function))
-  #'(lambda (nv class object slotd)
-      (declare (ignore class slotd))
-      (funcall function nv object)))
+  (lambda (nv class object slotd)
+    (declare (ignore class slotd))
+    (funcall function nv object)))
 
-(defun make-optimized-structure-slot-boundp-using-class-method-function (function)
-  (declare (type function function))
-  #'(lambda (class object slotd)
-      (declare (ignore class slotd))
-      (not (eq (funcall function object) +slot-unbound+))))
+(defun make-optimized-structure-slot-boundp-using-class-method-function ()
+  (lambda (class object slotd)
+    (declare (ignore class object slotd))
+    t))
 
-(defun get-optimized-std-slot-value-using-class-method-function (class
-								 slotd
-								 name)
-  (if (structure-class-p class)
-      (ecase name
-	(reader (make-optimized-structure-slot-value-using-class-method-function
-		 (slot-definition-internal-reader-function slotd)))
-	(writer (make-optimized-structure-setf-slot-value-using-class-method-function
-		 (slot-definition-internal-writer-function slotd)))
-	(boundp (make-optimized-structure-slot-boundp-using-class-method-function
-		 (slot-definition-internal-writer-function slotd))))
-      (let* ((fsc-p (cond ((standard-class-p class) nil)
-			  ((funcallable-standard-class-p class) t)
-			  (t (error "~S is not a standard-class" class))))
-	     (slot-name (slot-definition-name slotd))
-	     (index (slot-definition-location slotd))
-	     (function
-	      (ecase name
-		(reader
-		 #'make-optimized-std-slot-value-using-class-method-function)
-		(writer
-		 #'make-optimized-std-setf-slot-value-using-class-method-function)
-		(boundp
-		 #'make-optimized-std-slot-boundp-using-class-method-function))))
-	(declare (type function function))
-	(values (funcall function fsc-p slot-name index) index))))
+(defun get-optimized-std-slot-value-using-class-method-function
+    (class slotd name)
+  (cond
+    ((structure-class-p class)
+     (ecase name
+       (reader (make-optimized-structure-slot-value-using-class-method-function
+		(slot-definition-internal-reader-function slotd)))
+       (writer (make-optimized-structure-setf-slot-value-using-class-method-function
+		(slot-definition-internal-writer-function slotd)))
+       (boundp (make-optimized-structure-slot-boundp-using-class-method-function))))
+    ((condition-class-p class)
+     (ecase name
+       (reader
+	(let ((fun (slot-definition-reader-function slotd)))
+	  (declare (type function fun))
+	  (lambda (class object slotd)
+	    (declare (ignore class slotd))
+	    (funcall fun object))))
+       (writer
+	(let ((fun (slot-definition-writer-function slotd)))
+	  (declare (type function fun))
+	  (lambda (new-value class object slotd)
+	    (declare (ignore class slotd))
+	    (funcall fun new-value object))))
+       (boundp
+	(let ((fun (slot-definition-boundp-function slotd)))
+	  (declare (type function fun))
+	  (lambda (class object slotd)
+	    (declare (ignore class slotd))
+	    (funcall fun object))))))
+    (t
+     (let* ((fsc-p (cond ((standard-class-p class) nil)
+			 ((funcallable-standard-class-p class) t)
+			 (t (error "~S is not a standard-class" class))))
+	    (slot-name (slot-definition-name slotd))
+	    (index (slot-definition-location slotd))
+	    (function
+	     (ecase name
+	       (reader
+		#'make-optimized-std-slot-value-using-class-method-function)
+	       (writer
+		#'make-optimized-std-setf-slot-value-using-class-method-function)
+	       (boundp
+		#'make-optimized-std-slot-boundp-using-class-method-function))))
+       (declare (type function function))
+       (values (funcall function fsc-p slot-name index) index)))))
 
 (defun make-optimized-std-slot-value-using-class-method-function
     (fsc-p slot-name index)
@@ -239,25 +303,26 @@
     (fixnum (if fsc-p
 		(lambda (class instance slotd)
 		  (declare (ignore slotd))
-		  (unless (fsc-instance-p instance) (error "not fsc"))
+		  (check-obsolete-instance instance)
 		  (let ((value (clos-slots-ref (fsc-instance-slots instance)
 					       index)))
 		    (if (eq value +slot-unbound+)
-			(slot-unbound class instance slot-name)
+			(values (slot-unbound class instance slot-name))
 			value)))
 		(lambda (class instance slotd)
 		  (declare (ignore slotd))
-		  (unless (std-instance-p instance) (error "not std"))
+		  (check-obsolete-instance instance)
 		  (let ((value (clos-slots-ref (std-instance-slots instance)
 					       index)))
 		    (if (eq value +slot-unbound+)
-			(slot-unbound class instance slot-name)
+			(values (slot-unbound class instance slot-name))
 			value)))))
     (cons   (lambda (class instance slotd)
 	      (declare (ignore slotd))
+	      (check-obsolete-instance instance)
 	      (let ((value (cdr index)))
 		(if (eq value +slot-unbound+)
-		    (slot-unbound class instance slot-name)
+		    (values (slot-unbound class instance slot-name))
 		    value))))))
 
 (defun make-optimized-std-setf-slot-value-using-class-method-function
@@ -268,14 +333,17 @@
     (fixnum (if fsc-p
 		(lambda (nv class instance slotd)
 		  (declare (ignore class slotd))
+		  (check-obsolete-instance instance)
 		  (setf (clos-slots-ref (fsc-instance-slots instance) index)
 			nv))
 		(lambda (nv class instance slotd)
 		  (declare (ignore class slotd))
+		  (check-obsolete-instance instance)
 		  (setf (clos-slots-ref (std-instance-slots instance) index)
 			nv))))
     (cons  (lambda (nv class instance slotd)
-	     (declare (ignore class instance slotd))
+	     (declare (ignore class slotd))
+	     (check-obsolete-instance instance)
 	     (setf (cdr index) nv)))))
 
 (defun make-optimized-std-slot-boundp-using-class-method-function
@@ -286,20 +354,23 @@
     (fixnum (if fsc-p
 		(lambda (class instance slotd)
 		  (declare (ignore class slotd))
+		  (check-obsolete-instance instance)
 		  (not (eq (clos-slots-ref (fsc-instance-slots instance) index)
 			   +slot-unbound+)))
 		(lambda (class instance slotd)
 		  (declare (ignore class slotd))
+		  (check-obsolete-instance instance)
 		  (not (eq (clos-slots-ref (std-instance-slots instance) index)
 			   +slot-unbound+)))))
     (cons   (lambda (class instance slotd)
-	      (declare (ignore class instance slotd))
+	      (declare (ignore class slotd))
+	      (check-obsolete-instance instance)
 	      (not (eq (cdr index) +slot-unbound+))))))
 
 (defun get-accessor-from-svuc-method-function (class slotd sdfun name)
   (macrolet ((emf-funcall (emf &rest args)
 	       `(invoke-effective-method-function ,emf nil ,@args)))
-    (set-function-name
+    (set-fun-name
      (case name
        (reader (lambda (instance)
 		 (emf-funcall sdfun class instance slotd)))
@@ -310,7 +381,7 @@
      `(,name ,(class-name class) ,(slot-definition-name slotd)))))
 
 (defun make-internal-reader-method-function (class-name slot-name)
-  (list* ':method-spec `(internal-reader-method ,class-name ,slot-name)
+  (list* :method-spec `(internal-reader-method ,class-name ,slot-name)
 	 (make-method-function
 	  (lambda (instance)
 	    (let ((wrapper (get-instance-wrapper-or-nil instance)))
@@ -324,16 +395,16 @@
 		       (let ((value (clos-slots-ref (get-slots instance)
 						    index)))
 			 (if (eq value +slot-unbound+)
-			     (slot-unbound (class-of instance)
-					   instance
-					   slot-name)
+			     (values (slot-unbound (class-of instance)
+						   instance
+						   slot-name))
 			     value)))
 		      (cons
 		       (let ((value (cdr index)))
 			 (if (eq value +slot-unbound+)
-			     (slot-unbound (class-of instance)
-					   instance
-					   slot-name)
+			     (values (slot-unbound (class-of instance)
+						   instance
+						   slot-name))
 			     value)))
 		      (t
 		       (error "~@<The wrapper for class ~S does not have ~
@@ -352,10 +423,10 @@
 			 (instance-read-internal
 			  .pv. instance-slots 1
 			  (slot-value instance slot-name))))))))
-    (setf (getf (getf initargs ':plist) ':slot-name-lists)
+    (setf (getf (getf initargs :plist) :slot-name-lists)
 	  (list (list nil slot-name)))
-    (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol)
-    (list* ':method-spec `(reader-method ,class-name ,slot-name)
+    (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)
+    (list* :method-spec `(reader-method ,class-name ,slot-name)
 	   initargs)))
 
 (defun make-std-writer-method-function (class-name slot-name)
@@ -369,10 +440,10 @@
 			 (instance-write-internal
 			  .pv. instance-slots 1 nv
 			  (setf (slot-value instance slot-name) nv))))))))
-    (setf (getf (getf initargs ':plist) ':slot-name-lists)
+    (setf (getf (getf initargs :plist) :slot-name-lists)
 	  (list nil (list nil slot-name)))
-    (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol)
-    (list* ':method-spec `(writer-method ,class-name ,slot-name)
+    (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)
+    (list* :method-spec `(writer-method ,class-name ,slot-name)
 	   initargs)))
 
 (defun make-std-boundp-method-function (class-name slot-name)
@@ -386,29 +457,22 @@
 			  (instance-boundp-internal
 			   .pv. instance-slots 1
 			   (slot-boundp instance slot-name))))))))
-    (setf (getf (getf initargs ':plist) ':slot-name-lists)
+    (setf (getf (getf initargs :plist) :slot-name-lists)
 	  (list (list nil slot-name)))
-    (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol)
-    (list* ':method-spec `(boundp-method ,class-name ,slot-name)
+    (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)
+    (list* :method-spec `(boundp-method ,class-name ,slot-name)
 	   initargs)))
 
 (defun initialize-internal-slot-gfs (slot-name &optional type)
-  (when (or (null type) (eq type 'reader))
-    (let* ((name (slot-reader-symbol slot-name))
-	   (gf (ensure-generic-function name)))
-      (unless (generic-function-methods gf)
-	(add-reader-method *the-class-slot-object* gf slot-name))))
-  (when (or (null type) (eq type 'writer))
-    (let* ((name (slot-writer-symbol slot-name))
-	   (gf (ensure-generic-function name)))
-      (unless (generic-function-methods gf)
-	(add-writer-method *the-class-slot-object* gf slot-name))))
-  nil)
-
-(defun initialize-internal-slot-gfs* (readers writers boundps)
-  (dolist (reader readers)
-    (initialize-internal-slot-gfs reader 'reader))
-  (dolist (writer writers)
-    (initialize-internal-slot-gfs writer 'writer))
-  (dolist (boundp boundps)
-    (initialize-internal-slot-gfs boundp 'boundp)))
+  (macrolet ((frob (type name-fun add-fun)
+	       `(when (or (null type) (eq type ',type))
+		 (let* ((name (,name-fun slot-name))
+			(gf (ensure-generic-function name))
+			(methods (generic-function-methods gf)))
+		   (when (or (null methods)
+			     (plist-value gf 'slot-missing-method))
+		     (setf (plist-value gf 'slot-missing-method) nil)
+		     (,add-fun *the-class-slot-object* gf slot-name))))))
+    (frob reader slot-reader-name add-reader-method)
+    (frob writer slot-writer-name add-writer-method)
+    (frob boundp slot-boundp-name add-boundp-method)))