14ab0175c3
unwrapping operation helps a bit, especially with inherited fields. Unfortunately, as one might expect, TANSTAAFL applies here. In order to make sure that we keep the contracted objects around as much as possible to make sure there are no holes, we end up making local and inherited field access codes 2-3x more than they did before. However, this is still something on the order of 5x faster than external access. But blah. CONTRACTS ARE NOT FREE. Just ask your local lawyer. svn: r18285
385 lines
14 KiB
Scheme
385 lines
14 KiB
Scheme
#lang scheme/base
|
|
|
|
(require syntax/stx
|
|
(for-syntax scheme/base)
|
|
(for-template scheme/base "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))
|
|
|
|
(define (mk-set!-trans old-id proc)
|
|
(make-set!-transformer (make-s!t proc old-id)))
|
|
|
|
(define (make-method-apply id this orig-args)
|
|
(let loop ([args orig-args][accum null])
|
|
(cond
|
|
[(stx-null? args)
|
|
(list* id this orig-args)]
|
|
[(stx-pair? args)
|
|
(loop (stx-cdr args) (cons (stx-car args) accum))]
|
|
[else
|
|
(list* 'apply id this (reverse (cons args accum)))])))
|
|
|
|
(define (find the-finder name src)
|
|
(let ([this-id (syntax-local-value (syntax-local-get-shadower the-finder))])
|
|
(datum->syntax this-id name src)))
|
|
|
|
;; Check Syntax binding info:
|
|
(define (binding from to stx)
|
|
stx)
|
|
|
|
|
|
(define (make-this-map orig-id the-finder the-obj)
|
|
(let ([set!-stx (datum->syntax the-finder 'set!)])
|
|
(mk-set!-trans
|
|
orig-id
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(set! id expr)
|
|
(free-identifier=? (syntax set!) set!-stx)
|
|
(raise-syntax-error 'class "cannot mutate object identifier" stx)]
|
|
[(id . args)
|
|
(datum->syntax
|
|
stx
|
|
(cons (find the-finder the-obj stx) (syntax args))
|
|
stx)]
|
|
[id (find the-finder the-obj stx)])))))
|
|
|
|
(define (make-this%-map replace-stx the-finder)
|
|
(let ([set!-stx (datum->syntax the-finder 'set!)])
|
|
(make-set!-transformer
|
|
(λ (stx)
|
|
(syntax-case stx ()
|
|
[(set! id expr)
|
|
(free-identifier=? #'set! set!-stx)
|
|
(raise-syntax-error 'class "cannot mutate this% identifier" stx)]
|
|
[id
|
|
(identifier? #'id)
|
|
(quasisyntax/loc stx #,replace-stx)]
|
|
[(f . args)
|
|
(quasisyntax/loc stx (#,replace-stx . args))])))))
|
|
|
|
(define (make-field-map trace-flag the-finder the-obj unwrapper the-binder the-binder-localized
|
|
field-accessor field-mutator field-pos/null)
|
|
(let ([set!-stx (datum->syntax the-finder 'set!)])
|
|
(mk-set!-trans
|
|
the-binder-localized
|
|
(lambda (stx)
|
|
(with-syntax ([obj-expr (find the-finder the-obj stx)])
|
|
(syntax-case stx ()
|
|
[(set! id expr)
|
|
(free-identifier=? (syntax set!) set!-stx)
|
|
(with-syntax ([bindings (syntax/loc stx ([obj obj-expr] [id expr]))]
|
|
[trace (syntax/loc stx (set-event obj (quote id) id))]
|
|
[set (quasisyntax/loc stx
|
|
((unsyntax field-mutator)
|
|
((unsyntax unwrapper) obj)
|
|
(unsyntax-splicing field-pos/null) id))])
|
|
(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)
|
|
((unsyntax unwrapper) 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)
|
|
((unsyntax unwrapper) 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 the-finder 'set!)])
|
|
(mk-set!-trans
|
|
the-binder-localized
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(set! id expr)
|
|
(free-identifier=? (syntax set!) set!-stx)
|
|
(raise-syntax-error 'class "cannot mutate method" stx)]
|
|
[(id . args)
|
|
(binding
|
|
the-binder (syntax id)
|
|
(datum->syntax
|
|
the-finder
|
|
(make-method-apply
|
|
(list method-accessor (find the-finder the-obj stx))
|
|
(find the-finder the-obj stx)
|
|
(syntax args))
|
|
stx))]
|
|
[_else
|
|
(raise-syntax-error
|
|
'class
|
|
"misuse of method (not in application)"
|
|
stx)])))))
|
|
|
|
;; For methods that are dirrectly available via their names
|
|
;; (e.g., private methods)
|
|
(define (make-direct-method-map the-finder the-obj the-binder the-binder-localized new-name)
|
|
(let ([set!-stx (datum->syntax the-finder 'set!)])
|
|
(mk-set!-trans
|
|
the-binder-localized
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(set! id expr)
|
|
(free-identifier=? (syntax set!) set!-stx)
|
|
(raise-syntax-error 'class "cannot mutate method" stx)]
|
|
[(id . args)
|
|
(binding
|
|
the-binder (syntax id)
|
|
(datum->syntax
|
|
the-finder
|
|
(make-method-apply (find the-finder new-name stx) (find the-finder the-obj stx) (syntax args))
|
|
stx))]
|
|
[_else
|
|
(raise-syntax-error
|
|
'class
|
|
"misuse of method (not in application)"
|
|
stx)])))))
|
|
|
|
(define (make-rename-super-map the-finder the-obj the-binder the-binder-localized rename-temp)
|
|
(let ([set!-stx (datum->syntax the-finder 'set!)])
|
|
(mk-set!-trans
|
|
the-binder-localized
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(set! id expr)
|
|
(free-identifier=? (syntax set!) set!-stx)
|
|
(raise-syntax-error 'class "cannot mutate super method" stx)]
|
|
[(id . args)
|
|
(binding
|
|
the-binder (syntax id)
|
|
(datum->syntax
|
|
the-finder
|
|
(make-method-apply (find the-finder rename-temp stx) (find the-finder the-obj stx) (syntax args))
|
|
stx))]
|
|
[_else
|
|
(raise-syntax-error
|
|
'class
|
|
"misuse of super method (not in application)"
|
|
stx)])))))
|
|
|
|
(define (make-rename-inner-map the-finder the-obj the-binder the-binder-localized rename-temp)
|
|
(let ([set!-stx (datum->syntax the-finder 'set!)]
|
|
[lambda-stx (datum->syntax the-finder 'lambda)])
|
|
(mk-set!-trans
|
|
the-binder-localized
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(set! id expr)
|
|
(free-identifier=? (syntax set!) set!-stx)
|
|
(raise-syntax-error 'class "cannot mutate inner method" stx)]
|
|
[(id (lambda () default) . args)
|
|
(free-identifier=? (syntax lambda) lambda-stx)
|
|
(let ([target (find the-finder the-obj stx)])
|
|
(binding
|
|
the-binder (syntax id)
|
|
(datum->syntax
|
|
the-finder
|
|
(make-method-apply (list (find the-finder rename-temp stx) target #'default)
|
|
target (syntax args))
|
|
stx)))]
|
|
[(id (lambda largs default) . args)
|
|
(free-identifier=? (syntax lambda) lambda-stx)
|
|
(raise-syntax-error
|
|
'class
|
|
"misuse of inner method (lambda for default does not take zero arguments)"
|
|
stx)]
|
|
[(id (lambda . rest) . args)
|
|
(free-identifier=? (syntax lambda) lambda-stx)
|
|
(raise-syntax-error
|
|
'class
|
|
"misuse of inner method (ill-formed lambda for default)"
|
|
stx)]
|
|
[(id . args)
|
|
(raise-syntax-error
|
|
'class
|
|
"misuse of inner method (no lambda-wrapped default after name)"
|
|
stx)]
|
|
[_else
|
|
(raise-syntax-error
|
|
'class
|
|
"misuse of inner method (not in application)"
|
|
stx)])))))
|
|
|
|
(define (generate-super-call stx the-finder the-obj rename-temp args)
|
|
(datum->syntax
|
|
the-finder
|
|
(make-method-apply (find the-finder rename-temp stx)
|
|
(find the-finder the-obj stx)
|
|
args)
|
|
stx))
|
|
|
|
(define (generate-inner-call stx the-finder the-obj default-expr rename-temp args)
|
|
(datum->syntax
|
|
the-finder
|
|
(let ([target (find the-finder the-obj stx)])
|
|
(datum->syntax
|
|
the-finder
|
|
`(let ([i (,(find the-finder rename-temp stx) ,target)])
|
|
(if i
|
|
,(make-method-apply 'i target args)
|
|
,default-expr))
|
|
stx))
|
|
stx))
|
|
|
|
(define (make-init-error-map localized-id)
|
|
(mk-set!-trans
|
|
localized-id
|
|
(lambda (stx)
|
|
(raise-syntax-error
|
|
'class
|
|
"cannot use non-field init variable in a method"
|
|
stx))))
|
|
|
|
(define (make-init-redirect set!-stx #%app-stx local-id localized-id)
|
|
(mk-set!-trans
|
|
localized-id
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(set! id expr)
|
|
(free-identifier=? (syntax set!) set!-stx)
|
|
(with-syntax ([local-id local-id])
|
|
(syntax/loc stx (set! local-id expr)))]
|
|
[(id . args)
|
|
(with-syntax ([local-id local-id]
|
|
[#%app #%app-stx])
|
|
(syntax/loc stx (#%app local-id . args)))]
|
|
[_else (datum->syntax
|
|
local-id
|
|
(syntax-e local-id)
|
|
stx
|
|
stx)]))))
|
|
|
|
(define super-error-map
|
|
(lambda (stx)
|
|
(raise-syntax-error
|
|
'class
|
|
"cannot use superclass initialization form in a method"
|
|
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)
|
|
(and (identifier? (syntax id))
|
|
(free-identifier=? (syntax set!) set!-stx))
|
|
(raise-syntax-error 'with-method "cannot mutate method" stx)]
|
|
[(id . args)
|
|
(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)"
|
|
stx)]))))
|
|
|
|
(define (flatten-args orig-args)
|
|
(let loop ([args orig-args][accum null])
|
|
(cond
|
|
[(stx-null? args) orig-args]
|
|
[(stx-pair? args)
|
|
(loop (stx-cdr args) (cons (stx-car args) accum))]
|
|
[else
|
|
(reverse (cons args accum))])))
|
|
|
|
(define-struct private-name (orig-id gen-id)
|
|
#:property prop:procedure (lambda (self stx)
|
|
(if (not (eq? (syntax-local-context) 'expression))
|
|
#`(#%expression #,stx)
|
|
(raise-syntax-error
|
|
#f
|
|
"unbound local member name"
|
|
stx))))
|
|
|
|
(define (do-localize orig-id validate-local-member-stx)
|
|
(let loop ([id orig-id])
|
|
(let ([v (syntax-local-value id (lambda () #f))])
|
|
(cond
|
|
[(and v (private-name? v))
|
|
(list 'unquote
|
|
(list validate-local-member-stx
|
|
(list 'quote orig-id)
|
|
(binding (private-name-orig-id v)
|
|
id
|
|
(private-name-gen-id v))))]
|
|
[(and (set!-transformer? v)
|
|
(s!t? (set!-transformer-procedure v)))
|
|
(s!t-ref (set!-transformer-procedure v) 1)]
|
|
[else orig-id]))))
|
|
|
|
(define-struct class-context ())
|
|
|
|
(define (generate-class-expand-context)
|
|
(let ([c (syntax-local-context)]
|
|
[v (make-class-context)])
|
|
(if (pair? c)
|
|
(cons v c)
|
|
(list v))))
|
|
|
|
(define (class-top-level-context? ctx)
|
|
(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-out make-this-map 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 make-method-call
|
|
do-localize make-private-name
|
|
generate-super-call generate-inner-call
|
|
generate-class-expand-context class-top-level-context?))
|