X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=903a0a673f47d475521bb6b23bde80cd25c49453;hb=6bbc22725d3bf663726ed9adca544e39316364a6;hp=6516ca2680e69911ea27245204a96682c2031f4d;hpb=d604a358d8e5eb5587989e0a4f1d31dbe6ac5ffe;p=sbcl.git diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 6516ca2..903a0a6 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -14,15 +14,40 @@ (declaim (special *compiler-error-bailout*)) +;;; *CURRENT-FORM-NUMBER* is used in FIND-SOURCE-PATHS to compute the +;;; form number to associate with a source path. This should be bound +;;; to an initial value of 0 before the processing of each truly +;;; top level form. +(declaim (type index *current-form-number*)) +(defvar *current-form-number*) + ;;; *SOURCE-PATHS* is a hashtable from source code forms to the path ;;; taken through the source to reach the form. This provides a way to ;;; keep track of the location of original source forms, even when ;;; macroexpansions and other arbitary permutations of the code ;;; happen. This table is initialized by calling FIND-SOURCE-PATHS on ;;; the original source. +;;; +;;; It is fairly useless to store symbols, characters, or fixnums in +;;; this table, as 42 is EQ to 42 no matter where in the source it +;;; appears. GET-SOURCE-PATH and NOTE-SOURCE-PATH functions should be +;;; always used to access this table. (declaim (hash-table *source-paths*)) (defvar *source-paths*) +(declaim (inline source-form-has-path-p)) +(defun source-form-has-path-p (form) + (not (typep form '(or symbol fixnum character)))) + +(defun get-source-path (form) + (when (source-form-has-path-p form) + (gethash form *source-paths*))) + +(defun note-source-path (form &rest arguments) + (when (source-form-has-path-p form) + (setf (gethash form *source-paths*) + (apply #'list* 'original-source-start *current-form-number* arguments)))) + ;;; *CURRENT-COMPONENT* is the COMPONENT structure which we link ;;; blocks into as we generate them. This just serves to glue the ;;; emitted blocks together until local call analysis and flow graph @@ -64,7 +89,7 @@ ;;; Return a GLOBAL-VAR structure usable for referencing the global ;;; function NAME. -(defun find-free-really-fun (name) +(defun find-global-fun (name latep) (unless (info :function :kind name) (setf (info :function :kind name) :function) (setf (info :function :where-from name) :assumed)) @@ -75,15 +100,22 @@ ;; running Lisp. But at cross-compile time, the current ;; definedness of a function is irrelevant to the ;; definedness at runtime, which is what matters. - #-sb-xc-host (not (fboundp name))) + #-sb-xc-host (not (fboundp name)) + ;; LATEP is true when the user has indicated that + ;; late-late binding is desired by using eg. a quoted + ;; symbol -- in which case it makes little sense to + ;; complain about undefined functions. + (not latep)) (note-undefined-reference name :function)) (make-global-var :kind :global-function :%source-name name - :type (if (or *derive-function-types* - (eq where :declared) - (and (member name *fun-names-in-this-file* :test #'equal) - (not (fun-lexically-notinline-p name)))) + :type (if (and (not latep) + (or *derive-function-types* + (eq where :declared) + (and (member name *fun-names-in-this-file* + :test #'equal) + (not (fun-lexically-notinline-p name))))) (info :function :type name) (specifier-type 'function)) :where-from where))) @@ -165,7 +197,7 @@ :type (if (eq inlinep :notinline) (specifier-type 'function) (info :function :type name))) - (find-free-really-fun name)))))))) + (find-global-fun name nil)))))))) ;;; Return the LEAF structure for the lexically apparent function ;;; definition of NAME. @@ -386,12 +418,12 @@ ;;; The hashtables used to hold global namespace info must be ;;; reallocated elsewhere. Note also that *LEXENV* is not bound, so ;;; that local macro definitions can be introduced by enclosing code. -(defun ir1-toplevel (form path for-value) +(defun ir1-toplevel (form path for-value &optional (allow-instrumenting t)) (declare (list path)) (let* ((*current-path* path) (component (make-empty-component)) (*current-component* component) - (*allow-instrumenting* t)) + (*allow-instrumenting* allow-instrumenting)) (setf (component-name component) 'initial-component) (setf (component-kind component) :initial) (let* ((forms (if for-value `(,form) `(,form nil))) @@ -403,13 +435,6 @@ (functional-kind res) :toplevel) res))) -;;; *CURRENT-FORM-NUMBER* is used in FIND-SOURCE-PATHS to compute the -;;; form number to associate with a source path. This should be bound -;;; to an initial value of 0 before the processing of each truly -;;; top level form. -(declaim (type index *current-form-number*)) -(defvar *current-form-number*) - ;;; This function is called on freshly read forms to record the ;;; initial location of each form (and subform.) Form is the form to ;;; find the paths in, and TLF-NUM is the top level form number of the @@ -423,9 +448,8 @@ (sub-find-source-paths form (list tlf-num))) (values)) (defun sub-find-source-paths (form path) - (unless (gethash form *source-paths*) - (setf (gethash form *source-paths*) - (list* 'original-source-start *current-form-number* path)) + (unless (get-source-path form) + (note-source-path form path) (incf *current-form-number*) (let ((pos 0) (subform form) @@ -435,8 +459,13 @@ '(progn (when (atom subform) (return)) (let ((fm (car subform))) - (when (consp fm) - (sub-find-source-paths fm (cons pos path))) + (if (consp fm) + ;; If it's a cons, recurse + (sub-find-source-paths fm (cons pos path)) + ;; Otherwise store the containing form. It's + ;; not perfect, but better than nothing. + (unless (zerop pos) + (note-source-path subform pos path))) (incf pos)) (setq subform (cdr subform)) (when (eq subform trail) (return))))) @@ -463,7 +492,8 @@ ,@body (return-from ,skip nil))))) (ir1-convert ,start ,next ,result - (make-compiler-error-form ,condition ,form))))))) + (make-compiler-error-form ,condition + ,form))))))) ;; Translate FORM into IR1. The code is inserted as the NEXT of the ;; CTRAN START. RESULT is the LVAR which receives the value of the @@ -477,11 +507,10 @@ ;; namespace. (defun ir1-convert (start next result form) (ir1-error-bailout (start next result form) - (let ((*current-path* (or (gethash form *source-paths*) - (cons form *current-path*)))) - (cond ((step-form-p form) - (ir1-convert-step start next result form)) - ((atom form) + (let* ((*current-path* (or (get-source-path form) + (cons form *current-path*))) + (start (instrument-coverage start nil form))) + (cond ((atom form) (cond ((and (symbolp form) (not (keywordp form))) (ir1-convert-var start next result form)) ((leaf-p form) @@ -489,40 +518,7 @@ (t (reference-constant start next result form)))) (t - (let ((opname (car form))) - (cond ((or (symbolp opname) (leaf-p opname)) - (let ((lexical-def (if (leaf-p opname) - opname - (lexenv-find opname funs)))) - (typecase lexical-def - (null - (ir1-convert-global-functoid start next result - form)) - (functional - (ir1-convert-local-combination start next result - form - lexical-def)) - (global-var - (ir1-convert-srctran start next result - lexical-def form)) - (t - (aver (and (consp lexical-def) - (eq (car lexical-def) 'macro))) - (ir1-convert start next result - (careful-expand-macro (cdr lexical-def) - form)))))) - ((or (atom opname) (not (eq (car opname) 'lambda))) - (compiler-error "illegal function call")) - (t - ;; implicitly (LAMBDA ..) because the LAMBDA - ;; expression is the CAR of an executed form - (ir1-convert-combination start next result - form - (ir1-convert-lambda - opname - :debug-name (debug-name - 'lambda-car - opname)))))))))) + (ir1-convert-functoid start next result form))))) (values)) ;; Generate a reference to a manifest constant, creating a new leaf @@ -616,72 +612,124 @@ (defun ir1-convert-var (start next result name) (declare (type ctran start next) (type (or lvar null) result) (symbol name)) (let ((var (or (lexenv-find name vars) (find-free-var name)))) - (etypecase var - (leaf - (when (lambda-var-p var) - (let ((home (ctran-home-lambda-or-null start))) - (when home - (pushnew var (lambda-calls-or-closes home)))) - (when (lambda-var-ignorep var) - ;; (ANSI's specification for the IGNORE declaration requires - ;; that this be a STYLE-WARNING, not a full WARNING.) - #-sb-xc-host - (compiler-style-warn "reading an ignored variable: ~S" name) - ;; there's no need for us to accept ANSI's lameness when - ;; processing our own code, though. - #+sb-xc-host - (warn "reading an ignored variable: ~S" name))) - (reference-leaf start next result var)) - (cons - (aver (eq (car var) 'macro)) - ;; FIXME: [Free] type declarations. -- APD, 2002-01-26 - (ir1-convert start next result (cdr var))) - (heap-alien-info - (ir1-convert start next result `(%heap-alien ',var))))) + (if (and (global-var-p var) (not result)) + ;; KLUDGE: If the reference is dead, convert using SYMBOL-VALUE + ;; which is not flushable, so that unbound dead variables signal + ;; an error (bug 412). + (ir1-convert start next result `(symbol-value ',name)) + (etypecase var + (leaf + (when (lambda-var-p var) + (let ((home (ctran-home-lambda-or-null start))) + (when home + (sset-adjoin var (lambda-calls-or-closes home)))) + (when (lambda-var-ignorep var) + ;; (ANSI's specification for the IGNORE declaration requires + ;; that this be a STYLE-WARNING, not a full WARNING.) + #-sb-xc-host + (compiler-style-warn "reading an ignored variable: ~S" name) + ;; there's no need for us to accept ANSI's lameness when + ;; processing our own code, though. + #+sb-xc-host + (warn "reading an ignored variable: ~S" name))) + (reference-leaf start next result var)) + (cons + (aver (eq (car var) 'macro)) + ;; FIXME: [Free] type declarations. -- APD, 2002-01-26 + (ir1-convert start next result (cdr var))) + (heap-alien-info + (ir1-convert start next result `(%heap-alien ',var)))))) (values)) -;;; Convert anything that looks like a special form, global function -;;; or compiler-macro call. -(defun ir1-convert-global-functoid (start next result form) - (declare (type ctran start next) (type (or lvar null) result) (list form)) - (let* ((fun-name (first form)) - (translator (info :function :ir1-convert fun-name)) - (cmacro-fun (sb!xc:compiler-macro-function fun-name *lexenv*))) +;;; Find a compiler-macro for a form, taking FUNCALL into account. +(defun find-compiler-macro (opname form) + (if (eq opname 'funcall) + (let ((fun-form (cadr form))) + (cond ((and (consp fun-form) (eq 'function (car fun-form))) + (let ((real-fun (cadr fun-form))) + (if (legal-fun-name-p real-fun) + (values (sb!xc:compiler-macro-function real-fun *lexenv*) + real-fun) + (values nil nil)))) + ((sb!xc:constantp fun-form *lexenv*) + (let ((fun (constant-form-value fun-form *lexenv*))) + (if (legal-fun-name-p fun) + ;; CLHS tells us that local functions must shadow + ;; compiler-macro-functions, but since the call is + ;; through a name, we are obviously interested + ;; in the global function. + (values (sb!xc:compiler-macro-function fun nil) fun) + (values nil nil)))) + (t + (values nil nil)))) + (if (legal-fun-name-p opname) + (values (sb!xc:compiler-macro-function opname *lexenv*) opname) + (values nil nil)))) + +;;; Picks of special forms and compiler-macro expansions, and hands +;;; the rest to IR1-CONVERT-COMMON-FUNCTOID +(defun ir1-convert-functoid (start next result form) + (let* ((op (car form)) + (translator (and (symbolp op) (info :function :ir1-convert op)))) (cond (translator - (when cmacro-fun + (when (sb!xc:compiler-macro-function op *lexenv*) (compiler-warn "ignoring compiler macro for special form")) (funcall translator start next result form)) - ((and cmacro-fun - ;; gotcha: If you look up the DEFINE-COMPILER-MACRO - ;; macro in the ANSI spec, you might think that - ;; suppressing compiler-macro expansion when NOTINLINE - ;; is some pre-ANSI hack. However, if you look up the - ;; NOTINLINE declaration, you'll find that ANSI - ;; requires this behavior after all. - (not (eq (info :function :inlinep fun-name) :notinline))) - (let ((res (careful-expand-macro cmacro-fun form))) - (if (eq res form) - (ir1-convert-global-functoid-no-cmacro - start next result form fun-name) - (ir1-convert start next result res)))) (t - (ir1-convert-global-functoid-no-cmacro start next result - form fun-name))))) + (multiple-value-bind (cmacro-fun cmacro-fun-name) + (find-compiler-macro op form) + (if (and cmacro-fun + ;; CLHS 3.2.2.1.3 specifies that NOTINLINE + ;; suppresses compiler-macros. + (not (fun-lexically-notinline-p cmacro-fun-name))) + (let ((res (careful-expand-macro cmacro-fun form))) + (if (eq res form) + (ir1-convert-common-functoid start next result form + op) + (ir1-convert start next result res))) + (ir1-convert-common-functoid start next result form op))))))) -;;; Handle the case of where the call was not a compiler macro, or was -;;; a compiler macro and passed. -(defun ir1-convert-global-functoid-no-cmacro (start next result form fun) +;;; Handles the "common" cases: any other forms except special forms +;;; and compiler-macros. +(defun ir1-convert-common-functoid (start next result form op) + (cond ((or (symbolp op) (leaf-p op)) + (let ((lexical-def (if (leaf-p op) op (lexenv-find op funs)))) + (typecase lexical-def + (null + (ir1-convert-global-functoid start next result form op)) + (functional + (ir1-convert-local-combination start next result form + lexical-def)) + (global-var + (ir1-convert-srctran start next result lexical-def form)) + (t + (aver (and (consp lexical-def) (eq (car lexical-def) 'macro))) + (ir1-convert start next result + (careful-expand-macro (cdr lexical-def) form)))))) + ((or (atom op) (not (eq (car op) 'lambda))) + (compiler-error "illegal function call")) + (t + ;; implicitly (LAMBDA ..) because the LAMBDA expression is + ;; the CAR of an executed form. + (ir1-convert-combination + start next result form + (ir1-convert-lambda op + :debug-name (debug-name 'inline-lambda op)))))) + +;;; Convert anything that looks like a global function call. +(defun ir1-convert-global-functoid (start next result form fun) (declare (type ctran start next) (type (or lvar null) result) (list form)) ;; FIXME: Couldn't all the INFO calls here be converted into - ;; standard CL functions, like MACRO-FUNCTION or something? - ;; And what happens with lexically-defined (MACROLET) macros - ;; here, anyway? + ;; standard CL functions, like MACRO-FUNCTION or something? And what + ;; happens with lexically-defined (MACROLET) macros here, anyway? (ecase (info :function :kind fun) (:macro (ir1-convert start next result (careful-expand-macro (info :function :macro-function fun) - form))) + form)) + (unless (policy *lexenv* (zerop store-xref-data)) + (record-macroexpansion fun (ctran-block start) *current-path*))) ((nil :function) (ir1-convert-srctran start next result (find-free-fun fun "shouldn't happen! (no-cmacro)") @@ -702,7 +750,7 @@ (let ((*print-pretty* nil) ;; We rely on the printer to abbreviate FORM. (*print-length* 3) - (*print-level* 1)) + (*print-level* 3)) (format nil #-sb-xc-host "(in macroexpansion of ~S)" @@ -770,6 +818,8 @@ (forms body)) (loop (let ((form (car forms))) + (setf this-start + (maybe-instrument-progn-like this-start forms form)) (when (endp (cdr forms)) (ir1-convert this-start next result form) (return)) @@ -778,9 +828,116 @@ (setq this-start this-ctran forms (cdr forms))))))) (values)) + + +;;;; code coverage + +;;; Used as the CDR of the code coverage instrumentation records +;;; (instead of NIL) to ensure that any well-behaving user code will +;;; not have constants EQUAL to that record. This avoids problems with +;;; the records getting coalesced with non-record conses, which then +;;; get mutated when the instrumentation runs. Note that it's +;;; important for multiple records for the same location to be +;;; coalesced. -- JES, 2008-01-02 +(defconstant +code-coverage-unmarked+ '%code-coverage-unmarked%) + +;;; Check the policy for whether we should generate code coverage +;;; instrumentation. If not, just return the original START +;;; ctran. Otherwise insert code coverage instrumentation after +;;; START, and return the new ctran. +(defun instrument-coverage (start mode form) + ;; We don't actually use FORM for anything, it's just convenient to + ;; have around when debugging the instrumentation. + (declare (ignore form)) + (if (and (policy *lexenv* (> store-coverage-data 0)) + *code-coverage-records* + *allow-instrumenting*) + (let ((path (source-path-original-source *current-path*))) + (when mode + (push mode path)) + (if (member (ctran-block start) + (gethash path *code-coverage-blocks*)) + ;; If this source path has already been instrumented in + ;; this block, don't instrument it again. + start + (let ((store + ;; Get an interned record cons for the path. A cons + ;; with the same object identity must be used for + ;; each instrument for the same block. + (or (gethash path *code-coverage-records*) + (setf (gethash path *code-coverage-records*) + (cons path +code-coverage-unmarked+)))) + (next (make-ctran)) + (*allow-instrumenting* nil)) + (push (ctran-block start) + (gethash path *code-coverage-blocks*)) + (let ((*allow-instrumenting* nil)) + (ir1-convert start next nil + `(locally + (declare (optimize speed + (safety 0) + (debug 0) + (check-constant-modification 0))) + ;; We're being naughty here, and + ;; modifying constant data. That's ok, + ;; we know what we're doing. + (%rplacd ',store t)))) + next))) + start)) + +;;; In contexts where we don't have a source location for FORM +;;; e.g. due to it not being a cons, but where we have a source +;;; location for the enclosing cons, use the latter source location if +;;; available. This works pretty well in practice, since many PROGNish +;;; macroexpansions will just directly splice a block of forms into +;;; some enclosing form with `(progn ,@body), thus retaining the +;;; EQness of the conses. +(defun maybe-instrument-progn-like (start forms form) + (or (when (and *allow-instrumenting* + (not (get-source-path form))) + (let ((*current-path* (get-source-path forms))) + (when *current-path* + (instrument-coverage start nil form)))) + start)) + +(defun record-code-coverage (info cc) + (setf (gethash info *code-coverage-info*) cc)) + +(defun clear-code-coverage () + (clrhash *code-coverage-info*)) + +(defun reset-code-coverage () + (maphash (lambda (info cc) + (declare (ignore info)) + (dolist (cc-entry cc) + (setf (cdr cc-entry) +code-coverage-unmarked+))) + *code-coverage-info*)) + +(defun code-coverage-record-marked (record) + (aver (consp record)) + (ecase (cdr record) + ((#.+code-coverage-unmarked+) nil) + ((t) t))) + ;;;; converting combinations +;;; Does this form look like something that we should add single-stepping +;;; instrumentation for? +(defun step-form-p (form) + (flet ((step-symbol-p (symbol) + (not (member (symbol-package symbol) + (load-time-value + ;; KLUDGE: packages we're not interested in + ;; stepping. + (mapcar #'find-package '(sb!c sb!int sb!impl + sb!kernel sb!pcl))))))) + (and *allow-instrumenting* + (policy *lexenv* (= insert-step-conditions 3)) + (listp form) + (symbolp (car form)) + (step-symbol-p (car form))))) + ;;; Convert a function call where the function FUN is a LEAF. FORM is ;;; the source for the call. We return the COMBINATION node so that ;;; the caller can poke at it if it wants to. @@ -790,7 +947,20 @@ (let ((ctran (make-ctran)) (fun-lvar (make-lvar))) (ir1-convert start ctran fun-lvar `(the (or function symbol) ,fun)) - (ir1-convert-combination-args fun-lvar ctran next result (cdr form)))) + (let ((combination + (ir1-convert-combination-args fun-lvar ctran next result + (cdr form)))) + (when (step-form-p form) + ;; Store a string representation of the form in the + ;; combination node. This will let the IR2 translator know + ;; that we want stepper instrumentation for this node. The + ;; string will be stored in the debug-info by DUMP-1-LOCATION. + (setf (combination-step-info combination) + (let ((*print-pretty* t) + (*print-circle* t) + (*print-readably* nil)) + (prin1-to-string form)))) + combination))) ;;; Convert the arguments to a call and make the COMBINATION ;;; node. FUN-LVAR yields the function to call. ARGS is the list of @@ -804,8 +974,12 @@ (let ((node (make-combination fun-lvar))) (setf (lvar-dest fun-lvar) node) (collect ((arg-lvars)) - (let ((this-start start)) + (let ((this-start start) + (forms args)) (dolist (arg args) + (setf this-start + (maybe-instrument-progn-like this-start forms arg)) + (setf forms (cdr forms)) (let ((this-ctran (make-ctran)) (this-lvar (make-lvar node))) (ir1-convert this-start this-ctran this-lvar arg) @@ -838,6 +1012,10 @@ (ir1-convert start next result transformed))) (ir1-convert-maybe-predicate start next result form var)))))) +;;; KLUDGE: If we insert a synthetic IF for a function with the PREDICATE +;;; attribute, don't generate any branch coverage instrumentation for it. +(defvar *instrument-if-for-code-coverage* t) + ;;; If the function has the PREDICATE attribute, and the RESULT's DEST ;;; isn't an IF, then we convert (IF
T NIL), ensuring that a ;;; predicate always appears in a conditional context. @@ -853,7 +1031,8 @@ (if (and info (ir1-attributep (fun-info-attributes info) predicate) (not (if-p (and result (lvar-dest result))))) - (ir1-convert start next result `(if ,form t nil)) + (let ((*instrument-if-for-code-coverage* nil)) + (ir1-convert start next result `(if ,form t nil))) (ir1-convert-combination-checking-type start next result form var)))) ;;; Actually really convert a global function call that we are allowed @@ -922,15 +1101,15 @@ ;;; If a LAMBDA-VAR being bound, we intersect the type with the var's ;;; type, otherwise we add a type restriction on the var. If a symbol ;;; macro, we just wrap a THE around the expansion. -(defun process-type-decl (decl res vars) +(defun process-type-decl (decl res vars context) (declare (list decl vars) (type lexenv res)) (let ((type (compiler-specifier-type (first decl)))) (collect ((restr nil cons) (new-vars nil cons)) (dolist (var-name (rest decl)) (when (boundp var-name) - (compiler-assert-symbol-home-package-unlocked - var-name "declaring the type of ~A")) + (program-assert-symbol-home-package-unlocked + context var-name "declaring the type of ~A")) (let* ((bound-var (find-in-bindings vars var-name)) (var (or bound-var (lexenv-find var-name vars) @@ -985,15 +1164,15 @@ ;;; declarations for functions being bound, we must also deal with ;;; declarations that constrain the type of lexically apparent ;;; functions. -(defun process-ftype-decl (spec res names fvars) +(defun process-ftype-decl (spec res names fvars context) (declare (type list names fvars) (type lexenv res)) (let ((type (compiler-specifier-type spec))) (collect ((res nil cons)) (dolist (name names) (when (fboundp name) - (compiler-assert-symbol-home-package-unlocked - name "declaring the ftype of ~A")) + (program-assert-symbol-home-package-unlocked + context name "declaring the ftype of ~A")) (let ((found (find name fvars :key #'leaf-source-name :test #'equal))) (cond (found @@ -1013,11 +1192,12 @@ ;;; special declaration is instantiated by throwing a special variable ;;; into the variables if BINDING-FORM-P is NIL, or otherwise into ;;; *POST-BINDING-VARIABLE-LEXENV*. -(defun process-special-decl (spec res vars binding-form-p) +(defun process-special-decl (spec res vars binding-form-p context) (declare (list spec vars) (type lexenv res)) (collect ((new-venv nil cons)) (dolist (name (cdr spec)) - (compiler-assert-symbol-home-package-unlocked name "declaring ~A special") + (program-assert-symbol-home-package-unlocked + context name "declaring ~A special") (let ((var (find-in-bindings vars name))) (etypecase var (cons @@ -1066,6 +1246,8 @@ (defined-fun-inline-expansion var)) (setf (defined-fun-functional res) (defined-fun-functional var))) + ;; FIXME: Is this really right? Needs we not set the FUNCTIONAL + ;; to the original global-var? res)) ;;; Parse an inline/notinline declaration. If it's a local function we're @@ -1192,18 +1374,18 @@ ;;; Process a single declaration spec, augmenting the specified LEXENV ;;; RES. Return RES and result type. VARS and FVARS are as described ;;; PROCESS-DECLS. -(defun process-1-decl (raw-spec res vars fvars binding-form-p) +(defun process-1-decl (raw-spec res vars fvars binding-form-p context) (declare (type list raw-spec vars fvars)) (declare (type lexenv res)) (let ((spec (canonized-decl-spec raw-spec)) (result-type *wild-type*)) (values (case (first spec) - (special (process-special-decl spec res vars binding-form-p)) + (special (process-special-decl spec res vars binding-form-p context)) (ftype (unless (cdr spec) (compiler-error "no type specified in FTYPE declaration: ~S" spec)) - (process-ftype-decl (second spec) res (cddr spec) fvars)) + (process-ftype-decl (second spec) res (cddr spec) fvars context)) ((inline notinline maybe-inline) (process-inline-decl spec res fvars)) ((ignore ignorable) @@ -1224,7 +1406,7 @@ :handled-conditions (process-unmuffle-conditions-decl spec (lexenv-handled-conditions res)))) (type - (process-type-decl (cdr spec) res vars)) + (process-type-decl (cdr spec) res vars context)) (values (unless *suppress-values-declaration* (let ((types (cdr spec))) @@ -1259,8 +1441,8 @@ ;;; ;;; This is also called in main.lisp when PROCESS-FORM handles a use ;;; of LOCALLY. -(defun process-decls (decls vars fvars &key (lexenv *lexenv*) - (binding-form-p nil)) +(defun process-decls (decls vars fvars &key + (lexenv *lexenv*) (binding-form-p nil) (context :compile)) (declare (list decls vars fvars)) (let ((result-type *wild-type*) (*post-binding-variable-lexenv* nil)) @@ -1269,7 +1451,7 @@ (unless (consp spec) (compiler-error "malformed declaration specifier ~S in ~S" spec decl)) (multiple-value-bind (new-env new-result-type) - (process-1-decl spec lexenv vars fvars binding-form-p) + (process-1-decl spec lexenv vars fvars binding-form-p context) (setq lexenv new-env) (unless (eq new-result-type *wild-type*) (setq result-type