Newer
Older
(let ((value (exit-value node))
(entry (exit-entry node)))
(flush-dest value))
(when entry
(setf (entry-exits entry)
(delete node (entry-exits entry))))))
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
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
(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)))
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
(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))))))))
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
;;;; 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)
(derive-node-type ref (leaf-type leaf))
(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))
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
;;; 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))
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
(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.
;;;
(defun continuation-function-name (cont)
(declare (type continuation cont))
(let ((use (continuation-use cont)))
(if (and (ref-p use)
(not (eq (ref-inlinep use) :notinline)))
(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)))
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
(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:
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
(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*))
(defparameter *source-context-take-car-forms* '(defstruct function)
"A list of form names for which we should we should compute the source
context by taking the CAR of the first arg when it is a list.")
;;; 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)
;;; 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)
(let ((head (first form))
(next (second form)))
(list head
(if (and (listp next)
(member head *source-context-take-car-forms*))
(car next)
next))))
(t
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*))
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
(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)
(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)
(setq *last-error-context* nil)
(apply #'format *compiler-error-output* format-string format-args)
(force-output *compiler-error-output*))
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
;;; 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)))))
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
;;;; 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 (list name))
(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))
;;;; 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))
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
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
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
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
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
;;; 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))