avoid lifting more than once
svn: r7364
This commit is contained in:
parent
1654a0f03b
commit
ac52b9f2ba
|
@ -80,70 +80,32 @@ improve method arity mismatch contract violation error messages?
|
||||||
(string->symbol neg-blame-str)
|
(string->symbol neg-blame-str)
|
||||||
(quote-syntax _)))])))))
|
(quote-syntax _)))])))))
|
||||||
|
|
||||||
(define-for-syntax (make-provide/contract-transformer contract-id id pos-module-source)
|
|
||||||
(make-set!-transformer
|
|
||||||
(λ (stx)
|
|
||||||
(with-syntax ([contract-id contract-id]
|
|
||||||
[id id]
|
|
||||||
[pos-module-source pos-module-source])
|
|
||||||
(syntax-case stx (set!)
|
|
||||||
[(set! id body) (raise-syntax-error
|
|
||||||
#f
|
|
||||||
"cannot set! provide/contract identifier"
|
|
||||||
stx
|
|
||||||
(syntax id))]
|
|
||||||
[(name arg ...)
|
|
||||||
(syntax/loc stx
|
|
||||||
((begin-lifted
|
|
||||||
(-contract contract-id
|
|
||||||
id
|
|
||||||
pos-module-source
|
|
||||||
(module-source-as-symbol #'name)
|
|
||||||
(quote-syntax name)))
|
|
||||||
arg
|
|
||||||
...))]
|
|
||||||
[name
|
|
||||||
(identifier? (syntax name))
|
|
||||||
(syntax
|
|
||||||
(begin-lifted
|
|
||||||
(-contract contract-id
|
|
||||||
id
|
|
||||||
pos-module-source
|
|
||||||
(module-source-as-symbol #'name)
|
|
||||||
(quote-syntax name))))])))))
|
|
||||||
|
|
||||||
#;
|
|
||||||
(define-for-syntax (make-provide/contract-transformer contract-id id pos-module-source)
|
(define-for-syntax (make-provide/contract-transformer contract-id id pos-module-source)
|
||||||
(make-set!-transformer
|
(make-set!-transformer
|
||||||
(let ([saved-id-table (make-hash-table)])
|
(let ([saved-id-table (make-hash-table)])
|
||||||
(λ (stx)
|
(λ (stx)
|
||||||
(let ([key (syntax-local-lift-context)])
|
(let ([key (syntax-local-lift-context)])
|
||||||
(unless (hash-table-get saved-id-table key #f)
|
(unless (hash-table-get saved-id-table key #f)
|
||||||
(with-syntax ([contract-id contract-id]
|
(with-syntax ([contract-id contract-id]
|
||||||
[id id]
|
[id id]
|
||||||
[pos-module-source pos-module-source])
|
[name (datum->syntax-object #f (syntax-object->datum id) id)]
|
||||||
(hash-table-put!
|
[pos-module-source pos-module-source])
|
||||||
saved-id-table
|
(hash-table-put!
|
||||||
key
|
saved-id-table
|
||||||
(syntax-local-introduce
|
key
|
||||||
(syntax-local-lift-expression
|
(syntax-local-introduce
|
||||||
#'(-contract contract-id
|
(syntax-local-lift-expression
|
||||||
id
|
#'(-contract contract-id
|
||||||
pos-module-source
|
id
|
||||||
(module-source-as-symbol #'name)
|
pos-module-source
|
||||||
(quote-syntax id)))))))
|
(module-source-as-symbol #'name)
|
||||||
|
(quote-syntax name)))))))
|
||||||
(with-syntax ([saved-id (syntax-local-introduce (hash-table-get saved-id-table key))])
|
(with-syntax ([saved-id (syntax-local-introduce (hash-table-get saved-id-table key))])
|
||||||
(syntax-case stx (set!)
|
(syntax-case stx (set!)
|
||||||
[(set! id body) (raise-syntax-error
|
[(name arg ...) (syntax/loc stx (saved-id arg ...))]
|
||||||
#f
|
[name
|
||||||
"cannot set! provide/contract identifier"
|
(identifier? (syntax name))
|
||||||
stx
|
(syntax saved-id)])))))))
|
||||||
(syntax id))]
|
|
||||||
[(name arg ...) (syntax/loc stx (saved-id arg ...))]
|
|
||||||
[name
|
|
||||||
(identifier? (syntax name))
|
|
||||||
(syntax saved-id)])))))))
|
|
||||||
|
|
||||||
;; (define/contract id contract expr)
|
;; (define/contract id contract expr)
|
||||||
;; defines `id' with `contract'; initially binding
|
;; defines `id' with `contract'; initially binding
|
||||||
|
|
Loading…
Reference in New Issue
Block a user