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

On the plane I tried to avoid verifying the contracts when it's not needed.

Browse Source 
svn: r11783
This commit is contained in:
Stevie Strickland 2008-09-17 02:52:31 +00:00
parent 95d1e96142
commit 41b85b19de
1 changed files with 28 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -89,10 +89,13 @@ improve method arity mismatch contract violation error messages?
define-stx)] define-stx)]
[(_ name contract-expr expr) [(_ name contract-expr expr)
(identifier? #'name) (identifier? #'name)
(syntax/loc define-stx (let ([contract (if (a:known-good-contract? #'contract-expr)
#'contract-expr
#'(verify-contract 'define/contract contract-expr))])
(quasisyntax/loc define-stx
(with-contract #:type definition name (with-contract #:type definition name
([name (verify-contract 'define/contract contract-expr)]) ([name #,contract])
(define name expr)))] (define name expr))))]
[(_ name contract-expr expr0 expr ...) [(_ name contract-expr expr0 expr ...)
(identifier? #'name) (identifier? #'name)
(raise-syntax-error 'define/contract (raise-syntax-error 'define/contract
@ -224,10 +227,22 @@ improve method arity mismatch contract violation error messages?
[(_ #:type type blame (arg ...) body0 body ...) [(_ #:type type blame (arg ...) body0 body ...)
(and (identifier? #'blame) (and (identifier? #'blame)
(identifier? #'type)) (identifier? #'type))
(let-values ([(unprotected protected protections) (let*-values ([(unprotected protected protections)
(check-and-split-with-contract-args (syntax->list #'(arg ...)))] (check-and-split-with-contract-args (syntax->list #'(arg ...)))]
[(expanded-bodies) (head-expand-all (cons #'body0 [(expanded-bodies) (head-expand-all (cons #'body0
(syntax->list #'(body ...))))]) (syntax->list #'(body ...))))]
[(protected-ids ids contracts contract-defs)
(for/lists (protected-ids ids contracts contract-defs)
([n protected]
[c protections])
(let ([new-id (a:mangle-id stx "with-contract-id" n)])
(if (a:known-good-contract? c)
(values n new-id c #f)
(let ([contract-id (a:mangle-id stx "with-contract-contract-id" n)])
(values n new-id contract-id
(quasisyntax/loc stx
(define-values (#,contract-id)
(verify-contract 'with-contract #,c))))))))])
(begin (begin
(let* ([all-ids (append unprotected protected)] (let* ([all-ids (append unprotected protected)]
[dupd-id (check-duplicate-identifier all-ids)]) [dupd-id (check-duplicate-identifier all-ids)])
@ -236,14 +251,10 @@ improve method arity mismatch contract violation error messages?
"identifier appears twice in exports" "identifier appears twice in exports"
dupd-id)) dupd-id))
(check-exports (append unprotected protected) expanded-bodies)) (check-exports (append unprotected protected) expanded-bodies))
(with-syntax ([((protected-id id contract-id) ...) (with-syntax ([((protected-id id contract) ...)
(map (lambda (n) (map list protected-ids ids contracts)]
(list n [(contract-def ...) (filter values contract-defs)]
(a:mangle-id stx "with-contract-id" n)
(a:mangle-id stx "with-contract-contract-id" n)))
protected)]
[blame-str (format "~a ~a" (syntax-e #'type) (syntax-e #'blame))] [blame-str (format "~a ~a" (syntax-e #'type) (syntax-e #'blame))]
[(contract-expr ...) protections]
[(unprotected-id ...) unprotected]) [(unprotected-id ...) unprotected])
(quasisyntax/loc stx (quasisyntax/loc stx
(begin (begin
@ -252,10 +263,10 @@ improve method arity mismatch contract violation error messages?
(begin-with-definitions (begin-with-definitions
#,@expanded-bodies #,@expanded-bodies
(values unprotected-id ... protected-id ...)))) (values unprotected-id ... protected-id ...))))
(define contract-id (verify-contract 'with-contract contract-expr)) ... contract-def ...
(define-syntax protected-id (define-syntax protected-id
(make-with-contract-transformer (make-with-contract-transformer
(quote-syntax contract-id) (quote-syntax contract)
(quote-syntax id) (quote-syntax id)
blame-str)) ...)))))] blame-str)) ...)))))]
[(_ #:type type blame (arg ...) body0 body ...) [(_ #:type type blame (arg ...) body0 body ...)