stk/Lib/trace.stk

179 lines
6.2 KiB
Plaintext

; trace of a procedure
; list of traced procedures : global variable, empty at first
(define *traced-proc-list* '(()))
; value of indent for trace : global variable, null at first
(define *trace-indent* 0)
;***********************************************************************
; UNTRACE of an object
;***********************************************************************
(define (delete! proc)
; "proc" is in *traced-proc-list*
(let ((before *traced-proc-list*)
(now (cdr *traced-proc-list*)))
(while (not (eq? proc (caar now)))
(set! before now)
(set! now (cdr now)))
; "now" <==> proc, ==> remove it
(set-cdr! before (cdr now))))
(define-macro (untrace-one obj)
`(let ((already (assoc ',obj *traced-proc-list*)))
(cond ((pair? already) ; the name of this procedure is in *traced-proc-list*
(delete! ',obj) ; remove it in *traced-proc-list*
(if (eq? (cdr already) 'var) ; the obj traced is a variable
(untrace-var ',obj)
; else the obj traced is a procedure
(if (and (procedure? ,obj)
(eq? (cadr (procedure-body ,obj))
'**arguments-de-trace-mf**))
; obj was a procedure already traced ==> restore its body
(set! ,obj (cdr already)))))
(else ; "obj" is not "traced on" ==> message without error
(format #t "~S is not traced on~%" ',obj)))))
(define-macro (untrace . args)
`(if (not (null? ',args))
(begin
,@(map (lambda (x)
`(untrace-one ,x))
args))
(error "untrace: too few arguments")))
;***********************************************************************
; UNTRACE-ALL <==> UNTRACE ALL the objects traced
; ==> restore the bodies of all traced procedures
;***********************************************************************
(define-macro (untrace-all)
`(if (not (null? (cdr *traced-proc-list*)))
(begin
,@(map (lambda (x)
`(untrace-one ,(car x)))
(cdr *traced-proc-list*)))))
;***********************************************************************
; TRACE
;***********************************************************************
(define (indent x) ; displays "x" periods on current output-port
(format #t "~A" (make-string x #\.)))
(define (display-arguments form-list act-list)
; "form-list" contains formal parameters
; "act-list" contains actual parameters
(cond ((and (null? form-list) (null? act-list))
; two empty lists ==> nothing to do, go to new line
(newline))
((not (list? form-list)) ; x or improper list (x a b c . y)
(if (not (pair? form-list)) ; x only
(format #t "~S=~S~%" form-list act-list)
; improper list :
(if (not (null? act-list))
(begin
(format #t "~S=~S " ; display x
(car form-list) (car act-list))
(if (not (list? (cdr form-list)))
; form-list = (a b c . y)
(display-arguments (cdr form-list)
(cdr act-list))
; else form-list was (x . y)
(format #t "~S=~S~%" ; display y
(cdr form-list) (cdr act-list))))
; else, form-list = (x . y) and act-list = () ==> error
(begin (newline)
(set! *trace-indent* 0)
(error "Too few actual parameters")))))
((null? form-list) ; error
(newline)
(set! *trace-indent* 0)
(error "Too many actual parameters"))
((null? act-list) ; error
(newline)
(set! *trace-indent* 0)
(error "Too few actual parameters"))
(else ; form-list and act-list are "proper lists" and not empty
(format #t "~S=~S " (car form-list) (car act-list))
(display-arguments (cdr form-list) (cdr act-list)))))
(define-macro (trace-one obj)
`(let ((last-proc ,obj) ; body of procedure to trace
(res '()) ; result of procedure to trace
(already (assoc ',obj *traced-proc-list*)))
(cond ((primitive? ,obj) ; on ne peut pas.....
(error "the primitive ~S can't be traced~%" ',obj))
((not (procedure? ,obj))
; obj is a variable
(if (pair? already)
; name of the obj is already in *traced-proc-list*
(if (not (eq? (cdr already) 'var))
; this variable is already traced on but as a procedure
(begin
(untrace-one ,obj) ; remove the last trace
(trace-one ,obj)) ; trace the new variable
; else, this variable is already traced on as a variable
; ==> display a message, without error
(format #t "~S already traced on~%" ',obj))
; else it's the first trace on this variable
(begin ; ==> put it in *traced-proc-list*
(set! *traced-proc-list*
(cons '()
(cons (cons ',obj 'var)
(cdr *traced-proc-list*))))
(trace-var ',obj
(lambda () (format #t "~S ==> ~S~%" ',obj ,obj))))))
; obj is a procedure, not a primitive
((pair? already) ; name of obj is already in *traced-proc-list*
(if (eq? (cadr (procedure-body ,obj))
'**arguments-de-trace-mf**)
; this obj is already traced on as a procedure
; ==> display a message, without error
(format #t "~S already traced on~%" ',obj)
; this procedure has the same name of an obj
; already traced on ==> perhaps a new definition... ==>
(begin
(untrace-one ,obj) ; remove the last
(trace-one ,obj)))) ; trace the new
(else ; this procedure is not already traced on
; ==> put it in *traced-proc-list*
(set! *traced-proc-list*
(cons '()
(cons (cons ',obj last-proc)
(cdr *traced-proc-list*))))
(set! ,obj
(lambda **arguments-de-trace-mf**
(dynamic-wind
(lambda ()
; indent more
(set! *trace-indent* (+ *trace-indent* 2))
(indent *trace-indent*)
; display entering in procedure (its name)
(format #t "Entering ~S " ',obj)
; display formal and actual parameters
(display-arguments (cadr (procedure-body last-proc))
**arguments-de-trace-mf**))
(lambda ()
; eval the result of the procedure
(set! res
(apply last-proc **arguments-de-trace-mf**))
; exiting of procedure
(indent *trace-indent*)
(format #t "Exiting ~S result = ~S~%" ',obj res))
(lambda ()
(set! *trace-indent* (- *trace-indent* 2)))) ; indent less
res))))))
(define-macro (trace . args)
`(if (not (null? ',args))
(begin
,@(map (lambda (x)
`(trace-one ,x))
args))
(error "trace: too few arguments")))