Change from (module ...) -> #lang and also move any mzscheme -> scheme/base.
svn: r16563
This commit is contained in:
Stevie Strickland
parent
ad438ef63f
commit
c993533814
|
|
@ -1,11 +1,11 @@
|
||||||
(module class mzscheme
|
#lang scheme/base
|
||||||
|
|
||||||
(require "contract/private/object.ss")
|
(require "contract/private/object.ss")
|
||||||
(provide (all-from "contract/private/object.ss"))
|
(provide (all-from-out "contract/private/object.ss"))
|
||||||
|
|
||||||
;; All of the implementation is actually in private/class-internal.ss,
|
;; All of the implementation is actually in private/class-internal.ss,
|
||||||
;; which provides extra (private) functionality to contract.ss.
|
;; which provides extra (private) functionality to contract.ss.
|
||||||
(require "private/class-internal.ss")
|
(require "private/class-internal.ss")
|
||||||
|
|
||||||
(provide-public-names)
|
(provide-public-names)
|
||||||
(provide generic?))
|
(provide generic?)
|
||||||
|
|
|
||||||
|
|
@ -1,111 +1,110 @@
|
||||||
|
#lang scheme/base
|
||||||
|
|
||||||
(module class-events mzscheme
|
(require (for-syntax scheme/base
|
||||||
|
scheme/stxparam))
|
||||||
|
(require scheme/stxparam)
|
||||||
|
|
||||||
(require-for-syntax mzlib/stxparam)
|
(provide current-class-event-handler
|
||||||
(require mzlib/stxparam)
|
define-traced
|
||||||
|
trace-begin
|
||||||
|
trace
|
||||||
|
initialize-call-event
|
||||||
|
finalize-call-event
|
||||||
|
new-event
|
||||||
|
inspect-event
|
||||||
|
set-event
|
||||||
|
get-event
|
||||||
|
)
|
||||||
|
|
||||||
(provide current-class-event-handler
|
(define current-class-event-handler
|
||||||
define-traced
|
(make-parameter void))
|
||||||
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)
|
||||||
;; 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
|
(define-syntax (trace-begin stx)
|
||||||
(make-set!-transformer
|
(syntax-case stx (trace)
|
||||||
(lambda (stx)
|
[(form (trace expr) ...)
|
||||||
(raise-syntax-error
|
(raise-syntax-error
|
||||||
#f
|
#f
|
||||||
"trace used outside a trace-begin"
|
"traced block has no non-trace code"
|
||||||
stx))))
|
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 (trace-begin stx)
|
(define-syntax (define-traced stx)
|
||||||
(syntax-case stx (trace)
|
(syntax-case stx ()
|
||||||
[(form (trace expr) ...)
|
[(form (name . args) . body)
|
||||||
(raise-syntax-error
|
(syntax/loc stx (form name (lambda args . body)))]
|
||||||
#f
|
[(form name body ...)
|
||||||
"traced block has no non-trace code"
|
(with-syntax ([name-traced
|
||||||
stx)]
|
(datum->syntax
|
||||||
[(form expr0 (trace expr) ...)
|
(syntax name)
|
||||||
(if (syntax-parameter-value (syntax trace?))
|
(string->symbol
|
||||||
(syntax/loc stx (begin0 expr0 expr ...))
|
(string-append
|
||||||
(syntax expr0))]
|
(symbol->string (syntax-e (syntax name)))
|
||||||
[(form (trace expr) rest ...)
|
"-traced"))
|
||||||
(if (syntax-parameter-value (syntax trace?))
|
(syntax name))])
|
||||||
(syntax/loc stx (begin expr (form rest ...)))
|
(syntax/loc stx
|
||||||
(syntax/loc stx (form rest ...)))]
|
(begin
|
||||||
[(form expr rest ...)
|
(define name
|
||||||
(syntax/loc stx (begin expr (form rest ...)))]))
|
(syntax-parameterize ([trace? #f])
|
||||||
|
body ...))
|
||||||
|
(define name-traced
|
||||||
|
(syntax-parameterize ([trace? #t])
|
||||||
|
body ...)))))]))
|
||||||
|
|
||||||
(define-syntax (define-traced stx)
|
(define current-class-event-stack
|
||||||
(syntax-case stx ()
|
(make-parameter null))
|
||||||
[(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
|
(define (initialize-event event . args)
|
||||||
(make-parameter null))
|
(current-class-event-stack
|
||||||
|
(cons
|
||||||
|
(apply (current-class-event-handler) event args)
|
||||||
|
(current-class-event-stack))))
|
||||||
|
|
||||||
(define (initialize-event event . args)
|
(define (finalize-event event . args)
|
||||||
(current-class-event-stack
|
(let* ([stack (current-class-event-stack)]
|
||||||
(cons
|
[head (car stack)]
|
||||||
(apply (current-class-event-handler) event args)
|
[tail (cdr stack)])
|
||||||
(current-class-event-stack))))
|
(when (procedure? head) (apply head args))
|
||||||
|
(current-class-event-stack tail)))
|
||||||
|
|
||||||
(define (finalize-event event . args)
|
(define (new-event class obj fields)
|
||||||
(let* ([stack (current-class-event-stack)]
|
((current-class-event-handler) 'new class obj fields))
|
||||||
[head (car stack)]
|
|
||||||
[tail (cdr stack)])
|
|
||||||
(when (procedure? head) (apply head args))
|
|
||||||
(current-class-event-stack tail)))
|
|
||||||
|
|
||||||
(define (new-event class obj fields)
|
(define (initialize-call-event obj method args)
|
||||||
((current-class-event-handler) 'new class obj fields))
|
(initialize-event 'call obj method args))
|
||||||
|
|
||||||
(define (initialize-call-event obj method args)
|
(define (finalize-call-event . returned)
|
||||||
(initialize-event 'call obj method args))
|
(apply finalize-event 'call returned)
|
||||||
|
(apply values returned))
|
||||||
|
|
||||||
(define (finalize-call-event . returned)
|
(define (inspect-event obj)
|
||||||
(apply finalize-event 'call returned)
|
((current-class-event-handler) 'inspect obj))
|
||||||
(apply values returned))
|
|
||||||
|
|
||||||
(define (inspect-event obj)
|
(define (set-event obj field value)
|
||||||
((current-class-event-handler) 'inspect obj))
|
((current-class-event-handler) 'set obj field value))
|
||||||
|
|
||||||
(define (set-event obj field value)
|
(define (get-event obj field)
|
||||||
((current-class-event-handler) 'set obj field value))
|
((current-class-event-handler) 'get obj field))
|
||||||
|
|
||||||
(define (get-event obj field)
|
|
||||||
((current-class-event-handler) 'get obj field))
|
|
||||||
|
|
||||||
)
|
|
||||||
|
|
|
||||||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,367 +1,367 @@
|
||||||
|
#lang scheme/base
|
||||||
|
|
||||||
(module classidmap scheme/base
|
(require syntax/stx
|
||||||
(require syntax/stx
|
(for-syntax scheme/base)
|
||||||
(for-syntax scheme/base)
|
(for-template scheme/base "class-events.ss"))
|
||||||
(for-template scheme/base "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))
|
||||||
|
|
||||||
|
(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-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 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)
|
||||||
|
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)
|
||||||
|
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 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 (mk-set!-trans old-id proc)
|
(define-syntax (qstx stx)
|
||||||
(make-set!-transformer (make-s!t proc old-id)))
|
(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)))))
|
||||||
|
|
||||||
(define (make-method-apply id this orig-args)
|
(provide (protect-out make-this-map make-field-map make-method-map
|
||||||
(let loop ([args orig-args][accum null])
|
make-direct-method-map
|
||||||
(cond
|
make-rename-super-map make-rename-inner-map
|
||||||
[(stx-null? args)
|
make-init-error-map make-init-redirect super-error-map
|
||||||
(list* id this orig-args)]
|
make-with-method-map
|
||||||
[(stx-pair? args)
|
flatten-args make-method-call
|
||||||
(loop (stx-cdr args) (cons (stx-car args) accum))]
|
do-localize make-private-name
|
||||||
[else
|
generate-super-call generate-inner-call
|
||||||
(list* 'apply id this (reverse (cons args accum)))])))
|
generate-class-expand-context class-top-level-context?))
|
||||||
|
|
||||||
(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-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 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)
|
|
||||||
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)
|
|
||||||
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 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-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?)))
|
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user