0.7.7.22:

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

diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp
index 6f4177c..1c9b4fe 100644 (file)
--- 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,50 @@ 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
+             ;; (s/invalid/non-ANSI-conforming/ because the old PCL
+             ;; implementation allowed this, so people got used to
+             ;; it, and maybe this phrasing will help them to guess
+             ;; why their program which worked under PCL no longer works.)
+             "~@<non-ANSI-conforming argument ~S ~_in the generic function lambda list ~S~:>"
+             arg lambda-list))))
+    (multiple-value-bind (required optional restp rest keyp keys allowp
+                          auxp 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 aux)) ; since we require AUXP=NIL
+      (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 auxp
+       (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)))))
 \f
 (defmacro defmethod (&rest args &environment env)
   (multiple-value-bind (name qualifiers lambda-list body)
@@ -442,8 +487,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 +594,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 +682,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)
@@ -926,30 +972,6 @@ bootstrapping.
                  +slot-unbound+)))))
     (function
      (apply emf args))))
-
-;; KLUDGE: A comment from the original PCL said "This can be improved alot."
-(defun gf-make-function-from-emf (gf emf)
-  (etypecase emf
-    (fast-method-call (let* ((arg-info (gf-arg-info gf))
-                            (nreq (arg-info-number-required arg-info))
-                            (restp (arg-info-applyp arg-info)))
-                       (lambda (&rest args)
-                         (trace-emf-call emf t args)
-                         (apply (fast-method-call-function emf)
-                                (fast-method-call-pv-cell emf)
-                                (fast-method-call-next-method-call emf)
-                                (if restp
-                                    (let* ((rest-args (nthcdr nreq args))
-                                           (req-args (ldiff args
-                                                            rest-args)))
-                                      (nconc req-args rest-args))
-                                    args)))))
-    (method-call (lambda (&rest args)
-                  (trace-emf-call emf t args)
-                  (apply (method-call-function emf)
-                         args
-                         (method-call-call-method-args emf))))
-    (function emf)))
 \f
 (defmacro bind-fast-lexical-method-macros ((args rest-arg next-method-call)
                                           &body body)