1.0.42.32: fix for lp#611361

[sbcl.git] / src / pcl / boot.lisp

diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp
index e9eb7a6..ecb3bcf 100644 (file)
--- a/src/pcl/boot.lisp
+++ b/src/pcl/boot.lisp
@@ -733,6 +733,7 @@ bootstrapping.
                                            ,call-next-method-p
                                            :next-method-p-p ,next-method-p-p
                                            :setq-p ,setq-p
+                                           :parameters-setqd ,parameters-setqd
                                            :method-cell ,method-cell
                                            :closurep ,closurep
                                            :applyp ,applyp)
@@ -914,7 +915,7 @@ bootstrapping.
                   ;; the user defines a type and calls (SETF
                   ;; FIND-CLASS) in a consistent way.
                  (when (and class (typep class 'built-in-class))
-                   `(type ,specializer-nameoid ,parameter))))
+                   `(type ,(class-name class) ,parameter))))
               ((:instance nil)
                (let ((class (specializer-nameoid-class)))
                  (cond
@@ -967,7 +968,7 @@ bootstrapping.
 
 (defmacro bind-simple-lexical-method-functions
     ((method-args next-methods (&key call-next-method-p next-method-p-p setq-p
-                                     closurep applyp method-cell))
+                                     parameters-setqd closurep applyp method-cell))
      &body body
      &environment env)
   (if (not (or call-next-method-p setq-p closurep next-method-p-p applyp))
@@ -1001,9 +1002,25 @@ bootstrapping.
 (defun call-no-next-method (method-cell &rest args)
   (let ((method (car method-cell)))
     (aver method)
+    ;; Can't easily provide a RETRY restart here, as the return value here is
+    ;; for the method, not the generic function.
     (apply #'no-next-method (method-generic-function method)
            method args)))
 
+(defun call-no-applicable-method (gf args)
+  (restart-case
+          (apply #'no-applicable-method gf args)
+    (retry ()
+      :report "Retry calling the generic function."
+      (apply gf args))))
+
+(defun call-no-primary-method (gf args)
+  (restart-case
+      (apply #'no-primary-method gf args)
+    (retry ()
+      :report "Retry calling the generic function."
+      (apply gf args))))
+
 (defstruct (method-call (:copier nil))
   (function #'identity :type function)
   call-method-args)
@@ -1302,6 +1319,7 @@ bootstrapping.
     ((args rest-arg next-method-call (&key
                                       call-next-method-p
                                       setq-p
+                                      parameters-setqd
                                       method-cell
                                       next-method-p-p
                                       closurep
@@ -1475,23 +1493,6 @@ bootstrapping.
                     (setq next-method-p-p t)
                     form)
                    ((memq (car form) '(setq multiple-value-setq))
-                    ;; FIXME: this is possibly a little strong as
-                    ;; conditions go.  Ideally we would want to detect
-                    ;; which, if any, of the method parameters are
-                    ;; being set, and communicate that information to
-                    ;; e.g. SPLIT-DECLARATIONS.  However, the brute
-                    ;; force method doesn't really cost much; a little
-                    ;; loss of discrimination over IGNORED variables
-                    ;; should be all.  -- CSR, 2004-07-01
-                    ;;
-                    ;; As of 2006-09-18 modified parameter bindings
-                    ;; are now tracked with more granularity than just
-                    ;; one SETQ-P flag, in order to disable SLOT-VALUE
-                    ;; optimizations for parameters that are SETQd.
-                    ;; The old binary SETQ-P flag is still used for
-                    ;; all other purposes, since as noted above, the
-                    ;; extra cost is minimal. -- JES, 2006-09-18
-                    ;;
                     ;; The walker will split (SETQ A 1 B 2) to
                     ;; separate (SETQ A 1) and (SETQ B 2) forms, so we
                     ;; only need to handle the simple case of SETQ
@@ -2711,6 +2712,14 @@ bootstrapping.
           (t
            (multiple-value-bind (parameters lambda-list specializers required)
                (parse-specialized-lambda-list (cdr arglist))
+             ;; Check for valid arguments.
+             (unless (or (and (symbolp arg) (not (null arg)))
+                         (and (consp arg)
+                              (consp (cdr arg))
+                              (null (cddr arg))))
+               (error 'specialized-lambda-list-error
+                      :format-control "arg is not a non-NIL symbol or a list of two elements: ~A"
+                      :format-arguments (list arg)))
              (values (cons (if (listp arg) (car arg) arg) parameters)
                      (cons (if (listp arg) (car arg) arg) lambda-list)
                      (cons (if (listp arg) (cadr arg) t) specializers)