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

updated pconvert to use the new arguments to make-hash and friends

Browse Source 
svn: r18128

original commit: 66e329c21b8e817959f2704668ed77dcbca47dfb
This commit is contained in:
Robby Findler 2010-02-17 21:20:39 +00:00
commit 7959381ae0
9 changed files with 281 additions and 385 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
collects/mzlib/contract.ss
View File

@ -48,48 +48,11 @@
check-between/c check-between/c
string-len/c string-len/c
check-unary-between/c) check-unary-between/c)
(rename-out [string-len/c string/len])) (rename-out [or/c union])
(rename-out [string-len/c string/len])
;; from contract-guts.ss (except-out (all-from-out scheme/contract/private/guts)
check-flat-contract
(provide any check-flat-named-contract))
and/c
any/c
none/c
make-none/c
guilty-party
contract-violation->string
contract?
contract-name
contract-proc
flat-contract?
flat-contract
flat-contract-predicate
flat-named-contract
contract-first-order-passes?
;; below need docs
make-proj-contract
contract-stronger?
coerce-contract
flat-contract/predicate?
build-compound-type-name
raise-contract-error
proj-prop proj-pred? proj-get
name-prop name-pred? name-get
stronger-prop stronger-pred? stronger-get
flat-prop flat-pred? flat-get
first-order-prop first-order-get
(rename-out [or/c union]))
;; copied here because not provided by scheme/contract anymore ;; copied here because not provided by scheme/contract anymore

82
collects/mzlib/private/contract-arr-checks.ss
View File

@ -77,31 +77,21 @@
f))) f)))
(define (check-pre-expr->pp/h val pre-expr src-info blame orig-str) (define (check-pre-expr->pp/h val pre-expr blame)
(unless pre-expr (unless pre-expr
(raise-contract-error val (raise-blame-error blame val "pre-condition expression failure")))
src-info
blame
orig-str
"pre-condition expression failure")))
(define (check-post-expr->pp/h val post-expr src-info blame orig-str) (define (check-post-expr->pp/h val post-expr blame)
(unless post-expr (unless post-expr
(raise-contract-error val (raise-blame-error blame val "post-condition expression failure")))
src-info
blame
orig-str
"post-condition expression failure")))
(define (check-procedure val dom-length optionals mandatory-kwds optional-keywords src-info blame orig-str) (define (check-procedure val dom-length optionals mandatory-kwds optional-keywords blame)
(unless (and (procedure? val) (unless (and (procedure? val)
(procedure-arity-includes?/optionals val dom-length optionals) (procedure-arity-includes?/optionals val dom-length optionals)
(keywords-match mandatory-kwds optional-keywords val)) (keywords-match mandatory-kwds optional-keywords val))
(raise-contract-error (raise-blame-error
val
src-info
blame blame
orig-str val
"expected a procedure that accepts ~a arguments~a, given: ~e" "expected a procedure that accepts ~a arguments~a, given: ~e"
dom-length dom-length
(keyword-error-text mandatory-kwds) (keyword-error-text mandatory-kwds)
@ -140,53 +130,37 @@
(and (procedure? val) (and (procedure? val)
(procedure-accepts-and-more? val arity))) (procedure-accepts-and-more? val arity)))
(define (check-procedure/kind val arity kind-of-thing src-info blame orig-str) (define (check-procedure/kind val arity kind-of-thing blame)
(unless (procedure? val) (unless (procedure? val)
(raise-contract-error val (raise-blame-error blame val "expected a procedure, got ~e" val))
src-info
blame
orig-str
"expected a procedure, got ~e"
val))
(unless (procedure-arity-includes? val arity) (unless (procedure-arity-includes? val arity)
(raise-contract-error val (raise-blame-error blame
src-info val
blame "expected a ~a of arity ~a (not arity ~a), got ~e"
orig-str kind-of-thing
"expected a ~a of arity ~a (not arity ~a), got ~e" arity
kind-of-thing (procedure-arity val)
arity val)))
(procedure-arity val)
val)))
(define (check-procedure/more/kind val arity kind-of-thing src-info blame orig-str) (define (check-procedure/more/kind val arity kind-of-thing blame)
(unless (procedure? val) (unless (procedure? val)
(raise-contract-error val (raise-blame-error blame val "expected a procedure, got ~e" val))
src-info
blame
orig-str
"expected a procedure, got ~e"
val))
(unless (procedure-accepts-and-more? val arity) (unless (procedure-accepts-and-more? val arity)
(raise-contract-error val (raise-blame-error blame
src-info val
blame "expected a ~a that accepts ~a arguments and aribtrarily more (not arity ~a), got ~e"
orig-str kind-of-thing
"expected a ~a that accepts ~a arguments and aribtrarily more (not arity ~a), got ~e" arity
kind-of-thing (procedure-arity val)
arity val)))
(procedure-arity val)
val)))
(define (check-procedure/more val dom-length mandatory-kwds optional-kwds src-info blame orig-str) (define (check-procedure/more val dom-length mandatory-kwds optional-kwds blame)
(unless (and (procedure? val) (unless (and (procedure? val)
(procedure-accepts-and-more? val dom-length) (procedure-accepts-and-more? val dom-length)
(keywords-match mandatory-kwds optional-kwds val)) (keywords-match mandatory-kwds optional-kwds val))
(raise-contract-error (raise-blame-error
val
src-info
blame blame
orig-str val
"expected a procedure that accepts ~a arguments and and arbitrarily more~a, given: ~e" "expected a procedure that accepts ~a arguments and and arbitrarily more~a, given: ~e"
dom-length dom-length
(keyword-error-text mandatory-kwds) (keyword-error-text mandatory-kwds)

293
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 positive-position?))]) (let ([outer-args (syntax (val blame name-id))])
(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 positive-position?) outer-args] [(val blame name-id) 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
@ -37,11 +37,10 @@
(arguments-check (arguments-check
outer-args outer-args
(syntax/loc stx (syntax/loc stx
(make-proj-contract (simple-contract
name-id #:name name-id
(lambda (pos-blame neg-blame src-info orig-str positive-position?) #:projection (lambda (blame) proj-code)
proj-code) #:first-order first-order-check))))))))))
first-order-check))))))))))
(define (make-case->/proc method-proc? stx inferred-name-stx select/h) (define (make-case->/proc method-proc? stx inferred-name-stx select/h)
(syntax-case stx () (syntax-case stx ()
@ -55,9 +54,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 positive-position?))]) (let ([outer-args (syntax (val blame name-id))])
(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 positive-position?) outer-args] [(val blame name-id) 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
@ -73,11 +72,10 @@
(arguments-check (arguments-check
outer-args outer-args
(syntax/loc stx (syntax/loc stx
(make-proj-contract (simple-contract
(apply build-compound-type-name 'case-> name-id) #:name (apply build-compound-type-name 'case-> name-id)
(lambda (pos-blame neg-blame src-info orig-str positive-position?) #:projection (lambda (blame) proj-code)
proj-code) #:first-order first-order-check)))))))))]))
first-order-check)))))))))]))
(define (make-opt->/proc method-proc? stx select/h case-arr-stx arr-stx) (define (make-opt->/proc method-proc? stx select/h case-arr-stx arr-stx)
(syntax-case stx (any) (syntax-case stx (any)
@ -230,7 +228,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 positive-position?) outer-args] (with-syntax ([(val blame name-id) outer-args]
[body body] [body body]
[(name-ids ...) (reverse name-ids)]) [(name-ids ...) (reverse name-ids)])
(syntax (syntax
@ -249,10 +247,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 positive-position?) outer-args] (with-syntax ([(val blame name-id) 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 positive-position?)) (syntax (val blame new-id))
(arguments-checks (arguments-checks
outer-args outer-args
x)))) x))))
@ -364,28 +362,28 @@
(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 positive-position?) outer-args]) [(val blame name-id) 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-projection dom-contract-x)] ...)
(let ([name-id (build-compound-type-name '-> name-dom-contract-x ... 'any)]) (let ([name-id (build-compound-type-name '-> name-dom-contract-x ... 'any)])
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 positive-position?) outer-args] (with-syntax ([(val blame name-id) 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 (not positive-position?))] ...) (let ([dom-projection-x (dom-x (blame-swap blame))] ...)
inner-lambda)))) inner-lambda))))
(lambda (outer-args) (lambda (outer-args)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) (with-syntax ([(val blame name-id) outer-args])
(syntax (syntax
(check-procedure val dom-length 0 '() '() #|keywords|# src-info pos-blame orig-str)))) (check-procedure val dom-length 0 '() '() #|keywords|# blame))))
(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 positive-position?) outer-args]) (with-syntax ([(val blame name-id) outer-args])
(syntax (syntax
((arg-x ...) ((arg-x ...)
(val (dom-projection-x arg-x) ...))))))] (val (dom-projection-x arg-x) ...))))))]
@ -399,14 +397,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 positive-position?) outer-args]) [(val blame name-id) outer-args])
(syntax (syntax
(let ([dom-contract-x (coerce-contract '-> dom)] (let ([dom-contract-x (coerce-contract '-> dom)]
... ...
[rng-contract-x (coerce-contract '-> rng)] ...) [rng-contract-x (coerce-contract '-> rng)] ...)
(let ([dom-x (contract-proc dom-contract-x)] (let ([dom-x (contract-projection dom-contract-x)]
... ...
[rng-x (contract-proc rng-contract-x)] [rng-x (contract-projection rng-contract-x)]
...) ...)
(let ([name-id (let ([name-id
(build-compound-type-name (build-compound-type-name
@ -417,22 +415,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 positive-position?) outer-args] (with-syntax ([(val blame name-id) 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 (not positive-position?))] (let ([dom-projection-x (dom-x (blame-swap blame))]
... ...
[rng-projection-x (rng-x pos-blame neg-blame src-info orig-str positive-position?)] ...) [rng-projection-x (rng-x blame)] ...)
inner-lambda)))) inner-lambda))))
(lambda (outer-args) (lambda (outer-args)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) (with-syntax ([(val blame name-id) outer-args])
(syntax (syntax
(check-procedure val dom-length 0 '() '() #|keywords|# src-info pos-blame orig-str)))) (check-procedure val dom-length 0 '() '() #|keywords|# blame))))
(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 positive-position?) outer-args]) (with-syntax ([(val blame name-id) 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,34 +446,34 @@
(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 positive-position?) outer-args]) [(val blame name-id) outer-args])
(syntax (syntax
(let ([dom-contract-x (coerce-contract '-> dom)] (let ([dom-contract-x (coerce-contract '-> dom)]
... ...
[rng-contract-x (coerce-contract '-> rng)]) [rng-contract-x (coerce-contract '-> rng)])
(let ([dom-x (contract-proc dom-contract-x)] (let ([dom-x (contract-projection dom-contract-x)]
... ...
[rng-x (contract-proc rng-contract-x)]) [rng-x (contract-projection rng-contract-x)])
(let ([name-id (build-compound-type-name '-> name-dom-contract-x ... rng-contract-x)]) (let ([name-id (build-compound-type-name '-> name-dom-contract-x ... rng-contract-x)])
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 positive-position?) outer-args] (with-syntax ([(val blame name-id) 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 (not positive-position?))] (let ([dom-projection-x (dom-x (blame-swap blame))]
... ...
[rng-projection-x (rng-x pos-blame neg-blame src-info orig-str positive-position?)]) [rng-projection-x (rng-x blame)])
inner-lambda)))) inner-lambda))))
(lambda (outer-args) (lambda (outer-args)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) (with-syntax ([(val blame name-id) outer-args])
(syntax (syntax
(check-procedure val dom-length 0 '() '() #|keywords|# src-info pos-blame orig-str)))) (check-procedure val dom-length 0 '() '() #|keywords|# blame))))
(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 positive-position?) outer-args]) (with-syntax ([(val blame name-id) 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 +507,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 positive-position?) outer-args] (with-syntax ([(val blame name-id) outer-args]
[body body] [body body]
[(name-dom-contract-x ...) [(name-dom-contract-x ...)
(if method-proc? (if method-proc?
@ -522,10 +520,10 @@
... ...
[dom-rest-contract-x (coerce-contract '->* rest)] [dom-rest-contract-x (coerce-contract '->* rest)]
[rng-contract-x (coerce-contract '->* rng)] ...) [rng-contract-x (coerce-contract '->* rng)] ...)
(let ([dom-x (contract-proc dom-contract-x)] (let ([dom-x (contract-projection dom-contract-x)]
... ...
[dom-rest-x (contract-proc dom-rest-contract-x)] [dom-rest-x (contract-projection dom-rest-contract-x)]
[rng-x (contract-proc rng-contract-x)] [rng-x (contract-projection rng-contract-x)]
...) ...)
(let ([name-id (let ([name-id
(build-compound-type-name (build-compound-type-name
@ -536,22 +534,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 positive-position?) outer-args] (with-syntax ([(val blame name-id) 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 (not positive-position?))] (let ([dom-projection-x (dom-x (blame-swap blame))]
... ...
[dom-rest-projection-x (dom-rest-x neg-blame pos-blame src-info orig-str (not positive-position?))] [dom-rest-projection-x (dom-rest-x (blame-swap blame))]
[rng-projection-x (rng-x pos-blame neg-blame src-info orig-str positive-position?)] ...) [rng-projection-x (rng-x blame)] ...)
inner-lambda)))) inner-lambda))))
(lambda (outer-args) (lambda (outer-args)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) (with-syntax ([(val blame name-id) outer-args])
(syntax (syntax
(check-procedure/more val dom-length '() '() #|keywords|# src-info pos-blame orig-str)))) (check-procedure/more val dom-length '() '() #|keywords|# blame))))
(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 positive-position?) outer-args]) (with-syntax ([(val blame name-id) outer-args])
(syntax (syntax
((arg-x ... . arg-rest-x) ((arg-x ... . arg-rest-x)
(let-values ([(res-x ...) (let-values ([(res-x ...)
@ -577,7 +575,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 positive-position?) outer-args] [(val blame name-id) outer-args]
[(name-dom-contract-x ...) [(name-dom-contract-x ...)
(if method-proc? (if method-proc?
(cdr (cdr
@ -588,9 +586,9 @@
(let ([dom-contract-x (coerce-contract '->* dom)] (let ([dom-contract-x (coerce-contract '->* dom)]
... ...
[dom-rest-contract-x (coerce-contract '->* rest)]) [dom-rest-contract-x (coerce-contract '->* rest)])
(let ([dom-x (contract-proc dom-contract-x)] (let ([dom-x (contract-projection dom-contract-x)]
... ...
[dom-rest-x (contract-proc dom-rest-contract-x)]) [dom-rest-x (contract-projection dom-rest-contract-x)])
(let ([name-id (build-compound-type-name (let ([name-id (build-compound-type-name
'->* '->*
(build-compound-type-name name-dom-contract-x ...) (build-compound-type-name name-dom-contract-x ...)
@ -599,21 +597,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 positive-position?) outer-args] (with-syntax ([(val blame name-id) 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 (not positive-position?))] (let ([dom-projection-x (dom-x (blame-swap blame))]
... ...
[dom-projection-rest-x (dom-rest-x neg-blame pos-blame src-info orig-str (not positive-position?))]) [dom-projection-rest-x (dom-rest-x (blame-swap blame))])
inner-lambda)))) inner-lambda))))
(lambda (outer-args) (lambda (outer-args)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) (with-syntax ([(val blame name-id) outer-args])
(syntax (syntax
(check-procedure/more val dom-length '() '() #|keywords|# src-info pos-blame orig-str)))) (check-procedure/more val dom-length '() '() #|keywords|# blame))))
(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 positive-position?) outer-args]) (with-syntax ([(val blame name-id) outer-args])
(syntax (syntax
((arg-x ... . arg-rest-x) ((arg-x ... . arg-rest-x)
(apply (apply
@ -636,7 +634,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 positive-position?) outer-args] [(val blame name-id) outer-args]
[(name-dom-contract-x ...) [(name-dom-contract-x ...)
(if method-proc? (if method-proc?
(cdr (cdr
@ -645,7 +643,7 @@
(syntax (dom-contract-x ...)))]) (syntax (dom-contract-x ...)))])
(syntax (syntax
(let ([dom-contract-x (coerce-contract '->d dom)] ...) (let ([dom-contract-x (coerce-contract '->d dom)] ...)
(let ([dom-x (contract-proc dom-contract-x)] (let ([dom-x (contract-projection dom-contract-x)]
... ...
[rng-x rng]) [rng-x rng])
(check-rng-procedure '->d rng-x arity) (check-rng-procedure '->d rng-x arity)
@ -654,31 +652,27 @@
;; 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 positive-position?) outer-args] (with-syntax ([(val blame name-id) 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 (not positive-position?))] ...) (let ([dom-projection-x (dom-x (blame-swap blame))] ...)
inner-lambda)))) inner-lambda))))
(lambda (outer-args) (lambda (outer-args)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) (with-syntax ([(val blame name-id) outer-args])
(syntax (syntax
(check-procedure val arity 0 '() '() #|keywords|# src-info pos-blame orig-str)))) (check-procedure val arity 0 '() '() #|keywords|# blame))))
(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 positive-position?) outer-args]) (with-syntax ([(val blame name-id) outer-args])
(syntax (syntax
((arg-x ...) ((arg-x ...)
(let ([arg-x (dom-projection-x arg-x)] ...) (let ([arg-x (dom-projection-x arg-x)] ...)
(let ([rng-contract (rng-x arg-x ...)]) (let ([rng-contract (rng-x arg-x ...)])
(((contract-proc (coerce-contract '->d rng-contract)) (((contract-projection (coerce-contract '->d rng-contract))
pos-blame blame)
neg-blame
src-info
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))
@ -694,7 +688,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 positive-position?) outer-args] [(val blame name-id) outer-args]
[(name-dom-contract-x ...) [(name-dom-contract-x ...)
(if method-proc? (if method-proc?
(cdr (cdr
@ -703,7 +697,7 @@
(syntax (dom-contract-x ...)))]) (syntax (dom-contract-x ...)))])
(syntax (syntax
(let ([dom-contract-x (coerce-contract '->d* dom)] ...) (let ([dom-contract-x (coerce-contract '->d* dom)] ...)
(let ([dom-x (contract-proc dom-contract-x)] (let ([dom-x (contract-projection dom-contract-x)]
... ...
[rng-mk-x rng-mk]) [rng-mk-x rng-mk])
(check-rng-procedure '->d* rng-mk-x dom-length) (check-rng-procedure '->d* rng-mk-x dom-length)
@ -715,20 +709,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 positive-position?) outer-args] (with-syntax ([(val blame name-id) 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 (not positive-position?))] ...) (let ([dom-projection-x (dom-x (blame-swap blame))] ...)
inner-lambda)))) inner-lambda))))
(lambda (outer-args) (lambda (outer-args)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) (with-syntax ([(val blame name-id) outer-args])
(syntax (syntax
(check-procedure val dom-length 0 '() '() #|keywords|# src-info pos-blame orig-str)))) (check-procedure val dom-length 0 '() '() #|keywords|# blame))))
(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 positive-position?) outer-args]) (with-syntax ([(val blame name-id) outer-args])
(syntax (syntax
((arg-x ...) ((arg-x ...)
(call-with-values (call-with-values
@ -742,12 +736,8 @@
(apply (apply
values values
(map (lambda (rng-contract result) (map (lambda (rng-contract result)
(((contract-proc (coerce-contract '->d* rng-contract)) (((contract-projection (coerce-contract '->d* rng-contract))
pos-blame blame)
neg-blame
src-info
orig-str
positive-position?)
result)) result))
rng-contracts rng-contracts
results))))))))))))] results))))))))))))]
@ -763,7 +753,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 positive-position?) outer-args] [(val blame name-id) outer-args]
[(name-dom-contract-x ...) [(name-dom-contract-x ...)
(if method-proc? (if method-proc?
(cdr (cdr
@ -774,9 +764,9 @@
(let ([dom-contract-x (coerce-contract '->d* dom)] (let ([dom-contract-x (coerce-contract '->d* dom)]
... ...
[dom-rest-contract-x (coerce-contract '->d* rest)]) [dom-rest-contract-x (coerce-contract '->d* rest)])
(let ([dom-x (contract-proc dom-contract-x)] (let ([dom-x (contract-projection dom-contract-x)]
... ...
[dom-rest-x (contract-proc dom-rest-contract-x)] [dom-rest-x (contract-projection dom-rest-contract-x)]
[rng-mk-x rng-mk]) [rng-mk-x rng-mk])
(check-rng-procedure/more rng-mk-x arity) (check-rng-procedure/more rng-mk-x arity)
(let ([name-id (build-compound-type-name (let ([name-id (build-compound-type-name
@ -788,22 +778,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 positive-position?) outer-args] (with-syntax ([(val blame name-id) 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 (not positive-position?))] (let ([dom-projection-x (dom-x (blame-swap blame))]
... ...
[dom-rest-projection-x (dom-rest-x neg-blame pos-blame src-info orig-str (not positive-position?))]) [dom-rest-projection-x (dom-rest-x (blame-swap blame))])
inner-lambda)))) inner-lambda))))
(lambda (outer-args) (lambda (outer-args)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) (with-syntax ([(val blame name-id) outer-args])
(syntax (syntax
(check-procedure/more val arity '() '() #|keywords|# src-info pos-blame orig-str)))) (check-procedure/more val arity '() '() #|keywords|# blame))))
(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 positive-position?) outer-args]) (with-syntax ([(val blame name-id) outer-args])
(syntax (syntax
((arg-x ... . rest-arg-x) ((arg-x ... . rest-arg-x)
(call-with-values (call-with-values
@ -822,12 +812,8 @@
(apply (apply
values values
(map (lambda (rng-contract result) (map (lambda (rng-contract result)
(((contract-proc (coerce-contract '->d* rng-contract)) (((contract-projection (coerce-contract '->d* rng-contract))
pos-blame blame)
neg-blame
src-info
orig-str
positive-position?)
result)) result))
rng-contracts rng-contracts
results))))))))))))])) results))))))))))))]))
@ -880,32 +866,31 @@
(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 positive-position?) outer-args]) [(val blame name-id) 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 positive-position?) outer-args] (with-syntax ([(val blame name-id) outer-args]
[kind-of-thing (if method-proc? 'method 'procedure)]) [kind-of-thing (if method-proc? 'method 'procedure)])
(syntax (syntax
(begin (begin
(check-procedure/kind val arity 'kind-of-thing src-info pos-blame orig-str))))) (check-procedure/kind val arity 'kind-of-thing blame)))))
(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 positive-position?) outer-args]) (with-syntax ([(val blame name-id) 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 (blame-swap blame))
(let ([dom-id ((contract-proc (coerce-contract 'stx-name dom)) (let ([dom-id ((contract-projection (coerce-contract 'stx-name dom))
neg-blame pos-blame src-info orig-str (blame-swap blame))]
(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)
@ -915,16 +900,14 @@
(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 (blame-swap blame))
(let ([dom-id ((contract-proc (coerce-contract 'stx-name dom)) (let ([dom-id ((contract-projection (coerce-contract 'stx-name dom))
neg-blame pos-blame src-info orig-str (blame-swap blame))]
(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 blame)
(let ([rng-ids-x ((contract-proc (coerce-contract 'stx-name rng-ctc)) (let ([rng-ids-x ((contract-projection (coerce-contract 'stx-name rng-ctc))
pos-blame neg-blame src-info orig-str blame)] ...)
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 ...))))
@ -941,16 +924,14 @@
(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 (blame-swap blame))
(let ([dom-id ((contract-proc (coerce-contract 'stx-name dom)) (let ([dom-id ((contract-projection (coerce-contract 'stx-name dom))
neg-blame pos-blame src-info orig-str (blame-swap blame))]
(not positive-position?))]
... ...
[rng-id ((contract-proc (coerce-contract 'stx-name rng)) [rng-id ((contract-projection (coerce-contract 'stx-name rng))
pos-blame neg-blame src-info orig-str blame)])
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 blame)
res-id)))))] res-id)))))]
[_ [_
(raise-syntax-error name "unknown result specification" stx (syntax result-stuff))]))))))] (raise-syntax-error name "unknown result specification" stx (syntax result-stuff))]))))))]
@ -1000,35 +981,33 @@
(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 positive-position?) outer-args]) [(val blame name-id) 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 positive-position?) outer-args] (with-syntax ([(val blame name-id) outer-args]
[kind-of-thing (if method-proc? 'method 'procedure)]) [kind-of-thing (if method-proc? 'method 'procedure)])
(syntax (syntax
(begin (begin
(check-procedure/more/kind val arity 'kind-of-thing src-info pos-blame orig-str))))) (check-procedure/more/kind val arity 'kind-of-thing blame)))))
(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 positive-position?) outer-args]) (with-syntax ([(val blame name-id) 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 (blame-swap blame))
(let ([dom-id ((contract-proc (coerce-contract 'stx-name dom)) (let ([dom-id ((contract-projection (coerce-contract 'stx-name dom))
neg-blame pos-blame src-info orig-str (blame-swap blame))]
(not positive-position?))]
... ...
[rest-id ((contract-proc (coerce-contract 'stx-name rest-dom)) [rest-id ((contract-projection (coerce-contract 'stx-name rest-dom))
neg-blame pos-blame src-info orig-str (blame-swap blame))])
(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))]
@ -1039,19 +1018,16 @@
(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 (blame-swap blame))
(let ([dom-id ((contract-proc (coerce-contract 'stx-name dom)) (let ([dom-id ((contract-projection (coerce-contract 'stx-name dom))
neg-blame pos-blame src-info orig-str (blame-swap blame))]
(not positive-position?))]
... ...
[rest-id ((contract-proc (coerce-contract 'stx-name rest-dom)) [rest-id ((contract-projection (coerce-contract 'stx-name rest-dom))
neg-blame pos-blame src-info orig-str (blame-swap blame))])
(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 blame)
(let ([rng-ids-x ((contract-proc (coerce-contract 'stx-name rng-ctc)) (let ([rng-ids-x ((contract-projection (coerce-contract 'stx-name rng-ctc))
pos-blame neg-blame src-info orig-str blame)] ...)
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 ...))))
@ -1073,19 +1049,16 @@
(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 (blame-swap blame))
(let ([dom-id ((contract-proc (coerce-contract 'stx-name dom)) (let ([dom-id ((contract-projection (coerce-contract 'stx-name dom))
neg-blame pos-blame src-info orig-str (blame-swap blame))]
(not positive-position?))]
... ...
[rest-id ((contract-proc (coerce-contract 'stx-name rest-dom)) [rest-id ((contract-projection (coerce-contract 'stx-name rest-dom))
neg-blame pos-blame src-info orig-str (blame-swap blame))]
(not positive-position?))] [rng-id ((contract-projection (coerce-contract 'stx-name rng))
[rng-id ((contract-proc (coerce-contract 'stx-name rng)) blame)])
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 blame)
res-id)))))] res-id)))))]
[(rng res-id post-expr) [(rng res-id post-expr)
(not (identifier? (syntax res-id))) (not (identifier? (syntax res-id)))

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

@ -30,22 +30,20 @@
[(p-app-x ...) (generate-temporaries #'(rngs ...))] [(p-app-x ...) (generate-temporaries #'(rngs ...))]
[(res-x ...) (generate-temporaries #'(rngs ...))]) [(res-x ...) (generate-temporaries #'(rngs ...))])
#'(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...) #'(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...)
(let ([proj-x ((proj-get rngs-x) rngs-x)] ...) (let ([proj-x (contract-projection rngs-x)] ...)
(make-proj-contract (simple-contract
(build-compound-type-name 'unconstrained-domain-> ((name-get rngs-x) rngs-x) ...) #:name
(λ (pos-blame neg-blame src-info orig-str positive-position?) (build-compound-type-name 'unconstrained-domain-> (contract-name rngs-x) ...)
(let ([p-app-x (proj-x pos-blame neg-blame src-info orig-str positive-position?)] ...) #:projection
(λ (blame)
(let ([p-app-x (proj-x blame)] ...)
(λ (val) (λ (val)
(if (procedure? val) (if (procedure? val)
(λ args (λ args
(let-values ([(res-x ...) (apply val args)]) (let-values ([(res-x ...) (apply val args)])
(values (p-app-x res-x) ...))) (values (p-app-x res-x) ...)))
(raise-contract-error val (raise-blame-error blame val "expected a procedure")))))
src-info #:first-order procedure?))))]))
pos-blame
orig-str
"expected a procedure")))))
procedure?))))]))
(define (build--> name doms doms-rest rngs kwds quoted-kwds rng-any? func) (define (build--> name doms doms-rest rngs kwds quoted-kwds rng-any? func)
(let ([doms/c (map (λ (dom) (coerce-contract name dom)) doms)] (let ([doms/c (map (λ (dom) (coerce-contract name dom)) doms)]
@ -64,64 +62,66 @@
;; and it produces a wrapper-making function. ;; and it produces a wrapper-making function.
(define-struct -> (rng-any? doms dom-rest rngs kwds quoted-kwds func) (define-struct -> (rng-any? doms dom-rest rngs kwds quoted-kwds func)
#:omit-define-syntaxes #:omit-define-syntaxes
#:property proj-prop #:property prop:contract
(λ (ctc) (build-contract-property
(let* ([doms/c (map (λ (x) ((proj-get x) x)) #:projection
(if (->-dom-rest ctc) (λ (ctc)
(let* ([doms/c (map contract-projection
(if (->-dom-rest ctc)
(append (->-doms ctc) (list (->-dom-rest ctc))) (append (->-doms ctc) (list (->-dom-rest ctc)))
(->-doms ctc)))] (->-doms ctc)))]
[rngs/c (map (λ (x) ((proj-get x) x)) (->-rngs ctc))] [rngs/c (map contract-projection (->-rngs ctc))]
[kwds/c (map (λ (x) ((proj-get x) x)) (->-kwds ctc))] [kwds/c (map contract-projection (->-kwds ctc))]
[mandatory-keywords (->-quoted-kwds ctc)] [mandatory-keywords (->-quoted-kwds ctc)]
[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 positive-position?) (lambda (blame)
(let ([partial-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str (not positive-position?))) (let ([partial-doms (map (λ (dom) (dom (blame-swap blame)))
doms/c)] doms/c)]
[partial-ranges (map (λ (rng) (rng pos-blame neg-blame src-info orig-str positive-position?)) [partial-ranges (map (λ (rng) (rng blame))
rngs/c)] rngs/c)]
[partial-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str (not positive-position?))) [partial-kwds (map (λ (kwd) (kwd (blame-swap blame)))
kwds/c)]) kwds/c)])
(apply func (apply func
(λ (val) (λ (val)
(if has-rest? (if has-rest?
(check-procedure/more val dom-length '() mandatory-keywords src-info pos-blame orig-str) (check-procedure/more val dom-length '() mandatory-keywords blame)
(check-procedure val dom-length 0 '() mandatory-keywords src-info pos-blame orig-str))) (check-procedure val dom-length 0 '() mandatory-keywords blame)))
(append partial-doms partial-ranges partial-kwds)))))) (append partial-doms partial-ranges partial-kwds))))))
#:property name-prop #:name
(λ (ctc) (single-arrow-name-maker (λ (ctc) (single-arrow-name-maker
(->-doms ctc) (->-doms ctc)
(->-dom-rest ctc) (->-dom-rest ctc)
(->-kwds ctc) (->-kwds ctc)
(->-quoted-kwds ctc) (->-quoted-kwds ctc)
(->-rng-any? ctc) (->-rng-any? ctc)
(->-rngs ctc))) (->-rngs ctc)))
#:property first-order-prop #:first-order
(λ (ctc) (λ (ctc)
(let ([l (length (->-doms ctc))]) (let ([l (length (->-doms ctc))])
(if (->-dom-rest ctc) (if (->-dom-rest ctc)
(λ (x) (λ (x)
(and (procedure? x) (and (procedure? x)
(procedure-accepts-and-more? x l))) (procedure-accepts-and-more? x l)))
(λ (x) (λ (x)
(and (procedure? x) (and (procedure? x)
(procedure-arity-includes? x l) (procedure-arity-includes? x l)
(no-mandatory-keywords? x)))))) (no-mandatory-keywords? x))))))
#:property stronger-prop #:stronger
(λ (this that) (λ (this that)
(and (->? that) (and (->? that)
(= (length (->-doms that)) (= (length (->-doms that))
(length (->-doms this))) (length (->-doms this)))
(andmap contract-stronger? (andmap contract-stronger?
(->-doms that) (->-doms that)
(->-doms this)) (->-doms this))
(= (length (->-rngs that)) (= (length (->-rngs that))
(length (->-rngs this))) (length (->-rngs this)))
(andmap contract-stronger? (andmap contract-stronger?
(->-rngs this) (->-rngs this)
(->-rngs that))))) (->-rngs that))))))
(define (single-arrow-name-maker doms/c doms-rest kwds/c kwds rng-any? rngs) (define (single-arrow-name-maker doms/c doms-rest kwds/c kwds rng-any? rngs)
(cond (cond
@ -455,16 +455,14 @@
(append partials-rngs partial) (append partials-rngs partial)
(append this-stronger-ribs stronger-ribs)))]))]) (append this-stronger-ribs stronger-ribs)))]))])
(values (values
(with-syntax ((pos (opt/info-pos opt/info)) (with-syntax ((blame (opt/info-blame opt/info))
(src-info (opt/info-src-info opt/info))
(orig-str (opt/info-orig-str opt/info))
((dom-arg ...) dom-vars) ((dom-arg ...) dom-vars)
((rng-arg ...) rng-vars) ((rng-arg ...) rng-vars)
((next-dom ...) next-doms) ((next-dom ...) next-doms)
(dom-len (length dom-vars)) (dom-len (length dom-vars))
((next-rng ...) next-rngs)) ((next-rng ...) next-rngs))
(syntax (begin (syntax (begin
(check-procedure val dom-len 0 '() '() #| keywords |# src-info pos orig-str) (check-procedure val dom-len 0 '() '() #| keywords |# blame)
(λ (dom-arg ...) (λ (dom-arg ...)
(let-values ([(rng-arg ...) (val next-dom ...)]) (let-values ([(rng-arg ...) (val next-dom ...)])
(values next-rng ...)))))) (values next-rng ...))))))
@ -505,14 +503,12 @@
(append partials-doms partial) (append partials-doms partial)
(append this-stronger-ribs stronger-ribs)))]))]) (append this-stronger-ribs stronger-ribs)))]))])
(values (values
(with-syntax ((pos (opt/info-pos opt/info)) (with-syntax ((blame (opt/info-blame opt/info))
(src-info (opt/info-src-info opt/info))
(orig-str (opt/info-orig-str opt/info))
((dom-arg ...) dom-vars) ((dom-arg ...) dom-vars)
((next-dom ...) next-doms) ((next-dom ...) next-doms)
(dom-len (length dom-vars))) (dom-len (length dom-vars)))
(syntax (begin (syntax (begin
(check-procedure val dom-len 0 '() '() #|keywords|# src-info pos orig-str) (check-procedure val dom-len 0 '() '() #|keywords|# blame)
(λ (dom-arg ...) (λ (dom-arg ...)
(val next-dom ...))))) (val next-dom ...)))))
lifts-doms lifts-doms

11
collects/mzlib/private/contract-define.ss
View File

@ -2,9 +2,10 @@
(provide define/contract) (provide define/contract)
(require (for-syntax scheme/base) (require (for-syntax scheme/base
(only-in scheme/contract contract) unstable/srcloc
(for-syntax (prefix-in a: scheme/contract/private/helpers))) (prefix-in a: scheme/contract/private/helpers))
(only-in scheme/contract contract))
;; First, we have the old define/contract implementation, which ;; First, we have the old define/contract implementation, which
;; is still used in mzlib/contract. ;; is still used in mzlib/contract.
@ -12,7 +13,7 @@
(define-for-syntax (make-define/contract-transformer contract-id id) (define-for-syntax (make-define/contract-transformer contract-id id)
(make-set!-transformer (make-set!-transformer
(λ (stx) (λ (stx)
(with-syntax ([neg-blame-str (a:build-src-loc-string stx)] (with-syntax ([neg-blame-str (source-location->string stx "<<unknown>>")]
[contract-id contract-id] [contract-id contract-id]
[id id]) [id id])
(syntax-case stx (set!) (syntax-case stx (set!)
@ -27,6 +28,7 @@
id id
(syntax->datum (quote-syntax f)) (syntax->datum (quote-syntax f))
neg-blame-str neg-blame-str
(quote f)
(quote-syntax f)) (quote-syntax f))
arg arg
...))] ...))]
@ -37,6 +39,7 @@
id id
(syntax->datum (quote-syntax ident)) (syntax->datum (quote-syntax ident))
neg-blame-str neg-blame-str
(quote ident)
(quote-syntax ident)))]))))) (quote-syntax ident)))])))))
;; (define/contract id contract expr) ;; (define/contract id contract expr)

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

@ -331,37 +331,39 @@
... ...
[field-ctc-var (coerce-contract 'object-contract field-ctc-stx)] [field-ctc-var (coerce-contract 'object-contract field-ctc-stx)]
...) ...)
(let ([method-var (contract-proc method-ctc-var)] (let ([method-var (contract-projection method-ctc-var)]
... ...
[field-var (contract-proc field-ctc-var)] [field-var (contract-projection field-ctc-var)]
...) ...)
(let ([cls (make-wrapper-class 'wrapper-class (let ([cls (make-wrapper-class 'wrapper-class
'(method-name ...) '(method-name ...)
(list methods ...) (list methods ...)
'(field-name ...) '(field-name ...)
#t)]) #t)])
(make-proj-contract (simple-contract
#:name
`(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 positive-position?) #:projection
(let ([method/app-var (method-var pos-blame neg-blame src-info orig-str positive-position?)] (lambda (blame)
(let ([method/app-var (method-var blame)]
... ...
[field/app-var (field-var pos-blame neg-blame src-info orig-str positive-position?)] [field/app-var (field-var blame)]
...) ...)
(let ([field-names-list '(field-name ...)]) (let ([field-names-list '(field-name ...)])
(lambda (val) (lambda (val)
(check-object val src-info pos-blame orig-str) (check-object val blame)
(let ([val-mtd-names (let ([val-mtd-names
(interface->method-names (interface->method-names
(object-interface (object-interface
val))]) val))])
(void) (void)
(check-method val 'method-name val-mtd-names src-info pos-blame orig-str) (check-method val 'method-name val-mtd-names blame)
...) ...)
(unless (field-bound? field-name val) (unless (field-bound? field-name val)
(field-error val 'field-name src-info pos-blame orig-str)) ... (field-error val 'field-name blame)) ...
(let ([vtable (extract-vtable val)] (let ([vtable (extract-vtable val)]
[method-ht (extract-method-ht val)]) [method-ht (extract-method-ht val)])
@ -369,35 +371,19 @@
val val
(method/app-var (vector-ref vtable (hash-ref method-ht 'method-name))) ... (method/app-var (vector-ref vtable (hash-ref method-ht 'method-name))) ...
(field/app-var (get-field field-name val)) ... (field/app-var (get-field field-name val)) ...
)))))) )))))))))))))]))))
#f)))))))]))))
(define (check-object val src-info blame orig-str) (define (check-object val blame)
(unless (object? val) (unless (object? val)
(raise-contract-error val (raise-blame-error blame val "expected an object, got ~e" val)))
src-info
blame
orig-str
"expected an object, got ~e"
val)))
(define (check-method val method-name val-mtd-names src-info blame orig-str) (define (check-method val method-name val-mtd-names blame)
(unless (memq method-name val-mtd-names) (unless (memq method-name val-mtd-names)
(raise-contract-error val (raise-blame-error blame val "expected an object with method ~s" method-name)))
src-info
blame
orig-str
"expected an object with method ~s"
method-name)))
(define (field-error val field-name src-info blame orig-str) (define (field-error val field-name blame)
(raise-contract-error val (raise-blame-error blame val "expected an object with field ~s" field-name))
src-info
blame
orig-str
"expected an object with field ~s"
field-name))
(define (make-mixin-contract . %/<%>s) (define (make-mixin-contract . %/<%>s)
((and/c (flat-contract class?) ((and/c (flat-contract class?)

19
collects/mzlib/unit.ss
View File

@ -16,6 +16,7 @@
(require mzlib/etc (require mzlib/etc
scheme/contract/base scheme/contract/base
scheme/stxparam scheme/stxparam
unstable/location
"private/unit-contract.ss" "private/unit-contract.ss"
"private/unit-keywords.ss" "private/unit-keywords.ss"
"private/unit-runtime.ss" "private/unit-runtime.ss"
@ -482,7 +483,7 @@
(if (pair? v/c) (if (pair? v/c)
(contract (let-syntax #,renamings ctc-stx) (car v/c) (cdr v/c) (contract (let-syntax #,renamings ctc-stx) (car v/c) (cdr v/c)
(current-contract-region) (current-contract-region)
#,(id->contract-src-info var)) (quote #,var) (quote-syntax #,var))
(error 'unit "contracted import ~a used before definition" (error 'unit "contracted import ~a used before definition"
(quote #,(syntax->datum var)))))))) (quote #,(syntax->datum var))))))))
(quasisyntax/loc (error-syntax) (quasisyntax/loc (error-syntax)
@ -747,7 +748,8 @@
(contract #,ctc #,tmp (contract #,ctc #,tmp
(current-contract-region) (current-contract-region)
'cant-happen 'cant-happen
#,(id->contract-src-info id)) (quote #,id)
(quote-syntax #,id))
(set-box! #,export-loc (set-box! #,export-loc
(cons #,tmp (current-contract-region))))) (cons #,tmp (current-contract-region)))))
(quasisyntax/loc defn-or-expr (quasisyntax/loc defn-or-expr
@ -824,7 +826,7 @@
#`(let ([old-v/c (#,vref)]) #`(let ([old-v/c (#,vref)])
(contract ctc-stx (car old-v/c) (contract ctc-stx (car old-v/c)
(cdr old-v/c) (current-contract-region) (cdr old-v/c) (current-contract-region)
#,(id->contract-src-info var))) (quote #,var) (quote-syntax #,var)))
#`(#,vref)) #`(#,vref))
(current-contract-region))) (current-contract-region)))
(if ctc (if ctc
@ -832,7 +834,7 @@
(let ([old-v/c (#,vref)]) (let ([old-v/c (#,vref)])
(contract ctc-stx (car old-v/c) (contract ctc-stx (car old-v/c)
(cdr old-v/c) (current-contract-region) (cdr old-v/c) (current-contract-region)
#,(id->contract-src-info var)))) (quote #,var) (quote-syntax #,var))))
vref))))) vref)))))
(car target-sig) (car target-sig)
(cadddr target-sig))) (cadddr target-sig)))
@ -1293,7 +1295,7 @@
(((wrap-code ...) ...) (((wrap-code ...) ...)
(map (λ (os ov tbs) (map (λ (os ov tbs)
(define rename-bindings (define rename-bindings
(get-member-bindings def-table os #'(#%variable-reference))) (get-member-bindings def-table os #'(quote-module-path)))
(map (λ (tb i v c) (map (λ (tb i v c)
(if c (if c
(with-syntax ([ctc-stx (with-syntax ([ctc-stx
@ -1303,7 +1305,7 @@
#`(let ([v/c (#,tb)]) #`(let ([v/c (#,tb)])
(contract ctc-stx (car v/c) (cdr v/c) (contract ctc-stx (car v/c) (cdr v/c)
(current-contract-region) (current-contract-region)
#,(id->contract-src-info v)))) (quote #,v) (quote-syntax #,v))))
#`(#,tb))) #`(#,tb)))
tbs tbs
(iota (length (car os))) (iota (length (car os)))
@ -1503,11 +1505,10 @@
#'name #'name
(syntax/loc stx (syntax/loc stx
((import (import-tagged-sig-id [i.x i.c] ...) ...) ((import (import-tagged-sig-id [i.x i.c] ...) ...)
(export (export-tagged-sig-id [e.x e.c] ...) ...))))] (export (export-tagged-sig-id [e.x e.c] ...) ...))))])
[src-info (id->contract-src-info #'name)])
(values (values
(syntax/loc stx (syntax/loc stx
(contract unit-contract new-unit '(unit name) (current-contract-region) src-info)) (contract unit-contract new-unit '(unit name) (current-contract-region) (quote name) (quote-syntax name)))
isigs esigs deps))))] isigs esigs deps))))]
[(ic:import-clause/contract ec:export-clause/contract . body) [(ic:import-clause/contract ec:export-clause/contract . body)
(build-unit/contract (build-unit/contract

16
collects/tests/mzscheme/contract-mzlib-test.ss
View File

@ -78,13 +78,9 @@ of the contract library does not change over time.
(define (test/spec-failed name expression blame) (define (test/spec-failed name expression blame)
(let () (let ()
(define (has-proper-blame? msg) (define (has-proper-blame? msg)
(equal? (regexp-match?
blame (string-append "(^| )" (regexp-quote blame) " broke")
(cond msg))
[(regexp-match #rx"(^| )(.*) broke" msg)
=>
(λ (x) (caddr x))]
[else (format "no blame in error message: \"~a\"" msg)])))
(printf "testing: ~s\n" name) (printf "testing: ~s\n" name)
(contract-eval (contract-eval
`(,thunk-error-test `(,thunk-error-test
@ -5127,7 +5123,11 @@ so that propagation occurs.
(and (exn? x) (and (exn? x)
(regexp-match #rx"expected field name to be b, but found string?" (exn-message x))))) (regexp-match #rx"expected field name to be b, but found string?" (exn-message x)))))
(contract-eval `(,test 'pos guilty-party (with-handlers ((void values)) (contract not #t 'pos 'neg)))) (contract-eval
`(,test
'pos
(compose blame-positive exn:fail:contract:blame-object)
(with-handlers ((void values)) (contract not #t 'pos 'neg))))
(report-errs) (report-errs)

6
collects/tests/mzscheme/pconvert.ss
View File

@ -207,13 +207,13 @@
(make-same-test (make-weak-hasheq) (make-same-test (make-weak-hasheq)
'(weak-hasheq)) '(weak-hasheq))
(make-same-test (make-hash) (make-same-test (make-hash)
'(hash)) '(make-hash))
(make-same-test (make-weak-hash) (make-same-test (make-weak-hash)
'(weak-hash)) '(weak-hash))
(make-same-test (let ([ht (make-hash)]) (make-same-test (let ([ht (make-hash)])
(hash-set! ht 'x 1) (hash-set! ht 'x 1)
ht) ht)
'(hash ('x 1))) '(make-hash (list (cons 'x 1))))
(make-pctest (list 'a (box (list '())) (cons 1 '())) (make-pctest (list 'a (box (list '())) (cons 1 '()))
'(list (quote a) (box (list empty)) (list 1)) '(list (quote a) (box (list empty)) (list 1))
'(list (quote a) (box (list empty)) (list 1)) '(list (quote a) (box (list empty)) (list 1))
@ -356,7 +356,7 @@
(test-shared (vector 1 2 3) '(vector 1 2 3)) (test-shared (vector 1 2 3) '(vector 1 2 3))
(let () (define-struct a () #:inspector (make-inspector)) (test-shared (make-a) '(make-a))) (let () (define-struct a () #:inspector (make-inspector)) (test-shared (make-a) '(make-a)))
(test-shared (box 1) '(box 1)) (test-shared (box 1) '(box 1))
(test-shared (make-hash) '(hash))) (test-shared (make-hash) '(make-hash)))
(arity-test print-convert 1 2) (arity-test print-convert 1 2)
(arity-test build-share 1 1) (arity-test build-share 1 1)