225 lines
8.2 KiB
Racket
225 lines
8.2 KiB
Racket
#lang racket/base
|
|
;; owner: ryanc
|
|
(require racket/class
|
|
(for-syntax racket/base
|
|
syntax/parse
|
|
racket/syntax
|
|
"private/class-iop-ct.rkt"))
|
|
(provide define-interface
|
|
define-interface/dynamic
|
|
define-interface-expander
|
|
|
|
(rename-out [send: send/i]
|
|
[send*: send*/i]
|
|
[send/apply: send/apply/i]
|
|
|
|
[define: define/i]
|
|
#| lambda: |#
|
|
|
|
[init: init/i]
|
|
[init-field: init-field/i]
|
|
[init-private: init-private/i]))
|
|
|
|
;; Configuration
|
|
(define-for-syntax warn-on-dynamic-interfaces? #f)
|
|
(define-for-syntax warn-on-dynamic-object-check-generation? #f)
|
|
(define-for-syntax define-dotted-names #f)
|
|
|
|
;; define-interface SYNTAX
|
|
;; (define-interface NAME (IDENTIFIER ...))
|
|
;; Defines NAME as an interface.
|
|
(define-syntax (define-interface stx)
|
|
(syntax-parse stx
|
|
[(_ name:id (super:static-interface ...) (m:method-entry ...))
|
|
(with-syntax ([((super-method ...) ...)
|
|
(map static-interface-members (attribute super.value))])
|
|
#'(define-interface/dynamic name
|
|
(let ([name (interface (super ...) m.method ... ...)]) name)
|
|
(super-method ... ... m.method ... ...)))]))
|
|
|
|
;; define-interface/dynamic SYNTAX
|
|
;; (define-interface/dynamic NAME EXPR (IDENTIFIER ...))
|
|
;; Defines NAME as a static interface containing the names listed.
|
|
;; The EXPR is used as the dynamic componenent of the interface, and
|
|
;; it should contain a superset of the names listed.
|
|
(define-syntax (define-interface/dynamic stx)
|
|
(syntax-parse stx
|
|
[(_ name:id dynamic-interface:expr (mname:id ...))
|
|
(with-syntax ([(dynamic-name) (generate-temporaries #'(name))])
|
|
#'(begin (define dynamic-name
|
|
(let ([dynamic-name dynamic-interface])
|
|
(for-each
|
|
(lambda (m)
|
|
(unless (method-in-interface? m dynamic-name)
|
|
(error 'name "dynamic interface missing method '~s'" m)))
|
|
'(mname ...))
|
|
dynamic-name))
|
|
(define-syntax name
|
|
(make-static-interface #'dynamic-name '(mname ...)))))]))
|
|
|
|
(define-syntax (define-interface-expander stx)
|
|
(syntax-parse stx
|
|
[(_ name:id rhs:expr)
|
|
#'(define-syntax name (make-interface-expander rhs))]))
|
|
|
|
;; Helper
|
|
|
|
(begin-for-syntax
|
|
(define (check-method-in-interface for-whom method si)
|
|
(unless (member (syntax-e method) (static-interface-members si))
|
|
(raise-syntax-error (syntax-e for-whom)
|
|
"method not in static interface"
|
|
method))))
|
|
|
|
;; Checked send
|
|
|
|
(define-syntax (send: stx)
|
|
(syntax-parse stx
|
|
[(send: obj:expr iface:static-interface method:id . args)
|
|
(begin (check-method-in-interface #'send: #'method (attribute iface.value))
|
|
(syntax/loc stx
|
|
(send (check-object<:interface send: obj iface)
|
|
method . args)))]))
|
|
|
|
(define-syntax (send*: stx)
|
|
(syntax-parse stx
|
|
[(send*: obj:expr iface:static-interface (method:id . args) ...)
|
|
(begin (for ([method (syntax->list #'(method ...))])
|
|
(check-method-in-interface #'send*: method (attribute iface.value)))
|
|
(syntax/loc stx
|
|
(send* (check-object<:interface send*: obj iface)
|
|
(method . args) ...)))]))
|
|
|
|
(define-syntax (send/apply: stx)
|
|
(syntax-parse stx
|
|
[(send/apply: obj:expr iface:static-interface method:id . args)
|
|
(begin (check-method-in-interface #'send/apply: #'method (attribute iface.value))
|
|
(syntax/loc stx
|
|
(send/apply (check-object<:interface send/apply: obj iface)
|
|
method . args)))]))
|
|
|
|
;;
|
|
|
|
;; check-object<:interface SYNTAX
|
|
(define-syntax (check-object<:interface stx)
|
|
(syntax-parse stx
|
|
[(_ for-whom obj:checked-binding iface:static-interface)
|
|
(if (eq? (checked-binding-iface (attribute obj.value)) (attribute iface.value))
|
|
#'obj
|
|
(syntax/loc stx
|
|
(check-object<:interface for-whom
|
|
(#%expression obj)
|
|
(#%expression iface))))]
|
|
[(_ for-whom obj:expr iface:expr)
|
|
(begin
|
|
(when warn-on-dynamic-object-check-generation?
|
|
(printf "dynamic object check: ~s,~s\n"
|
|
(syntax-source #'obj)
|
|
(syntax-line #'obj)))
|
|
#'(dynamic:check-object<:interface 'for-whom obj iface))]))
|
|
|
|
(define (dynamic:check-object<:interface for-whom obj iface)
|
|
(unless (is-a? obj iface)
|
|
(error for-whom "interface check failed on: ~e" obj))
|
|
obj)
|
|
|
|
;;
|
|
|
|
(define-syntax (define: stx)
|
|
(syntax-parse stx
|
|
[(_ name:id iface:static-interface expr)
|
|
(let ([si (attribute iface.value)])
|
|
(with-syntax ([(name-internal) (generate-temporaries #'(name))]
|
|
[(method ...) (static-interface-members si)]
|
|
[(name.method ...)
|
|
(map (lambda (m)
|
|
(format-id #'name "~a.~a" (syntax-e #'name) m))
|
|
(static-interface-members si))])
|
|
#`(begin (define name-internal
|
|
(check-object<:interface define: expr iface))
|
|
(define-syntax name
|
|
(make-checked-binding
|
|
#'name-internal
|
|
(syntax-local-value #'iface)))
|
|
#,(if define-dotted-names
|
|
#'(begin
|
|
(define-syntax name.method
|
|
(syntax-rules ()
|
|
[(name.method . args)
|
|
(send: name iface method . args)]))
|
|
...)
|
|
#'(begin)))))]
|
|
[(_ (f:id . args) . body)
|
|
#'(define f (lambda: args . body))]))
|
|
|
|
(define-syntax (lambda: stx)
|
|
;; FIXME: rewrite as stxclass
|
|
(define (arg->define stx temp)
|
|
(syntax-case stx ()
|
|
[(arg : iface)
|
|
(and (identifier? #'arg)
|
|
(eq? ': (syntax-e #':)))
|
|
#`(define: arg iface #,temp)]
|
|
[arg
|
|
(identifier? #'arg)
|
|
#`(define-syntax arg (make-rename-transformer #'#,temp))]))
|
|
(syntax-parse stx
|
|
[(_ (arg ...) . body)
|
|
(let ([temporaries (generate-temporaries #'(arg ...))])
|
|
(with-syntax ([(temp ...) temporaries]
|
|
[(checked-definition ...)
|
|
(map arg->define
|
|
(syntax->list #'(arg ...))
|
|
temporaries)])
|
|
#'(lambda (temp ...)
|
|
(let ()
|
|
checked-definition ...
|
|
(let () . body)))))]))
|
|
|
|
|
|
;; FIXME: unsafe due to mutation
|
|
(define-syntax (init-field: stx)
|
|
(syntax-parse stx
|
|
[(_ (name:id iface:static-interface . default) ...)
|
|
#'(begin (init1: init-field name iface . default) ...)]))
|
|
|
|
(define-syntax (init: stx)
|
|
(syntax-parse stx
|
|
[(_ (name:id iface:static-interface . default) ...)
|
|
#'(begin (init1: init name iface . default) ...)]))
|
|
|
|
(define-syntax (init1: stx)
|
|
(syntax-parse stx
|
|
[(_ init name:id iface:static-interface . default)
|
|
(with-syntax ([(name-internal) (generate-temporaries #'(name))])
|
|
#'(begin (init ((name-internal name) . default))
|
|
(void (check-object<:interface init: name-internal iface))
|
|
(define-syntax name
|
|
(make-checked-binding
|
|
#'name-internal
|
|
(syntax-local-value #'iface)))))]))
|
|
|
|
(define-syntax (init-private stx)
|
|
(syntax-parse stx
|
|
[(init-private form ...)
|
|
#'(begin (init-private1 form) ...)]))
|
|
|
|
(define-syntax (init-private1 stx)
|
|
(syntax-parse stx
|
|
[(init-private1 id:id)
|
|
(with-syntax ([(id-internal) (generate-temporaries #'(id))])
|
|
#'(begin (init (id-internal id))
|
|
(define id id-internal)))]))
|
|
|
|
(define-syntax (init-private: stx)
|
|
(syntax-parse stx
|
|
[(_ (name:id iface:static-interface) ...)
|
|
#'(begin (init-private1: name iface) ...)]))
|
|
|
|
(define-syntax (init-private1: stx)
|
|
(syntax-parse stx
|
|
[(_ name:id iface:static-interface)
|
|
(with-syntax ([(id-internal) (generate-temporaries #'(id))])
|
|
#'(begin (init (id-internal name))
|
|
(define: name iface id-internal)))]))
|