From 40f94b0358e78a72ba2021b3598d773f4557f59e Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Mon, 16 Apr 1990 10:37:27 +0000
Subject: [PATCH] Merged non-descriptor changes: ir1util.lisp  revision 1.7.1.2
  date: 90/04/13 12:17:09;  author: ram;  state: Exp;  lines added/del: 33/12 
 Added hack to DELETE-RETURN to inhibit blowing away of tail-sets when  we
 delete TR returns.  Fixed up undefined reference stuff a bit, and added
 NOTE-NAME-DEFINED.  ----------------------------  revision 1.7.1.1  date:
 90/03/27 12:17:26;  author: ram;  state: Exp;  lines added/del: 40/0 
 Generalized the undefined function warning stuff so that it could be used 
 for undefined type warnings as well.  Moved stuff from ir1tran to ir1util, 
 defining the new NOTE-UNDEFINED-REFERENCE function.

---
 compiler/ir1util.lisp | 69 ++++++++++++++++++++++++++++++++++++++++---
 1 file changed, 65 insertions(+), 4 deletions(-)

diff --git a/compiler/ir1util.lisp b/compiler/ir1util.lisp
index 7c223b179..f710851c8 100644
--- a/compiler/ir1util.lisp
+++ b/compiler/ir1util.lisp
@@ -373,6 +373,7 @@
 ;;; Node-Ends-Block  --  Interface
 ;;;
 ;;;    Makes Node the Last node in its block, splitting the block if necessary.
+;;; The new block is added to the DFO immediately following Node's block.
 ;;;
 ;;;    If the mess-up for one of Block's End-Cleanups is moved into the new
 ;;; block, then we must adjust the end/start cleanups of the new and old blocks
@@ -598,16 +599,24 @@
 
 ;;; Delete-Return  --  Interface
 ;;;
-;;;    Do stuff to indicate that the return node Node is being deleted.
+;;;    Do stuff to indicate that the return node Node is being deleted.  We set
+;;; the RETURN to NIL and remove the function from its tail set.
+;;;
+;;;    As a rather random special case, we leave the function in the tail set
+;;; when there are uses of the result continuation marked TAIL-P.  This is done
+;;; to prevent the tail set from being blown away when the back end deletes the
+;;; return because it discovers that all calls are tail-recursive.
 ;;;
 (defun delete-return (node)
   (declare (type creturn node))
   (let* ((fun (return-lambda node))
 	 (tail-set (lambda-tail-set fun)))
     (assert (lambda-return fun))
-    (setf (tail-set-functions tail-set)
-	  (delete fun (tail-set-functions tail-set)))
-    (setf (lambda-tail-set fun) nil)
+    (unless (do-uses (use (return-result node) nil)
+	      (when (node-tail-p use) (return t)))
+      (setf (tail-set-functions tail-set)
+	    (delete fun (tail-set-functions tail-set)))
+      (setf (lambda-tail-set fun) nil))
     (setf (lambda-return fun) nil))
   (undefined-value))
 
@@ -1321,6 +1330,58 @@
 	    (*print-pretty* nil))
 	(format nil "~{~{~S~^ ~}~^ => ~}" context)))))
 
+
+;;;; 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))
+
 
 ;;;; Careful call:
 
-- 
GitLab