94 lines
3.2 KiB

;;;; t r a c e - g f . s t k l o s -- Trace generic functions
;;;; Copyright © 1997-1999 Erick Gallesio - I3S-CNRS/ESSI <>
;;;; 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 []
;;;; 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
(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)
(format *err-port* "~A <- GF ~S returns ~S\n" I name 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>)
; 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>))
(provide "trace-gf")