Newer
Older
(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))
(basic-combination
(when (and (eq (basic-combination-kind node) :local)
;; Not already deleted...
(continuation-use (basic-combination-fun node)))
(let ((fun (combination-lambda node)))
(when (member (functional-kind fun) '(:let :mv-let))
(delete-lambda fun))))
(flush-dest (basic-combination-fun node))
(dolist (arg (basic-combination-args node))
(when arg (flush-dest arg))))
(cif
(flush-dest (if-test node)))
(bind
(let ((lambda (bind-lambda node)))
(unless (eq (functional-kind lambda) :deleted)
(assert (member (functional-kind lambda) '(:let :mv-let)))
(delete-lambda lambda))))
(exit
(let ((value (exit-value node))
(entry (exit-entry node)))
(flush-dest value))
(when entry
(setf (entry-exits entry)
(delete node (entry-exits entry))))))
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
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
(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)))
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
(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)))
(do-blocks (block component)
(setf (block-delete-p block) t))
(dolist (fun (component-lambdas component))
(setf (leaf-refs fun) nil)
(delete-lambda fun))
(do-blocks (block component)
(delete-block block))
(undefined-value))
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
;;; 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)
(flush-dest cont)
(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))
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
;;; 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))
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
(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)))
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
(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:
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
(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*))
(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 *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 pathname (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)
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
;;; 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-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*))
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
(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 (typep name 'pathname)
(namestring 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*))
(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 (typep file 'pathname)
(note-message-repeats)
(setq last nil)
(format stream "~2&File: ~A~%" (namestring 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*))
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
;;; 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)))))
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
;;;; 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)
(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))
(undefined-warning-warnings res)))
(incf (undefined-warning-count res)))
(undefined-value))
;;;; 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))
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
;;; 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)))
((null current) nil)
(when (funcall test (funcall key current) element)
(return i)))))
;;; Map-In -- Interface
;;;
(defun map-in (next function list)
"Map Function over the elements in a null-terminated List linked by the
accessor function Next, returning a list of the results."
(collect ((res))
(do ((current list (funcall next current)))
((null current))
(res (funcall function current)))
(res)))
;;; Deletef-In -- Interface
;;;
(defmacro deletef-in (next place item &environment env)
"Deletef-In Next Place Item
Delete Item from a null-terminated list linked by the accessor function Next
that is stored in Place. Item must appear exactly once in the list."
(multiple-value-bind
(temps vals stores store access)
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
(let ((n-item (gensym))
(n-place (gensym))
(n-current (gensym))
(n-prev (gensym)))
`(let* (,@(mapcar #'list temps vals)
(,n-place ,access)
(,n-item ,item))
(if (eq ,n-place ,n-item)
(let ((,(first stores) (,next ,n-place)))
,store)
(do ((,n-prev ,n-place ,n-current)
(,n-current (,next ,n-place)
(,next ,n-current)))
((eq ,n-current ,n-item)
(setf (,next ,n-prev)
(,next ,n-current)))))
(undefined-value)))))
;;; Push-In -- Interface
;;;
(defmacro push-in (next item place &environment env)
"Push Item onto a list linked by the accessor function Next that is stored in
Place."
(multiple-value-bind
(temps vals stores store access)