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 560e5d87b397b0e5c1ef95f5c3e18521a7e5a123..9f0888a8656bb96570b9d3b76e8b640844fc0daa 100644 (file)
--- 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 24517a9282f3c193db1e48597e9ab05f74106865..47b51877b8133b977823de2202122a6226a265ce 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 719666004e8ef550f66f1d3f6b85e0944a659175..3fb4cdc80e6ac2e5f2a4d25a5a130153199279c4 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 7c62ad20521030409ad1673742caee919458152b..3d564af0d2556b665f1e09f87626e13a66c4a614 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 c71291d7a6766d21fc59a7c27c07910620aa7584..6bd1d5d4aa764d9beec6d65e4607d959096a2644 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.