From 637d81a5d1708601119508b0db0bd28356f58697 Mon Sep 17 00:00:00 2001 From: Douglas Katzman Date: Fri, 6 Nov 2015 20:08:16 -0500 Subject: [PATCH] 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 | 2 +- src/code/defboot.lisp | 7 ++-- src/code/early-extensions.lisp | 11 +++--- src/code/eval.lisp | 3 +- src/code/macros.lisp | 9 ++--- src/code/package.lisp | 3 +- src/code/parse-body.lisp | 77 ++++++++++++++----------------------- src/code/primordial-extensions.lisp | 3 +- src/code/seq.lisp | 5 +-- src/code/setf.lisp | 2 +- src/compiler/deftype.lisp | 2 +- src/compiler/fopcompile.lisp | 3 +- src/compiler/ir1-translators.lisp | 15 +++----- src/compiler/ir1tran-lambda.lisp | 2 +- src/compiler/macros.lisp | 6 +-- src/compiler/main.lisp | 3 +- src/compiler/parse-lambda-list.lisp | 3 +- src/interpreter/env.lisp | 56 +-------------------------- src/interpreter/function.lisp | 12 ++---- src/interpreter/macros.lisp | 3 +- src/interpreter/special-forms.lisp | 16 ++++---- src/pcl/boot.lisp | 4 +- src/pcl/defcombin.lisp | 2 +- src/pcl/walk.lisp | 2 +- 24 files changed, 78 insertions(+), 173 deletions(-) diff --git a/src/code/array.lisp b/src/code/array.lisp index bd394eb4f..04bc05135 100644 --- a/src/code/array.lisp +++ b/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) diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp index d9f23f0a4..b6f5dfc21 100644 --- a/src/code/defboot.lisp +++ b/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) diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 62f19b834..46716a916 100644 --- a/src/code/early-extensions.lisp +++ b/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 diff --git a/src/code/eval.lisp b/src/code/eval.lisp index a58d2583c..8fefd30ae 100644 --- a/src/code/eval.lisp +++ b/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 diff --git a/src/code/macros.lisp b/src/code/macros.lisp index 5f9cda3af..a31a9fbce 100644 --- a/src/code/macros.lisp +++ b/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)) diff --git a/src/code/package.lisp b/src/code/package.lisp index 36e33533a..5070b1d8d 100644 --- a/src/code/package.lisp +++ b/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) diff --git a/src/code/parse-body.lisp b/src/code/parse-body.lisp index 0f0ed1caa..bf23e62dc 100644 --- a/src/code/parse-body.lisp +++ b/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)))) diff --git a/src/code/primordial-extensions.lisp b/src/code/primordial-extensions.lisp index c13cae7f5..318818ea1 100644 --- a/src/code/primordial-extensions.lisp +++ b/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 diff --git a/src/code/seq.lisp b/src/code/seq.lisp index 915543d43..0d8b14881 100644 --- a/src/code/seq.lisp +++ b/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 diff --git a/src/code/setf.lisp b/src/code/setf.lisp index 3c2248517..e3f876a5e 100644 --- a/src/code/setf.lisp +++ b/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)) diff --git a/src/compiler/deftype.lisp b/src/compiler/deftype.lisp index 950b64cdd..9994d2b70 100644 --- a/src/compiler/deftype.lisp +++ b/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. diff --git a/src/compiler/fopcompile.lisp b/src/compiler/fopcompile.lisp index e117ba463..bb260317d 100644 --- a/src/compiler/fopcompile.lisp +++ b/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))) diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index 318e2b702..67d2b911a 100644 --- a/src/compiler/ir1-translators.lisp +++ b/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) diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp index 5ba56f466..00ce9a3bc 100644 --- a/src/compiler/ir1tran-lambda.lisp +++ b/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)) diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index f3588bb6f..cee762358 100644 --- a/src/compiler/macros.lisp +++ b/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. diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 8865ab0f3..191baf5a6 100644 --- a/src/compiler/main.lisp +++ b/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 diff --git a/src/compiler/parse-lambda-list.lisp b/src/compiler/parse-lambda-list.lisp index 3d633c866..5c529d42f 100644 --- a/src/compiler/parse-lambda-list.lisp +++ b/src/compiler/parse-lambda-list.lisp @@ -1064,8 +1064,7 @@ ((:environment envp) t) (wrap-block name)) (declare (type (member t nil :ignore) envp)) (declare (type (member nil :external :internal) doc-string-allowed)) - (binding* (((forms decls docstring) - (parse-body body :doc-string-allowed doc-string-allowed)) + (binding* (((forms decls docstring) (parse-body body doc-string-allowed)) ;; Parse the lambda list, but not recursively. ((llks req opt rest keys aux env whole) (parse-lambda-list diff --git a/src/interpreter/env.lisp b/src/interpreter/env.lisp index f8f7f24b7..6c61552c0 100644 --- a/src/interpreter/env.lisp +++ b/src/interpreter/env.lisp @@ -666,60 +666,6 @@ :key #'car)))) (setf (logbitp i special-b) t)))))) -;;; Split off the declarations (and the docstring, if DOCSTRING-ALLOWED -;;; is true) from the actual forms of BODY. -;;; Also do some rudimentary checks on the declarations (if any). -;;; Return three values: the cons in BODY containing the first evaluable -;;; subform, a list of the declarations, and a docstring if present. -;;; KLUDGE: would be nice to share the compiler's PARSE-BODY, -;;; except that because this is called potentially a lot more than -;;; once per input form, we don't want the "DECLAIM where DECLARE" -;;; style-warning every time. It's only a warning, not an error. -;;; KLUDGE: Genesis can't shadow parse-body, so name it differently. -(defun iparse-body (body &optional docstring-allowed) - (let (decls-list docstring) - (flet ((quick-validate-decls (subexpr &aux (specs (cdr subexpr))) - (unless (and (proper-list-p specs) (every #'consp specs)) - (ip-error "malformed declaration ~S" subexpr)) - ;; It's faster to store the list of DECLARE expressions - ;; sans initial DECLARE rather than append together - ;; into a list of just the decl-specs of all of them. - (dolist (decl specs) - (when (eq (car decl) 'optimize) - (dolist (element (cdr decl)) - (let ((quality - (if (atom element) - element - (with-subforms (quality value) element - (declare (ignore value)) - quality)))) - (unless (sb-c::policy-quality-name-p quality) - (warn "ignoring unknown optimization quality ~S in ~S" - quality subexpr)))))) - (push specs decls-list))) - (macrolet - ((scan (checking-docstring) - `(loop - (let ((form (car body))) - (cond ((listp form) - (cond ((eql (car form) 'declare) - (quick-validate-decls form) - (pop body)) - (t - (return)))) - ((and ,checking-docstring (stringp form)) - ;; CLHS 3.4.11 - (cond ((not (cdr body)) (return)) - (docstring ; "consequences are unspecified" - (ip-error "~@" - form)) - (t - (pop body) (setf docstring form)))) - (t (return))))))) - ;; slight optimization: two variations of the loop - (if docstring-allowed (scan t) (scan nil)) - (values body (nreverse decls-list) docstring))))) - (defun make-proto-fn (lambda-expression &optional (silent t)) (multiple-value-bind (name lambda-list body) (if (eq (car lambda-expression) 'named-lambda) @@ -731,7 +677,7 @@ ;; If lexical environment is NIL, :silent will be passed as NIL, ;; and we can warn about "suspcious variables" and such. (parse-lambda-list lambda-list :silent silent) - (multiple-value-bind (forms decls docstring) (iparse-body body t) + (multiple-value-bind (forms decls docstring) (parse-body body t t) (%make-proto-fn name lambda-list decls forms docstring (do-decl-spec (spec decls lambda-list) (when (eq (car spec) 'sb-c::lambda-list) diff --git a/src/interpreter/function.lisp b/src/interpreter/function.lisp index ec0666a4d..5bc00e440 100644 --- a/src/interpreter/function.lisp +++ b/src/interpreter/function.lisp @@ -56,9 +56,6 @@ (cookie nil) ; nonce for memoization of macros (%frame nil)) -(defun unparse-decls (list) - (mapcar (lambda (x) `(declare ,@x)) list)) - (defun fun-forms (fun) (proto-fn-forms (interpreted-function-proto-fn fun))) @@ -66,11 +63,10 @@ (let* ((proto-fn (interpreted-function-proto-fn fun)) (name (proto-fn-name proto-fn)) (named-p (neq name 0))) - (values (cons (if named-p 'named-lambda 'lambda) - (nconc (if named-p (list name)) - (list (proto-fn-lambda-list proto-fn)) - (unparse-decls (proto-fn-decls proto-fn)) - (proto-fn-forms proto-fn))) + (values (append (if named-p (list 'named-lambda name) '(lambda)) + (list (proto-fn-lambda-list proto-fn)) + (proto-fn-decls proto-fn) + (proto-fn-forms proto-fn)) ;; CLHS permits returning T as the safe default, ;; but we can return a better value. No function's env is NIL, ;; because it needs to capture a policy. If the only elements diff --git a/src/interpreter/macros.lisp b/src/interpreter/macros.lisp index 020042560..237081458 100644 --- a/src/interpreter/macros.lisp +++ b/src/interpreter/macros.lisp @@ -160,12 +160,11 @@ ;;; subexpresssions whose head was DECLARE in a form accepting declarations. ;;; The list as stored is doubly-nested because each DECLARE expression ;;; is preserved separately, and within it the declarations. -;;; e.g. (locally (declare foo) (declare bar baz)) = ((foo) (bar baz)) (defmacro do-decl-spec ((var input &optional result) &body body) (let ((outer (gensym)) (inner (gensym))) `(dolist (,outer ,input ,result) - (do-anonymous ((,inner ,outer (cdr ,inner))) ((endp ,inner)) + (do-anonymous ((,inner (cdr ,outer) (cdr ,inner))) ((endp ,inner)) (let ((,var (car ,inner))) ,@body))))) diff --git a/src/interpreter/special-forms.lisp b/src/interpreter/special-forms.lisp index 8f54043ee..07c084380 100644 --- a/src/interpreter/special-forms.lisp +++ b/src/interpreter/special-forms.lisp @@ -689,7 +689,7 @@ ;;; of the complicated ... (defun digest-locally (env body) - (multiple-value-bind (forms decls) (iparse-body body) + (multiple-value-bind (forms decls) (parse-body body nil t) (if (not decls) (digest-progn forms) (let* ((specials (free-specials env decls)) @@ -705,7 +705,7 @@ (defspecial locally (&body body) :immediate (env) - (multiple-value-bind (forms decls) (iparse-body body) + (multiple-value-bind (forms decls) (parse-body body nil t) (let* ((specials (free-specials env decls)) (scope (process-typedecls (make-decl-scope decls (new-policy env decls)) @@ -715,7 +715,7 @@ :deferred (env) (digest-locally env body)) (defun parse-symbol-macrolet (env bindings body wrap-fn) - (multiple-value-bind (forms decls) (iparse-body body) + (multiple-value-bind (forms decls) (parse-body body nil t) (binding* (((specials n-specials) (declared-specials decls)) (n-macros (length bindings)) (symbols (make-array (+ n-macros n-specials))) @@ -758,7 +758,7 @@ (dispatch (symbol-macro-body scope) (new-env))))))) (defun parse-let (maker env bindings body specials-listifier) - (multiple-value-bind (forms decls) (iparse-body body) + (multiple-value-bind (forms decls) (parse-body body nil t) (binding* (((declared-specials n-declared) (declared-specials decls)) (n-bindings 0) (n-free-specials @@ -914,7 +914,7 @@ ;;; MACROLET has an immediate-mode handler since it is common at toplevel. (defspecial macrolet (defs &body body) :immediate (env) - (multiple-value-bind (forms decls) (iparse-body body) + (multiple-value-bind (forms decls) (parse-body body nil t) (let* ((specials (free-specials env decls)) (scope (process-typedecls (make-decl-scope decls (new-policy env decls)) @@ -927,7 +927,7 @@ :deferred (env) (if (not defs) (digest-locally env body) - (multiple-value-bind (forms decls) (iparse-body body) + (multiple-value-bind (forms decls) (parse-body body nil t) (let ((scope (make-local-fn-scope decls (eval-local-macros env defs) forms env))) (hlambda MACROLET (scope) (env) @@ -944,7 +944,7 @@ (defun digest-local-fns (env kind bindings body) ; KIND is FLET or LABELS (flet ((proto-functionize (def) (with-subforms (name lambda-list &body body) def - (multiple-value-bind (forms decls docstring) (iparse-body body t) + (multiple-value-bind (forms decls docstring) (parse-body body t t) ;; *** Test LEGAL-FUN-NAME-P before asking for an info-value. ;; This is because (INFO :FUNCTION :KIND) uses FBOUNDP when it ;; does not have an entry for NAME. But calling FBOUNDP @@ -986,7 +986,7 @@ forms))) (%make-proto-fn `(,kind ,name) lambda-list decls forms docstring))))))) - (multiple-value-bind (forms decls) (iparse-body body) + (multiple-value-bind (forms decls) (parse-body body nil t) (make-local-fn-scope decls (map 'vector #'proto-functionize bindings) forms env)))) diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index e8434bac1..b6d2dfd01 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -592,7 +592,7 @@ generic function lambda list ~S~:>" is not a lambda form." method-lambda)) (multiple-value-bind (real-body declarations documentation) - (parse-body (cddr method-lambda)) + (parse-body (cddr method-lambda) t) ;; We have the %METHOD-NAME declaration in the place where we expect it only ;; if there is are no non-standard prior MAKE-METHOD-LAMBDA methods -- or ;; unless they're fantastically unintrusive. @@ -701,7 +701,7 @@ generic function lambda list ~S~:>" (multiple-value-bind (walked-lambda-body walked-declarations walked-documentation) - (parse-body (cddr walked-lambda)) + (parse-body (cddr walked-lambda) t) (declare (ignore walked-documentation)) (when (some #'cdr slots) (let ((slot-name-lists (slot-name-lists-from-slots slots))) diff --git a/src/pcl/defcombin.lisp b/src/pcl/defcombin.lisp index 9b3f46bf5..0b1f66cb6 100644 --- a/src/pcl/defcombin.lisp +++ b/src/pcl/defcombin.lisp @@ -269,7 +269,7 @@ (type-name ll method-group-specifiers args-option gf-var body) (declare (ignore type-name)) (multiple-value-bind (real-body declarations documentation) - (parse-body body) + (parse-body body t) (let ((wrapped-body (wrap-method-group-specifier-bindings method-group-specifiers declarations diff --git a/src/pcl/walk.lisp b/src/pcl/walk.lisp index 253f45ee8..81928b258 100644 --- a/src/pcl/walk.lisp +++ b/src/pcl/walk.lisp @@ -780,7 +780,7 @@ (bindings (cadr form)) (body (cddr form))) (multiple-value-bind (names inits) (let*-bindings bindings) - (multiple-value-bind (newbody decls doc) (parse-body body :doc-string-allowed nil) + (multiple-value-bind (newbody decls doc) (parse-body body nil) (declare (ignore newbody)) (aver (null doc)) (labels ((maybe-process-and-munge-declaration (name declaration env) -- 2.11.4.GIT