home *** CD-ROM | disk | FTP | other *** search
/ Super Net 1 / SUPERNET_1.iso / PC / OTROS / MSDOS / WATTCP / DELFT / SAGE.TAR / sage / scheme / schtra.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-04-26  |  4.9 KB  |  180 lines

  1. /**********************************************************************
  2. ** MODULE INFORMATION*
  3. **********************
  4. **      FILE     NAME:       SCHTRA.C
  5. **      SYSTEM   NAME:       SCHEME
  6. **      ORIGINAL AUTHOR(S):  Alfred Kayser
  7. **      VERSION  NUMBER:     1.5.5
  8. **      CREATION DATE:       89/05/09
  9. **
  10. ** DESCRIPTION: This module contains functions to
  11. **              trace the DScheme interpreter.
  12. ***********************************************************************
  13. ** CHANGES INFORMATION **
  14. *************************
  15. ** REVISION:    $Revision:   1.0  $
  16. ** CHANGER:     $Author:   JAN  $
  17. ** WORKFILE:    $Workfile:   schtra.c  $
  18. ** LOGFILE:     $Logfile:   C:/CPROG/SCHEME/VCS/SCHTRA.C_V  $
  19. ** LOGINFO:     $Log:   C:/CPROG/SCHEME/VCS/SCHTRA.C_V  $
  20. **
  21. **                 Rev 1.0   12 Oct 1989 11:45:36   JAN
  22. **              Initial revision.
  23. **********************************************************************/
  24. #include "schinc.h"
  25.  
  26. STATIC void PASCAL DsTraMessage __((int c, CELP item));
  27. STATIC void PASCAL DsTraceDummy __((int position));
  28. STATIC void PASCAL DsTraceHook  __((int position));
  29. STATIC CELP CDECL  Ds_strace    __((CELP arg));
  30. STATIC CELP CDECL  Ds_gtrace    __((void));
  31.  
  32. STATIC EXTDEF extensions[]=
  33.     {
  34.         {"GET-TRACE",  (EXTPROC)Ds_gtrace, 0},
  35.         {"SET-TRACE!", (EXTPROC)Ds_strace, 1, TYPE_INT},
  36.         ENDOFLIST
  37.     };
  38.  
  39. #define LEVEL_OFF   0x00
  40. #define LEVEL_EVAL  0x01
  41. #define LEVEL_APPLY 0x02
  42. #define LEVEL_TAIL  0x04
  43. #define LEVEL_MACRO 0x08
  44. #define LEVEL_SELF  0x10
  45.  
  46. TCALL tracer = DsTraceDummy;
  47. int   trace = 0;
  48.  
  49. /***************************************************************
  50. ** NAME:        DsTraceInit
  51. ** SYNOPSIS:    int DsTraceInit()
  52. ** DESCRIPTION: Initializes and link some trace functions to the
  53. **              DScheme system.
  54. ** RETURNS:     S_ERROR, if error occured.
  55. **              S_OKAY otherwise.
  56. ***************************************************************/
  57. void PASCAL DsTraceInit()
  58. {
  59.     trace = 0;
  60.     tracer = DsTraceDummy;
  61.     DsFuncDef(extensions);        /* link extended functions */
  62. }
  63.  
  64.  
  65. STATIC
  66. CELP Ds_strace(arg)
  67. CELP arg;
  68. {
  69.     trace = (int)CELINT(arg);
  70.     tracer = (trace) ? (TCALL)DsTraceHook : (TCALL)DsTraceDummy;
  71.     return(arg);
  72. }
  73.  
  74.  
  75. STATIC
  76. CELP Ds_gtrace()
  77. {
  78.     return DSINTCEL(trace);
  79. }
  80.  
  81. /***************************************************************
  82. ** NAME:        DsTraceDummy
  83. ** SYNOPSIS:    void PASCAL DsTraceDummy(n);
  84. **              int n;
  85. ** DESCRIPTION: Dummy function.
  86. ** RETURNS:     void
  87. ***************************************************************/
  88. STATIC
  89. void PASCAL DsTraceDummy(place)
  90. int place;
  91. {
  92.     place;
  93. }
  94.  
  95. /***************************************************************
  96. ** NAME:        DsTraceHook
  97. ** SYNOPSIS:    void DsTraceHook(key,n);
  98. **              CELP key;      The keyword to apply
  99. **              int position;  Position in the evaluator
  100. ** DESCRIPTION: Prints a trace message, when the corresponding
  101. **              trace bit is set.
  102. **              Currently there are four trace bits defined:
  103. **              1. Entering, tailing and returning complex evals
  104. **              2. Apply and return.
  105. **              4. Macro substitutions.
  106. **              8. Self evaluating expressions
  107. ** RETURNS:     void
  108. ***************************************************************/
  109. STATIC
  110. void PASCAL DsTraceHook(position)
  111. int position;
  112. {
  113.     switch(position)
  114.     {
  115.     case T_START:                  /* start complex evaluation */
  116.         if (trace&LEVEL_EVAL)
  117.         {
  118.             DsTraMessage('E',item);
  119.             GLOB(evaldepth)++;
  120.         }
  121.         break;
  122.  
  123.     case T_APPLY:
  124.         if (trace&LEVEL_APPLY)
  125.             DsTraMessage('A',DsCons(key,item));
  126.         break;
  127.  
  128.     case T_END:                     /* end complex evaluation */
  129.         if (trace&LEVEL_EVAL)
  130.             if (GLOB(evaldepth)>0) GLOB(evaldepth)--;
  131.         if (trace&(LEVEL_APPLY|LEVEL_EVAL))
  132.             DsTraMessage('R',item);
  133.         break;
  134.  
  135.     case T_TAIL:
  136.         if (trace&LEVEL_TAIL) DsTraMessage('T',item);
  137.         break;
  138.  
  139.     case T_MACRO:
  140.         if (trace&LEVEL_MACRO) DsTraMessage('M',item);
  141.         break;
  142.  
  143.     case T_SELF:             
  144.         if (trace&LEVEL_SELF) DsTraMessage('S',item);
  145.         break;
  146.  
  147.     case T_LOOKUP:
  148.         if (trace&LEVEL_MACRO) DsTraMessage('L',item);
  149.         break;
  150.     }
  151. }
  152.  
  153.  
  154. /***************************************************************
  155. ** NAME:        DsTraMessage
  156. ** SYNOPSIS:    void DsTraMessage(c,item);
  157. **              char c;         Trace message character.
  158. **              CELP item;      The expression to trace.
  159. ** DESCRIPTION: Prints a trace message.
  160. ** RETURNS:     void
  161. ***************************************************************/
  162. STATIC void PASCAL DsTraMessage(c,item)
  163. int c;
  164. CELP item;
  165. {
  166. #ifdef INDENT    
  167.     int n;
  168.     DsOutf(GLOB(errport),"TRACE %c:",c);
  169.     for (n=GLOB(evaldepth);n;n--) DsOut(GLOB(errport),' ');
  170.     DsOutf(GLOB(errport),"%a\n", item);
  171. #else
  172.     DsOutf(GLOB(errport),"TRACE %c: (%d) %a\n", (c), GLOB(evaldepth), (item));
  173. #endif
  174. }
  175.  
  176.  
  177.  
  178.  
  179.  
  180.