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

Allow for changing the name on flat contracts via flat-named-contract.

Browse Source 
svn: r16928
This commit is contained in:
Stevie Strickland 2009-11-20 20:45:45 +00:00
parent f540fc8f00
commit 71eef1bbd8
1 changed files with 10 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
collects/scheme/contract/private/guts.ss
View File

@ -361,10 +361,16 @@
(define (flat-contract predicate) (coerce-flat-contract 'flat-contract predicate))
(define (check-flat-named-contract predicate) (coerce-flat-contract 'flat-named-contract predicate))
(define (flat-named-contract name predicate)
(unless (and (procedure? predicate)
(procedure-arity-includes? predicate 1))
(error 'flat-named-contract "expected a procedure of arity 1 as second argument, got ~e" predicate))
(make-predicate-contract name predicate))
(cond
[(and (procedure? predicate)
(procedure-arity-includes? predicate 1))
(make-predicate-contract name predicate)]
[(flat-contract? predicate)
(make-predicate-contract name (flat-contract-predicate predicate))]
[else
(error 'flat-named-contract
"expected a flat contract or procedure of arity 1 as second argument, got ~e"
predicate)]))
;; build-compound-type-name : (union contract symbol) ... -> (-> sexp)
(define (build-compound-type-name . fs)