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

changed the low-level api for contracts so the projections accept an extra argument indicating if the contract is being used positively or negatively

Browse Source 
svn: r15850

original commit: 5c73253e03e6415de5ad0b2c3b8ec4fb82a9e1b6
This commit is contained in:
Robby Findler 2009-09-01 16:25:08 +00:00
parent 6d7ced9578
commit 170af53e07
3 changed files with 113 additions and 86 deletions

181
collects/mzlib/private/contract-arr-obj-helpers.ss
View File

@ -19,9 +19,9 @@
(define (make-/proc method-proc? /h stx) (define (make-/proc method-proc? /h stx)
(let-values ([(arguments-check build-proj check-val first-order-check wrapper) (let-values ([(arguments-check build-proj check-val first-order-check wrapper)
(/h method-proc? stx)]) (/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)] (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)]) [(val-args body) (wrapper outer-args)])
(with-syntax ([inner-lambda (with-syntax ([inner-lambda
(set-inferred-name-from (set-inferred-name-from
@ -39,7 +39,7 @@
(syntax/loc stx (syntax/loc stx
(make-proj-contract (make-proj-contract
name-id name-id
(lambda (pos-blame neg-blame src-info orig-str) (lambda (pos-blame neg-blame src-info orig-str positive-position?)
proj-code) proj-code)
first-order-check)))))))))) first-order-check))))))))))
@ -55,9 +55,9 @@
[(_ cases ...) [(_ cases ...)
(let-values ([(arguments-check build-projs check-val first-order-check wrapper) (let-values ([(arguments-check build-projs check-val first-order-check wrapper)
(case->/h method-proc? stx (syntax->list (syntax (cases ...))) select/h)]) (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)] (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)]) [(body ...) (wrapper outer-args)])
(with-syntax ([inner-lambda (with-syntax ([inner-lambda
(set-inferred-name-from (set-inferred-name-from
@ -75,7 +75,7 @@
(syntax/loc stx (syntax/loc stx
(make-proj-contract (make-proj-contract
(apply build-compound-type-name 'case-> name-id) (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) proj-code)
first-order-check)))))))))])) first-order-check)))))))))]))
@ -230,7 +230,7 @@
[(null? cases) [(null? cases)
(values (values
(lambda (outer-args body) (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] [body body]
[(name-ids ...) (reverse name-ids)]) [(name-ids ...) (reverse name-ids)])
(syntax (syntax
@ -249,10 +249,10 @@
(/h method-proc? (car cases))]) (/h method-proc? (car cases))])
(values (values
(lambda (outer-args x) (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]) [new-id new-id])
(arguments-check (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 (arguments-checks
outer-args outer-args
x)))) x))))
@ -364,7 +364,7 @@
(values (values
(lambda (outer-args body) (lambda (outer-args body)
(with-syntax ([body 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 (syntax
(let ([dom-contract-x (coerce-contract '-> dom)] ...) (let ([dom-contract-x (coerce-contract '-> dom)] ...)
(let ([dom-x (contract-proc dom-contract-x)] ...) (let ([dom-x (contract-proc dom-contract-x)] ...)
@ -373,19 +373,19 @@
;; proj ;; proj
(lambda (outer-args inner-lambda) (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]) [inner-lambda inner-lambda])
(syntax (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)))) inner-lambda))))
(lambda (outer-args) (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 (syntax
(check-procedure val dom-length 0 '() '() #|keywords|# src-info pos-blame orig-str)))) (check-procedure val dom-length 0 '() '() #|keywords|# src-info pos-blame orig-str))))
(syntax (check-procedure? dom-length)) (syntax (check-procedure? dom-length))
(lambda (outer-args) (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 (syntax
((arg-x ...) ((arg-x ...)
(val (dom-projection-x arg-x) ...))))))] (val (dom-projection-x arg-x) ...))))))]
@ -399,7 +399,7 @@
(values (values
(lambda (outer-args body) (lambda (outer-args body)
(with-syntax ([body 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 (syntax
(let ([dom-contract-x (coerce-contract '-> dom)] (let ([dom-contract-x (coerce-contract '-> dom)]
... ...
@ -417,22 +417,22 @@
;; proj ;; proj
(lambda (outer-args inner-lambda) (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]) [inner-lambda inner-lambda])
(syntax (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)))) inner-lambda))))
(lambda (outer-args) (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 (syntax
(check-procedure val dom-length 0 '() '() #|keywords|# src-info pos-blame orig-str)))) (check-procedure val dom-length 0 '() '() #|keywords|# src-info pos-blame orig-str))))
(syntax (check-procedure? dom-length)) (syntax (check-procedure? dom-length))
(lambda (outer-args) (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 (syntax
((arg-x ...) ((arg-x ...)
(let-values ([(res-x ...) (val (dom-projection-x arg-x) ...)]) (let-values ([(res-x ...) (val (dom-projection-x arg-x) ...)])
@ -448,7 +448,7 @@
(values (values
(lambda (outer-args body) (lambda (outer-args body)
(with-syntax ([body 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 (syntax
(let ([dom-contract-x (coerce-contract '-> dom)] (let ([dom-contract-x (coerce-contract '-> dom)]
... ...
@ -461,21 +461,21 @@
;; proj ;; proj
(lambda (outer-args inner-lambda) (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]) [inner-lambda inner-lambda])
(syntax (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)))) inner-lambda))))
(lambda (outer-args) (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 (syntax
(check-procedure val dom-length 0 '() '() #|keywords|# src-info pos-blame orig-str)))) (check-procedure val dom-length 0 '() '() #|keywords|# src-info pos-blame orig-str))))
(syntax (check-procedure? dom-length)) (syntax (check-procedure? dom-length))
(lambda (outer-args) (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 (syntax
((arg-x ...) ((arg-x ...)
(let ([res-x (val (dom-projection-x arg-x) ...)]) (let ([res-x (val (dom-projection-x arg-x) ...)])
@ -509,7 +509,7 @@
[arity (length (syntax->list (syntax (dom ...))))]) [arity (length (syntax->list (syntax (dom ...))))])
(values (values
(lambda (outer-args body) (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] [body body]
[(name-dom-contract-x ...) [(name-dom-contract-x ...)
(if method-proc? (if method-proc?
@ -536,22 +536,22 @@
body)))))) body))))))
;; proj ;; proj
(lambda (outer-args inner-lambda) (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]) [inner-lambda inner-lambda])
(syntax (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?))]
[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)))) inner-lambda))))
(lambda (outer-args) (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 (syntax
(check-procedure/more val dom-length '() '() #|keywords|# src-info pos-blame orig-str)))) (check-procedure/more val dom-length '() '() #|keywords|# src-info pos-blame orig-str))))
(syntax (check-procedure/more? dom-length)) (syntax (check-procedure/more? dom-length))
(lambda (outer-args) (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 (syntax
((arg-x ... . arg-rest-x) ((arg-x ... . arg-rest-x)
(let-values ([(res-x ...) (let-values ([(res-x ...)
@ -577,7 +577,7 @@
(values (values
(lambda (outer-args body) (lambda (outer-args body)
(with-syntax ([body 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 ...) [(name-dom-contract-x ...)
(if method-proc? (if method-proc?
(cdr (cdr
@ -599,21 +599,21 @@
body)))))) body))))))
;; proj ;; proj
(lambda (outer-args inner-lambda) (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]) [inner-lambda inner-lambda])
(syntax (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)))) inner-lambda))))
(lambda (outer-args) (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 (syntax
(check-procedure/more val dom-length '() '() #|keywords|# src-info pos-blame orig-str)))) (check-procedure/more val dom-length '() '() #|keywords|# src-info pos-blame orig-str))))
(syntax (check-procedure/more? dom-length)) (syntax (check-procedure/more? dom-length))
(lambda (outer-args) (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 (syntax
((arg-x ... . arg-rest-x) ((arg-x ... . arg-rest-x)
(apply (apply
@ -636,7 +636,7 @@
(values (values
(lambda (outer-args body) (lambda (outer-args body)
(with-syntax ([body 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 ...) [(name-dom-contract-x ...)
(if method-proc? (if method-proc?
(cdr (cdr
@ -654,21 +654,21 @@
;; proj ;; proj
(lambda (outer-args inner-lambda) (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]) [inner-lambda inner-lambda])
(syntax (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)))) inner-lambda))))
(lambda (outer-args) (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 (syntax
(check-procedure val arity 0 '() '() #|keywords|# src-info pos-blame orig-str)))) (check-procedure val arity 0 '() '() #|keywords|# src-info pos-blame orig-str))))
(syntax (check-procedure? arity)) (syntax (check-procedure? arity))
(lambda (outer-args) (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 (syntax
((arg-x ...) ((arg-x ...)
(let ([arg-x (dom-projection-x arg-x)] ...) (let ([arg-x (dom-projection-x arg-x)] ...)
@ -677,7 +677,8 @@
pos-blame pos-blame
neg-blame neg-blame
src-info src-info
orig-str) orig-str
positive-position?)
(val arg-x ...))))))))))])) (val arg-x ...))))))))))]))
;; ->d*/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) ;; ->d*/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
@ -693,7 +694,7 @@
(values (values
(lambda (outer-args body) (lambda (outer-args body)
(with-syntax ([body 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 ...) [(name-dom-contract-x ...)
(if method-proc? (if method-proc?
(cdr (cdr
@ -714,20 +715,20 @@
;; proj ;; proj
(lambda (outer-args inner-lambda) (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]) [inner-lambda inner-lambda])
(syntax (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)))) inner-lambda))))
(lambda (outer-args) (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 (syntax
(check-procedure val dom-length 0 '() '() #|keywords|# src-info pos-blame orig-str)))) (check-procedure val dom-length 0 '() '() #|keywords|# src-info pos-blame orig-str))))
(syntax (check-procedure? dom-length)) (syntax (check-procedure? dom-length))
(lambda (outer-args) (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 (syntax
((arg-x ...) ((arg-x ...)
(call-with-values (call-with-values
@ -745,7 +746,8 @@
pos-blame pos-blame
neg-blame neg-blame
src-info src-info
orig-str) orig-str
positive-position?)
result)) result))
rng-contracts rng-contracts
results))))))))))))] results))))))))))))]
@ -761,7 +763,7 @@
(values (values
(lambda (outer-args body) (lambda (outer-args body)
(with-syntax ([body 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 ...) [(name-dom-contract-x ...)
(if method-proc? (if method-proc?
(cdr (cdr
@ -786,22 +788,22 @@
;; proj ;; proj
(lambda (outer-args inner-lambda) (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]) [inner-lambda inner-lambda])
(syntax (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)))) inner-lambda))))
(lambda (outer-args) (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 (syntax
(check-procedure/more val arity '() '() #|keywords|# src-info pos-blame orig-str)))) (check-procedure/more val arity '() '() #|keywords|# src-info pos-blame orig-str))))
(syntax (check-procedure/more? arity)) (syntax (check-procedure/more? arity))
(lambda (outer-args) (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 (syntax
((arg-x ... . rest-arg-x) ((arg-x ... . rest-arg-x)
(call-with-values (call-with-values
@ -824,7 +826,8 @@
pos-blame pos-blame
neg-blame neg-blame
src-info src-info
orig-str) orig-str
positive-position?)
result)) result))
rng-contracts rng-contracts
results))))))))))))])) results))))))))))))]))
@ -877,14 +880,14 @@
(values (values
(lambda (outer-args body) (lambda (outer-args body)
(with-syntax ([body 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 (syntax
(let ([name-id name-stx]) (let ([name-id name-stx])
body)))) body))))
(lambda (outer-args inner-lambda) inner-lambda) (lambda (outer-args inner-lambda) inner-lambda)
(lambda (outer-args) (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)]) [kind-of-thing (if method-proc? 'method 'procedure)])
(syntax (syntax
(begin (begin
@ -893,14 +896,16 @@
(syntax (check-procedure? arity)) (syntax (check-procedure? arity))
(lambda (outer-args) (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=? (syntax-case* (syntax result-stuff) (any values) module-or-top-identifier=?
[(any) [(any)
(syntax (syntax
((x ...) ((x ...)
(begin (begin
(check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str) (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) ...)))))] (val (dom-id x) ...)))))]
[((values (rng-ids rng-ctc) ...) post-expr) [((values (rng-ids rng-ctc) ...) post-expr)
@ -911,12 +916,15 @@
((x ...) ((x ...)
(begin (begin
(check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str) (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) ...)]) (let-values ([(rng-ids ...) (val (dom-id x) ...)])
(check-post-expr->pp/h val post-expr src-info pos-blame orig-str) (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)) (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-x rng-ids) ...))))))))]
[((values (rng-ids rng-ctc) ...) post-expr) [((values (rng-ids rng-ctc) ...) post-expr)
(andmap identifier? (syntax->list (syntax (rng-ids ...)))) (andmap identifier? (syntax->list (syntax (rng-ids ...))))
@ -934,9 +942,13 @@
((x ...) ((x ...)
(begin (begin
(check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str) (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) ...))]) (let ([res-id (rng-id (val (dom-id x) ...))])
(check-post-expr->pp/h val post-expr src-info pos-blame orig-str) (check-post-expr->pp/h val post-expr src-info pos-blame orig-str)
res-id)))))] res-id)))))]
@ -988,14 +1000,14 @@
(values (values
(lambda (outer-args body) (lambda (outer-args body)
(with-syntax ([body 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 (syntax
(let ([name-id name-stx]) (let ([name-id name-stx])
body)))) body))))
(lambda (outer-args inner-lambda) inner-lambda) (lambda (outer-args inner-lambda) inner-lambda)
(lambda (outer-args) (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)]) [kind-of-thing (if method-proc? 'method 'procedure)])
(syntax (syntax
(begin (begin
@ -1003,16 +1015,20 @@
(syntax (check-procedure/more? arity)) (syntax (check-procedure/more? arity))
(lambda (outer-args) (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=? (syntax-case* (syntax result-stuff) (values any) module-or-top-identifier=?
[(any) [(any)
(syntax (syntax
((x ... . rest-x) ((x ... . rest-x)
(begin (begin
(check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str) (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))))))] (apply val (dom-id x) ... (rest-id rest-x))))))]
[(any . x) [(any . x)
(raise-syntax-error name "cannot have anything after any" stx (syntax result-stuff))] (raise-syntax-error name "cannot have anything after any" stx (syntax result-stuff))]
@ -1024,13 +1040,18 @@
((x ... . rest-x) ((x ... . rest-x)
(begin (begin
(check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str) (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))]) (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) (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)) (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-x rng-ids) ...))))))))]
[((values (rng-ids rng-ctc) ...) . whatever) [((values (rng-ids rng-ctc) ...) . whatever)
(and (andmap identifier? (syntax->list (syntax (rng-ids ...)))) (and (andmap identifier? (syntax->list (syntax (rng-ids ...))))
@ -1053,10 +1074,16 @@
((x ... . rest-x) ((x ... . rest-x)
(begin (begin
(check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str) (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))
[rng-id ((contract-proc (coerce-contract 'stx-name rng)) pos-blame neg-blame src-info orig-str)]) 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)))]) (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) (check-post-expr->pp/h val post-expr src-info pos-blame orig-str)
res-id)))))] res-id)))))]

12
collects/mzlib/private/contract-arrow.ss
View File

@ -33,8 +33,8 @@
(let ([proj-x ((proj-get rngs-x) rngs-x)] ...) (let ([proj-x ((proj-get rngs-x) rngs-x)] ...)
(make-proj-contract (make-proj-contract
(build-compound-type-name 'unconstrained-domain-> ((name-get rngs-x) rngs-x) ...) (build-compound-type-name 'unconstrained-domain-> ((name-get rngs-x) rngs-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)] ...) (let ([p-app-x (proj-x pos-blame neg-blame src-info orig-str positive-position?)] ...)
(λ (val) (λ (val)
(if (procedure? val) (if (procedure? val)
(λ args (λ args
@ -76,12 +76,12 @@
[func (->-func ctc)] [func (->-func ctc)]
[dom-length (length (->-doms ctc))] [dom-length (length (->-doms ctc))]
[has-rest? (and (->-dom-rest ctc) #t)]) [has-rest? (and (->-dom-rest ctc) #t)])
(lambda (pos-blame neg-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)) (let ([partial-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str (not positive-position?)))
doms/c)] 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)] 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)]) kwds/c)])
(apply func (apply func
(λ (val) (λ (val)

6
collects/mzlib/private/contract-object.ss
View File

@ -344,10 +344,10 @@
`(object-contract `(object-contract
,(build-compound-type-name 'method-name method-ctc-var) ... ,(build-compound-type-name 'method-name method-ctc-var) ...
,(build-compound-type-name 'field 'field-name field-ctc-var) ...) ,(build-compound-type-name 'field 'field-name field-ctc-var) ...)
(lambda (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)] (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 ...)]) (let ([field-names-list '(field-name ...)])
(lambda (val) (lambda (val)