suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Added tracing capabilities to mzscheme's class system.

Browse Source 
- class-internal.ss exports two versions (traced/untraced) of macros/functions
- classidmap.ss provides expansion to both forms (traced/untraced)
- class-traced.ss exports traced versions
- class.ss (unchanged) exports untraced versions
- class-events.ss contains hooks called by traced version
Functionality will be used by tool to be released via PLaneT.

svn: r4778
This commit is contained in:
Carl Eastlund 2006-11-04 20:46:52 +00:00
parent ac640eef71
commit 22fd8f51cc
4 changed files with 713 additions and 319 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

59
collects/mzlib/class-traced.ss Normal file
View File

@ -0,0 +1,59 @@
(module class-traced mzscheme
;; All of the implementation is actually in private/class-internal.ss,
;; which provides extra (private) functionality to contract.ss.
(require "private/class-internal.ss")
(provide (rename class-traced class)
(rename class*-traced class*)
(rename class/derived-traced class/derived)
(rename define-serializable-class-traced define-serializable-class)
(rename define-serializable-class*-traced define-serializable-class*)
class?
(rename mixin-traced mixin)
interface interface?
object% object? externalizable<%>
object=?
(rename new-traced new)
(rename make-object-traced make-object)
(rename instantiate-traced instantiate)
(rename send-traced send)
(rename send/apply-traced send/apply)
(rename send*-traced send*)
(rename class-field-accessor-traced class-field-accessor)
(rename class-field-mutator-traced class-field-mutator)
(rename with-method-traced with-method)
(rename get-field-traced get-field)
(rename field-bound?-traced field-bound?)
(rename field-names-traced field-names)
private* public* pubment*
override* overment*
augride* augment*
public-final* override-final* augment-final*
define/private define/public define/pubment
define/override define/overment
define/augride define/augment
define/public-final define/override-final define/augment-final
define-local-member-name define-member-name member-name-key generate-member-key
(rename generic-traced generic)
(rename make-generic-traced make-generic)
(rename send-generic-traced send-generic)
(rename is-a?-traced is-a?)
subclass? implementation? interface-extension?
(rename object-interface-traced object-interface)
(rename object-info-traced object-info)
(rename object->vector-traced object->vector)
(rename object-method-arity-includes?-traced object-method-arity-includes?)
method-in-interface? interface->method-names class->interface class-info
(struct exn:fail:object ())
make-primitive-class
;; "keywords":
private public override augment
pubment overment augride
public-final override-final augment-final
field init init-field
rename-super rename-inner inherit inherit-field
this super inner
super-make-object super-instantiate super-new
inspect))

111
collects/mzlib/private/class-events.ss Normal file
View File

@ -0,0 +1,111 @@
(module class-events mzscheme
(require-for-syntax (lib "stxparam.ss"))
(require (lib "stxparam.ss"))
(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))
)

739
collects/mzlib/private/class-internal.ss
View File

@ -3,6 +3,7 @@
(require (lib "list.ss") (require (lib "list.ss")
(lib "etc.ss") (lib "etc.ss")
(lib "stxparam.ss") (lib "stxparam.ss")
"class-events.ss"
"serialize-structs.ss") "serialize-structs.ss")
(require-for-syntax (lib "kerncase.ss" "syntax") (require-for-syntax (lib "kerncase.ss" "syntax")
(lib "stx.ss" "syntax") (lib "stx.ss" "syntax")
@ -117,7 +118,8 @@
;; class macros ;; class macros
;;-------------------------------------------------------------------- ;;--------------------------------------------------------------------
(define-syntaxes (class* _class class/derived) (define-syntaxes (class* _class class/derived
class*-traced class-traced class/derived-traced)
(let () (let ()
;; Start with Helper functions ;; Start with Helper functions
@ -393,7 +395,7 @@
;; -------------------------------------------------------------------------------- ;; --------------------------------------------------------------------------------
;; Start here: ;; Start here:
(define (main stx super-expr deserialize-id-expr name-id interface-exprs defn-and-exprs) (define (main stx trace-flag super-expr deserialize-id-expr name-id interface-exprs defn-and-exprs)
(let-values ([(this-id) #'this-id] (let-values ([(this-id) #'this-id]
[(the-obj) (datum->syntax-object (quote-syntax here) (gensym 'self))] [(the-obj) (datum->syntax-object (quote-syntax here) (gensym 'self))]
[(the-finder) (datum->syntax-object (quote-syntax here) (gensym 'find-self))]) [(the-finder) (datum->syntax-object (quote-syntax here) (gensym 'find-self))])
@ -1012,7 +1014,8 @@
;; make-XXX-map is supplied by private/classidmap.ss ;; make-XXX-map is supplied by private/classidmap.ss
(with-syntax ([the-obj the-obj] (with-syntax ([the-obj the-obj]
[the-finder the-finder] [the-finder the-finder]
[this-id this-id]) [this-id this-id]
[trace-flag (if trace-flag (syntax #t) (syntax #f))])
(syntax (syntax
([(inherit-field-name ... ([(inherit-field-name ...
local-field ... local-field ...
@ -1023,7 +1026,8 @@
public-final-name ... public-final-name ...
pubment-name ...) pubment-name ...)
(values (values
(make-field-map (quote-syntax the-finder) (make-field-map trace-flag
(quote-syntax the-finder)
(quote the-obj) (quote the-obj)
(quote-syntax inherit-field-name) (quote-syntax inherit-field-name)
(quote-syntax inherit-field-name-localized) (quote-syntax inherit-field-name-localized)
@ -1031,7 +1035,8 @@
(quote-syntax inherit-field-mutator) (quote-syntax inherit-field-mutator)
'()) '())
... ...
(make-field-map (quote-syntax the-finder) (make-field-map trace-flag
(quote-syntax the-finder)
(quote the-obj) (quote the-obj)
(quote-syntax local-field) (quote-syntax local-field)
(quote-syntax local-field-localized) (quote-syntax local-field-localized)
@ -1316,43 +1321,59 @@
;; Not primitive: ;; Not primitive:
#f)))))))))))))))) #f))))))))))))))))
(define (core-class* trace-flag)
(lambda (stx)
(syntax-case stx ()
[(_ super-expression (interface-expr ...)
defn-or-expr
...)
(main stx trace-flag
#'super-expression
#f #f
(syntax->list #'(interface-expr ...))
(syntax->list #'(defn-or-expr ...)))])))
(define (core-class trace-flag)
(lambda (stx)
(syntax-case stx ()
[(_ super-expression
defn-or-expr
...)
(main stx trace-flag
#'super-expression
#f #f
null
(syntax->list #'(defn-or-expr ...)))])))
(define (core-class/derived trace-flag)
(lambda (stx)
(syntax-case stx ()
[(_ orig-stx
[name-id super-expression (interface-expr ...) deserialize-id-expr]
defn-or-expr
...)
(main #'orig-stx trace-flag
#'super-expression
#'deserialize-id-expr
(and (syntax-e #'name-id) #'name-id)
(syntax->list #'(interface-expr ...))
(syntax->list #'(defn-or-expr ...)))])))
;; The class* and class entry points: ;; The class* and class entry points:
(values (values
;; class* ;; class*
(lambda (stx) (core-class* #f)
(syntax-case stx ()
[(_ super-expression (interface-expr ...)
defn-or-expr
...)
(main stx
#'super-expression
#f #f
(syntax->list #'(interface-expr ...))
(syntax->list #'(defn-or-expr ...)))]))
;; class ;; class
(lambda (stx) (core-class #f)
(syntax-case stx ()
[(_ super-expression
defn-or-expr
...)
(main stx
#'super-expression
#f #f
null
(syntax->list #'(defn-or-expr ...)))]))
;; class/derived ;; class/derived
(lambda (stx) (core-class/derived #f)
(syntax-case stx () ;; class*-traced
[(_ orig-stx (core-class* #t)
[name-id super-expression (interface-expr ...) deserialize-id-expr] ;; class-traced
defn-or-expr (core-class #t)
...) ;; class/derived-traced
(main #'orig-stx (core-class/derived #t)
#'super-expression )))
#'deserialize-id-expr
(and (syntax-e #'name-id) #'name-id)
(syntax->list #'(interface-expr ...))
(syntax->list #'(defn-or-expr ...)))])))))
(define-syntax (-define-serializable-class stx) (define-syntax (-define-serializable-class stx)
(syntax-case stx () (syntax-case stx ()
@ -2326,35 +2347,56 @@
;; instantiation ;; instantiation
;;-------------------------------------------------------------------- ;;--------------------------------------------------------------------
(define-syntax (new stx) (define-syntaxes (new new-traced)
(syntax-case stx ()
[(_ cls (id arg) ...) (let* ([core-new
(andmap identifier? (syntax->list (syntax (id ...)))) (lambda (instantiate-stx stx)
(syntax/loc stx (instantiate cls () (id arg) ...))] (syntax-case stx ()
[(_ cls (id arg) ...) [(_ cls (id arg) ...)
(for-each (lambda (id) (andmap identifier? (syntax->list (syntax (id ...))))
(unless (identifier? id) (quasisyntax/loc stx
(raise-syntax-error 'new "expected identifier" stx id))) ((unsyntax instantiate-stx) cls () (id arg) ...))]
(syntax->list (syntax (id ...))))] [(_ cls (id arg) ...)
[(_ cls pr ...) (for-each (lambda (id)
(for-each (unless (identifier? id)
(lambda (pr) (raise-syntax-error 'new "expected identifier" stx id)))
(syntax-case pr () (syntax->list (syntax (id ...))))]
[(x y) (void)] [(_ cls pr ...)
[else (raise-syntax-error 'new "expected name and value binding" stx pr)])) (for-each
(syntax->list (syntax (pr ...))))])) (lambda (pr)
(syntax-case pr ()
[(x y) (void)]
[else (raise-syntax-error 'new "expected name and value binding" stx pr)]))
(syntax->list (syntax (pr ...))))]))])
(values
(lambda (stx) (core-new (syntax/loc stx instantiate) stx))
(lambda (stx) (core-new (syntax/loc stx instantiate-traced) stx)))))
(define make-object (define make-object
(lambda (class . args) (lambda (class . args)
(do-make-object class args null))) (do-make-object class args null)))
(define make-object-traced
(lambda (class . args)
(do-make-object-traced class args null)))
(define-syntax instantiate (define-syntaxes (instantiate instantiate-traced)
(lambda (stx)
(syntax-case stx () (let* ([core-instantiate
[(form class (arg ...) . x) (lambda (do-make-object-stx stx)
(with-syntax ([orig-stx stx]) (syntax-case stx ()
(syntax/loc stx [(form class (arg ...) . x)
(-instantiate do-make-object orig-stx (class) (list arg ...) . x)))]))) (with-syntax ([orig-stx stx])
(quasisyntax/loc stx
(-instantiate (unsyntax do-make-object-stx)
orig-stx (class) (list arg ...) . x)))]))])
(values
(lambda (stx)
(core-instantiate (syntax/loc stx do-make-object) stx))
(lambda (stx)
(core-instantiate (syntax/loc stx do-make-object-traced) stx)))))
;; Helper; used by instantiate and super-instantiate ;; Helper; used by instantiate and super-instantiate
(define-syntax -instantiate (define-syntax -instantiate
@ -2389,13 +2431,26 @@
kwarg)])) kwarg)]))
(syntax->list (syntax (kwarg ...))))]))) (syntax->list (syntax (kwarg ...))))])))
(define (do-make-object class by-pos-args named-args) (define (alist->sexp alist)
(map (lambda (pair) (list (car pair) (cdr pair))) alist))
(define-traced (do-make-object class by-pos-args named-args)
(unless (class? class) (unless (class? class)
(raise-type-error 'instantiate "class" class)) (raise-type-error 'instantiate "class" class))
(let ([o ((class-make-object class))]) (let ([o ((class-make-object class))])
;; Initialize it: (trace-begin
(continue-make-object o class by-pos-args named-args #t) ;; Initialize it:
o)) (trace (new-event class o (alist->sexp (get-field-alist o))))
(trace (initialize-call-event
o (string->symbol "(constructor)")
(cons (alist->sexp named-args) by-pos-args)))
(continue-make-object o class by-pos-args named-args #t)
(trace (finalize-call-event o))
o)))
(define (get-field-alist obj)
(map (lambda (id) (cons id (get-field/proc id obj)))
(field-names obj)))
(define (continue-make-object o c by-pos-args named-args explict-named-args?) (define (continue-make-object o c by-pos-args named-args explict-named-args?)
(let ([by-pos-only? (not (class-init-args c))]) (let ([by-pos-only? (not (class-init-args c))])
@ -2554,58 +2609,80 @@
;; methods and fields ;; methods and fields
;;-------------------------------------------------------------------- ;;--------------------------------------------------------------------
(define-syntaxes (send send/apply) (define-syntaxes (send send/apply send-traced send/apply-traced)
(let ([mk (let ()
(lambda (flatten?)
(lambda (stx) (define (do-method traced? stx form obj name args rest-arg?)
(syntax-case stx () (with-syntax ([(sym method receiver)
[(_ obj name . args) (generate-temporaries (syntax (1 2 3)))])
(begin (quasisyntax/loc stx
(unless (identifier? (syntax name)) (let*-values ([(sym) (quasiquote (unsyntax (localize name)))]
(raise-syntax-error [(method receiver)
#f (find-method/who '(unsyntax form)
"method name is not an identifier" (unsyntax obj)
stx sym)])
(syntax name))) (unsyntax
(with-syntax ([name (localize (syntax name))]) (make-method-call
(if flatten? traced?
(if (stx-list? (syntax args)) stx
(syntax (let-values ([(mth unwrapped-this) (syntax/loc stx receiver)
(find-method/who 'send obj `name)]) (syntax/loc stx unwrap-object)
(apply mth unwrapped-this . args))) (syntax/loc stx method)
(raise-syntax-error (syntax/loc stx sym)
#f args
"bad syntax (illegal use of `.')" rest-arg?))))))
stx))
(if (stx-list? (syntax args)) (define (core-send traced? apply?)
(syntax/loc stx (lambda (stx)
(let-values ([(mth unwrapped-this) (syntax-case stx ()
(find-method/who 'send obj `name)]) [(form obj name . args)
(mth unwrapped-this . args))) (identifier? (syntax name))
(with-syntax ([args (flatten-args (syntax args))]) (if (stx-list? (syntax args))
(syntax/loc stx ;; (send obj name arg ...) or (send/apply obj name arg ...)
(let-values ([(mth unwrapped-this) (do-method traced? stx #'form #'obj #'name #'args apply?)
(find-method/who 'send obj `name)]) (if apply?
(apply mth unwrapped-this . args))))))))])))]) ;; (send/apply obj name arg ... . rest)
(values (mk #f) (mk #t)))) (raise-syntax-error
#f "bad syntax (illegal use of `.')" stx)
;; (send obj name arg ... . rest)
(do-method traced? stx #'form #'obj #'name
(flatten-args #'args) #t)))]
[(form obj name . args)
(raise-syntax-error
#f "method name is not an identifier" stx #'name)])))
(values
;; send
(core-send #f #f)
;; send/apply
(core-send #f #t)
;; send-traced
(core-send #t #f)
;; send/apply-traced
(core-send #t #t))))
(define-syntax send* (define-syntaxes (send* send*-traced)
(lambda (stx) (let* ([core-send*
(syntax-case stx () (lambda (traced?)
[(_ obj s ...) (lambda (stx)
(with-syntax ([sends (map (lambda (s) (syntax-case stx ()
(syntax-case s () [(form obj clause ...)
[(meth . args) (quasisyntax/loc stx
(syntax/loc s (send o meth . args))] (let* ([o obj])
[_else (raise-syntax-error (unsyntax-splicing
#f (map
"bad method call" (lambda (clause-stx)
stx (syntax-case clause-stx ()
s)])) [(meth . args)
(syntax->list (syntax (s ...))))]) (quasisyntax/loc stx
(syntax/loc stx ((unsyntax (if traced?
(let ([o obj]) (syntax/loc stx send-traced)
. sends)))]))) (syntax/loc stx send)))
o meth . args))]
[_ (raise-syntax-error
#f "bad method call" stx clause-stx)]))
(syntax->list (syntax (clause ...)))))))])))])
(values (core-send* #f) (core-send* #t))))
;; find-method/who : symbol[top-level-form/proc-name] ;; find-method/who : symbol[top-level-form/proc-name]
;; any[object] ;; any[object]
@ -2663,7 +2740,7 @@
make-struct-field-mutator class-field-set! make-struct-field-mutator class-field-set!
class name)) class name))
(define-struct generic (applicable)) (define-struct generic (name applicable))
;; Internally, make-generic comes from the struct def. ;; Internally, make-generic comes from the struct def.
;; Externally, make-generic is the following procedure. ;; Externally, make-generic is the following procedure.
@ -2676,6 +2753,7 @@
(unless (symbol? name) (unless (symbol? name)
(raise-type-error 'make-generic "symbol" name)) (raise-type-error 'make-generic "symbol" name))
(make-generic (make-generic
name
(if (interface? class) (if (interface? class)
(let ([intf class]) (let ([intf class])
(unless (method-in-interface? name intf) (unless (method-in-interface? name intf)
@ -2713,21 +2791,32 @@
dynamic-generic)))))]) dynamic-generic)))))])
make-generic)) make-generic))
(define-syntax send-generic (define-syntaxes (send-generic send-generic-traced)
(lambda (stx) (let ()
(syntax-case stx () (define (core-send-generic traced?)
[(_ obj generic . args) (lambda (stx)
(if (stx-list? (syntax args)) (syntax-case stx ()
(with-syntax ([call (syntax/loc stx [(_ object generic . args)
(((generic-applicable generic) this) this . args))]) (let* ([args-stx (syntax args)]
(syntax/loc stx (let ([this obj]) [proper? (stx-list? args-stx)]
call))) [flat-stx (if proper? args-stx (flatten-args args-stx))])
(with-syntax ([args (flatten-args (syntax args))]) (with-syntax ([(gen obj)
(with-syntax ([call (syntax/loc stx (generate-temporaries (syntax (generic object)))])
(apply ((generic-applicable generic) this) this . args))]) (quasisyntax/loc stx
(syntax (let ([this obj]) (let* ([obj object]
call)))))]))) [gen generic])
(unsyntax
(make-method-call
traced?
stx
(syntax obj)
(syntax/loc stx unwrap-object)
(syntax/loc stx ((generic-applicable gen) obj))
(syntax/loc stx (generic-name gen))
flat-stx
(not proper?)))))))])))
(values (core-send-generic #f) (core-send-generic #t))))
(define-syntaxes (class-field-accessor class-field-mutator generic/form) (define-syntaxes (class-field-accessor class-field-mutator generic/form)
(let ([mk (let ([mk
(lambda (make targets) (lambda (make targets)
@ -2755,29 +2844,58 @@
(mk (quote-syntax make-class-field-mutator) "class") (mk (quote-syntax make-class-field-mutator) "class")
(mk (quote-syntax make-generic/proc) "class or interface")))) (mk (quote-syntax make-generic/proc) "class or interface"))))
(define-syntax (get-field stx) (define-syntax (class-field-accessor-traced stx)
(syntax-case stx () (syntax-case stx ()
[(_ name obj) [(form class name)
(identifier? (syntax name)) (syntax/loc stx
(with-syntax ([localized (localize (syntax name))]) (let* ([accessor (class-field-accessor class name)])
(syntax (get-field/proc `localized obj)))] (lambda (obj)
[(_ name obj) (begin0 (accessor obj)
(raise-syntax-error 'get-field "expected a field name as first argument" stx (syntax name))])) (get-event obj 'name)))))]))
(define-syntax (class-field-mutator-traced stx)
(syntax-case stx ()
[(form class name)
(syntax/loc stx
(let* ([mutator (class-field-mutator class name)])
(lambda (obj value)
(begin0 (mutator obj value)
(set-event obj 'name value)))))]))
(define-syntaxes (get-field get-field-traced)
(let ()
(define (core-get-field traced?)
(lambda (stx)
(syntax-case stx ()
[(_ name obj)
(identifier? (syntax name))
(with-syntax ([get (if traced?
(syntax get-field/proc-traced)
(syntax get-field/proc))]
[localized (localize (syntax name))])
(syntax (get `localized obj)))]
[(_ name obj)
(raise-syntax-error
'get-field "expected a field name as first argument"
stx (syntax name))])))
(values (core-get-field #f) (core-get-field #t))))
(define (get-field/proc id obj) (define-traced (get-field/proc id obj)
(unless (object? obj) (unless (object? obj)
(raise-mismatch-error (raise-mismatch-error
'get-field 'get-field
"expected an object, got " "expected an object, got "
obj)) obj))
(let loop ([obj obj]) (trace-begin
(let* ([cls (object-ref obj)] (trace (get-event obj id))
[field-ht (class-field-ht cls)] (let loop ([obj obj])
[index (hash-table-get (let* ([cls (object-ref obj)]
field-ht [field-ht (class-field-ht cls)]
id [index (hash-table-get
#f)]) field-ht
(cond id
#f)])
(cond
[index [index
((class-field-ref (car index)) obj (cdr index))] ((class-field-ref (car index)) obj (cdr index))]
[(wrapper-object? obj) [(wrapper-object? obj)
@ -2786,122 +2904,150 @@
(raise-mismatch-error (raise-mismatch-error
'get-field 'get-field
(format "expected an object that has a field named ~s, got " id) (format "expected an object that has a field named ~s, got " id)
obj)])))) obj)])))))
(define-syntax (field-bound? stx) (define-syntaxes (field-bound? field-bound?-traced)
(syntax-case stx () (let ()
[(_ name obj) (define (core-field-bound? traced?)
(identifier? (syntax name)) (lambda (stx)
(with-syntax ([localized (localize (syntax name))]) (syntax-case stx ()
(syntax (field-bound?/proc `localized obj)))] [(_ name obj)
[(_ name obj) (identifier? (syntax name))
(raise-syntax-error 'field-bound? "expected a field name as first argument" stx (syntax name))])) (with-syntax ([localized (localize (syntax name))]
[bound? (if traced?
(syntax field-bound?/proc-traced)
(syntax field-bound?/proc))])
(syntax (bound? `localized obj)))]
[(_ name obj)
(raise-syntax-error
'field-bound? "expected a field name as first argument"
stx (syntax name))])))
(values (core-field-bound? #f) (core-field-bound? #t))))
(define (field-bound?/proc id obj) (define-traced (field-bound?/proc id obj)
(unless (object? obj) (unless (object? obj)
(raise-mismatch-error (raise-mismatch-error
'field-bound? 'field-bound?
"expected an object, got " "expected an object, got "
obj)) obj))
(let loop ([obj obj]) (trace-begin
(let* ([cls (object-ref obj)] (trace (inspect-event obj))
[field-ht (class-field-ht cls)]) (let loop ([obj obj])
(or (and (hash-table-get field-ht id #f) (let* ([cls (object-ref obj)]
#t) ;; ensure that only #t and #f leak out, not bindings in ht [field-ht (class-field-ht cls)])
(and (wrapper-object? obj) (or (and (hash-table-get field-ht id #f)
(loop (wrapper-object-wrapped obj))))))) #t) ;; ensure that only #t and #f leak out, not bindings in ht
(and (wrapper-object? obj)
(loop (wrapper-object-wrapped obj))))))))
(define (field-names obj) (define-traced (field-names obj)
(unless (object? obj) (unless (object? obj)
(raise-mismatch-error (raise-mismatch-error
'field-names 'field-names
"expected an object, got " "expected an object, got "
obj)) obj))
(let loop ([obj obj]) (trace-begin
(let* ([cls (object-ref obj)] (trace (inspect-event obj))
[field-ht (class-field-ht cls)] (let loop ([obj obj])
[flds (filter interned? (hash-table-map field-ht (lambda (x y) x)))]) (let* ([cls (object-ref obj)]
(if (wrapper-object? obj) [field-ht (class-field-ht cls)]
(append flds (loop (wrapper-object-wrapped obj))) [flds (filter interned? (hash-table-map field-ht (lambda (x y) x)))])
flds)))) (if (wrapper-object? obj)
(append flds (loop (wrapper-object-wrapped obj)))
flds)))))
(define-syntax with-method (define-syntaxes (with-method with-method-traced)
(lambda (stx) (let ()
(syntax-case stx () (define (core-with-method traced?)
[(_ ([id (obj-expr name)] ...) body0 body1 ...) (lambda (stx)
(let ([ids (syntax->list (syntax (id ...)))] (syntax-case stx ()
[names (syntax->list (syntax (name ...)))]) [(_ ([id (obj-expr name)] ...) body0 body1 ...)
(for-each (lambda (id name) (let ([ids (syntax->list (syntax (id ...)))]
(unless (identifier? id) [names (syntax->list (syntax (name ...)))])
(raise-syntax-error #f (for-each (lambda (id name)
"not an identifier for binding" (unless (identifier? id)
stx (raise-syntax-error #f
id)) "not an identifier for binding"
(unless (identifier? name) stx
(raise-syntax-error #f id))
"not an identifier for method name" (unless (identifier? name)
stx (raise-syntax-error #f
name))) "not an identifier for method name"
ids names) stx
(with-syntax ([(method ...) (generate-temporaries ids)] name)))
[(method-obj ...) (generate-temporaries ids)] ids names)
[(name ...) (map localize names)]) (with-syntax ([(method ...) (generate-temporaries ids)]
(syntax/loc stx (let-values ([(method method-obj) [(method-obj ...) (generate-temporaries ids)]
(let ([obj obj-expr]) [(name ...) (map localize names)]
(find-method/who 'with-method obj `name))] [trace-flag (if traced? (syntax/loc stx #t) (syntax/loc stx #f))])
...) (syntax/loc stx (let-values ([(method method-obj)
(letrec-syntaxes+values ([(id) (make-with-method-map (let ([obj obj-expr])
(quote-syntax set!) (find-method/who 'with-method obj `name))]
(quote-syntax id) ...)
(quote-syntax method) (letrec-syntaxes+values ([(id) (make-with-method-map
(quote-syntax method-obj))] trace-flag
...) (quote-syntax set!)
() (quote-syntax id)
body0 body1 ...)))))] (quote-syntax method)
;; Error cases: (quote-syntax method-obj)
[(_ (clause ...) . body) (syntax unwrap-object))]
(begin ...)
(for-each (lambda (clause) ()
(syntax-case clause () body0 body1 ...)))))]
[(id (obj-expr name)) ;; Error cases:
(and (identifier? (syntax id)) [(_ (clause ...) . body)
(identifier? (syntax name))) (begin
'ok] (for-each (lambda (clause)
[_else (syntax-case clause ()
(raise-syntax-error [(id (obj-expr name))
#f (and (identifier? (syntax id))
"binding clause is not of the form (identifier (object-expr method-identifier))" (identifier? (syntax name)))
stx 'ok]
clause)])) [_else
(syntax->list (syntax (clause ...)))) (raise-syntax-error
;; If we get here, the body must be bad #f
(if (stx-null? (syntax body)) "binding clause is not of the form (identifier (object-expr method-identifier))"
(raise-syntax-error stx
#f clause)]))
"empty body" (syntax->list (syntax (clause ...))))
stx) ;; If we get here, the body must be bad
(raise-syntax-error (if (stx-null? (syntax body))
#f (raise-syntax-error
"bad syntax (illegal use of `.')" #f
stx)))] "empty body"
[(_ x . rest) stx)
(raise-syntax-error (raise-syntax-error
#f #f
"not a binding sequence" "bad syntax (illegal use of `.')"
stx stx)))]
(syntax x))]))) [(_ x . rest)
(raise-syntax-error
#f
"not a binding sequence"
stx
(syntax x))])))
(values
;; with-method
(core-with-method #f)
;; with-method-traced
(core-with-method #t))))
;;-------------------------------------------------------------------- ;;--------------------------------------------------------------------
;; class, interface, and object properties ;; class, interface, and object properties
;;-------------------------------------------------------------------- ;;--------------------------------------------------------------------
(define (is-a? v c) (define-traced (is-a? v c)
(cond (trace-begin
[(class? c) ((class-object? c) (unwrap-object v))] (trace (when (object? v)
[(interface? c) (inspect-event v)))
(and (object? v) (cond
(implementation? (object-ref (unwrap-object v)) c))] [(class? c) ((class-object? c) (unwrap-object v))]
[else (raise-type-error 'is-a? "class or interface" 1 v c)])) [(interface? c)
(and (object? v)
(implementation? (object-ref (unwrap-object v)) c))]
[else (raise-type-error 'is-a? "class or interface" 1 v c)])))
(define (subclass? v c) (define (subclass? v c)
(unless (class? c) (unless (class? c)
@ -2911,12 +3057,14 @@
(and (<= p (class-pos v)) (and (<= p (class-pos v))
(eq? c (vector-ref (class-supers v) p)))))) (eq? c (vector-ref (class-supers v) p))))))
(define (object-interface o) (define-traced (object-interface o)
(unless (object? o) (unless (object? o)
(raise-type-error 'object-interface "object" o)) (raise-type-error 'object-interface "object" o))
(class-self-interface (object-ref (unwrap-object o)))) (trace-begin
(trace (inspect-event o))
(class-self-interface (object-ref (unwrap-object o)))))
(define (object-method-arity-includes? o name cnt) (define-traced (object-method-arity-includes? o name cnt)
(unless (object? o) (unless (object? o)
(raise-type-error 'object-method-arity-includes? "object" o)) (raise-type-error 'object-method-arity-includes? "object" o))
(unless (symbol? name) (unless (symbol? name)
@ -2925,14 +3073,16 @@
(exact? cnt) (exact? cnt)
(not (negative? cnt))) (not (negative? cnt)))
(raise-type-error 'object-method-arity-includes? "non-negative exact integer" cnt)) (raise-type-error 'object-method-arity-includes? "non-negative exact integer" cnt))
(let loop ([o o]) (trace-begin
(let* ([c (object-ref o)] (trace (inspect-event o))
[pos (hash-table-get (class-method-ht c) name #f)]) (let loop ([o o])
(cond (let* ([c (object-ref o)]
[pos (procedure-arity-includes? (vector-ref (class-methods c) pos) [pos (hash-table-get (class-method-ht c) name #f)])
(add1 cnt))] (cond
[(wrapper-object? o) (loop (wrapper-object-wrapped o))] [pos (procedure-arity-includes? (vector-ref (class-methods c) pos)
[else #f])))) (add1 cnt))]
[(wrapper-object? o) (loop (wrapper-object-wrapped o))]
[else #f])))))
(define (implementation? v i) (define (implementation? v i)
(unless (interface? i) (unless (interface? i)
@ -2968,17 +3118,19 @@
(apply list-immutable (filter interned? (interface-public-ids i)))) (apply list-immutable (filter interned? (interface-public-ids i))))
(define (object-info o) (define-traced (object-info o)
(unless (object? o) (unless (object? o)
(raise-type-error 'object-info "object" o)) (raise-type-error 'object-info "object" o))
(let loop ([c (object-ref (unwrap-object o))] (trace-begin
[skipped? #f]) (trace (inspect-event o))
(if (struct? ((class-insp-mk c))) (let loop ([c (object-ref (unwrap-object o))]
;; current inspector can inspect this object [skipped? #f])
(values c skipped?) (if (struct? ((class-insp-mk c)))
(if (zero? (class-pos c)) ;; current inspector can inspect this object
(values #f #t) (values c skipped?)
(loop (vector-ref (class-supers c) (sub1 (class-pos c))) #t))))) (if (zero? (class-pos c))
(values #f #t)
(loop (vector-ref (class-supers c) (sub1 (class-pos c))) #t))))))
(define (class-info c) (define (class-info c)
(unless (class? c) (unless (class? c)
@ -3000,20 +3152,23 @@
(loop (vector-ref (class-supers next) (sub1 (class-pos next))) #t))))) (loop (vector-ref (class-supers next) (sub1 (class-pos next))) #t)))))
(raise-mismatch-error 'class-info "current inspector cannot inspect class: " c))) (raise-mismatch-error 'class-info "current inspector cannot inspect class: " c)))
(define object->vector (define-traced object->vector
(opt-lambda (in-o [opaque-v '...]) (opt-lambda (in-o [opaque-v '...])
(unless (object? in-o) (unless (object? in-o)
(raise-type-error 'object->vector "object" in-o)) (raise-type-error 'object->vector "object" in-o))
(let ([o (unwrap-object in-o)]) (trace-begin
(list->vector (trace (inspect-event in-o))
(cons (let ([o (unwrap-object in-o)])
(string->symbol (format "object:~a" (class-name (object-ref o)))) (list->vector
(reverse (cons
(let-values ([(c skipped?) (object-info o)]) (string->symbol (format "object:~a" (class-name (object-ref o))))
(let loop ([c c][skipped? skipped?]) (reverse
(cond (let-values ([(c skipped?) (object-info o)])
(let loop ([c c][skipped? skipped?])
(cond
[(not c) (if skipped? (list opaque-v) null)] [(not c) (if skipped? (list opaque-v) null)]
[else (let-values ([(name num-fields field-ids field-ref field-set next next-skipped?) [else (let-values ([(name num-fields field-ids field-ref
field-set next next-skipped?)
(class-info c)]) (class-info c)])
(let ([rest (loop next next-skipped?)] (let ([rest (loop next next-skipped?)]
[here (let loop ([n num-fields]) [here (let loop ([n num-fields])
@ -3023,7 +3178,7 @@
(loop (sub1 n)))))]) (loop (sub1 n)))))])
(append (if skipped? (list opaque-v) null) (append (if skipped? (list opaque-v) null)
here here
rest)))]))))))))) rest)))]))))))))))
(define (object=? o1 o2) (define (object=? o1 o2)
(unless (object? o1) (unless (object? o1)
@ -3409,7 +3564,37 @@
(define externalizable<%> (define externalizable<%>
(_interface () externalize internalize)) (_interface () externalize internalize))
;; Providing traced versions:
(provide class-traced
class*-traced
class/derived-traced
(rename define-serializable-class define-serializable-class-traced)
(rename define-serializable-class* define-serializable-class*-traced)
(rename mixin mixin-traced)
new-traced
make-object-traced
instantiate-traced
send-traced
send/apply-traced
send*-traced
class-field-accessor-traced
class-field-mutator-traced
with-method-traced
get-field-traced
field-bound?-traced
field-names-traced
(rename generic/form generic-traced)
(rename make-generic/proc make-generic-traced)
send-generic-traced
is-a?-traced
object-interface-traced
object-info-traced
object->vector-traced
object-method-arity-includes?-traced
)
;; Providing normal functionality:
(provide (protect make-wrapper-class (provide (protect make-wrapper-class
wrapper-object-wrapped wrapper-object-wrapped
extract-vtable extract-vtable

123
collects/mzlib/private/classidmap.ss
View File

@ -1,6 +1,7 @@
(module classidmap mzscheme (module classidmap mzscheme
(require (lib "stx.ss" "syntax")) (require (lib "stx.ss" "syntax"))
(require-for-template mzscheme "class-events.ss")
(define-values (struct:s!t make-s!t s!t? s!t-ref s!t-set!) (define-values (struct:s!t make-s!t s!t? s!t-ref s!t-set!)
(make-struct-type 'set!-transformer #f 2 0 #f null (current-inspector) 0)) (make-struct-type 'set!-transformer #f 2 0 #f null (current-inspector) 0))
@ -24,13 +25,7 @@
;; Check Syntax binding info: ;; Check Syntax binding info:
(define (binding from to stx) (define (binding from to stx)
stx stx)
;; This 'bound-in-source is no longer needed
#;
(syntax-property
stx
'bound-in-source
(cons from (syntax-local-introduce to))))
(define (make-this-map orig-id the-finder the-obj) (define (make-this-map orig-id the-finder the-obj)
@ -49,34 +44,42 @@
stx)] stx)]
[id (find the-finder the-obj stx)]))))) [id (find the-finder the-obj stx)])))))
(define (make-field-map the-finder the-obj the-binder the-binder-localized field-accessor field-mutator field-pos/null) (define (make-field-map trace-flag the-finder the-obj the-binder the-binder-localized
field-accessor field-mutator field-pos/null)
(let ([set!-stx (datum->syntax-object the-finder 'set!)]) (let ([set!-stx (datum->syntax-object the-finder 'set!)])
(mk-set!-trans (mk-set!-trans
the-binder-localized the-binder-localized
(lambda (stx) (lambda (stx)
(syntax-case stx () (with-syntax ([obj-expr (find the-finder the-obj stx)])
[(set! id expr) (syntax-case stx ()
(module-identifier=? (syntax set!) set!-stx) [(set! id expr)
(binding (module-identifier=? (syntax set!) set!-stx)
the-binder (syntax id) (with-syntax ([bindings (syntax/loc stx ([obj obj-expr] [value expr]))]
(datum->syntax-object [trace (syntax/loc stx (set-event obj (quote id) value))]
the-finder [set (quasisyntax/loc stx
(list* field-mutator (find the-finder the-obj stx) (append field-pos/null (list (syntax expr)))) ((unsyntax field-mutator)
stx))] obj (unsyntax-splicing field-pos/null) value))])
[(id . args) (if trace-flag
(binding (syntax/loc stx (let* bindings trace set))
the-binder (syntax id) (syntax/loc stx (let* bindings set))))]
(datum->syntax-object [(id . args)
the-finder (with-syntax ([bindings (syntax/loc stx ([obj obj-expr]))]
(cons (list* field-accessor (find the-finder the-obj stx) field-pos/null) (syntax args)) [trace (syntax/loc stx (get-event obj (quote id)))]
stx))] [call (quasisyntax/loc stx
[_else (((unsyntax field-accessor)
(binding obj-expr (unsyntax-splicing field-pos/null)) . args))])
the-binder stx (if trace-flag
(datum->syntax-object (syntax/loc stx (let* bindings trace call))
the-finder (syntax/loc stx (let* bindings call))))]
(list* field-accessor (find the-finder the-obj stx) field-pos/null) [id
stx))]))))) (with-syntax ([bindings (syntax/loc stx ([obj obj-expr]))]
[trace (syntax/loc stx (get-event obj (quote id)))]
[get (quasisyntax/loc stx
((unsyntax field-accessor)
obj-expr (unsyntax-splicing field-pos/null)))])
(if trace-flag
(syntax/loc stx (let* bindings trace get))
(syntax/loc stx (let* bindings get))))]))))))
(define (make-method-map the-finder the-obj the-binder the-binder-localized method-accessor) (define (make-method-map the-finder the-obj the-binder the-binder-localized method-accessor)
(let ([set!-stx (datum->syntax-object the-finder 'set!)]) (let ([set!-stx (datum->syntax-object the-finder 'set!)])
@ -248,22 +251,31 @@
"cannot use superclass initialization form in a method" "cannot use superclass initialization form in a method"
stx))) stx)))
(define (make-with-method-map set!-stx id-stx method-stx method-obj-stx) (define (make-with-method-map trace-flag set!-stx id-stx
method-stx method-obj-stx unwrap-stx)
(make-set!-transformer (make-set!-transformer
(lambda (stx) (lambda (stx)
(syntax-case stx () (syntax-case stx ()
[(set! id expr) [(set! id expr)
(module-identifier=? (syntax set!) set!-stx) (and (identifier? (syntax id))
(module-identifier=? (syntax set!) set!-stx))
(raise-syntax-error 'with-method "cannot mutate method" stx)] (raise-syntax-error 'with-method "cannot mutate method" stx)]
[(id . args) [(id . args)
(datum->syntax-object (identifier? (syntax id))
set!-stx (let* ([args-stx (syntax args)]
(make-method-apply [proper? (stx-list? args-stx)]
method-stx [flat-args-stx (if proper? args-stx (flatten-args args-stx))])
method-obj-stx (make-method-call
(syntax args)) trace-flag
stx)] stx
[_else method-obj-stx
unwrap-stx
method-stx
(syntax (quote id))
flat-args-stx
(not proper?)))]
[id
(identifier? (syntax id))
(raise-syntax-error (raise-syntax-error
'with-method 'with-method
"misuse of method (not in application)" "misuse of method (not in application)"
@ -307,12 +319,39 @@
(and (pair? ctx) (and (pair? ctx)
(class-context? (car ctx)))) (class-context? (car ctx))))
(define (make-method-call traced? source-stx object-stx unwrap-stx
method-proc-stx method-name-stx args-stx rest-arg?)
(define-syntax (qstx stx)
(syntax-case stx ()
[(form body) (syntax/loc stx (quasisyntax/loc source-stx body))]))
(with-syntax ([object object-stx]
[method method-proc-stx]
[app (if rest-arg? (qstx apply) (qstx #%app))]
[args args-stx])
(if traced?
(with-syntax ([(mth obj) (generate-temporaries
(list object-stx method-proc-stx))]
[unwrap unwrap-stx]
[name method-name-stx]
[(arg ...) (qstx args)]
[(var ...) (generate-temporaries (qstx args))])
(qstx (let ([mth method]
[obj object]
[var arg] ...)
(initialize-call-event
(unwrap obj) name (app list var ...))
(call-with-values (lambda () (app mth obj var ...))
finalize-call-event))))
(qstx (app method object . args)))))
(provide (protect make-this-map make-field-map make-method-map (provide (protect make-this-map make-field-map make-method-map
make-direct-method-map make-direct-method-map
make-rename-super-map make-rename-inner-map make-rename-super-map make-rename-inner-map
make-init-error-map make-init-redirect super-error-map make-init-error-map make-init-redirect super-error-map
make-with-method-map make-with-method-map
flatten-args flatten-args make-method-call
make-private-name localize make-private-name localize
generate-super-call generate-inner-call generate-super-call generate-inner-call
generate-class-expand-context class-top-level-context?))) generate-class-expand-context class-top-level-context?)))