home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-385-Vol-1of3.iso / s / siod-29.zip / SIOD-29.SHA / trace.c < prev   
C/C++ Source or Header  |  1993-01-09  |  4KB  |  145 lines
  1. /*    COPYRIGHT (c) 1992 BY
  2.  *    MITECH CORPORATION, CONCORD, MASSACHUSETTS.
  3.  *    See the source file SLIB.C for more information.
  4.  
  5. (trace procedure1 procedure2 ...)
  6. (untrace procedure1 procedure2 ...)
  7.  
  8. Currently only user-defined procedures can be traced.
  9. Fancy printing features such as indentation based on
  10. recursion level will also have to wait for a future version.
  11.  
  12.  
  13.  */
  14.  
  15. #include <stdio.h>
  16. #include "siod.h"
  17. #include <setjmp.h>
  18. #include "siodp.h"
  19.  
  20. #define tc_closure_traced tc_sys_1
  21.  
  22. static LISP sym_traced = NIL;
  23. static LISP sym_quote = NIL;
  24. static LISP sym_begin = NIL;
  25.  
  26. LISP ltrace_fcn_name(LISP body);
  27. LISP ltrace_1(LISP fcn_name,LISP env);
  28. LISP ltrace(LISP fcn_names,LISP env);
  29. LISP luntrace_1(LISP fcn);
  30. LISP luntrace(LISP fcns);
  31. static void ct_gc_scan(LISP ptr);
  32. static LISP ct_gc_mark(LISP ptr);
  33. void ct_prin1(LISP ptr,FILE *f);
  34. LISP ct_eval(LISP ct,LISP *px,LISP *penv);
  35.  
  36. LISP ltrace_fcn_name(LISP body)
  37. {LISP tmp;
  38.  if NCONSP(body) return(NIL);
  39.  if NEQ(CAR(body),sym_begin) return(NIL);
  40.  tmp = CDR(body);
  41.  if NCONSP(tmp) return(NIL);
  42.  tmp = CAR(tmp);
  43.  if NCONSP(tmp) return(NIL);
  44.  if NEQ(CAR(tmp),sym_quote) return(NIL);
  45.  tmp = CDR(tmp);
  46.  if NCONSP(tmp) return(NIL);
  47.  return(CAR(tmp));}
  48.  
  49. LISP ltrace_1(LISP fcn_name,LISP env)
  50. {LISP fcn,code;
  51.  fcn = leval(fcn_name,env);
  52.  switch TYPE(fcn)
  53.    {case tc_closure:
  54.       code = fcn->storage_as.closure.code;
  55.       if NULLP(ltrace_fcn_name(cdr(code)))
  56.     setcdr(code,cons(sym_begin,
  57.              cons(cons(sym_quote,cons(fcn_name,NIL)),
  58.                   cons(cdr(code),NIL))));
  59.       fcn->type = tc_closure_traced;
  60.       break;
  61.     case tc_closure_traced:
  62.       break;
  63.     default:
  64.       err("not a closure, cannot trace",fcn);}
  65.  return(NIL);}
  66.  
  67. LISP ltrace(LISP fcn_names,LISP env)
  68. {LISP l;
  69.  for(l=fcn_names;NNULLP(l);l=cdr(l))
  70.    ltrace_1(car(l),env);
  71.  return(NIL);}
  72.  
  73. LISP luntrace_1(LISP fcn)
  74. {switch TYPE(fcn)
  75.    {case tc_closure:
  76.       break;
  77.     case tc_closure_traced:
  78.       fcn->type = tc_closure;
  79.       break;
  80.     default:
  81.       err("not a closure, cannot untrace",fcn);}
  82.  return(NIL);}
  83.  
  84. LISP luntrace(LISP fcns)
  85. {LISP l;
  86.  for(l=fcns;NNULLP(l);l=cdr(l))
  87.    luntrace_1(car(l));
  88.  return(NIL);}
  89.  
  90. static void ct_gc_scan(LISP ptr)
  91. {CAR(ptr) = gc_relocate(CAR(ptr));
  92.  CDR(ptr) = gc_relocate(CDR(ptr));}
  93.  
  94. static LISP ct_gc_mark(LISP ptr)
  95. {long j;
  96.  gc_mark(ptr->storage_as.closure.code);
  97.  return(ptr->storage_as.closure.env);}
  98.  
  99. void ct_prin1(LISP ptr,FILE *f)
  100. {fput_st(f,"#<CLOSURE(TRACED) ");
  101.  lprin1f(car(ptr->storage_as.closure.code),f);
  102.  fput_st(f," ");
  103.  lprin1f(cdr(ptr->storage_as.closure.code),f);
  104.  fput_st(f,">");}
  105.  
  106. LISP ct_eval(LISP ct,LISP *px,LISP *penv)
  107. {LISP lexname,fcn_name,args,env,result,l;
  108.  lexname = CAR(*px);
  109.  fcn_name = ltrace_fcn_name(cdr(ct->storage_as.closure.code));
  110.  args = leval_args(CDR(*px),*penv);
  111.  fput_st(stdout,"->");
  112.  lprin1f(fcn_name,stdout);
  113.  for(l=args;NNULLP(l);l=cdr(l))
  114.    {fput_st(stdout," ");
  115.     lprin1f(car(l),stdout);}
  116.  fput_st(stdout,"\n");
  117.  env = extend_env(args,
  118.           car(ct->storage_as.closure.code),
  119.           ct->storage_as.closure.env);
  120.  result = leval(cdr(ct->storage_as.closure.code),env);
  121.  fput_st(stdout,"<-");
  122.  lprin1f(fcn_name,stdout);
  123.  fput_st(stdout," ");
  124.  lprin1f(result,stdout);
  125.  fput_st(stdout,"\n");
  126.  *px = result;
  127.  return(NIL);}
  128.  
  129. void init_trace(void)
  130. {long j;
  131.  set_gc_hooks(tc_closure_traced,
  132.           NULL,
  133.           ct_gc_mark,
  134.           ct_gc_scan,
  135.           NULL,
  136.           &j);
  137.  gc_protect_sym(&sym_traced,"*traced*");
  138.  setvar(sym_traced,NIL,NIL);
  139.  gc_protect_sym(&sym_begin,"begin");
  140.  gc_protect_sym(&sym_quote,"quote");
  141.  set_print_hooks(tc_closure_traced,ct_prin1);
  142.  set_eval_hooks(tc_closure_traced,ct_eval);
  143.  init_subr("trace",tc_fsubr,ltrace);
  144.  init_subr("untrace",tc_lsubr,luntrace);}
  145.