src/code/parse-body.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3 ;;;;
   4 ;;;; This software is derived from the CMU CL system, which was
   5 ;;;; written at Carnegie Mellon University and released into the
   6 ;;;; public domain. The software is in the public domain and is
   7 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
   8 ;;;; files for more information.
   9
  10 (in-package "SB!IMPL")
  11
  12 ;;; Given a sequence of declarations (and possibly a documentation
  13 ;;; string) followed by other forms (as occurs in the bodies of DEFUN,
  14 ;;; DEFMACRO, etc.) return (VALUES FORMS DECLS DOC), where DECLS holds
  15 ;;; declarations, DOC holds a doc string (or NIL if none), and FORMS
  16 ;;; holds the other forms.
  17 ;;;
  18 ;;; If DOC-STRING-ALLOWED is NIL, then no forms will be treated as
  19 ;;; documentation strings.
  20 (defun parse-body (body doc-string-allowed &optional silent)
  21   (flet ((doc-string-p (x remaining-forms doc)
  22            (and (stringp x) doc-string-allowed
  23                   ;; ANSI 3.4.11 explicitly requires that a doc string
  24                   ;; be followed by another form (either an ordinary form
  25                   ;; or a declaration). Hence:
  26                 remaining-forms
  27                 (if doc
  28                       ;; .. and says that the consequences of multiple
  29                       ;; doc strings are unspecified.
  30                       ;; That's probably not something the programmer intends.
  31                       ;; We raise an error so that this won't pass unnoticed.
  32                     (error "duplicate doc string ~S" x)
  33                     t)))
  34          (declaration-p (x)
  35            (when (listp x)
  36              (let ((name (car x)))
  37                (cond ((eq name 'declare) t)
  38                      (t
  39                       (when (and (eq name 'declaim) (not silent))
  40                         ;; technically legal, but rather unlikely to
  41                         ;; be what the user meant to do...
  42                         (style-warn
  43                          "DECLAIM where DECLARE was probably intended"))
  44                       nil))))))
  45     (let ((forms body) (decls (list nil)) (doc nil))
  46       (declare (truly-dynamic-extent decls))
  47       (let ((decls decls))
  48         (loop (when (endp forms) (return))
  49               (let ((form (first forms)))
  50                 (cond ((doc-string-p form (rest forms) doc)
  51                        (setq doc form))
  52                       ((declaration-p form)
  53                        (setq decls (setf (cdr decls) (list form))))
  54                       (t
  55                        (return))))
  56               (setq forms (rest forms))))
  57       (values forms (cdr decls) doc))))