Newer
Older
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
(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)))
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
(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))))))))
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
;;;; 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))
;;; 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))
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
(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)))
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
(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:
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
(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 *defmumble-take-car-forms* '(defstruct)
"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.")
;;; 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 nil :type simple-string)
;; A list of prefixes of "interesting" forms that enclose original-source.
(context nil :type list))
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
;;; 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)
;;; 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)))
(root (find-source-root (first rpath) *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))
(if (>= (length form) 2)
(let ((next (second form)))
(context
(list head
(if (and (listp next)
(member head
*defmumble-take-car-forms*))
(when (null current) (return))
(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)))))))))
;;; 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* *error-print-level*)
(*print-length* *error-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)))
:enclosing-source (short)
:source (full)
:original-source (stringify-form form)
:context src-context))))))))
;;;; 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)
;;; 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 (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 format-args)))
(unless stream (return-from print-error-message (undefined-value)))
(cond
(context
(let ((in (compiler-error-context-context context))
(enclosing (compiler-error-context-enclosing-source context))
(source (compiler-error-context-source context))
(last *last-error-context*))
(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)
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
(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)
(setq *last-error-context* nil)
(apply #'format *compiler-error-output* format-string format-args)
(force-output *compiler-error-output*))
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
;;; 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)))))
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
;;;; 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))
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
;;;; 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:
(proclaim '(inline find-in position-in map-in))
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
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
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
;;; 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))