104 lines
3.2 KiB
Scheme
104 lines
3.2 KiB
Scheme
#lang scheme/base
|
|
(require (for-template scheme/base
|
|
scheme/class)
|
|
stxclass)
|
|
|
|
(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-of 'static-interface static-interface?)
|
|
#:with value #'x.value))
|
|
|
|
(define-syntax-class checked-binding
|
|
(pattern x
|
|
#:declare x (static-of 'checked-binding checked-binding?)
|
|
#:with value #'x.value))
|
|
|
|
|
|
(define-syntax-class interface-expander
|
|
(pattern x
|
|
#:declare x (static-of 'interface-expander interface-expander?)
|
|
#:with value #'x.value))
|
|
|
|
(define-syntax-class method-entry
|
|
(pattern method:id
|
|
#:with methods (list #'method))
|
|
(pattern (macro:interface-expander . args)
|
|
#:with methods
|
|
(apply append
|
|
(for/list ([m ((interface-expander-proc #'macro.value)
|
|
#'(macro . args))])
|
|
(syntax-parse m
|
|
[m:method-entry #'m.methods])))))
|