From 74eadac3fe0a52fed0365e3cadbfda4cbb67799f Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Mon, 23 Jul 1990 14:48:47 +0000
Subject: [PATCH] Error message stuff much changed for new source context
 stuff.  New source context utilities.  New block-attributes stuff to squeeze
 together all those boolean flags w/o changing all uses.  Changes for new
 NLX/cleanup stuff.

---
 compiler/ir1util.lisp | 539 +++++++++++++++++++++++-------------------
 1 file changed, 297 insertions(+), 242 deletions(-)

diff --git a/compiler/ir1util.lisp b/compiler/ir1util.lisp
index 60ae2f585..d6ae547c9 100644
--- a/compiler/ir1util.lisp
+++ b/compiler/ir1util.lisp
@@ -17,15 +17,20 @@
 
 ;;;; Cleanup hackery:
 
-;;; Find-Enclosing-Cleanup  --  Interface
+
+;;; Node-Enclosing-Cleanup  --  Interface
 ;;;
-;;;    Chain up the Lambda-Cleanup thread until we find a Cleanup or null.
+;;;    Return the innermost cleanup enclosing Node, or NIL if there is none in
+;;; its function.  If Node has no cleanup, but is in a let, then we must still
+;;; check the environment that the call is in.
 ;;;
-(defun find-enclosing-cleanup (thing)
-  (declare (type (or cleanup clambda null) thing))
-  (etypecase thing
-    ((or cleanup null) thing)
-    (clambda (find-enclosing-cleanup (lambda-cleanup thing)))))
+(defun node-enclosing-cleanup (node)
+  (declare (type node node))
+  (let ((env (node-lexenv node)))
+    (or (lexenv-cleanup env)
+	(let ((lambda (lexenv-lambda env)))
+	  (and (member (functional-kind lambda) '(:mv-let :let))
+	       (node-enclosing-cleanup (let-combination lambda)))))))
 
 
 ;;; Insert-Cleanup-Code  --  Interface
@@ -34,15 +39,20 @@
 ;;; implicit MV-Prog1.  The inserted block is returned.  Node is used for IR1
 ;;; context when converting the form.  Note that the block is not assigned a
 ;;; number, and is linked into the DFO at the beginning.  We indicate that we
-;;; have trashed the DFO by setting Component-Reanalyze.
+;;; have trashed the DFO by setting Component-Reanalyze.  If Cleanup is
+;;; supplied, then convert with that cleanup.
 ;;;
-(defun insert-cleanup-code (block1 block2 node form)
-  (declare (type cblock block1 block2) (type node node))
+(defun insert-cleanup-code (block1 block2 node form &optional cleanup)
+  (declare (type cblock block1 block2) (type node node)
+	   (type (or cleanup null) cleanup))
   (with-ir1-environment node
-    (setf (component-reanalyze *current-component*) t)
     (let* ((start (make-continuation))
 	   (block (continuation-starts-block start))
-	   (cont (make-continuation)))
+	   (cont (make-continuation))
+	   (*lexical-environment*
+	   (if cleanup
+	       (make-lexenv :cleanup cleanup)
+	       *lexical-environment*)))
       (change-block-successor block1 block2 block)
       (link-blocks block block2)
       (ir1-convert start cont form)
@@ -190,9 +200,7 @@
 	 (cond ((or (eq kind :unused)
 		    (eq (node-cont (block-last block)) cont))
 		(setf (continuation-block cont)
-		      (make-block-key :start cont :lambda nil
-				      :start-cleanup nil :end-cleanup nil
-				      :component nil))
+		      (make-block-key :start cont  :component nil))
 		(setf (continuation-kind cont) :deleted-block-start))
 	       (t
 		(node-ends-block (continuation-use cont))))))))
@@ -202,11 +210,8 @@
 ;;; Substitute-Continuation-Uses  --  Interface
 ;;;
 ;;;    Replace all uses of Old with uses of New, where New has an arbitary
-;;; number of uses.  If a use is an Exit, then we also substitute New for Old
-;;; in the Entry's Exits to maintain consistency between the two.
-;;;
-;;;    If New will end up with more than one use, then we must arrange for it
-;;; to start a block if it doesn't already.
+;;; number of uses.  If New will end up with more than one use, then we must
+;;; arrange for it to start a block if it doesn't already.
 ;;;
 (defun substitute-continuation-uses (new old)
   (declare (type continuation old new))
@@ -215,53 +220,140 @@
     (ensure-block-start new))
   
   (do-uses (node old)
-    (when (exit-p node)
-      (let ((entry (exit-entry node)))
-	(when entry
-	  (setf (entry-exits entry)
-		(nsubst new old (entry-exits entry))))))
     (delete-continuation-use node)
     (add-continuation-use node new))
 
   (reoptimize-continuation new)
   (undefined-value))
 
-#|
-;;; Substitute-Node-Cont  --  Interface
-;;;
-;;;    Replace Old's single use with a use of New.  This is used in contexts
-;;; where we know that New has no use and Old has a single use.
-;;;
-(defun substitute-node-cont (new old)
-  (declare (type continuation new old))
-  (assert (member (continuation-kind new) '(:block-start :unused)))
-  (assert (eq (continuation-kind old) :inside-block))
-
-  (let ((use (continuation-use old)))
-    (delete-continuation-use use)
-    (add-continuation-use use new))
-
-  (undefined-value))
-|#
-
 
-;;; NODE-BLOCK, NODE-ENVIRONMENT, NODE-TLF-NUMBER  --  Interface
-;;;
-;;;    Shorthand for common idiom.
+;;;; Misc shortand functions:
+
+;;; NODE-xxx  --  Interface
 ;;;
-(proclaim '(inline node-block node-environment node-tlf-number))
+(proclaim '(inline node-block node-home-lambda node-environment
+		   node-tlf-number))
 (defun node-block (node)
   (declare (type node node))
   (the cblock (continuation-block (node-prev node))))
 ;;;
-(defun node-environment (node)
+(defun node-home-lambda (node)
   (declare (type node node))
-  (the environment (lambda-environment (block-lambda (node-block node)))))
+  (lambda-home (lexenv-lambda (node-lexenv node))))
 ;;;
-(defun node-tlf-number (node)
+(defun node-environment (node)
   (declare (type node node))
-  (car (last (node-source-path node))))
+  (the environment (lambda-environment (lexenv-lambda (node-lexenv node)))))
+
+
+
+;;; BLOCK-xxx-CLEANUP  --  Interface
+;;;
+;;;    Return the enclosing cleanup for environment of the first or last node
+;;; in Block.
+;;;
+(defun block-start-cleanup (block)
+  (declare (type cblock block))
+  (node-enclosing-cleanup (continuation-next (block-start block))))
+;;;
+(defun block-end-cleanup (block)
+  (declare (type cblock block))
+  (node-enclosing-cleanup (block-last block)))
+
+
+;;; BLOCK-HOME-LAMBDA  --  Interface
+;;;
+;;;    Return the non-let lambda that holds Block's code.
+;;;
+(defun block-home-lambda (block)
+  (declare (type cblock block))
+  (lambda-home (lexenv-lambda (node-lexenv (block-last block)))))
+
+
+;;; BLOCK-ENVIRONMENT  --  Interface
+;;;
+;;;    Return the IR1 environment for Block.
+;;;
+(defun block-environment (block)
+  (declare (type cblock block))
+  (lambda-environment (lexenv-lambda (node-lexenv (block-last block)))))
+
+
+;;; SOURCE-PATH-TLF-NUMBER  --  Interface
+;;;
+;;;    Return the Top Level Form number of path, i.e. the ordinal number of
+;;; its orignal source's top-level form in its compilation unit.
+;;;
+(defun source-path-tlf-number (path)
+  (declare (list path))
+  (car (last path)))
+
+
+;;; SOURCE-PATH-ORIGINAL-SOURCE  --  Interface
+;;;
+;;;    Return the (reversed) list for the path in the orignal source (with the
+;;; TLF number last.)
+;;; 
+(defun source-path-original-source (path)
+  (declare (list path))
+  (cddr (member 'original-source-start path)))
+
+
+;;; SOURCE-PATH-FORM-NUMBER  --  Interface
+;;;
+;;;    Return the Form Number of Path's orignal source inside the Top Level
+;;; Form that contains it.  This is determined by the order that we walk the
+;;; subforms of the top level source form.
+;;;
+(defun source-path-form-number (path)
+  (declare (list path))
+  (cadr (member 'original-source-start path)))
+
+
+;;; SOURCE-PATH-FORMS  --  Interface
+;;;
+;;;    Return a list of all the enclosing forms not in the original source that
+;;; converted to get to this form, with the immediate source for node at the
+;;; start of the list.
+;;;
+(defun source-path-forms (path)
+  (subseq path 0 (position 'original-source-start path)))
 
+
+;;; MAKE-LEXENV  --  Interface
+;;;
+;;;    Return a new LEXENV just like Default except for the specified slot
+;;; values.  Values for the alist slots are NCONC'ed to the beginning of the
+;;; current value, rather than replacing it entirely.
+;;; 
+(defun make-lexenv (&key (default *lexical-environment*)
+			 functions variables blocks tags type-restrictions
+			 inlines
+			 (lambda (lexenv-lambda default))
+			 (cleanup (lexenv-cleanup default))
+			 (cookie (lexenv-cookie default)))
+  (macrolet ((frob (var slot)
+	       `(let ((old (,slot default)))
+		  (if ,var
+		      (nconc ,var old)
+		      old))))
+    (internal-make-lexenv
+     (frob functions lexenv-functions)
+     (frob variables lexenv-variables)
+     (frob blocks lexenv-blocks)
+     (frob tags lexenv-tags)
+     (frob type-restrictions lexenv-type-restrictions)
+     (frob inlines lexenv-inlines)
+     lambda cleanup cookie)))
+#|
+functions
+variables
+blocks
+tags
+type-restrictions
+inlines
+|#
+			   
 
 ;;;; Flow/DFO/Component hackery:
 
@@ -269,18 +361,21 @@
 ;;;
 ;;;    Join or separate Block1 and Block2.
 ;;;
-(proclaim '(ftype (function (block block) void) link-blocks unlink-blocks))
 (defun link-blocks (block1 block2)
+  (declare (type cblock block1 block2))
   (assert (not (member block2 (block-succ block1))))
   (push block2 (block-succ block1))
-  (push block1 (block-pred block2)))
+  (push block1 (block-pred block2))
+  (undefined-value))
 ;;;
 (defun unlink-blocks (block1 block2)
+  (declare (type cblock block1 block2))
   (assert (member block2 (block-succ block1)))
   (setf (block-succ block1)
 	(delete block2 (block-succ block1)))
   (setf (block-pred block2)
-	(delete block1 (block-pred block2))))
+	(delete block1 (block-pred block2)))
+  (undefined-value))
 
 
 ;;; Change-Block-Successor  --  Internal
@@ -324,14 +419,15 @@
 ;;;    Add Block to the next/prev chain following After.  We also set the
 ;;; Component to be the same as for After.
 ;;;
-(proclaim '(function add-to-dfo (block block) void))
 (defun add-to-dfo (block after)
+  (declare (type cblock block after))
   (let ((next (block-next after)))
     (setf (block-component block) (block-component after))
     (setf (block-next after) block)
     (setf (block-prev block) after)
     (setf (block-next block) next)
-    (setf (block-prev next) block)))
+    (setf (block-prev next) block))
+  (undefined-value))
 
 
 ;;; Clear-Flags  --  Interface
@@ -356,10 +452,8 @@
 ;;;
 (proclaim '(function make-empty-component () component))
 (defun make-empty-component ()
-  (let* ((head (make-block-key :start nil :lambda nil :start-cleanup nil
-			       :end-cleanup nil :component nil))
-	 (tail (make-block-key :start nil :lambda nil :start-cleanup nil
-			       :end-cleanup nil :component nil))
+  (let* ((head (make-block-key :start nil :component nil))
+	 (tail (make-block-key :start nil :component nil))
 	 (res (make-component :head head  :tail tail)))
     (setf (block-flag head) t)
     (setf (block-flag tail) t)
@@ -375,14 +469,6 @@
 ;;;    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
-;;; to reflect the movement of the mess-up.  If any of the old end cleanups
-;;; were in the new block, then we scan up from that cleanup trying to find one
-;;; that isn't.  When we do, that becomes the new start/end cleanup of the
-;;; old/new block.  We set the start/end as a pair, since we don't want anyone
-;;; to think that a cleanup is necessary.
-;;;
 (defun node-ends-block (node)
   (declare (type node node))
   (let* ((block (node-block node))
@@ -392,12 +478,8 @@
     (unless (eq last node)
       (assert (eq (continuation-kind start) :inside-block))
       (let* ((succ (block-succ block))
-	     (cleanup (block-end-cleanup block))
 	     (new-block
 	      (make-block-key :start start
-			      :lambda (block-lambda block)
-			      :start-cleanup cleanup
-			      :end-cleanup cleanup
 			      :component (block-component block)
 			      :start-uses (list (continuation-use start))
 			      :succ succ :last last)))
@@ -416,24 +498,6 @@
 	       (setf (continuation-block last-cont) new-block)))
 	  (setf (continuation-block cont) new-block))
 
-	(let ((start-cleanup (block-start-cleanup block)))
-	  (do ((cup (find-enclosing-cleanup cleanup)
-		    (find-enclosing-cleanup (cleanup-enclosing cup))))
-	      ((null cup))
-	    (when (eq (node-block (continuation-use (cleanup-start cup)))
-		      new-block)
-	      (do ((cup (find-enclosing-cleanup (cleanup-enclosing cup))
-			(find-enclosing-cleanup (cleanup-enclosing cup))))
-		  ((null cup)
-		   (setf (block-end-cleanup block) start-cleanup)
-		   (setf (block-start-cleanup new-block) start-cleanup))
-		(let ((cb (node-block (continuation-use (cleanup-start cup)))))
-		  (unless (eq cb new-block)
-		    (setf (block-end-cleanup block) cup)
-		    (setf (block-start-cleanup new-block) cup)
-		    (return))))
-	      (return))))
-
 	(setf (block-type-asserted block) t)
 	(setf (block-test-modified block) t))))
 
@@ -646,8 +710,8 @@
 ;;;
 ;;;    This function is called by people who delete nodes; it provides a way to
 ;;; indicate that the value of a continuation is no longer used.  We null out
-;;; the Continuation-Dest, set Block-Flush-P in the blocks containing uses of
-;;; Cont and set Component-Reoptimize.
+;;; the Continuation-Dest, set Flush-P in the blocks containing uses of Cont
+;;; and set Component-Reoptimize.
 ;;;
 ;;;    If the continuation is :Deleted, then we don't do anything, since all
 ;;; semantics have already been flushed.  If the continuation is a
@@ -673,9 +737,9 @@
      (do-uses (use cont)
        (let ((prev (node-prev use)))
 	 (unless (eq (continuation-kind prev) :deleted)
-	   (let ((block (continuation-block prev)))
-	     (setf (block-flush-p block) t)
-	     (setf (block-type-asserted block) t)))))))
+	   (setf (block-attributep (block-flags (continuation-block prev))
+				   flush-p type-asserted)
+		 t))))))
 
   (setf (continuation-%type-check cont) nil)
   
@@ -716,8 +780,7 @@
     (let ((prev (node-prev use)))
       (unless (eq (continuation-kind prev) :deleted)
 	(let ((block (continuation-block prev)))
-	  (setf (block-flush-p block) t)
-	  (setf (block-type-asserted block) t)
+	  (setf (block-attributep (block-flags block) flush-p type-asserted) t)
 	  (setf (component-reoptimize (block-component block)) t)))))
 
   (let ((dest (continuation-dest cont)))
@@ -788,9 +851,13 @@
 	   (assert (member (functional-kind lambda) '(:let :mv-let)))
 	   (delete-lambda lambda))))
       (exit
-       (let ((value (exit-value node)))
+       (let ((value (exit-value node))
+	     (entry (exit-entry node)))
 	 (when value
-	   (flush-dest value))))
+	   (flush-dest value))
+	 (when entry
+	   (setf (entry-exits entry)
+		 (delete node (entry-exits entry))))))
       (creturn
        (flush-dest (return-result node))
        (delete-return node))
@@ -860,7 +927,7 @@
 	     (cond
 	      ((member block succ)
 	       (with-ir1-environment node
-		 (let ((exit (make-exit :source (node-source node)))
+		 (let ((exit (make-exit))
 		       (dummy (make-continuation)))
 		   (setf (continuation-next prev) nil)
 		   (prev-link exit prev)
@@ -869,8 +936,8 @@
 	       (setf (node-prev node) nil)
 	       nil)
 	      (t
-	       (assert (eq (find-enclosing-cleanup (block-start-cleanup block))
-			   (find-enclosing-cleanup (block-end-cleanup block))))
+	       (assert (eq (block-start-cleanup block)
+			   (block-end-cleanup block)))
 	       (unlink-blocks block next)
 	       (dolist (pred (block-pred block))
 		 (change-block-successor pred block next))
@@ -948,15 +1015,10 @@
 ;;;
 (defun find-nlx-info (entry cont)
   (declare (type entry entry) (type continuation cont))
-  (dolist (nlx (environment-nlx-info (node-environment entry)) nil)
-    (let* ((cleanup (nlx-info-cleanup nlx))
-	   (entry-cleanup (ecase (cleanup-kind cleanup)
-			    ((:catch :unwind-protect)
-			     (cleanup-enclosing cleanup))
-			    (:entry cleanup))))
+  (let ((entry-cleanup (entry-cleanup entry)))
+    (dolist (nlx (environment-nlx-info (node-environment entry)) nil)
       (when (and (eq (nlx-info-continuation nlx) cont)
-		 (eq (continuation-use (cleanup-start entry-cleanup))
-		     entry))
+		 (eq (nlx-info-cleanup nlx) entry-cleanup))
 	(return nlx)))))
 
 
@@ -967,7 +1029,7 @@
 ;;;    If Functional is a Lambda, just return it; if it is an
 ;;; optional-dispatch, return the main-entry.
 ;;;
-(proclaim '(function main-entry (functional) lambda))
+(proclaim '(function main-entry (functional) clambda))
 (defun main-entry (functional)
   (if (lambda-p functional)
       functional
@@ -1008,13 +1070,14 @@
 
 ;;; Continuation-Function-Name  --  Interface
 ;;;
-;;;    If Cont's only use is a global function reference, then return the
-;;; referenced symbol, otherwise NIL.
+;;;    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 (ref-p use)
+    (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))
@@ -1029,7 +1092,7 @@
 ;;;
 (defun let-combination (fun)
   (declare (type clambda fun))
-  (assert (eq (functional-kind fun) :let))
+  (assert (member (functional-kind fun) '(:let :mv-let)))
   (continuation-dest (node-cont (first (leaf-refs fun)))))
 
 
@@ -1056,14 +1119,41 @@
 
 ;;;; Compiler error context determination:
 
-(proclaim '(special *current-path* *current-form*))
+(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.
+;;; 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
@@ -1071,23 +1161,18 @@
 	       (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 the stringified CARs of the enclosing non-original source forms
+  ;; exceeding the *enclosing-source-cutoff*.
+  (enclosing-source nil :type list)
   ;;
-  ;; A list of prefixes of "interesting" forms that enclose original-source.
-  context
+  ;; A list of stringified enclosing non-original source forms.
+  (source nil :type list)
   ;;
-  ;; Source for a form enclosing this one, or NIL if unknown.
-  enclosing-source
+  ;; The stringified form in the original source that expanded into Source.
+  (original-source nil :type simple-string)
   ;;
-  ;; 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)))
+  ;; A list of prefixes of "interesting" forms that enclose original-source.
+  (context nil :type list))
 
   
 ;;; If true, this is the node which is used as context in compiler warning
@@ -1098,12 +1183,6 @@
 (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
@@ -1120,8 +1199,7 @@
 ;;;
 (defun find-original-source (path)
   (declare (list path))
-  (assert path)
-  (let* ((rpath (reverse (rest path)))
+  (let* ((rpath (reverse (source-path-original-source path)))
 	 (root (find-source-root (first rpath) *source-info*)))
     (collect ((context))
       (let ((form root)
@@ -1140,7 +1218,7 @@
 			 (list head
 			       (if (and (listp next)
 					(member head
-						defmumble-take-car-forms))
+						*defmumble-take-car-forms*))
 				   (car next)
 				   next))))
 		      (context (list head)))))))
@@ -1158,86 +1236,58 @@
 		       '((some strange place)))))))))
 
 
-;;; 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.  This is inhibited when
-;;; the DEST has a different source path from NODE.  This ensures that the
-;;; enclosing source results from macroexpansion of the orignal source (or is
-;;; the orignal source).  Otherwise, we might return a form enclosing the
-;;; orignal source, which would be confusing.
-;;;
-(defun find-enclosing-source (node)
-  (declare (type node node))
-  (let* ((cont (node-cont node))
-	 (dest (continuation-dest cont)))
-    (when (and dest
-	       (equal (node-source-path dest) (node-source-path node)))
-      (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)))))))))))
-	  
-
-;;; 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.")
-
-
 ;;; STRINGIFY-FORM  --  Internal
 ;;;
 ;;;    Convert a source form to a string, formatted suitably for use in
 ;;; compiler warnings.
 ;;;
-(defun stringify-form (form)
+(defun stringify-form (form &optional (pretty t))
   (let ((*print-level* *error-print-level*)
 	(*print-length* *error-print-length*)
-	(*print-circle* t))
-    (format nil "  ~S~%" form)))
-
+	(*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.
+;;; 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 ()
+(defun find-error-context (args)
   (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*)))
+	(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)
-	      (multiple-value-bind (enclosing how)
-				   (when (and context (not *current-form*))
-				     (find-enclosing-source context))
+	      (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)))
+		
 		(make-compiler-error-context
-		 :source (stringify-form source)
+		 :enclosing-source (short)
+		 :source (full)
 		 :original-source (stringify-form form)
-		 :context src-context
-		 :enclosing-source (when enclosing
-				     (stringify-form enclosing))
-		 :enclosed-how how))))))))
+		 :context src-context))))))))
 
 
 ;;;; Printing error messages:
@@ -1248,24 +1298,29 @@
 (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.
 ;;;
-(proclaim '(list *last-source-context*))
-(defvar *last-source-context* nil)
-(defvar *last-original-source* nil)
-(defvar *last-source-form* nil)
-(defvar *last-enclosing-source* nil)
 (defvar *last-format-string* nil)
 (defvar *last-format-args* nil)
-(defvar *last-message-count* 0)
+(proclaim '(type (or string null) *last-format-string*))
+(proclaim '(type list *last-format-args*))
 
-;;; 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*))
+;;; 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
@@ -1299,52 +1354,53 @@
   (let* ((*print-level* *error-print-level*)
 	 (*print-length* *error-print-length*)
 	 (stream *compiler-error-output*)
-	 (context (find-error-context)))
+	 (context (find-error-context format-args)))
     
     (unless stream (return-from print-error-message (undefined-value)))
     
     (cond
      (context
-      (let ((context (compiler-error-context-context context))
+      (let ((in (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)))
+	    (source (compiler-error-context-source context))
+	    (last *last-error-context*))
 	
-	(unless (equal context *last-source-context*)
+	(unless (and last
+		     (equal in (compiler-error-context-context last)))
 	  (note-message-repeats)
-	  (setq *last-source-context* context)
-	  (setq *last-original-source* nil)
-	  (format stream "~2&In:~{~<~%   ~4:;~{ ~S~}~>~^ =>~}~%" context))
+	  (setq last nil)
+	  (format stream "~2&In:~{~<~%   ~4:;~{ ~S~}~>~^ =>~}~%" in))
 	
-	(unless (equal form *last-original-source*)
+	(unless (and last
+		     (string= form
+			      (compiler-error-context-original-source last)))
 	  (note-message-repeats)
-	  (setq *last-original-source* form)
-	  (setq *last-enclosing-source* nil)
-	  (setq *last-format-string* nil)
+	  (setq last nil)
 	  (write-string form stream))
 	
-	(unless (equal source form)
-	  (unless (or (equal enclosing *last-enclosing-source*)
-		      (equal enclosing form))
+	(unless (and last
+		     (equal enclosing
+			    (compiler-error-context-enclosing-source last)))
+	  (when enclosing
 	    (note-message-repeats)
-	    (setq *last-source-form* nil)
-	    (setq *last-enclosing-source* enclosing)
-	    (when enclosing
-	      (write-line "==>" stream)
-	      (write-string enclosing stream)))
-	  
-	  (unless (tree-equal source *last-source-form*)
+	    (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
 	    (note-message-repeats)
-	    (setq *last-source-form* source)
-	    (setq *last-format-string* nil)
-	    (if *last-enclosing-source*
-		(format stream "The ~A:~%" how)
-		(write-line "==>" stream))
-	    (write-string source stream)))))
+	    (dolist (src source)
+	      (write-line "==>" stream)
+	      (write-string src stream))))))
      (t
       (note-message-repeats)
+      (setq *last-format-string* nil)
       (format stream "~2&")))
+
+    (setq *last-error-context* context)
     
     (unless (and (equal format-string *last-format-string*)
 		 (tree-equal format-args *last-format-args*))
@@ -1408,8 +1464,7 @@
 (proclaim '(function compiler-mumble (string &rest t) void))
 (defun compiler-mumble (format-string &rest format-args)
   (note-message-repeats)
-  (setq *last-source-context* nil)
-  (setq *last-format-string* nil)
+  (setq *last-error-context* nil)
   (apply #'format *compiler-error-output* format-string format-args)
   (force-output *compiler-error-output*))
 
@@ -1466,7 +1521,7 @@
     (unless found (push res *undefined-warnings*))
     (when (or (not *undefined-warning-limit*)
 	      (< (undefined-warning-count res) *undefined-warning-limit*))
-	(push (find-error-context)
+	(push (find-error-context (list name))
 	      (undefined-warning-warnings res)))
     (incf (undefined-warning-count res)))
   (undefined-value))
-- 
GitLab