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

Allow unprotected identifiers to be exported from with-contract, plus

Browse Source 
do some error checking on that list.

svn: r11651
This commit is contained in:
Stevie Strickland 2008-09-11 21:01:14 +00:00
parent 1621335290
commit 430374358e
1 changed files with 44 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -124,34 +124,63 @@ improve method arity mismatch contract violation error messages?
pos-blame-id pos-blame-id
'neg-blame-id 'neg-blame-id
(quote-syntax ident)))]))))) (quote-syntax ident)))])))))
(define-for-syntax (check-and-split-with-contract-args args)
(let loop ([args args]
[unprotected null]
[protected null]
[protections null])
(cond
[(null? args)
(values unprotected protected protections)]
[(identifier? (car args))
(loop (cdr args)
(cons (car args) unprotected)
protected
protections)]
[(let ([lst (syntax->list (car args))])
(and (list? lst)
(= (length lst) 2)
lst))
=>
(lambda (l)
(loop (cdr args)
unprotected
(cons (first l) protected)
(cons (second l) protections)))]
[else
(raise-syntax-error 'with-contract
"expected an identifier or (identifier contract)"
(car args))])))
(define-syntax (with-contract stx) (define-syntax (with-contract stx)
(let ([introducer (make-syntax-introducer)]) (let ([introducer (make-syntax-introducer)])
(syntax-case stx () (syntax-case stx ()
[(_ blame ([name contract-expr] ...) body0 body ...) [(_ blame (arg ...) body0 body ...)
(and (identifier? (syntax blame)) (identifier? (syntax blame))
(andmap identifier? (syntax->list (syntax (name ...))))) (let-values ([(unprotected protected protections)
(with-syntax ([(id ...) (check-and-split-with-contract-args (syntax->list #'(arg ...)))])
(with-syntax ([((protected-id id contract-id) ...)
(map (lambda (n) (map (lambda (n)
(a:mangle-id stx "with-contract-id" n)) (list n
(syntax->list (syntax (name ...))))] (a:mangle-id stx "with-contract-id" n)
[(contract-id ...) (a:mangle-id stx "with-contract-contract-id" n)))
(map (lambda (n) protected)]
(a:mangle-id stx "with-contract-contract-id" n)) [(contract-expr ...) protections]
(syntax->list (syntax (name ...))))]) [(unprotected-id ...) unprotected])
(syntax/loc stx (syntax/loc stx
(begin (begin
(define-values (id ...) (define-values (unprotected-id ... id ...)
(syntax-parameterize ([current-contract-region (quote blame)]) (syntax-parameterize ([current-contract-region (quote blame)])
(begin-with-definitions (begin-with-definitions
body0 body ... body0 body ...
(values name ...)))) (values unprotected-id ... protected-id ...))))
(define contract-id contract-expr) ... (define contract-id contract-expr) ...
(define-syntax name (define-syntax protected-id
(make-with-contract-transformer (make-with-contract-transformer
(quote-syntax contract-id) (quote-syntax contract-id)
(quote-syntax id) (quote-syntax id)
(quote-syntax (quote blame)))) ...)))]))) (quote-syntax (quote blame)))) ...))))])))
; ;
; ;