home *** CD-ROM | disk | FTP | other *** search
/ PC Pro 2002 April / pcpro0402.iso / essentials / graphics / Gimp / gimp-src-20001226.exe / src / gimp / plug-ins / script-fu / interp_trace.c < prev    next >
Encoding:
C/C++ Source or Header  |  1998-04-10  |  4.3 KB  |  193 lines
  1.  
  2. /*    COPYRIGHT (c) 1992-1994 BY
  3.  *    MITECH CORPORATION, ACTON, MASSACHUSETTS.
  4.  *    See the source file SLIB.C for more information.
  5.  
  6.  (trace procedure1 procedure2 ...)
  7.  (untrace procedure1 procedure2 ...)
  8.  
  9.  Currently only user-defined procedures can be traced.
  10.  Fancy printing features such as indentation based on
  11.  recursion level will also have to wait for a future version.
  12.  
  13.  
  14.  */
  15.  
  16. #include <stdio.h>
  17. #include <stdlib.h>
  18. #include <setjmp.h>
  19. #include "siod.h"
  20. #include "siodp.h"
  21.  
  22. static void 
  23. init_trace_version (void)
  24. {
  25.   setvar (cintern ("*trace-version*"),
  26.       cintern ("$Id: interp_trace.c,v 1.3 1998/04/11 05:07:47 yosh Exp $"),
  27.       NIL);
  28. }
  29.  
  30.  
  31. static long tc_closure_traced = 0;
  32.  
  33. static LISP sym_traced = NIL;
  34. static LISP sym_quote = NIL;
  35. static LISP sym_begin = NIL;
  36.  
  37. LISP ltrace_fcn_name (LISP body);
  38. LISP ltrace_1 (LISP fcn_name, LISP env);
  39. LISP ltrace (LISP fcn_names, LISP env);
  40. LISP luntrace_1 (LISP fcn);
  41. LISP luntrace (LISP fcns);
  42. static void ct_gc_scan (LISP ptr);
  43. static LISP ct_gc_mark (LISP ptr);
  44. void ct_prin1 (LISP ptr, struct gen_printio *f);
  45. LISP ct_eval (LISP ct, LISP * px, LISP * penv);
  46.  
  47. LISP 
  48. ltrace_fcn_name (LISP body)
  49. {
  50.   LISP tmp;
  51.   if NCONSP
  52.     (body) return (NIL);
  53.   if NEQ
  54.     (CAR (body), sym_begin) return (NIL);
  55.   tmp = CDR (body);
  56.   if NCONSP
  57.     (tmp) return (NIL);
  58.   tmp = CAR (tmp);
  59.   if NCONSP
  60.     (tmp) return (NIL);
  61.   if NEQ
  62.     (CAR (tmp), sym_quote) return (NIL);
  63.   tmp = CDR (tmp);
  64.   if NCONSP
  65.     (tmp) return (NIL);
  66.   return (CAR (tmp));
  67. }
  68.  
  69. LISP 
  70. ltrace_1 (LISP fcn_name, LISP env)
  71. {
  72.   LISP fcn, code;
  73.   fcn = leval (fcn_name, env);
  74.   if (TYPE (fcn) == tc_closure)
  75.     {
  76.       code = fcn->storage_as.closure.code;
  77.       if NULLP
  78.     (ltrace_fcn_name (cdr (code)))
  79.       setcdr (code, cons (sym_begin,
  80.                   cons (cons (sym_quote, cons (fcn_name, NIL)),
  81.                     cons (cdr (code), NIL))));
  82.       fcn->type = tc_closure_traced;
  83.     }
  84.   else if (TYPE (fcn) == tc_closure_traced)
  85.     ;
  86.   else
  87.     my_err ("not a closure, cannot trace", fcn);
  88.   return (NIL);
  89. }
  90.  
  91. LISP 
  92. ltrace (LISP fcn_names, LISP env)
  93. {
  94.   LISP l;
  95.   for (l = fcn_names; NNULLP (l); l = cdr (l))
  96.     ltrace_1 (car (l), env);
  97.   return (NIL);
  98. }
  99.  
  100. LISP 
  101. luntrace_1 (LISP fcn)
  102. {
  103.   if (TYPE (fcn) == tc_closure)
  104.     ;
  105.   else if (TYPE (fcn) == tc_closure_traced)
  106.     fcn->type = tc_closure;
  107.   else
  108.     my_err ("not a closure, cannot untrace", fcn);
  109.   return (NIL);
  110. }
  111.  
  112. LISP 
  113. luntrace (LISP fcns)
  114. {
  115.   LISP l;
  116.   for (l = fcns; NNULLP (l); l = cdr (l))
  117.     luntrace_1 (car (l));
  118.   return (NIL);
  119. }
  120.  
  121. static void 
  122. ct_gc_scan (LISP ptr)
  123. {
  124.   CAR (ptr) = gc_relocate (CAR (ptr));
  125.   CDR (ptr) = gc_relocate (CDR (ptr));
  126. }
  127.  
  128. static LISP 
  129. ct_gc_mark (LISP ptr)
  130. {
  131.   gc_mark (ptr->storage_as.closure.code);
  132.   return (ptr->storage_as.closure.env);
  133. }
  134.  
  135. void 
  136. ct_prin1 (LISP ptr, struct gen_printio *f)
  137. {
  138.   gput_st (f, "#<CLOSURE(TRACED) ");
  139.   lprin1g (car (ptr->storage_as.closure.code), f);
  140.   gput_st (f, " ");
  141.   lprin1g (cdr (ptr->storage_as.closure.code), f);
  142.   gput_st (f, ">");
  143. }
  144.  
  145. LISP 
  146. ct_eval (LISP ct, LISP * px, LISP * penv)
  147. {
  148.   LISP fcn_name, args, env, result, l;
  149.   fcn_name = ltrace_fcn_name (cdr (ct->storage_as.closure.code));
  150.   args = leval_args (CDR (*px), *penv);
  151.   fput_st (stdout, "->");
  152.   lprin1f (fcn_name, stdout);
  153.   for (l = args; NNULLP (l); l = cdr (l))
  154.     {
  155.       fput_st (stdout, " ");
  156.       lprin1f (car (l), stdout);
  157.     }
  158.   fput_st (stdout, "\n");
  159.   env = extend_env (args,
  160.             car (ct->storage_as.closure.code),
  161.             ct->storage_as.closure.env);
  162.   result = leval (cdr (ct->storage_as.closure.code), env);
  163.   fput_st (stdout, "<-");
  164.   lprin1f (fcn_name, stdout);
  165.   fput_st (stdout, " ");
  166.   lprin1f (result, stdout);
  167.   fput_st (stdout, "\n");
  168.   *px = result;
  169.   return (NIL);
  170. }
  171.  
  172. void 
  173. init_trace (void)
  174. {
  175.   long j;
  176.   tc_closure_traced = allocate_user_tc ();
  177.   set_gc_hooks (tc_closure_traced,
  178.         NULL,
  179.         ct_gc_mark,
  180.         ct_gc_scan,
  181.         NULL,
  182.         &j);
  183.   gc_protect_sym (&sym_traced, "*traced*");
  184.   setvar (sym_traced, NIL, NIL);
  185.   gc_protect_sym (&sym_begin, "begin");
  186.   gc_protect_sym (&sym_quote, "quote");
  187.   set_print_hooks (tc_closure_traced, ct_prin1);
  188.   set_eval_hooks (tc_closure_traced, ct_eval);
  189.   init_fsubr ("trace", ltrace);
  190.   init_lsubr ("untrace", luntrace);
  191.   init_trace_version ();
  192. }
  193.