home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Lib / trace.stk < prev    next >
Encoding:
Text File  |  1996-04-10  |  6.2 KB  |  179 lines
  1.  
  2. ; trace of a procedure
  3.  
  4. ; list of traced  procedures : global variable, empty at first
  5. (define *traced-proc-list* '(()))
  6. ; value of indent for trace : global variable, null at first
  7. (define *trace-indent* 0)
  8.  
  9. ;***********************************************************************
  10. ; UNTRACE of an object
  11. ;***********************************************************************
  12. (define (delete! proc)
  13.   ; "proc" is in *traced-proc-list*
  14.   (let ((before *traced-proc-list*)
  15.     (now (cdr *traced-proc-list*)))
  16.     (while (not (eq? proc (caar now)))
  17.        (set! before now)
  18.        (set! now (cdr now)))
  19.     ; "now" <==> proc, ==> remove it
  20.     (set-cdr! before (cdr now))))
  21.  
  22. (define-macro (untrace-one obj)
  23.   `(let ((already (assoc ',obj *traced-proc-list*)))
  24.      (cond ((pair? already)  ; the name of this procedure is in *traced-proc-list*
  25.         (delete! ',obj)  ; remove it in *traced-proc-list*
  26.         (if (eq? (cdr already) 'var) ; the obj traced is a variable
  27.         (untrace-var ',obj)
  28.         ; else the obj traced is a procedure
  29.         (if (and (procedure? ,obj)
  30.              (eq? (cadr (procedure-body ,obj))
  31.                   '**arguments-de-trace-mf**))
  32.             ; obj was a procedure already traced ==> restore its body
  33.             (set! ,obj (cdr already)))))
  34.        (else   ; "obj" is not "traced on" ==> message without error
  35.         (format #t "~S is not traced on~%" ',obj)))))
  36.  
  37. (define-macro (untrace . args)
  38.   `(if (not (null? ',args))
  39.        (begin
  40.      ,@(map (lambda (x)
  41.           `(untrace-one ,x))
  42.         args))
  43.        (error "untrace: too few arguments")))
  44.  
  45. ;***********************************************************************
  46. ; UNTRACE-ALL <==> UNTRACE ALL the objects traced
  47. ; ==> restore the bodies of all traced procedures
  48. ;***********************************************************************
  49.  
  50. (define-macro (untrace-all)
  51.   `(if (not (null? (cdr *traced-proc-list*)))
  52.       (begin 
  53.      ,@(map (lambda (x)
  54.           `(untrace-one ,(car x)))
  55.         (cdr *traced-proc-list*)))))
  56.  
  57. ;***********************************************************************
  58. ; TRACE
  59. ;***********************************************************************
  60.  
  61. (define (indent x)            ; displays "x" periods on current output-port
  62.   (format #t "~A" (make-string x #\.)))
  63.  
  64. (define (display-arguments form-list act-list)
  65.   ; "form-list" contains formal parameters
  66.   ; "act-list" contains actual parameters
  67.   (cond ((and (null? form-list) (null? act-list))
  68.      ; two empty lists ==> nothing to do, go to new line
  69.      (newline))
  70.     ((not (list? form-list)) ; x or improper list (x a b c . y)
  71.      (if (not (pair? form-list)) ; x only
  72.          (format #t "~S=~S~%" form-list act-list)
  73.          ; improper list :
  74.          (if (not (null? act-list))
  75.          (begin   
  76.            (format #t "~S=~S "    ; display x
  77.                (car form-list) (car act-list))
  78.            (if (not (list? (cdr form-list))) 
  79.                ; form-list = (a b c . y)
  80.                (display-arguments (cdr form-list)
  81.                       (cdr act-list))
  82.                ; else form-list was (x . y)
  83.                (format #t "~S=~S~%"    ; display y
  84.                    (cdr form-list) (cdr act-list))))
  85.          ; else, form-list = (x . y) and act-list = () ==> error
  86.          (begin (newline)
  87.             (set! *trace-indent* 0) 
  88.             (error "Too few actual parameters")))))
  89.     ((null? form-list)  ; error
  90.      (newline)
  91.      (set! *trace-indent* 0)     
  92.      (error "Too many actual parameters"))
  93.     ((null? act-list) ; error
  94.      (newline)
  95.      (set! *trace-indent* 0)     
  96.      (error "Too few actual parameters"))
  97.     (else ; form-list and act-list are "proper lists" and not empty
  98.      (format #t "~S=~S " (car form-list) (car act-list))
  99.      (display-arguments (cdr form-list) (cdr act-list)))))
  100.  
  101.  
  102. (define-macro (trace-one obj)
  103.   `(let ((last-proc ,obj) ; body of procedure to trace
  104.      (res '())         ; result of procedure to trace
  105.      (already (assoc ',obj *traced-proc-list*)))
  106.      (cond ((primitive? ,obj) ; on ne peut pas.....
  107.         (error "the primitive ~S can't be traced~%" ',obj))
  108.        ((not (procedure? ,obj))
  109.         ; obj is a variable
  110.         (if (pair? already) 
  111.         ; name of the obj is already in *traced-proc-list*
  112.         (if (not (eq? (cdr already) 'var))
  113.             ; this variable is already traced on but as a procedure
  114.             (begin
  115.               (untrace-one ,obj)  ; remove the last trace
  116.               (trace-one ,obj))  ; trace the new variable
  117.             ; else, this variable is already traced on as a variable
  118.             ; ==> display a message, without error
  119.             (format #t "~S already traced on~%" ',obj))
  120.         ; else it's the first trace on this variable
  121.         (begin     ; ==> put it in *traced-proc-list*
  122.           (set! *traced-proc-list*
  123.             (cons '()
  124.                   (cons (cons ',obj 'var)
  125.                     (cdr *traced-proc-list*))))
  126.           (trace-var ',obj
  127.                  (lambda () (format #t "~S ==> ~S~%" ',obj ,obj))))))
  128.        ; obj is a procedure, not a primitive
  129.        ((pair? already)   ; name of obj is already in *traced-proc-list*
  130.         (if (eq? (cadr (procedure-body ,obj))
  131.              '**arguments-de-trace-mf**)
  132.         ; this obj is already traced on as a procedure
  133.         ; ==> display a message, without error
  134.         (format #t "~S already traced on~%" ',obj)
  135.         ; this procedure has the same name of an obj
  136.         ; already traced on ==> perhaps a new definition... ==>
  137.         (begin
  138.           (untrace-one ,obj)  ; remove the last
  139.           (trace-one ,obj))))  ; trace the new
  140.        (else ; this procedure is not already traced on
  141.         ; ==> put it in *traced-proc-list*
  142.         (set! *traced-proc-list*
  143.           (cons '()
  144.             (cons (cons ',obj last-proc)
  145.                   (cdr *traced-proc-list*))))
  146.         (set! ,obj
  147.           (lambda **arguments-de-trace-mf**
  148.             (dynamic-wind 
  149.  
  150.              (lambda ()
  151.                 ; indent more
  152.                (set! *trace-indent* (+ *trace-indent* 2))
  153.                (indent *trace-indent*)
  154.                ; display entering in procedure (its name)
  155.                (format #t "Entering ~S " ',obj)
  156.                ; display formal and actual parameters
  157.                (display-arguments (cadr (procedure-body last-proc))
  158.                       **arguments-de-trace-mf**))
  159.              (lambda ()
  160.                ; eval the result of the procedure
  161.                (set! res 
  162.                  (apply last-proc **arguments-de-trace-mf**))
  163.                ; exiting of procedure
  164.                (indent *trace-indent*)
  165.                (format #t "Exiting ~S result = ~S~%" ',obj res))
  166.              (lambda ()
  167.                (set! *trace-indent* (- *trace-indent* 2)))) ; indent less
  168.             res))))))
  169.  
  170. (define-macro (trace . args)
  171.   `(if (not (null? ',args))
  172.        (begin
  173.      ,@(map (lambda (x)
  174.           `(trace-one ,x))
  175.         args))
  176.        (error "trace: too few arguments")))
  177.  
  178.  
  179.