Added tracing capabilities to mzscheme's class system.
- 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
parent
ac640eef71
commit
22fd8f51cc
59
collects/mzlib/class-traced.ss
Normal file
59
collects/mzlib/class-traced.ss
Normal 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
111
collects/mzlib/private/class-events.ss
Normal 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))
|
||||
|
||||
)
|
||||
|
|
@ -3,6 +3,7 @@
|
|||
(require (lib "list.ss")
|
||||
(lib "etc.ss")
|
||||
(lib "stxparam.ss")
|
||||
"class-events.ss"
|
||||
"serialize-structs.ss")
|
||||
(require-for-syntax (lib "kerncase.ss" "syntax")
|
||||
(lib "stx.ss" "syntax")
|
||||
|
|
@ -117,7 +118,8 @@
|
|||
;; class macros
|
||||
;;--------------------------------------------------------------------
|
||||
|
||||
(define-syntaxes (class* _class class/derived)
|
||||
(define-syntaxes (class* _class class/derived
|
||||
class*-traced class-traced class/derived-traced)
|
||||
(let ()
|
||||
;; Start with Helper functions
|
||||
|
||||
|
|
@ -393,7 +395,7 @@
|
|||
;; --------------------------------------------------------------------------------
|
||||
;; 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]
|
||||
[(the-obj) (datum->syntax-object (quote-syntax here) (gensym '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
|
||||
(with-syntax ([the-obj the-obj]
|
||||
[the-finder the-finder]
|
||||
[this-id this-id])
|
||||
[this-id this-id]
|
||||
[trace-flag (if trace-flag (syntax #t) (syntax #f))])
|
||||
(syntax
|
||||
([(inherit-field-name ...
|
||||
local-field ...
|
||||
|
|
@ -1023,7 +1026,8 @@
|
|||
public-final-name ...
|
||||
pubment-name ...)
|
||||
(values
|
||||
(make-field-map (quote-syntax the-finder)
|
||||
(make-field-map trace-flag
|
||||
(quote-syntax the-finder)
|
||||
(quote the-obj)
|
||||
(quote-syntax inherit-field-name)
|
||||
(quote-syntax inherit-field-name-localized)
|
||||
|
|
@ -1031,7 +1035,8 @@
|
|||
(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-syntax local-field)
|
||||
(quote-syntax local-field-localized)
|
||||
|
|
@ -1316,43 +1321,59 @@
|
|||
;; Not primitive:
|
||||
#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:
|
||||
(values
|
||||
;; class*
|
||||
(lambda (stx)
|
||||
(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 ...)))]))
|
||||
(core-class* #f)
|
||||
;; class
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ super-expression
|
||||
defn-or-expr
|
||||
...)
|
||||
(main stx
|
||||
#'super-expression
|
||||
#f #f
|
||||
null
|
||||
(syntax->list #'(defn-or-expr ...)))]))
|
||||
(core-class #f)
|
||||
;; class/derived
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ orig-stx
|
||||
[name-id super-expression (interface-expr ...) deserialize-id-expr]
|
||||
defn-or-expr
|
||||
...)
|
||||
(main #'orig-stx
|
||||
#'super-expression
|
||||
#'deserialize-id-expr
|
||||
(and (syntax-e #'name-id) #'name-id)
|
||||
(syntax->list #'(interface-expr ...))
|
||||
(syntax->list #'(defn-or-expr ...)))])))))
|
||||
(core-class/derived #f)
|
||||
;; class*-traced
|
||||
(core-class* #t)
|
||||
;; class-traced
|
||||
(core-class #t)
|
||||
;; class/derived-traced
|
||||
(core-class/derived #t)
|
||||
)))
|
||||
|
||||
(define-syntax (-define-serializable-class stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -2326,35 +2347,56 @@
|
|||
;; instantiation
|
||||
;;--------------------------------------------------------------------
|
||||
|
||||
(define-syntax (new stx)
|
||||
(syntax-case stx ()
|
||||
[(_ cls (id arg) ...)
|
||||
(andmap identifier? (syntax->list (syntax (id ...))))
|
||||
(syntax/loc stx (instantiate cls () (id arg) ...))]
|
||||
[(_ cls (id arg) ...)
|
||||
(for-each (lambda (id)
|
||||
(unless (identifier? id)
|
||||
(raise-syntax-error 'new "expected identifier" stx id)))
|
||||
(syntax->list (syntax (id ...))))]
|
||||
[(_ cls pr ...)
|
||||
(for-each
|
||||
(lambda (pr)
|
||||
(syntax-case pr ()
|
||||
[(x y) (void)]
|
||||
[else (raise-syntax-error 'new "expected name and value binding" stx pr)]))
|
||||
(syntax->list (syntax (pr ...))))]))
|
||||
(define-syntaxes (new new-traced)
|
||||
|
||||
(let* ([core-new
|
||||
(lambda (instantiate-stx stx)
|
||||
(syntax-case stx ()
|
||||
[(_ cls (id arg) ...)
|
||||
(andmap identifier? (syntax->list (syntax (id ...))))
|
||||
(quasisyntax/loc stx
|
||||
((unsyntax instantiate-stx) cls () (id arg) ...))]
|
||||
[(_ cls (id arg) ...)
|
||||
(for-each (lambda (id)
|
||||
(unless (identifier? id)
|
||||
(raise-syntax-error 'new "expected identifier" stx id)))
|
||||
(syntax->list (syntax (id ...))))]
|
||||
[(_ cls pr ...)
|
||||
(for-each
|
||||
(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
|
||||
(lambda (class . args)
|
||||
(do-make-object class args null)))
|
||||
|
||||
(define make-object-traced
|
||||
(lambda (class . args)
|
||||
(do-make-object-traced class args null)))
|
||||
|
||||
(define-syntax instantiate
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(form class (arg ...) . x)
|
||||
(with-syntax ([orig-stx stx])
|
||||
(syntax/loc stx
|
||||
(-instantiate do-make-object orig-stx (class) (list arg ...) . x)))])))
|
||||
(define-syntaxes (instantiate instantiate-traced)
|
||||
|
||||
(let* ([core-instantiate
|
||||
(lambda (do-make-object-stx stx)
|
||||
(syntax-case stx ()
|
||||
[(form class (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
|
||||
(define-syntax -instantiate
|
||||
|
|
@ -2389,13 +2431,26 @@
|
|||
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)
|
||||
(raise-type-error 'instantiate "class" class))
|
||||
(let ([o ((class-make-object class))])
|
||||
;; Initialize it:
|
||||
(continue-make-object o class by-pos-args named-args #t)
|
||||
o))
|
||||
(trace-begin
|
||||
;; Initialize it:
|
||||
(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?)
|
||||
(let ([by-pos-only? (not (class-init-args c))])
|
||||
|
|
@ -2554,58 +2609,80 @@
|
|||
;; methods and fields
|
||||
;;--------------------------------------------------------------------
|
||||
|
||||
(define-syntaxes (send send/apply)
|
||||
(let ([mk
|
||||
(lambda (flatten?)
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ obj name . args)
|
||||
(begin
|
||||
(unless (identifier? (syntax name))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"method name is not an identifier"
|
||||
stx
|
||||
(syntax name)))
|
||||
(with-syntax ([name (localize (syntax name))])
|
||||
(if flatten?
|
||||
(if (stx-list? (syntax args))
|
||||
(syntax (let-values ([(mth unwrapped-this)
|
||||
(find-method/who 'send obj `name)])
|
||||
(apply mth unwrapped-this . args)))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad syntax (illegal use of `.')"
|
||||
stx))
|
||||
(if (stx-list? (syntax args))
|
||||
(syntax/loc stx
|
||||
(let-values ([(mth unwrapped-this)
|
||||
(find-method/who 'send obj `name)])
|
||||
(mth unwrapped-this . args)))
|
||||
(with-syntax ([args (flatten-args (syntax args))])
|
||||
(syntax/loc stx
|
||||
(let-values ([(mth unwrapped-this)
|
||||
(find-method/who 'send obj `name)])
|
||||
(apply mth unwrapped-this . args))))))))])))])
|
||||
(values (mk #f) (mk #t))))
|
||||
(define-syntaxes (send send/apply send-traced send/apply-traced)
|
||||
(let ()
|
||||
|
||||
(define (do-method traced? stx form obj name args rest-arg?)
|
||||
(with-syntax ([(sym method receiver)
|
||||
(generate-temporaries (syntax (1 2 3)))])
|
||||
(quasisyntax/loc stx
|
||||
(let*-values ([(sym) (quasiquote (unsyntax (localize name)))]
|
||||
[(method receiver)
|
||||
(find-method/who '(unsyntax form)
|
||||
(unsyntax obj)
|
||||
sym)])
|
||||
(unsyntax
|
||||
(make-method-call
|
||||
traced?
|
||||
stx
|
||||
(syntax/loc stx receiver)
|
||||
(syntax/loc stx unwrap-object)
|
||||
(syntax/loc stx method)
|
||||
(syntax/loc stx sym)
|
||||
args
|
||||
rest-arg?))))))
|
||||
|
||||
(define (core-send traced? apply?)
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(form obj name . args)
|
||||
(identifier? (syntax name))
|
||||
(if (stx-list? (syntax args))
|
||||
;; (send obj name arg ...) or (send/apply obj name arg ...)
|
||||
(do-method traced? stx #'form #'obj #'name #'args apply?)
|
||||
(if apply?
|
||||
;; (send/apply obj name arg ... . rest)
|
||||
(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*
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ obj s ...)
|
||||
(with-syntax ([sends (map (lambda (s)
|
||||
(syntax-case s ()
|
||||
[(meth . args)
|
||||
(syntax/loc s (send o meth . args))]
|
||||
[_else (raise-syntax-error
|
||||
#f
|
||||
"bad method call"
|
||||
stx
|
||||
s)]))
|
||||
(syntax->list (syntax (s ...))))])
|
||||
(syntax/loc stx
|
||||
(let ([o obj])
|
||||
. sends)))])))
|
||||
(define-syntaxes (send* send*-traced)
|
||||
(let* ([core-send*
|
||||
(lambda (traced?)
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(form obj clause ...)
|
||||
(quasisyntax/loc stx
|
||||
(let* ([o obj])
|
||||
(unsyntax-splicing
|
||||
(map
|
||||
(lambda (clause-stx)
|
||||
(syntax-case clause-stx ()
|
||||
[(meth . args)
|
||||
(quasisyntax/loc stx
|
||||
((unsyntax (if traced?
|
||||
(syntax/loc stx send-traced)
|
||||
(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]
|
||||
;; any[object]
|
||||
|
|
@ -2663,7 +2740,7 @@
|
|||
make-struct-field-mutator class-field-set!
|
||||
class name))
|
||||
|
||||
(define-struct generic (applicable))
|
||||
(define-struct generic (name applicable))
|
||||
|
||||
;; Internally, make-generic comes from the struct def.
|
||||
;; Externally, make-generic is the following procedure.
|
||||
|
|
@ -2676,6 +2753,7 @@
|
|||
(unless (symbol? name)
|
||||
(raise-type-error 'make-generic "symbol" name))
|
||||
(make-generic
|
||||
name
|
||||
(if (interface? class)
|
||||
(let ([intf class])
|
||||
(unless (method-in-interface? name intf)
|
||||
|
|
@ -2713,21 +2791,32 @@
|
|||
dynamic-generic)))))])
|
||||
make-generic))
|
||||
|
||||
(define-syntax send-generic
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ obj generic . args)
|
||||
(if (stx-list? (syntax args))
|
||||
(with-syntax ([call (syntax/loc stx
|
||||
(((generic-applicable generic) this) this . args))])
|
||||
(syntax/loc stx (let ([this obj])
|
||||
call)))
|
||||
(with-syntax ([args (flatten-args (syntax args))])
|
||||
(with-syntax ([call (syntax/loc stx
|
||||
(apply ((generic-applicable generic) this) this . args))])
|
||||
(syntax (let ([this obj])
|
||||
call)))))])))
|
||||
|
||||
(define-syntaxes (send-generic send-generic-traced)
|
||||
(let ()
|
||||
(define (core-send-generic traced?)
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ object generic . args)
|
||||
(let* ([args-stx (syntax args)]
|
||||
[proper? (stx-list? args-stx)]
|
||||
[flat-stx (if proper? args-stx (flatten-args args-stx))])
|
||||
(with-syntax ([(gen obj)
|
||||
(generate-temporaries (syntax (generic object)))])
|
||||
(quasisyntax/loc stx
|
||||
(let* ([obj object]
|
||||
[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)
|
||||
(let ([mk
|
||||
(lambda (make targets)
|
||||
|
|
@ -2755,29 +2844,58 @@
|
|||
(mk (quote-syntax make-class-field-mutator) "class")
|
||||
(mk (quote-syntax make-generic/proc) "class or interface"))))
|
||||
|
||||
(define-syntax (get-field stx)
|
||||
(define-syntax (class-field-accessor-traced stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name obj)
|
||||
(identifier? (syntax name))
|
||||
(with-syntax ([localized (localize (syntax name))])
|
||||
(syntax (get-field/proc `localized obj)))]
|
||||
[(_ name obj)
|
||||
(raise-syntax-error 'get-field "expected a field name as first argument" stx (syntax name))]))
|
||||
[(form class name)
|
||||
(syntax/loc stx
|
||||
(let* ([accessor (class-field-accessor class name)])
|
||||
(lambda (obj)
|
||||
(begin0 (accessor obj)
|
||||
(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)
|
||||
(raise-mismatch-error
|
||||
'get-field
|
||||
"expected an object, got "
|
||||
obj))
|
||||
(let loop ([obj obj])
|
||||
(let* ([cls (object-ref obj)]
|
||||
[field-ht (class-field-ht cls)]
|
||||
[index (hash-table-get
|
||||
field-ht
|
||||
id
|
||||
#f)])
|
||||
(cond
|
||||
(trace-begin
|
||||
(trace (get-event obj id))
|
||||
(let loop ([obj obj])
|
||||
(let* ([cls (object-ref obj)]
|
||||
[field-ht (class-field-ht cls)]
|
||||
[index (hash-table-get
|
||||
field-ht
|
||||
id
|
||||
#f)])
|
||||
(cond
|
||||
[index
|
||||
((class-field-ref (car index)) obj (cdr index))]
|
||||
[(wrapper-object? obj)
|
||||
|
|
@ -2786,122 +2904,150 @@
|
|||
(raise-mismatch-error
|
||||
'get-field
|
||||
(format "expected an object that has a field named ~s, got " id)
|
||||
obj)]))))
|
||||
obj)])))))
|
||||
|
||||
(define-syntax (field-bound? stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name obj)
|
||||
(identifier? (syntax name))
|
||||
(with-syntax ([localized (localize (syntax name))])
|
||||
(syntax (field-bound?/proc `localized obj)))]
|
||||
[(_ name obj)
|
||||
(raise-syntax-error 'field-bound? "expected a field name as first argument" stx (syntax name))]))
|
||||
(define-syntaxes (field-bound? field-bound?-traced)
|
||||
(let ()
|
||||
(define (core-field-bound? traced?)
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name obj)
|
||||
(identifier? (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)
|
||||
(raise-mismatch-error
|
||||
'field-bound?
|
||||
"expected an object, got "
|
||||
obj))
|
||||
(let loop ([obj obj])
|
||||
(let* ([cls (object-ref obj)]
|
||||
[field-ht (class-field-ht cls)])
|
||||
(or (and (hash-table-get field-ht id #f)
|
||||
#t) ;; ensure that only #t and #f leak out, not bindings in ht
|
||||
(and (wrapper-object? obj)
|
||||
(loop (wrapper-object-wrapped obj)))))))
|
||||
(trace-begin
|
||||
(trace (inspect-event obj))
|
||||
(let loop ([obj obj])
|
||||
(let* ([cls (object-ref obj)]
|
||||
[field-ht (class-field-ht cls)])
|
||||
(or (and (hash-table-get field-ht id #f)
|
||||
#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)
|
||||
(raise-mismatch-error
|
||||
'field-names
|
||||
"expected an object, got "
|
||||
obj))
|
||||
(let loop ([obj obj])
|
||||
(let* ([cls (object-ref obj)]
|
||||
[field-ht (class-field-ht cls)]
|
||||
[flds (filter interned? (hash-table-map field-ht (lambda (x y) x)))])
|
||||
(if (wrapper-object? obj)
|
||||
(append flds (loop (wrapper-object-wrapped obj)))
|
||||
flds))))
|
||||
(trace-begin
|
||||
(trace (inspect-event obj))
|
||||
(let loop ([obj obj])
|
||||
(let* ([cls (object-ref obj)]
|
||||
[field-ht (class-field-ht cls)]
|
||||
[flds (filter interned? (hash-table-map field-ht (lambda (x y) x)))])
|
||||
(if (wrapper-object? obj)
|
||||
(append flds (loop (wrapper-object-wrapped obj)))
|
||||
flds)))))
|
||||
|
||||
(define-syntax with-method
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ ([id (obj-expr name)] ...) body0 body1 ...)
|
||||
(let ([ids (syntax->list (syntax (id ...)))]
|
||||
[names (syntax->list (syntax (name ...)))])
|
||||
(for-each (lambda (id name)
|
||||
(unless (identifier? id)
|
||||
(raise-syntax-error #f
|
||||
"not an identifier for binding"
|
||||
stx
|
||||
id))
|
||||
(unless (identifier? name)
|
||||
(raise-syntax-error #f
|
||||
"not an identifier for method name"
|
||||
stx
|
||||
name)))
|
||||
ids names)
|
||||
(with-syntax ([(method ...) (generate-temporaries ids)]
|
||||
[(method-obj ...) (generate-temporaries ids)]
|
||||
[(name ...) (map localize names)])
|
||||
(syntax/loc stx (let-values ([(method method-obj)
|
||||
(let ([obj obj-expr])
|
||||
(find-method/who 'with-method obj `name))]
|
||||
...)
|
||||
(letrec-syntaxes+values ([(id) (make-with-method-map
|
||||
(quote-syntax set!)
|
||||
(quote-syntax id)
|
||||
(quote-syntax method)
|
||||
(quote-syntax method-obj))]
|
||||
...)
|
||||
()
|
||||
body0 body1 ...)))))]
|
||||
;; Error cases:
|
||||
[(_ (clause ...) . body)
|
||||
(begin
|
||||
(for-each (lambda (clause)
|
||||
(syntax-case clause ()
|
||||
[(id (obj-expr name))
|
||||
(and (identifier? (syntax id))
|
||||
(identifier? (syntax name)))
|
||||
'ok]
|
||||
[_else
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"binding clause is not of the form (identifier (object-expr method-identifier))"
|
||||
stx
|
||||
clause)]))
|
||||
(syntax->list (syntax (clause ...))))
|
||||
;; If we get here, the body must be bad
|
||||
(if (stx-null? (syntax body))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"empty body"
|
||||
stx)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad syntax (illegal use of `.')"
|
||||
stx)))]
|
||||
[(_ x . rest)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"not a binding sequence"
|
||||
stx
|
||||
(syntax x))])))
|
||||
(define-syntaxes (with-method with-method-traced)
|
||||
(let ()
|
||||
(define (core-with-method traced?)
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ ([id (obj-expr name)] ...) body0 body1 ...)
|
||||
(let ([ids (syntax->list (syntax (id ...)))]
|
||||
[names (syntax->list (syntax (name ...)))])
|
||||
(for-each (lambda (id name)
|
||||
(unless (identifier? id)
|
||||
(raise-syntax-error #f
|
||||
"not an identifier for binding"
|
||||
stx
|
||||
id))
|
||||
(unless (identifier? name)
|
||||
(raise-syntax-error #f
|
||||
"not an identifier for method name"
|
||||
stx
|
||||
name)))
|
||||
ids names)
|
||||
(with-syntax ([(method ...) (generate-temporaries ids)]
|
||||
[(method-obj ...) (generate-temporaries ids)]
|
||||
[(name ...) (map localize names)]
|
||||
[trace-flag (if traced? (syntax/loc stx #t) (syntax/loc stx #f))])
|
||||
(syntax/loc stx (let-values ([(method method-obj)
|
||||
(let ([obj obj-expr])
|
||||
(find-method/who 'with-method obj `name))]
|
||||
...)
|
||||
(letrec-syntaxes+values ([(id) (make-with-method-map
|
||||
trace-flag
|
||||
(quote-syntax set!)
|
||||
(quote-syntax id)
|
||||
(quote-syntax method)
|
||||
(quote-syntax method-obj)
|
||||
(syntax unwrap-object))]
|
||||
...)
|
||||
()
|
||||
body0 body1 ...)))))]
|
||||
;; Error cases:
|
||||
[(_ (clause ...) . body)
|
||||
(begin
|
||||
(for-each (lambda (clause)
|
||||
(syntax-case clause ()
|
||||
[(id (obj-expr name))
|
||||
(and (identifier? (syntax id))
|
||||
(identifier? (syntax name)))
|
||||
'ok]
|
||||
[_else
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"binding clause is not of the form (identifier (object-expr method-identifier))"
|
||||
stx
|
||||
clause)]))
|
||||
(syntax->list (syntax (clause ...))))
|
||||
;; If we get here, the body must be bad
|
||||
(if (stx-null? (syntax body))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"empty body"
|
||||
stx)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad syntax (illegal use of `.')"
|
||||
stx)))]
|
||||
[(_ 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
|
||||
;;--------------------------------------------------------------------
|
||||
|
||||
(define (is-a? v c)
|
||||
(cond
|
||||
[(class? c) ((class-object? c) (unwrap-object v))]
|
||||
[(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-traced (is-a? v c)
|
||||
(trace-begin
|
||||
(trace (when (object? v)
|
||||
(inspect-event v)))
|
||||
(cond
|
||||
[(class? c) ((class-object? c) (unwrap-object v))]
|
||||
[(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)
|
||||
(unless (class? c)
|
||||
|
|
@ -2911,12 +3057,14 @@
|
|||
(and (<= p (class-pos v))
|
||||
(eq? c (vector-ref (class-supers v) p))))))
|
||||
|
||||
(define (object-interface o)
|
||||
(define-traced (object-interface o)
|
||||
(unless (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)
|
||||
(raise-type-error 'object-method-arity-includes? "object" o))
|
||||
(unless (symbol? name)
|
||||
|
|
@ -2925,14 +3073,16 @@
|
|||
(exact? cnt)
|
||||
(not (negative? cnt)))
|
||||
(raise-type-error 'object-method-arity-includes? "non-negative exact integer" cnt))
|
||||
(let loop ([o o])
|
||||
(let* ([c (object-ref o)]
|
||||
[pos (hash-table-get (class-method-ht c) name #f)])
|
||||
(cond
|
||||
[pos (procedure-arity-includes? (vector-ref (class-methods c) pos)
|
||||
(add1 cnt))]
|
||||
[(wrapper-object? o) (loop (wrapper-object-wrapped o))]
|
||||
[else #f]))))
|
||||
(trace-begin
|
||||
(trace (inspect-event o))
|
||||
(let loop ([o o])
|
||||
(let* ([c (object-ref o)]
|
||||
[pos (hash-table-get (class-method-ht c) name #f)])
|
||||
(cond
|
||||
[pos (procedure-arity-includes? (vector-ref (class-methods c) pos)
|
||||
(add1 cnt))]
|
||||
[(wrapper-object? o) (loop (wrapper-object-wrapped o))]
|
||||
[else #f])))))
|
||||
|
||||
(define (implementation? v i)
|
||||
(unless (interface? i)
|
||||
|
|
@ -2968,17 +3118,19 @@
|
|||
(apply list-immutable (filter interned? (interface-public-ids i))))
|
||||
|
||||
|
||||
(define (object-info o)
|
||||
(define-traced (object-info o)
|
||||
(unless (object? o)
|
||||
(raise-type-error 'object-info "object" o))
|
||||
(let loop ([c (object-ref (unwrap-object o))]
|
||||
[skipped? #f])
|
||||
(if (struct? ((class-insp-mk c)))
|
||||
;; current inspector can inspect this object
|
||||
(values c skipped?)
|
||||
(if (zero? (class-pos c))
|
||||
(values #f #t)
|
||||
(loop (vector-ref (class-supers c) (sub1 (class-pos c))) #t)))))
|
||||
(trace-begin
|
||||
(trace (inspect-event o))
|
||||
(let loop ([c (object-ref (unwrap-object o))]
|
||||
[skipped? #f])
|
||||
(if (struct? ((class-insp-mk c)))
|
||||
;; current inspector can inspect this object
|
||||
(values c skipped?)
|
||||
(if (zero? (class-pos c))
|
||||
(values #f #t)
|
||||
(loop (vector-ref (class-supers c) (sub1 (class-pos c))) #t))))))
|
||||
|
||||
(define (class-info c)
|
||||
(unless (class? c)
|
||||
|
|
@ -3000,20 +3152,23 @@
|
|||
(loop (vector-ref (class-supers next) (sub1 (class-pos next))) #t)))))
|
||||
(raise-mismatch-error 'class-info "current inspector cannot inspect class: " c)))
|
||||
|
||||
(define object->vector
|
||||
(define-traced object->vector
|
||||
(opt-lambda (in-o [opaque-v '...])
|
||||
(unless (object? in-o)
|
||||
(raise-type-error 'object->vector "object" in-o))
|
||||
(let ([o (unwrap-object in-o)])
|
||||
(list->vector
|
||||
(cons
|
||||
(string->symbol (format "object:~a" (class-name (object-ref o))))
|
||||
(reverse
|
||||
(let-values ([(c skipped?) (object-info o)])
|
||||
(let loop ([c c][skipped? skipped?])
|
||||
(cond
|
||||
(trace-begin
|
||||
(trace (inspect-event in-o))
|
||||
(let ([o (unwrap-object in-o)])
|
||||
(list->vector
|
||||
(cons
|
||||
(string->symbol (format "object:~a" (class-name (object-ref o))))
|
||||
(reverse
|
||||
(let-values ([(c skipped?) (object-info o)])
|
||||
(let loop ([c c][skipped? skipped?])
|
||||
(cond
|
||||
[(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)])
|
||||
(let ([rest (loop next next-skipped?)]
|
||||
[here (let loop ([n num-fields])
|
||||
|
|
@ -3023,7 +3178,7 @@
|
|||
(loop (sub1 n)))))])
|
||||
(append (if skipped? (list opaque-v) null)
|
||||
here
|
||||
rest)))])))))))))
|
||||
rest)))]))))))))))
|
||||
|
||||
(define (object=? o1 o2)
|
||||
(unless (object? o1)
|
||||
|
|
@ -3409,7 +3564,37 @@
|
|||
|
||||
(define externalizable<%>
|
||||
(_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
|
||||
wrapper-object-wrapped
|
||||
extract-vtable
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
|
||||
(module classidmap mzscheme
|
||||
(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!)
|
||||
(make-struct-type 'set!-transformer #f 2 0 #f null (current-inspector) 0))
|
||||
|
|
@ -24,13 +25,7 @@
|
|||
|
||||
;; Check Syntax binding info:
|
||||
(define (binding from to stx)
|
||||
stx
|
||||
;; This 'bound-in-source is no longer needed
|
||||
#;
|
||||
(syntax-property
|
||||
stx
|
||||
'bound-in-source
|
||||
(cons from (syntax-local-introduce to))))
|
||||
stx)
|
||||
|
||||
|
||||
(define (make-this-map orig-id the-finder the-obj)
|
||||
|
|
@ -49,34 +44,42 @@
|
|||
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!)])
|
||||
(mk-set!-trans
|
||||
the-binder-localized
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(set! id expr)
|
||||
(module-identifier=? (syntax set!) set!-stx)
|
||||
(binding
|
||||
the-binder (syntax id)
|
||||
(datum->syntax-object
|
||||
the-finder
|
||||
(list* field-mutator (find the-finder the-obj stx) (append field-pos/null (list (syntax expr))))
|
||||
stx))]
|
||||
[(id . args)
|
||||
(binding
|
||||
the-binder (syntax id)
|
||||
(datum->syntax-object
|
||||
the-finder
|
||||
(cons (list* field-accessor (find the-finder the-obj stx) field-pos/null) (syntax args))
|
||||
stx))]
|
||||
[_else
|
||||
(binding
|
||||
the-binder stx
|
||||
(datum->syntax-object
|
||||
the-finder
|
||||
(list* field-accessor (find the-finder the-obj stx) field-pos/null)
|
||||
stx))])))))
|
||||
(with-syntax ([obj-expr (find the-finder the-obj stx)])
|
||||
(syntax-case stx ()
|
||||
[(set! id expr)
|
||||
(module-identifier=? (syntax set!) set!-stx)
|
||||
(with-syntax ([bindings (syntax/loc stx ([obj obj-expr] [value expr]))]
|
||||
[trace (syntax/loc stx (set-event obj (quote id) value))]
|
||||
[set (quasisyntax/loc stx
|
||||
((unsyntax field-mutator)
|
||||
obj (unsyntax-splicing field-pos/null) value))])
|
||||
(if trace-flag
|
||||
(syntax/loc stx (let* bindings trace set))
|
||||
(syntax/loc stx (let* bindings set))))]
|
||||
[(id . args)
|
||||
(with-syntax ([bindings (syntax/loc stx ([obj obj-expr]))]
|
||||
[trace (syntax/loc stx (get-event obj (quote id)))]
|
||||
[call (quasisyntax/loc stx
|
||||
(((unsyntax field-accessor)
|
||||
obj-expr (unsyntax-splicing field-pos/null)) . args))])
|
||||
(if trace-flag
|
||||
(syntax/loc stx (let* bindings trace call))
|
||||
(syntax/loc stx (let* bindings call))))]
|
||||
[id
|
||||
(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)
|
||||
(let ([set!-stx (datum->syntax-object the-finder 'set!)])
|
||||
|
|
@ -248,22 +251,31 @@
|
|||
"cannot use superclass initialization form in a method"
|
||||
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
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(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)]
|
||||
[(id . args)
|
||||
(datum->syntax-object
|
||||
set!-stx
|
||||
(make-method-apply
|
||||
method-stx
|
||||
method-obj-stx
|
||||
(syntax args))
|
||||
stx)]
|
||||
[_else
|
||||
(identifier? (syntax id))
|
||||
(let* ([args-stx (syntax args)]
|
||||
[proper? (stx-list? args-stx)]
|
||||
[flat-args-stx (if proper? args-stx (flatten-args args-stx))])
|
||||
(make-method-call
|
||||
trace-flag
|
||||
stx
|
||||
method-obj-stx
|
||||
unwrap-stx
|
||||
method-stx
|
||||
(syntax (quote id))
|
||||
flat-args-stx
|
||||
(not proper?)))]
|
||||
[id
|
||||
(identifier? (syntax id))
|
||||
(raise-syntax-error
|
||||
'with-method
|
||||
"misuse of method (not in application)"
|
||||
|
|
@ -307,12 +319,39 @@
|
|||
(and (pair? 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
|
||||
make-direct-method-map
|
||||
make-rename-super-map make-rename-inner-map
|
||||
make-init-error-map make-init-redirect super-error-map
|
||||
make-with-method-map
|
||||
flatten-args
|
||||
flatten-args make-method-call
|
||||
make-private-name localize
|
||||
generate-super-call generate-inner-call
|
||||
generate-class-expand-context class-top-level-context?)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user