stk/STklos/trace-gf.stklos

;;;;
;;;; t r a c e - g f . s t k l o s	-- Trace generic functions
;;;;
;;;; Copyright <20> 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: 17-Jan-1998 17:48
;;;; Last file update:  3-Sep-1999 20:06 (eg)


(require "trace")		;; The one which doesn't feal with generic
(select-module Trace)		;; Place the rest of this file in module Trace

;=============================================================================
;
; Class <Traced-generic>
;
; Trace of a generic function is done using MOP.
; In fact, to trace a gf we change its class from <generic> to <traced-generic>
; Untracing is of course just the contrary
;
;=============================================================================

(define-class <Traced-generic> (<generic>)
  ())

;;
;; How to apply the methods of a <traced-generic>
;; 
(define-method apply-method ((gf <traced-generic>) methods-list build-next args)
  (let* ((name (generic-function-name gf))
	 (m    (car methods-list))
	 (spec (method-specializers m))
	 (map* (with-module STklos map*)))
    ;; Trace the closure application in a dynammic wind to restore indentation
    ;; on error. This code is quite identical to the code used for procedure in
    ;; trace.stk
    (dynamic-wind 
       (lambda () (set! *indentation* (+ *indentation* 2)))
	  
       (lambda ()
	 (let ((I   (indent))
	       (res #f))
	   (format *err-port* "~A -> GF ~S\n~A    spec = ~S\n~A    args = ~S\n" 
		   I name I (map* class-name spec) I args)
	   (set! res (apply (method-procedure (car methods-list))
			    (build-next (cdr methods-list) args)
			    args))
	   (format *err-port* "~A <- GF ~S returns ~S\n" I name res)
	   res))

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


;=============================================================================
;
; Trace-generic
;
;=============================================================================

(define-method trace-generic ((symbol <symbol>) (gf <generic>))
  ;; Verify that gf is "exactly" a <generic> (not "is-a?")
  ;; Otherwise, we can lost some information when untracing
  (unless (eq? (class-of gf) <generic>)
    (error "trace: cannot trace ~S (descendant of <generic>)" symbol))
  (change-class gf <traced-generic>)
  gf)


;=============================================================================
;
; Untrace-symbol
;
;=============================================================================

(define-generic untrace-symbol)	; transform function untrace-symbol in a generic

(define-method untrace-symbol ((symbol <symbol>))
  (let ((entry (hash-table-get *traced-symbols* symbol #f)))
    (if (and entry (is-a? (car entry) <generic>))
	(change-class (car entry) <generic>))
    (next-method)))

(provide "trace-gf")