stk/Lib/trace.stk

;;;;
;;;; t r a c e . s t k			
;;;;
;;;; Copyright © 1997-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;; 
;;;; Permission to use, copy, modify, distribute,and license this
;;;; software and its documentation for any purpose is hereby granted,
;;;; provided that existing copyright notices are retained in all
;;;; copies and that this notice is included verbatim in any
;;;; distributions.  No written agreement, license, or royalty fee is
;;;; required for any of the authorized uses.
;;;; This software is provided ``AS IS'' without express or implied
;;;; warranty.
;;;;
;;;;           Author: Erick Gallesio [eg@unice.fr]
;;;;    Creation date: 26-Apr-1997 16:02
;;;; Last file update:  3-Sep-1999 19:55 (eg)


(require "hash")

(define-module Trace
  (import Scheme STklos)
  
  (define *traced-symbols* (make-hash-table equal?))
  (define *indentation*    0)
  (define *err-port*	   (current-error-port))
  (define indent	   (lambda () (make-string *indentation* #\.)))


  ;;
  ;; Trace-primitive
  ;;
  (define (trace-primitive   symbol value)
    (lambda l
      (format *err-port* "~A -> ~A with args = ~S\n" (indent) symbol l)
      (let ((res (apply value l)))
	(format *err-port* "~A <- ~A returns ~S\n"   (indent) symbol res)
	res)))

  ;;
  ;; Trace-closure
  ;;
  (define (trace-closure symbol value)
    (define (trace-args closure args)
      (let ((formals (cadr (procedure-body closure))))
	(unless (null? formals)
	  (format *err-port* "with "))
	(let Loop ((formals formals) (actuals args))
	  (cond 
	     ((null? formals)   (unless (null? actuals)
				  (error "too many actual parameters for ~S"
					 symbol)))
	     ((symbol? formals) (format *err-port* "~A = ~S\n" formals actuals))
	     ((null? actuals)   (unless (null? formals)
				  (error "too few actual parameters for ~S"
					 symbol)))
	     (else	        (format *err-port* "~A = ~S~A" 
					(car formals) 
					(car actuals)
					(if (null? (cdr formals)) "\n" ",  "))
				(Loop (cdr formals) (cdr actuals)))))))
    ;;=== Body of trace-closure
    (lambda l
      ;; We trace the closure in a dynamic-wind to restore indentation
      ;; on error
      (dynamic-wind 
          (lambda () (set! *indentation* (+ *indentation* 2)))
	  
	  (lambda ()
	    (format *err-port* "~A -> ~A " (indent) symbol)
	    (trace-args value l)
	    (let ((res (apply value l)))
	      (format *err-port* "~A <- ~A returns ~S\n" (indent) symbol res)
	      res))

	  (lambda () (set! *indentation* (- *indentation* 2))))))

  ;;
  ;; Trace-symbol
  ;;
  (define (trace-symbol symbol proc env)
    (unless (symbol? symbol) (error "trace: bad symbol: ~S" symbol))
    ; Verify if symbol is already traced
    (let ((entry (hash-table-get *traced-symbols* (cons symbol env) #f)))
      (when entry
	; (car entry) contains the traced proc and (cdr entry) the untraced one
	(let ((old (car entry)))
	  (if (and (procedure? old) (eq? old proc))
	      (error "trace: procedure ``~S'' is already traced" symbol)))))
    ;; Trace symbol
    (let ((traced-proc  (cond  ; Order is important!!!
			 ((generic?   proc)(trace-generic   symbol proc))
			 ((primitive? proc)(trace-primitive symbol proc))
			 ((procedure? proc)(trace-closure   symbol proc))
			 (else		   (error "trace: cannot trace ~S" proc)))))
      (hash-table-put! *traced-symbols* (cons symbol env) (cons traced-proc proc))
      traced-proc))
  
  ;;
  ;; Untrace-symbol
  ;; 
  (define (untrace-symbol symbol env)
    (unless (symbol? symbol) (error "untrace: bad symbol: ~S" symbol))
    ;; Verify if symbol is already traced
     (let ((entry (hash-table-get *traced-symbols* (cons symbol env) #f)))
       (if entry
	   (begin 
	     (hash-table-remove! *traced-symbols* (cons symbol env))
	     (cdr entry))
	   (error "untrace: ~S is not traced" symbol))))


  ;;
  ;; Generic?  
  ;;
  ;; A pseudo-predicate which returns always false, while STklos is 
  ;; not initialized. If STklos is initialized it loads, if needed,
  ;; the code for tracing generic functions and returns a proper 
  ;; value depending of 
  (define (generic? proc)
    (if (symbol-bound? '<generic> (module-environment (find-module 'STklos)))
	(begin
	  (require "trace-gf")
	  (is-a? proc <generic>))
	#f))

  ;;;;
  ;;;; T R A C E  /  U N T R A C E
  ;;;;

  (define-macro (trace . args)
    (if (null? args)
	(error "trace: no argument")
	`(begin
	   ,@(map (lambda (x) 
		    `(set! ,x ((with-module Trace trace-symbol) ',x ,x
			       (the-environment))))
		  args))))
  
  (define-macro (untrace . args)
    (if (null? args)
	(error "untrace: no argument")
	`(begin
	   ,@(map (lambda (x) 
		    `(set! ,x ((with-module Trace untrace-symbol) ',x
			   (the-environment))))
		  args))))
)

;; Trace and untrace were defined as autoload in the STk module and
;; are defined as exported symbols from the Trace module. The autoload
;; will complain that the symbol was not defined. So, we define these
;; symbol in the current module to overload the autoload

(define trace   (with-module Trace trace))
(define untrace (with-module Trace untrace))

(provide "trace")