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 ca6b9d430c3b96a111b14e990421b62606e2420d..7c7cd293f13de5ecff4ed8a99163d6518067c703 100644 (file)
--- 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 e69eca649e5e7c79ebbab6c59b613c8e19cc482f..6c12e31f1557da66b59038d8565ab2b13b40d5ff 100644 (file)
--- 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 4b0cf1e18ddd84c4fe93c421f45a81ed07a3e290..959b15f462e080af69d8870afac707750791591f 100644 (file)
--- 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 3b03b3c880cd08337571d20f59cbbe34de476b20..4e47c76aefdc3c26fb768dc142a4ab2e297e7442 100644 (file)
--- 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 37d5e08a4e82385f2409df8c6433a64c08a52e4f..a9049ec6dff7021ca099f787dee74e27f19d36b8 100644 (file)
--- a/tests/check.scm
+++ b/tests/check.scm
@@ -30,6 +30,11 @@ USA.
 
 (declare (usual-integrations))
 \f
+;;; 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.