X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fboot.lisp;h=f4dc2ceb500b712a8b688a7d8a8cd8b0b2c94e40;hb=9a2e730f74641e7de6ad4099111db92c5ad863bf;hp=6f4177c6045ad1449db1fb609f276c779f645e7e;hpb=35fecfc13c93b85d30a23375ca2850cbbf4a923e;p=sbcl.git

diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp
index 6f4177c..f4dc2ce 100644
--- a/src/pcl/boot.lisp
+++ b/src/pcl/boot.lisp
@@ -161,6 +161,7 @@ bootstrapping.
     (error 'simple-program-error
 	   :format-control "illegal generic function name ~S"
 	   :format-arguments (list fun-name)))
+  (check-gf-lambda-list lambda-list)
   (let ((initargs ())
 	(methods ()))
     (flet ((duplicate-option (name)
@@ -231,6 +232,45 @@ bootstrapping.
          :lambda-list lambda-list
          :definition-source `((defgeneric ,fun-name) ,*load-truename*)
          initargs))
+
+;;; As per section 3.4.2 of the ANSI spec, generic function lambda
+;;; lists have some special limitations, which we check here.
+(defun check-gf-lambda-list (lambda-list)
+  (flet ((ensure (arg ok)
+           (unless ok
+	     (error
+	      "invalid argument ~S in the generic function lambda list ~S"
+	      arg lambda-list))))
+    (multiple-value-bind (required optional restp rest keyp keys allowp aux
+		          morep more-context more-count)
+	(parse-lambda-list lambda-list)
+      (declare (ignore required)) ; since they're no different in a gf ll
+      (declare (ignore restp rest)) ; since they're no different in a gf ll
+      (declare (ignore allowp)) ; since &ALLOW-OTHER-KEYS is fine either way
+      (declare (ignore more-context more-count)) ; safely ignored unless MOREP
+      ;; no defaults allowed for &OPTIONAL arguments
+      (dolist (i optional)
+	(ensure i (or (symbolp i)
+		      (and (consp i) (symbolp (car i)) (null (cdr i))))))
+      ;; no defaults allowed for &KEY arguments
+      (when keyp
+	(dolist (i keys)
+	  (ensure i (or (symbolp i)
+			(and (consp i)
+			     (or (symbolp (car i))
+				 (and (consp (car i))
+				      (symbolp (caar i))
+				      (symbolp (cadar i))
+				      (null (cddar i))))
+			     (null (cdr i)))))))
+      ;; no &AUX allowed
+      (when aux
+	(error "&AUX is not allowed in a generic function lambda list: ~S"
+	       lambda-list))
+      ;; Oh, *puhlease*... not specifically as per section 3.4.2 of
+      ;; the ANSI spec, but the CMU CL &MORE extension does not
+      ;; belong here!
+      (aver (not morep)))))
 
 (defmacro defmethod (&rest args &environment env)
   (multiple-value-bind (name qualifiers lambda-list body)
@@ -442,8 +482,8 @@ bootstrapping.
   (multiple-value-bind (parameters unspecialized-lambda-list specializers)
       (parse-specialized-lambda-list lambda-list)
     (declare (ignore parameters))
-    (multiple-value-bind (documentation declarations real-body)
-	(extract-declarations body env)
+    (multiple-value-bind (real-body declarations documentation)
+	(parse-body body env)
       (values `(lambda ,unspecialized-lambda-list
 		 ,@(when documentation `(,documentation))
 		 ;; (Old PCL code used a somewhat different style of
@@ -549,8 +589,8 @@ bootstrapping.
     (error "The METHOD-LAMBDA argument to MAKE-METHOD-LAMBDA, ~S, ~
 	    is not a lambda form."
 	   method-lambda))
-  (multiple-value-bind (documentation declarations real-body)
-      (extract-declarations (cddr method-lambda) env)
+  (multiple-value-bind (real-body declarations documentation)
+      (parse-body (cddr method-lambda) env)
     (let* ((name-decl (get-declaration '%method-name declarations))
 	   (sll-decl (get-declaration '%method-lambda-list declarations))
 	   (method-name (when (consp name-decl) (car name-decl)))
@@ -637,10 +677,11 @@ bootstrapping.
 				  env
 				  slots
 				  calls)
-	    (multiple-value-bind
-		(ignore walked-declarations walked-lambda-body)
-		(extract-declarations (cddr walked-lambda))
-	      (declare (ignore ignore))
+	    (multiple-value-bind (walked-lambda-body
+				  walked-declarations
+				  walked-documentation)
+		(parse-body (cddr walked-lambda) env)
+	      (declare (ignore walked-documentation))
 	      (when (or next-method-p-p call-next-method-p)
 		(setq plist (list* :needs-next-methods-p t plist)))
 	      (when (some #'cdr slots)