94 lines
3.2 KiB
Plaintext
94 lines
3.2 KiB
Plaintext
;;;;
|
|
;;;; t r a c e - g f . s t k l o s -- Trace generic functions
|
|
;;;;
|
|
;;;; 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: 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")
|