Newer
Older
;;; 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))
(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))))))
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
1114
1115
1116
1117
1118
1119
(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)))
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
(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))
;;;; 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))
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
;;; 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))
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
(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)))
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
(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:
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
(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)
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
;;; 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
`(defmethod ,name ,@(subseq stuff 0 arg-pos)
,@(nth-value 2 (pcl::parse-specialized-lambda-list
(elt stuff arg-pos))))
`(defmethod ,name "<illegal syntax>"))))
;;; 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*))
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
(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*))
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
;;; 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)))))
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
;;;; 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))
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
;;; 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)
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
(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)
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
`(let (,@(mapcar #'list temps vals)
(,(first stores) ,item))
(setf (,next ,(first stores)) ,access)
,store
(undefined-value))))
;;; Compiler-Constantp -- Interface
;;;
;;; We don't want to assume that a variable is a constant just because it is
;;; in the current lisp environment.
;;;
;;; ### For now, just use CONSTANTP to avoid bootstrapping problems with having
;;; to have the INFO database available at meta-compile time.
;;;
(proclaim '(function compiler-constantp (t) boolean))
(defun compiler-constantp (exp)
"Like constantp, only uses the compilation environment rather than the
current Lisp environment."
#|
(if (symbolp exp)
(eq (info variable kind exp) :constant)
(constantp exp))
|#
(constantp exp))