From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Wed, 18 Jan 2017 22:02:15 +0000 (-0700)
Subject: Suppress microcode error reports during tests.
X-Git-Tag: mit-scheme-pucked-9.2.12~239
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=6f05825648920b9a240f0732a930a9e371942d02;p=mit-scheme.git

Suppress microcode error reports during tests.

Many such reports clutter `make check's output when the mirocode was
built with --enable-debugging.
---

diff --git a/src/microcode/debug.c b/src/microcode/debug.c
index ca6b9d430..7c7cd293f 100644
--- a/src/microcode/debug.c
+++ b/src/microcode/debug.c
@@ -1290,9 +1290,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 *
@@ -1315,6 +1315,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);
     }
@@ -1340,6 +1341,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 e69eca649..6c12e31f1 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 4b0cf1e18..959b15f46 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 3b03b3c88..4e47c76ae 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 37d5e08a4..a9049ec6d 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.