X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fboot.lisp;h=14e6984fc6056d90c80e90d2c94c467de96e674f;hb=bd0ba0f214518e8d72ff2d44de5a1e3e4b02af2c;hp=bdb2f183ed425486371667af15fda63c073cb500;hpb=7e00a27796fce8eb5b0ab920dda636584a011ba2;p=sbcl.git

diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp
index bdb2f18..14e6984 100644
--- 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)))
-	      ((: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))
@@ -587,13 +608,26 @@ bootstrapping.
 	 ;; weirdness when bootstrapping.. -- WHN 20000610
 	 '(ignorable))
 	(t
-	 ;; Otherwise, we can make Python very happy.
+	 ;; Otherwise, we can usually make Python very happy.
 	 (let ((type (info :type :kind specializer)))
 	   (ecase type
 	     ((:primitive :defined :instance :forthcoming-defclass-type)
 	      `(type ,specializer ,parameter))
 	     ((nil)
-	      `(type ,(class-name (find-class specializer)) ,parameter)))))))
+	      (let ((class (find-class specializer nil)))
+		(if class
+		    `(type ,(class-name class) ,parameter)
+		    (progn
+		      ;; we can get here, and still not have a failure
+		      ;; case, by doing MOP programming like (PROGN
+		      ;; (ENSURE-CLASS 'FOO) (DEFMETHOD BAR ((X FOO))
+		      ;; ...)).  Best to let the user know we haven't
+		      ;; been able to extract enough information:
+		      (style-warn
+		       "~@<can't find type for presumed class ~S in ~S.~@:>"
+		       specializer
+		       'parameter-specializer-declaration-in-defmethod)
+		      '(ignorable))))))))))
 
 (defun make-method-lambda-internal (method-lambda &optional env)
   (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda))
@@ -1160,8 +1194,14 @@ bootstrapping.
 		   (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)
@@ -1571,7 +1611,7 @@ bootstrapping.
 
 ;;; Keep pages clean by not setting if the value is already the same.
 (defmacro esetf (pos val)
-  (let ((valsym (gensym "value")))
+  (with-unique-names (valsym)
     `(let ((,valsym ,val))
        (unless (equal ,pos ,valsym)
 	 (setf ,pos ,valsym)))))
@@ -1707,27 +1747,21 @@ bootstrapping.
 		    (generic-function-name gf)
 		    (!early-gf-name gf))))
       (esetf (gf-precompute-dfun-and-emf-p arg-info)
-	     (let* ((sym (if (atom name) name (cadr name)))
-		    (pkg-list (cons *pcl-package*
-				    (package-use-list *pcl-package*))))
-	       ;; FIXME: given the presence of generalized function
-	       ;; names, this test is broken.  A little
-	       ;; reverse-engineering suggests that this was intended
-	       ;; to prevent precompilation of things on some
-	       ;; PCL-internal automatically-constructed functions
-	       ;; like the old "~A~A standard class ~A reader"
-	       ;; functions.  When the CADR of SB-PCL::SLOT-ACCESSOR
-	       ;; generalized functions was *, this test returned T,
-	       ;; not NIL, and an error was signalled in
-	       ;; MAKE-ACCESSOR-TABLE for (DEFUN FOO (X) (SLOT-VALUE X
-	       ;; 'ASLDKJ)).  Whether the right thing to do is to fix
-	       ;; MAKE-ACCESSOR-TABLE so that it can work in the
-	       ;; presence of slot names that have no classes, or to
-	       ;; restore this test to something more obvious, I don't
-	       ;; know.  -- CSR, 2003-02-14
-	       (and sym (symbolp sym)
-		    (not (null (memq (symbol-package sym) pkg-list)))
-		    (not (find #\space (symbol-name sym))))))))
+	     (cond
+	       ((and (consp name)
+		     (member (car name)
+			     *internal-pcl-generalized-fun-name-symbols*))
+		nil)
+	       (t (let* ((symbol (fun-name-block-name name))
+			 (package (symbol-package symbol)))
+		    (and (or (eq package *pcl-package*)
+			     (memq package (package-use-list *pcl-package*)))
+			 ;; FIXME: this test will eventually be
+			 ;; superseded by the *internal-pcl...* test,
+			 ;; above.  While we are in a process of
+			 ;; transition, however, it should probably
+			 ;; remain.
+			 (not (find #\Space (symbol-name symbol))))))))))
   (esetf (gf-info-fast-mf-p arg-info)
 	 (or (not (eq *boot-state* 'complete))
 	     (let* ((method-class (generic-function-method-class gf))