From 0234901c953c5651616609dc49254866b503befd Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?David=20V=C3=A1zquez=20P=C3=BAa?= <davazp@gmail.com>
Date: Tue, 1 May 2018 20:32:50 +0200
Subject: [PATCH] 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 | 38 ++++++++++++++++++++++++--------------
 tests/defun.lisp           | 29 +++++++++++++++++++++++++++++
 2 files changed, 53 insertions(+), 14 deletions(-)

diff --git a/src/compiler/compiler.lisp b/src/compiler/compiler.lisp
index 8f0a8a85..dcc8bfcc 100644
--- a/src/compiler/compiler.lisp
+++ b/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)))
 
 
diff --git a/tests/defun.lisp b/tests/defun.lisp
index 39f945eb..ce783ce4 100644
--- a/tests/defun.lisp
+++ b/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"))))
+