home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / plbin.zip / pl / src / pl-trace.c < prev    next >
C/C++ Source or Header  |  1993-02-18  |  25KB  |  954 lines
  1. /*  pl-trace.c,v 1.4 1993/02/18 15:16:36 jan Exp
  2.  
  3.     Copyright (c) 1990 Jan Wielemaker. All rights reserved.
  4.     See ../LICENCE to find out about your rights.
  5.     jan@swi.psy.uva.nl
  6.  
  7.     Purpose: tracer
  8. */
  9.  
  10. #include "pl-incl.h"
  11. #include "pl-ctype.h"
  12.  
  13. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  14. This module defines the tracer and interrupt  handler  that  allows  the
  15. user  to break the normal Prolog execution.  The tracer is written in C,
  16. but before taking action it calls Prolog.   This  mechanism  allows  the
  17. user to intercept and redefine the tracer.
  18. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  19.  
  20. #define W_PRINT        1        /* print/1 for displaying goal */
  21. #define W_WRITE        2        /* write/1 */
  22. #define W_WRITEQ    3        /* writeq/1 */
  23. #define W_DISPLAY    4        /* display/1 */
  24.  
  25.                     /* Frame <-> Prolog integer */
  26. #define PrologRef(fr)     consNum((Word)fr - (Word)lBase)
  27. #define FrameRef(w)     ((LocalFrame)((Word)lBase + valNum(w)))
  28.  
  29. forwards LocalFrame    redoFrame P((LocalFrame));
  30. forwards int        traceAction P((char *, int, LocalFrame, bool));
  31. forwards void        helpTrace P((void));
  32. forwards void        helpInterrupt P((void));
  33. forwards bool        hasAlternativesFrame P((LocalFrame));
  34. forwards void        alternatives P((LocalFrame));
  35. forwards void        listProcedure P((Procedure));
  36. forwards int        traceInterception P((LocalFrame, int));
  37. forwards bool        canUnifyTermWithGoal P((Word, LocalFrame));
  38. forwards int        setupFind P((char *));
  39.  
  40. static struct
  41. { int     port;                /* Port to find */
  42.   bool     searching;            /* Currently searching? */
  43.   Record goal;                /* Goal to find */
  44. } find;
  45.  
  46. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  47. redoFrame() returns the latest skipped frame or NULL if  no  such  frame
  48. exists.   This  is used to give the redo port of the goal skipped rather
  49. than the redo port of some subgoal of this port.
  50. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  51.  
  52. static LocalFrame
  53. redoFrame(fr)
  54. register LocalFrame fr;
  55. { for( ; fr && false(fr, FR_SKIPPED); fr = parentFrame(fr) )
  56.     ;
  57.  
  58.   return fr;
  59. }
  60.  
  61. static bool
  62. canUnifyTermWithGoal(t, fr)
  63. Word t;
  64. LocalFrame fr;
  65. { deRef(t);
  66.   if ( isVar(*t) )
  67.     succeed;
  68.   if ( isAtom(*t) && fr->procedure->functor->name == (Atom)*t )
  69.     succeed;
  70.   if ( isTerm(*t) && functorTerm(*t) == fr->procedure->functor )
  71.   { mark m;
  72.     Word a, b;
  73.     int arity;
  74.  
  75.     Mark(m);
  76.     a = argTermP(*t, 0);
  77.     b = argFrameP(fr, 0);
  78.     arity = functorTerm(*t)->arity;
  79.     while( arity > 0 )
  80.     { if ( unify(a, b) == FALSE )
  81.       { Undo(m);
  82.         fail;
  83.       }
  84.     }
  85.     Undo(m);
  86.     succeed;
  87.   }
  88.   
  89.   fail;
  90. }
  91.  
  92. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  93. Toplevel  of  the  tracer.   This  function  is  called  from  the   WAM
  94. interpreter.   It  can  take  care of most of the tracer actions itself,
  95. except if the execution path is to  be  changed.   For  this  reason  it
  96. returns to the WAM interpreter how to continue the execution:
  97.  
  98.     ACTION_CONTINUE:    Continue normal
  99.     ACTION_FAIL:    Go to the fail port of this goal
  100.     ACTION_RETRY:    Redo the current goal
  101.     ACTION_IGNORE:    Go to the exit port of this goal
  102. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  103.  
  104. int
  105. tracePort(frame, port)
  106. LocalFrame frame;
  107. int port;
  108. { int OldOut;
  109.   extern int Output;
  110.   int action = ACTION_CONTINUE;
  111.   Procedure proc = frame->procedure;
  112.   Definition def = proc->definition;
  113.   LocalFrame fr;
  114.  
  115.   if ( (true(frame, FR_NODEBUG) && !(SYSTEM_MODE))    || /* hidden */
  116.        debugstatus.suspendTrace                || /* called back */
  117.        (!debugstatus.tracing && false(def, SPY_ME))    || /* non-tracing */
  118.        debugstatus.skiplevel < levelFrame(frame)    || /* skipped */
  119.        false(def, TRACE_ME)                || /* non-tracing */
  120.        (!(debugstatus.visible & port))            || /* wrong port */
  121.        (port == REDO_PORT && (debugstatus.skiplevel == levelFrame(frame) ||
  122.                   (true(def, SYSTEM) && !SYSTEM_MODE)
  123.                  )) )                   /* redos */
  124.     return ACTION_CONTINUE;
  125.  
  126. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  127. Give a trace on the skipped goal for a redo.
  128. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  129.  
  130.   if ( port == REDO_PORT && debugstatus.skiplevel == VERY_DEEP &&
  131.        (fr = redoFrame(frame)) != NULL )
  132.   { debugstatus.skiplevel--;                   /* avoid a loop */
  133.     switch( tracePort(fr, REDO_PORT) )
  134.     { case ACTION_CONTINUE:
  135.     if ( debugstatus.skiplevel < levelFrame(frame) )
  136.       return ACTION_CONTINUE;
  137.     break;
  138.       case ACTION_RETRY:
  139.       case ACTION_IGNORE:
  140.       case ACTION_FAIL:
  141.     Putf("Action not yet implemented here\n");
  142.     break;
  143.     }
  144.   }
  145.  
  146. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  147. We are in searching mode; should we actually give this port?
  148. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  149.  
  150.   if ( find.searching )
  151.   { DEBUG(2, printf("Searching\n"));
  152.  
  153.     if ( (port & find.port) && canUnifyTermWithGoal(&find.goal->term, frame) )
  154.     { find.searching = FALSE;        /* Got you */
  155.     } else
  156.     { return ACTION_CONTINUE;        /* Continue the search */
  157.     }
  158.   }
  159.  
  160. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  161. Do the Prolog trace interception.
  162. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  163.  
  164.   if ((action = traceInterception(frame, port)) >= 0)
  165.     return action;
  166.  
  167. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  168. All failed.  Things now are upto the normal Prolog tracer.
  169. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  170.  
  171.   action = ACTION_CONTINUE;
  172.   OldOut = Output;
  173.   Output = 1;
  174.  
  175. again:
  176.   Put( true(def, SPY_ME) ? '*' : ' ' );
  177.   Put( true(def, TRANSPARENT) ? '^' : ' ');
  178.  
  179.   switch(port)
  180.   { case CALL_PORT:    Putf(" Call:  ");    break;
  181.     case REDO_PORT:    Putf(" Redo:  ");    break;
  182.     case FAIL_PORT:    Putf(" Fail:  ");
  183.             Undo(frame->mark);    break;
  184.     case EXIT_PORT:    Putf(" Exit:  ");    break;
  185.     case UNIFY_PORT:    Putf(" Unify: ");    break;
  186.   }
  187.   Putf("(%3ld) ", levelFrame(frame));
  188.   writeFrameGoal(frame, debugstatus.style);
  189.  
  190.   debugstatus.skiplevel = VERY_DEEP;
  191.   debugstatus.tracing = TRUE;
  192.  
  193.   if (debugstatus.leashing & port)
  194.   { char buf[LINESIZ];
  195.  
  196.     Putf(" ? ");
  197.     pl_flush();
  198.     if ( status.notty )
  199.     { readLine(buf, 0);
  200.     } else
  201.     { buf[0] = getSingleChar();
  202.       buf[1] = EOS;
  203.       if ( isDigit(buf[0]) || buf[0] == '/' )
  204.       { Putf(buf);
  205.     readLine(&buf[1], 0);
  206.       }
  207.     }
  208.     if ((action = traceAction(buf, port, frame, status.notty ? FALSE : TRUE))
  209.                             == ACTION_AGAIN)
  210.       goto again;
  211.   } else
  212.     Put('\n');
  213.   Output = OldOut;
  214.  
  215.   return action;
  216. }
  217.  
  218. static int
  219. setupFind(buf)
  220. char *buf;
  221. { static word w;
  222.   mark m;
  223.   long rval;
  224.   char *s;
  225.   int port = 0;
  226.  
  227.   for(s = buf; *s && isBlank(*s); s++)    /* Skip blanks */
  228.     ;
  229.   if ( *s == EOS )            /* No specification: repeat */
  230.   { if ( find.port == 0 )
  231.     { Putf("[No previous search]\n");
  232.       fail;
  233.     }
  234.     find.searching = TRUE;
  235.     succeed;
  236.   }
  237.   for( ; *s && !isBlank(*s); s++ )    /* Parse the port specification */
  238.   { switch( *s )  
  239.     { case 'c':    port |= CALL_PORT;  continue;
  240.       case 'e':    port |= EXIT_PORT;  continue;
  241.       case 'r':    port |= REDO_PORT;  continue;
  242.       case 'f':    port |= FAIL_PORT;  continue;
  243.       case 'u':    port |= UNIFY_PORT; continue;
  244.       case 'a':    port |= CALL_PORT|REDO_PORT|FAIL_PORT|EXIT_PORT|UNIFY_PORT;
  245.                     continue;
  246.       default:  Putf("[Illegal port specification]\n");
  247.         fail;
  248.     }
  249.   }
  250.   for( ; *s && isBlank(*s); s++)    /* Skip blanks */
  251.     ;
  252.  
  253.   if ( *s == EOS )            /* Nothing is a variable */
  254.   { s = buf;
  255.     strcpy(buf, "_");
  256.   }
  257.  
  258.   Mark(m);
  259.   seeString(s);
  260.   setVar(w);
  261.   rval = pl_read(&w);
  262.   seenString();
  263.  
  264.   if ( rval == FALSE )
  265.   { Undo(m);
  266.     fail;
  267.   }
  268.  
  269.   if ( find.goal != NULL )
  270.     freeRecord(find.goal);
  271.   find.port      = port;
  272.   find.goal      = copyTermToHeap(&w);
  273.   find.searching = TRUE;
  274.   Undo(m);
  275.  
  276.   DEBUG(2, printf("setup ok, port = 0x%x, goal = ", port);
  277.        pl_write(&find.goal->term);
  278.        printf("\n") );
  279.  
  280.   succeed;
  281. }
  282.  
  283.  
  284. static int
  285. traceAction(cmd, port, frame, interactive)
  286. char *cmd;
  287. int port;
  288. LocalFrame frame;
  289. bool interactive;
  290. { int num_arg;                /* numeric argument */
  291.   char *s;
  292.  
  293. #define FeedBack(msg)    { if (interactive) Putf(msg); }
  294. #define Warn(msg)    { if (interactive) Putf(msg); else warning(msg); }
  295. #define Default        (-1)
  296.  
  297.   for(s=cmd; *s && isBlank(*s); s++)
  298.     ;
  299.   if ( isDigit(*s) )
  300.   { num_arg = strtol(s, &s, 10);
  301.  
  302.     while(isBlank(*s))
  303.       s++;
  304.   } else
  305.     num_arg = Default;
  306.  
  307.   switch( *s )
  308.   { case 'a':    FeedBack("abort\n");
  309.         pl_abort();
  310.     case 'b':    FeedBack("break\n");
  311.         pl_break();
  312.         return ACTION_AGAIN;
  313.     case '/':     FeedBack("/");
  314.             pl_flush();
  315.             if ( setupFind(&s[1]) == TRUE )
  316.         { clear(frame, FR_SKIPPED);
  317.           return ACTION_CONTINUE;
  318.         }
  319.         return ACTION_AGAIN;            
  320.     case '.':   if ( find.goal != NULL )
  321.                   { FeedBack("repeat search\n");
  322.           find.searching = TRUE;
  323.           clear(frame, FR_SKIPPED);
  324.           return ACTION_CONTINUE;
  325.         } else
  326.         { Warn("No previous search\n");
  327.         }
  328.         return ACTION_AGAIN;            
  329.     case EOS:
  330.     case ' ':
  331.     case '\n':
  332.     case 'c':    FeedBack("creep\n");
  333.         clear(frame, FR_SKIPPED);
  334.         return ACTION_CONTINUE;
  335.     case '\04':
  336.     case EOF:    FeedBack("EOF: ");
  337.     case 'e':    FeedBack("exit\n");
  338.         pl_halt();
  339.     case 'f':    FeedBack("fail\n");
  340.         return ACTION_FAIL;
  341.     case 'i':    if (port & (CALL_PORT|REDO_PORT|FAIL_PORT))
  342.         { FeedBack("ignore\n");
  343.           return ACTION_IGNORE;
  344.         } else
  345.           Warn("Can't ignore goal at this port\n");
  346.         return ACTION_CONTINUE;
  347.     case 'r':    if (port & (REDO_PORT|FAIL_PORT|EXIT_PORT))
  348.         { FeedBack("retry\n[retry]\n");
  349.           return ACTION_RETRY;
  350.         } else
  351.           Warn("Can't retry at this port\n");
  352.         return ACTION_CONTINUE;
  353.     case 's':    FeedBack("skip\n");
  354.         set(frame, FR_SKIPPED);
  355.         debugstatus.skiplevel = levelFrame(frame);
  356.         return ACTION_CONTINUE;
  357.     case 'u':    FeedBack("up\n");
  358.         debugstatus.skiplevel = levelFrame(frame) - 1;
  359.         return ACTION_CONTINUE;
  360.     case 'w':    FeedBack("write\n");
  361.         debugstatus.style = W_WRITEQ;
  362.         return ACTION_AGAIN;
  363.     case 'p':    FeedBack("print\n");
  364.         debugstatus.style = W_PRINT;
  365.         return ACTION_AGAIN;
  366.     case 'd':    FeedBack("display\n");
  367.         debugstatus.style = W_DISPLAY;
  368.         return ACTION_AGAIN;
  369.     case 'l':    FeedBack("leap\n");
  370.         debugstatus.tracing = FALSE;
  371.         return ACTION_CONTINUE;
  372.     case 'n':    FeedBack("no debug\n");
  373.         debugstatus.debugging = FALSE;
  374.         debugstatus.tracing = FALSE;
  375.         return ACTION_CONTINUE;
  376.     case 'g':    FeedBack("goals\n");
  377.         backTrace(frame, num_arg == Default ? 5 : num_arg);
  378.         return ACTION_AGAIN;
  379.     case 'A':    FeedBack("alternatives\n");
  380.         alternatives(frame);
  381.         return ACTION_AGAIN;
  382.     case 'C':    debugstatus.showContext = 1 - debugstatus.showContext;
  383.         if ( debugstatus.showContext == TRUE )
  384.         { FeedBack("Show context\n");
  385.         } else
  386.         { FeedBack("No show context\n");
  387.         }
  388.         return ACTION_AGAIN;
  389.     case 'L':    FeedBack("Listing");
  390.         listProcedure(frame->procedure);
  391.         return ACTION_AGAIN;
  392.     case '+':    FeedBack("spy\n");
  393.         set(frame->procedure->definition, SPY_ME);
  394.         return ACTION_AGAIN;
  395.     case '-':    FeedBack("no spy\n");
  396.         clear(frame->procedure->definition, SPY_ME);
  397.         return ACTION_AGAIN;
  398.     case '?': 
  399.     case 'h':    helpTrace();
  400.         return ACTION_AGAIN;
  401.     case 'D':   status.debugLevel = num_arg;
  402.         FeedBack("Debug level\n");
  403.         return ACTION_AGAIN;
  404.     default:    Warn("Unknown option (h for help)\n");
  405.         return ACTION_AGAIN;
  406.   }
  407. }
  408.  
  409. static void
  410. helpTrace()
  411. { Putf("Options:\n");
  412.   Putf("+:                 spy        -:                 no spy\n");
  413.   Putf("/ports goal:       find       .:                 repeat find\n");
  414.   Putf("a:                 abort      A:                 alternatives\n");
  415.   Putf("b:                 break      c (return, space): creep\n");
  416.   Putf("d:                 display    e:                 exit\n");
  417.   Putf("f:                 fail       [depth] g:         goals\n");
  418.   Putf("h (?):             help       i:                 ignore\n");
  419.   Putf("l:                 leap       L:                 listing\n");
  420.   Putf("n:                 no debug   p:                 print\n");
  421.   Putf("r:                 retry      s:                 skip\n");
  422.   Putf("u:                 up         w:                 write\n");
  423.   Putf("C:                 toggle show context\n");
  424. }
  425.  
  426. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  427. Write goal of stack frame.  First a term representing the  goal  of  the
  428. frame  is  constructed.  Trail and global stack are marked and undone to
  429. avoid garbage on the global stack.
  430.  
  431. Trick, trick, O big trick ... In order to print the  goal  we  create  a
  432. term  for  it  (otherwise  we  would  have to write a special version of
  433. write/1, etc.  for stack frames).  A small problem arises: if the  frame
  434. holds a variable we will make a reference to the new term, thus printing
  435. the wrong variable: variables sharing in a clause does not seem to share
  436. any  longer  in  the  tracer  (Anjo  Anjewierden discovered this ackward
  437. feature of the tracer).  The solution is simple: we make  the  reference
  438. pointer  the other way around.  Normally references should never go from
  439. the global to the local stack as the local stack frame  might  cease  to
  440. exists  before  the  global frame.  In this case this does not matter as
  441. the local stack frame definitely survives the tracer (measuring does not
  442. always mean influencing in computer science).
  443. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  444.  
  445. void
  446. writeFrameGoal(frame, how)
  447. LocalFrame frame;
  448. int how;
  449. { Procedure proc = frame->procedure;
  450.   Definition def = proc->definition;
  451.   Word argv = argFrameP(frame, 0);
  452.   Word argp;
  453.   int argc = proc->functor->arity;
  454.   int n;
  455.   word goal;
  456.   mark m;
  457.   int debugSave = debugstatus.debugging;
  458.  
  459.   if ( debugstatus.showContext )
  460.     Putf("[%s] ", stringAtom(contextModule(frame)->name));
  461.   if ( def->module != MODULE_user &&
  462.        (false(def->module, SYSTEM) || SYSTEM_MODE))
  463.     Putf("%s:", stringAtom(def->module->name));
  464.  
  465.   Mark(m);
  466.   if (argc == 0)
  467.     goal = (word) proc->functor->name;
  468.   else
  469.   { goal = globalFunctor(proc->functor);
  470.     argp = argTermP(goal, 0);
  471.     for(n=0; n<argc; n++, argp++, argv++)
  472.     { register Word a;
  473.   
  474.       deRef2(argv, a);
  475.       *argp = (isVar(*a) ? makeRef(a) : *a);
  476.     }
  477.   }
  478.   
  479.   switch(how)
  480.   { case W_PRINT:
  481.     debugstatus.debugging = FALSE;
  482.     if ( status.boot )
  483.       pl_write(&goal);
  484.     else
  485.       pl_print(&goal);
  486.     debugstatus.debugging = debugSave;
  487.     break;
  488.     case W_WRITE:
  489.     pl_write(&goal);
  490.     break;
  491.     case W_WRITEQ:
  492.     pl_writeq(&goal);
  493.     break;
  494.     case W_DISPLAY:
  495.     pl_display(&goal);
  496.     break;
  497.   }
  498.   Undo(m);
  499. }
  500.  
  501. /*  Write those frames on the stack that have alternatives left.
  502.  
  503.  ** Tue May 10 23:23:11 1988  jan@swivax.UUCP (Jan Wielemaker)  */
  504.  
  505. static bool
  506. hasAlternativesFrame(frame)
  507. register LocalFrame frame;
  508. { register Clause clause;
  509.  
  510.   if ( true(frame, FR_CUT) )
  511.     fail;
  512.   if (true(frame->procedure->definition, FOREIGN))
  513.     succeed;
  514.   for(clause = frame->clause; clause; clause = clause->next)
  515.     if ( false(clause, ERASED) )
  516.       succeed;
  517.   fail;
  518. }
  519.  
  520. static void
  521. alternatives(frame)
  522. LocalFrame frame;
  523. { for(; frame; frame = frame->backtrackFrame)
  524.   { if (hasAlternativesFrame(frame) &&
  525.      (false(frame, FR_NODEBUG) || SYSTEM_MODE) )
  526.     { Putf("    [%3ld] ", levelFrame(frame));
  527.       writeFrameGoal(frame, debugstatus.style);
  528.       Put('\n');
  529.     }
  530.   }
  531. }    
  532.  
  533. static void
  534. listProcedure(proc)
  535. Procedure proc;
  536. { extern int Output;
  537.   int OldOut = Output;
  538.   Word gSave = gTop;
  539.   word goal = globalFunctor(FUNCTOR_listing1);
  540.   word mod  = globalFunctor(FUNCTOR_module2);
  541.   word spec = globalFunctor(FUNCTOR_divide2);
  542.   int debugSave = debugstatus.debugging;
  543.  
  544.   argTerm(goal, 0) = mod;
  545.   argTerm(mod, 0)  = (word) proc->definition->module->name;
  546.   argTerm(mod, 1)  = spec;
  547.   argTerm(spec, 0) = (word) proc->functor->name;
  548.   argTerm(spec, 1) = consNum(proc->functor->arity);
  549.  
  550.   Output = 1;
  551.   debugstatus.debugging = FALSE;
  552.   callGoal(MODULE_system, goal, FALSE);        /* listing(mod:name/arity) */
  553.   debugstatus.debugging = debugSave;
  554.   Output = OldOut;
  555.   gTop = gSave;
  556. }
  557.  
  558. void
  559. backTrace(frame, depth)
  560. LocalFrame frame;
  561. int depth;
  562. { extern int Output;
  563.   int OldOut = Output;
  564.   LocalFrame same_proc_frame = NULL;
  565.   Procedure proc = NULL;
  566.   int same_proc = 0;
  567.   int alien = FALSE;
  568.  
  569.   if ( frame == NULL )
  570.      frame = environment_frame;
  571.  
  572.   Output = 1;
  573.   for(; depth > 0 && frame;
  574.         alien = (frame->parent == NULL), frame = parentFrame(frame))
  575.   { if ( alien )
  576.       Putf("    <Alien goal>\n");
  577.  
  578.     if ( frame->procedure == proc )
  579.     { if ( ++same_proc >= 10 )
  580.       { if ( same_proc == 10 )
  581.       Putf("    ...\n    ...\n");
  582.     same_proc_frame = frame;  
  583.     continue;
  584.       }
  585.     } else
  586.     { if ( same_proc_frame != NULL )
  587.       { if ( false(same_proc_frame, FR_NODEBUG) || SYSTEM_MODE )
  588.         { Putf("    [%3ld] ", levelFrame(same_proc_frame));
  589.       writeFrameGoal(same_proc_frame, debugstatus.style);
  590.       depth--;
  591.       Put('\n');
  592.     }
  593.     same_proc_frame = NULL;
  594.     same_proc = 0;
  595.       }
  596.       proc = frame->procedure;
  597.     }
  598.  
  599.     if (false(frame, FR_NODEBUG) || SYSTEM_MODE)
  600.     { Putf("    [%3ld] ", levelFrame(frame));
  601.       writeFrameGoal(frame, debugstatus.style);
  602.       depth--;
  603.       Put('\n');
  604.     }
  605.   }
  606.   Output = OldOut;
  607. }
  608.  
  609. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  610. Trace interception mechanism.  Whenever the tracer wants to perform some
  611. action   it   will   first   call   the    users'    Prolog    predicate
  612. prolog_trace_interception/3, allowing the user to define his/her action.
  613. If  this procedure succeeds the tracer assumes the trace action has been
  614. done and returns, otherwise the  default  C-defined  trace  actions  are
  615. performed.
  616.  
  617. The functions traceInterception() and pl_prolog_trace_continuation() are
  618. the entry points from the C-defined tracer. $prolog_trace_interception/2
  619. is responsible for the communication with the users' predicate.
  620. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  621.  
  622. int trace_continuation;            /* how to continue? */
  623.  
  624. word
  625. pl_trace_continuation(what)
  626. Word what;
  627. { if (isInteger(*what) )
  628.   { trace_continuation = (int)valNum(*what);
  629.     succeed;
  630.   }
  631.  
  632.   fail;
  633. }
  634.  
  635. static int
  636. traceInterception(frame, port)
  637. LocalFrame frame;
  638. int port;
  639. { word goal;
  640.   Word arg;
  641.   mark m;
  642.   bool rval;
  643.  
  644.   if (status.boot == TRUE || status.debugLevel > 0)
  645.     return -1;
  646.  
  647.   Mark(m);
  648.   goal = globalFunctor(FUNCTOR_traceinterc2);
  649.   arg = argTermP(goal, 0);
  650.   switch(port)
  651.   { case CALL_PORT:    *arg = (word) ATOM_call;    break;
  652.     case REDO_PORT:    *arg = (word) ATOM_redo;    break;
  653.     case EXIT_PORT:    *arg = (word) ATOM_exit;    break;
  654.     case FAIL_PORT:    *arg = (word) ATOM_fail;    break;
  655.     case UNIFY_PORT:    *arg = (word) ATOM_unify;    break;
  656.   }
  657.   *++arg = PrologRef(frame);
  658.  
  659.   debugstatus.suspendTrace++;
  660.   rval = callGoal(MODULE_system, goal, FALSE);
  661.   debugstatus.suspendTrace--;
  662.  
  663.   Undo(m);
  664.  
  665.   if (rval == TRUE)
  666.     return trace_continuation;
  667.   else
  668.     return -1;
  669. }
  670.  
  671. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  672. Handling  interrupts.   We  know  we  are  not  in  critical  code  (see
  673. startCritical()  and endCritical(), so the heap is consistent.  The only
  674. problem can be that we are currently writing the arguments of  the  next
  675. goal  above  the  local  stack  top  pointer.  To avoid problems we just
  676. increment the top pointer to point above the furthest argument.
  677. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  678.  
  679. static void
  680. helpInterrupt()
  681. { Putf("Options:\n");
  682.   Putf("a:                 abort      b:                 break\n");
  683.   Putf("c:                 continue   e:                 exit\n");
  684.   Putf("g:                 goals      h (?):             help\n");
  685.   Putf("t:                 trace\n");
  686. }
  687.  
  688. void
  689. interruptHandler()
  690. { extern int Output;
  691.   int OldOut = Output;
  692.   LocalFrame oldltop = lTop;
  693.   Char c; 
  694.  
  695.   if ( status.initialised == FALSE )
  696.   { fprintf(stderr, "Interrupt during startup. Cannot continue\n");
  697.     Halt(1);
  698.   }  
  699.  
  700.   Output = 1;
  701.   lTop = (LocalFrame)addPointer(lTop, sizeof(struct localFrame) +
  702.                       MAXARITY * sizeof(word));
  703.  
  704. again:
  705.   Putf("\nAction (h for help) ? ");
  706.   pl_flush();
  707.   ResetTty();                           /* clear pending input -- atoenne -- */
  708.   c = getSingleChar();
  709.  
  710. #if O_SIG_AUTO_RESET
  711. #if OS2 && EMX
  712.   signal(SIGINT, SIG_ACK);
  713. #endif
  714.   signal(SIGINT, interruptHandler);    /* reinsert handler */
  715. #endif
  716.  
  717.   switch(c)
  718.   { case 'a':    Putf("abort\n");
  719.         pl_abort();
  720.         break;
  721.     case 'b':    Putf("break\n");
  722.         pl_break();
  723.         goto again;        
  724.     case 'c':    Putf("continue\n");
  725.         break;
  726.     case 04:
  727.     case EOF:    Putf("EOF: ");
  728.     case 'e':    Putf("exit\n");
  729.         pl_halt();
  730.         break;
  731.     case 'g':    Putf("goals\n");
  732.         backTrace(environment_frame, 5);
  733.         goto again;
  734.     case 'h':
  735.     case '?':    helpInterrupt();
  736.         goto again;
  737.     case 't':    Putf("trace\n");
  738.         pl_trace();
  739.         break;
  740.     default:    Putf("Unknown option (h for help)\n");
  741.         goto again;
  742.   }
  743.   Output = OldOut;
  744.   lTop = oldltop;
  745. }
  746.  
  747. void
  748. initTracer()
  749. { 
  750. #if unix || EMX
  751.   pl_signal(SIGINT, interruptHandler);
  752. #endif
  753.  
  754.   debugstatus.visible  = CALL_PORT|FAIL_PORT|REDO_PORT|EXIT_PORT;
  755.   debugstatus.leashing = CALL_PORT|FAIL_PORT|REDO_PORT|EXIT_PORT;
  756.   debugstatus.tracing = debugstatus.debugging = FALSE;
  757.   debugstatus.suspendTrace = FALSE;
  758.   debugstatus.skiplevel = 0;
  759.   debugstatus.style = status.boot ? W_WRITE : W_PRINT; 
  760.   debugstatus.showContext = FALSE;
  761. }
  762.  
  763.         /********************************
  764.         *       PROLOG PREDICATES       *
  765.         *********************************/
  766.  
  767. word
  768. pl_trace()
  769. { debugstatus.debugging = debugstatus.tracing = TRUE;
  770.   debugstatus.skiplevel = VERY_DEEP;
  771.   find.searching = FALSE;
  772.  
  773.   succeed;
  774. }
  775.  
  776. word
  777. pl_notrace()
  778. { debugstatus.tracing = FALSE;
  779.  
  780.   succeed;
  781. }
  782.  
  783. word
  784. pl_tracing()
  785. { return debugstatus.tracing;
  786. }
  787.  
  788. word
  789. pl_debug()
  790. { debugstatus.debugging = TRUE;
  791.   debugstatus.skiplevel = VERY_DEEP;
  792.  
  793.   succeed;
  794. }
  795.  
  796. word
  797. pl_nodebug()
  798. { debugstatus.debugging = FALSE;
  799.  
  800.   succeed;
  801. }
  802.  
  803. word
  804. pl_debugging()
  805. { if ( debugstatus.debugging )
  806.     succeed;
  807.  
  808.   fail;
  809. }
  810.  
  811. word
  812. pl_skip_level(old, new)
  813. Word old, new;
  814. { TRY(unifyAtomic(old, debugstatus.skiplevel == VERY_DEEP ?
  815.             (word) ATOM_very_deep :
  816.             consNum(debugstatus.skiplevel)) );
  817.  
  818.   if (isInteger(*new) )
  819.   { debugstatus.skiplevel = valNum(*new);
  820.     succeed;
  821.   }
  822.   if (isAtom(*new) && *new == (word) ATOM_very_deep)
  823.   { debugstatus.skiplevel = VERY_DEEP;
  824.     succeed;
  825.   }
  826.   fail;
  827. }
  828.  
  829. word
  830. pl_spy(p)
  831. Word p;
  832. { Procedure proc;
  833.  
  834.   if ((proc = findProcedure(p)) == (Procedure) NULL)
  835.     fail;
  836.   set(proc->definition, SPY_ME);
  837.  
  838.   return pl_debug();
  839. }
  840.  
  841. word
  842. pl_nospy(p)
  843. Word p;
  844. { Procedure proc;
  845.  
  846.   if ((proc = findProcedure(p)) == (Procedure) NULL)
  847.     fail;
  848.   clear(proc->definition, SPY_ME);
  849.  
  850.   succeed;
  851. }
  852.  
  853. word
  854. pl_leash(old, new)
  855. Word old, new;
  856. { TRY(unifyAtomic(old, consNum(debugstatus.leashing) ));
  857.  
  858.   if (!isInteger(*new) )
  859.     fail;
  860.   debugstatus.leashing = valNum(*new) & 0x1f;
  861.  
  862.   succeed;
  863. }
  864.  
  865. word
  866. pl_visible(old, new)
  867. Word old, new;
  868. { TRY(unifyAtomic(old, consNum(debugstatus.visible) ));
  869.  
  870.   if (!isInteger(*new) )
  871.     fail;
  872.   debugstatus.visible = valNum(*new) & 0x1f;
  873.  
  874.   succeed;
  875. }
  876.  
  877. word
  878. pl_unknown(old, new)
  879. Word old, new;
  880. { Module m = contextModule(environment_frame);
  881.  
  882.   TRY(unifyAtomic(old, true(m, UNKNOWN) ? ATOM_trace : ATOM_fail) );
  883.   if (*new == (word) ATOM_trace)
  884.     set(m, UNKNOWN);
  885.   else if (*new == (word) ATOM_fail)
  886.     clear(m, UNKNOWN);
  887.   else
  888.     return warning("unknown/2: argument should be 'fail' or 'trace'");
  889.  
  890.   succeed;
  891. }
  892.  
  893. word
  894. pl_prolog_current_frame(fr)
  895. Word fr;
  896. { return unifyAtomic(fr, PrologRef(parentFrame(environment_frame)));
  897. }
  898.  
  899. word
  900. pl_prolog_frame_attribute(frame, what, value)
  901. Word frame, what, value;
  902. { LocalFrame fr;
  903.   Atom key;
  904.   word result;
  905.  
  906.   if (!isInteger(*frame) || !isAtom(*what) || !isVar(*value))
  907.     return warning("prolog_frame_attribute/3: instantiation fault");
  908.  
  909.   if ((fr = FrameRef(*frame)) < lBase || fr > lTop)
  910.     return warning("prolog_frame_attribute/3: illegal frame reference");
  911.   key = (Atom) *what;
  912.   
  913.   if (        key == ATOM_level)
  914.   { result = consNum(levelFrame(fr));
  915.   } else if (key == ATOM_has_alternatives)
  916.   { result = consNum(hasAlternativesFrame(fr) );
  917.   } else if (key == ATOM_alternative)
  918.   { if (fr->backtrackFrame == (LocalFrame) NULL)
  919.       fail;
  920.     result = PrologRef(fr->backtrackFrame);
  921.   } else if (key == ATOM_parent)
  922.   { LocalFrame parent;
  923.  
  924.     if ((parent = parentFrame(fr)) != (LocalFrame) NULL)
  925.       result = PrologRef(parent);
  926.     fail;
  927.   } else if (key == ATOM_top)
  928.   { result = consNum(fr->parent == (LocalFrame) NULL ? 1 : 0);
  929.   } else if (key == ATOM_context_module)
  930.   { result = (word) contextModule(fr)->name;
  931.   } else if (key == ATOM_goal)
  932.   { int arity, n;
  933.     Word arg;
  934.     
  935.     if (fr->procedure->definition->module != MODULE_user)
  936.     { result = globalFunctor(FUNCTOR_module2);
  937.       argTerm(result, 0) = (word) fr->procedure->definition->module->name;
  938.       arg = argTermP(result, 1);
  939.     } else
  940.       arg = &result;
  941.  
  942.     if ((arity = fr->procedure->functor->arity) == 0)
  943.     { *arg = (word) fr->procedure->functor->name;
  944.     } else
  945.     { *arg = globalFunctor(fr->procedure->functor);
  946.       for(arg=argTermP(*arg, 0), n=0; n < arity; arg++, n++)
  947.     pl_unify(arg, argFrameP(fr, n) );
  948.     }
  949.   } else
  950.     return warning("prolog_frame_attribute/3: unknown key");
  951.  
  952.   return pl_unify(value, &result);
  953. }
  954.