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

Add identifier checking and contract verification where appropriate.

Browse Source 
svn: r11658
This commit is contained in:
Stevie Strickland 2008-09-11 22:43:19 +00:00
parent ab3da5b574
commit 249f3db1b5
1 changed files with 16 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -34,6 +34,19 @@ improve method arity mismatch contract violation error messages?
(for-syntax (prefix-in a: "contract-helpers.ss"))) (for-syntax (prefix-in a: "contract-helpers.ss")))
;; These are useful for all below.
(define-syntax (verify-contract stx)
(syntax-case stx ()
[(_ x) (a:known-good-contract? #'x) #'x]
[(_ x) #'(verify-contract/proc x)]))
(define (verify-contract/proc x)
(unless (or (contract? x)
(and (procedure? x)
(procedure-arity-includes? x 1)))
(error 'provide/contract "expected a contract or a procedure of arity one, got ~e" x))
x)
; ;
; ;
@ -60,7 +73,7 @@ improve method arity mismatch contract violation error messages?
[(_ name contract-expr expr0 expr ...) [(_ name contract-expr expr0 expr ...)
(identifier? (syntax name)) (identifier? (syntax name))
#'(with-contract name #'(with-contract name
([name contract-expr]) ([name (verify-contract contract-expr)])
(define name expr0 expr ...))] (define name expr0 expr ...))]
[(_ name+arg-list contract body0 body ...) [(_ name+arg-list contract body0 body ...)
(let-values ([(name lam-expr) (let-values ([(name lam-expr)
@ -141,6 +154,7 @@ improve method arity mismatch contract violation error messages?
[(let ([lst (syntax->list (car args))]) [(let ([lst (syntax->list (car args))])
(and (list? lst) (and (list? lst)
(= (length lst) 2) (= (length lst) 2)
(identifier? (first lst))
lst)) lst))
=> =>
(lambda (l) (lambda (l)
@ -175,7 +189,7 @@ improve method arity mismatch contract violation error messages?
(begin-with-definitions (begin-with-definitions
body0 body ... body0 body ...
(values unprotected-id ... protected-id ...)))) (values unprotected-id ... protected-id ...))))
(define contract-id contract-expr) ... (define contract-id (verify-contract contract-expr)) ...
(define-syntax protected-id (define-syntax protected-id
(make-with-contract-transformer (make-with-contract-transformer
(quote-syntax contract-id) (quote-syntax contract-id)
@ -766,19 +780,6 @@ improve method arity mismatch contract violation error messages?
(begin (begin
bodies ...))))])) bodies ...))))]))
(define-syntax (verify-contract stx)
(syntax-case stx ()
[(_ x) (a:known-good-contract? #'x) #'x]
[(_ x) #'(verify-contract/proc x)]))
(define (verify-contract/proc x)
(unless (or (contract? x)
(and (procedure? x)
(procedure-arity-includes? x 1)))
(error 'provide/contract "expected a contract or a procedure of arity one, got ~e" x))
x)
(define (make-pc-struct-type struct-name struct:struct-name . ctcs) (define (make-pc-struct-type struct-name struct:struct-name . ctcs)
(let-values ([(struct:struct-name _make _pred _get _set) (let-values ([(struct:struct-name _make _pred _get _set)
(make-struct-type struct-name (make-struct-type struct-name