;;;; files for more information.
(in-package "SB!C")
-
-(file-comment
- "$Header$")
\f
;;;; cleanup hackery
;;; 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))
;;; 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))
(setf (continuation-dest new) dest))
(values))
-;;; Replace all uses of Old with uses of New, where New has an arbitary
-;;; number of uses. If New will end up with more than one use, then we must
-;;; arrange for it to start a block if it doesn't already.
+;;; Replace all uses of OLD with uses of NEW, where NEW has an
+;;; arbitary number of uses. If NEW will end up with more than one
+;;; use, then we must arrange for it to start a block if it doesn't
+;;; already.
(defun substitute-continuation-uses (new old)
(declare (type continuation old new))
(unless (and (eq (continuation-kind new) :unused)
(do-uses (node old)
(delete-continuation-use node)
(add-continuation-use node new))
+ (dolist (lexenv-use (continuation-lexenv-uses old))
+ (setf (cadr lexenv-use) new))
(reoptimize-continuation new)
(values))
\f
;;;; block starting/creation
-;;; Return the block that Continuation is the start of, making a block if
-;;; necessary. This function is called by IR1 translators which may cause a
-;;; continuation to be used more than once. Every continuation which may be
-;;; used more than once must start a block by the time that anyone does a
-;;; Use-Continuation on it.
+;;; Return the block that CONT is the start of, making a block if
+;;; necessary. This function is called by IR1 translators which may
+;;; cause a continuation to be used more than once. Every continuation
+;;; which may be used more than once must start a block by the time
+;;; that anyone does a USE-CONTINUATION on it.
;;;
;;; We also throw the block into the next/prev list for the
-;;; *current-component* so that we keep track of which blocks we have made.
+;;; *CURRENT-COMPONENT* so that we keep track of which blocks we have
+;;; made.
(defun continuation-starts-block (cont)
(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)))
#!-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)))
-;;; Return a list of all the enclosing forms not in the original source that
-;;; converted to get to this form, with the immediate source for node at the
-;;; start of the list.
+;;; Return a list of all the enclosing forms not in the original
+;;; source that converted to get to this form, with the immediate
+;;; source for node at the start of the list.
(defun source-path-forms (path)
(subseq path 0 (position 'original-source-start path)))
(first forms)
(values (find-original-source path)))))
-;;; Return NODE-SOURCE-FORM, T if continuation has a single use, otherwise
-;;; NIL, NIL.
+;;; Return NODE-SOURCE-FORM, T if continuation has a single use,
+;;; otherwise NIL, NIL.
(defun continuation-source (cont)
(let ((use (continuation-use cont)))
(if use
(values (node-source-form use) t)
(values nil nil))))
\f
-;;; Return a new LEXENV just like Default except for the specified slot
-;;; values. Values for the alist slots are NCONC'ed to the beginning of the
-;;; current value, rather than replacing it entirely.
+;;; Return a new LEXENV just like DEFAULT except for the specified
+;;; slot values. Values for the alist slots are NCONCed to the
+;;; beginning of the current value, rather than replacing it entirely.
(defun make-lexenv (&key (default *lexenv*)
functions variables blocks tags type-restrictions
options
(lambda (lexenv-lambda default))
(cleanup (lexenv-cleanup default))
- (cookie (lexenv-cookie default))
- (interface-cookie (lexenv-interface-cookie default)))
+ (policy (lexenv-policy default)))
(macrolet ((frob (var slot)
`(let ((old (,slot default)))
(if ,var
(frob blocks lexenv-blocks)
(frob tags lexenv-tags)
(frob type-restrictions lexenv-type-restrictions)
- lambda cleanup cookie interface-cookie
+ lambda cleanup policy
(frob options lexenv-options))))
-
-;;; Return a cookie that defaults any unsupplied optimize qualities in the
-;;; Interface-Cookie with the corresponding ones from the Cookie.
-(defun make-interface-cookie (lexenv)
- (declare (type lexenv lexenv))
- (let ((icookie (lexenv-interface-cookie lexenv))
- (cookie (lexenv-cookie lexenv)))
- (make-cookie
- :speed (or (cookie-speed icookie) (cookie-speed cookie))
- :space (or (cookie-space icookie) (cookie-space cookie))
- :safety (or (cookie-safety icookie) (cookie-safety cookie))
- :cspeed (or (cookie-cspeed icookie) (cookie-cspeed cookie))
- :brevity (or (cookie-brevity icookie) (cookie-brevity cookie))
- :debug (or (cookie-debug icookie) (cookie-debug cookie)))))
\f
;;;; flow/DFO/component hackery
-;;; Join Block1 and Block2.
+;;; Join BLOCK1 and BLOCK2.
#!-sb-fluid (declaim (inline link-blocks))
(defun link-blocks (block1 block2)
(declare (type cblock block1 block2))
(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
(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)
(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)
(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
;;; 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)))
(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))
(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~]"
(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)
(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))
(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)))
;;; 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)))
(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)
(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))
(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))
(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."
(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)
(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
(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))
;;; 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))
(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)))
;;; 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.
#!-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
(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
(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)
(current (rest rpath)))
(loop
(when (atom form)
- (assert (null current))
+ (aver (null current))
(return))
(let ((head (first form)))
(when (symbolp head)
(values '(unable to locate source)
'((some strange place)))))))))
-;;; Convert a source form to a string, formatted suitably for use in
+;;; Convert a source form to a string, suitably formatted for use in
;;; compiler warnings.
(defun stringify-form (form &optional (pretty t))
(let ((*print-level* *compiler-error-print-level*)
(*print-lines* *compiler-error-print-lines*)
(*print-pretty* pretty))
(if pretty
- (format nil " ~S~%" form)
+ (format nil "~<~@; ~S~:>" (list form))
(prin1-to-string form))))
-;;; Return a COMPILER-ERROR-CONTEXT structure describing the current error
-;;; context, or NIL if we can't figure anything out. ARGS is a list of things
-;;; that are going to be printed out in the error message, and can thus be
-;;; blown off when they appear in the source context.
+;;; Return a COMPILER-ERROR-CONTEXT structure describing the current
+;;; error context, or NIL if we can't figure anything out. ARGS is a
+;;; list of things that are going to be printed out in the error
+;;; message, and can thus be blown off when they appear in the source
+;;; context.
(defun find-error-context (args)
(let ((context *compiler-error-context*))
(if (compiler-error-context-p context)
\f
;;;; printing error messages
-;;; We save the context information that we printed out most recently so that
-;;; we don't print it out redundantly.
+;;; We save the context information that we printed out most recently
+;;; so that we don't print it out redundantly.
;;; The last COMPILER-ERROR-CONTEXT that we printed.
(defvar *last-error-context* nil)
(declaim (type (or string null) *last-format-string*))
(declaim (type list *last-format-args*))
-;;; The number of times that the last error message has been emitted, so that
-;;; we can compress duplicate error messages.
+;;; The number of times that the last error message has been emitted,
+;;; so that we can compress duplicate error messages.
(defvar *last-message-count* 0)
(declaim (type index *last-message-count*))
(cond ((= *last-message-count* 1)
(when terpri (terpri *error-output*)))
((> *last-message-count* 1)
- (format *error-output* "[Last message occurs ~D times.]~2%"
+ (format *error-output* "~&; [Last message occurs ~D times.]~2%"
*last-message-count*)))
(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.
+;;; Print out the message, with appropriate context if we can find it.
+;;; 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.
+;;; We suppress printing of messages identical to the previous, but
+;;; record the number of times that the message is repeated.
(defun print-compiler-message (format-string format-args)
(declare (type simple-string format-string))
(when (pathnamep file)
(note-message-repeats)
(setq last nil)
- (format stream "~2&file: ~A~%" (namestring file))))
+ (format stream "~2&; file: ~A~%" (namestring file))))
(unless (and last
(equal in (compiler-error-context-context last)))
(note-message-repeats)
(setq last nil)
- (format stream "~2&in:~{~<~% ~4:;~{ ~S~}~>~^ =>~}~%" in))
+ (format stream "~&")
+ (pprint-logical-block (stream nil :per-line-prefix "; ")
+ (format stream "in:~{~<~% ~4:;~{ ~S~}~>~^ =>~}" in))
+ (format stream "~%"))
+
(unless (and last
(string= form
(compiler-error-context-original-source last)))
(note-message-repeats)
(setq last nil)
- (write-string form stream))
+ (format stream "~&")
+ (pprint-logical-block (stream nil :per-line-prefix "; ")
+ (format stream " ~A" form))
+ (format stream "~&"))
(unless (and last
(equal enclosing
(when enclosing
(note-message-repeats)
(setq last nil)
- (format stream "--> ~{~<~%--> ~1:;~A~> ~}~%" enclosing)))
+ (format stream "~&; --> ~{~<~%; --> ~1:;~A~> ~}~%" enclosing)))
(unless (and last
(equal source (compiler-error-context-source last)))
(when source
(note-message-repeats)
(dolist (src source)
- (write-line "==>" stream)
- (write-string src stream))))))
+ (format stream "~&")
+ (write-string "; ==>" stream)
+ (format stream "~&")
+ (pprint-logical-block (stream nil :per-line-prefix "; ")
+ (write-string src stream)))))))
(t
+ (format stream "~&")
(note-message-repeats)
(setq *last-format-string* nil)
- (format stream "~2&")))
+ (format stream "~&")))
(setq *last-error-context* context)
(let ((*print-level* *compiler-error-print-level*)
(*print-length* *compiler-error-print-length*)
(*print-lines* *compiler-error-print-lines*))
- (format stream "~&~?~&" format-string format-args))))
+ (format stream "~&")
+ (pprint-logical-block (stream nil :per-line-prefix "; ")
+ (format stream "~&~?" format-string format-args))
+ (format stream "~&"))))
(incf *last-message-count*)
(values))
(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)
;;; 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 nil (= inhibit-warnings 3)))
(incf *compiler-note-count*)
(print-compiler-message (format nil "note: ~A" format-string)
format-args))
(values))
+;;; Issue a note when we might or might not be in the compiler.
+(defun maybe-compiler-note (&rest rest)
+ (if (boundp '*lexenv*) ; if we're in the compiler
+ (apply #'compiler-note rest)
+ (let ((stream *error-output*))
+ (pprint-logical-block (stream nil :per-line-prefix ";")
+
+ (format stream " note: ~3I~_")
+ (pprint-logical-block (stream nil)
+ (apply #'format stream rest)))
+ (fresh-line stream)))) ; (outside logical block, no per-line-prefix)
+
;;; The politically correct way to print out progress messages and
;;; such like. We clear the current error context so that we know that
;;; it needs to be reprinted, and we also Force-Output so that the
(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))))
(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*)
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.
;;;
;;; 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
+ ;; (POLICY NIL ..) isn't well-defined except in IR1
+ ;; conversion. This BOUNDP test seems to be a test for
+ ;; whether IR1 conversion is 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 nil (= inhibit-warnings 3)))
(let* ((found (dolist (warning *undefined-warnings* nil)
(when (and (equal (undefined-warning-name warning) name)
(eq (undefined-warning-kind warning) kind))
(return-from careful-call (values nil nil))))))
t))
\f
-;;;; 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))
(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)
(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 node (= inhibit-warnings 0))
+ (policy nil (= inhibit-warnings 0))))
(let ((*compiler-error-context* node))
(compiler-note (event-info-description info))))
projects / sbcl.git / blobdiff