moved code out of macro expansion and into functions
svn: r1409
This commit is contained in:
Matthew Flatt
parent
ea3b0c8781
commit
78622b7bb3
|
|
@ -3089,6 +3089,43 @@
|
|||
;;
|
||||
;; mixin
|
||||
;;
|
||||
|
||||
(define (check-mixin-super mixin-name super% from-ids)
|
||||
(let ([mixin-name (or mixin-name 'mixin)])
|
||||
(unless (class? super%)
|
||||
(error mixin-name "argument is not a class: ~e" super%))
|
||||
(for-each (lambda (from-id)
|
||||
(unless (implementation? super% from-id)
|
||||
(error mixin-name "argument does not implement ~e: ~e" from-id super%)))
|
||||
from-ids)))
|
||||
|
||||
(define (check-mixin-from-interfaces all-from)
|
||||
(for-each (lambda (from-id)
|
||||
(unless (interface? from-id)
|
||||
(error 'mixin
|
||||
"expected from-interface, got: ~e; others ~e"
|
||||
from-id
|
||||
all-from)))
|
||||
all-from))
|
||||
|
||||
(define (check-mixin-to-interfaces all-to)
|
||||
(for-each (lambda (to-id)
|
||||
(unless (interface? to-id)
|
||||
(error 'mixin
|
||||
"expected to-interface, got: ~e; others ~e"
|
||||
to-id
|
||||
all-to)))
|
||||
all-to))
|
||||
|
||||
|
||||
(define (check-interface-includes xs from-ids)
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(unless (ormap (lambda (i) (method-in-interface? x i)) from-ids)
|
||||
(error 'mixin
|
||||
"method `~a' was referenced in definition, but is not in any of the from-interfaces: ~e"
|
||||
x from-ids)))
|
||||
xs))
|
||||
|
||||
(define-syntax (mixin stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -3148,43 +3185,17 @@
|
|||
(with-syntax ([mixin-expr
|
||||
(syntax/loc stx
|
||||
(λ (super%)
|
||||
(unless (class? super%)
|
||||
(error mixin-name "argument ~a not a class" super%))
|
||||
(unless (implementation? super% from-ids)
|
||||
(error mixin-name "argument ~s does not implement ~s" super% from-ids))
|
||||
...
|
||||
(check-mixin-super mixin-name super% (list from-ids ...))
|
||||
class-expr))])
|
||||
|
||||
;; Finally, build the complete mixin expression:
|
||||
(syntax/loc stx
|
||||
(let ([from-ids from] ...)
|
||||
(let ([to-ids to] ...)
|
||||
|
||||
(let ([all-from (list from-ids ...)])
|
||||
(void)
|
||||
(unless (interface? from-ids)
|
||||
(error 'mixin
|
||||
"expected interfaces for from, got: ~e, others ~e"
|
||||
from-ids
|
||||
all-from)) ...)
|
||||
|
||||
(let ([all-to (list to-ids ...)])
|
||||
(void)
|
||||
(unless (interface? to-ids)
|
||||
(error 'mixin
|
||||
"expected interfaces for to, got: ~e, others ~e"
|
||||
to-ids
|
||||
all-to)) ...)
|
||||
|
||||
(let ([ensure-interface-has?
|
||||
(λ (x)
|
||||
(unless (or (method-in-interface? x from-ids) ...)
|
||||
(error 'mixin
|
||||
"method `~a' not in any of ~a, but was referenced in definition"
|
||||
x (list from-ids ...))))])
|
||||
(void)
|
||||
(ensure-interface-has? (quote super-vars)) ...)
|
||||
|
||||
(check-mixin-from-interfaces (list from-ids ...))
|
||||
(check-mixin-to-interfaces (list to-ids ...))
|
||||
(check-interface-includes (list (quote super-vars) ...)
|
||||
(list from-ids ...))
|
||||
mixin-expr)))))))]))
|
||||
|
||||
(define externalizable<%>
|
||||
|
|
|
|||
|
|
@ -73,6 +73,69 @@ add struct contracts for immutable structs?
|
|||
; ;
|
||||
;
|
||||
|
||||
|
||||
(define-for-syntax (make-define/contract-transformer contract-id id)
|
||||
(make-set!-transformer
|
||||
(lambda (stx)
|
||||
(with-syntax ([neg-blame-str (or (a:build-src-loc-string stx) "")]
|
||||
[contract-id contract-id]
|
||||
[id id])
|
||||
(syntax-case stx (set!)
|
||||
[(set! _ arg)
|
||||
(raise-syntax-error 'define/contract
|
||||
"cannot set! a define/contract variable"
|
||||
stx
|
||||
(syntax _))]
|
||||
[(_ arg ...)
|
||||
(syntax/loc stx
|
||||
((-contract contract-id
|
||||
id
|
||||
(syntax-object->datum (quote-syntax _))
|
||||
(string->symbol neg-blame-str)
|
||||
(quote-syntax _))
|
||||
arg
|
||||
...))]
|
||||
[_
|
||||
(identifier? (syntax _))
|
||||
(syntax/loc stx
|
||||
(-contract contract-id
|
||||
id
|
||||
(syntax-object->datum (quote-syntax _))
|
||||
(string->symbol neg-blame-str)
|
||||
(quote-syntax _)))])))))
|
||||
|
||||
(define-for-syntax (make-provide/contract-transformer contract-id id pos-module-source)
|
||||
(make-set!-transformer
|
||||
(lambda (stx)
|
||||
(with-syntax ([neg-stx (datum->syntax-object stx 'here)]
|
||||
[contract-id contract-id]
|
||||
[id id]
|
||||
[pos-module-source pos-module-source])
|
||||
(syntax-case stx (set!)
|
||||
[(set! _ body) (raise-syntax-error
|
||||
#f
|
||||
"cannot set! provide/contract identifier"
|
||||
stx
|
||||
(syntax _))]
|
||||
[(_ arg ...)
|
||||
(syntax
|
||||
((begin-lifted
|
||||
(-contract contract-id
|
||||
id
|
||||
pos-module-source
|
||||
(module-source-as-symbol #'neg-stx)
|
||||
(quote-syntax _)))
|
||||
arg
|
||||
...))]
|
||||
[_
|
||||
(identifier? (syntax _))
|
||||
(syntax
|
||||
(begin-lifted
|
||||
(-contract contract-id
|
||||
id
|
||||
pos-module-source
|
||||
(module-source-as-symbol #'neg-stx)
|
||||
(quote-syntax _))))])))))
|
||||
|
||||
;; (define/contract id contract expr)
|
||||
;; defines `id' with `contract'; initially binding
|
||||
|
|
@ -81,8 +144,7 @@ add struct contracts for immutable structs?
|
|||
(syntax-case define-stx ()
|
||||
[(_ name contract-expr expr)
|
||||
(identifier? (syntax name))
|
||||
(with-syntax ([pos-blame-stx (datum->syntax-object define-stx 'here)]
|
||||
[contract-id
|
||||
(with-syntax ([contract-id
|
||||
(a:mangle-id define-stx
|
||||
"define/contract-contract-id"
|
||||
(syntax name))]
|
||||
|
|
@ -93,32 +155,8 @@ add struct contracts for immutable structs?
|
|||
(begin
|
||||
(define contract-id contract-expr)
|
||||
(define-syntax name
|
||||
(make-set!-transformer
|
||||
(lambda (stx)
|
||||
(with-syntax ([neg-blame-str (or (a:build-src-loc-string stx) "")])
|
||||
(syntax-case stx (set!)
|
||||
[(set! _ arg)
|
||||
(raise-syntax-error 'define/contract
|
||||
"cannot set! a define/contract variable"
|
||||
stx
|
||||
(syntax _))]
|
||||
[(_ arg (... ...))
|
||||
(syntax/loc stx
|
||||
((-contract contract-id
|
||||
id
|
||||
(syntax-object->datum (quote-syntax _))
|
||||
(string->symbol neg-blame-str)
|
||||
(quote-syntax _))
|
||||
arg
|
||||
(... ...)))]
|
||||
[_
|
||||
(identifier? (syntax _))
|
||||
(syntax/loc stx
|
||||
(-contract contract-id
|
||||
id
|
||||
(syntax-object->datum (quote-syntax _))
|
||||
(string->symbol neg-blame-str)
|
||||
(quote-syntax _)))])))))
|
||||
(make-define/contract-transformer (quote-syntax contract-id)
|
||||
(quote-syntax id)))
|
||||
(define id (let ([name expr]) name)) ;; let for procedure naming
|
||||
)))]
|
||||
[(_ name contract-expr expr)
|
||||
|
|
@ -556,34 +594,9 @@ add struct contracts for immutable structs?
|
|||
(define pos-module-source (module-source-as-symbol #'pos-stx))
|
||||
(define contract-id (let ([id ctrct]) id))
|
||||
(define-syntax id-rename
|
||||
(make-set!-transformer
|
||||
(lambda (stx)
|
||||
(with-syntax ([neg-stx (datum->syntax-object stx 'here)])
|
||||
(syntax-case stx (set!)
|
||||
[(set! _ body) (raise-syntax-error
|
||||
#f
|
||||
"cannot set! provide/contract identifier"
|
||||
stx
|
||||
(syntax _))]
|
||||
[(_ arg (... ...))
|
||||
(syntax
|
||||
((begin-lifted
|
||||
(-contract contract-id
|
||||
id
|
||||
pos-module-source
|
||||
(module-source-as-symbol #'neg-stx)
|
||||
(quote-syntax _)))
|
||||
arg
|
||||
(... ...)))]
|
||||
[_
|
||||
(identifier? (syntax _))
|
||||
(syntax
|
||||
(begin-lifted
|
||||
(-contract contract-id
|
||||
id
|
||||
pos-module-source
|
||||
(module-source-as-symbol #'neg-stx)
|
||||
(quote-syntax _))))])))))))])
|
||||
(make-provide/contract-transformer (quote-syntax contract-id)
|
||||
(quote-syntax id)
|
||||
(quote-syntax pos-module-source)))))])
|
||||
(syntax (code id-rename)))))
|
||||
|
||||
(with-syntax ([(bodies ...) (code-for-each-clause (syntax->list (syntax (p/c-ele ...))))])
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user