Newer
Older
(do-nodes (node cont block)
(let* ((path (node-source-path node))
(first (first path)))
(when (or (eq first 'original-source-start)
(and (atom first)
(or (not (symbolp first))
(let ((pkg (symbol-package first)))
(and pkg
(not (eq pkg (symbol-package :end))))))
(not (member first *deletion-ignored-objects*))
(not (typep first '(or fixnum character)))
(every #'(lambda (x)
(present-in-form first x 0))
(source-path-forms path))
(present-in-form first (find-original-source path)
0)))
(unless (return-p node)
(let ((*compiler-error-context* node))
(compiler-note "Deleting unreachable code.")))
(return))))))
(undefined-value))
;;; Delete-Block -- Interface
;;;
;;; 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.
;;;
(defun delete-block (block)
(declare (type cblock block))
(assert (block-component block) () "Block is already deleted.")
(note-block-deletion block)
(setf (block-delete-p block) t)
(let* ((last (block-last block))
(cont (node-cont last)))
(delete-continuation-use last)
(if (eq (continuation-kind cont) :unused)
(delete-continuation cont)
(reoptimize-continuation cont)))
(dolist (b (block-pred block))
(unlink-blocks b block))
(dolist (b (block-succ block))
(unlink-blocks block b))
(do-nodes (node cont block)
(typecase node
(ref (delete-ref node))
(cif
(flush-dest (if-test node)))
;;
;; The next two cases serve to maintain the invariant that a LET always
;; has a well-formed COMBINATION, REF and BIND. We delete the lambda
;; whenever we delete any of these, but we must be careful that this LET
;; has not already been partially deleted.
(when (and (eq (basic-combination-kind node) :local)
;; Guards COMBINATION-LAMBDA agains the REF being deleted.
(continuation-use (basic-combination-fun node)))
(let ((fun (combination-lambda node)))
;; If our REF was the 2'nd to last ref, and has been deleted, then
;; Fun may be a LET for some other combination.
(when (and (member (functional-kind fun) '(:let :mv-let))
(eq (let-combination fun) node))
(delete-lambda fun))))
(flush-dest (basic-combination-fun node))
(dolist (arg (basic-combination-args node))
(when arg (flush-dest arg))))
(bind
(let ((lambda (bind-lambda node)))
(unless (eq (functional-kind lambda) :deleted)
(assert (member (functional-kind lambda)
'(:let :mv-let :assignment)))
(delete-lambda lambda))))
(let ((value (exit-value node))
(entry (exit-entry node)))
(flush-dest value))
(when entry
(setf (entry-exits entry)
(delete node (entry-exits entry))))))
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
(creturn
(flush-dest (return-result node))
(delete-return node))
(cset
(flush-dest (set-value node))
(let ((var (set-var node)))
(setf (basic-var-sets var)
(delete node (basic-var-sets var))))))
(delete-continuation (node-prev node)))
(remove-from-dfo block)
(undefined-value))
;;; Unlink-Node -- Interface
;;;
;;; Delete a node from a block, deleting the block if there are no nodes
;;; left. We remove the node from the uses of its CONT, but we don't deal with
;;; cleaning up any type-specific semantic attachments. If the CONT is :UNUSED
;;; after deleting this use, then we delete CONT. (Note :UNUSED is not the
;;; same as no uses. A continuation will only become :UNUSED if it was
;;; :INSIDE-BLOCK before.)
;;;
;;; If the node is the last node, there must be exactly one successor. We
;;; link all of our precedessors to the successor and unlink the block. In
;;; this case, we return T, otherwise NIL. If no nodes are left, and the block
;;; is a successor of itself, then we replace the only node with a degenerate
;;; exit node. This provides a way to represent the bodyless infinite loop,
;;; given the prohibition on empty blocks in IR1.
;;;
(defun unlink-node (node)
(declare (type node node))
(let* ((cont (node-cont node))
(next (continuation-next cont))
(prev (node-prev node))
(block (continuation-block prev))
(prev-kind (continuation-kind prev))
(last (block-last block)))
(unless (eq (continuation-kind cont) :deleted)
(delete-continuation-use node)
(when (eq (continuation-kind cont) :unused)
(assert (not (continuation-dest cont)))
(delete-continuation cont)))
(setf (block-type-asserted block) t)
(setf (block-test-modified block) t)
(cond ((or (eq prev-kind :inside-block)
(and (eq prev-kind :block-start)
(not (eq node last))))
(cond ((eq node last)
(setf (block-last block) (continuation-use prev))
(setf (continuation-next prev) nil))
(t
(setf (continuation-next prev) next)
(setf (node-prev next) prev)))
(setf (node-prev node) nil)
nil)
(t
(assert (eq prev-kind :block-start))
(assert (eq node last))
(let* ((succ (block-succ block))
(next (first succ)))
(assert (and succ (null (cdr succ))))
(cond
((member block succ)
(with-ir1-environment node
(let ((exit (make-exit))
(dummy (make-continuation)))
(setf (continuation-next prev) nil)
(prev-link exit prev)
(add-continuation-use exit dummy)
(setf (block-last block) exit)))
(setf (node-prev node) nil)
nil)
(t
(assert (eq (block-start-cleanup block)
(block-end-cleanup block)))
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
(unlink-blocks block next)
(dolist (pred (block-pred block))
(change-block-successor pred block next))
(remove-from-dfo block)
(cond ((continuation-dest prev)
(setf (continuation-next prev) nil)
(setf (continuation-kind prev) :deleted-block-start))
(t
(delete-continuation prev)))
(setf (node-prev node) nil)
t)))))))
;;; NODE-DELETED -- Interface
;;;
;;; Return true if NODE has been deleted, false if it is still a valid part
;;; of IR1.
;;;
(defun node-deleted (node)
(declare (type node node))
(let ((prev (node-prev node)))
(not (and prev
(not (eq (continuation-kind prev) :deleted))
(let ((block (continuation-block prev)))
(and (block-component block)
(not (block-delete-p block))))))))
;;; DELETE-COMPONENT -- Interface
;;;
;;; Delete all the blocks and functions in Component. We scan first marking
;;; the blocks as delete-p to prevent weird stuff from being triggered by
;;; deletion.
;;;
(defun delete-component (component)
(declare (type component component))
(assert (null (component-new-functions component)))
(setf (component-kind component) :deleted)
(do-blocks (block component)
(setf (block-delete-p block) t))
(dolist (fun (component-lambdas component))
(setf (functional-kind fun) nil)
(setf (leaf-refs fun) nil)
(delete-lambda fun))
(do-blocks (block component)
(delete-block block))
(undefined-value))
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
;;; EXTRACT-FUNCTION-ARGS -- interface
;;;
;;; Convert code of the form (foo ... (fun ...) ...) to (foo ... ... ...).
;;; In other words, replace the function combination fun by it's arguments.
;;; If there are any problems with doing this, use GIVE-UP to blow out of
;;; whatever transform called this. Note, as the number of arguments changes,
;;; the transform must be prepared to return a lambda with a new lambda-list
;;; with the correct number of arguments.
;;;
(defun extract-function-args (cont fun num-args)
"If CONT is a call to FUN with NUM-ARGS args, change those arguments
to feed directly to the continuation-dest of CONT, which must be
a combination."
(declare (type continuation cont)
(type symbol fun)
(type index num-args))
(let ((outside (continuation-dest cont))
(inside (continuation-use cont)))
(assert (combination-p outside))
(unless (combination-p inside)
(give-up))
(let ((inside-fun (combination-fun inside)))
(unless (eq (continuation-function-name inside-fun) fun)
(give-up))
(let ((inside-args (combination-args inside)))
(unless (= (length inside-args) num-args)
(give-up))
(let* ((outside-args (combination-args outside))
(arg-position (position cont outside-args))
(before-args (subseq outside-args 0 arg-position))
(after-args (subseq outside-args (1+ arg-position))))
(dolist (arg inside-args)
(setf (continuation-dest arg) outside))
(setf (combination-args inside) nil)
(setf (combination-args outside)
(append before-args inside-args after-args))
(change-ref-leaf (continuation-use inside-fun)
(find-free-function 'list "???"))
(setf (combination-kind inside) :full)
(setf (node-derived-type inside) *wild-type*)
(flush-dest cont)
(setf (continuation-asserted-type cont) *wild-type*)
(undefined-value))))))
;;;; Leaf hackery:
;;; Change-Ref-Leaf -- Interface
;;;
;;; Change the Leaf that a Ref refers to.
;;;
(defun change-ref-leaf (ref leaf)
(declare (type ref ref) (type leaf leaf))
(unless (eq (ref-leaf ref) leaf)
(push ref (leaf-refs leaf))
(delete-ref ref)
(setf (ref-leaf ref) leaf)
(let ((ltype (leaf-type leaf)))
(if (function-type-p ltype)
(setf (node-derived-type ref) ltype)
(derive-node-type ref ltype)))
(reoptimize-continuation (node-cont ref)))
(undefined-value))
;;; Substitute-Leaf -- Interface
;;;
;;; Change all Refs for Old-Leaf to New-Leaf.
;;;
(defun substitute-leaf (new-leaf old-leaf)
(declare (type leaf new-leaf old-leaf))
(dolist (ref (leaf-refs old-leaf))
(change-ref-leaf ref new-leaf))
(undefined-value))
;;; SUBSTITUTE-LEAF-IF -- Interface
;;;
;;; Like SUBSITIUTE-LEAF, only there is a predicate on the Ref to tell
;;; whether to substitute.
;;;
(defun substitute-leaf-if (test new-leaf old-leaf)
(declare (type leaf new-leaf old-leaf) (type function test))
(dolist (ref (leaf-refs old-leaf))
(when (funcall test ref)
(change-ref-leaf ref new-leaf)))
(undefined-value))
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
;;; Find-Constant -- Interface
;;;
;;; Return a Leaf which represents the specified constant object. If the
;;; object is not in *constants*, then we create a new constant Leaf and
;;; enter it.
;;;
(defun find-constant (object)
(or (gethash object *constants*)
(setf (gethash object *constants*)
(make-constant :value object :name nil
:type (ctype-of object)
:where-from :defined))))
;;;; Find-NLX-Info -- Interface
;;;
;;; If there is a non-local exit noted in Entry's environment that exits to
;;; Cont in that entry, then return it, otherwise return NIL.
;;;
(defun find-nlx-info (entry cont)
(declare (type entry entry) (type continuation cont))
(let ((entry-cleanup (entry-cleanup entry)))
(dolist (nlx (environment-nlx-info (node-environment entry)) nil)
(eq (nlx-info-cleanup nlx) entry-cleanup))
(return nlx)))))
;;;; Functional hackery:
;;; Main-Entry -- Interface
;;;
;;; If Functional is a Lambda, just return it; if it is an
;;; optional-dispatch, return the main-entry.
;;;
(proclaim '(function main-entry (functional) clambda))
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
(defun main-entry (functional)
(if (lambda-p functional)
functional
(optional-dispatch-main-entry functional)))
;;; Looks-Like-An-MV-Bind -- Interface
;;;
;;; Returns true if Functional is a thing that can be treated like MV-Bind
;;; when it appears in an MV-Call. All fixed arguments must be optional with
;;; null default and no supplied-p. There must be a rest arg with no
;;; references.
;;;
(proclaim '(function looks-like-an-mv-bind (functional) boolean))
(defun looks-like-an-mv-bind (functional)
(and (optional-dispatch-p functional)
(do ((arg (optional-dispatch-arglist functional) (cdr arg)))
((null arg) nil)
(let ((info (lambda-var-arg-info (car arg))))
(unless info (return nil))
(case (arg-info-kind info)
(:optional
(when (or (arg-info-supplied-p info) (arg-info-default info))
(return nil)))
(:rest
(return (and (null (cdr arg)) (null (leaf-refs (car arg))))))
(t
(return nil)))))))
;;; External-Entry-Point-P -- Interface
;;;
;;; Return true if function is an XEP. This is true of normal XEPs
;;; (:External kind) and top-level lambdas (:Top-Level kind.)
;;;
(defun external-entry-point-p (fun)
(declare (type functional fun))
(not (null (member (functional-kind fun) '(:external :top-level)))))
;;; Continuation-Function-Name -- Interface
;;;
;;; If Cont's only use is a non-notinline global function reference, then
;;; return the referenced symbol, otherwise NIL. If Notinline-OK is true, then
;;; we don't care if the ref is notinline.
(defun continuation-function-name (cont &optional notinline-ok)
(declare (type continuation cont))
(let ((use (continuation-use cont)))
(if (and (ref-p use)
(or (not (eq (ref-inlinep use) :notinline))
notinline-ok))
(let ((leaf (ref-leaf use)))
(if (and (global-var-p leaf)
(eq (global-var-kind leaf) :global-function))
(leaf-name leaf)
nil))
nil)))
;;; LET-COMBINATION -- Interface
;;;
;;; 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)))
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
(continuation-dest (node-cont (first (leaf-refs fun)))))
;;; LET-VAR-INITIAL-VALUE -- Interface
;;;
;;; Return the initial value continuation for a let variable or NIL if none.
;;;
(defun let-var-initial-value (var)
(declare (type lambda-var var))
(let ((fun (lambda-var-home var)))
(elt (combination-args (let-combination fun))
(position var (lambda-vars fun)))))
;;; COMBINATION-LAMBDA -- Interface
;;;
;;; Return the LAMBDA that is called by the local Call.
;;;
(defun combination-lambda (call)
(declare (type basic-combination call))
(assert (eq (basic-combination-kind call) :local))
(ref-leaf (continuation-use (basic-combination-fun call))))
;;;; Compiler error context determination:
(proclaim '(special *current-path*))
;;; We bind print level and length when printing out messages so that we don't
;;; dump huge amounts of garbage.
;;;
(proclaim '(type (or unsigned-byte null) *error-print-level*
*error-print-length* *error-print-lines*))
(defvar *error-print-level* 3
"The value for *Print-Level* when printing compiler error messages.")
(defvar *error-print-length* 5
"The value for *Print-Length* when printing compiler error messages.")
(defvar *error-print-lines* 5
"The value for *Print-Lines* when printing compiler error messages.")
(defvar *enclosing-source-cutoff* 1
"The maximum number of enclosing non-original source forms (i.e. from
macroexpansion) that we print in full. For additional enclosing forms, we
print only the CAR.")
(proclaim '(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 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
(:print-function
(lambda (s stream d)
(declare (ignore s d))
(format stream "#<Compiler-Error-Context>"))))
;;
;; A list of the stringified CARs of the enclosing non-original source forms
;; exceeding the *enclosing-source-cutoff*.
(enclosing-source nil :type list)
;; A list of stringified enclosing non-original source forms.
(source nil :type list)
;; The stringified form in the original source that expanded into Source.
(original-source (required-argument) :type simple-string)
;; A list of prefixes of "interesting" forms that enclose original-source.
(context nil :type list)
;;
;; The FILE-INFO-NAME for the relevant FILE-INFO.
(file-name (required-argument)
:type (or simple-string (member :lisp :stream)))
;;
;; The file position at which the top-level form starts, if applicable.
(file-position nil :type (or index null))
;;
;; The original source part of the source path.
(original-source-path nil :type list))
;;; If true, this is the node which is used as context in compiler warning
;;; messages.
;;;
(proclaim '(type (or null compiler-error-context node)
*compiler-error-context*))
(defvar *compiler-error-context* nil)
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
;;; Hashtable mapping macro names to source context parsers. Each parser
;;; function returns the source-context list for that form.
;;;
(defvar *source-context-methods* (make-hash-table))
;;; DEF-SOURCE-CONTEXT -- Public
;;;
(defmacro def-source-context (name ll &body body)
"DEF-SOURCE-CONTEXT Name Lambda-List Form*
This macro defines how to extract an abbreviated source context from the
Named form when it appears in the compiler input. Lambda-List is a DEFMACRO
style lambda-list used to parse the arguments. The Body should return a
list of subforms suitable for a \"~{~S ~}\" format string."
(let ((n-whole (gensym)))
`(setf (gethash ',name *source-context-methods*)
#'(lambda (,n-whole)
(destructuring-bind ,ll ,n-whole ,@body)))))
(def-source-context defstruct (name-or-options &rest slots)
(declare (ignore slots))
`(defstruct ,(if (consp name-or-options)
(car name-or-options)
name-or-options)))
(def-source-context function (thing)
(if (and (consp thing) (eq (first thing) 'lambda) (consp (rest thing)))
`(lambda ,(second thing))
`(function ,thing)))
#+pcl
(def-source-context pcl::defmethod (name &rest stuff)
(let ((arg-pos (position-if #'listp stuff)))
(if arg-pos
`(pcl::defmethod ,name ,@(subseq stuff 0 arg-pos)
,@(nth-value 2 (pcl::parse-specialized-lambda-list
(elt stuff arg-pos))))
;;; SOURCE-FORM-CONTEXT -- Internal
;;;
;;; Return the first two elements of Form if Form is a list. Take the car
;;; of the second form if appropriate.
;;;
(defun source-form-context (form)
(cond ((atom form) nil)
((>= (length form) 2)
(funcall (gethash (first form) *source-context-methods*
#'(lambda (x)
(declare (ignore x))
(list (first form) (second form))))
(rest form)))
;;; Find-Original-Source -- Internal
;;;
;;; 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.)
;;;
(defun find-original-source (path)
(declare (list path))
(let* ((rpath (reverse (source-path-original-source path)))
(tlf (first rpath))
(root (find-source-root tlf *source-info*)))
(collect ((context))
(let ((form root)
(current (rest rpath)))
(loop
(when (atom form)
(assert (null current))
(return))
(let ((head (first form)))
(when (symbolp head)
(let ((name (symbol-name head)))
(when (and (>= (length name) 3) (string= name "DEF" :end1 3))
(context (source-form-context form))))))
(when (null current) (return))
(setq form (nth (pop current) form)))
(cond ((context)
(values form (context)))
((and path root)
(let ((c (source-form-context root)))
(values form (if c (list c) nil))))
(t
(values '(unable to locate source)
'((some strange place)))))))))
;;; STRINGIFY-FORM -- Internal
;;;
;;; Convert a source form to a string, formatted suitably for use in
;;; compiler warnings.
;;;
(defun stringify-form (form &optional (pretty t))
(let ((*print-level* (or *error-print-level* *print-level*))
(*print-length* (or *error-print-length* *print-length*))
(*print-lines* (or *error-print-lines* *print-lines*))
(*print-pretty* pretty))
(if pretty
(format nil " ~S~%" form)
(prin1-to-string form))))
;;; FIND-ERROR-CONTEXT -- Interface
;;;
;;; 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)
context
(let ((path (or *current-path*
(if context
(node-source-path context)
nil))))
(when (and *source-info* path)
(multiple-value-bind (form src-context)
(find-original-source path)
(collect ((full nil cons)
(short nil cons))
(let ((forms (source-path-forms path))
(n 0))
(dolist (src (if (member (first forms) args)
(rest forms)
forms))
(if (>= n *enclosing-source-cutoff*)
(short (stringify-form (if (consp src)
(car src)
src)
nil))
(full (stringify-form src)))
(incf n)))
(let* ((tlf (source-path-tlf-number path))
(file (find-file-info tlf *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-position
(multiple-value-bind (ignore pos)
(find-source-root tlf *source-info*)
(declare (ignore ignore))
pos)
:original-source-path
(source-path-original-source path))))))))))
;;;; Printing error messages:
;;; A function that is called to unwind out of Compiler-Error.
;;;
(proclaim '(type (function () nil) *compiler-error-bailout*))
(defvar *compiler-error-bailout*
#'(lambda () (error "Compiler-Error with no bailout.")))
;;; The stream that compiler error output is directed to.
;;;
(defvar *compiler-error-output* (make-synonym-stream '*error-output*))
(proclaim '(type stream *compiler-error-output*))
;;; 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)
(proclaim '(type (or compiler-error-context null) *last-error-context*))
;;; The format string and args for the last error we printed.
;;;
(defvar *last-format-string* nil)
(defvar *last-format-args* nil)
(proclaim '(type (or string null) *last-format-string*))
(proclaim '(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.
(defvar *last-message-count* 0)
(proclaim '(type index *last-message-count*))
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
(defvar *compiler-notification-function* nil
"This is the function called by the compiler to specially note a warning,
comment, or error. The function must take four arguments, the severity
a string for context, the file namestring, and the file position. The
severity is one of :note, :warning, or :error. Except for the severity, all
of these can be NIL if unavailable or inapplicable.")
;;; COMPILER-NOTIFICATION -- Internal
;;;
;;; Call any defined notification function.
;;;
(defun compiler-notification (severity context)
(declare (type (member :note :warning :error) severity)
(type (or compiler-error-context null) context))
(when *compiler-notification-function*
(if context
(let ((*print-level* 2)
(*print-pretty* nil)
(name (compiler-error-context-file-name context)))
(funcall *compiler-notification-function* severity
(format nil "~{~{~S~^ ~}~^ => ~}"
(compiler-error-context-context context))
(when (stringp name) name)
(compiler-error-context-file-position context)))
(funcall *compiler-notification-function* severity nil nil nil)))
(undefined-value))
;;; Note-Message-Repeats -- Internal
;;;
;;; If the last message was given more than once, then print out an
;;; indication of how many times it was repeated. We reset the message count
;;; when we are done.
;;;
(defun note-message-repeats (&optional (terpri t))
(cond ((= *last-message-count* 1)
(when terpri (terpri *compiler-error-output*)))
((> *last-message-count* 1)
(format *compiler-error-output* "[Last message occurs ~D times]~2%"
*last-message-count*)))
(setq *last-message-count* 0))
;;; Print-Error-Message -- Internal
;;;
;;; 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.
;;;
;;; We suppress printing of messages identical to the previous, but record
;;; the number of times that the message is repeated.
;;;
(defun print-error-message (what format-string format-args)
(declare (type (member :error :warning :note) what) (string format-string)
(list format-args))
(let* ((*print-level* (or *error-print-level* *print-level*))
(*print-length* (or *error-print-length* *print-length*))
(*print-lines* (or *error-print-lines* *print-lines*))
(context (find-error-context format-args)))
(let ((file (compiler-error-context-file-name context))
(in (compiler-error-context-context context))
(enclosing (compiler-error-context-enclosing-source context))
(source (compiler-error-context-source context))
(last *last-error-context*))
(compiler-notification what context)
(unless (and last
(equal file (compiler-error-context-file-name last)))
(when (stringp file)
(note-message-repeats)
(setq last nil)
(format stream "~2&File: ~A~%" file)))
(unless (and last
(equal in (compiler-error-context-context last)))
(setq last nil)
(format stream "~2&In:~{~<~% ~4:;~{ ~S~}~>~^ =>~}~%" in))
(unless (and last
(string= form
(compiler-error-context-original-source last)))
(setq last nil)
(write-string form stream))
(unless (and last
(equal enclosing
(compiler-error-context-enclosing-source last)))
(when enclosing
(setq last nil)
(format stream "--> ~{~<~%--> ~1:;~A~> ~}~%" enclosing)))
(unless (and last
(equal source (compiler-error-context-source last)))
(setq *last-format-string* nil)
(when source
(dolist (src source)
(write-line "==>" stream)
(write-string src stream))))))
(setq *last-format-string* nil)
(setq *last-error-context* context)
(setq *last-format-string* format-string)
(setq *last-format-args* format-args)
(format stream "~&~:(~A~): ~?~&" what format-string format-args)))
(incf *last-message-count*)
(undefined-value))
;;; Keep track of how many times each kind of warning happens.
;;;
(proclaim '(type index *compiler-error-count* *compiler-warning-count*
*compiler-note-count*))
(defvar *compiler-error-count* 0)
(defvar *compiler-warning-count* 0)
(defvar *compiler-note-count* 0)
;;; Compiler-Error, ... -- Interface
;;;
;;; Increment the count and print the message. Compiler-Note never prints
;;; anything when Brevity is 3. Compiler-Error calls the bailout function
;;; so that it never returns. Compiler-Error-Message returns like
;;; Compiler-Warning, but prints a message like Compiler-Error.
;;;
(proclaim '(ftype (function (string &rest t) void)
compiler-error compiler-warning compiler-note))
;;;
(defun compiler-error (format-string &rest format-args)
(incf *compiler-error-count*)
(print-error-message :error format-string format-args)
(funcall *compiler-error-bailout*)
(error "*Compiler-Error-Bailout* returned?"))
;;;
(defun compiler-error-message (format-string &rest format-args)
(incf *compiler-error-count*)
(print-error-message :error format-string format-args))
;;;
(defun compiler-warning (format-string &rest format-args)
(incf *compiler-warning-count*)
(print-error-message :warning format-string format-args))
;;;
(defun compiler-note (format-string &rest format-args)
(unless (if *compiler-error-context*
(policy *compiler-error-context* (= brevity 3))
(policy nil (= brevity 3)))
(incf *compiler-note-count*)
(print-error-message :note format-string format-args)))
;;; Compiler-Mumble -- Interface
;;;
;;; The politically correct way to print out random 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 message gets
;;; seen right away.
;;;
(proclaim '(function compiler-mumble (string &rest t) void))
(defun compiler-mumble (format-string &rest format-args)
(setq *last-error-context* nil)
(apply #'format *compiler-error-output* format-string format-args)
(force-output *compiler-error-output*))
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
;;; Find-Component-Name -- Interface
;;;
;;; 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.
;;;
(proclaim '(function find-component-name (component) simple-string))
(defun find-component-name (component)
(let ((ep (first (block-succ (component-head component)))))
(assert ep () "No entry points?")
(multiple-value-bind
(form context)
(find-original-source
(node-source-path (continuation-next (block-start ep))))
(declare (ignore form))
(let ((*print-level* 2)
(*print-pretty* nil))
(format nil "~{~{~S~^ ~}~^ => ~}" context)))))
;;;; Undefined warnings:
(defvar *undefined-warning-limit* 3
"If non-null, then an upper limit on the number of unknown function or type
warnings that the compiler will print for any given name in a single
compilation. This prevents excessive amounts of output when there really is
a missing definition (as opposed to a typo in the use.)")
;;; NOTE-UNDEFINED-REFERENCE -- Interface
;;;
;;; Make an entry in the *UNDEFINED-WARNINGS* describing a reference to Name
;;; of the specified Kind. If we have exceeded the warning limit, then just
;;; increment the count, otherwise note the current error context.
;;;
(defun note-undefined-reference (name kind)
(unless (policy nil (= brevity 3))
(let* ((found (dolist (warn *undefined-warnings* nil)
(when (and (equal (undefined-warning-name warn) name)
(eq (undefined-warning-kind warn) kind))
(return warn))))
(res (or found
(make-undefined-warning :name name :kind kind))))
(unless found (push res *undefined-warnings*))
(when (or (not *undefined-warning-limit*)
(< (undefined-warning-count res) *undefined-warning-limit*))
(push (find-error-context (list name))
(incf (undefined-warning-count res))))
;;;; Careful call:
;;; Careful-Call -- Interface
;;;
;;; Apply a function to some arguments, returning a list of the values
;;; resulting of the evaulation. If an error is signalled during the
;;; application, then we print a warning message and return NIL as our second
;;; value to indicate this. Node is used as the error context for any error
;;; message, and Context is a string that is spliced into the warning.
;;;
(proclaim '(function careful-call ((or symbol function) list node string)
(values list boolean)))
(defun careful-call (function args node context)
(values
(multiple-value-list
(handler-case (apply function args)
(error (condition)
(let ((*compiler-error-context* node))
(compiler-warning "Lisp error during ~A:~%~A" context condition)
(return-from careful-call (values nil nil))))))
t))
;;;; Generic list (?) functions:
(proclaim '(inline find-in position-in map-in))
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
;;; Find-In -- Interface
;;;
(defun find-in (next element list &key (key #'identity)
(test #'eql test-p) (test-not nil not-p))
"Find Element in a null-terminated List linked by the accessor function
Next. Key, Test and Test-Not are the same as for generic sequence
functions."
(when (and test-p not-p)
(error "Silly to supply both :Test and :Test-Not."))
(if not-p
(do ((current list (funcall next current)))
((null current) nil)
(unless (funcall test-not (funcall key current) element)
(return current)))
(do ((current list (funcall next current)))
((null current) nil)
(when (funcall test (funcall key current) element)
(return current)))))
;;; Position-In -- Interface
;;;
(defun position-in (next element list &key (key #'identity)
(test #'eql test-p) (test-not nil not-p))
"Return the position of Element (or NIL if absent) in a null-terminated List
linked by the accessor function Next. Key, Test and Test-Not are the same as
for generic sequence functions."
(when (and test-p not-p)
(error "Silly to supply both :Test and :Test-Not."))
(if not-p
(do ((current list (funcall next current))
(i 0 (1+ i)))
((null current) nil)
(unless (funcall test-not (funcall key current) element)
(return i)))
(do ((current list (funcall next current))
(i 0 (1+ i)))