suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

This is a change I was toying with that shouldn't have gotten caught up in

Browse Source 
the trunk sync of 13084.

svn: r13088
This commit is contained in:
Stevie Strickland 2009-01-13 19:01:21 +00:00
parent 2537508865
commit 51da9beab4
1 changed files with 78 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

124
collects/scheme/private/contract.ss
View File

@ -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,9 +861,9 @@ 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)))
(provide (rename-out [id-rename external-name]))))]) (provide (rename-out [id-rename external-name]))))])