0.8alpha.0.39:

	A couple more CLOS fixes:
	... make &OPTIONAL argument count checking less lax in methods
		(caught by pfdietz' MAKE-LOAD-FORM.ERROR.2)
	... make :ARGUMENT-PRECEDENCE-ORDER and :METHOD-COMBINATION
		DEFGENERIC options do sanity checking on their arguments
		(:A-P-O caught by pfdietz' suite; :M-C
		checking defensively installed :-)

diff --git a/NEWS b/NEWS
index 7dcd85a..815d29e 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -1755,6 +1755,11 @@ changes in sbcl-0.8.0 relative to sbcl-0.8alpha.0
        STRUCTURE-OBJECT, CONDITION and STANDARD-OBJECT.
     ** MAKE-LOAD-FORM-SAVING-SLOTS no longer returns a special
        keyword, and now implements the SLOT-NAMES argument.
        STRUCTURE-OBJECT, CONDITION and STANDARD-OBJECT.
     ** MAKE-LOAD-FORM-SAVING-SLOTS no longer returns a special
        keyword, and now implements the SLOT-NAMES argument.

+    ** methods with &OPTIONAL arguments no longer allow too many
+       arguments to be passed in the call without error.
+    ** DEFGENERIC now checks that the :ARGUMENT-PRECEDENCE-ORDER
+       option is consistent with the required arguments of the generic
+       function lambda list.

 
 planned incompatible changes in 0.8.x:
   * (not done yet, but planned:) When the profiling interface settles
 
 planned incompatible changes in 0.8.x:
   * (not done yet, but planned:) When the profiling interface settles

diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp
index e10af04..49edcfe 100644 (file)
--- a/src/pcl/boot.lisp
+++ b/src/pcl/boot.lisp
@@ -190,11 +190,32 @@ bootstrapping.
                                          is not allowed inside DEFGENERIC."
                        :format-arguments (list (cadr option))))
               (push (cadr option) (initarg :declarations)))
                                          is not allowed inside DEFGENERIC."
                        :format-arguments (list (cadr option))))
               (push (cadr option) (initarg :declarations)))

-             ((:argument-precedence-order :method-combination)
-              (if (initarg car-option)
-                  (duplicate-option car-option)
-                  (setf (initarg car-option)
-                        `',(cdr option))))
+             (:method-combination
+              (when (initarg car-option)
+                (duplicate-option car-option))
+              (unless (symbolp (cadr option))
+                (error 'simple-program-error
+                       :format-control "METHOD-COMBINATION name not a ~
+                                         symbol: ~S"
+                       :format-arguments (list (cadr option))))
+              (setf (initarg car-option)
+                    `',(cdr option)))
+             (:argument-precedence-order
+              (let* ((required (parse-lambda-list lambda-list))
+                     (supplied (cdr option)))
+                (unless (= (length required) (length supplied))
+                  (error 'simple-program-error
+                         :format-control "argument count discrepancy in ~
+                                           :ARGUMENT-PRECEDENCE-ORDER clause."
+                         :format-arguments nil))
+                (when (set-difference required supplied)
+                  (error 'simple-program-error
+                         :format-control "unequal sets for ~
+                                           :ARGUMENT-PRECEDENCE-ORDER clause: ~
+                                           ~S and ~S"
+                         :format-arguments (list required supplied)))
+                (setf (initarg car-option)
+                      `',(cdr option))))

              ((:documentation :generic-function-class :method-class)
               (unless (proper-list-of-length-p option 2)
                 (error "bad list length for ~S" option))
              ((:documentation :generic-function-class :method-class)
               (unless (proper-list-of-length-p option 2)
                 (error "bad list length for ~S" option))

@@ -1173,8 +1194,14 @@ bootstrapping.
                   (aux `(,var))))))
       (let ((bindings (mapcan #'process-var lambda-list)))
        `(let* ((,args-tail ,args)
                   (aux `(,var))))))
       (let ((bindings (mapcan #'process-var lambda-list)))
        `(let* ((,args-tail ,args)

-               ,@bindings)
-          (declare (ignorable ,args-tail))
+               ,@bindings
+               (.dummy0.
+                ,@(when (eq state 'optional)
+                    `((unless (null ,args-tail)
+                        (error 'simple-program-error
+                               :format-control "surplus arguments: ~S"
+                               :format-arguments (list ,args-tail)))))))
+          (declare (ignorable ,args-tail .dummy0.))

           ,@body)))))
 
 (defun get-key-arg-tail (keyword list)
           ,@body)))))
 
 (defun get-key-arg-tail (keyword list)

diff --git a/version.lisp-expr b/version.lisp-expr
index 69cfebc..077543b 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)

-"0.8alpha.0.38"
+"0.8alpha.0.39"