106 lines
3.4 KiB
Scheme
106 lines
3.4 KiB
Scheme
#lang scheme/base
|
|
(require (for-template scheme/base
|
|
scheme/class)
|
|
syntax/parse
|
|
syntax/stx)
|
|
|
|
(provide static-interface?
|
|
make-static-interface
|
|
static-interface-dynamic
|
|
static-interface-members
|
|
|
|
make-checked-binding
|
|
checked-binding?
|
|
checked-binding-dynamic
|
|
checked-binding-iface
|
|
|
|
checked-binding
|
|
static-interface
|
|
|
|
interface-expander?
|
|
make-interface-expander
|
|
interface-expander-proc
|
|
|
|
interface-expander
|
|
method-entry)
|
|
|
|
|
|
(define-struct static-interface (dynamic members)
|
|
#:omit-define-syntaxes
|
|
#:property prop:procedure
|
|
(lambda (self stx)
|
|
(syntax-case stx ()
|
|
[(ifname . args)
|
|
(datum->syntax stx (cons #'(#%expression ifname) #'args) stx)]
|
|
[ifname
|
|
(identifier? #'ifname)
|
|
(static-interface-dynamic self)])))
|
|
|
|
(define-struct raw-checked-binding (dynamic iface)
|
|
#:omit-define-syntaxes
|
|
#:property prop:procedure
|
|
(lambda (self stx)
|
|
(syntax-case stx (set!)
|
|
[(set! var expr)
|
|
#`(let ([newval expr])
|
|
(unless (is-a? newval #,(static-interface-dynamic
|
|
(raw-checked-binding-iface self)))
|
|
(error 'check "interface check failed on: ~e" newval))
|
|
(set! #,(raw-checked-binding-dynamic self) newval))]
|
|
[(var . args)
|
|
(datum->syntax stx (cons #'(#%expression var) #'args) stx)]
|
|
[var
|
|
(identifier? #'var)
|
|
(raw-checked-binding-dynamic self)]
|
|
[else
|
|
(raise-syntax-error #f "oops" stx)])))
|
|
|
|
(define (make-checked-binding dynamic iface)
|
|
(make-set!-transformer
|
|
(make-raw-checked-binding dynamic iface)))
|
|
|
|
(define (checked-binding? x)
|
|
(and (set!-transformer? x)
|
|
(raw-checked-binding? (set!-transformer-procedure x))))
|
|
|
|
(define (checked-binding-dynamic x)
|
|
(raw-checked-binding-dynamic (set!-transformer-procedure x)))
|
|
|
|
(define (checked-binding-iface x)
|
|
(raw-checked-binding-iface (set!-transformer-procedure x)))
|
|
|
|
|
|
(define-struct interface-expander (proc)
|
|
#:omit-define-syntaxes)
|
|
|
|
|
|
;; Syntax
|
|
|
|
(define-syntax-class static-interface
|
|
(pattern x
|
|
#:declare x (static static-interface? 'static-interface)
|
|
#:attr value (attribute x.value)))
|
|
|
|
(define-syntax-class checked-binding
|
|
(pattern x
|
|
#:declare x (static checked-binding? 'checked-binding)
|
|
#:attr value (attribute x.value)))
|
|
|
|
(define-syntax-class interface-expander
|
|
(pattern x
|
|
#:declare x (static interface-expander? 'interface-expander)
|
|
#:attr value (attribute x.value)))
|
|
|
|
(define-syntax-class method-entry
|
|
(pattern m:id
|
|
#:with (method ...) #'(m))
|
|
(pattern (macro:interface-expander . args)
|
|
#:with (method ...)
|
|
(with-syntax ([((m ...) ...)
|
|
(for/list ([m (stx->list
|
|
((interface-expander-proc (attribute macro.value))
|
|
#'(macro . args)))])
|
|
(syntax-parse m
|
|
[m:method-entry #'(m.method ...)]))])
|
|
#'(m ... ...))))
|