X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmethods.lisp;h=4b68b67f71a3cfe74c933c6bb6daa18050486cfc;hb=05b900143b52fa4454f868da90fec48681da1812;hp=dff22ed8f15d5b2428cd552069fbd56bb6bd3de6;hpb=796d3abb79fdb3ac896b639b83756ef9d86007f6;p=sbcl.git

diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index dff22ed..4b68b67 100644
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -89,10 +89,7 @@
       "is not a non-null atom"))
 
 (defmethod legal-slot-name-p ((object standard-method) x)
-  (cond ((not (symbolp x)) "is not a symbol and so cannot be bound")
-	((keywordp x)      "is a keyword and so cannot be bound")
-	((memq x '(t nil)) "cannot be bound")
-	((constantp x)     "is a constant and so cannot be bound")
+  (cond ((not (symbolp x)) "is not a symbol")
 	(t t)))
 
 (defmethod legal-specializers-p ((object standard-method) x)
@@ -266,30 +263,7 @@
     (apply #'call-next-method generic-function initargs)))
 ||#
 
-;;; These three are scheduled for demolition.
-
-(defmethod remove-named-method (generic-function-name argument-specifiers
-						      &optional extra)
-  (let ((generic-function ())
-	(method ()))
-    (cond ((or (null (fboundp generic-function-name))
-	       (not (generic-function-p
-		      (setq generic-function
-			    (fdefinition generic-function-name)))))
-	   (error "~S does not name a generic function."
-		  generic-function-name))
-	  ((null (setq method (get-method generic-function
-					  extra
-					  (parse-specializers
-					    argument-specifiers)
-					  nil)))
-	   (error "There is no method for the generic function ~S~%~
-		   which matches the ARGUMENT-SPECIFIERS ~S."
-		  generic-function
-		  argument-specifiers))
-	  (t
-	   (remove-method generic-function method)))))
-
+;;; These two are scheduled for demolition.
 (defun real-add-named-method (generic-function-name
 			      qualifiers
 			      specializers
@@ -311,28 +285,61 @@
 				     :specializers specs
 				     :lambda-list lambda-list
 				     other-initargs)))
-    (add-method generic-function new)))
+    (add-method generic-function new)
+    new))
+
+(define-condition find-method-length-mismatch
+    (reference-condition simple-error)
+  ()
+  (:default-initargs :references (list '(:ansi-cl :function find-method))))
 
 (defun real-get-method (generic-function qualifiers specializers
-					 &optional (errorp t))
-  (let ((hit 
-	  (dolist (method (generic-function-methods generic-function))
-	    (let ((mspecializers (method-specializers method)))
-	      (when (and (equal qualifiers (method-qualifiers method))
-			 (= (length specializers) (length mspecializers))
-			 (every #'same-specializer-p specializers
-				(method-specializers method)))
-		(return method))))))
-    (cond (hit hit)
-	  ((null errorp) nil)
-	  (t
-	   (error "no method on ~S with qualifiers ~:S and specializers ~:S"
-		  generic-function qualifiers specializers)))))
-
+			&optional (errorp t) 
+			always-check-specializers)
+  (let ((lspec (length specializers))
+	(methods (generic-function-methods generic-function)))
+    (when (or methods always-check-specializers)
+      (let ((nreq (length (arg-info-metatypes (gf-arg-info
+					       generic-function)))))
+	;; Since we internally bypass FIND-METHOD by using GET-METHOD
+	;; instead we need to to this here or users may get hit by a
+	;; failed AVER instead of a sensible error message.
+	(when (/= lspec nreq)
+	  (error 
+	   'find-method-length-mismatch
+	   :format-control
+	   "~@<The generic function ~S takes ~D required argument~:P; ~
+            was asked to find a method with specializers ~S~@:>"
+	   :format-arguments (list generic-function nreq specializers)))))
+    (let ((hit 
+	   (dolist (method methods)
+	     (let ((mspecializers (method-specializers method)))
+	       (aver (= lspec (length mspecializers)))
+	       (when (and (equal qualifiers (method-qualifiers method))
+			  (every #'same-specializer-p specializers
+				 (method-specializers method)))
+		 (return method))))))
+      (cond (hit hit)
+	    ((null errorp) nil)
+	    (t
+	     (error "~@<There is no method on ~S with ~
+                    ~:[no qualifiers~;~:*qualifiers ~S~] ~
+                    and specializers ~S.~@:>"
+		    generic-function qualifiers specializers))))))
+
 (defmethod find-method ((generic-function standard-generic-function)
 			qualifiers specializers &optional (errorp t))
-  (real-get-method generic-function qualifiers
-		   (parse-specializers specializers) errorp))
+  ;; ANSI about FIND-METHOD: "The specializers argument contains the
+  ;; parameter specializers for the method. It must correspond in
+  ;; length to the number of required arguments of the generic
+  ;; function, or an error is signaled."
+  ;;
+  ;; This error checking is done by REAL-GET-METHOD.
+  (real-get-method generic-function 
+		   qualifiers
+		   (parse-specializers specializers) 
+		   errorp 
+		   t))
 
 ;;; Compute various information about a generic-function's arglist by looking
 ;;; at the argument lists of the methods. The hair for trying not to use
@@ -399,11 +406,14 @@
 (defun make-discriminating-function-arglist (number-required-arguments restp)
   (nconc (let ((args nil))
            (dotimes (i number-required-arguments)
-             (push (intern (format nil "Discriminating Function Arg ~D" i))
+             (push (format-symbol *package* ;; ! is this right?
+				  "Discriminating Function Arg ~D"
+				  i)
                    args))
            (nreverse args))
 	 (when restp
-	       `(&rest ,(intern "Discriminating Function &rest Arg")))))
+	       `(&rest ,(format-symbol *package* 
+				       "Discriminating Function &rest Arg")))))
 
 (defmethod generic-function-argument-precedence-order
     ((gf standard-generic-function))
@@ -422,8 +432,7 @@
 (defmethod initialize-instance :after ((gf standard-generic-function)
 				       &key (lambda-list nil lambda-list-p)
 				       argument-precedence-order)
-  (with-slots (arg-info)
-    gf
+  (with-slots (arg-info) gf
     (if lambda-list-p
 	(set-arg-info gf
 		      :lambda-list lambda-list
@@ -432,25 +441,25 @@
     (when (arg-info-valid-p arg-info)
       (update-dfun gf))))
 
-(defmethod reinitialize-instance :after ((gf standard-generic-function)
-					 &rest args
-					 &key (lambda-list nil lambda-list-p)
-					 (argument-precedence-order
-					  nil argument-precedence-order-p))
-  (with-slots (arg-info)
-    gf
-    (if lambda-list-p
-	(if argument-precedence-order-p
-	    (set-arg-info gf
-			  :lambda-list lambda-list
-			  :argument-precedence-order argument-precedence-order)
-	    (set-arg-info gf
-			  :lambda-list lambda-list))
-	(set-arg-info gf))
-    (when (and (arg-info-valid-p arg-info)
-	       args
-	       (or lambda-list-p (cddr args)))
-      (update-dfun gf))))
+(defmethod reinitialize-instance :around
+    ((gf standard-generic-function) &rest args &key
+     (lambda-list nil lambda-list-p) (argument-precedence-order nil apo-p))
+  (let ((old-mc (generic-function-method-combination gf)))
+    (prog1 (call-next-method)
+      ;; KLUDGE: EQ is too strong a test.
+      (unless (eq old-mc (generic-function-method-combination gf))
+	(flush-effective-method-cache gf))
+      (cond
+	((and lambda-list-p apo-p)
+	 (set-arg-info gf
+		       :lambda-list lambda-list
+		       :argument-precedence-order argument-precedence-order))
+	(lambda-list-p (set-arg-info gf :lambda-list lambda-list))
+	(t (set-arg-info gf)))
+      (when (and (arg-info-valid-p (gf-arg-info gf))
+		 (not (null args))
+		 (or lambda-list-p (cddr args)))
+	(update-dfun gf)))))
 
 (declaim (special *lazy-dfun-compute-p*))
 
@@ -461,9 +470,9 @@
 
 (defun real-add-method (generic-function method &optional skip-dfun-update-p)
   (when (method-generic-function method)
-    (error "The method ~S is already part of the generic~@
-	    function ~S. It can't be added to another generic~@
-	    function until it is removed from the first one."
+    (error "~@<The method ~S is already part of the generic ~
+	    function ~S; it can't be added to another generic ~
+	    function until it is removed from the first one.~@:>"
 	   method (method-generic-function method)))
   (flet ((similar-lambda-lists-p (method-a method-b)
 	   (multiple-value-bind (a-nreq a-nopt a-keyp a-restp)
@@ -507,12 +516,39 @@
 		 (setq remove-again-p nil))
 	    (when remove-again-p
 	      (remove-method generic-function method))))
+
+	;; KLUDGE II: ANSI saith that it is not an error to add a
+	;; method with invalid qualifiers to a generic function of the
+	;; wrong kind; it's only an error at generic function
+	;; invocation time; I dunno what the rationale was, and it
+	;; sucks.  Nevertheless, it's probably a programmer error, so
+	;; let's warn anyway. -- CSR, 2003-08-20
+	(let ((mc (generic-function-method-combination generic-functioN)))
+	  (cond
+	    ((eq mc *standard-method-combination*)
+	     (when (and qualifiers
+			(or (cdr qualifiers)
+			    (not (memq (car qualifiers)
+				       '(:around :before :after)))))
+	       (warn "~@<Invalid qualifiers for standard method combination ~
+                      in method ~S:~2I~_~S.~@:>"
+		     method qualifiers)))
+	    ((short-method-combination-p mc)
+	     (let ((mc-name (method-combination-type mc)))
+	       (when (or (null qualifiers)
+			 (cdr qualifiers)
+			 (and (neq (car qualifiers) :around)
+			      (neq (car qualifiers) mc-name)))
+		 (warn "~@<Invalid qualifiers for ~S method combination ~
+                        in method ~S:~2I~_~S.~@:>"
+		       mc-name method qualifiers))))))
+	
 	(unless skip-dfun-update-p
 	  (update-ctors 'add-method
 			:generic-function generic-function
 			:method method)
 	  (update-dfun generic-function))
-	method)))
+	generic-function)))
 
 (defun real-remove-method (generic-function method)
   (when  (eq generic-function (method-generic-function method))
@@ -652,9 +688,10 @@
   (let ((types (mapcar #'class-eq-type classes)))
     (multiple-value-bind (methods all-applicable-and-sorted-p)
 	(compute-applicable-methods-using-types gf types)
-      (function-funcall (get-secondary-dispatch-function1
-			 gf methods types nil t all-applicable-and-sorted-p)
-			nil (mapcar #'class-wrapper classes)))))
+      (let ((generator (get-secondary-dispatch-function1
+			gf methods types nil t all-applicable-and-sorted-p)))
+	(make-callable gf methods generator
+		       nil (mapcar #'class-wrapper classes))))))
 
 (defun value-for-caching (gf classes)
   (let ((methods (compute-applicable-methods-using-types
@@ -676,7 +713,8 @@
   (loop (when (atom x) (return (eq x y)))
 	(when (atom y) (return nil))
 	(unless (eq (car x) (car y)) (return nil))
-	(setq x (cdr x)  y (cdr y))))
+	(setq x (cdr x)
+	      y (cdr y))))
 
 (defvar *std-cam-methods* nil)
 
@@ -820,6 +858,9 @@
 (defvar *standard-slot-value-using-class-method* nil)
 (defvar *standard-setf-slot-value-using-class-method* nil)
 (defvar *standard-slot-boundp-using-class-method* nil)
+(defvar *condition-slot-value-using-class-method* nil)
+(defvar *condition-setf-slot-value-using-class-method* nil)
+(defvar *condition-slot-boundp-using-class-method* nil)
 (defvar *structure-slot-value-using-class-method* nil)
 (defvar *structure-setf-slot-value-using-class-method* nil)
 (defvar *structure-slot-boundp-using-class-method* nil)
@@ -836,6 +877,18 @@
     (writer (setq *standard-setf-slot-value-using-class-method* method))
     (boundp (setq *standard-slot-boundp-using-class-method* method))))
 
+(defun condition-svuc-method (type)
+  (case type
+    (reader *condition-slot-value-using-class-method*)
+    (writer *condition-setf-slot-value-using-class-method*)
+    (boundp *condition-slot-boundp-using-class-method*)))
+
+(defun set-condition-svuc-method (type method)
+  (case type
+    (reader (setq *condition-slot-value-using-class-method* method))
+    (writer (setq *condition-setf-slot-value-using-class-method* method))
+    (boundp (setq *condition-slot-boundp-using-class-method* method))))
+
 (defun structure-svuc-method (type)
   (case type
     (reader *structure-slot-value-using-class-method*)
@@ -854,17 +907,18 @@
       (when (and (or (not (eq type 'writer))
 		     (eq (pop specls) *the-class-t*))
 		 (every #'classp specls))
-	(cond ((and (eq (class-name (car specls))
-			'std-class)
-		    (eq (class-name (cadr specls))
-			'std-object)
+	(cond ((and (eq (class-name (car specls)) 'std-class)
+		    (eq (class-name (cadr specls)) 'std-object)
 		    (eq (class-name (caddr specls))
 			'standard-effective-slot-definition))
 	       (set-standard-svuc-method type method))
-	      ((and (eq (class-name (car specls))
-			'structure-class)
-		    (eq (class-name (cadr specls))
-			'structure-object)
+	      ((and (eq (class-name (car specls)) 'condition-class)
+		    (eq (class-name (cadr specls)) 'condition)
+		    (eq (class-name (caddr specls))
+			'condition-effective-slot-definition))
+	       (set-condition-svuc-method type method))
+	      ((and (eq (class-name (car specls)) 'structure-class)
+		    (eq (class-name (cadr specls)) 'structure-object)
 		    (eq (class-name (caddr specls))
 			'structure-effective-slot-definition))
 	       (set-structure-svuc-method type method)))))))
@@ -1182,15 +1236,19 @@
 
 (defmacro mlookup (key info default &optional eq-p type)
   (unless (or (eq eq-p t) (null eq-p))
-    (error "Invalid eq-p argument"))
+    (bug "Invalid eq-p argument: ~S" eq-p))
   (ecase type
     (:simple
-     `(if (,(if eq-p 'eq 'eql) ,key (car ,info))
+     `(if (locally
+	    (declare (optimize (inhibit-warnings 3)))
+	    (,(if eq-p 'eq 'eql) ,key (car ,info)))
 	  (cdr ,info)
 	  ,default))
     (:assoc
      `(dolist (e ,info ,default)
-	(when (,(if eq-p 'eq 'eql) (car e) ,key)
+	(when (locally
+		(declare (optimize (inhibit-warnings 3)))
+		(,(if eq-p 'eq 'eql) (car e) ,key))
 	  (return (cdr e)))))
     (:hash-table
      `(gethash ,key ,info ,default))))
@@ -1478,6 +1536,10 @@
 	     (set-dfun gf dfun cache info) ; lest the cache be freed twice
 	     (update-dfun gf dfun cache info))))))
 
+(defmethod (setf class-name) :before (new-value (class class))
+  (let ((classoid (find-classoid (class-name class))))
+    (setf (classoid-name classoid) new-value)))
+
 (defmethod function-keywords ((method standard-method))
   (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
       (analyze-lambda-list (if (consp method)