changed the low-level api for contracts so the projections accept an extra argument indicating if the contract is being used positively or negatively
svn: r15850
This commit is contained in:
Robby Findler
parent
a06f5921f8
commit
5c73253e03
|
|
@ -19,9 +19,9 @@
|
|||
(define (make-/proc method-proc? /h stx)
|
||||
(let-values ([(arguments-check build-proj check-val first-order-check wrapper)
|
||||
(/h method-proc? stx)])
|
||||
(let ([outer-args (syntax (val pos-blame neg-blame src-info orig-str name-id))])
|
||||
(let ([outer-args (syntax (val pos-blame neg-blame src-info orig-str name-id positive-position?))])
|
||||
(with-syntax ([inner-check (check-val outer-args)]
|
||||
[(val pos-blame neg-blame src-info orig-str name-id) outer-args]
|
||||
[(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]
|
||||
[(val-args body) (wrapper outer-args)])
|
||||
(with-syntax ([inner-lambda
|
||||
(set-inferred-name-from
|
||||
|
|
@ -39,7 +39,7 @@
|
|||
(syntax/loc stx
|
||||
(make-proj-contract
|
||||
name-id
|
||||
(lambda (pos-blame neg-blame src-info orig-str)
|
||||
(lambda (pos-blame neg-blame src-info orig-str positive-position?)
|
||||
proj-code)
|
||||
first-order-check))))))))))
|
||||
|
||||
|
|
@ -55,9 +55,9 @@
|
|||
[(_ cases ...)
|
||||
(let-values ([(arguments-check build-projs check-val first-order-check wrapper)
|
||||
(case->/h method-proc? stx (syntax->list (syntax (cases ...))) select/h)])
|
||||
(let ([outer-args (syntax (val pos-blame neg-blame src-info orig-str name-id))])
|
||||
(let ([outer-args (syntax (val pos-blame neg-blame src-info orig-str name-id positive-position?))])
|
||||
(with-syntax ([(inner-check ...) (check-val outer-args)]
|
||||
[(val pos-blame neg-blame src-info orig-str name-id) outer-args]
|
||||
[(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]
|
||||
[(body ...) (wrapper outer-args)])
|
||||
(with-syntax ([inner-lambda
|
||||
(set-inferred-name-from
|
||||
|
|
@ -75,7 +75,7 @@
|
|||
(syntax/loc stx
|
||||
(make-proj-contract
|
||||
(apply build-compound-type-name 'case-> name-id)
|
||||
(lambda (pos-blame neg-blame src-info orig-str)
|
||||
(lambda (pos-blame neg-blame src-info orig-str positive-position?)
|
||||
proj-code)
|
||||
first-order-check)))))))))]))
|
||||
|
||||
|
|
@ -230,7 +230,7 @@
|
|||
[(null? cases)
|
||||
(values
|
||||
(lambda (outer-args body)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]
|
||||
[body body]
|
||||
[(name-ids ...) (reverse name-ids)])
|
||||
(syntax
|
||||
|
|
@ -249,10 +249,10 @@
|
|||
(/h method-proc? (car cases))])
|
||||
(values
|
||||
(lambda (outer-args x)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]
|
||||
[new-id new-id])
|
||||
(arguments-check
|
||||
(syntax (val pos-blame neg-blame src-info orig-str new-id))
|
||||
(syntax (val pos-blame neg-blame src-info orig-str new-id positive-position?))
|
||||
(arguments-checks
|
||||
outer-args
|
||||
x))))
|
||||
|
|
@ -364,7 +364,7 @@
|
|||
(values
|
||||
(lambda (outer-args body)
|
||||
(with-syntax ([body body]
|
||||
[(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
||||
[(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args])
|
||||
(syntax
|
||||
(let ([dom-contract-x (coerce-contract '-> dom)] ...)
|
||||
(let ([dom-x (contract-proc dom-contract-x)] ...)
|
||||
|
|
@ -373,19 +373,19 @@
|
|||
|
||||
;; proj
|
||||
(lambda (outer-args inner-lambda)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]
|
||||
[inner-lambda inner-lambda])
|
||||
(syntax
|
||||
(let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ...)
|
||||
(let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str (not positive-position?))] ...)
|
||||
inner-lambda))))
|
||||
|
||||
(lambda (outer-args)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args])
|
||||
(syntax
|
||||
(check-procedure val dom-length 0 '() '() #|keywords|# src-info pos-blame orig-str))))
|
||||
(syntax (check-procedure? dom-length))
|
||||
(lambda (outer-args)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args])
|
||||
(syntax
|
||||
((arg-x ...)
|
||||
(val (dom-projection-x arg-x) ...))))))]
|
||||
|
|
@ -399,7 +399,7 @@
|
|||
(values
|
||||
(lambda (outer-args body)
|
||||
(with-syntax ([body body]
|
||||
[(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
||||
[(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args])
|
||||
(syntax
|
||||
(let ([dom-contract-x (coerce-contract '-> dom)]
|
||||
...
|
||||
|
|
@ -417,22 +417,22 @@
|
|||
|
||||
;; proj
|
||||
(lambda (outer-args inner-lambda)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]
|
||||
[inner-lambda inner-lambda])
|
||||
(syntax
|
||||
(let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)]
|
||||
(let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str (not positive-position?))]
|
||||
...
|
||||
[rng-projection-x (rng-x pos-blame neg-blame src-info orig-str)] ...)
|
||||
[rng-projection-x (rng-x pos-blame neg-blame src-info orig-str positive-position?)] ...)
|
||||
inner-lambda))))
|
||||
|
||||
(lambda (outer-args)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args])
|
||||
(syntax
|
||||
(check-procedure val dom-length 0 '() '() #|keywords|# src-info pos-blame orig-str))))
|
||||
(syntax (check-procedure? dom-length))
|
||||
|
||||
(lambda (outer-args)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args])
|
||||
(syntax
|
||||
((arg-x ...)
|
||||
(let-values ([(res-x ...) (val (dom-projection-x arg-x) ...)])
|
||||
|
|
@ -448,7 +448,7 @@
|
|||
(values
|
||||
(lambda (outer-args body)
|
||||
(with-syntax ([body body]
|
||||
[(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
||||
[(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args])
|
||||
(syntax
|
||||
(let ([dom-contract-x (coerce-contract '-> dom)]
|
||||
...
|
||||
|
|
@ -461,21 +461,21 @@
|
|||
|
||||
;; proj
|
||||
(lambda (outer-args inner-lambda)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]
|
||||
[inner-lambda inner-lambda])
|
||||
(syntax
|
||||
(let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)]
|
||||
(let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str (not positive-position?))]
|
||||
...
|
||||
[rng-projection-x (rng-x pos-blame neg-blame src-info orig-str)])
|
||||
[rng-projection-x (rng-x pos-blame neg-blame src-info orig-str positive-position?)])
|
||||
inner-lambda))))
|
||||
|
||||
(lambda (outer-args)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args])
|
||||
(syntax
|
||||
(check-procedure val dom-length 0 '() '() #|keywords|# src-info pos-blame orig-str))))
|
||||
(syntax (check-procedure? dom-length))
|
||||
(lambda (outer-args)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args])
|
||||
(syntax
|
||||
((arg-x ...)
|
||||
(let ([res-x (val (dom-projection-x arg-x) ...)])
|
||||
|
|
@ -509,7 +509,7 @@
|
|||
[arity (length (syntax->list (syntax (dom ...))))])
|
||||
(values
|
||||
(lambda (outer-args body)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]
|
||||
[body body]
|
||||
[(name-dom-contract-x ...)
|
||||
(if method-proc?
|
||||
|
|
@ -536,22 +536,22 @@
|
|||
body))))))
|
||||
;; proj
|
||||
(lambda (outer-args inner-lambda)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]
|
||||
[inner-lambda inner-lambda])
|
||||
(syntax
|
||||
(let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)]
|
||||
(let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str (not positive-position?))]
|
||||
...
|
||||
[dom-rest-projection-x (dom-rest-x neg-blame pos-blame src-info orig-str)]
|
||||
[rng-projection-x (rng-x pos-blame neg-blame src-info orig-str)] ...)
|
||||
[dom-rest-projection-x (dom-rest-x neg-blame pos-blame src-info orig-str (not positive-position?))]
|
||||
[rng-projection-x (rng-x pos-blame neg-blame src-info orig-str positive-position?)] ...)
|
||||
inner-lambda))))
|
||||
|
||||
(lambda (outer-args)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args])
|
||||
(syntax
|
||||
(check-procedure/more val dom-length '() '() #|keywords|# src-info pos-blame orig-str))))
|
||||
(syntax (check-procedure/more? dom-length))
|
||||
(lambda (outer-args)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args])
|
||||
(syntax
|
||||
((arg-x ... . arg-rest-x)
|
||||
(let-values ([(res-x ...)
|
||||
|
|
@ -577,7 +577,7 @@
|
|||
(values
|
||||
(lambda (outer-args body)
|
||||
(with-syntax ([body body]
|
||||
[(val pos-blame neg-blame src-info orig-str name-id) outer-args]
|
||||
[(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]
|
||||
[(name-dom-contract-x ...)
|
||||
(if method-proc?
|
||||
(cdr
|
||||
|
|
@ -599,21 +599,21 @@
|
|||
body))))))
|
||||
;; proj
|
||||
(lambda (outer-args inner-lambda)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]
|
||||
[inner-lambda inner-lambda])
|
||||
(syntax
|
||||
(let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)]
|
||||
(let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str (not positive-position?))]
|
||||
...
|
||||
[dom-projection-rest-x (dom-rest-x neg-blame pos-blame src-info orig-str)])
|
||||
[dom-projection-rest-x (dom-rest-x neg-blame pos-blame src-info orig-str (not positive-position?))])
|
||||
inner-lambda))))
|
||||
|
||||
(lambda (outer-args)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args])
|
||||
(syntax
|
||||
(check-procedure/more val dom-length '() '() #|keywords|# src-info pos-blame orig-str))))
|
||||
(syntax (check-procedure/more? dom-length))
|
||||
(lambda (outer-args)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args])
|
||||
(syntax
|
||||
((arg-x ... . arg-rest-x)
|
||||
(apply
|
||||
|
|
@ -636,7 +636,7 @@
|
|||
(values
|
||||
(lambda (outer-args body)
|
||||
(with-syntax ([body body]
|
||||
[(val pos-blame neg-blame src-info orig-str name-id) outer-args]
|
||||
[(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]
|
||||
[(name-dom-contract-x ...)
|
||||
(if method-proc?
|
||||
(cdr
|
||||
|
|
@ -654,21 +654,21 @@
|
|||
|
||||
;; proj
|
||||
(lambda (outer-args inner-lambda)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]
|
||||
[inner-lambda inner-lambda])
|
||||
(syntax
|
||||
(let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ...)
|
||||
(let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str (not positive-position?))] ...)
|
||||
inner-lambda))))
|
||||
|
||||
(lambda (outer-args)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args])
|
||||
(syntax
|
||||
(check-procedure val arity 0 '() '() #|keywords|# src-info pos-blame orig-str))))
|
||||
|
||||
(syntax (check-procedure? arity))
|
||||
|
||||
(lambda (outer-args)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args])
|
||||
(syntax
|
||||
((arg-x ...)
|
||||
(let ([arg-x (dom-projection-x arg-x)] ...)
|
||||
|
|
@ -677,7 +677,8 @@
|
|||
pos-blame
|
||||
neg-blame
|
||||
src-info
|
||||
orig-str)
|
||||
orig-str
|
||||
positive-position?)
|
||||
(val arg-x ...))))))))))]))
|
||||
|
||||
;; ->d*/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
|
||||
|
|
@ -693,7 +694,7 @@
|
|||
(values
|
||||
(lambda (outer-args body)
|
||||
(with-syntax ([body body]
|
||||
[(val pos-blame neg-blame src-info orig-str name-id) outer-args]
|
||||
[(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]
|
||||
[(name-dom-contract-x ...)
|
||||
(if method-proc?
|
||||
(cdr
|
||||
|
|
@ -714,20 +715,20 @@
|
|||
|
||||
;; proj
|
||||
(lambda (outer-args inner-lambda)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]
|
||||
[inner-lambda inner-lambda])
|
||||
(syntax
|
||||
(let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ...)
|
||||
(let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str (not positive-position?))] ...)
|
||||
inner-lambda))))
|
||||
|
||||
(lambda (outer-args)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args])
|
||||
(syntax
|
||||
(check-procedure val dom-length 0 '() '() #|keywords|# src-info pos-blame orig-str))))
|
||||
(syntax (check-procedure? dom-length))
|
||||
|
||||
(lambda (outer-args)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args])
|
||||
(syntax
|
||||
((arg-x ...)
|
||||
(call-with-values
|
||||
|
|
@ -745,7 +746,8 @@
|
|||
pos-blame
|
||||
neg-blame
|
||||
src-info
|
||||
orig-str)
|
||||
orig-str
|
||||
positive-position?)
|
||||
result))
|
||||
rng-contracts
|
||||
results))))))))))))]
|
||||
|
|
@ -761,7 +763,7 @@
|
|||
(values
|
||||
(lambda (outer-args body)
|
||||
(with-syntax ([body body]
|
||||
[(val pos-blame neg-blame src-info orig-str name-id) outer-args]
|
||||
[(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]
|
||||
[(name-dom-contract-x ...)
|
||||
(if method-proc?
|
||||
(cdr
|
||||
|
|
@ -786,22 +788,22 @@
|
|||
|
||||
;; proj
|
||||
(lambda (outer-args inner-lambda)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]
|
||||
[inner-lambda inner-lambda])
|
||||
(syntax
|
||||
(let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)]
|
||||
(let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str (not positive-position?))]
|
||||
...
|
||||
[dom-rest-projection-x (dom-rest-x neg-blame pos-blame src-info orig-str)])
|
||||
[dom-rest-projection-x (dom-rest-x neg-blame pos-blame src-info orig-str (not positive-position?))])
|
||||
inner-lambda))))
|
||||
|
||||
(lambda (outer-args)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args])
|
||||
(syntax
|
||||
(check-procedure/more val arity '() '() #|keywords|# src-info pos-blame orig-str))))
|
||||
(syntax (check-procedure/more? arity))
|
||||
|
||||
(lambda (outer-args)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args])
|
||||
(syntax
|
||||
((arg-x ... . rest-arg-x)
|
||||
(call-with-values
|
||||
|
|
@ -824,7 +826,8 @@
|
|||
pos-blame
|
||||
neg-blame
|
||||
src-info
|
||||
orig-str)
|
||||
orig-str
|
||||
positive-position?)
|
||||
result))
|
||||
rng-contracts
|
||||
results))))))))))))]))
|
||||
|
|
@ -877,14 +880,14 @@
|
|||
(values
|
||||
(lambda (outer-args body)
|
||||
(with-syntax ([body body]
|
||||
[(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
||||
[(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args])
|
||||
(syntax
|
||||
(let ([name-id name-stx])
|
||||
body))))
|
||||
(lambda (outer-args inner-lambda) inner-lambda)
|
||||
|
||||
(lambda (outer-args)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]
|
||||
[kind-of-thing (if method-proc? 'method 'procedure)])
|
||||
(syntax
|
||||
(begin
|
||||
|
|
@ -893,14 +896,16 @@
|
|||
(syntax (check-procedure? arity))
|
||||
|
||||
(lambda (outer-args)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args])
|
||||
(syntax-case* (syntax result-stuff) (any values) module-or-top-identifier=?
|
||||
[(any)
|
||||
(syntax
|
||||
((x ...)
|
||||
(begin
|
||||
(check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str)
|
||||
(let ([dom-id ((contract-proc (coerce-contract 'stx-name dom)) neg-blame pos-blame src-info orig-str)]
|
||||
(let ([dom-id ((contract-proc (coerce-contract 'stx-name dom))
|
||||
neg-blame pos-blame src-info orig-str
|
||||
(not positive-position?))]
|
||||
...)
|
||||
(val (dom-id x) ...)))))]
|
||||
[((values (rng-ids rng-ctc) ...) post-expr)
|
||||
|
|
@ -911,12 +916,15 @@
|
|||
((x ...)
|
||||
(begin
|
||||
(check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str)
|
||||
(let ([dom-id ((contract-proc (coerce-contract 'stx-name dom)) neg-blame pos-blame src-info orig-str)]
|
||||
(let ([dom-id ((contract-proc (coerce-contract 'stx-name dom))
|
||||
neg-blame pos-blame src-info orig-str
|
||||
(not positive-position?))]
|
||||
...)
|
||||
(let-values ([(rng-ids ...) (val (dom-id x) ...)])
|
||||
(check-post-expr->pp/h val post-expr src-info pos-blame orig-str)
|
||||
(let ([rng-ids-x ((contract-proc (coerce-contract 'stx-name rng-ctc))
|
||||
pos-blame neg-blame src-info orig-str)] ...)
|
||||
pos-blame neg-blame src-info orig-str
|
||||
positive-position?)] ...)
|
||||
(values (rng-ids-x rng-ids) ...))))))))]
|
||||
[((values (rng-ids rng-ctc) ...) post-expr)
|
||||
(andmap identifier? (syntax->list (syntax (rng-ids ...))))
|
||||
|
|
@ -934,9 +942,13 @@
|
|||
((x ...)
|
||||
(begin
|
||||
(check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str)
|
||||
(let ([dom-id ((contract-proc (coerce-contract 'stx-name dom)) neg-blame pos-blame src-info orig-str)]
|
||||
(let ([dom-id ((contract-proc (coerce-contract 'stx-name dom))
|
||||
neg-blame pos-blame src-info orig-str
|
||||
(not positive-position?))]
|
||||
...
|
||||
[rng-id ((contract-proc (coerce-contract 'stx-name rng)) pos-blame neg-blame src-info orig-str)])
|
||||
[rng-id ((contract-proc (coerce-contract 'stx-name rng))
|
||||
pos-blame neg-blame src-info orig-str
|
||||
positive-position?)])
|
||||
(let ([res-id (rng-id (val (dom-id x) ...))])
|
||||
(check-post-expr->pp/h val post-expr src-info pos-blame orig-str)
|
||||
res-id)))))]
|
||||
|
|
@ -988,14 +1000,14 @@
|
|||
(values
|
||||
(lambda (outer-args body)
|
||||
(with-syntax ([body body]
|
||||
[(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
||||
[(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args])
|
||||
(syntax
|
||||
(let ([name-id name-stx])
|
||||
body))))
|
||||
(lambda (outer-args inner-lambda) inner-lambda)
|
||||
|
||||
(lambda (outer-args)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]
|
||||
[kind-of-thing (if method-proc? 'method 'procedure)])
|
||||
(syntax
|
||||
(begin
|
||||
|
|
@ -1003,16 +1015,20 @@
|
|||
(syntax (check-procedure/more? arity))
|
||||
|
||||
(lambda (outer-args)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args])
|
||||
(syntax-case* (syntax result-stuff) (values any) module-or-top-identifier=?
|
||||
[(any)
|
||||
(syntax
|
||||
((x ... . rest-x)
|
||||
(begin
|
||||
(check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str)
|
||||
(let ([dom-id ((contract-proc (coerce-contract 'stx-name dom)) neg-blame pos-blame src-info orig-str)]
|
||||
(let ([dom-id ((contract-proc (coerce-contract 'stx-name dom))
|
||||
neg-blame pos-blame src-info orig-str
|
||||
(not positive-position?))]
|
||||
...
|
||||
[rest-id ((contract-proc (coerce-contract 'stx-name rest-dom)) neg-blame pos-blame src-info orig-str)])
|
||||
[rest-id ((contract-proc (coerce-contract 'stx-name rest-dom))
|
||||
neg-blame pos-blame src-info orig-str
|
||||
(not positive-position?))])
|
||||
(apply val (dom-id x) ... (rest-id rest-x))))))]
|
||||
[(any . x)
|
||||
(raise-syntax-error name "cannot have anything after any" stx (syntax result-stuff))]
|
||||
|
|
@ -1024,13 +1040,18 @@
|
|||
((x ... . rest-x)
|
||||
(begin
|
||||
(check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str)
|
||||
(let ([dom-id ((contract-proc (coerce-contract 'stx-name dom)) neg-blame pos-blame src-info orig-str)]
|
||||
(let ([dom-id ((contract-proc (coerce-contract 'stx-name dom))
|
||||
neg-blame pos-blame src-info orig-str
|
||||
(not positive-position?))]
|
||||
...
|
||||
[rest-id ((contract-proc (coerce-contract 'stx-name rest-dom)) neg-blame pos-blame src-info orig-str)])
|
||||
[rest-id ((contract-proc (coerce-contract 'stx-name rest-dom))
|
||||
neg-blame pos-blame src-info orig-str
|
||||
(not positive-position?))])
|
||||
(let-values ([(rng-ids ...) (apply val (dom-id x) ... (rest-id rest-x))])
|
||||
(check-post-expr->pp/h val post-expr src-info pos-blame orig-str)
|
||||
(let ([rng-ids-x ((contract-proc (coerce-contract 'stx-name rng-ctc))
|
||||
pos-blame neg-blame src-info orig-str)] ...)
|
||||
pos-blame neg-blame src-info orig-str
|
||||
positive-position?)] ...)
|
||||
(values (rng-ids-x rng-ids) ...))))))))]
|
||||
[((values (rng-ids rng-ctc) ...) . whatever)
|
||||
(and (andmap identifier? (syntax->list (syntax (rng-ids ...))))
|
||||
|
|
@ -1053,10 +1074,16 @@
|
|||
((x ... . rest-x)
|
||||
(begin
|
||||
(check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str)
|
||||
(let ([dom-id ((contract-proc (coerce-contract 'stx-name dom)) neg-blame pos-blame src-info orig-str)]
|
||||
(let ([dom-id ((contract-proc (coerce-contract 'stx-name dom))
|
||||
neg-blame pos-blame src-info orig-str
|
||||
(not positive-position?))]
|
||||
...
|
||||
[rest-id ((contract-proc (coerce-contract 'stx-name rest-dom)) neg-blame pos-blame src-info orig-str)]
|
||||
[rng-id ((contract-proc (coerce-contract 'stx-name rng)) pos-blame neg-blame src-info orig-str)])
|
||||
[rest-id ((contract-proc (coerce-contract 'stx-name rest-dom))
|
||||
neg-blame pos-blame src-info orig-str
|
||||
(not positive-position?))]
|
||||
[rng-id ((contract-proc (coerce-contract 'stx-name rng))
|
||||
pos-blame neg-blame src-info orig-str
|
||||
positive-position?)])
|
||||
(let ([res-id (rng-id (apply val (dom-id x) ... (rest-id rest-x)))])
|
||||
(check-post-expr->pp/h val post-expr src-info pos-blame orig-str)
|
||||
res-id)))))]
|
||||
|
|
|
|||
|
|
@ -33,8 +33,8 @@
|
|||
(let ([proj-x ((proj-get rngs-x) rngs-x)] ...)
|
||||
(make-proj-contract
|
||||
(build-compound-type-name 'unconstrained-domain-> ((name-get rngs-x) rngs-x) ...)
|
||||
(λ (pos-blame neg-blame src-info orig-str)
|
||||
(let ([p-app-x (proj-x pos-blame neg-blame src-info orig-str)] ...)
|
||||
(λ (pos-blame neg-blame src-info orig-str positive-position?)
|
||||
(let ([p-app-x (proj-x pos-blame neg-blame src-info orig-str positive-position?)] ...)
|
||||
(λ (val)
|
||||
(if (procedure? val)
|
||||
(λ args
|
||||
|
|
@ -76,12 +76,12 @@
|
|||
[func (->-func ctc)]
|
||||
[dom-length (length (->-doms ctc))]
|
||||
[has-rest? (and (->-dom-rest ctc) #t)])
|
||||
(lambda (pos-blame neg-blame src-info orig-str)
|
||||
(let ([partial-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str))
|
||||
(lambda (pos-blame neg-blame src-info orig-str positive-position?)
|
||||
(let ([partial-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str (not positive-position?)))
|
||||
doms/c)]
|
||||
[partial-ranges (map (λ (rng) (rng pos-blame neg-blame src-info orig-str))
|
||||
[partial-ranges (map (λ (rng) (rng pos-blame neg-blame src-info orig-str positive-position?))
|
||||
rngs/c)]
|
||||
[partial-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str))
|
||||
[partial-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str (not positive-position?)))
|
||||
kwds/c)])
|
||||
(apply func
|
||||
(λ (val)
|
||||
|
|
|
|||
|
|
@ -344,10 +344,10 @@
|
|||
`(object-contract
|
||||
,(build-compound-type-name 'method-name method-ctc-var) ...
|
||||
,(build-compound-type-name 'field 'field-name field-ctc-var) ...)
|
||||
(lambda (pos-blame neg-blame src-info orig-str)
|
||||
(let ([method/app-var (method-var pos-blame neg-blame src-info orig-str)]
|
||||
(lambda (pos-blame neg-blame src-info orig-str positive-position?)
|
||||
(let ([method/app-var (method-var pos-blame neg-blame src-info orig-str positive-position?)]
|
||||
...
|
||||
[field/app-var (field-var pos-blame neg-blame src-info orig-str)]
|
||||
[field/app-var (field-var pos-blame neg-blame src-info orig-str positive-position?)]
|
||||
...)
|
||||
(let ([field-names-list '(field-name ...)])
|
||||
(lambda (val)
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@
|
|||
(provide (for-syntax unit/c/core) unit/c)
|
||||
|
||||
(define-for-syntax (contract-imports/exports import?)
|
||||
(λ (table-stx import-tagged-infos import-sigs ctc-table pos neg src-info name)
|
||||
(λ (table-stx import-tagged-infos import-sigs ctc-table pos neg src-info name positive-position?)
|
||||
(define def-table (make-bound-identifier-mapping))
|
||||
|
||||
(define (convert-reference var vref ctc sig-ctc rename-bindings)
|
||||
|
|
@ -28,7 +28,8 @@
|
|||
#,(if import? neg pos)
|
||||
#,(if import? pos neg)
|
||||
#,src-info
|
||||
#,name)
|
||||
#,name
|
||||
#,(if import? (not positive-position?) positive-position?))
|
||||
#,stx)))])
|
||||
(if ctc
|
||||
#`(λ ()
|
||||
|
|
@ -146,7 +147,7 @@
|
|||
(map list (list 'e.x ...)
|
||||
(build-compound-type-name 'e.c ...)))
|
||||
...)))
|
||||
(λ (pos neg src-info name)
|
||||
(λ (pos neg src-info name positive-position?)
|
||||
(λ (unit-tmp)
|
||||
(unless (unit? unit-tmp)
|
||||
(raise-contract-error unit-tmp src-info pos name
|
||||
|
|
@ -178,7 +179,8 @@
|
|||
#'pos
|
||||
#'neg
|
||||
#'src-info
|
||||
#'name)))
|
||||
#'name
|
||||
#'positive-position?)))
|
||||
#,(contract-exports
|
||||
#'export-table
|
||||
export-tagged-infos
|
||||
|
|
@ -187,7 +189,8 @@
|
|||
#'pos
|
||||
#'neg
|
||||
#'src-info
|
||||
#'name)))))))
|
||||
#'name
|
||||
#'positive-position?)))))))
|
||||
(λ (v)
|
||||
(and (unit? v)
|
||||
(with-handlers ([exn:fail:contract? (λ () #f)])
|
||||
|
|
|
|||
|
|
@ -51,8 +51,8 @@ v4 todo:
|
|||
(let ([proj-x ((proj-get rngs-x) rngs-x)] ...)
|
||||
(make-proj-contract
|
||||
(build-compound-type-name 'unconstrained-domain-> ((name-get rngs-x) rngs-x) ...)
|
||||
(λ (pos-blame neg-blame src-info orig-str)
|
||||
(let ([p-app-x (proj-x pos-blame neg-blame src-info orig-str)] ...)
|
||||
(λ (pos-blame neg-blame src-info orig-str positive-position?)
|
||||
(let ([p-app-x (proj-x pos-blame neg-blame src-info orig-str positive-position?)] ...)
|
||||
(λ (val)
|
||||
(if (procedure? val)
|
||||
(make-keyword-procedure
|
||||
|
|
@ -116,16 +116,16 @@ v4 todo:
|
|||
[dom-length (length (->-doms/c ctc))]
|
||||
[optionals-length (length (->-optional-doms/c ctc))]
|
||||
[has-rest? (and (->-dom-rest/c ctc) #t)])
|
||||
(λ (pos-blame neg-blame src-info orig-str)
|
||||
(let ([partial-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str))
|
||||
(λ (pos-blame neg-blame src-info orig-str positive-position?)
|
||||
(let ([partial-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str (not positive-position?)))
|
||||
doms-proj)]
|
||||
[partial-optional-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str))
|
||||
[partial-optional-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str (not positive-position?)))
|
||||
doms-optional-proj)]
|
||||
[partial-ranges (map (λ (rng) (rng pos-blame neg-blame src-info orig-str))
|
||||
[partial-ranges (map (λ (rng) (rng pos-blame neg-blame src-info orig-str positive-position?))
|
||||
rngs-proj)]
|
||||
[partial-mandatory-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str))
|
||||
[partial-mandatory-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str (not positive-position?)))
|
||||
mandatory-kwds-proj)]
|
||||
[partial-optional-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str))
|
||||
[partial-optional-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str (not positive-position?)))
|
||||
optional-kwds-proj)])
|
||||
(apply func
|
||||
(λ (val mtd?)
|
||||
|
|
@ -851,7 +851,7 @@ v4 todo:
|
|||
(list (+ mandatory-count i))]
|
||||
[else
|
||||
(cons (+ mandatory-count i) (loop (+ i 1)))]))])])
|
||||
(λ (pos-blame neg-blame src-info orig-str)
|
||||
(λ (pos-blame neg-blame src-info orig-str positive-position?)
|
||||
(let ([this->d-id (gensym '->d-tail-key)])
|
||||
(λ (val)
|
||||
(check-procedure val
|
||||
|
|
@ -885,7 +885,7 @@ v4 todo:
|
|||
[(or (null? building-kwd-args) (null? all-kwds)) '()]
|
||||
[else (if (eq? (car all-kwds)
|
||||
(car building-kwd-args))
|
||||
(cons (invoke-dep-ctc (car kwd-ctcs) dep-pre-args (car building-kwd-arg-vals) neg-blame pos-blame src-info orig-str)
|
||||
(cons (invoke-dep-ctc (car kwd-ctcs) dep-pre-args (car building-kwd-arg-vals) neg-blame pos-blame src-info orig-str (not positive-position?))
|
||||
(loop (cdr all-kwds) (cdr kwd-ctcs) (cdr building-kwd-args) (cdr building-kwd-arg-vals)))
|
||||
(loop (cdr all-kwds) (cdr kwd-ctcs) building-kwd-args building-kwd-arg-vals))]))
|
||||
|
||||
|
|
@ -902,17 +902,17 @@ v4 todo:
|
|||
(cond
|
||||
[(null? args)
|
||||
(if (->d-rest-ctc ->d-stct)
|
||||
(invoke-dep-ctc (->d-rest-ctc ->d-stct) dep-pre-args '() neg-blame pos-blame src-info orig-str)
|
||||
(invoke-dep-ctc (->d-rest-ctc ->d-stct) dep-pre-args '() neg-blame pos-blame src-info orig-str (not positive-position?))
|
||||
'())]
|
||||
[(null? non-kwd-ctcs)
|
||||
(if (->d-rest-ctc ->d-stct)
|
||||
(invoke-dep-ctc (->d-rest-ctc ->d-stct) dep-pre-args args neg-blame pos-blame src-info orig-str)
|
||||
(invoke-dep-ctc (->d-rest-ctc ->d-stct) dep-pre-args args neg-blame pos-blame src-info orig-str (not positive-position?))
|
||||
|
||||
;; ran out of arguments, but don't have a rest parameter.
|
||||
;; procedure-reduce-arity (or whatever the new thing is
|
||||
;; going to be called) should ensure this doesn't happen.
|
||||
(error 'shouldnt\ happen))]
|
||||
[else (cons (invoke-dep-ctc (car non-kwd-ctcs) dep-pre-args (car args) neg-blame pos-blame src-info orig-str)
|
||||
[else (cons (invoke-dep-ctc (car non-kwd-ctcs) dep-pre-args (car args) neg-blame pos-blame src-info orig-str (not positive-position?))
|
||||
(loop (cdr args)
|
||||
(cdr non-kwd-ctcs)))])))))]
|
||||
[rng (let ([rng (->d-range ->d-stct)])
|
||||
|
|
@ -975,7 +975,7 @@ v4 todo:
|
|||
(cons
|
||||
(invoke-dep-ctc (car result-contracts)
|
||||
(if rng-underscore? #f dep-post-args)
|
||||
(car results) pos-blame neg-blame src-info orig-str)
|
||||
(car results) pos-blame neg-blame src-info orig-str positive-position?)
|
||||
(loop (cdr results) (cdr result-contracts)))]))))))]
|
||||
[else
|
||||
(thunk)])))))])
|
||||
|
|
@ -990,11 +990,11 @@ v4 todo:
|
|||
(->d-keywords ->d-stct))))))))
|
||||
|
||||
;; invoke-dep-ctc : (...? -> ctc) (or/c #f (listof tst)) val pos-blame neg-blame src-info orig-src -> tst
|
||||
(define (invoke-dep-ctc dep-ctc dep-args val pos-blame neg-blame src-info orig-str)
|
||||
(define (invoke-dep-ctc dep-ctc dep-args val pos-blame neg-blame src-info orig-str positive-position?)
|
||||
(let ([ctc (coerce-contract '->d (if dep-args
|
||||
(apply dep-ctc dep-args)
|
||||
dep-ctc))])
|
||||
((((proj-get ctc) ctc) pos-blame neg-blame src-info orig-str) val)))
|
||||
((((proj-get ctc) ctc) pos-blame neg-blame src-info orig-str positive-position?) val)))
|
||||
|
||||
;; build-dep-ctc-args : number (listof any) boolean (listof keyword) (listof keyword) (listof any)
|
||||
(define (build-dep-ctc-args non-kwd-ctc-count args rest-arg? all-kwds supplied-kwds supplied-args)
|
||||
|
|
@ -1233,9 +1233,9 @@ v4 todo:
|
|||
(and rngs (map to-proj (get-case->-rng-ctcs ctc))))]
|
||||
[rst-ctcs (case->-rst-ctcs ctc)]
|
||||
[specs (case->-specs ctc)])
|
||||
(λ (pos-blame neg-blame src-info orig-str)
|
||||
(let ([projs (append (map (λ (f) (f neg-blame pos-blame src-info orig-str)) dom-ctcs)
|
||||
(map (λ (f) (f pos-blame neg-blame src-info orig-str)) rng-ctcs))]
|
||||
(λ (pos-blame neg-blame src-info orig-str positive-position?)
|
||||
(let ([projs (append (map (λ (f) (f neg-blame pos-blame src-info orig-str (not positive-position?))) dom-ctcs)
|
||||
(map (λ (f) (f pos-blame neg-blame src-info orig-str positive-position?)) rng-ctcs))]
|
||||
[chk
|
||||
(λ (val mtd?)
|
||||
(cond
|
||||
|
|
|
|||
|
|
@ -222,7 +222,8 @@ it around flattened out.
|
|||
((((proj-get ctc) ctc) (contract/info-pos contract/info)
|
||||
(contract/info-neg contract/info)
|
||||
(contract/info-src-info contract/info)
|
||||
(contract/info-orig-str contract/info))
|
||||
(contract/info-orig-str contract/info)
|
||||
(contract/info-positive-position? contract/info))
|
||||
ctc-x)])
|
||||
(update-parent-links parent ctc-field-val)
|
||||
ctc-field-val)] ...)
|
||||
|
|
@ -235,8 +236,8 @@ it around flattened out.
|
|||
(contract-get b selector-indicies)) ...))
|
||||
|
||||
(define (lazy-contract-proj ctc)
|
||||
(λ (pos-blame neg-blame src-info orig-str)
|
||||
(let ([contract/info (make-contract/info ctc pos-blame neg-blame src-info orig-str)])
|
||||
(λ (pos-blame neg-blame src-info orig-str positive-position?)
|
||||
(let ([contract/info (make-contract/info ctc pos-blame neg-blame src-info orig-str positive-position?)])
|
||||
(λ (val)
|
||||
(unless (or (wrap-predicate val)
|
||||
(opt-wrap-predicate val)
|
||||
|
|
@ -488,7 +489,7 @@ it around flattened out.
|
|||
(list 'and '...)))]
|
||||
[else (apply build-compound-type-name name/dc fields)]))]))
|
||||
|
||||
(define-struct contract/info (contract pos neg src-info orig-str))
|
||||
(define-struct contract/info (contract pos neg src-info orig-str positive-position?))
|
||||
(define-struct opt-contract/info (contract enforcer id))
|
||||
|
||||
;; parents : (listof wrap-parent)
|
||||
|
|
|
|||
|
|
@ -298,7 +298,7 @@
|
|||
|
||||
(define (flat-proj ctc)
|
||||
(let ([pred? ((flat-get ctc) ctc)])
|
||||
(λ (pos neg src-info orig-str)
|
||||
(λ (pos neg src-info orig-str positive-position?)
|
||||
(λ (val)
|
||||
(if (pred? val)
|
||||
val
|
||||
|
|
@ -312,14 +312,19 @@
|
|||
val))))))
|
||||
|
||||
(define (double-any-curried-proj ctc) double-any-curred-proj2)
|
||||
(define (double-any-curred-proj2 pos-blame neg-blame src-info orig-str) values)
|
||||
(define (double-any-curred-proj2 pos-blame neg-blame src-info orig-str positive-position?) values)
|
||||
|
||||
|
||||
(define-values (make-proj-contract)
|
||||
(let ()
|
||||
(define-struct proj-contract (the-name proj first-order-proc)
|
||||
#:property proj-prop
|
||||
(λ (ctc) (proj-contract-proj ctc))
|
||||
(λ (ctc)
|
||||
(let ([raw-proj (proj-contract-proj ctc)])
|
||||
(if (procedure-arity-includes? raw-proj 5)
|
||||
raw-proj
|
||||
(λ (pos neg src-info name positive-position?)
|
||||
(raw-proj pos neg src-info name)))))
|
||||
|
||||
#:property name-prop
|
||||
(λ (ctc) (proj-contract-the-name ctc))
|
||||
|
|
@ -376,8 +381,8 @@
|
|||
|
||||
(define (and-proj ctc)
|
||||
(let ([mk-pos-projs (map (λ (x) ((proj-get x) x)) (and/c-ctcs ctc))])
|
||||
(lambda (pos neg src-info orig-str)
|
||||
(let ([projs (map (λ (c) (c pos neg src-info orig-str)) mk-pos-projs)])
|
||||
(lambda (pos neg src-info orig-str positive-position?)
|
||||
(let ([projs (map (λ (c) (c pos neg src-info orig-str positive-position?)) mk-pos-projs)])
|
||||
(let loop ([projs (cdr projs)]
|
||||
[proj (car projs)])
|
||||
(cond
|
||||
|
|
@ -435,7 +440,7 @@
|
|||
(define any/c (make-any/c))
|
||||
|
||||
(define (none-curried-proj ctc)
|
||||
(λ (pos-blame neg-blame src-info orig-str)
|
||||
(λ (pos-blame neg-blame src-info orig-str positive-position?)
|
||||
(λ (val)
|
||||
(raise-contract-error
|
||||
val
|
||||
|
|
|
|||
|
|
@ -17,8 +17,8 @@
|
|||
#;
|
||||
(let* ([cm (syntax-parameterize ((making-a-method #t)) (-> any/c integer? integer?))]
|
||||
[cf (-> integer? integer?)]
|
||||
[m-proj (((proj-get cm) cm) 'pos 'neg #'here "whatever")]
|
||||
[f-proj (((proj-get cf) cf) 'pos 'neg #'here "whatever")]
|
||||
[m-proj (((proj-get cm) cm) 'pos 'neg #'here "whatever" some-boolean)]
|
||||
[f-proj (((proj-get cf) cf) 'pos 'neg #'here "whatever" some-boolean)]
|
||||
[cls (make-wrapper-class 'wrapper-class
|
||||
'(m)
|
||||
(list
|
||||
|
|
@ -58,12 +58,12 @@
|
|||
[meth-param-projs (map (λ (x) ((proj-get x) x)) (object-contract-method-ctcs ctc))]
|
||||
[ctc-field-names (object-contract-fields ctc)]
|
||||
[field-param-projs (map (λ (x) ((proj-get x) x)) (object-contract-field-ctcs ctc))])
|
||||
(λ (pos-blame neg-blame src-info orig-str)
|
||||
(let* ([meth-projs (map (λ (x) (x pos-blame neg-blame src-info orig-str))
|
||||
(λ (pos-blame neg-blame src-info orig-str positive-position?)
|
||||
(let* ([meth-projs (map (λ (x) (x pos-blame neg-blame src-info orig-str positive-position?))
|
||||
meth-param-projs)]
|
||||
[meths (map (λ (p x) (p x)) meth-projs (object-contract-method-wrappers ctc))]
|
||||
[cls (make-wrapper-class 'wrapper-class meth-names meths ctc-field-names #f)]
|
||||
[field-projs (map (λ (x) (x pos-blame neg-blame src-info orig-str)) field-param-projs)])
|
||||
[field-projs (map (λ (x) (x pos-blame neg-blame src-info orig-str positive-position?)) field-param-projs)])
|
||||
(λ (val)
|
||||
|
||||
(unless (object? val)
|
||||
|
|
|
|||
|
|
@ -14,6 +14,7 @@
|
|||
opt/info-neg
|
||||
opt/info-src-info
|
||||
opt/info-orig-str
|
||||
opt/info-positive-position?
|
||||
opt/info-free-vars
|
||||
opt/info-recf
|
||||
opt/info-base-pred
|
||||
|
|
@ -55,15 +56,17 @@
|
|||
|
||||
|
||||
;; struct for color-keeping across opters
|
||||
(define-struct opt/info (contract val pos neg src-info orig-str free-vars recf base-pred this that))
|
||||
(define-struct opt/info (contract val pos neg src-info orig-str positive-position?
|
||||
free-vars recf base-pred this that))
|
||||
|
||||
;; opt/info-swap-blame : opt/info -> opt/info
|
||||
;; swaps pos and neg
|
||||
(define (opt/info-swap-blame info)
|
||||
(let ((ctc (opt/info-contract info))
|
||||
(val (opt/info-val info))
|
||||
(pos (opt/info-neg info))
|
||||
(neg (opt/info-pos info))
|
||||
(pos (opt/info-pos info))
|
||||
(neg (opt/info-neg info))
|
||||
(positive-position? (opt/info-positive-position? info))
|
||||
(src-info (opt/info-src-info info))
|
||||
(orig-str (opt/info-orig-str info))
|
||||
(free-vars (opt/info-free-vars info))
|
||||
|
|
@ -71,14 +74,16 @@
|
|||
(base-pred (opt/info-base-pred info))
|
||||
(this (opt/info-this info))
|
||||
(that (opt/info-that info)))
|
||||
(make-opt/info ctc val pos neg src-info orig-str free-vars recf base-pred this that)))
|
||||
(make-opt/info ctc val neg pos src-info orig-str (not positive-position?)
|
||||
free-vars recf base-pred this that)))
|
||||
|
||||
;; opt/info-change-val : identifier opt/info -> opt/info
|
||||
;; changes the name of the variable that the value-to-be-contracted is bound to
|
||||
(define (opt/info-change-val val info)
|
||||
(let ((ctc (opt/info-contract info))
|
||||
(pos (opt/info-neg info))
|
||||
(neg (opt/info-pos info))
|
||||
(pos (opt/info-pos info))
|
||||
(neg (opt/info-neg info))
|
||||
(positive-position? (opt/info-positive-position? info))
|
||||
(src-info (opt/info-src-info info))
|
||||
(orig-str (opt/info-orig-str info))
|
||||
(free-vars (opt/info-free-vars info))
|
||||
|
|
@ -86,7 +91,7 @@
|
|||
(base-pred (opt/info-base-pred info))
|
||||
(this (opt/info-this info))
|
||||
(that (opt/info-that info)))
|
||||
(make-opt/info ctc val neg pos src-info orig-str free-vars recf base-pred this that)))
|
||||
(make-opt/info ctc val pos neg src-info orig-str positive-position? free-vars recf base-pred this that)))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
@ -186,8 +191,9 @@
|
|||
(pos (opt/info-pos opt/info))
|
||||
(neg (opt/info-neg opt/info))
|
||||
(src-info (opt/info-src-info opt/info))
|
||||
(orig-str (opt/info-orig-str opt/info)))
|
||||
(syntax (((proj-get lift-var) lift-var) pos neg src-info orig-str))))
|
||||
(orig-str (opt/info-orig-str opt/info))
|
||||
(positive-position? (opt/info-positive-position? opt/info)))
|
||||
(syntax (((proj-get lift-var) lift-var) pos neg src-info orig-str positive-position?))))
|
||||
(cons
|
||||
partial-flat-var
|
||||
(with-syntax ((lift-var lift-var))
|
||||
|
|
|
|||
|
|
@ -65,9 +65,10 @@
|
|||
(pos (opt/info-pos opt/info))
|
||||
(neg (opt/info-neg opt/info))
|
||||
(src-info (opt/info-src-info opt/info))
|
||||
(orig-str (opt/info-orig-str opt/info)))
|
||||
(orig-str (opt/info-orig-str opt/info))
|
||||
(positive-position? (opt/info-positive-position? opt/info)))
|
||||
(syntax (let ((ctc stx))
|
||||
((((proj-get ctc) ctc) pos neg src-info orig-str) val))))
|
||||
((((proj-get ctc) ctc) pos neg src-info orig-str positive-position?) val))))
|
||||
null
|
||||
null
|
||||
null
|
||||
|
|
@ -125,6 +126,7 @@
|
|||
#'neg
|
||||
#'src-info
|
||||
#'orig-str
|
||||
#'positive-position?
|
||||
(syntax->list #'(opt-recursive-args ...))
|
||||
#f
|
||||
#f
|
||||
|
|
@ -138,7 +140,7 @@
|
|||
lifts
|
||||
#`(make-opt-contract
|
||||
(λ (ctc)
|
||||
(λ (pos neg src-info orig-str)
|
||||
(λ (pos neg src-info orig-str positive-position?)
|
||||
#,(if (syntax-parameter-value #'define/opt-recursive-fn)
|
||||
(with-syntax ([f (syntax-parameter-value #'define/opt-recursive-fn)])
|
||||
(bind-superlifts
|
||||
|
|
|
|||
|
|
@ -646,7 +646,16 @@ improve method arity mismatch contract violation error messages?
|
|||
;; No: lift the contract creation:
|
||||
(with-syntax ([contract-id contract-id]
|
||||
[id id]
|
||||
[pos-module-source pos-module-source])
|
||||
[pos-module-source pos-module-source]
|
||||
[id-ref (syntax-case stx (set!)
|
||||
[(set! whatever e)
|
||||
id] ;; just avoid an error here, signal the error later
|
||||
[(id . x)
|
||||
#'id]
|
||||
[id
|
||||
(identifier? #'id)
|
||||
#'id])])
|
||||
;(printf "id ~s ~s\n" #'id-ref (syntax->datum #'id-ref))
|
||||
(syntax-local-introduce
|
||||
(syntax-local-lift-expression
|
||||
#`(-contract contract-id
|
||||
|
|
@ -1282,7 +1291,7 @@ improve method arity mismatch contract violation error messages?
|
|||
(unpack-blame pos-blame)
|
||||
a-contract-raw
|
||||
name))
|
||||
(((contract-proc a-contract) pos-blame neg-blame src-info (contract-name a-contract))
|
||||
(((contract-proc a-contract) pos-blame neg-blame src-info (contract-name a-contract) #t)
|
||||
name)))
|
||||
|
||||
(define-syntax (recursive-contract stx)
|
||||
|
|
@ -1290,11 +1299,11 @@ improve method arity mismatch contract violation error messages?
|
|||
[(_ arg)
|
||||
(syntax (make-proj-contract
|
||||
'(recursive-contract arg)
|
||||
(λ (pos-blame neg-blame src str)
|
||||
(λ (pos-blame neg-blame src str positive-position?)
|
||||
(let ([ctc (coerce-contract 'recursive-contract arg)])
|
||||
(let ([proc (contract-proc ctc)])
|
||||
(λ (val)
|
||||
((proc pos-blame neg-blame src str) val)))))
|
||||
((proc pos-blame neg-blame src str positive-position?) val)))))
|
||||
#f))]))
|
||||
|
||||
;
|
||||
|
|
@ -1438,8 +1447,8 @@ improve method arity mismatch contract violation error messages?
|
|||
(λ (ctc)
|
||||
(let ([c-proc ((proj-get (or/c-ho-ctc ctc)) (or/c-ho-ctc ctc))]
|
||||
[pred (or/c-pred ctc)])
|
||||
(λ (pos-blame neg-blame src-info orig-str)
|
||||
(let ([partial-contract (c-proc pos-blame neg-blame src-info orig-str)])
|
||||
(λ (pos-blame neg-blame src-info orig-str positive-position?)
|
||||
(let ([partial-contract (c-proc pos-blame neg-blame src-info orig-str positive-position?)])
|
||||
(λ (val)
|
||||
(cond
|
||||
[(pred val) val]
|
||||
|
|
@ -1477,8 +1486,8 @@ improve method arity mismatch contract violation error messages?
|
|||
[c-procs (map (λ (x) ((proj-get x) x)) ho-contracts)]
|
||||
[first-order-checks (map (λ (x) ((first-order-get x) x)) ho-contracts)]
|
||||
[predicates (map flat-contract-predicate (multi-or/c-flat-ctcs ctc))])
|
||||
(λ (pos-blame neg-blame src-info orig-str)
|
||||
(let ([partial-contracts (map (λ (c-proc) (c-proc pos-blame neg-blame src-info orig-str)) c-procs)])
|
||||
(λ (pos-blame neg-blame src-info orig-str positive-position?)
|
||||
(let ([partial-contracts (map (λ (c-proc) (c-proc pos-blame neg-blame src-info orig-str positive-position?)) c-procs)])
|
||||
(λ (val)
|
||||
(cond
|
||||
[(ormap (λ (pred) (pred val)) predicates)
|
||||
|
|
@ -1594,8 +1603,9 @@ improve method arity mismatch contract violation error messages?
|
|||
(pos (opt/info-pos opt/info))
|
||||
(neg (opt/info-neg opt/info))
|
||||
(src-info (opt/info-src-info opt/info))
|
||||
(orig-str (opt/info-orig-str opt/info)))
|
||||
(syntax (((proj-get lift-var) lift-var) pos neg src-info orig-str)))))
|
||||
(orig-str (opt/info-orig-str opt/info))
|
||||
(positive-position? (opt/info-orig-str opt/info)))
|
||||
(syntax (((proj-get lift-var) lift-var) pos neg src-info orig-str positive-position?)))))
|
||||
#f
|
||||
lift-var
|
||||
(list #f)
|
||||
|
|
@ -2041,8 +2051,8 @@ improve method arity mismatch contract violation error messages?
|
|||
(let ([proj (contract-proc ctc)])
|
||||
(make-proj-contract
|
||||
(build-compound-type-name 'name ctc)
|
||||
(λ (pos-blame neg-blame src-info orig-str)
|
||||
(let ([p-app (proj pos-blame neg-blame src-info orig-str)])
|
||||
(λ (pos-blame neg-blame src-info orig-str positive-position?)
|
||||
(let ([p-app (proj pos-blame neg-blame src-info orig-str positive-position?)])
|
||||
(λ (val)
|
||||
(unless (predicate? val)
|
||||
(raise-contract-error
|
||||
|
|
@ -2204,8 +2214,8 @@ improve method arity mismatch contract violation error messages?
|
|||
(let ([procs (contract-proc ctc-x)] ...)
|
||||
(make-proj-contract
|
||||
(build-compound-type-name 'name ctc-x ...)
|
||||
(λ (pos-blame neg-blame src-info orig-str)
|
||||
(let ([p-apps (procs pos-blame neg-blame src-info orig-str)] ...)
|
||||
(λ (pos-blame neg-blame src-info orig-str positive-position?)
|
||||
(let ([p-apps (procs pos-blame neg-blame src-info orig-str positive-position?)] ...)
|
||||
(λ (v)
|
||||
(if #,(if test-immutable?
|
||||
#'(and (predicate?-name v)
|
||||
|
|
@ -2234,8 +2244,8 @@ improve method arity mismatch contract violation error messages?
|
|||
(let ([procs (map contract-proc ctcs)])
|
||||
(make-proj-contract
|
||||
(apply build-compound-type-name 'name ctcs)
|
||||
(λ (pos-blame neg-blame src-info orig-str)
|
||||
(let ([p-apps (map (λ (proc) (proc pos-blame neg-blame src-info orig-str)) procs)]
|
||||
(λ (pos-blame neg-blame src-info orig-str positive-position?)
|
||||
(let ([p-apps (map (λ (proc) (proc pos-blame neg-blame src-info orig-str positive-position?)) procs)]
|
||||
[count (length params)])
|
||||
(λ (v)
|
||||
(if (and (immutable? v)
|
||||
|
|
@ -2336,8 +2346,8 @@ improve method arity mismatch contract violation error messages?
|
|||
[ctc-proc (contract-proc ctc)])
|
||||
(make-proj-contract
|
||||
(build-compound-type-name 'promise/c ctc)
|
||||
(λ (pos-blame neg-blame src-info orig-str)
|
||||
(let ([p-app (ctc-proc pos-blame neg-blame src-info orig-str)])
|
||||
(λ (pos-blame neg-blame src-info orig-str positive-position?)
|
||||
(let ([p-app (ctc-proc pos-blame neg-blame src-info orig-str positive-position?)])
|
||||
(λ (val)
|
||||
(unless (promise? val)
|
||||
(raise-contract-error
|
||||
|
|
@ -2427,9 +2437,9 @@ improve method arity mismatch contract violation error messages?
|
|||
#:property proj-prop
|
||||
(λ (ctc)
|
||||
(let ([c-proc ((proj-get (parameter/c-ctc ctc)) (parameter/c-ctc ctc))])
|
||||
(λ (pos-blame neg-blame src-info orig-str)
|
||||
(let ([partial-neg-contract (c-proc neg-blame pos-blame src-info orig-str)]
|
||||
[partial-pos-contract (c-proc pos-blame neg-blame src-info orig-str)])
|
||||
(λ (pos-blame neg-blame src-info orig-str positive-position?)
|
||||
(let ([partial-neg-contract (c-proc neg-blame pos-blame src-info orig-str (not positive-position?))]
|
||||
[partial-pos-contract (c-proc pos-blame neg-blame src-info orig-str positive-position?)])
|
||||
(λ (val)
|
||||
(cond
|
||||
[(parameter? val)
|
||||
|
|
@ -2499,9 +2509,9 @@ improve method arity mismatch contract violation error messages?
|
|||
(let ([dom-proc ((proj-get (hash/c-dom ctc)) (hash/c-dom ctc))]
|
||||
[rng-proc ((proj-get (hash/c-rng ctc)) (hash/c-rng ctc))]
|
||||
[immutable (hash/c-immutable ctc)])
|
||||
(λ (pos-blame neg-blame src-info orig-str)
|
||||
(let ([partial-dom-contract (dom-proc pos-blame neg-blame src-info orig-str)]
|
||||
[partial-rng-contract (rng-proc pos-blame neg-blame src-info orig-str)])
|
||||
(λ (pos-blame neg-blame src-info orig-str positive-position?)
|
||||
(let ([partial-dom-contract (dom-proc pos-blame neg-blame src-info orig-str positive-position?)]
|
||||
[partial-rng-contract (rng-proc pos-blame neg-blame src-info orig-str positive-position?)])
|
||||
(λ (val)
|
||||
(unless (hash? val)
|
||||
(raise-contract-error val src-info pos-blame orig-str
|
||||
|
|
@ -2541,9 +2551,9 @@ improve method arity mismatch contract violation error messages?
|
|||
(λ (ctc)
|
||||
(let ([dom-proc ((proj-get (immutable-hash/c-dom ctc)) (immutable-hash/c-dom ctc))]
|
||||
[rng-proc ((proj-get (immutable-hash/c-rng ctc)) (immutable-hash/c-rng ctc))])
|
||||
(λ (pos-blame neg-blame src-info orig-str)
|
||||
(let ([partial-dom-contract (dom-proc pos-blame neg-blame src-info orig-str)]
|
||||
[partial-rng-contract (rng-proc pos-blame neg-blame src-info orig-str)])
|
||||
(λ (pos-blame neg-blame src-info orig-str positive-position?)
|
||||
(let ([partial-dom-contract (dom-proc pos-blame neg-blame src-info orig-str positive-position?)]
|
||||
[partial-rng-contract (rng-proc pos-blame neg-blame src-info orig-str positive-position?)])
|
||||
(λ (val)
|
||||
(unless (and (hash? val)
|
||||
(immutable? val))
|
||||
|
|
|
|||
|
|
@ -852,13 +852,13 @@ as well as a record of the source location where the
|
|||
contract was established and the name of the contract. They
|
||||
can then, in turn, pass that information
|
||||
to @scheme[raise-contract-error] to signal a good error
|
||||
message (see below for details on its behavior).
|
||||
message.
|
||||
|
||||
Here is the first of those two projections, rewritten for
|
||||
use in the contract system:
|
||||
|
||||
@schemeblock[
|
||||
(define (int-proj pos neg src-info name)
|
||||
(define (int-proj pos neg src-info name positive-position?)
|
||||
(lambda (x)
|
||||
(if (integer? x)
|
||||
x
|
||||
|
|
@ -873,7 +873,9 @@ use in the contract system:
|
|||
|
||||
The first two new arguments specify who is to be blamed for
|
||||
positive and negative contract violations,
|
||||
respectively. Contracts, in this system, are always
|
||||
respectively.
|
||||
|
||||
Contracts, in this system, are always
|
||||
established between two parties. One party provides some
|
||||
value according to the contract, and the other consumes the
|
||||
value, also according to the contract. The first is called
|
||||
|
|
@ -887,9 +889,9 @@ to @scheme[raise-contract-error]).
|
|||
Compare that to the projection for our function contract:
|
||||
|
||||
@schemeblock[
|
||||
(define (int->int-proj pos neg src-info name)
|
||||
(let ([dom (int-proj neg pos src-info name)]
|
||||
[rng (int-proj pos neg src-info name)])
|
||||
(define (int->int-proj pos neg src-info name positive-position?)
|
||||
(let ([dom (int-proj neg pos src-info name (not positive-position?))]
|
||||
[rng (int-proj pos neg src-info name positive-position?)])
|
||||
(lambda (f)
|
||||
(if (and (procedure? f)
|
||||
(procedure-arity-includes? f 1))
|
||||
|
|
@ -944,9 +946,9 @@ returns a contract for functions between them.
|
|||
|
||||
@schemeblock[
|
||||
(define (make-simple-function-contract dom-proj range-proj)
|
||||
(lambda (pos neg src-info name)
|
||||
(let ([dom (dom-proj neg pos src-info name)]
|
||||
[rng (range-proj pos neg src-info name)])
|
||||
(lambda (pos neg src-info name positive-position?)
|
||||
(let ([dom (dom-proj neg pos src-info name (not positive-position?))]
|
||||
[rng (range-proj pos neg src-info name positive-position?)])
|
||||
(lambda (f)
|
||||
(if (and (procedure? f)
|
||||
(procedure-arity-includes? f 1))
|
||||
|
|
@ -966,19 +968,21 @@ other, new kinds of value you might make, can be used with
|
|||
the contract library primitives below.
|
||||
|
||||
@defproc[(make-proj-contract [name any/c]
|
||||
[proj (symbol? symbol? any/c any/c . -> . any/c)]
|
||||
[proj (or/c (-> symbol? symbol? any/c any/c any/c)
|
||||
(-> symbol? symbol? any/c any/c boolean? any/c))]
|
||||
[first-order-test (any/c . -> . any/c)])
|
||||
contract?]{
|
||||
|
||||
The simplest way to build a contract. It can be less
|
||||
efficient than using other contract constructors described
|
||||
below, but it is the right choice for new contract
|
||||
constructors or first-time contract builders.
|
||||
|
||||
Builds a new contract.
|
||||
|
||||
The first argument is the name of the contract. It can be an
|
||||
arbitrary S-expression. The second is a projection (see
|
||||
above).
|
||||
|
||||
If the projection only takes four arguments, then the
|
||||
positive position boolean is not passed to it (this is
|
||||
for backwards compatibility).
|
||||
|
||||
The final argument is a predicate that is a
|
||||
conservative, first-order test of a value. It should be a
|
||||
function that accepts one argument and returns a boolean. If
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user