added keywords to ->*
svn: r8049
This commit is contained in:
Robby Findler
parent
9dcef875fe
commit
a3f3dcb64d
|
|
@ -4,11 +4,11 @@
|
||||||
|
|
||||||
keywords done:
|
keywords done:
|
||||||
|
|
||||||
- added mandatory keywords to ->
|
- added mandatory keywords to ->, ->*
|
||||||
|
|
||||||
keywords todo:
|
keywords todo:
|
||||||
|
|
||||||
add mandatory keywords to ->* ->d ->d*
|
add mandatory keywords to ->d ->d*
|
||||||
|
|
||||||
Add both optional and mandatory keywords to opt-> and friends.
|
Add both optional and mandatory keywords to opt-> and friends.
|
||||||
(Update opt-> so that it doesn't use case-lambda anymore.)
|
(Update opt-> so that it doesn't use case-lambda anymore.)
|
||||||
|
|
@ -299,65 +299,83 @@ Add both optional and mandatory keywords to opt-> and friends.
|
||||||
(->/proc/main (syntax (-> doms ... any)))]
|
(->/proc/main (syntax (-> doms ... any)))]
|
||||||
[(->* (doms ...) (rngs ...))
|
[(->* (doms ...) (rngs ...))
|
||||||
(->/proc/main (syntax (-> doms ... (values rngs ...))))]
|
(->/proc/main (syntax (-> doms ... (values rngs ...))))]
|
||||||
[(->* (doms ...) rst (rngs ...))
|
[(->* (raw-doms ...) rst rng)
|
||||||
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (doms ...)))]
|
(with-syntax ([((doms ...) ((dom-kwd dom-kwd-ctc) ...)) (split-doms stx '-> #'(raw-doms ...))])
|
||||||
[(args ...) (generate-temporaries (syntax (doms ...)))]
|
(with-syntax ([(dom-kwd-arg ...) (generate-temporaries (syntax (dom-kwd ...)))]
|
||||||
[(rst-x) (generate-temporaries (syntax (rst)))]
|
[(dom-kwd-ctc-id ...) (generate-temporaries (syntax (dom-kwd ...)))])
|
||||||
[(rest-arg) (generate-temporaries (syntax (rst)))]
|
(with-syntax ([(keyword-formal-parameters ...) (apply append (map syntax->list (syntax->list #'((dom-kwd dom-kwd-arg) ...))))]
|
||||||
[(rng-x ...) (generate-temporaries (syntax (rngs ...)))]
|
[(args ...) (generate-temporaries (syntax (doms ...)))]
|
||||||
[(rng-args ...) (generate-temporaries (syntax (rngs ...)))])
|
[(dom-ctc ...) (generate-temporaries (syntax (doms ...)))])
|
||||||
(let ([inner-args/body
|
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (doms ...)))]
|
||||||
(syntax ((args ... . rest-arg)
|
[(args ...) (generate-temporaries (syntax (doms ...)))]
|
||||||
(let-values ([(rng-args ...) (apply val (dom-x args) ... (rst-x rest-arg))])
|
[(rst-x) (generate-temporaries (syntax (rst)))]
|
||||||
(values (rng-x rng-args) ...))))])
|
[(rest-arg) (generate-temporaries (syntax (rst)))])
|
||||||
(with-syntax ([inner-lambda (with-syntax ([(args body) inner-args/body])
|
(syntax-case #'rng (any)
|
||||||
(add-name-prop
|
[(rngs ...)
|
||||||
(syntax-local-infer-name stx)
|
(with-syntax ([(rng-x ...) (generate-temporaries (syntax (rngs ...)))]
|
||||||
(syntax (lambda args body))))])
|
[(rng-args ...) (generate-temporaries (syntax (rngs ...)))])
|
||||||
(with-syntax ([outer-lambda
|
|
||||||
(syntax
|
(let ([inner-args/body
|
||||||
(lambda (chk dom-x ... rst-x rng-x ...)
|
#`((args ... keyword-formal-parameters ... . rest-arg)
|
||||||
(lambda (val)
|
(let-values ([(rng-args ...)
|
||||||
(chk val)
|
#,(if (null? (syntax-e #'(dom-kwd ...)))
|
||||||
inner-lambda)))])
|
#'(apply val (dom-x args) ... (rst-x rest-arg))
|
||||||
(values (syntax (build--> '->*
|
#'(keyword-apply val
|
||||||
(list doms ...)
|
'(dom-kwd ...)
|
||||||
rst
|
(list (dom-kwd-ctc-id dom-kwd-arg) ...)
|
||||||
(list rngs ...)
|
(dom-x args) ...
|
||||||
'()
|
(rst-x rest-arg)))])
|
||||||
'()
|
(values (rng-x rng-args) ...)))])
|
||||||
#f
|
(with-syntax ([inner-lambda (with-syntax ([(args body) inner-args/body])
|
||||||
outer-lambda))
|
(add-name-prop
|
||||||
inner-args/body
|
(syntax-local-infer-name stx)
|
||||||
(syntax (dom-x ... rst-x rng-x ...)))))))]
|
(syntax (lambda args body))))])
|
||||||
[(->* (doms ...) rst any)
|
(with-syntax ([outer-lambda
|
||||||
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (doms ...)))]
|
(syntax
|
||||||
[(args ...) (generate-temporaries (syntax (doms ...)))]
|
(lambda (chk dom-x ... rst-x rng-x ... dom-kwd-ctc-id ...)
|
||||||
[(rst-x) (generate-temporaries (syntax (rst)))]
|
(lambda (val)
|
||||||
[(rest-arg) (generate-temporaries (syntax (rst)))])
|
(chk val)
|
||||||
(let ([inner-args/body
|
inner-lambda)))])
|
||||||
(syntax ((args ... . rest-arg)
|
(values (syntax (build--> '->*
|
||||||
(apply val (dom-x args) ... (rst-x rest-arg))))])
|
(list doms ...)
|
||||||
(with-syntax ([inner-lambda (with-syntax ([(args body) inner-args/body])
|
rst
|
||||||
(add-name-prop
|
(list rngs ...)
|
||||||
(syntax-local-infer-name stx)
|
(list dom-kwd-ctc ...)
|
||||||
(syntax (lambda args body))))])
|
'(dom-kwd ...)
|
||||||
(with-syntax ([outer-lambda
|
#f
|
||||||
(syntax
|
outer-lambda))
|
||||||
(lambda (chk dom-x ... rst-x ignored)
|
inner-args/body
|
||||||
(lambda (val)
|
(syntax (dom-x ... rst-x rng-x ...)))))))]
|
||||||
(chk val)
|
[any
|
||||||
inner-lambda)))])
|
(let ([inner-args/body
|
||||||
(values (syntax (build--> '->*
|
#`((args ... keyword-formal-parameters ... . rest-arg)
|
||||||
(list doms ...)
|
#,(if (null? (syntax-e #'(dom-kwd ...)))
|
||||||
rst
|
#'(apply val (dom-x args) ... (rst-x rest-arg))
|
||||||
(list any/c)
|
#'(keyword-apply val
|
||||||
'()
|
'(dom-kwd ...)
|
||||||
'()
|
(list (dom-kwd-ctc-id dom-kwd-arg) ...)
|
||||||
#t
|
(dom-x args) ...
|
||||||
outer-lambda))
|
(rst-x rest-arg))))])
|
||||||
inner-args/body
|
(with-syntax ([inner-lambda (with-syntax ([(args body) inner-args/body])
|
||||||
(syntax (dom-x ... rst-x)))))))]))
|
(add-name-prop
|
||||||
|
(syntax-local-infer-name stx)
|
||||||
|
(syntax (lambda args body))))])
|
||||||
|
(with-syntax ([outer-lambda
|
||||||
|
(syntax
|
||||||
|
(lambda (chk dom-x ... rst-x ignored dom-kwd-ctc-id ...)
|
||||||
|
(lambda (val)
|
||||||
|
(chk val)
|
||||||
|
inner-lambda)))])
|
||||||
|
(values (syntax (build--> '->*
|
||||||
|
(list doms ...)
|
||||||
|
rst
|
||||||
|
(list any/c)
|
||||||
|
(list dom-kwd-ctc ...)
|
||||||
|
'(dom-kwd ...)
|
||||||
|
#t
|
||||||
|
outer-lambda))
|
||||||
|
inner-args/body
|
||||||
|
(syntax (dom-x ... rst-x))))))])))))]))
|
||||||
|
|
||||||
(define-syntax (->* stx)
|
(define-syntax (->* stx)
|
||||||
(let-values ([(stx _1 _2) (->*/proc/main stx)])
|
(let-values ([(stx _1 _2) (->*/proc/main stx)])
|
||||||
|
|
|
||||||
|
|
@ -363,18 +363,30 @@ If @scheme[(values res-expr ...)] is used as the last sub-form of
|
||||||
@scheme[->], the function must produce a result for each contract, and
|
@scheme[->], the function must produce a result for each contract, and
|
||||||
each values must match its respective contract.}
|
each values must match its respective contract.}
|
||||||
|
|
||||||
@defform*[#:literals (any)
|
@;{
|
||||||
[(->* (expr ...) (res-expr ...))
|
@defform*/subs[#:literals (any)
|
||||||
(->* (expr ...) rest-expr (res-expr ...))
|
[(->* (mandatory-dom ...) (optional-dom ...) rest-expr range)
|
||||||
(->* (expr ...) any)
|
(->* (mandatory-dom ...) (optional-dom ...) range)]
|
||||||
(->* (expr ...) rest-expr any)]]{
|
([mandatory-dom dom-expr (code:line keyword dom-expr)]
|
||||||
|
[optional-dom dom-expr (code:line keyword dom-expr)]
|
||||||
|
[range (range-expr ...) any])]{
|
||||||
|
new one
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
Like @scheme[->], but for functions that return multiple results
|
@defform*/subs[#:literals (any)
|
||||||
and/or have ``rest'' arguments. The @scheme[expr]s specify contracts
|
[(->* (dom ...) (res-expr ...))
|
||||||
on the initial arguments, and @scheme[rest-expr] (if supplied)
|
(->* (dom ...) rest-expr (res-expr ...))
|
||||||
specifies a contract on an additional ``rest'' argument, which is
|
(->* (dom ...) any)
|
||||||
always a list. Each @scheme[res-expr] specifies a contract on a
|
(->* (dom ...) rest-expr any)]
|
||||||
result from the function.
|
([dom dom-expr (code:line keyword dom-expr)])]{
|
||||||
|
|
||||||
|
Like @scheme[->], but for functions that have ``rest''
|
||||||
|
arguments. The @scheme[dom]s specify contracts on the
|
||||||
|
initial arguments, and @scheme[rest-expr] (if supplied)
|
||||||
|
specifies a contract on an additional ``rest'' argument,
|
||||||
|
which is always a list. Each @scheme[res-expr] specifies a
|
||||||
|
contract on a result from the function.
|
||||||
|
|
||||||
For example, a function that accepts one or more integer arguments and
|
For example, a function that accepts one or more integer arguments and
|
||||||
returns one boolean would have the following contract:
|
returns one boolean would have the following contract:
|
||||||
|
|
|
||||||
|
|
@ -394,6 +394,82 @@
|
||||||
'pos
|
'pos
|
||||||
'neg))
|
'neg))
|
||||||
|
|
||||||
|
(test/pos-blame
|
||||||
|
'contract-arrow-star-keyword1
|
||||||
|
'(contract (->* (integer?) (listof integer?) (integer?))
|
||||||
|
(λ (x #:y y . args) x)
|
||||||
|
'pos
|
||||||
|
'neg))
|
||||||
|
|
||||||
|
(test/pos-blame
|
||||||
|
'contract-arrow-star-keyword2
|
||||||
|
'(contract (->* (integer?) (listof integer?) any)
|
||||||
|
(λ (x #:y y . args) x)
|
||||||
|
'pos
|
||||||
|
'neg))
|
||||||
|
|
||||||
|
(test/spec-passed
|
||||||
|
'contract-arrow-star-keyword3
|
||||||
|
'(contract (->* (integer? #:y integer?) (listof integer?) (integer? integer?))
|
||||||
|
(λ (x #:y y . args) x)
|
||||||
|
'pos
|
||||||
|
'neg))
|
||||||
|
|
||||||
|
(test/spec-passed
|
||||||
|
'contract-arrow-star-keyword4
|
||||||
|
'(contract (->* (integer? #:y integer?) (listof integer?) any)
|
||||||
|
(λ (x #:y y . args) x)
|
||||||
|
'pos
|
||||||
|
'neg))
|
||||||
|
|
||||||
|
(test/neg-blame
|
||||||
|
'contract-arrow-star-keyword5
|
||||||
|
'((contract (->* (integer? #:y integer?) (listof integer?) (integer? integer?))
|
||||||
|
(λ (x #:y y . args) x)
|
||||||
|
'pos
|
||||||
|
'neg)
|
||||||
|
1 #:y #t))
|
||||||
|
|
||||||
|
(test/neg-blame
|
||||||
|
'contract-arrow-star-keyword6
|
||||||
|
'((contract (->* (integer? #:y integer?) (listof integer?) any)
|
||||||
|
(λ (x #:y y . args) x)
|
||||||
|
'pos
|
||||||
|
'neg)
|
||||||
|
1 #:y #t))
|
||||||
|
|
||||||
|
(test/neg-blame
|
||||||
|
'contract-arrow-star-keyword7
|
||||||
|
'((contract (->* (integer? #:y integer?) (listof integer?) (integer? integer?))
|
||||||
|
(λ (x #:y y . args) x)
|
||||||
|
'pos
|
||||||
|
'neg)
|
||||||
|
#t #:y 1))
|
||||||
|
|
||||||
|
(test/neg-blame
|
||||||
|
'contract-arrow-star-keyword8
|
||||||
|
'((contract (->* (integer? #:y integer?) (listof integer?) any)
|
||||||
|
(λ (x #:y y . args) x)
|
||||||
|
'pos
|
||||||
|
'neg)
|
||||||
|
#t #:y 1))
|
||||||
|
|
||||||
|
(test/spec-passed
|
||||||
|
'contract-arrow-star-keyword9
|
||||||
|
'((contract (->* (integer? #:y integer?) (listof integer?) (integer? integer?))
|
||||||
|
(λ (x #:y y . args) (values x x))
|
||||||
|
'pos
|
||||||
|
'neg)
|
||||||
|
2 #:y 1))
|
||||||
|
|
||||||
|
(test/spec-passed
|
||||||
|
'contract-arrow-star-keyword10
|
||||||
|
'((contract (->* (integer? #:y integer?) (listof integer?) any)
|
||||||
|
(λ (x #:y y . args) (values x x))
|
||||||
|
'pos
|
||||||
|
'neg)
|
||||||
|
2 #:y 1))
|
||||||
|
|
||||||
(test/spec-passed
|
(test/spec-passed
|
||||||
'contract-arrow-values1
|
'contract-arrow-values1
|
||||||
'(let-values ([(a b) ((contract (-> integer? (values integer? integer?))
|
'(let-values ([(a b) ((contract (-> integer? (values integer? integer?))
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user