;** allow primitives

; Procedure call/return tracing

; Uses: startup

(define trace

(lambda (var)

(if (get var 'traced)

(list var 'already 'traced)

(if (not (bound-to-lambda? var))

'(not a defined-procedure name)

(begin

(put var 'traced (eval var))

(set var (make-traced var))

var)))))

(define untrace

(lambda (var)

(if (not (get var 'traced))

(list var 'not 'traced)

(begin

(set var (get var 'traced))

var))))

(define bound-to-lambda?

(lambda (var)

(and (symbol? var)

(let ((value (eval var)))

(and (pair? value)

(eq? (car value) 'lambda))))))

(define make-traced

(lambda (var)

(let ((proc (eval var)))

(list 'lambda (cadr proc)

(list '=enter= (list 'quote var) (cons 'list (cadr proc)))

(list '=exit= (list 'quote var)

(cons (list 'get (list 'quote var) (list 'quote 'traced))

(cadr proc)))))))

(define =enter=

(lambda (name args)

(tab *indentation*)

(set! *indentation* (+ *indentation* 1))

(write 'entering)

(write name)

(write ':)

(for-each write args)

(newline)))

(define =exit=

(lambda (name result)

(set! *indentation* (- *indentation* 1))

(tab *indentation*)

(write 'exiting)

(write name)

(write ':)

(print result)

result))

(define *indentation* 0)

(define tab

(lambda (n)

(while (< 0 n)

(write '>)

(set! n (- n 1)))))

(define set

(lambda (var value)

(eval (list 'set! var (list 'quote value)))))