Be more careful when parsing method bodies.

code/fast-method.lisp

@@ -31,16 +31,17 @@
     (assert (eql lambda-symbol 'lambda))
     (multiple-value-bind (required optional rest-var keyword allow-other-keys-p auxiliary)
         (parse-ordinary-lambda-list lambda-list)
-      (let ((n-declarations (position-if-not (starts-with 'declare) body))
-            (partially-flattened-lambda-list
-              `(,@(lambda-list-variables
-                   (unparse-ordinary-lambda-list
-                    required optional rest-var keyword allow-other-keys-p '()))
-                ,@(unparse-ordinary-lambda-list '() '() nil '() nil auxiliary))))
-        (trivial-macroexpand-all:macroexpand-all
-         `(lambda ,partially-flattened-lambda-list
-            (declare (ignorable ,@(mapcar #'required-info-variable required)))
-            ,@(subseq body 0 n-declarations)
-            (block ,(block-name (generic-function-name generic-function))
-              ,@(subseq body n-declarations)))
-         environment)))))
+      (multiple-value-bind (forms declarations)
+          (parse-body body)
+        (let ((partially-flattened-lambda-list
+                `(,@(lambda-list-variables
+                     (unparse-ordinary-lambda-list
+                      required optional rest-var keyword allow-other-keys-p '()))
+                  ,@(unparse-ordinary-lambda-list '() '() nil '() nil auxiliary))))
+          (trivial-macroexpand-all:macroexpand-all
+           `(lambda ,partially-flattened-lambda-list
+              (declare (ignorable ,@(mapcar #'required-info-variable required)))
+              ,@declarations
+              (block ,(block-name (generic-function-name generic-function))
+                ,@forms))
+           environment))))))

code/utilities.lisp

@@ -1,11 +1,22 @@
 (in-package #:fast-generic-functions)
 
-(defun starts-with (item)
-  (lambda (sequence)
-    (typecase sequence
-      (list (eql (first sequence) item))
-      (sequence (eql (elt sequence 0) item))
-      (otherwise nil))))
+(defun parse-body (body)
+  (let ((declarations '())
+        (documentation nil))
+    (loop for (item . rest) on body do
+      (cond ((and (stringp item) (consp rest))
+             (if (not documentation)
+                 (setf documentation item)
+                 (error "Multiple documentation strings in body: ~%~S~% and~%~S."
+                        documentation item)))
+            ((and (listp item) (eq (first item) 'declare))
+             (push item declarations))
+            (t
+             (return-from parse-body
+               (values
+                (list* item rest)
+                (reverse declarations)
+                documentation)))))))
 
 (defun block-name (function-name)
   (etypecase function-name