X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1util.lisp;h=da56197f27cc6e1d8cf828b01a1eb39dcd4847d3;hb=0dcc957ae6bf24809fda82fd59c134e70058c42a;hp=86a7b8d8d10c784ffd95a7c2948fc320b4149a62;hpb=64bf93a97814ea1caf62bbdcc7ef43e2fbfc8f73;p=sbcl.git diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 86a7b8d..da56197 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -25,12 +25,13 @@ (let ((cup (lexenv-cleanup lexenv))) (when cup (return cup))))) -;;; Convert the Form in a block inserted between Block1 and Block2 as an -;;; implicit MV-Prog1. The inserted block is returned. Node is used for IR1 -;;; context when converting the form. Note that the block is not assigned a -;;; number, and is linked into the DFO at the beginning. We indicate that we -;;; have trashed the DFO by setting Component-Reanalyze. If Cleanup is -;;; supplied, then convert with that cleanup. +;;; Convert the FORM in a block inserted between BLOCK1 and BLOCK2 as +;;; an implicit MV-PROG1. The inserted block is returned. NODE is used +;;; for IR1 context when converting the form. Note that the block is +;;; not assigned a number, and is linked into the DFO at the +;;; beginning. We indicate that we have trashed the DFO by setting +;;; COMPONENT-REANALYZE. If CLEANUP is supplied, then convert with +;;; that cleanup. (defun insert-cleanup-code (block1 block2 node form &optional cleanup) (declare (type cblock block1 block2) (type node node) (type (or cleanup null) cleanup)) @@ -60,9 +61,9 @@ (:unused nil) (:deleted nil))) -;;; Update continuation use information so that Node is no longer a -;;; use of its Cont. If the old continuation doesn't start its block, -;;; then we don't update the Block-Start-Uses, since it will be +;;; Update continuation use information so that NODE is no longer a +;;; use of its CONT. If the old continuation doesn't start its block, +;;; then we don't update the BLOCK-START-USES, since it will be ;;; deleted when we are done. ;;; ;;; Note: if you call this function, you may have to do a @@ -87,8 +88,8 @@ (setf (node-cont node) nil)) (values)) -;;; Update continuation use information so that Node uses Cont. If -;;; Cont is :Unused, then we set its block to Node's Node-Block (which +;;; Update continuation use information so that NODE uses CONT. If +;;; CONT is :UNUSED, then we set its block to NODE's NODE-BLOCK (which ;;; must be set.) ;;; ;;; Note: if you call this function, you may have to do a @@ -96,14 +97,14 @@ ;;; has changed. (declaim (ftype (function (node continuation) (values)) add-continuation-use)) (defun add-continuation-use (node cont) - (assert (not (node-cont node))) + (aver (not (node-cont node))) (let ((block (continuation-block cont))) (ecase (continuation-kind cont) (:deleted) (:unused - (assert (not block)) + (aver (not block)) (let ((block (node-block node))) - (assert block) + (aver block) (setf (continuation-block cont) block)) (setf (continuation-kind cont) :inside-block) (setf (continuation-use cont) node)) @@ -115,8 +116,8 @@ (setf (node-cont node) cont) (values)) -;;; Return true if Cont is the Node-Cont for Node and Cont is transferred to -;;; immediately after the evaluation of Node. +;;; Return true if CONT is the NODE-CONT for NODE and CONT is +;;; transferred to immediately after the evaluation of NODE. (defun immediately-used-p (cont node) (declare (type continuation cont) (type node node)) (and (eq (node-cont node) cont) @@ -130,12 +131,12 @@ ;;;; continuation substitution -;;; In Old's Dest, replace Old with New. New's Dest must initially be NIL. -;;; When we are done, we call Flush-Dest on Old to clear its Dest and to note -;;; potential optimization opportunities. +;;; In OLD's DEST, replace OLD with NEW. NEW's DEST must initially be +;;; NIL. When we are done, we call FLUSH-DEST on OLD to clear its DEST +;;; and to note potential optimization opportunities. (defun substitute-continuation (new old) (declare (type continuation old new)) - (assert (not (continuation-dest new))) + (aver (not (continuation-dest new))) (let ((dest (continuation-dest old))) (etypecase dest ((or ref bind)) @@ -187,7 +188,7 @@ (declare (type continuation cont)) (ecase (continuation-kind cont) (:unused - (assert (not (continuation-block cont))) + (aver (not (continuation-block cont))) (let* ((head (component-head *current-component*)) (next (block-next head)) (new-block (make-block cont))) @@ -273,21 +274,21 @@ #!-sb-fluid (declare (inline node-home-lambda)) (lambda-environment (node-home-lambda (block-last block)))) -;;; Return the Top Level Form number of path, i.e. the ordinal number of -;;; its orignal source's top-level form in its compilation unit. +;;; Return the Top Level Form number of path, i.e. the ordinal number +;;; of its original source's top-level form in its compilation unit. (defun source-path-tlf-number (path) (declare (list path)) (car (last path))) -;;; Return the (reversed) list for the path in the orignal source (with the -;;; TLF number last.) +;;; Return the (reversed) list for the path in the original source +;;; (with the Top Level Form number last). (defun source-path-original-source (path) (declare (list path) (inline member)) (cddr (member 'original-source-start path :test #'eq))) -;;; Return the Form Number of Path's orignal source inside the Top Level -;;; Form that contains it. This is determined by the order that we walk the -;;; subforms of the top level source form. +;;; Return the Form Number of Path's original source inside the Top +;;; Level Form that contains it. This is determined by the order that +;;; we walk the subforms of the top level source form. (defun source-path-form-number (path) (declare (list path) (inline member)) (cadr (member 'original-source-start path :test #'eq))) @@ -323,8 +324,7 @@ options (lambda (lexenv-lambda default)) (cleanup (lexenv-cleanup default)) - (policy (lexenv-policy default)) - (interface-policy (lexenv-interface-policy default))) + (policy (lexenv-policy default))) (macrolet ((frob (var slot) `(let ((old (,slot default))) (if ,var @@ -336,22 +336,8 @@ (frob blocks lexenv-blocks) (frob tags lexenv-tags) (frob type-restrictions lexenv-type-restrictions) - lambda cleanup policy interface-policy + lambda cleanup policy (frob options lexenv-options)))) - -;;; Return a POLICY that defaults any unsupplied optimize qualities in -;;; the INTERFACE-POLICY with the corresponding ones from the POLICY. -(defun make-interface-policy (lexenv) - (declare (type lexenv lexenv)) - (let ((ipolicy (lexenv-interface-policy lexenv)) - (policy (lexenv-policy lexenv))) - (make-policy - :speed (or (policy-speed ipolicy) (policy-speed policy)) - :space (or (policy-space ipolicy) (policy-space policy)) - :safety (or (policy-safety ipolicy) (policy-safety policy)) - :cspeed (or (policy-cspeed ipolicy) (policy-cspeed policy)) - :brevity (or (policy-brevity ipolicy) (policy-brevity policy)) - :debug (or (policy-debug ipolicy) (policy-debug policy))))) ;;;; flow/DFO/component hackery @@ -368,7 +354,7 @@ (defun %link-blocks (block1 block2) (declare (type cblock block1 block2) (inline member)) (let ((succ1 (block-succ block1))) - (assert (not (member block2 succ1 :test #'eq))) + (aver (not (member block2 succ1 :test #'eq))) (cons block2 succ1))) ;;; Like LINK-BLOCKS, but we separate BLOCK1 and BLOCK2. If this leaves a @@ -384,7 +370,7 @@ (prev succ1 succ)) ((eq (car succ) block2) (setf (cdr prev) (cdr succ))) - (assert succ)))) + (aver succ)))) (let ((new-pred (delq block1 (block-pred block2)))) (setf (block-pred block2) new-pred) @@ -445,7 +431,7 @@ (declare (type cblock block after)) (let ((next (block-next after)) (comp (block-component after))) - (assert (not (eq (component-kind comp) :deleted))) + (aver (not (eq (component-kind comp) :deleted))) (setf (block-component block) comp) (setf (block-next after) block) (setf (block-prev block) after) @@ -489,7 +475,7 @@ (last (block-last block)) (last-cont (node-cont last))) (unless (eq last node) - (assert (and (eq (continuation-kind start) :inside-block) + (aver (and (eq (continuation-kind start) :inside-block) (not (block-delete-p block)))) (let* ((succ (block-succ block)) (new-block @@ -572,8 +558,8 @@ ;;; be called on functions that never had any references, since otherwise ;;; DELETE-REF will handle the deletion. (defun delete-functional (fun) - (assert (and (null (leaf-refs fun)) - (not (functional-entry-function fun)))) + (aver (and (null (leaf-refs fun)) + (not (functional-entry-function fun)))) (etypecase fun (optional-dispatch (delete-optional-dispatch fun)) (clambda (delete-lambda fun))) @@ -598,7 +584,7 @@ (declare (type clambda leaf)) (let ((kind (functional-kind leaf)) (bind (lambda-bind leaf))) - (assert (not (member kind '(:deleted :optional :top-level)))) + (aver (not (member kind '(:deleted :optional :top-level)))) (setf (functional-kind leaf) :deleted) (setf (lambda-bind leaf) nil) (dolist (let (lambda-lets leaf)) @@ -611,7 +597,7 @@ (let* ((bind-block (node-block bind)) (component (block-component bind-block)) (return (lambda-return leaf))) - (assert (null (leaf-refs leaf))) + (aver (null (leaf-refs leaf))) (unless (leaf-ever-used leaf) (let ((*compiler-error-context* bind)) (compiler-note "deleting unused function~:[.~;~:*~% ~S~]" @@ -656,12 +642,12 @@ (declare (type optional-dispatch leaf)) (let ((entry (functional-entry-function leaf))) (unless (and entry (leaf-refs entry)) - (assert (or (not entry) (eq (functional-kind entry) :deleted))) + (aver (or (not entry) (eq (functional-kind entry) :deleted))) (setf (functional-kind leaf) :deleted) (flet ((frob (fun) (unless (eq (functional-kind fun) :deleted) - (assert (eq (functional-kind fun) :optional)) + (aver (eq (functional-kind fun) :optional)) (setf (functional-kind fun) nil) (let ((refs (leaf-refs fun))) (cond ((null refs) @@ -697,7 +683,7 @@ (clambda (ecase (functional-kind leaf) ((nil :let :mv-let :assignment :escape :cleanup) - (assert (not (functional-entry-function leaf))) + (aver (not (functional-entry-function leaf))) (delete-lambda leaf)) (:external (delete-lambda leaf)) @@ -731,7 +717,7 @@ (declare (type continuation cont)) (unless (eq (continuation-kind cont) :deleted) - (assert (continuation-dest cont)) + (aver (continuation-dest cont)) (setf (continuation-dest cont) nil) (do-uses (use cont) (let ((prev (node-prev use))) @@ -767,7 +753,7 @@ ;;; people to ignore them, and to cause them to be deleted eventually. (defun delete-continuation (cont) (declare (type continuation cont)) - (assert (not (eq (continuation-kind cont) :deleted))) + (aver (not (eq (continuation-kind cont) :deleted))) (do-uses (use cont) (let ((prev (node-prev use))) @@ -798,16 +784,17 @@ (values)) -;;; This function does what is necessary to eliminate the code in it from -;;; the IR1 representation. This involves unlinking it from its predecessors -;;; and successors and deleting various node-specific semantic information. +;;; This function does what is necessary to eliminate the code in it +;;; from the IR1 representation. This involves unlinking it from its +;;; predecessors and successors and deleting various node-specific +;;; semantic information. ;;; -;;; We mark the Start as has having no next and remove the last node from -;;; its Cont's uses. We also flush the DEST for all continuations whose values -;;; are received by nodes in the block. +;;; We mark the START as has having no next and remove the last node +;;; from its CONT's uses. We also flush the DEST for all continuations +;;; whose values are received by nodes in the block. (defun delete-block (block) (declare (type cblock block)) - (assert (block-component block) () "Block is already deleted.") + (aver (block-component block)) ; else block is already deleted! (note-block-deletion block) (setf (block-delete-p block) t) @@ -848,8 +835,7 @@ (bind (let ((lambda (bind-lambda node))) (unless (eq (functional-kind lambda) :deleted) - (assert (member (functional-kind lambda) - '(:let :mv-let :assignment))) + (aver (member (functional-kind lambda) '(:let :mv-let :assignment))) (delete-lambda lambda)))) (exit (let ((value (exit-value node)) @@ -878,7 +864,7 @@ (defun delete-return (node) (declare (type creturn node)) (let ((fun (return-lambda node))) - (assert (lambda-return fun)) + (aver (lambda-return fun)) (setf (lambda-return fun) nil)) (values)) @@ -890,7 +876,7 @@ (unless (or (leaf-ever-used var) (lambda-var-ignorep var)) (let ((*compiler-error-context* (lambda-bind fun))) - (unless (policy *compiler-error-context* (= brevity 3)) + (unless (policy *compiler-error-context* (= inhibit-warnings 3)) ;; ANSI section "3.2.5 Exceptional Situations in the Compiler" ;; requires this to be a STYLE-WARNING. (compiler-style-warning "The variable ~S is defined but never used." @@ -990,7 +976,7 @@ (unless (eq (continuation-kind cont) :deleted) (delete-continuation-use node) (when (eq (continuation-kind cont) :unused) - (assert (not (continuation-dest cont))) + (aver (not (continuation-dest cont))) (delete-continuation cont))) (setf (block-type-asserted block) t) @@ -1008,11 +994,11 @@ (setf (node-prev node) nil) nil) (t - (assert (eq prev-kind :block-start)) - (assert (eq node last)) + (aver (eq prev-kind :block-start)) + (aver (eq node last)) (let* ((succ (block-succ block)) (next (first succ))) - (assert (and succ (null (cdr succ)))) + (aver (and succ (null (cdr succ)))) (cond ((member block succ) (with-ir1-environment node @@ -1025,8 +1011,8 @@ (setf (node-prev node) nil) nil) (t - (assert (eq (block-start-cleanup block) - (block-end-cleanup block))) + (aver (eq (block-start-cleanup block) + (block-end-cleanup block))) (unlink-blocks block next) (dolist (pred (block-pred block)) (change-block-successor pred block next)) @@ -1055,7 +1041,7 @@ ;;; deletion. (defun delete-component (component) (declare (type component component)) - (assert (null (component-new-functions component))) + (aver (null (component-new-functions component))) (setf (component-kind component) :deleted) (do-blocks (block component) (setf (block-delete-p block) t)) @@ -1088,7 +1074,7 @@ (type index num-args)) (let ((outside (continuation-dest cont)) (inside (continuation-use cont))) - (assert (combination-p outside)) + (aver (combination-p outside)) (unless (combination-p inside) (give-up-ir1-transform)) (let ((inside-fun (combination-fun inside))) @@ -1231,7 +1217,7 @@ ;;; Return the COMBINATION node that is the call to the let Fun. (defun let-combination (fun) (declare (type clambda fun)) - (assert (member (functional-kind fun) '(:let :mv-let))) + (aver (member (functional-kind fun) '(:let :mv-let))) (continuation-dest (node-cont (first (leaf-refs fun))))) ;;; Return the initial value continuation for a let variable or NIL if none. @@ -1245,7 +1231,7 @@ #!-sb-fluid (declaim (inline combination-lambda)) (defun combination-lambda (call) (declare (type basic-combination call)) - (assert (eq (basic-combination-kind call) :local)) + (aver (eq (basic-combination-kind call) :local)) (ref-leaf (continuation-use (basic-combination-fun call)))) (defvar *inline-expansion-limit* 200 @@ -1273,21 +1259,26 @@ (declaim (special *current-path*)) -;;; We bind print level and length when printing out messages so that we don't -;;; dump huge amounts of garbage. +;;; We bind print level and length when printing out messages so that +;;; we don't dump huge amounts of garbage. +;;; +;;; FIXME: It's not possible to get the defaults right for everyone. +;;; So: Should these variables be in the SB-EXT package? Or should we +;;; just get rid of them completely and just use the bare +;;; CL:*PRINT-FOO* variables instead? (declaim (type (or unsigned-byte null) *compiler-error-print-level* *compiler-error-print-length* *compiler-error-print-lines*)) -(defvar *compiler-error-print-level* 3 +(defvar *compiler-error-print-level* 5 #!+sb-doc - "The value for *PRINT-LEVEL* when printing compiler error messages.") -(defvar *compiler-error-print-length* 5 + "the value for *PRINT-LEVEL* when printing compiler error messages") +(defvar *compiler-error-print-length* 10 #!+sb-doc - "The value for *PRINT-LENGTH* when printing compiler error messages.") -(defvar *compiler-error-print-lines* 5 + "the value for *PRINT-LENGTH* when printing compiler error messages") +(defvar *compiler-error-print-lines* 12 #!+sb-doc - "The value for *PRINT-LINES* when printing compiler error messages.") + "the value for *PRINT-LINES* when printing compiler error messages") (defvar *enclosing-source-cutoff* 1 #!+sb-doc @@ -1296,18 +1287,20 @@ print only the CAR.") (declaim (type unsigned-byte *enclosing-source-cutoff*)) -;;; We separate the determination of compiler error contexts from the actual -;;; signalling of those errors by objectifying the error context. This allows -;;; postponement of the determination of how (and if) to signal the error. +;;; We separate the determination of compiler error contexts from the +;;; actual signalling of those errors by objectifying the error +;;; context. This allows postponement of the determination of how (and +;;; if) to signal the error. ;;; -;;; We take care not to reference any of the IR1 so that pending potential -;;; error messages won't prevent the IR1 from being GC'd. To this end, we -;;; convert source forms to strings so that source forms that contain IR1 -;;; references (e.g. %DEFUN) don't hold onto the IR. +;;; We take care not to reference any of the IR1 so that pending +;;; potential error messages won't prevent the IR1 from being GC'd. To +;;; this end, we convert source forms to strings so that source forms +;;; that contain IR1 references (e.g. %DEFUN) don't hold onto the IR. (defstruct (compiler-error-context #-no-ansi-print-object (:print-object (lambda (x stream) - (print-unreadable-object (x stream :type t))))) + (print-unreadable-object (x stream :type t)))) + (:copier nil)) ;; A list of the stringified CARs of the enclosing non-original source forms ;; exceeding the *enclosing-source-cutoff*. (enclosing-source nil :type list) @@ -1344,10 +1337,10 @@ ;;; no method is defined, then the first two subforms are returned. ;;; Note that this facility implicitly determines the string name ;;; associated with anonymous functions. -;;; So even though SBCL itself only uses this macro within this file, it's a -;;; reasonable thing to put in SB-EXT in case some dedicated user wants to do -;;; some heavy tweaking to make SBCL give more informative output about his -;;; code. +;;; So even though SBCL itself only uses this macro within this file, +;;; it's a reasonable thing to put in SB-EXT in case some dedicated +;;; user wants to do some heavy tweaking to make SBCL give more +;;; informative output about his code. (defmacro def-source-context (name lambda-list &body body) #!+sb-doc "DEF-SOURCE-CONTEXT Name Lambda-List Form* @@ -1384,17 +1377,19 @@ (t form))) -;;; Given a source path, return the original source form and a description -;;; of the interesting aspects of the context in which it appeared. The -;;; context is a list of lists, one sublist per context form. The sublist is a -;;; list of some of the initial subforms of the context form. +;;; Given a source path, return the original source form and a +;;; description of the interesting aspects of the context in which it +;;; appeared. The context is a list of lists, one sublist per context +;;; form. The sublist is a list of some of the initial subforms of the +;;; context form. ;;; -;;; For now, we use the first two subforms of each interesting form. A form is -;;; interesting if the first element is a symbol beginning with "DEF" and it is -;;; not the source form. If there is no DEF-mumble, then we use the outermost -;;; containing form. If the second subform is a list, then in some cases we -;;; return the car of that form rather than the whole form (i.e. don't show -;;; defstruct options, etc.) +;;; For now, we use the first two subforms of each interesting form. A +;;; form is interesting if the first element is a symbol beginning +;;; with "DEF" and it is not the source form. If there is no +;;; DEF-mumble, then we use the outermost containing form. If the +;;; second subform is a list, then in some cases we return the CAR of +;;; that form rather than the whole form (i.e. don't show DEFSTRUCT +;;; options, etc.) (defun find-original-source (path) (declare (list path)) (let* ((rpath (reverse (source-path-original-source path))) @@ -1405,7 +1400,7 @@ (current (rest rpath))) (loop (when (atom form) - (assert (null current)) + (aver (null current)) (return)) (let ((head (first form))) (when (symbolp head) @@ -1466,13 +1461,13 @@ (incf n))) (let* ((tlf (source-path-tlf-number path)) - (file (find-file-info tlf *source-info*))) + (file-info (source-info-file-info *source-info*))) (make-compiler-error-context :enclosing-source (short) :source (full) :original-source (stringify-form form) :context src-context - :file-name (file-info-name file) + :file-name (file-info-name file-info) :file-position (multiple-value-bind (ignore pos) (find-source-root tlf *source-info*) @@ -1513,10 +1508,10 @@ (setq *last-message-count* 0)) ;;; Print out the message, with appropriate context if we can find it. -;;; If If the context is different from the context of the last -;;; message we printed, then we print the context. If the original -;;; source is different from the source we are working on, then we -;;; print the current source in addition to the original source. +;;; If the context is different from the context of the last message +;;; we printed, then we print the context. If the original source is +;;; different from the source we are working on, then we print the +;;; current source in addition to the original source. ;;; ;;; We suppress printing of messages identical to the previous, but ;;; record the number of times that the message is repeated. @@ -1608,9 +1603,10 @@ (defun print-compiler-condition (condition) (declare (type condition condition)) - (let (;; These different classes of conditions have different effects - ;; on the return codes of COMPILE-FILE, so it's nice for users to be - ;; able to pick them out by lexical search through the output. + (let (;; These different classes of conditions have different + ;; effects on the return codes of COMPILE-FILE, so it's nice + ;; for users to be able to pick them out by lexical search + ;; through the output. (what (etypecase condition (style-warning 'style-warning) (warning 'warning) @@ -1630,15 +1626,16 @@ (values)) ;;; COMPILER-NOTE is vaguely like COMPILER-ERROR and the other -;;; condition-signalling functions, but it just writes some output instead of -;;; signalling. (In CMU CL, it did signal a condition, but this didn't seem to -;;; work all that well; it was weird to have COMPILE-FILE return with -;;; WARNINGS-P set when the only problem was that the compiler couldn't figure -;;; out how to compile something as efficiently as it liked.) +;;; condition-signalling functions, but it just writes some output +;;; instead of signalling. (In CMU CL, it did signal a condition, but +;;; this didn't seem to work all that well; it was weird to have +;;; COMPILE-FILE return with WARNINGS-P set when the only problem was +;;; that the compiler couldn't figure out how to compile something as +;;; efficiently as it liked.) (defun compiler-note (format-string &rest format-args) (unless (if *compiler-error-context* - (policy *compiler-error-context* (= brevity 3)) - (policy nil (= brevity 3))) + (policy *compiler-error-context* (= inhibit-warnings 3)) + (policy *lexenv* (= inhibit-warnings 3))) (incf *compiler-note-count*) (print-compiler-message (format nil "note: ~A" format-string) format-args)) @@ -1668,13 +1665,13 @@ (force-output *error-output*) (values)) -;;; Return a string that somehow names the code in Component. We use +;;; Return a string that somehow names the code in COMPONENT. We use ;;; the source path for the bind node for an arbitrary entry point to ;;; find the source context, then return that as a string. (declaim (ftype (function (component) simple-string) find-component-name)) (defun find-component-name (component) (let ((ep (first (block-succ (component-head component))))) - (assert ep () "no entry points?") + (aver ep) ; else no entry points?? (multiple-value-bind (form context) (find-original-source (node-source-path (continuation-next (block-start ep)))) @@ -1697,8 +1694,8 @@ (defvar *warnings-p*) ;;; condition handlers established by the compiler. We re-signal the -;;; condition, if it is not handled, we increment our warning counter -;;; and print the error message. +;;; condition, then if it isn't handled, we increment our warning +;;; counter and print the error message. (defun compiler-error-handler (condition) (signal condition) (incf *compiler-error-count*) @@ -1730,7 +1727,7 @@ problem is a missing definition (as opposed to a typo in the use.)") ;;; Make an entry in the *UNDEFINED-WARNINGS* describing a reference -;;; to Name of the specified Kind. If we have exceeded the warning +;;; to NAME of the specified KIND. If we have exceeded the warning ;;; limit, then just increment the count, otherwise note the current ;;; error context. ;;; @@ -1738,14 +1735,17 @@ ;;; WITH-COMPILATION-UNIT, which can potentially be invoked outside ;;; the compiler, hence the BOUNDP check. (defun note-undefined-reference (name kind) - (unless (and (boundp '*lexenv*) - ;; FIXME: I'm pretty sure the BREVITY test below isn't - ;; a good idea; we should have BREVITY affect compiler - ;; notes, not STYLE-WARNINGs. And I'm not sure what the - ;; BOUNDP '*LEXENV* test above is for; it's likely - ;; a good idea, but it probably deserves an explanatory - ;; comment. - (policy nil (= brevity 3))) + (unless (and + ;; Check for boundness so we don't blow up if we're called + ;; when IR1 conversion isn't going on. + (boundp '*lexenv*) + ;; FIXME: I'm pretty sure the INHIBIT-WARNINGS test below + ;; isn't a good idea; we should have INHIBIT-WARNINGS + ;; affect compiler notes, not STYLE-WARNINGs. And I'm not + ;; sure what the BOUNDP '*LEXENV* test above is for; it's + ;; likely a good idea, but it probably deserves an + ;; explanatory comment. + (policy *lexenv* (= inhibit-warnings 3))) (let* ((found (dolist (warning *undefined-warnings* nil) (when (and (equal (undefined-warning-name warning) name) (eq (undefined-warning-kind warning) kind)) @@ -1781,11 +1781,11 @@ (return-from careful-call (values nil nil)))))) t)) -;;;; utilities used at run-time for parsing keyword args in IR1 +;;;; utilities used at run-time for parsing &KEY args in IR1 -;;; This function is used by the result of Parse-Deftransform to find -;;; the continuation for the value of the keyword argument Key in the -;;; list of continuations Args. It returns the continuation if the +;;; This function is used by the result of PARSE-DEFTRANSFORM to find +;;; the continuation for the value of the &KEY argument KEY in the +;;; list of continuations ARGS. It returns the continuation if the ;;; keyword is present, or NIL otherwise. The legality and ;;; constantness of the keywords should already have been checked. (declaim (ftype (function (list keyword) (or continuation null)) @@ -1796,24 +1796,24 @@ (when (eq (continuation-value (first arg)) key) (return (second arg))))) -;;; This function is used by the result of Parse-Deftransform to -;;; verify that alternating continuations in Args are constant and +;;; This function is used by the result of PARSE-DEFTRANSFORM to +;;; verify that alternating continuations in ARGS are constant and ;;; that there is an even number of args. -(declaim (ftype (function (list) boolean) check-keywords-constant)) -(defun check-keywords-constant (args) +(declaim (ftype (function (list) boolean) check-key-args-constant)) +(defun check-key-args-constant (args) (do ((arg args (cddr arg))) ((null arg) t) (unless (and (rest arg) (constant-continuation-p (first arg))) (return nil)))) -;;; This function is used by the result of Parse-Deftransform to -;;; verify that the list of continuations Args is a well-formed -;;; keyword arglist and that only keywords present in the list Keys -;;; are supplied. +;;; This function is used by the result of PARSE-DEFTRANSFORM to +;;; verify that the list of continuations ARGS is a well-formed &KEY +;;; arglist and that only keywords present in the list KEYS are +;;; supplied. (declaim (ftype (function (list list) boolean) check-transform-keys)) (defun check-transform-keys (args keys) - (and (check-keywords-constant args) + (and (check-key-args-constant args) (do ((arg args (cddr arg))) ((null arg) t) (unless (member (continuation-value (first arg)) keys) @@ -1826,9 +1826,8 @@ (defun %event (info node) (incf (event-info-count info)) (when (and (>= (event-info-level info) *event-note-threshold*) - (if node - (policy node (= brevity 0)) - (policy nil (= brevity 0)))) + (policy (or node *lexenv*) + (= inhibit-warnings 0))) (let ((*compiler-error-context* node)) (compiler-note (event-info-description info))))