home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / forth / pfe-0.000 / pfe-0 / pfe-0.9.13 / src / debug.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-07-17  |  11.0 KB  |  539 lines
  1. /*
  2.  * This file is part of the portable Forth environment written in ANSI C.
  3.  * Copyright (C) 1995  Dirk Uwe Zoller
  4.  *
  5.  * This library is free software; you can redistribute it and/or
  6.  * modify it under the terms of the GNU Library General Public
  7.  * License as published by the Free Software Foundation; either
  8.  * version 2 of the License, or (at your option) any later version.
  9.  *
  10.  * This library is distributed in the hope that it will be useful,
  11.  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  12.  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  13.  * See the GNU Library General Public License for more details.
  14.  *
  15.  * You should have received a copy of the GNU Library General Public
  16.  * License along with this library; if not, write to the Free
  17.  * Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  18.  *
  19.  * This file is version 0.9.13 of 17-July-95
  20.  * Check for the latest version of this package via anonymous ftp at
  21.  *    roxi.rz.fht-mannheim.de:/pub/languages/forth/pfe-VERSION.tar.gz
  22.  * or    sunsite.unc.edu:/pub/languages/forth/pfe-VERSION.tar.gz
  23.  * or    ftp.cygnus.com:/pub/forth/pfe-VERSION.tar.gz
  24.  *
  25.  * Please direct any comments via internet to
  26.  *    duz@roxi.rz.fht-mannheim.de.
  27.  * Thank You.
  28.  */
  29. /*
  30.  * debug.c ---        analyze compiled code
  31.  * (duz 26Aug93)
  32.  */
  33.  
  34. #include "forth.h"
  35. #include "support.h"
  36. #include "compiler.h"
  37. #include "term.h"
  38.  
  39. #include <ctype.h>
  40. #include <string.h>
  41.  
  42. #include "missing.h"
  43.  
  44. /************************************************************************/
  45. /* decompiler                                                           */
  46. /************************************************************************/
  47.  
  48. #ifdef WRONG_SPRINTF        /* provision for buggy sprintf (SunOS) */
  49. #define SPRFIX(X) strlen(X)
  50. #else
  51. #define SPRFIX(X) X
  52. #endif
  53.  
  54. static int debugging, level, maxlevel;
  55. static long opcounter;
  56. static short locals[10];
  57.  
  58. static Xt *
  59. decompile_word (Xt *ip, char *p, Decomp *d)
  60. {
  61.   static Decomp default_style = {SKIPS_NOTHING, 0, 0, 0, 0, 0};
  62.   Xt xt = *ip++;
  63.   Semant *s;
  64.   char *nfa, buf[80];
  65.  
  66.   s = to_semant (xt);
  67.   *d = s ? s->decomp : default_style;
  68.   if (*xt == literal_execution_)
  69.     {
  70.       strcpy (p, str_dot (*(Cell *) ip, buf + sizeof buf, BASE));
  71.       return ++ip;
  72.     }
  73.   if (*xt == locals_bar_execution_)
  74.     {
  75.       int i;
  76.  
  77.       locals[level] = *(Cell *) ip;
  78.       p += SPRFIX (sprintf (p, "LOCALS| "));
  79.       for (i = locals[level]; --i >= 0;)
  80.     p += SPRFIX (sprintf (p, "<%c> ", 'A' - 1 + locals[level] - i));
  81.       p += SPRFIX (sprintf (p, "| "));
  82.       return ++ip;
  83.     }
  84.   if (*xt == to_execution_)
  85.     {
  86.       xt = *ip++;
  87.       nfa = to_name (xt);
  88.       sprintf (p, "TO %.*s ", *nfa & 0x1F, nfa + 1);
  89.       return ip;
  90.     }
  91.   if (*xt == plus_to_execution_)
  92.     {
  93.       xt = *ip++;
  94.       nfa = to_name (xt);
  95.       sprintf (p, "+TO %.*s ", *nfa & 0x1F, nfa + 1);
  96.       return ip;
  97.     }
  98.   if (*xt == local_execution_)
  99.     {
  100.       sprintf (p, "<%c> ", 'A' + 1 + locals[level] - (int) *(Cell *) ip);
  101.       return ++ip;
  102.     }
  103.   if (*xt == to_local_execution_)
  104.     {
  105.       sprintf (p, "TO <%c> ", 'A' + 1 + locals[level] - (int) *(Cell *) ip);
  106.       return ++ip;
  107.     }
  108.   if (*xt == plus_to_local_execution_)
  109.     {
  110.       sprintf (p, "+TO <%c> ", 'A' + 1 + locals[level] - (int) *(Cell *) ip);
  111.       return ++ip;
  112.     }
  113.   if (s == NULL)
  114.     {
  115.       nfa = to_name (xt);
  116.       sprintf (p, *nfa & IMMEDIATE ? "POSTPONE %.*s " : "%.*s ",
  117.            *nfa & 0x1F, nfa + 1);
  118.       return ip;
  119.     }
  120.   else
  121.     nfa = s->name;
  122.   switch (d->skips)
  123.     {
  124.     case SKIPS_CELL:
  125.     case SKIPS_OFFSET:
  126.       INC (ip, Cell);
  127.  
  128.     default:
  129.       sprintf (p, "%.*s ", *nfa & 0x1F, nfa + 1);
  130.       return ip;
  131.     case SKIPS_DCELL:
  132.       sprintf (p, "%s. ",
  133.            str_d_dot_r (*(dCell *) ip, buf + sizeof buf, 0, BASE));
  134.       INC (ip, dCell);
  135.  
  136.       return ip;
  137.     case SKIPS_FLOAT:
  138. #if DFLOAT_ALIGN > CELL_ALIGN
  139.       if (!DFALIGNED (ip))
  140.     ip++;
  141. #endif
  142.       sprintf (p, "%g ", *(double *) ip);
  143.       INC (ip, double);
  144.  
  145.       return ip;
  146.     case SKIPS_STRING:
  147.       sprintf (p, "%.*s %.*s\" ",
  148.            *nfa & 0x1F, nfa + 1,
  149.            (int) *(Byte *) ip, (Byte *) ip + 1);
  150.       SKIP_STRING;
  151.       return ip;
  152.     case SKIPS_2STRINGS:
  153.       {
  154.     Byte *s1 = (Byte *) ip;
  155.  
  156.     SKIP_STRING;
  157.     sprintf (p, "%.*s %.*s %.*s ",
  158.          *nfa & 0x1F, nfa + 1, (int) *s1, s1 + 1,
  159.          (int) *(Byte *) ip, (Byte *) ip + 1);
  160.     SKIP_STRING;
  161.     return ip;
  162.       }
  163.     }
  164. }
  165.  
  166. static void
  167. decompile_rest (Xt *ip, int nl, int indent)
  168. {
  169.   char buf[0x80];
  170.   Seman2 *s;
  171.   Decomp d;
  172.  
  173.   start_question_cr_ ();
  174.   for (;;)
  175.     {
  176.       s = (Seman2 *) to_semant (*ip);
  177.       ip = decompile_word (ip, buf, &d);
  178.       indent += d.ind_bef;
  179.       if ((!nl && d.cr_bef) || OUT + strlen (buf) >= cols)
  180.     {
  181.       if (question_cr ())
  182.         break;
  183.       nl = 1;
  184.     }
  185.       if (nl)
  186.     {
  187.       spaces (indent);
  188.       nl = 0;
  189.     }
  190.       outs (buf);
  191.       spaces (d.space);
  192.       indent += d.ind_aft;
  193.       if (d.cr_aft)
  194.     {
  195.       if (question_cr ())
  196.         break;
  197.       nl = 1;
  198.     }
  199.       if (s == &semicolon_semantics)
  200.     break;
  201.     }
  202. }
  203.  
  204. void
  205. decompile (char *nfa, Xt xt)
  206. {
  207.   char buf[80];
  208.  
  209.   cr_ ();
  210.   if (*xt == create_runtime ||
  211.       *xt == sysvar_runtime)
  212.     {
  213.       outs ("VARIABLE ");
  214.       dot_name (nfa);
  215.     }
  216.   else if (*xt == constant_runtime)
  217.     {
  218.       DOT (*TO_BODY (xt), buf);
  219.       outs ("CONSTANT ");
  220.       dot_name (nfa);
  221.     }
  222.   else if (*xt == value_runtime)
  223.     {
  224.       DOT (*TO_BODY (xt), buf);
  225.       outs ("VALUE ");
  226.       dot_name (nfa);
  227.     }
  228.   else if (*xt == sysconst_runtime)
  229.     {
  230.       DOT (**(Cell **) TO_BODY (xt), buf);
  231.       outs ("CONSTANT ");
  232.       dot_name (nfa);
  233.     }
  234.   else if (*xt == two_constant_runtime)
  235.     {
  236.       DDOTR (*(dCell *) TO_BODY (xt), 0, buf);
  237.       outs (". 2CONSTANT ");
  238.       dot_name (nfa);
  239.     }
  240.   else if (*xt == f_constant_runtime)
  241.     {
  242.       outf ("%g FCONSTANT ", *(double *) dfaligned ((Cell) TO_BODY (xt)));
  243.       dot_name (nfa);
  244.     }
  245.   else if (*xt == f_variable_runtime)
  246.     {
  247.       outf ("%g FVARIABLE ", *(double *) dfaligned ((Cell) TO_BODY (xt)));
  248.       dot_name (nfa);
  249.     }
  250.   else if (*xt == marker_runtime)
  251.     {
  252.       outs ("MARKER ");
  253.       dot_name (nfa);
  254.     }
  255.   else if (*xt == vocabulary_runtime)
  256.     {
  257.       outs ("VOCABULARY ");
  258.       dot_name (nfa);
  259.     }
  260.   else if (*xt == colon_runtime ||
  261.        *xt == debug_colon_runtime)
  262.     {
  263.       outs (": ");
  264.       dot_name (nfa);
  265.       cr_ ();
  266.       decompile_rest ((Xt *) TO_BODY (xt), 1, 4);
  267.     }
  268.   else if (*xt == does_defined_runtime ||
  269.        *xt == debug_does_defined_runtime)
  270.     {
  271.       outs ("DOES> ");
  272.       decompile_rest (((Xt **) xt)[-1], 0, 4);
  273.     }
  274.   else
  275.     {
  276.       dot_name (nfa);
  277.       outf ("is primitive ");
  278.     }
  279.   if (*nfa & IMMEDIATE)
  280.     outs ("IMMEDIATE ");
  281. }
  282.  
  283. /************************************************************************/
  284. /* debugger                                                             */
  285. /************************************************************************/
  286.  
  287. char
  288. category (pCode p)
  289. {
  290.   if (p == colon_runtime || p == debug_colon_runtime)
  291.     return ':';
  292.   if (p == create_runtime)
  293.     return 'V';
  294.   if (p == constant_runtime || p == two_constant_runtime)
  295.     return 'C';
  296.   if (p == sysvar_runtime)
  297.     return 'v';
  298.   if (p == sysconst_runtime)
  299.     return 'c';
  300.   if (p == vocabulary_runtime)
  301.     return 'W';
  302.   if (p == does_defined_runtime || p == debug_does_defined_runtime)
  303.     return 'D';
  304.   if (p == marker_runtime)
  305.     return 'M';
  306.   /* must be primitive */ return 'p';
  307. }
  308.  
  309. static void
  310. prompt_col (void)
  311. {
  312.   spaces (24 - OUT);
  313. }
  314.  
  315. static void
  316. display (Xt *ip)
  317. {
  318.   Decomp style;
  319.   char buf[80];
  320.   int indent = maxlevel * 2;
  321.   int depth = sys.s0 - sp, i;
  322.  
  323.   prompt_col ();
  324.   for (i = 0; i < depth; i++)
  325.     {
  326.       outf ("%10ld ", (long) sp[i]);
  327.       if (OUT + 11 >= cols)
  328.     break;
  329.     }
  330.   cr_ ();
  331.   decompile_word (ip, buf, &style);
  332.   outf ("%*s%c %s", indent, "", category (**ip), buf);
  333. }
  334.  
  335. static void
  336. interaction (Xt *ip)
  337. {
  338.   int c;
  339.  
  340.   for (;;)
  341.     {
  342.       display (ip);
  343.  
  344.       prompt_col ();
  345.       outs ("> ");
  346.       c = getekey ();
  347.       backspace_ ();
  348.       backspace_ ();
  349.       if (isalpha (c))
  350.     c = tolower (c);
  351.  
  352.       switch (c)
  353.     {
  354.     default:
  355.       c_bell ();
  356.       continue;
  357.     case EKEY_kr:
  358.     case 'd':
  359.     case 'l':
  360.       maxlevel++;
  361.       return;
  362.     case EKEY_kd:
  363.     case '\r':
  364.     case '\n':
  365.     case 'k':
  366.     case 'x':
  367.       return;
  368.     case EKEY_kl:
  369.     case 's':
  370.     case 'j':
  371.       maxlevel--;
  372.       return;
  373.     case 'q':
  374.       outf ("\nQuit!");
  375.       debugging = 0;
  376.       tHrow (THROW_QUIT);
  377.     case ' ':
  378.       switch (category (**ip))
  379.         {
  380.         default:
  381.           decompile (to_name (*ip), *ip);
  382.           break;
  383.         case ':':
  384.           cr_ ();
  385.           decompile_rest ((Xt *) TO_BODY (*ip), 1, 4);
  386.           break;
  387.         case 'd':
  388.           outs ("\nDOES>");
  389.           decompile_rest ((Xt *) (*ip)[-1], 0, 4);
  390.           break;
  391.         }
  392.       cr_ ();
  393.       continue;
  394.     case 'r':
  395.       opcounter = 0;
  396.       outf ("\nOperation counter reset\n");
  397.       continue;
  398.     case 'c':
  399.       outf ("\n%ld Forth operations\n", opcounter);
  400.       continue;
  401.     case 'h':
  402.     case '?':
  403.       outf ("\nDown,  'x', 'k', CR\t" "execute word"
  404.         "\nRight, 'd', 'l'\t\t" "single step word"
  405.         "\nLeft,  's', 'j'\t\t" "finish word w/o single stepping"
  406.         "\nSpace\t\t\t" "SEE word to be executed"
  407.         "\n'C'\t\t\t" "display operation counter"
  408.         "\n'R'\t\t\t" "reset operation counter"
  409.         "\n'Q'\t\t\t" "QUIT"
  410.         "\n'?', 'H'\t\t" "this message"
  411.         "\n");
  412.       continue;
  413.     }
  414.     }
  415. }
  416.  
  417. static void
  418. adjust_level (Xt xt)
  419. {
  420.   if (*xt == colon_runtime ||
  421.       *xt == debug_colon_runtime ||
  422.       *xt == does_defined_runtime ||
  423.       *xt == debug_does_defined_runtime)
  424.     level++;
  425.   else if (*xt == semicolon_execution_ ||
  426.        *xt == locals_exit_execution_)
  427.     level--;
  428. }
  429.  
  430. static void
  431. debug_execute (Xt xt)
  432. {
  433.   adjust_level (xt);
  434.   normal_execute (xt);
  435. }
  436.  
  437. static void
  438. debug_on (void)
  439. {
  440.   debugging = 1;
  441.   opcounter = 0;
  442.   execute = debug_execute;
  443.   level = maxlevel = 0;
  444.   outf ("\nSingle stepping, type 'h' or '?' for help\n");
  445. }
  446.  
  447. void
  448. debug_off (void)
  449. {
  450.   debugging = 0;
  451.   execute = normal_execute;
  452. }
  453.  
  454. static void            /* modified inner interpreter for */
  455. single_step (void)        /* single stepping */
  456. {
  457.   while (level >= 0)
  458.     {
  459.       if (level <= maxlevel)
  460.     {
  461.       maxlevel = level;
  462.       interaction (ip);
  463.     }
  464.       adjust_level (*ip);
  465.       opcounter++;
  466.       {
  467. #ifdef W
  468.     Xt w = *ip++;        /* ip is register but W isn't */
  469.  
  470.     (*w) ();
  471. #else
  472.     W = *ip++;        /* ip and W are same: register or not */
  473.     (*W) ();
  474. #endif
  475.       }
  476.     }
  477. }
  478.  
  479. void
  480. debug_colon_runtime (void)
  481. {
  482.   colon_runtime ();
  483.   if (!debugging)
  484.     {
  485.       debug_on ();
  486.       single_step ();
  487.       debug_off ();
  488.     }
  489. }
  490.  
  491. void
  492. debug_does_defined_runtime (void)
  493. {
  494.   does_defined_runtime ();
  495.   if (!debugging)
  496.     {
  497.       debug_on ();
  498.       single_step ();
  499.       debug_off ();
  500.     }
  501. }
  502.  
  503. Code (debug)
  504. {
  505.   Xt xt;
  506.  
  507.   tick (&xt);
  508.   if (*xt == debug_colon_runtime ||
  509.       *xt == debug_does_defined_runtime)
  510.     return;
  511.   if (*xt == colon_runtime)
  512.     *xt = debug_colon_runtime;
  513.   else if (*xt == does_defined_runtime)
  514.     *xt = debug_does_defined_runtime;
  515.   else
  516.     tHrow (THROW_ARG_TYPE);
  517. }
  518.  
  519. Code (no_debug)
  520. {
  521.   Xt xt;
  522.  
  523.   tick (&xt);
  524.   if (*xt == debug_colon_runtime)
  525.     *xt = colon_runtime;
  526.   else if (*xt == debug_does_defined_runtime)
  527.     *xt = does_defined_runtime;
  528.   else
  529.     tHrow (THROW_ARG_TYPE);
  530. }
  531.  
  532. LISTWORDS (debug) =
  533. {
  534.   CO ("DEBUG", debug),
  535.   CO ("NO-DEBUG", no_debug)
  536. };
  537.  
  538. COUNTWORDS (debug, "Debugger words");
  539.