This is a change I was toying with that shouldn't have gotten caught up in
the trunk sync of 13084. svn: r13088
This commit is contained in:
Stevie Strickland
parent
2537508865
commit
51da9beab4
|
|
@ -51,48 +51,7 @@ improve method arity mismatch contract violation error messages?
|
||||||
#,(syntax-span id))
|
#,(syntax-span id))
|
||||||
#,(format "~s" (syntax->datum id))))
|
#,(format "~s" (syntax->datum id))))
|
||||||
|
|
||||||
(define-for-syntax (make-contracted-transformer contract-id id pos-module-source)
|
|
||||||
(make-set!-transformer
|
|
||||||
(let ([saved-id-table (make-hasheq)])
|
|
||||||
(λ (stx)
|
|
||||||
(if (eq? 'expression (syntax-local-context))
|
|
||||||
;; In an expression context:
|
|
||||||
(let ([key (syntax-local-lift-context)])
|
|
||||||
;; Already lifted in this lifting context?
|
|
||||||
(let ([lifted-id
|
|
||||||
(or (hash-ref saved-id-table key #f)
|
|
||||||
;; No: lift the contract creation:
|
|
||||||
(with-syntax ([contract-id contract-id]
|
|
||||||
[id id]
|
|
||||||
[neg-blame-id (or (syntax-parameter-value #'current-contract-region)
|
|
||||||
#'(#%variable-reference))]
|
|
||||||
[pos-module-source pos-module-source])
|
|
||||||
(syntax-local-introduce
|
|
||||||
(syntax-local-lift-expression
|
|
||||||
#`(-contract contract-id
|
|
||||||
id
|
|
||||||
pos-module-source
|
|
||||||
neg-blame-id
|
|
||||||
#,(id->contract-src-info #'id))))))])
|
|
||||||
(when key
|
|
||||||
(hash-set! saved-id-table key lifted-id))
|
|
||||||
;; Expand to a use of the lifted expression:
|
|
||||||
(with-syntax ([saved-id (syntax-local-introduce lifted-id)])
|
|
||||||
(syntax-case stx (set!)
|
|
||||||
[name
|
|
||||||
(identifier? (syntax name))
|
|
||||||
(syntax saved-id)]
|
|
||||||
[(set! id arg)
|
|
||||||
(raise-syntax-error 'provide/contract
|
|
||||||
"cannot set! a contracted variable"
|
|
||||||
stx
|
|
||||||
(syntax id))]
|
|
||||||
[(name . more)
|
|
||||||
(with-syntax ([app (datum->syntax stx '#%app)])
|
|
||||||
(syntax/loc stx (app saved-id . more)))]))))
|
|
||||||
;; In case of partial expansion for module-level and internal-defn contexts,
|
|
||||||
;; delay expansion until it's a good time to lift expressions:
|
|
||||||
(quasisyntax/loc stx (#%expression #,stx)))))))
|
|
||||||
|
|
||||||
;
|
;
|
||||||
;
|
;
|
||||||
|
|
@ -177,6 +136,37 @@ improve method arity mismatch contract violation error messages?
|
||||||
|
|
||||||
(define-syntax-parameter current-contract-region #f)
|
(define-syntax-parameter current-contract-region #f)
|
||||||
|
|
||||||
|
(define-for-syntax (make-with-contract-transformer contract-id id pos-blame-id)
|
||||||
|
(make-set!-transformer
|
||||||
|
(lambda (stx)
|
||||||
|
(with-syntax ([neg-blame-id (or (syntax-parameter-value #'current-contract-region)
|
||||||
|
#'(#%variable-reference))]
|
||||||
|
[pos-blame-id pos-blame-id]
|
||||||
|
[contract-id contract-id]
|
||||||
|
[id id])
|
||||||
|
(syntax-case stx (set!)
|
||||||
|
[(set! id arg)
|
||||||
|
(raise-syntax-error 'with-contract
|
||||||
|
"cannot set! a with-contract variable"
|
||||||
|
stx
|
||||||
|
(syntax id))]
|
||||||
|
[(f arg ...)
|
||||||
|
(syntax/loc stx
|
||||||
|
((-contract contract-id
|
||||||
|
id
|
||||||
|
pos-blame-id
|
||||||
|
neg-blame-id
|
||||||
|
#'f)
|
||||||
|
arg ...))]
|
||||||
|
[ident
|
||||||
|
(identifier? (syntax ident))
|
||||||
|
(syntax/loc stx
|
||||||
|
(-contract contract-id
|
||||||
|
id
|
||||||
|
pos-blame-id
|
||||||
|
neg-blame-id
|
||||||
|
#'ident))])))))
|
||||||
|
|
||||||
(define-for-syntax (head-expand-all body-stxs)
|
(define-for-syntax (head-expand-all body-stxs)
|
||||||
(for/list ([stx body-stxs])
|
(for/list ([stx body-stxs])
|
||||||
(local-expand stx
|
(local-expand stx
|
||||||
|
|
@ -275,7 +265,7 @@ improve method arity mismatch contract violation error messages?
|
||||||
(values unprotected-id ... protected-id ...))))
|
(values unprotected-id ... protected-id ...))))
|
||||||
contract-def ...
|
contract-def ...
|
||||||
(define-syntax protected-id
|
(define-syntax protected-id
|
||||||
(make-contracted-transformer
|
(make-with-contract-transformer
|
||||||
(quote-syntax contract)
|
(quote-syntax contract)
|
||||||
(quote-syntax id)
|
(quote-syntax id)
|
||||||
blame-str)) ...)))))]
|
blame-str)) ...)))))]
|
||||||
|
|
@ -342,6 +332,48 @@ improve method arity mismatch contract violation error messages?
|
||||||
provide-stx
|
provide-stx
|
||||||
id)))))
|
id)))))
|
||||||
|
|
||||||
|
(define-for-syntax (make-provide/contract-transformer contract-id id pos-module-source)
|
||||||
|
(make-set!-transformer
|
||||||
|
(let ([saved-id-table (make-hasheq)])
|
||||||
|
(λ (stx)
|
||||||
|
(if (eq? 'expression (syntax-local-context))
|
||||||
|
;; In an expression context:
|
||||||
|
(let ([key (syntax-local-lift-context)])
|
||||||
|
;; Already lifted in this lifting context?
|
||||||
|
(let ([lifted-id
|
||||||
|
(or (hash-ref saved-id-table key #f)
|
||||||
|
;; No: lift the contract creation:
|
||||||
|
(with-syntax ([contract-id contract-id]
|
||||||
|
[id id]
|
||||||
|
[pos-module-source pos-module-source])
|
||||||
|
(syntax-local-introduce
|
||||||
|
(syntax-local-lift-expression
|
||||||
|
#`(-contract contract-id
|
||||||
|
id
|
||||||
|
pos-module-source
|
||||||
|
(#%variable-reference)
|
||||||
|
#,(id->contract-src-info #'id))))))])
|
||||||
|
(when key
|
||||||
|
(hash-set! saved-id-table key lifted-id))
|
||||||
|
;; Expand to a use of the lifted expression:
|
||||||
|
(with-syntax ([saved-id (syntax-local-introduce lifted-id)])
|
||||||
|
(syntax-case stx (set!)
|
||||||
|
[name
|
||||||
|
(identifier? (syntax name))
|
||||||
|
(syntax saved-id)]
|
||||||
|
[(set! id arg)
|
||||||
|
(raise-syntax-error 'provide/contract
|
||||||
|
"cannot set! a provide/contract variable"
|
||||||
|
stx
|
||||||
|
(syntax id))]
|
||||||
|
[(name . more)
|
||||||
|
(with-syntax ([app (datum->syntax stx '#%app)])
|
||||||
|
(syntax/loc stx (app saved-id . more)))]))))
|
||||||
|
;; In case of partial expansion for module-level and internal-defn contexts,
|
||||||
|
;; delay expansion until it's a good time to lift expressions:
|
||||||
|
(quasisyntax/loc stx (#%expression #,stx)))))))
|
||||||
|
|
||||||
|
|
||||||
;; (provide/contract p/c-ele ...)
|
;; (provide/contract p/c-ele ...)
|
||||||
;; p/c-ele = (id expr) | (rename id id expr) | (struct id (id expr) ...)
|
;; p/c-ele = (id expr) | (rename id id expr) | (struct id (id expr) ...)
|
||||||
;; provides each `id' with the contract `expr'.
|
;; provides each `id' with the contract `expr'.
|
||||||
|
|
@ -829,7 +861,7 @@ improve method arity mismatch contract violation error messages?
|
||||||
(list)
|
(list)
|
||||||
(list #'(define contract-id (verify-contract 'provide/contract ctrct))))
|
(list #'(define contract-id (verify-contract 'provide/contract ctrct))))
|
||||||
(define-syntax id-rename
|
(define-syntax id-rename
|
||||||
(make-contracted-transformer (quote-syntax contract-id)
|
(make-provide/contract-transformer (quote-syntax contract-id)
|
||||||
(quote-syntax id)
|
(quote-syntax id)
|
||||||
(quote-syntax pos-module-source)))
|
(quote-syntax pos-module-source)))
|
||||||
|
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user