From b2d2a0ef198dcb17d3fd72efefd52b8ed6e2b891 Mon Sep 17 00:00:00 2001
From: Matt Birkholz <matt@birchwood-abbey.net>
Date: Thu, 12 Jan 2017 15:12:10 -0700
Subject: [PATCH] Suppress microcode error reports during tests.

Many such reports clutter `make check's output when the mirocode was
built with --enable-debugging.
---
 src/microcode/debug.c   |  6 +++--
 src/microcode/extern.h  |  4 +++-
 src/microcode/storage.c |  3 ++-
 src/microcode/utils.c   | 49 ++++++++++++++++++++++-------------------
 tests/check.scm         |  5 +++++
 5 files changed, 40 insertions(+), 27 deletions(-)

diff --git a/src/microcode/debug.c b/src/microcode/debug.c
index 560e5d87b..9f0888a86 100644
--- a/src/microcode/debug.c
+++ b/src/microcode/debug.c
@@ -1291,9 +1291,9 @@ Returns #T if the scan was successful and #F if there were any complaints.")
 #define D_TRACE_ON_ERROR	12
 #define D_PER_FILE		13
 #define D_BIGNUM		14
-
+#define D_PRINT_ERRORS		15
 #ifndef LAST_SWITCH
-#define LAST_SWITCH D_BIGNUM
+#define LAST_SWITCH D_PRINT_ERRORS
 #endif
 
 static bool *
@@ -1316,6 +1316,7 @@ find_flag (int flag_number)
     case D_TRACE_ON_ERROR:	return (&Trace_On_Error);
     case D_PER_FILE:		return (&Per_File);
     case D_BIGNUM:		return (&Bignum_Debug);
+    case D_PRINT_ERRORS:	return (&Print_Errors);
     MORE_DEBUG_FLAG_CASES ();
     default:			return (0);
     }
@@ -1341,6 +1342,7 @@ flag_name (int flag_number)
     case D_TRACE_ON_ERROR:	return ("Trace_On_Error");
     case D_PER_FILE:		return ("Per_File");
     case D_BIGNUM:		return ("Bignum_Debug");
+    case D_PRINT_ERRORS:	return ("Print_Errors");
     MORE_DEBUG_FLAG_NAMES ();
     default:			return ("Unknown Debug Flag");
     }
diff --git a/src/microcode/extern.h b/src/microcode/extern.h
index 24517a928..47b51877b 100644
--- a/src/microcode/extern.h
+++ b/src/microcode/extern.h
@@ -107,10 +107,11 @@ extern void set_ulong_register (unsigned int, unsigned long);
    extern bool Lookup_Debug;
    extern bool GC_Debug;
    extern bool Upgrade_Debug;
-   extern bool Trace_On_Error;
    extern bool Dump_Debug;
+   extern bool Trace_On_Error;
    extern bool Per_File;
    extern bool Bignum_Debug;
+   extern bool Print_Errors;
 
    extern bool verify_heap (void);
    extern void Pop_Return_Break_Point (void);
@@ -136,6 +137,7 @@ extern void set_ulong_register (unsigned int, unsigned long);
 #  define Dump_Debug 0
 #  define Per_File 0
 #  define Bignum_Debug 0
+#  define Print_Errors 0
 #endif
 
 extern SCHEME_OBJECT * Free;
diff --git a/src/microcode/storage.c b/src/microcode/storage.c
index 719666004..3fb4cdc80 100644
--- a/src/microcode/storage.c
+++ b/src/microcode/storage.c
@@ -110,8 +110,9 @@ bool ephemeron_request_hard_p;
    bool Upgrade_Debug = false;
    bool Dump_Debug = false;
    bool Trace_On_Error = false;
-   bool Bignum_Debug = false;
    bool Per_File = false;
+   bool Bignum_Debug = false;
+   bool Print_Errors = true;
    unsigned int debug_slotno = 0;
    unsigned int debug_nslots = 0;
    unsigned int local_slotno = 0;
diff --git a/src/microcode/utils.c b/src/microcode/utils.c
index 7c62ad205..3d564af0d 100644
--- a/src/microcode/utils.c
+++ b/src/microcode/utils.c
@@ -537,34 +537,37 @@ Do_Micro_Error (long error_code, bool from_pop_return_p)
   SCHEME_OBJECT handler = SHARP_F;
 
 #ifdef ENABLE_DEBUGGING_TOOLS
-  err_print (error_code, ERROR_OUTPUT);
-  if ((GET_RC == RC_INTERNAL_APPLY)
-      || (GET_RC == RC_INTERNAL_APPLY_VAL))
+  if (Print_Errors)
     {
-      Print_Expression (STACK_REF(CONTINUATION_SIZE + STACK_ENV_FUNCTION),
-			"Procedure");
-      outf_error ("\n");
-      {
-	int i, nargs = (APPLY_FRAME_HEADER_N_ARGS
-			(STACK_REF(CONTINUATION_SIZE + STACK_ENV_HEADER)));
-	for (i = 0; i < nargs; i += 1)
+      err_print (error_code, ERROR_OUTPUT);
+      if ((GET_RC == RC_INTERNAL_APPLY)
+	  || (GET_RC == RC_INTERNAL_APPLY_VAL))
+	{
+	  Print_Expression (STACK_REF(CONTINUATION_SIZE + STACK_ENV_FUNCTION),
+			    "Procedure");
+	  outf_error ("\n");
 	  {
-	    outf_error ("Argument %d: ", i+1);
-	    Print_Expression ((STACK_REF(CONTINUATION_SIZE
-					 + STACK_ENV_FIRST_ARG + i)), "");
-	    outf_error ("\n");
+	    int i, nargs = (APPLY_FRAME_HEADER_N_ARGS
+			    (STACK_REF(CONTINUATION_SIZE + STACK_ENV_HEADER)));
+	    for (i = 0; i < nargs; i += 1)
+	      {
+		outf_error ("Argument %d: ", i+1);
+		Print_Expression ((STACK_REF(CONTINUATION_SIZE
+					     + STACK_ENV_FIRST_ARG + i)), "");
+		outf_error ("\n");
+	      }
 	  }
-      }
-    }
-  else
-    {
-      Print_Expression (GET_EXP, "Expression");
-      outf_error ("\n");
-      Print_Expression (GET_ENV, "Environment");
+	}
+      else
+	{
+	  Print_Expression (GET_EXP, "Expression");
+	  outf_error ("\n");
+	  Print_Expression (GET_ENV, "Environment");
+	  outf_error ("\n");
+	}
+      Print_Return ("Return code");
       outf_error ("\n");
     }
-  Print_Return ("Return code");
-  outf_error ("\n");
 #endif
 
   if (Trace_On_Error)
diff --git a/tests/check.scm b/tests/check.scm
index c71291d7a..6bd1d5d4a 100644
--- a/tests/check.scm
+++ b/tests/check.scm
@@ -30,6 +30,11 @@ USA.
 
 (declare (usual-integrations))
 
+;;; Suppress useless (expected) error reports from a ucode that has
+;;; --enabled-debugging.
+(if ((make-primitive-procedure 'get-primitive-address) 'set-debug-flags! #f)
+    ((make-primitive-procedure 'set-debug-flags!) 15 #f)) ;D_PRINT_ERRORS
+
 ;;; Can't just look at */test-*.scm because not everything has been
 ;;; converted to use the automatic framework.
 
-- 
2.25.1