Use PARSE-BODY in the interpreter.

Also change DOC-STRING-ALLOWED to a required argument.
The most often used value was NIL, but it defaulted to T. Rather than
invert the default, make it clear that there is no default.

src/code/array.lisp

@@ -594,7 +594,7 @@ of specialized arrays is supported."
 
 ;;; Like DOVECTOR, but more magical -- can't use this on host.
 (defmacro do-vector-data ((elt vector &optional result) &body body)
- (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
+ (multiple-value-bind (forms decls) (parse-body body nil)
  (with-unique-names (index vec start end ref)
  `(with-array-data ((,vec ,vector)
  (,start)

src/code/defboot.lisp

@@ -134,8 +134,7 @@ evaluated as a PROGN."
 ;;;; various sequencing constructs
 
 (flet ((prog-expansion-from-let (varlist body-decls let)
- (multiple-value-bind (body decls)
- (parse-body body-decls :doc-string-allowed nil)
+ (multiple-value-bind (body decls) (parse-body body-decls nil)
  `(block nil
  (,let ,varlist
  ,@decls
@@ -182,7 +181,7 @@ evaluated as a PROGN."
  #+sb-xc-host
  (unless (symbol-package (fun-name-block-name name))
  (warn "DEFUN of uninterned function name ~S (tricky for GENESIS)" name))
- (multiple-value-bind (forms decls doc) (parse-body body)
+ (multiple-value-bind (forms decls doc) (parse-body body t)
  (let* (;; stuff shared between LAMBDA and INLINE-LAMBDA and NAMED-LAMBDA
  (lambda-guts `(,args
  ,@(when doc (list doc))
@@ -402,7 +401,7 @@ evaluated as a PROGN."
  ;; environment. We spuriously reference the gratuitous variable,
  ;; since we don't want to use IGNORABLE on what might be a special
  ;; var.
- (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
+ (multiple-value-bind (forms decls) (parse-body body nil)
  (let* ((n-list (gensym "N-LIST"))
  (start (gensym "START")))
  (multiple-value-bind (clist members clist-ok)

src/code/early-extensions.lisp

@@ -427,7 +427,7 @@
  decls))
 ;;; just like DOLIST, but with one-dimensional arrays
 (defmacro dovector ((elt vector &optional result) &body body)
- (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
+ (multiple-value-bind (forms decls) (parse-body body nil)
  (with-unique-names (index length vec)
  `(let ((,vec ,vector))
  (declare (type vector ,vec))
@@ -445,7 +445,7 @@
 ;;; Iterate over the entries in a HASH-TABLE, first obtaining the lock
 ;;; if the table is a synchronized table.
 (defmacro dohash (((key-var value-var) table &key result locked) &body body)
- (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
+ (multiple-value-bind (forms decls) (parse-body body nil)
  (with-unique-names (gen n-more n-table)
  (let ((iter-form `(with-hash-table-iterator (,gen ,n-table)
  (loop
@@ -489,7 +489,7 @@
 (def!macro binding* ((&rest clauses) &body body)
  (unless clauses ; wrap in LET to preserve non-toplevelness
  (return-from binding* `(let () ,@body)))
- (multiple-value-bind (body decls) (parse-body body :doc-string-allowed nil)
+ (multiple-value-bind (body decls) (parse-body body nil)
  ;; Generate an abstract representation that combines LET* clauses.
  (let (repr)
  (dolist (clause clauses)
@@ -812,7 +812,7 @@
  memoizer-supplied-p)
  &allow-other-keys)
  args &body body-decls-doc)
- (binding* (((forms decls doc) (parse-body body-decls-doc))
+ (binding* (((forms decls doc) (parse-body body-decls-doc t))
  ((inputs aux-vars)
  (let ((aux (member '&aux args)))
  (if aux
@@ -1700,8 +1700,7 @@ to :INTERPRET, an interpreter will be used.")
 (defmacro with-simple-output-to-string
  ((var &optional string)
  &body body)
- (multiple-value-bind (forms decls)
- (parse-body body :doc-string-allowed nil)
+ (multiple-value-bind (forms decls) (parse-body body nil)
  (if string
  `(let ((,var (sb!impl::make-fill-pointer-output-stream ,string)))
  ,@decls

src/code/eval.lisp

@@ -74,8 +74,7 @@
  (return (simple-eval-in-lexenv (first i) lexenv)))))
 
 (defun simple-eval-locally (exp lexenv &key vars)
- (multiple-value-bind (body decls)
- (parse-body (rest exp) :doc-string-allowed nil)
+ (multiple-value-bind (body decls) (parse-body (rest exp) nil)
  (let ((lexenv
  ;; KLUDGE: Uh, yeah. I'm not anticipating
  ;; winning any prizes for this code, which was

src/code/macros.lisp

@@ -412,8 +412,7 @@ invoked. In that case it will store into PLACE and start over."
 ;;;; WITH-FOO i/o-related macros
 
 (defmacro-mundanely with-open-stream ((var stream) &body forms-decls)
- (multiple-value-bind (forms decls)
- (parse-body forms-decls :doc-string-allowed nil)
+ (multiple-value-bind (forms decls) (parse-body forms-decls nil)
  (let ((abortp (gensym)))
  `(let ((,var ,stream)
  (,abortp t))
@@ -432,8 +431,7 @@ invoked. In that case it will store into PLACE and start over."
 
 (defmacro-mundanely with-input-from-string ((var string &key index start end)
  &body forms-decls)
- (multiple-value-bind (forms decls)
- (parse-body forms-decls :doc-string-allowed nil)
+ (multiple-value-bind (forms decls) (parse-body forms-decls nil)
  `(let ((,var
  ;; Should (WITH-INPUT-FROM-STRING (stream str :start nil :end 5))
  ;; pass the explicit NIL, and thus get an error? It's logical
@@ -453,8 +451,7 @@ invoked. In that case it will store into PLACE and start over."
 (defmacro-mundanely with-output-to-string
  ((var &optional string &key (element-type ''character))
  &body forms-decls)
- (multiple-value-bind (forms decls)
- (parse-body forms-decls :doc-string-allowed nil)
+ (multiple-value-bind (forms decls) (parse-body forms-decls nil)
  (if string
  (let ((element-type-var (gensym)))
  `(let ((,var (make-fill-pointer-output-stream ,string))

src/code/package.lisp

@@ -101,8 +101,7 @@
 ;;;; iteration macros
 
 (flet ((expand-iterator (range var body result-form)
- (multiple-value-bind (forms decls)
- (parse-body body :doc-string-allowed nil)
+ (multiple-value-bind (forms decls) (parse-body body nil)
  (with-unique-names (iterator winp next)
  `(block nil
  (with-package-iterator (,iterator ,@range)

src/code/parse-body.lisp

@@ -1,10 +1,3 @@
-;;;; functions used to parse function/macro bodies
-;;;;
-;;;; FIXME: In an early attempt to bootstrap SBCL, this file
-;;;; was loaded before fundamental things like DEFUN and AND and OR
-;;;; were defined, and it still bears scars from the attempt to
-;;;; make that work. (TAGBODY, forsooth..) It should be cleaned up.
-
 ;;;; This software is part of the SBCL system. See the README file for
 ;;;; more information.
 ;;;;
@@ -16,8 +9,6 @@
 
 (in-package "SB!IMPL")
 
-(/show0 "entering parse-body.lisp")
-
 ;;; Given a sequence of declarations (and possibly a documentation
 ;;; string) followed by other forms (as occurs in the bodies of DEFUN,
 ;;; DEFMACRO, etc.) return (VALUES FORMS DECLS DOC), where DECLS holds
@@ -26,53 +17,41 @@
 ;;;
 ;;; If DOC-STRING-ALLOWED is NIL, then no forms will be treated as
 ;;; documentation strings.
-(defun parse-body (body &key (doc-string-allowed t) (toplevel nil))
- (let ((reversed-decls nil)
- (forms body)
- (doc nil))
- (flet ((doc-string-p (x remaining-forms)
- (and (stringp x) doc-string-allowed
+(defun parse-body (body doc-string-allowed &optional silent)
+ (flet ((doc-string-p (x remaining-forms doc)
+ (and (stringp x) doc-string-allowed
  ;; ANSI 3.4.11 explicitly requires that a doc string
  ;; be followed by another form (either an ordinary form
  ;; or a declaration). Hence:
-  remaining-forms
-  (if doc
+ remaining-forms
+ (if doc
  ;; .. and says that the consequences of multiple
  ;; doc strings are unspecified.
  ;; That's probably not something the programmer intends.
  ;; We raise an error so that this won't pass unnoticed.
- (error "duplicate doc string ~S" x)
- t)))
- (declaration-p (x)
- (if (consp x)
- (let ((name (car x)))
- (case name
- ((declare) t)
- ((declaim)
- (unless toplevel
+ (error "duplicate doc string ~S" x)
+ t)))
+ (declaration-p (x)
+ (when (listp x)
+ (let ((name (car x)))
+ (cond ((eq name 'declare) t)
+ (t
+ (when (and (eq name 'declaim) (not silent))
  ;; technically legal, but rather unlikely to
  ;; be what the user meant to do...
  (style-warn
- "DECLAIM where DECLARE was probably intended")
- nil))
- (t nil))))))
- (tagbody
- :again
- (if forms
- (let ((form1 (first forms)))
- ;; Note: The (IF (IF ..) ..) stuff is because we don't
- ;; have the macro AND yet.:-|
- (if (doc-string-p form1 (rest forms))
- (setq doc form1)
- (if (declaration-p form1)
- (setq reversed-decls
- (cons form1 reversed-decls))
- (go :done)))
- (setq forms (rest forms))
- (go :again)))
- :done)
- (values forms
- (nreverse reversed-decls)
- doc))))
-
-(/show0 "leaving parse-body.lisp")
+ "DECLAIM where DECLARE was probably intended"))
+ nil))))))
+ (let ((forms body) (decls (list nil)) (doc nil))
+ (declare (truly-dynamic-extent decls))
+ (let ((decls decls))
+ (loop (when (endp forms) (return))
+ (let ((form (first forms)))
+ (cond ((doc-string-p form (rest forms) doc)
+ (setq doc form))
+ ((declaration-p form)
+ (setq decls (setf (cdr decls) (list form))))
+ (t
+ (return))))
+ (setq forms (rest forms))))
+ (values forms (cdr decls) doc))))

src/code/primordial-extensions.lisp

@@ -98,8 +98,7 @@
  (t (illegal-varlist)))))
  (t (illegal-varlist)))))
  ;; Construct the new form.
- (multiple-value-bind (code decls)
- (parse-body decls-and-code :doc-string-allowed nil)
+ (multiple-value-bind (code decls) (parse-body decls-and-code nil)
  `(block ,block
  (,bind ,(nreverse r-inits)
  ,@decls

src/code/seq.lisp

@@ -84,8 +84,7 @@
  (or null function))))
 
 (sb!xc:defmacro define-sequence-traverser (name args &body body)
- (multiple-value-bind (body declarations docstring)
- (parse-body body :doc-string-allowed t)
+ (multiple-value-bind (body declarations docstring) (parse-body body t)
  (collect ((new-args)
  (new-declarations)
  ;; Things which are definitely used in any code path.
@@ -837,7 +836,7 @@ many elements are copied."
  #!+sb-doc
  "Executes BODY with ELEMENT subsequently bound to each element of
  SEQUENCE, then returns RETURN."
- (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
+ (multiple-value-bind (forms decls) (parse-body body nil)
  (once-only ((sequence sequence))
  (with-unique-names (state limit from-end step endp elt)
  `(block nil

src/code/setf.lisp

@@ -490,7 +490,7 @@
  '(&optional &rest &key &allow-other-keys
  &environment))
  :context "a DEFSETF lambda list"))
- ((forms decls doc) (parse-body body))
+ ((forms decls doc) (parse-body body t))
  ((outer-decls inner-decls)
  (extract-var-decls decls (append env stores)))
  (subforms (copy-symbol 'subforms))

src/compiler/deftype.lisp

@@ -33,7 +33,7 @@
  (bad-type name 'symbol "Type name is not a symbol:~% ~S"
  form))
  (multiple-value-bind (expander-form doc source-location-form)
- (multiple-value-bind (forms decls doc) (parse-body body)
+ (multiple-value-bind (forms decls doc) (parse-body body t)
  ;; FIXME: We could use CONSTANTP here to deal with slightly more
  ;; complex deftypes using CONSTANT-TYPE-EXPANDER, but that XC:CONSTANTP
  ;; is not availble early enough.

src/compiler/fopcompile.lisp

@@ -199,8 +199,7 @@
 
 (defun let-fopcompilable-p (operator args)
  (when (>= (length args) 1)
- (multiple-value-bind (body decls)
- (parse-body (cdr args) :doc-string-allowed nil)
+ (multiple-value-bind (body decls) (parse-body (cdr args) nil)
  (declare (ignore body))
  (let* ((orig-lexenv *lexenv*)
  (*lexenv* (make-lexenv)))

src/compiler/ir1-translators.lisp

@@ -700,8 +700,7 @@ have been evaluated."
  (cond ((null bindings)
  (ir1-translate-locally body start next result))
  ((listp bindings)
- (multiple-value-bind (forms decls)
- (parse-body body :doc-string-allowed nil)
+ (multiple-value-bind (forms decls) (parse-body body nil)
  (multiple-value-bind (vars values) (extract-let-vars bindings 'let)
  (binding* ((ctran (make-ctran))
  (fun-lvar (make-lvar))
@@ -727,8 +726,7 @@ have been evaluated."
 Similar to LET, but the variables are bound sequentially, allowing each VALUE
 form to reference any of the previous VARS."
  (if (listp bindings)
- (multiple-value-bind (forms decls)
- (parse-body body :doc-string-allowed nil)
+ (multiple-value-bind (forms decls) (parse-body body nil)
  (multiple-value-bind (vars values) (extract-let-vars bindings 'let*)
  (processing-decls (decls vars nil next result post-binding-lexenv)
  (ir1-convert-aux-bindings start
@@ -750,7 +748,7 @@ form to reference any of the previous VARS."
 (defun ir1-translate-locally (body start next result &key vars funs)
  (declare (type ctran start next) (type (or lvar null) result)
  (type list body))
- (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
+ (multiple-value-bind (forms decls) (parse-body body nil)
  (processing-decls (decls vars funs next result)
  (ir1-convert-progn-body start next result forms))))
 
@@ -785,7 +783,7 @@ also processed as top level forms."
  (program-assert-symbol-home-package-unlocked
  :compile name "binding ~A as a local function"))
  (names name)
- (multiple-value-bind (forms decls doc) (parse-body (cddr def))
+ (multiple-value-bind (forms decls doc) (parse-body (cddr def) t)
  (defs `(lambda ,(second def)
  ,@(when doc (list doc))
  ,@decls
@@ -824,8 +822,7 @@ also processed as top level forms."
 Evaluate the BODY-FORMS with local function definitions. The bindings do
 not enclose the definitions; any use of NAME in the FORMS will refer to the
 lexically apparent function definition in the enclosing environment."
- (multiple-value-bind (forms decls)
- (parse-body body :doc-string-allowed nil)
+ (multiple-value-bind (forms decls) (parse-body body nil)
  (unless (listp definitions)
  (compiler-error "Malformed FLET definitions: ~s" definitions))
  (multiple-value-bind (names defs)
@@ -848,7 +845,7 @@ lexically apparent function definition in the enclosing environment."
 Evaluate the BODY-FORMS with local function definitions. The bindings enclose
 the new definitions, so the defined functions can call themselves or each
 other."
- (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
+ (multiple-value-bind (forms decls) (parse-body body nil)
  (unless (listp definitions)
  (compiler-error "Malformed LABELS definitions: ~s" definitions))
  (multiple-value-bind (names defs)

src/compiler/ir1tran-lambda.lisp

@@ -945,7 +945,7 @@
  (setf debug-name (name-lambdalike form)))
  (multiple-value-bind (vars keyp allow-other-keys aux-vars aux-vals)
  (make-lambda-vars (cadr form))
- (multiple-value-bind (forms decls doc) (parse-body (cddr form))
+ (multiple-value-bind (forms decls doc) (parse-body (cddr form) t)
  (binding* (((*lexenv* result-type post-binding-lexenv lambda-list)
  (process-decls decls (append aux-vars vars) nil
  :binding-form-p t :allow-lambda-list t))

src/compiler/macros.lisp

@@ -95,7 +95,7 @@
  ;; except that it needs a "silently do nothing" mode, which may or may not
  ;; be a generally exposed feature.
  (binding*
- (((forms decls) (parse-body body))
+ (((forms decls) (parse-body body nil))
  ((llks req opt rest keys aux env whole)
  (parse-lambda-list
  lambda-list
@@ -422,7 +422,7 @@
  (declare (type (member nil :slightly t) important))
  (when (and eval-name defun-only)
  (error "can't specify both DEFUN-ONLY and EVAL-NAME"))
- (multiple-value-bind (body decls doc) (parse-body body-decls-doc)
+ (multiple-value-bind (body decls doc) (parse-body body-decls-doc t)
  (let ((n-node (or node (make-symbol "NODE")))
  (n-decls (sb!xc:gensym))
  (n-lambda (sb!xc:gensym)))
@@ -541,7 +541,7 @@
  what
  (symbolicate (function-name (first what))
  "-" (second what) "-OPTIMIZER"))))
- ((forms decls) (parse-body body :doc-string-allowed nil))
+ ((forms decls) (parse-body body nil))
  ((var-decls more-decls) (extract-var-decls decls vars))
  ;; In case the BODY declares IGNORE of the formal NODE var,
  ;; we rebind it from N-NODE and never reference it from BINDS.

src/compiler/main.lisp

@@ -1054,8 +1054,7 @@ necessary, since type inference may take arbitrarily long to converge.")
 ;;; We parse declarations and then recursively process the body.
 (defun process-toplevel-locally (body path compile-time-too &key vars funs)
  (declare (list path))
- (multiple-value-bind (forms decls)
- (parse-body body :doc-string-allowed nil :toplevel t)
+ (multiple-value-bind (forms decls) (parse-body body nil t)
  (with-ir1-namespace
  (let* ((*lexenv* (process-decls decls vars funs))
  ;; FIXME: VALUES declaration