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")))
;; 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 ...)
(identifier? (syntax name))
#'(with-contract name
([name contract-expr])
([name (verify-contract contract-expr)])
(define name expr0 expr ...))]
[(_ name+arg-list contract body0 body ...)
(let-values ([(name lam-expr)
@ -141,6 +154,7 @@ improve method arity mismatch contract violation error messages?
[(let ([lst (syntax->list (car args))])
(and (list? lst)
(= (length lst) 2)
(identifier? (first lst))
lst))
=>
(lambda (l)
@ -175,7 +189,7 @@ improve method arity mismatch contract violation error messages?
(begin-with-definitions
body0 body ...
(values unprotected-id ... protected-id ...))))
(define contract-id contract-expr) ...
(define contract-id (verify-contract contract-expr)) ...
(define-syntax protected-id
(make-with-contract-transformer
(quote-syntax contract-id)
@ -766,19 +780,6 @@ improve method arity mismatch contract violation error messages?
(begin
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)
(let-values ([(struct:struct-name _make _pred _get _set)
(make-struct-type struct-name