0.8.12.27:
[sbcl.git] / src / pcl / slots-boot.lisp
index 98d9848..354e3e5 100644 (file)
 
 (in-package "SB-PCL")
 \f
-(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
+                :lambda-list (ecase type
+                               ((reader boundp) '(object))
+                               (writer '(new-value object))))))
+        (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.))
+      (truly-the (values t &optional)
+                 (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))
                     (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))
+  (aver (constantp slot-name))
   (let* ((slot-name (eval slot-name))
-        (sym (slot-boundp-symbol slot-name)))
-    `(slot-boundp-normal ,object ',slot-name)))
-
-(defun structure-slot-boundp (object)
-  (declare (ignore object))
-  t)
+        (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))))
+     (null
+      (lambda (instance)
+       ;; maybe MOP-ERROR?  You get here by making effective slot
+       ;; definitions with :ALLOCATION not :INSTANCE or :CLASS, and
+       ;; not defining any methods on SLOT-VALUE-USING-CLASS.
+       (error "~S called on ~S for the slot ~S (with no location information)"
+              'slot-value instance slot-name))))
    `(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))
-              (setf (cdr index) nv))))
+              (check-obsolete-instance instance)
+              (setf (cdr index) nv)))
+     (null
+      (lambda (nv instance)
+       (declare (ignore nv))
+       ;; again, maybe MOP-ERROR (see above)
+       (error "~S called on ~S for the slot ~S (with no location information)"
+              '(setf slot-value) instance slot-name))))
    `(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+))))
+     (null
+      (lambda (instance)
+       (error "~S called on ~S for the slot ~S (with no location information)"
+              'slot-boundp instance slot-name))))
    `(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)
     (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)
-                   value))))))
+                   (values (slot-unbound class instance slot-name))
+                   value))))
+    (null
+     (lambda (class instance slotd)
+       ;; FIXME: MOP-ERROR
+       (error "Standard ~S method called on arguments ~S."
+             'slot-value-using-class (list class instance slotd))))))
 
 (defun make-optimized-std-setf-slot-value-using-class-method-function
     (fsc-p slot-name index)
     (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))
-            (setf (cdr index) nv)))))
+            (declare (ignore class slotd))
+            (check-obsolete-instance instance)
+            (setf (cdr index) nv)))
+    (null (lambda (nv class instance slotd)
+           (error "Standard ~S method called on arguments ~S."
+                  '(setf slot-value-using-class)
+                  (list nv class instance slotd))))))
 
 (defun make-optimized-std-slot-boundp-using-class-method-function
     (fsc-p slot-name index)
     (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))
-             (not (eq (cdr index) +slot-unbound+))))))
+             (declare (ignore class slotd))
+             (check-obsolete-instance instance)
+             (not (eq (cdr index) +slot-unbound+))))
+    (null (lambda (class instance slotd)
+           (error "Standard ~S method called on arguments ~S."
+                  'slot-boundp-using-class (list class instance slotd))))))
 
 (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)))
      `(,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)))
                       (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 ~
                         (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)
                         (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)
                          (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 ll)
+              `(when (or (null type) (eq type ',type))
+                (let* ((name (,name-fun slot-name))
+                       (gf (ensure-generic-function name
+                                                    :lambda-list ',ll))
+                       (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 (object))
+    (frob writer slot-writer-name add-writer-method (new-value object))
+    (frob boundp slot-boundp-name add-boundp-method (object))))