Newer
Older
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
;;; Return the COMBINATION node that is the call to the let Fun.
;;;
(defun let-combination (fun)
(declare (type clambda fun))
(assert (eq (functional-kind fun) :let))
(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* *current-form*))
;;; 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.
;;;
(defstruct (compiler-error-context
(:print-function
(lambda (s stream d)
(declare (ignore s d))
(format stream "#<Compiler-Error-Context>"))))
;;
;; The form immediately responsible for this error (may be the result of
;; mecroexpansion, etc.)
source
;;
;; The form in the original source that expanded into Source.
original-source
;;
;; A list of prefixes of "interesting" forms that enclose original-source.
context
;;
;; Source for a form enclosing this one, or NIL if unknown.
enclosing-source
;;
;; Description of how the value of SOURCE is used by ENCLOSING-SOURCE such as
;; "third argument", "set value", etc. Null when there is no
;; ENCLOSING-SOURCE.
(enclosed-how nil :type (or simple-string null)))
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
;;; 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)
;;; A list of "DEFxxx" forms for which we should we should compute the source
;;; context by taking the CAR of the first arg when it is a list.
;;;
(defparameter defmumble-take-car-forms '(defstruct))
;;; 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))
(assert path)
(let* ((rpath (reverse (rest path)))
(root (find-source-root (first rpath) *source-info*)))
(collect ((context))
(let ((form root)
(current (rest rpath)))
(loop
(when (null current) (return))
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
(let ((head (first form)))
(when (symbolp head)
(let ((name (symbol-name head)))
(when (and (>= (length name) 3) (string= name "DEF" :end1 3))
(if (>= (length form) 2)
(let ((next (second form)))
(context
(list head
(if (and (listp next)
(member head
defmumble-take-car-forms))
(car next)
next))))
(context (list head)))))))
(setq form (nth (pop current) form)))
(cond ((context)
(values form (context)))
((and path root)
(if (listp root)
(values form (list (subseq root 0 (min 2 (length root)))))
(values form ())))
(t
(values '(unable to locate source)
'((some strange place)))))))))
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
;;; FIND-ENCLOSING-SOURCE -- Internal
;;;
;;; Look at the DEST of node, and return the source for it, along with a
;;; description of how the value is used by the DEST.
;;;
(defun find-enclosing-source (node)
(declare (type node node))
(let* ((cont (node-cont node))
(dest (continuation-dest cont)))
(when dest
(values
(node-source dest)
(etypecase dest
(cif "conditional test value")
(cset "assigned value")
(creturn "function return value")
(exit "RETURN'ed value")
(basic-combination
(if (eq cont (basic-combination-fun dest))
"called function"
(format nil "~:R argument"
(1+ (position cont
(basic-combination-args dest)))))))))))
;;; FIND-ERROR-CONTEXT -- Interface
;;;
;;; Return a COMPILER-ERROR-CONTEXT structure describing the current error
;;; context, or NIL if we can't figure anything out.
;;;
(defun find-error-context ()
(let ((context *compiler-error-context*))
(if (compiler-error-context-p context)
context
(let ((source (cond (*current-form*)
(context (node-source context))
(t nil)))
(path (if context (node-source-path context) *current-path*)))
(when (and *source-info* path)
(multiple-value-bind (form src-context)
(find-original-source path)
(multiple-value-bind (enclosing how)
(when (and context (not *current-form*))
(find-enclosing-source context))
(make-compiler-error-context
:source source
:original-source form
:context src-context
:enclosing-source enclosing
:enclosed-how how))))))))
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
;;;; 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.")))
;;; 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.")
;;; We save the context information that we printed out most recently so that
;;; we don't print it out redundantly.
;;;
(proclaim '(list *last-source-context*))
(defvar *last-source-context* nil)
(defvar *last-original-source* nil)
(defvar *last-source-form* nil)
(defvar *last-format-string* nil)
(defvar *last-format-args* nil)
(defvar *last-message-count* 0)
;;; The stream that compiler error output is directed to, or NIL if error
;;; output is inhibited.
;;;
(defvar *compiler-error-output* (make-synonym-stream '*error-output*))
(proclaim '(type (or stream null) *compiler-error-output*))
;;; 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 ()
(cond ((= *last-message-count* 1) (terpri *compiler-error-output*))
((> *last-message-count* 1)
(format *compiler-error-output* "[Last message occurs ~D times]~2%"
*last-message-count*)))
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
1257
(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 (string what format-string) (list format-args))
(let* ((*print-level* *error-print-level*)
(*print-length* *error-print-length*)
(stream *compiler-error-output*)
(context (find-error-context)))
(unless stream (return-from print-error-message (undefined-value)))
(cond
(context
(let ((context (compiler-error-context-context context))
(form (compiler-error-context-original-source context))
(source (compiler-error-context-source context))
(enclosing (compiler-error-context-enclosing-source context))
(how (compiler-error-context-enclosed-how context)))
(note-message-repeats)
(setq *last-source-context* context)
(setq *last-original-source* nil)
(format stream "~2&In:~{~<~% ~4:;~{ ~S~}~>~^ =>~}~%" context))
l
(unless (tree-equal form *last-original-source*)
(note-message-repeats)
(setq *last-original-source* form)
(setq *last-enclosing-source* nil)
(setq *last-format-string* nil)
(unless (or (tree-equal source form)
(member source form))
(unless (tree-equal enclosing *last-enclosing-source*)
(note-message-repeats)
(setq *last-source-form* '#(invalid))
(setq *last-enclosing-source* enclosing)
(format stream "==>~% ~S~%" enclosing))
(unless (tree-equal source *last-source-form*)
(note-message-repeats)
(setq *last-source-form* source)
(setq *last-format-string* nil)
(unless (member source format-args)
(if *last-enclosing-source*
(format stream "The ~A:~% ~S~%" how source)
(format stream "==>~% ~S~%" source)))))))
(t
(note-message-repeats)
(format stream "~2&")))
(unless (and (equal format-string *last-format-string*)
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
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
(note-message-repeats)
(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 unsigned-byte *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)
(incf *compiler-note-count*)
(unless (if *compiler-error-context*
(policy *compiler-error-context* (= brevity 3))
(policy nil (= brevity 3)))
(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)
(when *last-format-string*
(note-message-repeats)
(terpri *compiler-error-output*)
(setq *last-source-context* nil)
(setq *last-format-string* nil))
(apply #'format *compiler-error-output* format-string format-args)
(force-output *compiler-error-output*))
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
;;; 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)))))
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
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
1433
1434
1435
;;;; Undefined warnings:
;;; A list of UNDEFINED-WARNING structures representing the calls to unknown
;;; functions. This is bound by WITH-COMPILATION-UNIT.
;;;
(defvar *undefined-warnings*)
(proclaim '(list *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)
(undefined-warning-warnings res)))
(incf (undefined-warning-count res)))
(undefined-value))
;;; NOTE-NAME-DEFINED -- Interface
;;;
;;; Delete any undefined warnings for Name and Kind.
;;;
(defun note-name-defined (name kind)
(setq *undefined-warnings*
(delete-if #'(lambda (x)
(and (equal (undefined-warning-name x) name)
(eq (undefined-warning-kind x) kind)))
*undefined-warnings*))
(undefined-value))
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
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
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
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
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
;;;; 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 (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:
;;; 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)
#-new-compiler
(if clc::*in-the-compiler*
(get-setf-method place env)
(lisp::foo-get-setf-method place env))
#+new-compiler
(lisp::foo-get-setf-method place env)
(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)
#-new-compiler
(if clc::*in-the-compiler*
(get-setf-method place env)
(lisp::foo-get-setf-method place env))
#+new-compiler
(lisp::foo-get-setf-method place env)
`(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))