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

..

Browse Source 
original commit: 78671f5cc1d716230985f9a3bd6868c91331c57d
This commit is contained in:
Robby Findler 2003-08-10 23:36:54 +00:00
parent 9c771e9c73
commit 5a2b33f8fb
1 changed files with 317 additions and 166 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

325
collects/mzlib/contract.ss
View File

@ -8,16 +8,18 @@
case-> case->
opt-> opt->
opt->* opt->*
class-contract ;class-contract
class-contract/prim ;class-contract/prim
;object-contract ;; not yet good enough ;object-contract ;; not yet good enough
provide/contract provide/contract
define/contract define/contract
contract? contract?
flat-named-contract flat-contract?
flat-named-contract-type-name
flat-contract flat-contract
flat-contract-predicate) flat-contract-predicate
flat-named-contract?
flat-named-contract
flat-named-contract-type-name)
(require-for-syntax mzscheme (require-for-syntax mzscheme
"list.ss" "list.ss"
@ -31,6 +33,39 @@
(require (lib "contract-helpers.scm" "mzlib" "private")) (require (lib "contract-helpers.scm" "mzlib" "private"))
(require-for-syntax (prefix a: (lib "contract-helpers.scm" "mzlib" "private"))) (require-for-syntax (prefix a: (lib "contract-helpers.scm" "mzlib" "private")))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; deprecated
;;
(define-syntax (deprecated stx)
(syntax-case stx ()
[(_ old new)
(syntax
(define-syntax (old stx)
(syntax-case stx ()
[(_ args (... ...))
(fprintf
(current-error-port)
"WARNING: ~a is deprecated, use ~a instead ~a:~a.~a\n"
'old
'new
(syntax-source stx)
(syntax-line stx)
(syntax-column stx))
(syntax (new args (... ...)))])))]))
(provide or/f and/f flat-named-contract-predicate)
(deprecated or/f union)
(deprecated and/f and/c)
(deprecated flat-named-contract-predicate flat-contract-predicate)
;;
;; end deprecated
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; ;
; ;
@ -435,10 +470,9 @@
make-contract make-contract
contract?))) contract?)))
;; flat-named-contract = (flat-named-contract string (any -> boolean)) ;; flat-contract = (make-flat-contract contract (any -> boolean))
;; this holds flat contracts that have names for error reporting ;; this holds flat contracts that have names for error reporting
(define-values (struct:flat-contract flat-contract flat-contract? flat-contract-predicate) (define-values (struct:flat-contract
(let-values ([(struct:flat-contract
make-flat-contract make-flat-contract
flat-contract? flat-contract?
flat-contract-ref flat-contract-ref
@ -450,7 +484,7 @@
#f ;; auto-v #f ;; auto-v
null ;; prop-value-list null ;; prop-value-list
#f ;; inspector #f ;; inspector
#f)]) ;; proc-spec #f)) ;; proc-spec
(define (flat-contract predicate) (define (flat-contract predicate)
(unless (and (procedure? predicate) (unless (and (procedure? predicate)
@ -479,11 +513,6 @@
(error 'flat-contract-predicate "expected argument of type <flat-contract>, got: ~e" s)) (error 'flat-contract-predicate "expected argument of type <flat-contract>, got: ~e" s))
(flat-contract-ref s 0)) (flat-contract-ref s 0))
(values struct:flat-contract
flat-contract
flat-contract?
flat-contract-predicate)))
(define-values (struct:flat-named-contract flat-named-contract flat-named-contract? flat-named-contract-type-name) (define-values (struct:flat-named-contract flat-named-contract flat-named-contract? flat-named-contract-type-name)
(let-values ([(struct:flat-named-contract (let-values ([(struct:flat-named-contract
make-flat-named-contract make-flat-named-contract
@ -686,12 +715,12 @@
(set-inferred-name-from (set-inferred-name-from
stx stx
(syntax/loc stx (lambda val-args body)))]) (syntax/loc stx (lambda val-args body)))])
(with-syntax ([inner-lambda-w/err-check (let ([inner-lambda-w/err-check
(syntax (syntax
(lambda (val) (lambda (val)
inner-check inner-check
inner-lambda))]) inner-lambda))])
(with-syntax ([proj-code (build-proj outer-args (syntax inner-lambda-w/err-check))]) (with-syntax ([proj-code (build-proj outer-args inner-lambda-w/err-check)])
(arguments-check (arguments-check
(set-inferred-name-from (set-inferred-name-from
stx stx
@ -705,22 +734,27 @@
(define (case->/proc stx) (define (case->/proc stx)
(syntax-case stx () (syntax-case stx ()
[(_ cases ...) [(_ cases ...)
(let-values ([(add-outer-check make-inner-check make-bodies) (let-values ([(arguments-check build-projs check-val wrapper)
(case->/h stx (syntax->list (syntax (cases ...))))]) (case->/h stx (syntax->list (syntax (cases ...))))])
(let ([outer-args (syntax (val pos-blame neg-blame src-info))]) (let ([outer-args (syntax (val pos-blame neg-blame src-info))])
(with-syntax ([outer-args outer-args] (with-syntax ([(inner-check ...) (check-val outer-args)]
[(inner-check ...) (make-inner-check outer-args)] [(val pos-blame neg-blame src-info) outer-args]
[(body ...) (make-bodies outer-args)]) [(body ...) (wrapper outer-args)])
(with-syntax ([inner-lambda (with-syntax ([inner-lambda
(set-inferred-name-from (set-inferred-name-from
stx stx
(syntax/loc stx (case-lambda body ...)))]) (syntax/loc stx (case-lambda body ...)))])
(add-outer-check (let ([inner-lambda-w/err-check
(syntax
(lambda (val)
inner-check ...
inner-lambda))])
(with-syntax ([proj-code (build-projs outer-args inner-lambda-w/err-check)])
(arguments-check
(syntax/loc stx (syntax/loc stx
(make-contract (make-contract
(lambda outer-args (lambda (pos-blame neg-blame src-info)
inner-check ... proj-code))))))))))]))
inner-lambda))))))))]))
;; exactract-argument-lists : syntax -> (listof syntax) ;; exactract-argument-lists : syntax -> (listof syntax)
(define (extract-argument-lists stx) (define (extract-argument-lists stx)
@ -739,9 +773,13 @@
[(number? this-case) [(number? this-case)
(cond (cond
[(member this-case individual-cases) [(member this-case individual-cases)
(raise-syntax-error 'case-> (format "found multiple cases with ~a arguments" this-case) stx)] (raise-syntax-error
'case->
(format "found multiple cases with ~a arguments" this-case)
stx)]
[(and dot-min (dot-min . <= . this-case)) [(and dot-min (dot-min . <= . this-case))
(raise-syntax-error 'case-> (raise-syntax-error
'case->
(format "found overlapping cases (~a+ followed by ~a)" dot-min this-case) (format "found overlapping cases (~a+ followed by ~a)" dot-min this-case)
stx)] stx)]
[else (set! individual-cases (cons this-case individual-cases))])] [else (set! individual-cases (cons this-case individual-cases))])]
@ -750,7 +788,8 @@
(cond (cond
[dot-min [dot-min
(if (dot-min . <= . new-dot-min) (if (dot-min . <= . new-dot-min)
(raise-syntax-error 'case-> (raise-syntax-error
'case->
(format "found overlapping cases (~a+ followed by ~a+)" dot-min new-dot-min) (format "found overlapping cases (~a+ followed by ~a+)" dot-min new-dot-min)
stx) stx)
(set! dot-min new-dot-min))] (set! dot-min new-dot-min))]
@ -771,28 +810,41 @@
'more)))) 'more))))
;; case->/h : syntax (listof syntax) -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax) (syntax -> syntax) syntax syntax) ;; case->/h : syntax (listof syntax)
;; -> (values (syntax -> syntax)
;; (syntax -> syntax)
;; (syntax syntax -> syntax)
;; (syntax -> syntax))
;; like the other /h functions, but composes the wrapper functions ;; like the other /h functions, but composes the wrapper functions
;; together and combines the cases of the case-lambda into a single list. ;; together and combines the cases of the case-lambda into a single list.
(define (case->/h orig-stx cases) (define (case->/h orig-stx cases)
(let loop ([cases cases]) (let loop ([cases cases])
(cond (cond
[(null? cases) (values (lambda (x) x) [(null? cases) (values (lambda (x) x)
(lambda (x y) y)
(lambda (args) (syntax ())) (lambda (args) (syntax ()))
(lambda (args) (syntax ())))] (lambda (args) (syntax ())))]
[else [else
(let ([/h (select/h (car cases) 'case-> orig-stx)]) (let ([/h (select/h (car cases) 'case-> orig-stx)])
(let-values ([(add-outer-checks make-inner-checks make-bodies) (loop (cdr cases))] (let-values ([(arguments-checks build-projs check-vals wrappers)
[(add-outer-check make-inner-check make-body) (/h (car cases))]) (loop (cdr cases))]
[(arguments-check build-proj check-val wrapper)
(/h (car cases))])
(values (values
(lambda (x) (add-outer-check (add-outer-checks x))) (lambda (x) (arguments-check (arguments-checks x)))
(lambda (args inner)
(build-projs
args
(build-proj
args
inner)))
(lambda (args) (lambda (args)
(with-syntax ([checks (make-inner-checks args)] (with-syntax ([checks (check-vals args)]
[check (make-inner-check args)]) [check (check-val args)])
(syntax (check . checks)))) (syntax (check . checks))))
(lambda (args) (lambda (args)
(with-syntax ([case (make-body args)] (with-syntax ([case (wrapper args)]
[cases (make-bodies args)]) [cases (wrappers args)])
(syntax (case . cases)))))))]))) (syntax (case . cases)))))))])))
(define (class-contract/proc stx) (class-contract-mo? stx #f)) (define (class-contract/proc stx) (class-contract-mo? stx #f))
@ -1098,24 +1150,19 @@
(let ([dom-x (coerce-contract -> dom)] ... (let ([dom-x (coerce-contract -> dom)] ...
[rng-x (coerce-contract -> rng)] ...) [rng-x (coerce-contract -> rng)] ...)
body))))] body))))]
[->body (syntax (->* (dom-x ...) (rng-x ...)))]) [->body (if ignore-range-checking?
(syntax (->* (dom-x ...) any))
(syntax (->* (dom-x ...) (rng-x ...))))])
(let-values ([(->*add-outer-check (let-values ([(->*add-outer-check
->*make-projections
->*make-inner-check ->*make-inner-check
->*make-body) ->*make-body)
(->*/h ->body)]) (->*/h ->body)])
(values (values
(lambda (body) (->add-outer-check (->*add-outer-check body))) (lambda (body) (->add-outer-check (->*add-outer-check body)))
->*make-projections
(lambda (stx) (->*make-inner-check stx)) (lambda (stx) (->*make-inner-check stx))
(if ignore-range-checking? ->*make-body))))))]))
(lambda (stx)
(with-syntax ([(val pos-blame neg-blame src-info) stx])
(syntax
((arg-x ...)
(val
(dom-x arg-x neg-blame pos-blame src-info)
...)))))
(lambda (stx)
(->*make-body stx)))))))))]))
;; ->*/h : stx -> (values (syntax -> syntax) (syntax syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) ;; ->*/h : stx -> (values (syntax -> syntax) (syntax syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
(define (->*/h stx) (define (->*/h stx)
@ -1169,15 +1216,56 @@
(values (rng-projection-x (values (rng-projection-x
res-x) res-x)
...))))))))] ...))))))))]
[(_ (dom ...) any)
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
[(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))]
[(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))]
[(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))]
[(arg-x ...) (generate-temporaries (syntax (dom ...)))])
(values
(lambda (body)
(with-syntax ([body body])
(syntax
(let ([dom-x (coerce-contract ->* dom)] ...)
body))))
(lambda (outer-args inner-lambda)
(with-syntax ([(val pos-blame neg-blame src-info) outer-args]
[inner-lambda inner-lambda])
(syntax
(let ([dom-projection-x (dom-x neg-blame pos-blame src-info)] ...)
inner-lambda))))
(lambda (outer-args)
(with-syntax ([(val pos-blame neg-blame src-info) outer-args])
(syntax
(unless (and (procedure? val)
(procedure-arity-includes? val dom-length))
(raise-contract-error
src-info
pos-blame
neg-blame
"expected a procedure that accepts ~a arguments, given: ~e"
dom-length
val)))))
(lambda (outer-args)
(with-syntax ([(val pos-blame neg-blame src-info) outer-args])
(syntax
((arg-x ...)
(val (dom-projection-x arg-x) ...)))))))]
[(_ (dom ...) rest (rng ...)) [(_ (dom ...) rest (rng ...))
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
[(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))]
[(arg-x ...) (generate-temporaries (syntax (dom ...)))] [(arg-x ...) (generate-temporaries (syntax (dom ...)))]
[(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))] [(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))]
[(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))] [(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))]
[dom-rest-x (car (generate-temporaries (list (syntax rest))))] [dom-rest-x (car (generate-temporaries (list (syntax rest))))]
[dom-rest-projection-x (car (generate-temporaries (list (syntax rest))))]
[arg-rest-x (car (generate-temporaries (list (syntax rest))))] [arg-rest-x (car (generate-temporaries (list (syntax rest))))]
[(rng-x ...) (generate-temporaries (syntax (rng ...)))] [(rng-x ...) (generate-temporaries (syntax (rng ...)))]
[(rng-projection-x ...) (generate-temporaries (syntax (rng ...)))]
[(rng-length rng-index ...) (generate-indicies (syntax (rng ...)))] [(rng-length rng-index ...) (generate-indicies (syntax (rng ...)))]
[(rng-ant-x ...) (generate-temporaries (syntax (rng ...)))] [(rng-ant-x ...) (generate-temporaries (syntax (rng ...)))]
[(res-x ...) (generate-temporaries (syntax (rng ...)))] [(res-x ...) (generate-temporaries (syntax (rng ...)))]
@ -1190,6 +1278,14 @@
[dom-rest-x (coerce-contract ->* rest)] [dom-rest-x (coerce-contract ->* rest)]
[rng-x (coerce-contract ->* rng)] ...) [rng-x (coerce-contract ->* rng)] ...)
body)))) body))))
(lambda (outer-args inner-lambda)
(with-syntax ([(val pos-blame neg-blame src-info) outer-args]
[inner-lambda inner-lambda])
(syntax
(let ([dom-projection-x (dom-x neg-blame pos-blame src-info)] ...
[dom-rest-projection-x (dom-rest-x neg-blame pos-blame src-info)]
[rng-projection-x (rng-x pos-blame neg-blame src-info)] ...)
inner-lambda))))
(lambda (stx) (lambda (stx)
(with-syntax ([(val check-rev-contract check-same-contract failure) stx]) (with-syntax ([(val check-rev-contract check-same-contract failure) stx])
(syntax (syntax
@ -1208,21 +1304,18 @@
(let-values ([(res-x ...) (let-values ([(res-x ...)
(apply (apply
val val
(dom-x arg-x neg-blame pos-blame src-info) (dom-projection-x arg-x)
... ...
(dom-rest-x arg-rest-x neg-blame pos-blame src-info))]) (dom-rest-projection-x arg-rest-x))])
(values (rng-x (values (rng-projection-x res-x) ...))))))))]
res-x
pos-blame
neg-blame
src-info)
...))))))))]
[(_ (dom ...) rest any) [(_ (dom ...) rest any)
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
[(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))]
[(arg-x ...) (generate-temporaries (syntax (dom ...)))] [(arg-x ...) (generate-temporaries (syntax (dom ...)))]
[(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))] [(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))]
[(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))] [(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))]
[dom-rest-x (car (generate-temporaries (list (syntax rest))))] [dom-rest-x (car (generate-temporaries (list (syntax rest))))]
[dom-projection-rest-x (car (generate-temporaries (list (syntax rest))))]
[arg-rest-x (car (generate-temporaries (list (syntax rest))))] [arg-rest-x (car (generate-temporaries (list (syntax rest))))]
[arity (length (syntax->list (syntax (dom ...))))]) [arity (length (syntax->list (syntax (dom ...))))])
@ -1233,6 +1326,13 @@
(let ([dom-x (coerce-contract ->* dom)] ... (let ([dom-x (coerce-contract ->* dom)] ...
[dom-rest-x (coerce-contract ->* rest)]) [dom-rest-x (coerce-contract ->* rest)])
body)))) body))))
(lambda (outer-args inner-lambda)
(with-syntax ([(val pos-blame neg-blame src-info) outer-args]
[inner-lambda inner-lambda])
(syntax
(let ([dom-projection-x (dom-x neg-blame pos-blame src-info)] ...
[dom-projection-rest-x (dom-rest-x neg-blame pos-blame src-info)])
inner-lambda))))
(lambda (stx) (lambda (stx)
(with-syntax ([(val check-rev-contract check-same-contract failure) stx]) (with-syntax ([(val check-rev-contract check-same-contract failure) stx])
(syntax (syntax
@ -1250,9 +1350,9 @@
((arg-x ... . arg-rest-x) ((arg-x ... . arg-rest-x)
(apply (apply
val val
(dom-x arg-x neg-blame pos-blame src-info) (dom-projection-x arg-x)
... ...
(dom-rest-x arg-rest-x neg-blame pos-blame src-info))))))))])) (dom-projection-rest-x arg-rest-x))))))))]))
;; ->d/h : stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) ;; ->d/h : stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
(define (->d/h stx) (define (->d/h stx)
@ -1262,6 +1362,7 @@
(with-syntax ([(dom ...) (all-but-last (syntax->list (syntax (ct ...))))] (with-syntax ([(dom ...) (all-but-last (syntax->list (syntax (ct ...))))]
[rng (car (last-pair (syntax->list (syntax (ct ...)))))]) [rng (car (last-pair (syntax->list (syntax (ct ...)))))])
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
[(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))]
[(arg-x ...) (generate-temporaries (syntax (dom ...)))] [(arg-x ...) (generate-temporaries (syntax (dom ...)))]
[arity (length (syntax->list (syntax (dom ...))))]) [arity (length (syntax->list (syntax (dom ...))))])
(values (values
@ -1276,6 +1377,12 @@
arity arity
rng-x)) rng-x))
body)))) body))))
(lambda (outer-args inner-lambda)
(with-syntax ([(val pos-blame neg-blame src-info) outer-args]
[inner-lambda inner-lambda])
(syntax
(let ([dom-projection-x (dom-x neg-blame pos-blame src-info)] ...)
inner-lambda))))
(lambda (stx) (lambda (stx)
(with-syntax ([(val pos-blame neg-blame src-info) stx]) (with-syntax ([(val pos-blame neg-blame src-info) stx])
(syntax (syntax
@ -1293,17 +1400,18 @@
(syntax (syntax
((arg-x ...) ((arg-x ...)
(let ([rng-contract (rng-x arg-x ...)]) (let ([rng-contract (rng-x arg-x ...)])
((coerce-contract ->d rng-contract) (((coerce-contract ->d rng-contract)
(val (dom-x arg-x neg-blame pos-blame src-info) ...)
pos-blame pos-blame
neg-blame neg-blame
src-info)))))))))])) src-info)
(val (dom-projection-x arg-x) ...))))))))))]))
;; ->d*/h : stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) ;; ->d*/h : stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
(define (->d*/h stx) (define (->d*/h stx)
(syntax-case stx () (syntax-case stx ()
[(_ (dom ...) rng-mk) [(_ (dom ...) rng-mk)
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
[(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))]
[(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))] [(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))]
[(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))] [(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))]
[(arg-x ...) (generate-temporaries (syntax (dom ...)))]) [(arg-x ...) (generate-temporaries (syntax (dom ...)))])
@ -1318,6 +1426,12 @@
(error '->d* "expected range position to be a procedure that accepts ~a arguments, given: ~e" (error '->d* "expected range position to be a procedure that accepts ~a arguments, given: ~e"
dom-length rng-mk-x)) dom-length rng-mk-x))
body)))) body))))
(lambda (outer-args inner-lambda)
(with-syntax ([(val pos-blame neg-blame src-info) outer-args]
[inner-lambda inner-lambda])
(syntax
(let ([dom-projection-x (dom-x neg-blame pos-blame src-info)] ...)
inner-lambda))))
(lambda (stx) (lambda (stx)
(with-syntax ([(val pos-blame neg-blame src-info) stx]) (with-syntax ([(val pos-blame neg-blame src-info) stx])
(syntax (syntax
@ -1339,8 +1453,7 @@
(lambda rng-contracts (lambda rng-contracts
(call-with-values (call-with-values
(lambda () (lambda ()
(val (val (dom-projection-x arg-x) ...))
(dom-x arg-x neg-blame pos-blame src-info) ...))
(lambda results (lambda results
(unless (= (length results) (length rng-contracts)) (unless (= (length results) (length rng-contracts))
(error '->d* (error '->d*
@ -1349,15 +1462,18 @@
(apply (apply
values values
(map (lambda (rng-contract result) (map (lambda (rng-contract result)
((coerce-contract ->d* rng-contract) (((coerce-contract ->d* rng-contract)
result
pos-blame pos-blame
neg-blame neg-blame
src-info)) src-info)
result))
rng-contracts rng-contracts
results))))))))))))] results))))))))))))]
[(_ (dom ...) rest rng-mk) [(_ (dom ...) rest rng-mk)
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
[(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))]
[(dom-rest-x) (generate-temporaries (syntax (rest)))]
[(dom-rest-projection-x) (generate-temporaries (syntax (rest)))]
[(arg-x ...) (generate-temporaries (syntax (dom ...)))] [(arg-x ...) (generate-temporaries (syntax (dom ...)))]
[arity (length (syntax->list (syntax (dom ...))))]) [arity (length (syntax->list (syntax (dom ...))))])
(values (values
@ -1371,6 +1487,13 @@
(error '->d* "expected range position to be a procedure that accepts ~a arguments, given: ~e" (error '->d* "expected range position to be a procedure that accepts ~a arguments, given: ~e"
arity rng-mk-x)) arity rng-mk-x))
body)))) body))))
(lambda (outer-args inner-lambda)
(with-syntax ([(val pos-blame neg-blame src-info) outer-args]
[inner-lambda inner-lambda])
(syntax
(let ([dom-projection-x (dom-x neg-blame pos-blame src-info)] ...
[dom-rest-projection-x (dom-rest-x neg-blame pos-blame src-info)])
inner-lambda))))
(lambda (stx) (lambda (stx)
(with-syntax ([(val pos-blame neg-blame src-info) stx]) (with-syntax ([(val pos-blame neg-blame src-info) stx])
(syntax (syntax
@ -1394,9 +1517,9 @@
(lambda () (lambda ()
(apply (apply
val val
(dom-x arg-x neg-blame pos-blame src-info) (dom-projection-x arg-x)
... ...
(dom-rest-x rest-arg-x neg-blame pos-blame src-info))) (dom-rest-projection-x rest-arg-x)))
(lambda results (lambda results
(unless (= (length results) (length rng-contracts)) (unless (= (length results) (length rng-contracts))
(error '->d* (error '->d*
@ -1405,11 +1528,11 @@
(apply (apply
values values
(map (lambda (rng-contract result) (map (lambda (rng-contract result)
((coerce-contract ->d* rng-contract) (((coerce-contract ->d* rng-contract)
result
pos-blame pos-blame
neg-blame neg-blame
src-info )) src-info)
result))
rng-contracts rng-contracts
results))))))))))))])) results))))))))))))]))
@ -1521,17 +1644,21 @@
(provide union (provide any?
and/c not/f union
and/c
not/f
>=/c <=/c </c >/c >=/c <=/c </c >/c
integer-in real-in integer-in
string/len real-in
natural-number? natural-number?
false? any? string/len
false?
printable? printable?
symbols symbols
subclass?/c implementation?/c is-a?/c is-a?/c subclass?/c implementation?/c
listof vectorof vector/p cons/p list/p box/p listof vectorof
vector/p cons/p list/p box/p
mixin-contract make-mixin-contract) mixin-contract make-mixin-contract)
(define (union . args) (define (union . args)
@ -1571,7 +1698,7 @@
[(ormap (lambda (pred) (pred val)) predicates) [(ormap (lambda (pred) (pred val)) predicates)
val] val]
[else [else
(contract val)])))))] (partial-contract val)])))))]
[else [else
(flat-named-contract (flat-named-contract
(apply build-compound-type-name "union" fc/predicates) (apply build-compound-type-name "union" fc/predicates)
@ -1584,7 +1711,9 @@
(lambda (x) (not x)))) (lambda (x) (not x))))
(define any? (define any?
(make-contract (lambda (pos neg src-info) (lambda (val) val)))) (make-flat-contract
(lambda (pos neg src-info) (lambda (val) val))
(lambda (x) #t)))
(define (string/len n) (define (string/len n)
(unless (number? n) (unless (number? n)
@ -1680,20 +1809,42 @@
(define (and/c . fs) (define (and/c . fs)
(for-each (for-each
(lambda (x) (lambda (x)
(unless (flat-contract/predicate? x) (unless (or (contract? x)
(and (procedure? x)
(procedure-arity-includes? x 1)))
(error 'and/c "expected procedures of arity 1 or <contract>s, given: ~e" x))) (error 'and/c "expected procedures of arity 1 or <contract>s, given: ~e" x)))
fs) fs)
(cond
[(null? fs) any?]
[(andmap flat-contract/predicate? fs)
(let* ([to-predicate
(lambda (x)
(if (flat-contract? x)
(flat-contract-predicate x)
x))]
[pred
(let loop ([pred (to-predicate (car fs))]
[preds (cdr fs)])
(cond
[(null? preds) pred]
[else
(let* ([fst (to-predicate (car preds))])
(loop (lambda (x) (and (pred x) (fst x)))
(cdr preds)))]))])
(flat-contract pred))]
[else
(let ([contracts (map (lambda (x) (if (contract? x) x (flat-contract x))) fs)]) (let ([contracts (map (lambda (x) (if (contract? x) x (flat-contract x))) fs)])
(make-contract (make-contract
(lambda (pos neg src-info) (lambda (pos neg src-info)
(let ([partial-contracts (map (lambda (contract) (contract pos neg src-info)) contracts)]) (let ([partial-contracts (map (lambda (contract) (contract pos neg src-info)) contracts)])
(lambda (val) (let loop ([ctct (car partial-contracts)]
(let loop ([val val] [rest (cdr partial-contracts)])
[contracts contracts])
(cond (cond
[(null? contracts) val] [(null? rest) ctct]
[else (loop ((car contracts) val) [else
(cdr contracts))])))))))) (let ([fst (car rest)])
(loop (lambda (x) (fst (ctct x)))
(cdr rest)))]))))))]))
(define (not/f f) (define (not/f f)
(unless (flat-contract/predicate? f) (unless (flat-contract/predicate? f)
@ -1835,10 +1986,10 @@
"implementation of <<unknown>>") "implementation of <<unknown>>")
(lambda (x) (implementation? x <%>))))) (lambda (x) (implementation? x <%>)))))
(define mixin-contract '(class? . ->d . subclass?/c)) (define mixin-contract (class? . ->d . subclass?/c))
(define (make-mixin-contract . %/<%>s) (define (make-mixin-contract . %/<%>s)
'((and/c (flat-contract class?) ((and/c (flat-contract class?)
(apply and/c (map sub/impl?/c %/<%>s))) (apply and/c (map sub/impl?/c %/<%>s)))
. ->d . . ->d .
subclass?/c)) subclass?/c))