X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmethods.lisp;h=eeb37f926c46c958b4de928b04199d63ba459cfb;hb=46d8e06740236e41db254d95c6bdc662039d32f6;hp=adb89d850ec59d6b34d1c32f3f465f84ff5c4a3d;hpb=42938a8cffe21be4b5a50d2253bbe76bab25e16a;p=sbcl.git

diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index adb89d8..eeb37f9 100644
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -23,29 +23,13 @@
 
 (in-package "SB-PCL")
 
-
 ;;; methods
 ;;;
 ;;; Methods themselves are simple inanimate objects. Most properties of
 ;;; methods are immutable, methods cannot be reinitialized. The following
 ;;; properties of methods can be changed:
 ;;;   METHOD-GENERIC-FUNCTION
-;;;   METHOD-FUNCTION       ??
-
-(defmethod method-function ((method standard-method))
-  (or (slot-value method '%function)
-      (let ((fmf (slot-value method 'fast-function)))
-        (unless fmf ; The :BEFORE SHARED-INITIALIZE method prevents this.
-          (error "~S doesn't seem to have a METHOD-FUNCTION." method))
-        (setf (slot-value method '%function)
-              (method-function-from-fast-function fmf)))))
-
-(defmethod accessor-method-class ((method standard-accessor-method))
-  (car (slot-value method 'specializers)))
-
-(defmethod accessor-method-class ((method standard-writer-method))
-  (cadr (slot-value method 'specializers)))
-
+
 ;;; initialization
 ;;;
 ;;; Error checking is done in before methods. Because of the simplicity of
@@ -78,127 +62,100 @@
   (def update-instance-for-different-class ((old method) new &rest initargs)
     "No behaviour specified for ~S on method objects."))
 
-(defmethod legal-documentation-p ((object standard-method) x)
-  (if (or (null x) (stringp x))
-      t
-      "a string or NULL"))
-
-(defmethod legal-lambda-list-p ((object standard-method) x)
-  (declare (ignore x))
-  t)
+(define-condition invalid-method-initarg (simple-program-error)
+  ((method :initarg :method :reader invalid-method-initarg-method))
+  (:report
+   (lambda (c s)
+     (format s "~@<In initialization of ~S:~2I~_~?~@:>"
+             (invalid-method-initarg-method c)
+             (simple-condition-format-control c)
+             (simple-condition-format-arguments c)))))
+
+(defun invalid-method-initarg (method format-control &rest args)
+  (error 'invalid-method-initarg :method method
+         :format-control format-control :format-arguments args))
+
+(defun check-documentation (method doc)
+  (unless (or (null doc) (stringp doc))
+    (invalid-method-initarg method "~@<~S of ~S is neither ~S nor a ~S.~@:>"
+                            :documentation doc 'null 'string)))
+(defun check-lambda-list (method ll)
+  nil)
 
-(defmethod legal-method-function-p ((object standard-method) x)
-  (if (functionp x)
-      t
-      "a function"))
+(defun check-method-function (method fun)
+  (unless (functionp fun)
+    (invalid-method-initarg method "~@<~S of ~S is not a ~S.~@:>"
+                            :function fun 'function)))
 
-(defmethod legal-qualifiers-p ((object standard-method) x)
+(defun check-qualifiers (method qualifiers)
   (flet ((improper-list ()
-           (return-from legal-qualifiers-p "Is not a proper list.")))
-    (dolist-carefully (q x improper-list)
-      (let ((ok (legal-qualifier-p object q)))
-        (unless (eq ok t)
-          (return-from legal-qualifiers-p
-            (format nil "Contains ~S which ~A" q ok)))))
-    t))
-
-(defmethod legal-qualifier-p ((object standard-method) x)
-  (if (and x (atom x))
-      t
-      "is not a non-null atom"))
-
-(defmethod legal-slot-name-p ((object standard-method) x)
-  (cond ((not (symbolp x)) "is not a symbol")
-        (t t)))
-
-(defmethod legal-specializers-p ((object standard-method) x)
+           (invalid-method-initarg method
+                                   "~@<~S of ~S is an improper list.~@:>"
+                                   :qualifiers qualifiers)))
+    (dolist-carefully (q qualifiers improper-list)
+      (unless (and q (atom q))
+        (invalid-method-initarg method
+                                "~@<~S, in ~S ~S, is not a non-~S atom.~@:>"
+                                q :qualifiers qualifiers 'null)))))
+
+(defun check-slot-name (method name)
+  (unless (symbolp name)
+    (invalid-method-initarg "~@<~S of ~S is not a ~S.~@:>"
+                            :slot-name name 'symbol)))
+
+(defun check-specializers (method specializers)
   (flet ((improper-list ()
-           (return-from legal-specializers-p "Is not a proper list.")))
-    (dolist-carefully (s x improper-list)
-      (let ((ok (legal-specializer-p object s)))
-        (unless (eq ok t)
-          (return-from legal-specializers-p
-            (format nil "Contains ~S which ~A" s ok)))))
-    t))
-
-(defvar *allow-experimental-specializers-p* nil)
-
-(defmethod legal-specializer-p ((object standard-method) x)
-  (if (if *allow-experimental-specializers-p*
-          (specializerp x)
-          (or (classp x)
-              (eql-specializer-p x)))
-      t
-      "is neither a class object nor an EQL specializer"))
-
-(defmethod shared-initialize :before ((method standard-method)
-                                      slot-names
-                                      &key qualifiers
-                                           lambda-list
-                                           specializers
-                                           function
-                                           fast-function
-                                           documentation)
+           (invalid-method-initarg method
+                                   "~@<~S of ~S is an improper list.~@:>"
+                                   :specializers specializers)))
+    (dolist-carefully (s specializers improper-list)
+      (unless (specializerp s)
+        (invalid-method-initarg method
+                                "~@<~S, in ~S ~S, is not a ~S.~@:>"
+                                s :specializers specializers 'specializer)))
+    ;; KLUDGE: ANSI says that it's not valid to have methods
+    ;; specializing on classes which are "not defined", leaving
+    ;; unclear what the definedness of a class is; AMOP suggests that
+    ;; forward-referenced-classes, since they have proper names and
+    ;; all, are at least worthy of some level of definition.  We allow
+    ;; methods specialized on forward-referenced-classes, but it's
+    ;; non-portable and potentially dubious, so
+    (let ((frcs (remove-if-not #'forward-referenced-class-p specializers)))
+      (unless (null frcs)
+        (style-warn "~@<Defining a method using ~
+                     ~V[~;~1{~S~}~;~1{~S and ~S~}~:;~{~#[~;and ~]~S~^, ~}~] ~
+                     as ~2:*~V[~;a specializer~:;specializers~].~@:>"
+                    (length frcs) frcs)))))
+
+(defmethod shared-initialize :before
+    ((method standard-method) slot-names &key
+     qualifiers lambda-list specializers function documentation)
   (declare (ignore slot-names))
-  (flet ((lose (initarg value string)
-           (error "when initializing the method ~S:~%~
-                   The ~S initialization argument was: ~S.~%~
-                   which ~A."
-                  method initarg value string)))
-    (let ((check-qualifiers    (legal-qualifiers-p method qualifiers))
-          (check-lambda-list   (legal-lambda-list-p method lambda-list))
-          (check-specializers  (legal-specializers-p method specializers))
-          (check-fun (legal-method-function-p method
-                                              (or function
-                                                  fast-function)))
-          (check-documentation (legal-documentation-p method documentation)))
-      (unless (eq check-qualifiers t)
-        (lose :qualifiers qualifiers check-qualifiers))
-      (unless (eq check-lambda-list t)
-        (lose :lambda-list lambda-list check-lambda-list))
-      (unless (eq check-specializers t)
-        (lose :specializers specializers check-specializers))
-      (unless (eq check-fun t)
-        (lose :function function check-fun))
-      (unless (eq check-documentation t)
-        (lose :documentation documentation check-documentation)))))
-
-(defmethod shared-initialize :before ((method standard-accessor-method)
-                                      slot-names
-                                      &key slot-name slot-definition)
+  ;; FIXME: it's not clear to me (CSR, 2006-08-09) why methods get
+  ;; this extra paranoia and nothing else does; either everything
+  ;; should be aggressively checking initargs, or nothing much should.
+  ;; In either case, it would probably be better to have :type
+  ;; declarations in slots, which would then give a suitable type
+  ;; error (if we implement type-checking for slots...) rather than
+  ;; this hand-crafted thing.
+  (check-qualifiers method qualifiers)
+  (check-lambda-list method lambda-list)
+  (check-specializers method specializers)
+  (check-method-function method function)
+  (check-documentation method documentation))
+
+(defmethod shared-initialize :before
+    ((method standard-accessor-method) slot-names &key
+     slot-name slot-definition)
   (declare (ignore slot-names))
   (unless slot-definition
-    (let ((legalp (legal-slot-name-p method slot-name)))
-      ;; FIXME: nasty convention; should be renamed to ILLEGAL-SLOT-NAME-P and
-      ;; ILLEGALP, and the convention redone to be less twisty
-      (unless (eq legalp t)
-        (error "The value of the :SLOT-NAME initarg ~A." legalp)))))
+    (check-slot-name method slot-name)))
 
 (defmethod shared-initialize :after ((method standard-method) slot-names
-                                     &rest initargs
-                                     &key qualifiers method-spec plist)
-  (declare (ignore slot-names method-spec plist))
-  (initialize-method-function initargs nil method)
-  (setf (plist-value method 'qualifiers) qualifiers)
-  #+ignore
-  (setf (slot-value method 'closure-generator)
-        (method-function-closure-generator (slot-value method '%function))))
-
-(defmethod shared-initialize :after ((method standard-accessor-method)
-                                     slot-names
-                                     &key)
+                                     &rest initargs &key)
   (declare (ignore slot-names))
-  (with-slots (slot-name %slot-definition) method
-    (unless %slot-definition
-      (let ((class (accessor-method-class method)))
-        (when (slot-class-p class)
-          (setq %slot-definition (find slot-name (class-direct-slots class)
-                                      :key #'slot-definition-name)))))
-    (when (and %slot-definition (null slot-name))
-      (setq slot-name (slot-definition-name %slot-definition)))))
-
-(defmethod method-qualifiers ((method standard-method))
-  (plist-value method 'qualifiers))
+  (initialize-method-function initargs method))
+
 
 (defvar *the-class-generic-function*
   (find-class 'generic-function))
@@ -252,36 +209,14 @@
            (initarg-error :method-combination
                           "not supplied"
                           "a method combination object")))))
-
-#||
-(defmethod reinitialize-instance ((generic-function standard-generic-function)
-                                  &rest initargs
-                                  &key name
-                                       lambda-list
-                                       argument-precedence-order
-                                       declarations
-                                       documentation
-                                       method-class
-                                       method-combination)
-  (declare (ignore documentation declarations argument-precedence-order
-                   lambda-list name method-class method-combination))
-  (macrolet ((add-initarg (check name slot-name)
-               `(unless ,check
-                  (push (slot-value generic-function ,slot-name) initargs)
-                  (push ,name initargs))))
-;   (add-initarg name :name 'name)
-;   (add-initarg lambda-list :lambda-list 'lambda-list)
-;   (add-initarg argument-precedence-order
-;                :argument-precedence-order
-;                'argument-precedence-order)
-;   (add-initarg declarations :declarations 'declarations)
-;   (add-initarg documentation :documentation '%documentation)
-;   (add-initarg method-class :method-class 'method-class)
-;   (add-initarg method-combination :method-combination '%method-combination)
-    (apply #'call-next-method generic-function initargs)))
-||#
 
-;;; These two are scheduled for demolition.
+(defun find-generic-function (name &optional (errorp t))
+  (let ((fun (and (fboundp name) (fdefinition name))))
+    (cond
+      ((and fun (typep fun 'generic-function)) fun)
+      (errorp (error "No generic function named ~S." name))
+      (t nil))))
+
 (defun real-add-named-method (generic-function-name
                               qualifiers
                               specializers
@@ -291,11 +226,13 @@
                (typep (fdefinition generic-function-name) 'generic-function))
     (style-warn "implicitly creating new generic function ~S"
                 generic-function-name))
-  ;; XXX What about changing the class of the generic function if
-  ;; there is one? Whose job is that, anyway? Do we need something
-  ;; kind of like CLASS-FOR-REDEFINITION?
-  (let* ((generic-function
-           (ensure-generic-function generic-function-name))
+  (let* ((existing-gf (find-generic-function generic-function-name nil))
+         (generic-function
+          (if existing-gf
+              (ensure-generic-function
+               generic-function-name
+               :generic-function-class (class-of existing-gf))
+              (ensure-generic-function generic-function-name)))
          (specs (parse-specializers specializers))
          (proto (method-prototype-for-gf generic-function-name))
          (new (apply #'make-instance (class-of proto)
@@ -673,7 +610,7 @@
    ))
 
 (defmethod same-specializer-p ((specl1 specializer) (specl2 specializer))
-  nil)
+  (eql specl1 specl2))
 
 (defmethod same-specializer-p ((specl1 class) (specl2 class))
   (eq specl1 specl2))
@@ -692,14 +629,23 @@
 (defmethod specializer-class ((specializer eql-specializer))
   (class-of (slot-value specializer 'object)))
 
-(defvar *in-gf-arg-info-p* nil)
-(setf (gdefinition 'arg-info-reader)
-      (let ((mf (initialize-method-function
-                 (make-internal-reader-method-function
-                  'standard-generic-function 'arg-info)
-                 t)))
-        (lambda (&rest args) (funcall mf args nil))))
+;;; KLUDGE: this is needed to allow for user-defined specializers in
+;;; RAISE-METATYPE; however, the list of methods is maintained by
+;;; hand, which is error-prone.  We can't just add a method to
+;;; SPECIALIZER-CLASS, or at least not with confidence, as that
+;;; function is used elsewhere in PCL.  `STANDARD' here is used in the
+;;; sense of `comes with PCL' rather than `blessed by the
+;;; authorities'.  -- CSR, 2007-05-10
+(defmethod standard-specializer-p ((specializer class)) t)
+(defmethod standard-specializer-p ((specializer eql-specializer)) t)
+(defmethod standard-specializer-p ((specializer class-eq-specializer)) t)
+(defmethod standard-specializer-p ((specializer class-prototype-specializer))
+  t)
+(defmethod standard-specializer-p ((specializer specializer)) nil)
 
+(defun specializer-class-or-nil (specializer)
+  (and (standard-specializer-p specializer)
+       (specializer-class specializer)))
 
 (defun error-need-at-least-n-args (function n)
   (error 'simple-program-error
@@ -746,9 +692,7 @@
 (defun value-for-caching (gf classes)
   (let ((methods (compute-applicable-methods-using-types
                    gf (mapcar #'class-eq-type classes))))
-    (method-function-get (or (safe-method-fast-function (car methods))
-                             (safe-method-function (car methods)))
-                         :constant-value)))
+    (method-plist-value (car methods) :constant-value)))
 
 (defun default-secondary-dispatch-function (generic-function)
   (lambda (&rest args)
@@ -827,16 +771,17 @@
     (setf (gf-info-simple-accessor-type arg-info)
           (let* ((methods (generic-function-methods gf))
                  (class (and methods (class-of (car methods))))
-                 (type (and class
-                            (cond ((eq class
-                                       *the-class-standard-reader-method*)
-                                   'reader)
-                                  ((eq class
-                                       *the-class-standard-writer-method*)
-                                   'writer)
-                                  ((eq class
-                                       *the-class-standard-boundp-method*)
-                                   'boundp)))))
+                 (type
+                  (and class
+                       (cond ((or (eq class *the-class-standard-reader-method*)
+                                  (eq class *the-class-global-reader-method*))
+                              'reader)
+                             ((or (eq class *the-class-standard-writer-method*)
+                                  (eq class *the-class-global-writer-method*))
+                              'writer)
+                             ((or (eq class *the-class-standard-boundp-method*)
+                                  (eq class *the-class-global-boundp-method*))
+                              'boundp)))))
             (when (and (gf-info-c-a-m-emf-std-p arg-info)
                        type
                        (dolist (method (cdr methods) t)
@@ -897,13 +842,13 @@
   (unless *new-class*
     (update-std-or-str-methods gf type))
   (when (and (standard-svuc-method type) (structure-svuc-method type))
-    (flet ((update-class (class)
+    (flet ((update-accessor-info (class)
              (when (class-finalized-p class)
                (dolist (slotd (class-slots class))
                  (compute-slot-accessor-info slotd type gf)))))
       (if *new-class*
-          (update-class *new-class*)
-          (map-all-classes #'update-class 'slot-object)))))
+          (update-accessor-info *new-class*)
+          (map-all-classes #'update-accessor-info 'slot-object)))))
 
 (defvar *standard-slot-value-using-class-method* nil)
 (defvar *standard-setf-slot-value-using-class-method* nil)
@@ -1316,7 +1261,8 @@
   (if (atom form)
       (default-test-converter form)
       (case (car form)
-        ((invoke-effective-method-function invoke-fast-method-call)
+        ((invoke-effective-method-function invoke-fast-method-call
+          invoke-effective-narrow-method-function)
          '.call.)
         (methods
          '.methods.)
@@ -1409,20 +1355,20 @@
     (let* ((name (generic-function-name generic-function))
            (arg-info (gf-arg-info generic-function))
            (metatypes (arg-info-metatypes arg-info))
+           (nargs (length metatypes))
            (applyp (arg-info-applyp arg-info))
-           (fmc-arg-info (cons (length metatypes) applyp))
+           (fmc-arg-info (cons nargs applyp))
            (arglist (if function-p
-                        (make-dfun-lambda-list metatypes applyp)
-                        (make-fast-method-call-lambda-list metatypes applyp))))
+                        (make-dfun-lambda-list nargs applyp)
+                        (make-fast-method-call-lambda-list nargs applyp))))
       (multiple-value-bind (cfunction constants)
           (get-fun1 `(lambda
                       ,arglist
                       ,@(unless function-p
-                          `((declare (ignore .pv-cell.
-                                             .next-method-call.))))
+                          `((declare (ignore .pv-cell. .next-method-call.))))
                       (locally (declare #.*optimize-speed*)
                                (let ((emf ,net))
-                                 ,(make-emf-call metatypes applyp 'emf))))
+                                 ,(make-emf-call nargs applyp 'emf))))
                     #'net-test-converter
                     #'net-code-converter
                     (lambda (form)
@@ -1599,7 +1545,7 @@
          (update-dfun gf dfun cache info))))))
 
 (defmethod (setf class-name) (new-value class)
-  (let ((classoid (%wrapper-classoid (class-wrapper class))))
+  (let ((classoid (wrapper-classoid (class-wrapper class))))
     (if (and new-value (symbolp new-value))
         (setf (classoid-name classoid) new-value)
         (setf (classoid-name classoid) nil)))