home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / microcode / debug.c < prev    next >
C/C++ Source or Header  |  2001-03-08  |  26KB  |  1,036 lines
  1. /* -*-C-*-
  2.  
  3. $Id: debug.c,v 9.52 2001/03/08 18:00:18 cph Exp $
  4.  
  5. Copyright (c) 1987-2000 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. */
  21.  
  22. /* Utilities to help with debugging */
  23.  
  24. #include "scheme.h"
  25. #include "prims.h"
  26. #include "trap.h"
  27. #include "lookup.h"
  28.  
  29. static void EXFUN (do_printing, (outf_channel, SCHEME_OBJECT, Boolean));
  30. static Boolean EXFUN (print_primitive_name, (outf_channel, SCHEME_OBJECT));
  31. static void EXFUN (print_expression, (outf_channel, SCHEME_OBJECT, char *));
  32.  
  33. /* Compiled Code Debugging */
  34.  
  35. static SCHEME_OBJECT
  36. DEFUN (compiled_block_debug_filename, (block), SCHEME_OBJECT block)
  37. {
  38.   extern SCHEME_OBJECT EXFUN (compiled_block_debugging_info, (SCHEME_OBJECT));
  39.   SCHEME_OBJECT info;
  40.  
  41.   info = (compiled_block_debugging_info (block));
  42.   return
  43.     (((STRING_P (info)) ||
  44.       ((PAIR_P (info)) &&
  45.        (STRING_P (PAIR_CAR (info))) &&
  46.        (FIXNUM_P (PAIR_CDR (info)))))
  47.      ? info
  48.      : SHARP_F);
  49. }
  50.  
  51. extern void
  52.   EXFUN (compiled_entry_type, (SCHEME_OBJECT, long *));
  53.  
  54. extern long
  55.   EXFUN (compiled_entry_closure_p, (SCHEME_OBJECT)),
  56.   EXFUN (compiled_entry_to_block_offset, (SCHEME_OBJECT));
  57.  
  58. extern SCHEME_OBJECT
  59.   * EXFUN (compiled_entry_to_block_address, (SCHEME_OBJECT)),
  60.   EXFUN (compiled_closure_to_entry, (SCHEME_OBJECT));
  61.  
  62. #define COMPILED_ENTRY_TO_BLOCK(entry)                    \
  63. (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK,                \
  64.               (compiled_entry_to_block_address (entry))))
  65.  
  66. static SCHEME_OBJECT
  67. DEFUN (compiled_entry_debug_filename, (entry), SCHEME_OBJECT entry)
  68. {
  69.   long results [3];
  70.  
  71.   compiled_entry_type (entry, (& (results [0])));
  72.   if (((results [0]) == 0) && (compiled_entry_closure_p (entry)))
  73.     entry = (compiled_closure_to_entry (entry));
  74.   return (compiled_block_debug_filename (COMPILED_ENTRY_TO_BLOCK (entry)));
  75. }
  76.  
  77. char *
  78. DEFUN (compiled_entry_filename, (entry), SCHEME_OBJECT entry)
  79. {
  80.   SCHEME_OBJECT result;
  81.  
  82.   result = (compiled_entry_debug_filename (entry));
  83.   if (STRING_P (result))
  84.     return ((char *) (STRING_LOC ((result), 0)));
  85.   else if (PAIR_P (result))
  86.     return ((char *) (STRING_LOC ((PAIR_CAR (result)), 0)));
  87.   else
  88.     return ("**** filename not known ****");
  89. }
  90.  
  91. void
  92. DEFUN_VOID (Show_Pure)
  93. {
  94.   SCHEME_OBJECT *Obj_Address;
  95.   long Pure_Size, Total_Size;
  96.  
  97.   Obj_Address = Constant_Space;
  98.   while (true)
  99.   {
  100.     if (Obj_Address > Free_Constant)
  101.     {
  102.       outf_console ("Past end of area.\n");
  103.       return;
  104.     }
  105.     if (Obj_Address == Free_Constant)
  106.     {
  107.       outf_console ("Done.\n");
  108.       return;
  109.     }
  110.     Pure_Size = OBJECT_DATUM (*Obj_Address);
  111.     Total_Size = OBJECT_DATUM (Obj_Address[1]);
  112.     outf_console ("0x%lx: pure=0x%lx, total=0x%lx\n",
  113.         ((long) Obj_Address), ((long) Pure_Size), ((long) Total_Size));
  114.     if (OBJECT_TYPE (*Obj_Address) != TC_MANIFEST_SPECIAL_NM_VECTOR)
  115.     {
  116.       outf_console ("Missing initial SNMV.\n");
  117.       return;
  118.     }
  119.     if (OBJECT_TYPE (Obj_Address[1]) != PURE_PART)
  120.     {
  121.       outf_console ("Missing subsequent pure header.\n");
  122.     }
  123.     if (OBJECT_TYPE (Obj_Address[Pure_Size-1]) !=
  124.         TC_MANIFEST_SPECIAL_NM_VECTOR)
  125.     {
  126.       outf_console ("Missing internal SNMV.\n");
  127.       return;
  128.     }
  129.     if (OBJECT_TYPE (Obj_Address[Pure_Size]) != CONSTANT_PART)
  130.     {
  131.       outf_console ("Missing constant header.\n");
  132.       return;
  133.     }
  134.     if (((long) (OBJECT_DATUM (Obj_Address[Pure_Size]))) != Pure_Size)
  135.     {
  136.       outf_console ("Pure size mismatch 0x%lx.\n",
  137.           ((long) (OBJECT_DATUM (Obj_Address[Pure_Size]))));
  138.     }
  139.     if (OBJECT_TYPE (Obj_Address[Total_Size-1]) !=
  140.         TC_MANIFEST_SPECIAL_NM_VECTOR)
  141.     {
  142.       outf_console ("Missing ending SNMV.\n");
  143.       return;
  144.     }
  145.     if (OBJECT_TYPE (Obj_Address[Total_Size]) != END_OF_BLOCK)
  146.     {
  147.       outf_console ("Missing ending header.\n");
  148.       return;
  149.     }
  150.     if (((long) (OBJECT_DATUM (Obj_Address[Total_Size]))) != Total_Size)
  151.     {
  152.       outf_console ("Total size mismatch 0x%lx.\n",
  153.           ((long) (OBJECT_DATUM (Obj_Address[Total_Size]))));
  154.     }
  155.     Obj_Address += Total_Size+1;
  156. #ifdef FLOATING_ALIGNMENT
  157.     while (*Obj_Address == MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0))
  158.     {
  159.       Obj_Address += 1;
  160.     }
  161. #endif
  162.   }
  163. }
  164.  
  165. void
  166. DEFUN (Show_Env, (The_Env), SCHEME_OBJECT The_Env)
  167. {
  168.   SCHEME_OBJECT *name_ptr, procedure, *value_ptr, extension;
  169.   long count, i;
  170.  
  171.   procedure = MEMORY_REF (The_Env, ENVIRONMENT_FUNCTION);
  172.   value_ptr = MEMORY_LOC (The_Env, ENVIRONMENT_FIRST_ARG);
  173.  
  174.   if (OBJECT_TYPE (procedure) == AUX_LIST_TYPE)
  175.   {
  176.     extension = procedure;
  177.     procedure = FAST_MEMORY_REF (extension, ENV_EXTENSION_PROCEDURE);
  178.   }
  179.   else
  180.     extension = SHARP_F;
  181.  
  182.   if ((OBJECT_TYPE (procedure) != TC_PROCEDURE) &&
  183.       (OBJECT_TYPE (procedure) != TC_EXTENDED_PROCEDURE))
  184.   {
  185.     outf_console ("Not created by a procedure");
  186.     return;
  187.   }
  188.   name_ptr = MEMORY_LOC (procedure, PROCEDURE_LAMBDA_EXPR);
  189.   name_ptr = MEMORY_LOC (*name_ptr, LAMBDA_FORMALS);
  190.   count = VECTOR_LENGTH (*name_ptr) - 1;
  191.  
  192.   name_ptr = MEMORY_LOC (*name_ptr, 2);
  193.   for (i = 0; i < count; i++)
  194.   {
  195.     Print_Expression (*name_ptr++, "Name ");
  196.     Print_Expression (*value_ptr++, " Value ");
  197.     outf_console ("\n");
  198.   }
  199.   if (extension != SHARP_F)
  200.   {
  201.     outf_console ("Auxilliary Variables\n");
  202.     count = OBJECT_DATUM (MEMORY_REF (extension, AUX_LIST_COUNT));
  203.     for (i = 0, name_ptr = MEMORY_LOC (extension, AUX_LIST_FIRST);
  204.      i < count;
  205.      i++, name_ptr++)
  206.     {
  207.       Print_Expression ((PAIR_CAR (*name_ptr)), "Name ");
  208.       Print_Expression ((PAIR_CDR (*name_ptr)), " Value ");
  209.       outf_console ("\n");
  210.     }
  211.   }
  212. }
  213.  
  214. static void
  215. DEFUN (print_list, (stream, pair), outf_channel stream AND SCHEME_OBJECT pair)
  216. {
  217.   int count;
  218.  
  219.   outf (stream, "(");
  220.   count = 0;
  221.   while (((PAIR_P (pair)) || (WEAK_PAIR_P (pair))) && (count < MAX_LIST_PRINT))
  222.     {
  223.       if (count > 0)
  224.     outf (stream, " ");
  225.       print_expression (stream,
  226.             (PAIR_CAR (pair)),
  227.             ((WEAK_PAIR_P (pair)) ? "{weak}" : ""));
  228.       pair = (PAIR_CDR (pair));
  229.       count += 1;
  230.     }
  231.   if (pair != EMPTY_LIST)
  232.     {
  233.       if (count == MAX_LIST_PRINT)
  234.     outf (stream, " ...");
  235.       else
  236.     {
  237.       outf (stream, " . ");
  238.       print_expression (stream, pair, "");
  239.     }
  240.     }
  241.   outf (stream, ")");
  242.   return;
  243. }
  244.  
  245. static void
  246. DEFUN (print_return_name, (stream, Ptr), outf_channel stream AND SCHEME_OBJECT Ptr)
  247. {
  248.   long index;
  249.   char * name;
  250.  
  251.   index = (OBJECT_DATUM (Ptr));
  252.   if (index <= MAX_RETURN)
  253.     {
  254.       name = (Return_Names [index]);
  255.       if ((name != ((char *) 0)) &&
  256.       ((name [0]) != '\0'))
  257.     {
  258.       outf (stream, "%s", name);
  259.       return;
  260.     }
  261.     }
  262.   outf (stream, "[0x%lx]", index);
  263.   return;
  264. }
  265.  
  266. void
  267. DEFUN (Print_Return, (String), char * String)
  268. {
  269.   outf_console ("%s: ", String);
  270.   print_return_name (console_output, Fetch_Return ());
  271.   outf_console ("\n");
  272. }
  273.  
  274. static void
  275. DEFUN (print_string, (stream, string), outf_channel stream AND SCHEME_OBJECT string)
  276. {
  277.   long length;
  278.   long i;
  279.   char * next;
  280.   char this;
  281.  
  282.   outf (stream, "\"");
  283.   length = (STRING_LENGTH (string));
  284.   next = ((char *) (STRING_LOC (string, 0)));
  285.   for (i = 0; (i < length); i += 1)
  286.     {
  287.       this = (*next++);
  288.       switch (this)
  289.     {
  290.     case '\\':
  291.       outf (stream, "\\\\");
  292.       break;
  293.     case '"':
  294.       outf (stream, "\\\"");
  295.       break;
  296.     case '\t':
  297.       outf (stream, "\\t");
  298.       break;
  299.     case '\n':
  300.       outf (stream, "\\n");
  301.       break;
  302.     case '\f':
  303.       outf (stream, "\\f");
  304.       break;
  305.     default:
  306.       if ((this >= ' ') && (this <= '~'))
  307.         outf (stream, "%c", this);
  308.       else
  309.         outf (stream, "\\%03o", this);
  310.       break;
  311.     }
  312.     }
  313.   outf (stream, "\"");
  314.   return;
  315. }
  316.  
  317. static void
  318. DEFUN (print_symbol, (stream, symbol), outf_channel stream AND SCHEME_OBJECT symbol)
  319. {
  320.   SCHEME_OBJECT string;
  321.   long length;
  322.   long i;
  323.   char * next;
  324.  
  325.   string = (MEMORY_REF (symbol, SYMBOL_NAME));
  326.   length = (STRING_LENGTH (string));
  327.   next = ((char *) (STRING_LOC (string, 0)));
  328.   for (i = 0; (i < length); i += 1)
  329.     outf(stream, "%c", *next++);  /*should use %s? */
  330.   return;
  331. }
  332.  
  333. static void
  334. DEFUN (print_filename, (stream, filename),
  335.        outf_channel stream AND SCHEME_OBJECT filename)
  336. {
  337.   long length;
  338.   char * scan;
  339.   char * end;
  340.   char * slash;
  341.  
  342.   length = (STRING_LENGTH (filename));
  343.   scan = ((char *) (STRING_LOC (filename, 0)));
  344.   end = (scan + length);
  345.   slash = scan;
  346.   while (scan < end)
  347.     if ((*scan++) == '/')
  348.       slash = scan;
  349.   outf (stream, "\"%s\"", slash);
  350.   return;
  351. }
  352.  
  353. static void
  354. DEFUN (print_object, (object), SCHEME_OBJECT object)
  355. {
  356.   do_printing (console_output, object, true);
  357.   outf_console ("\n");
  358.   outf_flush_console();
  359.   return;
  360. }
  361.  
  362. DEFINE_PRIMITIVE ("DEBUGGING-PRINTER", Prim_debugging_printer, 1, 1,
  363.   "A cheap, built-in printer intended for debugging the interpreter.")
  364. {
  365.   PRIMITIVE_HEADER (1);
  366.  
  367.   print_object (ARG_REF (1));
  368.   return (SHARP_F);
  369. }
  370.  
  371. static void
  372. DEFUN (print_objects, (objects, n),
  373.        SCHEME_OBJECT * objects AND int n)
  374. {
  375.   SCHEME_OBJECT * scan;
  376.   SCHEME_OBJECT * end;
  377.  
  378.   scan = objects;
  379.   end = (objects + n);
  380.   while (scan < end)
  381.     {
  382.       outf_console ("%4x: ", (((char *) scan) - ((char *) objects)));
  383.       do_printing (console_output, (*scan++), true);
  384.       outf_console ("\n");
  385.     }
  386.   outf_flush_console();
  387.   return;
  388. }
  389.  
  390. /* This is useful because `do_printing' doesn't print the contents of
  391.    vectors.  The reason that it doesn't is because vectors are used to
  392.    represent named structures, and most named structures don't want to
  393.    be printed out explicitly.  */
  394.  
  395. void
  396. DEFUN (Print_Vector, (vector), SCHEME_OBJECT vector)
  397. {
  398.   print_objects
  399.     ((MEMORY_LOC (vector, 1)), (OBJECT_DATUM (VECTOR_LENGTH (vector))));
  400. }
  401.  
  402. static void
  403. DEFUN (print_expression, (stream, expression, string),
  404.        outf_channel stream AND SCHEME_OBJECT expression AND char * string)
  405. {
  406.   if ((string [0]) != 0)
  407.     outf (stream, "%s: ", string);
  408.   do_printing (stream, expression, true);
  409.   return;
  410. }
  411.  
  412. void
  413. DEFUN (Print_Expression, (expression, string),
  414.        SCHEME_OBJECT expression AND char * string)
  415. {
  416.   print_expression (console_output, expression, string);
  417.   return;
  418. }
  419.  
  420. extern char * Type_Names [];
  421.  
  422. static void
  423. DEFUN (do_printing, (stream, Expr, Detailed),
  424.        outf_channel stream AND SCHEME_OBJECT Expr AND Boolean Detailed)
  425. {
  426.   long Temp_Address;
  427.   Boolean handled_p;
  428.  
  429.   Temp_Address = (OBJECT_DATUM (Expr));
  430.   handled_p = false;
  431.  
  432.   if (Expr == EMPTY_LIST)    { outf (stream, "()");    return; }
  433.   else if (Expr == SHARP_F)    { outf (stream, "#F");    return; }
  434.   else if (Expr == SHARP_T)    { outf (stream, "#T");    return; }
  435.   else if (Expr == UNSPECIFIC)    { outf (stream, "[UNSPECIFIC]"); return; }
  436.  
  437.   switch (OBJECT_TYPE (Expr))
  438.     {
  439.     case TC_ACCESS:
  440.       {
  441.     outf (stream, "[ACCESS (");
  442.     Expr = (MEMORY_REF (Expr, ACCESS_NAME));
  443.       SPrint:
  444.     print_symbol (stream, Expr);
  445.     handled_p = true;
  446.     outf (stream, ")");
  447.     break;
  448.       }
  449.  
  450.     case TC_ASSIGNMENT:
  451.       outf (stream, "[SET! (");
  452.       Expr = (MEMORY_REF ((MEMORY_REF (Expr, ASSIGN_NAME)), VARIABLE_SYMBOL));
  453.       goto SPrint;
  454.  
  455.     case TC_CHARACTER_STRING:
  456.       print_string (stream, Expr);
  457.       return;
  458.  
  459.     case TC_DEFINITION:
  460.       outf (stream, "[DEFINE (");
  461.       Expr = (MEMORY_REF (Expr, DEFINE_NAME));
  462.       goto SPrint;
  463.  
  464.     case_TC_FIXNUMs:
  465.       outf (stream, "%ld", ((long) (FIXNUM_TO_LONG (Expr))));
  466.       return;
  467.  
  468.     case TC_BIG_FLONUM:
  469.       outf (stream, "%lf", (FLONUM_TO_DOUBLE (Expr)));
  470.       return;
  471.  
  472.     case TC_WEAK_CONS:
  473.     case TC_LIST:
  474.       print_list (stream, Expr);
  475.       return;
  476.  
  477.     case TC_NULL:
  478.       break;
  479.  
  480.     case TC_UNINTERNED_SYMBOL:
  481.       outf (stream, "[UNINTERNED_SYMBOL (");
  482.       goto SPrint;
  483.  
  484.     case TC_INTERNED_SYMBOL:
  485.       print_symbol (stream, Expr);
  486.       return;
  487.  
  488.     case TC_VARIABLE:
  489.       Expr = (MEMORY_REF (Expr, VARIABLE_SYMBOL));
  490.       if (Detailed)
  491.     {
  492.       outf (stream, "[VARIABLE (");
  493.       goto SPrint;
  494.     }
  495.       print_symbol (stream, Expr);
  496.       return;
  497.  
  498.     case TC_COMBINATION:
  499.       outf (stream, "[COMBINATION (%ld args) 0x%lx]",
  500.           ((long) ((VECTOR_LENGTH (Expr)) - 1)),
  501.           ((long) Temp_Address));
  502.       if (Detailed)
  503.     {
  504.       outf (stream, " (");
  505.       do_printing (stream, (MEMORY_REF (Expr, COMB_FN_SLOT)), false);
  506.       outf (stream, " ...)");
  507.     }
  508.       return;
  509.  
  510.     case TC_COMBINATION_1:
  511.       outf (stream, "[COMBINATION_1 0x%lx]", ((long) Temp_Address));
  512.       if (Detailed)
  513.     {
  514.       outf (stream, " (");
  515.       do_printing (stream, (MEMORY_REF (Expr, COMB_1_FN)), false);
  516.       outf (stream, ", ");
  517.       do_printing (stream, (MEMORY_REF (Expr, COMB_1_ARG_1)), false);
  518.       outf (stream, ")");
  519.     }
  520.       return;
  521.  
  522.     case TC_COMBINATION_2:
  523.       outf (stream, "[COMBINATION_2 0x%lx]", ((long) Temp_Address));
  524.       if (Detailed)
  525.     {
  526.       outf (stream, " (");
  527.       do_printing (stream, (MEMORY_REF (Expr, COMB_2_FN)), false);
  528.       outf (stream, ", ");
  529.       do_printing (stream, (MEMORY_REF (Expr, COMB_2_ARG_1)), false);
  530.       outf (stream, ", ");
  531.       do_printing (stream, (MEMORY_REF (Expr, COMB_2_ARG_2)), false);
  532.       outf (stream, ")");
  533.     }
  534.       return;
  535.  
  536.     case TC_ENVIRONMENT:
  537.       {
  538.     SCHEME_OBJECT procedure;
  539.  
  540.     outf (stream, "[ENVIRONMENT 0x%lx]", ((long) Temp_Address));
  541.     outf (stream, " (from ");
  542.     procedure = (MEMORY_REF (Expr, ENVIRONMENT_FUNCTION));
  543.     if ((OBJECT_TYPE (procedure)) == TC_QUAD)
  544.       procedure = (MEMORY_REF (procedure, ENV_EXTENSION_PROCEDURE));
  545.     do_printing (stream, procedure, false);
  546.     outf (stream, ")");
  547.     return;
  548.       }
  549.  
  550.     case TC_EXTENDED_LAMBDA:
  551.       if (Detailed)
  552.     outf (stream, "[EXTENDED_LAMBDA (");
  553.       do_printing (stream,
  554.            (MEMORY_REF ((MEMORY_REF (Expr, ELAMBDA_NAMES)), 1)),
  555.            false);
  556.       if (Detailed)
  557.     outf (stream, ") 0x%lx", ((long) Temp_Address));
  558.       return;
  559.  
  560.     case TC_EXTENDED_PROCEDURE:
  561.       if (Detailed)
  562.     outf (stream, "[EXTENDED_PROCEDURE (");
  563.       do_printing (stream, (MEMORY_REF (Expr, PROCEDURE_LAMBDA_EXPR)), false);
  564.       if (Detailed)
  565.     outf (stream, ") 0x%lx]", ((long) Temp_Address));
  566.       break;
  567.  
  568.     case TC_LAMBDA:
  569.       if (Detailed)
  570.     outf (stream, "[LAMBDA (");
  571.       do_printing (stream,
  572.            (MEMORY_REF ((MEMORY_REF (Expr, LAMBDA_FORMALS)), 1)),
  573.           false);
  574.       if (Detailed)
  575.     outf (stream, ") 0x%lx]", ((long) Temp_Address));
  576.       return;
  577.  
  578.     case TC_PRIMITIVE:
  579.       outf (stream, "[PRIMITIVE ");
  580.       print_primitive_name (stream, Expr);
  581.       outf (stream, "]");
  582.       return;
  583.  
  584.     case TC_PROCEDURE:
  585.       if (Detailed)
  586.     outf (stream, "[PROCEDURE (");
  587.       do_printing (stream, (MEMORY_REF (Expr, PROCEDURE_LAMBDA_EXPR)), false);
  588.       if (Detailed)
  589.     outf (stream, ") 0x%lx]", ((long) Temp_Address));
  590.       return;
  591.  
  592.     case TC_REFERENCE_TRAP:
  593.       {
  594.     if ((OBJECT_DATUM (Expr)) <= TRAP_MAX_IMMEDIATE)
  595.       break;
  596.     outf (stream, "[REFERENCE-TRAP");
  597.     print_expression (stream, (MEMORY_REF (Expr, TRAP_TAG)), " tag");
  598.     print_expression (stream, (MEMORY_REF (Expr, TRAP_EXTRA)), " extra");
  599.     outf (stream, "]");
  600.     return;
  601.       }
  602.  
  603.     case TC_RETURN_CODE:
  604.       outf (stream, "[RETURN_CODE ");
  605.       print_return_name (stream, Expr);
  606.       outf (stream, "]");
  607.       return;
  608.  
  609.     case TC_CONSTANT:
  610.       break;
  611.  
  612.     case TC_COMPILED_ENTRY:
  613.       {
  614.     long results [3];
  615.     char * type_string;
  616.     SCHEME_OBJECT filename;
  617.     SCHEME_OBJECT entry;
  618.     Boolean closure_p;
  619.  
  620.     entry = Expr;
  621.     closure_p = false;
  622.     compiled_entry_type (entry, (& (results [0])));
  623.     switch (results [0])
  624.       {
  625.       case 0:
  626.         if (compiled_entry_closure_p (entry))
  627.           {
  628.         type_string = "COMPILED_CLOSURE";
  629.         entry = (compiled_closure_to_entry (entry));
  630.         closure_p = true;
  631.           }
  632.         else
  633.           type_string = "COMPILED_PROCEDURE";
  634.         break;
  635.       case 1:
  636.         type_string = "COMPILED_RETURN_ADDRESS";
  637.         break;
  638.       case 2:
  639.         type_string = "COMPILED_EXPRESSION";
  640.         break;
  641.       default:
  642.         type_string = "COMPILED_ENTRY";
  643.         break;
  644.       }
  645.  
  646.     outf (stream, "[%s offset: 0x%lx entry: 0x%lx",
  647.          type_string,
  648.          ((long) (compiled_entry_to_block_offset (entry))),
  649.          ((long) (OBJECT_DATUM (entry))));
  650.     if (closure_p)
  651.       outf (stream, " address: 0x%lx", ((long) Temp_Address));
  652.  
  653.     filename = (compiled_entry_debug_filename (entry));
  654.     if (STRING_P (filename))
  655.       {
  656.         outf (stream, " file: ");
  657.         print_filename (stream, filename);
  658.       }
  659.     else if (PAIR_P (filename))
  660.       {
  661.         outf (stream, " file: ");
  662.         print_filename (stream, (PAIR_CAR (filename)));
  663.         outf (stream, " block: %ld",
  664.             ((long) (FIXNUM_TO_LONG (PAIR_CDR (filename)))));
  665.       }
  666.     outf (stream, "]");
  667.     return;
  668.       }
  669.  
  670.     default:
  671.       break;
  672.     }
  673.   if (! handled_p)
  674.     {
  675.       if ((OBJECT_TYPE (Expr)) <= LAST_TYPE_CODE)
  676.     outf (stream, "[%s", (Type_Names [OBJECT_TYPE (Expr)]));
  677.       else
  678.     outf (stream, "[0x%02x", (OBJECT_TYPE (Expr)));
  679.     }
  680.   outf (stream, " 0x%lx]", ((long) Temp_Address));
  681.   return;
  682. }
  683.  
  684. extern void
  685. DEFUN (Debug_Print, (Expr, Detailed),
  686.        SCHEME_OBJECT Expr AND Boolean Detailed)
  687. {
  688.   do_printing(console_output, Expr, Detailed);
  689.   outf_flush_console ();
  690.   return;
  691. }
  692.  
  693. static Boolean
  694. DEFUN (print_one_continuation_frame, (stream, Temp),
  695.        outf_channel stream AND SCHEME_OBJECT Temp)
  696. {
  697.   SCHEME_OBJECT Expr;
  698.  
  699.   print_expression (stream, Temp, "Return code");
  700.   outf (stream, "\n");
  701.   Expr = (STACK_POP ());
  702.   print_expression (stream, Expr, "Expression");
  703.   outf (stream, "\n");
  704.   if (((OBJECT_DATUM (Temp)) == RC_END_OF_COMPUTATION) ||
  705.       ((OBJECT_DATUM (Temp)) == RC_HALT))
  706.     return (true);
  707.   if ((OBJECT_DATUM (Temp)) == RC_JOIN_STACKLETS)
  708.     Stack_Pointer = (Previous_Stack_Pointer (Expr));
  709.   return (false);
  710. }
  711.  
  712. extern Boolean EXFUN (Print_One_Continuation_Frame, (SCHEME_OBJECT));
  713.  
  714. Boolean
  715. DEFUN (Print_One_Continuation_Frame, (Temp), SCHEME_OBJECT Temp)
  716. {
  717.   return (print_one_continuation_frame (console_output, Temp));
  718. }
  719.  
  720. /* Back_Trace relies on (a) only a call to Save_Cont puts a return code on the
  721.    stack; (b) Save_Cont pushes the expression first.
  722.  */
  723.  
  724. void
  725. DEFUN (Back_Trace, (stream), outf_channel stream)
  726. {
  727.   SCHEME_OBJECT Temp, * Old_Stack;
  728.  
  729.   Back_Trace_Entry_Hook();
  730.   Old_Stack = Stack_Pointer;
  731.   while (true)
  732.   {
  733.     if ((STACK_LOCATIVE_DIFFERENCE (Stack_Top, (STACK_LOC (0)))) <= 0)
  734.     {
  735.       if ((STACK_LOC (0)) == Old_Stack)
  736.     outf (stream, "\n[Invalid stack pointer.]\n");
  737.       else
  738.     outf (stream, "\n[Stack ends abruptly.]\n");
  739.       break;
  740.     }
  741.     if (Return_Hook_Address == (STACK_LOC (0)))
  742.     {
  743.       Temp = (STACK_POP ());
  744.       if (Temp != (MAKE_OBJECT (TC_RETURN_CODE, RC_RETURN_TRAP_POINT)))
  745.       {
  746.         outf (stream, "\n--> Return trap is missing here <--\n");
  747.       }
  748.       else
  749.       {
  750.     outf (stream, "\n[Return trap found here as expected]\n");
  751.         Temp = Old_Return_Code;
  752.       }
  753.     }
  754.     else
  755.     {
  756.       Temp = (STACK_POP ());
  757.     }
  758.     if ((OBJECT_TYPE (Temp)) == TC_RETURN_CODE)
  759.     {
  760.       outf (stream, "{0x%x}", STACK_LOC(0));
  761.       if (print_one_continuation_frame (stream, Temp))
  762.     break;
  763.     }
  764.     else
  765.     {
  766.       outf (stream, "{0x%x}", STACK_LOC(0));
  767.       print_expression (stream, Temp, "  ...");
  768.       if ((OBJECT_TYPE (Temp)) == TC_MANIFEST_NM_VECTOR)
  769.       {
  770.     Stack_Pointer = (STACK_LOC (- ((long) (OBJECT_DATUM (Temp)))));
  771.         outf (stream, " (skipping)");
  772.       }
  773.       outf (stream, "\n");
  774.     }
  775.   }
  776.   Stack_Pointer = Old_Stack;
  777.   Back_Trace_Exit_Hook();
  778.   outf_flush (stream);
  779.   return;
  780. }
  781.  
  782. void
  783. DEFUN (print_stack, (sp), SCHEME_OBJECT * sp)
  784. {
  785.   SCHEME_OBJECT * saved_sp;
  786.  
  787.   saved_sp = Stack_Pointer;
  788.   Stack_Pointer = sp;
  789.   Back_Trace (console_output);
  790.   Stack_Pointer = saved_sp;
  791.   return;
  792. }
  793.  
  794. extern void
  795. DEFUN_VOID(Debug_Stack_Trace)
  796. {
  797.   print_stack(STACK_LOC(0));
  798. }
  799.  
  800. static Boolean
  801. DEFUN (print_primitive_name, (stream, primitive),
  802.        outf_channel stream AND SCHEME_OBJECT primitive)
  803. {
  804.   CONST char * name = (PRIMITIVE_NAME (primitive));
  805.   if (name == 0)
  806.   {
  807.     outf (stream, "Unknown primitive 0x%08x", PRIMITIVE_NUMBER(primitive));
  808.     return false;
  809.   }
  810.   else
  811.   {
  812.     outf (stream, "%s", name);
  813.     return true;
  814.   }
  815. }
  816.  
  817. void
  818. DEFUN (Print_Primitive, (primitive), SCHEME_OBJECT primitive)
  819. {
  820.   char buffer[40];
  821.   int NArgs, i;
  822.  
  823.   outf_console ("Primitive: ");
  824.   if (print_primitive_name (console_output, primitive))
  825.     NArgs = (PRIMITIVE_ARITY (primitive));
  826.   else
  827.     NArgs = 3;            /* Unknown primitive */
  828.  
  829.   outf_console ("\n");
  830.  
  831.   for (i = 0; i < NArgs; i++)
  832.   {
  833.     sprintf (buffer, "...Arg %ld", ((long) (i + 1)));
  834.     print_expression (console_output, (STACK_REF (i)), buffer);
  835.     outf_console ("\n");
  836.   }
  837.   return;
  838. }
  839.  
  840. /* Code for interactively setting and clearing the interpreter
  841.    debugging flags.  Invoked via the "D" command to the ^C
  842.    handler or during each FASLOAD. */
  843.  
  844. #ifdef ENABLE_DEBUGGING_FLAGS
  845.  
  846. #ifndef MORE_DEBUG_FLAG_CASES
  847. #define MORE_DEBUG_FLAG_CASES()
  848. #endif
  849.  
  850. #ifndef MORE_DEBUG_FLAG_NAMES
  851. #define MORE_DEBUG_FLAG_NAMES()
  852. #endif
  853.  
  854. #ifndef SET_FLAG_HOOK
  855. #define SET_FLAG_HOOK(hook)
  856. #endif
  857.  
  858. #ifndef DEBUG_GETDEC
  859. #define DEBUG_GETDEC debug_getdec
  860. #endif
  861.  
  862. #define D_EVAL            0
  863. #define D_HEX_INPUT        1
  864. #define D_FILE_LOAD        2
  865. #define D_RELOC            3
  866. #define D_INTERN        4
  867. #define D_CONT            5
  868. #define D_PRIMITIVE        6
  869. #define D_LOOKUP        7
  870. #define D_DEFINE        8
  871. #define D_GC            9
  872. #define D_UPGRADE        10
  873. #define D_DUMP            11
  874. #define D_TRACE_ON_ERROR    12
  875. #define D_PER_FILE        13
  876. #define D_BIGNUM        14
  877. #define D_FLUIDS        15
  878.  
  879. #ifndef LAST_SWITCH
  880. #define LAST_SWITCH D_FLUIDS
  881. #endif
  882.  
  883. static Boolean *
  884. DEFUN (find_flag, (flag_number), int flag_number)
  885. {
  886.   switch (flag_number)
  887.     {
  888.     case D_EVAL:        return (&Eval_Debug);
  889.     case D_HEX_INPUT:        return (&Hex_Input_Debug);
  890.     case D_FILE_LOAD:        return (&File_Load_Debug);
  891.     case D_RELOC:        return (&Reloc_Debug);
  892.     case D_INTERN:        return (&Intern_Debug);
  893.     case D_CONT:        return (&Cont_Debug);
  894.     case D_PRIMITIVE:        return (&Primitive_Debug);
  895.     case D_LOOKUP:        return (&Lookup_Debug) ;
  896.     case D_DEFINE:        return (&Define_Debug);
  897.     case D_GC:            return (&GC_Debug);
  898.     case D_UPGRADE:        return (&Upgrade_Debug);
  899.     case D_DUMP:        return (&Dump_Debug);
  900.     case D_TRACE_ON_ERROR:    return (&Trace_On_Error);
  901.     case D_PER_FILE:        return (&Per_File);
  902.     case D_BIGNUM:        return (&Bignum_Debug);
  903.     case D_FLUIDS:        return (&Fluids_Debug);
  904.     MORE_DEBUG_FLAG_CASES ();
  905.     default:            return (0);
  906.     }
  907. }
  908.  
  909. static char *
  910. DEFUN (flag_name, (flag_number), int flag_number)
  911. {
  912.   switch (flag_number)
  913.     {
  914.     case D_EVAL:        return ("Eval_Debug");
  915.     case D_HEX_INPUT:        return ("Hex_Input_Debug");
  916.     case D_FILE_LOAD:        return ("File_Load_Debug");
  917.     case D_RELOC:        return ("Reloc_Debug");
  918.     case D_INTERN:        return ("Intern_Debug");
  919.     case D_CONT:        return ("Cont_Debug");
  920.     case D_PRIMITIVE:        return ("Primitive_Debug");
  921.     case D_LOOKUP:        return ("Lookup_Debug");
  922.     case D_DEFINE:        return ("Define_Debug");
  923.     case D_GC:            return ("GC_Debug");
  924.     case D_UPGRADE:        return ("Upgrade_Debug");
  925.     case D_DUMP:        return ("Dump_Debug");
  926.     case D_TRACE_ON_ERROR:    return ("Trace_On_Error");
  927.     case D_PER_FILE:        return ("Per_File");
  928.     case D_BIGNUM:        return ("Bignum_Debug");
  929.     case D_FLUIDS:        return ("Fluids_Debug");
  930.     MORE_DEBUG_FLAG_NAMES ();
  931.     default:            return ("Unknown Debug Flag");
  932.     }
  933. }
  934.  
  935. static void
  936. DEFUN (show_flags, (all), int all)
  937. {
  938.   int i;
  939.   for (i = 0; (i <= LAST_SWITCH); i += 1)
  940.     {
  941.       int value = (* (find_flag (i)));
  942.       if (all || value)
  943.     outf (console_output, "Flag %ld (%s) is %s.\n",
  944.          ((long) i), (flag_name (i)), (value ? "set" : "clear"));
  945.     }
  946.   outf_flush_console();
  947.   return;
  948. }
  949.  
  950. static int
  951. DEFUN (set_flag, (flag_number, value), int flag_number AND int value)
  952. {
  953.   Boolean * flag = (find_flag (flag_number));
  954.   if (flag == 0)
  955.     show_flags (1);
  956.   else
  957.     {
  958.       (*flag) = value;
  959.       SET_FLAG_HOOK (flag);
  960.     }
  961.   return (0);
  962. }
  963.  
  964. static int
  965. DEFUN (debug_getdec, (string), CONST char * string)
  966. {
  967.   int result;
  968.  
  969.   sscanf (string, "%ld", (&result));
  970.   return (result);
  971. }
  972.  
  973. void
  974. DEFUN_VOID (debug_edit_flags)
  975. {
  976.   char input_line [256];
  977.   show_flags (0);
  978.   while (1)
  979.     {
  980.       outf_console("Clear<number>, Set<number>, Done, ?, or Halt: ");
  981.       outf_flush_console();
  982.       {
  983.     fgets (input_line, (sizeof (input_line)), stdin);
  984.     switch (input_line[0])
  985.       {
  986.        case 'c':
  987.        case 'C':
  988.          set_flag ((DEBUG_GETDEC (input_line)), 0);
  989.          break;
  990.        case 's':
  991.        case 'S':
  992.          set_flag ((DEBUG_GETDEC (input_line)), 1);
  993.          break;
  994.        case 'd':
  995.        case 'D':
  996.          return;
  997.        case 'h':
  998.        case 'H':
  999.          termination_normal (0);
  1000.        case '?':
  1001.        default:
  1002.          show_flags (1);
  1003.          break;
  1004.        }
  1005.       }
  1006.     }
  1007. }
  1008.  
  1009. #else /* not ENABLE_DEBUGGING_FLAGS */
  1010.  
  1011. void
  1012. DEFUN_VOID (debug_edit_flags)
  1013. {
  1014.   outf_error ("Not a debugging version.  No flags to handle.\n");
  1015.   outf_flush_error();
  1016.   return;
  1017. }
  1018.  
  1019. static int
  1020. DEFUN (set_flag, (flag_number, value), int flag_number AND int value)
  1021. {
  1022.   signal_error_from_primitive (ERR_UNIMPLEMENTED_PRIMITIVE);
  1023.   /*NOTREACHED*/
  1024.   return (0);
  1025. }
  1026.  
  1027. #endif /* not ENABLE_DEBUGGING_FLAGS */
  1028.  
  1029. DEFINE_PRIMITIVE("SET-DEBUG-FLAGS!", Prim_set_debug_flags, 2, 2,
  1030.   "(SET-DEBUG-FLAGS! flag_number boolean)")
  1031. {
  1032.   PRIMITIVE_HEADER (2);
  1033.   set_flag ((arg_integer (1)), (BOOLEAN_ARG (2)));
  1034.   PRIMITIVE_RETURN (UNSPECIFIC);
  1035. }
  1036.