112 lines
3.2 KiB
Scheme
112 lines
3.2 KiB
Scheme
|
|
(module class-events mzscheme
|
|
|
|
(require-for-syntax mzlib/stxparam)
|
|
(require mzlib/stxparam)
|
|
|
|
(provide current-class-event-handler
|
|
define-traced
|
|
trace-begin
|
|
trace
|
|
initialize-call-event
|
|
finalize-call-event
|
|
new-event
|
|
inspect-event
|
|
set-event
|
|
get-event
|
|
)
|
|
|
|
(define current-class-event-handler
|
|
(make-parameter void))
|
|
|
|
;; ----------------------------------------------------------------------
|
|
;; Definitions for traced vs untraced functions
|
|
;; ----------------------------------------------------------------------
|
|
|
|
(define-syntax-parameter trace? #f)
|
|
|
|
(define-syntax trace
|
|
(make-set!-transformer
|
|
(lambda (stx)
|
|
(raise-syntax-error
|
|
#f
|
|
"trace used outside a trace-begin"
|
|
stx))))
|
|
|
|
(define-syntax (trace-begin stx)
|
|
(syntax-case stx (trace)
|
|
[(form (trace expr) ...)
|
|
(raise-syntax-error
|
|
#f
|
|
"traced block has no non-trace code"
|
|
stx)]
|
|
[(form expr0 (trace expr) ...)
|
|
(if (syntax-parameter-value (syntax trace?))
|
|
(syntax/loc stx (begin0 expr0 expr ...))
|
|
(syntax expr0))]
|
|
[(form (trace expr) rest ...)
|
|
(if (syntax-parameter-value (syntax trace?))
|
|
(syntax/loc stx (begin expr (form rest ...)))
|
|
(syntax/loc stx (form rest ...)))]
|
|
[(form expr rest ...)
|
|
(syntax/loc stx (begin expr (form rest ...)))]))
|
|
|
|
(define-syntax (define-traced stx)
|
|
(syntax-case stx ()
|
|
[(form (name . args) . body)
|
|
(syntax/loc stx (form name (lambda args . body)))]
|
|
[(form name body ...)
|
|
(with-syntax ([name-traced
|
|
(datum->syntax-object
|
|
(syntax name)
|
|
(string->symbol
|
|
(string-append
|
|
(symbol->string (syntax-e (syntax name)))
|
|
"-traced"))
|
|
(syntax name))])
|
|
(syntax/loc stx
|
|
(begin
|
|
(define name
|
|
(syntax-parameterize ([trace? #f])
|
|
body ...))
|
|
(define name-traced
|
|
(syntax-parameterize ([trace? #t])
|
|
body ...)))))]))
|
|
|
|
(define current-class-event-stack
|
|
(make-parameter null))
|
|
|
|
(define (initialize-event event . args)
|
|
(current-class-event-stack
|
|
(cons
|
|
(apply (current-class-event-handler) event args)
|
|
(current-class-event-stack))))
|
|
|
|
(define (finalize-event event . args)
|
|
(let* ([stack (current-class-event-stack)]
|
|
[head (car stack)]
|
|
[tail (cdr stack)])
|
|
(when (procedure? head) (apply head args))
|
|
(current-class-event-stack tail)))
|
|
|
|
(define (new-event class obj fields)
|
|
((current-class-event-handler) 'new class obj fields))
|
|
|
|
(define (initialize-call-event obj method args)
|
|
(initialize-event 'call obj method args))
|
|
|
|
(define (finalize-call-event . returned)
|
|
(apply finalize-event 'call returned)
|
|
(apply values returned))
|
|
|
|
(define (inspect-event obj)
|
|
((current-class-event-handler) 'inspect obj))
|
|
|
|
(define (set-event obj field value)
|
|
((current-class-event-handler) 'set obj field value))
|
|
|
|
(define (get-event obj field)
|
|
((current-class-event-handler) 'get obj field))
|
|
|
|
)
|