Fix docstring and body parsing

Consider cases where there are multiple declarations or a docstring in
between. Those cases do not seem very clearly specified in the CLHS,
but I have tried to interpret it in the more flexible way.

It fixes some code examples from PAIP and it is consistent with SBCL.

Some test cases were added.

src/compiler/compiler.lisp

@@ -397,20 +397,30 @@
 ;;; list of declaration forms and the docstring.
 (defun parse-body (body &key declarations docstring)
   (let ((value-declarations)
-        (value-docstring))
-    ;; Parse declarations
-    (when declarations
-      (do* ((rest body (cdr rest))
-            (form (car rest) (car rest)))
-           ((or (atom form) (not (eq (car form) 'declare)))
-            (setf body rest))
-        (push form value-declarations)))
-    ;; Parse docstring
-    (when (and docstring
-               (stringp (car body))
-               (not (null (cdr body))))
-      (setq value-docstring (car body))
-      (setq body (cdr body)))
+        (value-docstring)
+        (end nil))
+
+    (while (not end)
+      (cond
+        ;; Docstring
+        ((and docstring
+              (stringp (car body))
+              (not (null (cdr body))))
+         (when value-docstring
+           (error "Duplicated docstring ~S" (car body)))
+         (setq value-docstring (car body))
+         (setq body (cdr body)))
+
+        ;; Declaration
+        ((and declarations
+              (consp (car body))
+              (eq (caar body) 'declare))
+         (push (car body) value-declarations)
+         (setq body (cdr body)))
+
+        (t
+         (setq end t))))
+
     (values body value-declarations value-docstring)))
 
 

tests/defun.lisp

@@ -2,3 +2,32 @@
 
 ;;; Regression test for #111
 (test (eql (defun foo () "foo's" ()) 'foo))
+
+
+;;; Body, declarations and docstrings
+
+(let ((actual
+       (multiple-value-list
+        (parse-body '((declare (integerp x)) "foo" 3)
+                    :declarations t
+                    :docstring t))))
+
+  (test (equal actual '((3) ((DECLARE (INTEGERP X))) "foo"))))
+
+(let ((actual
+       (multiple-value-list
+        (parse-body '((declare (integerp x)) "foo")
+                    :declarations t
+                    :docstring t))))
+
+  (test (equal actual '(("foo") ((DECLARE (INTEGERP X))) nil))))
+
+
+(let ((actual
+       (multiple-value-list
+        (parse-body '("foo" 3)
+                    :declarations t
+                    :docstring t))))
+
+  (test (equal actual '((3) nil "foo"))))
+