ccfc18829f
added call to internal-definition-seal in lib added static-of stxclass ported class-iop from macros planet package svn: r13086
74 lines
2.4 KiB
Scheme
74 lines
2.4 KiB
Scheme
#lang scheme/base
|
|
(require (for-template scheme/base
|
|
scheme/class)
|
|
macro-debugger/stxclass/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)
|
|
|
|
(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)))
|
|
|
|
;; 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))
|