Ported a lot of mzlib contracts to new properties.
svn: r17699 original commit: 1f969b883113a646d9bbf3470df1755dfc3a708e
This commit is contained in:
Carl Eastlund
parent
e19d7a7128
commit
7a79b808a8
|
|
@ -48,48 +48,11 @@
|
|||
check-between/c
|
||||
string-len/c
|
||||
check-unary-between/c)
|
||||
(rename-out [string-len/c string/len]))
|
||||
|
||||
;; from contract-guts.ss
|
||||
|
||||
(provide any
|
||||
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]))
|
||||
(rename-out [or/c union])
|
||||
(rename-out [string-len/c string/len])
|
||||
(except-out (all-from-out scheme/contract/private/guts)
|
||||
check-flat-contract
|
||||
check-flat-named-contract))
|
||||
|
||||
|
||||
;; copied here because not provided by scheme/contract anymore
|
||||
|
|
|
|||
|
|
@ -77,31 +77,21 @@
|
|||
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
|
||||
(raise-contract-error val
|
||||
src-info
|
||||
blame
|
||||
orig-str
|
||||
"pre-condition expression failure")))
|
||||
(raise-blame-error blame val "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
|
||||
(raise-contract-error val
|
||||
src-info
|
||||
blame
|
||||
orig-str
|
||||
"post-condition expression failure")))
|
||||
(raise-blame-error blame val "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)
|
||||
(procedure-arity-includes?/optionals val dom-length optionals)
|
||||
(keywords-match mandatory-kwds optional-keywords val))
|
||||
(raise-contract-error
|
||||
val
|
||||
src-info
|
||||
(raise-blame-error
|
||||
blame
|
||||
orig-str
|
||||
val
|
||||
"expected a procedure that accepts ~a arguments~a, given: ~e"
|
||||
dom-length
|
||||
(keyword-error-text mandatory-kwds)
|
||||
|
|
@ -140,53 +130,37 @@
|
|||
(and (procedure? val)
|
||||
(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)
|
||||
(raise-contract-error val
|
||||
src-info
|
||||
blame
|
||||
orig-str
|
||||
"expected a procedure, got ~e"
|
||||
val))
|
||||
(raise-blame-error blame val "expected a procedure, got ~e" val))
|
||||
(unless (procedure-arity-includes? val arity)
|
||||
(raise-contract-error val
|
||||
src-info
|
||||
blame
|
||||
orig-str
|
||||
"expected a ~a of arity ~a (not arity ~a), got ~e"
|
||||
kind-of-thing
|
||||
arity
|
||||
(procedure-arity val)
|
||||
val)))
|
||||
(raise-blame-error blame
|
||||
val
|
||||
"expected a ~a of arity ~a (not arity ~a), got ~e"
|
||||
kind-of-thing
|
||||
arity
|
||||
(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)
|
||||
(raise-contract-error val
|
||||
src-info
|
||||
blame
|
||||
orig-str
|
||||
"expected a procedure, got ~e"
|
||||
val))
|
||||
(raise-blame-error blame val "expected a procedure, got ~e" val))
|
||||
(unless (procedure-accepts-and-more? val arity)
|
||||
(raise-contract-error val
|
||||
src-info
|
||||
blame
|
||||
orig-str
|
||||
"expected a ~a that accepts ~a arguments and aribtrarily more (not arity ~a), got ~e"
|
||||
kind-of-thing
|
||||
arity
|
||||
(procedure-arity val)
|
||||
val)))
|
||||
(raise-blame-error blame
|
||||
val
|
||||
"expected a ~a that accepts ~a arguments and aribtrarily more (not arity ~a), got ~e"
|
||||
kind-of-thing
|
||||
arity
|
||||
(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)
|
||||
(procedure-accepts-and-more? val dom-length)
|
||||
(keywords-match mandatory-kwds optional-kwds val))
|
||||
(raise-contract-error
|
||||
val
|
||||
src-info
|
||||
(raise-blame-error
|
||||
blame
|
||||
orig-str
|
||||
val
|
||||
"expected a procedure that accepts ~a arguments and and arbitrarily more~a, given: ~e"
|
||||
dom-length
|
||||
(keyword-error-text mandatory-kwds)
|
||||
|
|
|
|||
|
|
@ -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 positive-position?))])
|
||||
(let ([outer-args (syntax (val blame name-id))])
|
||||
(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)])
|
||||
(with-syntax ([inner-lambda
|
||||
(set-inferred-name-from
|
||||
|
|
@ -37,11 +37,10 @@
|
|||
(arguments-check
|
||||
outer-args
|
||||
(syntax/loc stx
|
||||
(make-proj-contract
|
||||
name-id
|
||||
(lambda (pos-blame neg-blame src-info orig-str positive-position?)
|
||||
proj-code)
|
||||
first-order-check))))))))))
|
||||
(simple-contract
|
||||
#:name name-id
|
||||
#:projection (lambda (blame) proj-code)
|
||||
#:first-order first-order-check))))))))))
|
||||
|
||||
(define (make-case->/proc method-proc? stx inferred-name-stx select/h)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -55,9 +54,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 positive-position?))])
|
||||
(let ([outer-args (syntax (val blame name-id))])
|
||||
(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)])
|
||||
(with-syntax ([inner-lambda
|
||||
(set-inferred-name-from
|
||||
|
|
@ -73,11 +72,10 @@
|
|||
(arguments-check
|
||||
outer-args
|
||||
(syntax/loc stx
|
||||
(make-proj-contract
|
||||
(apply build-compound-type-name 'case-> name-id)
|
||||
(lambda (pos-blame neg-blame src-info orig-str positive-position?)
|
||||
proj-code)
|
||||
first-order-check)))))))))]))
|
||||
(simple-contract
|
||||
#:name (apply build-compound-type-name 'case-> name-id)
|
||||
#:projection (lambda (blame) proj-code)
|
||||
#:first-order first-order-check)))))))))]))
|
||||
|
||||
(define (make-opt->/proc method-proc? stx select/h case-arr-stx arr-stx)
|
||||
(syntax-case stx (any)
|
||||
|
|
@ -230,7 +228,7 @@
|
|||
[(null? cases)
|
||||
(values
|
||||
(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]
|
||||
[(name-ids ...) (reverse name-ids)])
|
||||
(syntax
|
||||
|
|
@ -249,10 +247,10 @@
|
|||
(/h method-proc? (car cases))])
|
||||
(values
|
||||
(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])
|
||||
(arguments-check
|
||||
(syntax (val pos-blame neg-blame src-info orig-str new-id positive-position?))
|
||||
(syntax (val blame new-id))
|
||||
(arguments-checks
|
||||
outer-args
|
||||
x))))
|
||||
|
|
@ -364,7 +362,7 @@
|
|||
(values
|
||||
(lambda (outer-args 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
|
||||
(let ([dom-contract-x (coerce-contract '-> dom)] ...)
|
||||
(let ([dom-x (contract-proc dom-contract-x)] ...)
|
||||
|
|
@ -373,19 +371,19 @@
|
|||
|
||||
;; proj
|
||||
(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])
|
||||
(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))))
|
||||
|
||||
(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
|
||||
(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))
|
||||
(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
|
||||
((arg-x ...)
|
||||
(val (dom-projection-x arg-x) ...))))))]
|
||||
|
|
@ -399,14 +397,14 @@
|
|||
(values
|
||||
(lambda (outer-args 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
|
||||
(let ([dom-contract-x (coerce-contract '-> dom)]
|
||||
...
|
||||
[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
|
||||
|
|
@ -417,22 +415,22 @@
|
|||
|
||||
;; proj
|
||||
(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])
|
||||
(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))))
|
||||
|
||||
(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
|
||||
(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))
|
||||
|
||||
(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
|
||||
((arg-x ...)
|
||||
(let-values ([(res-x ...) (val (dom-projection-x arg-x) ...)])
|
||||
|
|
@ -448,34 +446,34 @@
|
|||
(values
|
||||
(lambda (outer-args 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
|
||||
(let ([dom-contract-x (coerce-contract '-> dom)]
|
||||
...
|
||||
[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)])
|
||||
body))))))
|
||||
|
||||
;; proj
|
||||
(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])
|
||||
(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))))
|
||||
|
||||
(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
|
||||
(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))
|
||||
(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
|
||||
((arg-x ...)
|
||||
(let ([res-x (val (dom-projection-x arg-x) ...)])
|
||||
|
|
@ -509,7 +507,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 positive-position?) outer-args]
|
||||
(with-syntax ([(val blame name-id) outer-args]
|
||||
[body body]
|
||||
[(name-dom-contract-x ...)
|
||||
(if method-proc?
|
||||
|
|
@ -522,10 +520,10 @@
|
|||
...
|
||||
[dom-rest-contract-x (coerce-contract '->* rest)]
|
||||
[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)]
|
||||
[rng-x (contract-proc rng-contract-x)]
|
||||
[dom-rest-x (contract-projection dom-rest-contract-x)]
|
||||
[rng-x (contract-projection rng-contract-x)]
|
||||
...)
|
||||
(let ([name-id
|
||||
(build-compound-type-name
|
||||
|
|
@ -536,22 +534,22 @@
|
|||
body))))))
|
||||
;; proj
|
||||
(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])
|
||||
(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?))]
|
||||
[rng-projection-x (rng-x pos-blame neg-blame src-info orig-str positive-position?)] ...)
|
||||
[dom-rest-projection-x (dom-rest-x (blame-swap blame))]
|
||||
[rng-projection-x (rng-x blame)] ...)
|
||||
inner-lambda))))
|
||||
|
||||
(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
|
||||
(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))
|
||||
(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
|
||||
((arg-x ... . arg-rest-x)
|
||||
(let-values ([(res-x ...)
|
||||
|
|
@ -577,7 +575,7 @@
|
|||
(values
|
||||
(lambda (outer-args 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 ...)
|
||||
(if method-proc?
|
||||
(cdr
|
||||
|
|
@ -588,9 +586,9 @@
|
|||
(let ([dom-contract-x (coerce-contract '->* dom)]
|
||||
...
|
||||
[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
|
||||
'->*
|
||||
(build-compound-type-name name-dom-contract-x ...)
|
||||
|
|
@ -599,21 +597,21 @@
|
|||
body))))))
|
||||
;; proj
|
||||
(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])
|
||||
(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))))
|
||||
|
||||
(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
|
||||
(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))
|
||||
(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
|
||||
((arg-x ... . arg-rest-x)
|
||||
(apply
|
||||
|
|
@ -636,7 +634,7 @@
|
|||
(values
|
||||
(lambda (outer-args 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 ...)
|
||||
(if method-proc?
|
||||
(cdr
|
||||
|
|
@ -645,7 +643,7 @@
|
|||
(syntax (dom-contract-x ...)))])
|
||||
(syntax
|
||||
(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])
|
||||
(check-rng-procedure '->d rng-x arity)
|
||||
|
|
@ -654,31 +652,27 @@
|
|||
|
||||
;; proj
|
||||
(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])
|
||||
(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))))
|
||||
|
||||
(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
|
||||
(check-procedure val arity 0 '() '() #|keywords|# src-info pos-blame orig-str))))
|
||||
(check-procedure val arity 0 '() '() #|keywords|# blame))))
|
||||
|
||||
(syntax (check-procedure? arity))
|
||||
|
||||
(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
|
||||
((arg-x ...)
|
||||
(let ([arg-x (dom-projection-x arg-x)] ...)
|
||||
(let ([rng-contract (rng-x arg-x ...)])
|
||||
(((contract-proc (coerce-contract '->d rng-contract))
|
||||
pos-blame
|
||||
neg-blame
|
||||
src-info
|
||||
orig-str
|
||||
positive-position?)
|
||||
(((contract-projection (coerce-contract '->d rng-contract))
|
||||
blame)
|
||||
(val arg-x ...))))))))))]))
|
||||
|
||||
;; ->d*/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
|
||||
|
|
@ -694,7 +688,7 @@
|
|||
(values
|
||||
(lambda (outer-args 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 ...)
|
||||
(if method-proc?
|
||||
(cdr
|
||||
|
|
@ -703,7 +697,7 @@
|
|||
(syntax (dom-contract-x ...)))])
|
||||
(syntax
|
||||
(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])
|
||||
(check-rng-procedure '->d* rng-mk-x dom-length)
|
||||
|
|
@ -715,20 +709,20 @@
|
|||
|
||||
;; proj
|
||||
(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])
|
||||
(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))))
|
||||
|
||||
(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
|
||||
(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))
|
||||
|
||||
(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
|
||||
((arg-x ...)
|
||||
(call-with-values
|
||||
|
|
@ -742,12 +736,8 @@
|
|||
(apply
|
||||
values
|
||||
(map (lambda (rng-contract result)
|
||||
(((contract-proc (coerce-contract '->d* rng-contract))
|
||||
pos-blame
|
||||
neg-blame
|
||||
src-info
|
||||
orig-str
|
||||
positive-position?)
|
||||
(((contract-projection (coerce-contract '->d* rng-contract))
|
||||
blame)
|
||||
result))
|
||||
rng-contracts
|
||||
results))))))))))))]
|
||||
|
|
@ -763,7 +753,7 @@
|
|||
(values
|
||||
(lambda (outer-args 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 ...)
|
||||
(if method-proc?
|
||||
(cdr
|
||||
|
|
@ -774,9 +764,9 @@
|
|||
(let ([dom-contract-x (coerce-contract '->d* dom)]
|
||||
...
|
||||
[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])
|
||||
(check-rng-procedure/more rng-mk-x arity)
|
||||
(let ([name-id (build-compound-type-name
|
||||
|
|
@ -788,22 +778,22 @@
|
|||
|
||||
;; proj
|
||||
(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])
|
||||
(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))))
|
||||
|
||||
(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
|
||||
(check-procedure/more val arity '() '() #|keywords|# src-info pos-blame orig-str))))
|
||||
(check-procedure/more val arity '() '() #|keywords|# blame))))
|
||||
(syntax (check-procedure/more? arity))
|
||||
|
||||
(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
|
||||
((arg-x ... . rest-arg-x)
|
||||
(call-with-values
|
||||
|
|
@ -822,12 +812,8 @@
|
|||
(apply
|
||||
values
|
||||
(map (lambda (rng-contract result)
|
||||
(((contract-proc (coerce-contract '->d* rng-contract))
|
||||
pos-blame
|
||||
neg-blame
|
||||
src-info
|
||||
orig-str
|
||||
positive-position?)
|
||||
(((contract-projection (coerce-contract '->d* rng-contract))
|
||||
blame)
|
||||
result))
|
||||
rng-contracts
|
||||
results))))))))))))]))
|
||||
|
|
@ -880,32 +866,31 @@
|
|||
(values
|
||||
(lambda (outer-args 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
|
||||
(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 positive-position?) outer-args]
|
||||
(with-syntax ([(val blame name-id) outer-args]
|
||||
[kind-of-thing (if method-proc? 'method 'procedure)])
|
||||
(syntax
|
||||
(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))
|
||||
|
||||
(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=?
|
||||
[(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
|
||||
(not positive-position?))]
|
||||
(check-pre-expr->pp/h val pre-expr blame)
|
||||
(let ([dom-id ((contract-projection (coerce-contract 'stx-name dom))
|
||||
(blame-swap blame))]
|
||||
...)
|
||||
(val (dom-id x) ...)))))]
|
||||
[((values (rng-ids rng-ctc) ...) post-expr)
|
||||
|
|
@ -915,16 +900,14 @@
|
|||
(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
|
||||
(not positive-position?))]
|
||||
(check-pre-expr->pp/h val pre-expr (blame-swap blame))
|
||||
(let ([dom-id ((contract-projection (coerce-contract 'stx-name dom))
|
||||
(blame-swap blame))]
|
||||
...)
|
||||
(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
|
||||
positive-position?)] ...)
|
||||
(check-post-expr->pp/h val post-expr blame)
|
||||
(let ([rng-ids-x ((contract-projection (coerce-contract 'stx-name rng-ctc))
|
||||
blame)] ...)
|
||||
(values (rng-ids-x rng-ids) ...))))))))]
|
||||
[((values (rng-ids rng-ctc) ...) post-expr)
|
||||
(andmap identifier? (syntax->list (syntax (rng-ids ...))))
|
||||
|
|
@ -941,16 +924,14 @@
|
|||
(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
|
||||
(not positive-position?))]
|
||||
(check-pre-expr->pp/h val pre-expr (blame-swap blame))
|
||||
(let ([dom-id ((contract-projection (coerce-contract 'stx-name dom))
|
||||
(blame-swap blame))]
|
||||
...
|
||||
[rng-id ((contract-proc (coerce-contract 'stx-name rng))
|
||||
pos-blame neg-blame src-info orig-str
|
||||
positive-position?)])
|
||||
[rng-id ((contract-projection (coerce-contract 'stx-name rng))
|
||||
blame)])
|
||||
(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)))))]
|
||||
[_
|
||||
(raise-syntax-error name "unknown result specification" stx (syntax result-stuff))]))))))]
|
||||
|
|
@ -1000,35 +981,33 @@
|
|||
(values
|
||||
(lambda (outer-args 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
|
||||
(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 positive-position?) outer-args]
|
||||
(with-syntax ([(val blame name-id) outer-args]
|
||||
[kind-of-thing (if method-proc? 'method 'procedure)])
|
||||
(syntax
|
||||
(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))
|
||||
|
||||
(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=?
|
||||
[(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
|
||||
(not positive-position?))]
|
||||
(check-pre-expr->pp/h val pre-expr (blame-swap blame))
|
||||
(let ([dom-id ((contract-projection (coerce-contract 'stx-name dom))
|
||||
(blame-swap blame))]
|
||||
...
|
||||
[rest-id ((contract-proc (coerce-contract 'stx-name rest-dom))
|
||||
neg-blame pos-blame src-info orig-str
|
||||
(not positive-position?))])
|
||||
[rest-id ((contract-projection (coerce-contract 'stx-name rest-dom))
|
||||
(blame-swap blame))])
|
||||
(apply val (dom-id x) ... (rest-id rest-x))))))]
|
||||
[(any . x)
|
||||
(raise-syntax-error name "cannot have anything after any" stx (syntax result-stuff))]
|
||||
|
|
@ -1039,19 +1018,16 @@
|
|||
(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
|
||||
(not positive-position?))]
|
||||
(check-pre-expr->pp/h val pre-expr (blame-swap blame))
|
||||
(let ([dom-id ((contract-projection (coerce-contract 'stx-name dom))
|
||||
(blame-swap blame))]
|
||||
...
|
||||
[rest-id ((contract-proc (coerce-contract 'stx-name rest-dom))
|
||||
neg-blame pos-blame src-info orig-str
|
||||
(not positive-position?))])
|
||||
[rest-id ((contract-projection (coerce-contract 'stx-name rest-dom))
|
||||
(blame-swap blame))])
|
||||
(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
|
||||
positive-position?)] ...)
|
||||
(check-post-expr->pp/h val post-expr blame)
|
||||
(let ([rng-ids-x ((contract-projection (coerce-contract 'stx-name rng-ctc))
|
||||
blame)] ...)
|
||||
(values (rng-ids-x rng-ids) ...))))))))]
|
||||
[((values (rng-ids rng-ctc) ...) . whatever)
|
||||
(and (andmap identifier? (syntax->list (syntax (rng-ids ...))))
|
||||
|
|
@ -1073,19 +1049,16 @@
|
|||
(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
|
||||
(not positive-position?))]
|
||||
(check-pre-expr->pp/h val pre-expr (blame-swap blame))
|
||||
(let ([dom-id ((contract-projection (coerce-contract 'stx-name dom))
|
||||
(blame-swap blame))]
|
||||
...
|
||||
[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?)])
|
||||
[rest-id ((contract-projection (coerce-contract 'stx-name rest-dom))
|
||||
(blame-swap blame))]
|
||||
[rng-id ((contract-projection (coerce-contract 'stx-name rng))
|
||||
blame)])
|
||||
(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)))))]
|
||||
[(rng res-id post-expr)
|
||||
(not (identifier? (syntax res-id)))
|
||||
|
|
|
|||
|
|
@ -30,21 +30,19 @@
|
|||
[(p-app-x ...) (generate-temporaries #'(rngs ...))]
|
||||
[(res-x ...) (generate-temporaries #'(rngs ...))])
|
||||
#'(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...)
|
||||
(let ([proj-x ((proj-get rngs-x) rngs-x)] ...)
|
||||
(make-proj-contract
|
||||
(let ([proj-x (contract-projection rngs-x)] ...)
|
||||
(simple-contract
|
||||
#:name
|
||||
(build-compound-type-name 'unconstrained-domain-> ((name-get rngs-x) rngs-x) ...)
|
||||
(λ (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?)] ...)
|
||||
#:projection
|
||||
(λ (blame)
|
||||
(let ([p-app-x (proj-x blame)] ...)
|
||||
(λ (val)
|
||||
(if (procedure? val)
|
||||
(λ args
|
||||
(let-values ([(res-x ...) (apply val args)])
|
||||
(values (p-app-x res-x) ...)))
|
||||
(raise-contract-error val
|
||||
src-info
|
||||
pos-blame
|
||||
orig-str
|
||||
"expected a procedure")))))
|
||||
(raise-blame-error blame val "expected a procedure")))))
|
||||
procedure?))))]))
|
||||
|
||||
(define (build--> name doms doms-rest rngs kwds quoted-kwds rng-any? func)
|
||||
|
|
@ -64,64 +62,66 @@
|
|||
;; and it produces a wrapper-making function.
|
||||
(define-struct -> (rng-any? doms dom-rest rngs kwds quoted-kwds func)
|
||||
#:omit-define-syntaxes
|
||||
#:property proj-prop
|
||||
(λ (ctc)
|
||||
(let* ([doms/c (map (λ (x) ((proj-get x) x))
|
||||
(if (->-dom-rest ctc)
|
||||
#:property prop:contract
|
||||
(build-contract-property
|
||||
#:projection
|
||||
(λ (ctc)
|
||||
(let* ([doms/c (map contract-projection
|
||||
(if (->-dom-rest ctc)
|
||||
(append (->-doms ctc) (list (->-dom-rest ctc)))
|
||||
(->-doms ctc)))]
|
||||
[rngs/c (map (λ (x) ((proj-get x) x)) (->-rngs ctc))]
|
||||
[kwds/c (map (λ (x) ((proj-get x) x)) (->-kwds ctc))]
|
||||
[mandatory-keywords (->-quoted-kwds ctc)]
|
||||
[func (->-func ctc)]
|
||||
[dom-length (length (->-doms ctc))]
|
||||
[has-rest? (and (->-dom-rest ctc) #t)])
|
||||
(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 positive-position?))
|
||||
rngs/c)]
|
||||
[partial-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str (not positive-position?)))
|
||||
kwds/c)])
|
||||
(apply func
|
||||
(λ (val)
|
||||
(if has-rest?
|
||||
(check-procedure/more val dom-length '() mandatory-keywords src-info pos-blame orig-str)
|
||||
(check-procedure val dom-length 0 '() mandatory-keywords src-info pos-blame orig-str)))
|
||||
(append partial-doms partial-ranges partial-kwds))))))
|
||||
|
||||
#:property name-prop
|
||||
(λ (ctc) (single-arrow-name-maker
|
||||
(->-doms ctc)
|
||||
(->-dom-rest ctc)
|
||||
(->-kwds ctc)
|
||||
(->-quoted-kwds ctc)
|
||||
(->-rng-any? ctc)
|
||||
(->-rngs ctc)))
|
||||
#:property first-order-prop
|
||||
(λ (ctc)
|
||||
(let ([l (length (->-doms ctc))])
|
||||
(if (->-dom-rest ctc)
|
||||
[rngs/c (map contract-projection (->-rngs ctc))]
|
||||
[kwds/c (map contract-projection (->-kwds ctc))]
|
||||
[mandatory-keywords (->-quoted-kwds ctc)]
|
||||
[func (->-func ctc)]
|
||||
[dom-length (length (->-doms ctc))]
|
||||
[has-rest? (and (->-dom-rest ctc) #t)])
|
||||
(lambda (blame)
|
||||
(let ([partial-doms (map (λ (dom) (dom (blame-swap blame)))
|
||||
doms/c)]
|
||||
[partial-ranges (map (λ (rng) (rng blame))
|
||||
rngs/c)]
|
||||
[partial-kwds (map (λ (kwd) (kwd (blame-swap blame)))
|
||||
kwds/c)])
|
||||
(apply func
|
||||
(λ (val)
|
||||
(if has-rest?
|
||||
(check-procedure/more val dom-length '() mandatory-keywords blame)
|
||||
(check-procedure val dom-length 0 '() mandatory-keywords blame)))
|
||||
(append partial-doms partial-ranges partial-kwds))))))
|
||||
|
||||
#:name
|
||||
(λ (ctc) (single-arrow-name-maker
|
||||
(->-doms ctc)
|
||||
(->-dom-rest ctc)
|
||||
(->-kwds ctc)
|
||||
(->-quoted-kwds ctc)
|
||||
(->-rng-any? ctc)
|
||||
(->-rngs ctc)))
|
||||
#:first-order
|
||||
(λ (ctc)
|
||||
(let ([l (length (->-doms ctc))])
|
||||
(if (->-dom-rest ctc)
|
||||
(λ (x)
|
||||
(and (procedure? x)
|
||||
(procedure-accepts-and-more? x l)))
|
||||
(and (procedure? x)
|
||||
(procedure-accepts-and-more? x l)))
|
||||
(λ (x)
|
||||
(and (procedure? x)
|
||||
(procedure-arity-includes? x l)
|
||||
(no-mandatory-keywords? x))))))
|
||||
#:property stronger-prop
|
||||
(λ (this that)
|
||||
(and (->? that)
|
||||
(= (length (->-doms that))
|
||||
(length (->-doms this)))
|
||||
(andmap contract-stronger?
|
||||
(->-doms that)
|
||||
(->-doms this))
|
||||
(= (length (->-rngs that))
|
||||
(length (->-rngs this)))
|
||||
(andmap contract-stronger?
|
||||
(->-rngs this)
|
||||
(->-rngs that)))))
|
||||
(and (procedure? x)
|
||||
(procedure-arity-includes? x l)
|
||||
(no-mandatory-keywords? x))))))
|
||||
#:stronger
|
||||
(λ (this that)
|
||||
(and (->? that)
|
||||
(= (length (->-doms that))
|
||||
(length (->-doms this)))
|
||||
(andmap contract-stronger?
|
||||
(->-doms that)
|
||||
(->-doms this))
|
||||
(= (length (->-rngs that))
|
||||
(length (->-rngs this)))
|
||||
(andmap contract-stronger?
|
||||
(->-rngs this)
|
||||
(->-rngs that))))))
|
||||
|
||||
(define (single-arrow-name-maker doms/c doms-rest kwds/c kwds rng-any? rngs)
|
||||
(cond
|
||||
|
|
@ -455,16 +455,14 @@
|
|||
(append partials-rngs partial)
|
||||
(append this-stronger-ribs stronger-ribs)))]))])
|
||||
(values
|
||||
(with-syntax ((pos (opt/info-pos opt/info))
|
||||
(src-info (opt/info-src-info opt/info))
|
||||
(orig-str (opt/info-orig-str opt/info))
|
||||
(with-syntax ((blame (opt/info-blame opt/info))
|
||||
((dom-arg ...) dom-vars)
|
||||
((rng-arg ...) rng-vars)
|
||||
((next-dom ...) next-doms)
|
||||
(dom-len (length dom-vars))
|
||||
((next-rng ...) next-rngs))
|
||||
(syntax (begin
|
||||
(check-procedure val dom-len 0 '() '() #| keywords |# src-info pos orig-str)
|
||||
(check-procedure val dom-len 0 '() '() #| keywords |# blame)
|
||||
(λ (dom-arg ...)
|
||||
(let-values ([(rng-arg ...) (val next-dom ...)])
|
||||
(values next-rng ...))))))
|
||||
|
|
@ -505,14 +503,12 @@
|
|||
(append partials-doms partial)
|
||||
(append this-stronger-ribs stronger-ribs)))]))])
|
||||
(values
|
||||
(with-syntax ((pos (opt/info-pos opt/info))
|
||||
(src-info (opt/info-src-info opt/info))
|
||||
(orig-str (opt/info-orig-str opt/info))
|
||||
(with-syntax ((blame (opt/info-blame opt/info))
|
||||
((dom-arg ...) dom-vars)
|
||||
((next-dom ...) next-doms)
|
||||
(dom-len (length dom-vars)))
|
||||
(syntax (begin
|
||||
(check-procedure val dom-len 0 '() '() #|keywords|# src-info pos orig-str)
|
||||
(check-procedure val dom-len 0 '() '() #|keywords|# blame)
|
||||
(λ (dom-arg ...)
|
||||
(val next-dom ...)))))
|
||||
lifts-doms
|
||||
|
|
|
|||
|
|
@ -344,24 +344,24 @@
|
|||
`(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 positive-position?)
|
||||
(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 ...)])
|
||||
(lambda (val)
|
||||
(check-object val src-info pos-blame orig-str)
|
||||
(check-object val blame)
|
||||
(let ([val-mtd-names
|
||||
(interface->method-names
|
||||
(object-interface
|
||||
val))])
|
||||
(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)
|
||||
(field-error val 'field-name src-info pos-blame orig-str)) ...
|
||||
(field-error val 'field-name blame)) ...
|
||||
|
||||
(let ([vtable (extract-vtable val)]
|
||||
[method-ht (extract-method-ht val)])
|
||||
|
|
@ -373,31 +373,16 @@
|
|||
#f)))))))]))))
|
||||
|
||||
|
||||
(define (check-object val src-info blame orig-str)
|
||||
(define (check-object val blame)
|
||||
(unless (object? val)
|
||||
(raise-contract-error val
|
||||
src-info
|
||||
blame
|
||||
orig-str
|
||||
"expected an object, got ~e"
|
||||
val)))
|
||||
(raise-blame-error blame val "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)
|
||||
(raise-contract-error val
|
||||
src-info
|
||||
blame
|
||||
orig-str
|
||||
"expected an object with method ~s"
|
||||
method-name)))
|
||||
(raise-blame-error blame val "expected an object with method ~s" method-name)))
|
||||
|
||||
(define (field-error val field-name src-info blame orig-str)
|
||||
(raise-contract-error val
|
||||
src-info
|
||||
blame
|
||||
orig-str
|
||||
"expected an object with field ~s"
|
||||
field-name))
|
||||
(define (field-error val field-name blame)
|
||||
(raise-blame-error blame val "expected an object with field ~s" field-name))
|
||||
|
||||
(define (make-mixin-contract . %/<%>s)
|
||||
((and/c (flat-contract class?)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user