added keywords to ->*
svn: r8049
This commit is contained in:
Robby Findler
parent
9dcef875fe
commit
a3f3dcb64d
|
|
@ -4,11 +4,11 @@
|
|||
|
||||
keywords done:
|
||||
|
||||
- added mandatory keywords to ->
|
||||
- added mandatory keywords to ->, ->*
|
||||
|
||||
keywords todo:
|
||||
|
||||
add mandatory keywords to ->* ->d ->d*
|
||||
add mandatory keywords to ->d ->d*
|
||||
|
||||
Add both optional and mandatory keywords to opt-> and friends.
|
||||
(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)))]
|
||||
[(->* (doms ...) (rngs ...))
|
||||
(->/proc/main (syntax (-> doms ... (values rngs ...))))]
|
||||
[(->* (doms ...) rst (rngs ...))
|
||||
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (doms ...)))]
|
||||
[(args ...) (generate-temporaries (syntax (doms ...)))]
|
||||
[(rst-x) (generate-temporaries (syntax (rst)))]
|
||||
[(rest-arg) (generate-temporaries (syntax (rst)))]
|
||||
[(rng-x ...) (generate-temporaries (syntax (rngs ...)))]
|
||||
[(rng-args ...) (generate-temporaries (syntax (rngs ...)))])
|
||||
(let ([inner-args/body
|
||||
(syntax ((args ... . rest-arg)
|
||||
(let-values ([(rng-args ...) (apply val (dom-x args) ... (rst-x rest-arg))])
|
||||
(values (rng-x rng-args) ...))))])
|
||||
(with-syntax ([inner-lambda (with-syntax ([(args body) inner-args/body])
|
||||
(add-name-prop
|
||||
(syntax-local-infer-name stx)
|
||||
(syntax (lambda args body))))])
|
||||
(with-syntax ([outer-lambda
|
||||
(syntax
|
||||
(lambda (chk dom-x ... rst-x rng-x ...)
|
||||
(lambda (val)
|
||||
(chk val)
|
||||
inner-lambda)))])
|
||||
(values (syntax (build--> '->*
|
||||
(list doms ...)
|
||||
rst
|
||||
(list rngs ...)
|
||||
'()
|
||||
'()
|
||||
#f
|
||||
outer-lambda))
|
||||
inner-args/body
|
||||
(syntax (dom-x ... rst-x rng-x ...)))))))]
|
||||
[(->* (doms ...) rst any)
|
||||
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (doms ...)))]
|
||||
[(args ...) (generate-temporaries (syntax (doms ...)))]
|
||||
[(rst-x) (generate-temporaries (syntax (rst)))]
|
||||
[(rest-arg) (generate-temporaries (syntax (rst)))])
|
||||
(let ([inner-args/body
|
||||
(syntax ((args ... . rest-arg)
|
||||
(apply val (dom-x args) ... (rst-x rest-arg))))])
|
||||
(with-syntax ([inner-lambda (with-syntax ([(args body) inner-args/body])
|
||||
(add-name-prop
|
||||
(syntax-local-infer-name stx)
|
||||
(syntax (lambda args body))))])
|
||||
(with-syntax ([outer-lambda
|
||||
(syntax
|
||||
(lambda (chk dom-x ... rst-x ignored)
|
||||
(lambda (val)
|
||||
(chk val)
|
||||
inner-lambda)))])
|
||||
(values (syntax (build--> '->*
|
||||
(list doms ...)
|
||||
rst
|
||||
(list any/c)
|
||||
'()
|
||||
'()
|
||||
#t
|
||||
outer-lambda))
|
||||
inner-args/body
|
||||
(syntax (dom-x ... rst-x)))))))]))
|
||||
[(->* (raw-doms ...) rst rng)
|
||||
(with-syntax ([((doms ...) ((dom-kwd dom-kwd-ctc) ...)) (split-doms stx '-> #'(raw-doms ...))])
|
||||
(with-syntax ([(dom-kwd-arg ...) (generate-temporaries (syntax (dom-kwd ...)))]
|
||||
[(dom-kwd-ctc-id ...) (generate-temporaries (syntax (dom-kwd ...)))])
|
||||
(with-syntax ([(keyword-formal-parameters ...) (apply append (map syntax->list (syntax->list #'((dom-kwd dom-kwd-arg) ...))))]
|
||||
[(args ...) (generate-temporaries (syntax (doms ...)))]
|
||||
[(dom-ctc ...) (generate-temporaries (syntax (doms ...)))])
|
||||
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (doms ...)))]
|
||||
[(args ...) (generate-temporaries (syntax (doms ...)))]
|
||||
[(rst-x) (generate-temporaries (syntax (rst)))]
|
||||
[(rest-arg) (generate-temporaries (syntax (rst)))])
|
||||
(syntax-case #'rng (any)
|
||||
[(rngs ...)
|
||||
(with-syntax ([(rng-x ...) (generate-temporaries (syntax (rngs ...)))]
|
||||
[(rng-args ...) (generate-temporaries (syntax (rngs ...)))])
|
||||
|
||||
(let ([inner-args/body
|
||||
#`((args ... keyword-formal-parameters ... . rest-arg)
|
||||
(let-values ([(rng-args ...)
|
||||
#,(if (null? (syntax-e #'(dom-kwd ...)))
|
||||
#'(apply val (dom-x args) ... (rst-x rest-arg))
|
||||
#'(keyword-apply val
|
||||
'(dom-kwd ...)
|
||||
(list (dom-kwd-ctc-id dom-kwd-arg) ...)
|
||||
(dom-x args) ...
|
||||
(rst-x rest-arg)))])
|
||||
(values (rng-x rng-args) ...)))])
|
||||
(with-syntax ([inner-lambda (with-syntax ([(args body) inner-args/body])
|
||||
(add-name-prop
|
||||
(syntax-local-infer-name stx)
|
||||
(syntax (lambda args body))))])
|
||||
(with-syntax ([outer-lambda
|
||||
(syntax
|
||||
(lambda (chk dom-x ... rst-x rng-x ... dom-kwd-ctc-id ...)
|
||||
(lambda (val)
|
||||
(chk val)
|
||||
inner-lambda)))])
|
||||
(values (syntax (build--> '->*
|
||||
(list doms ...)
|
||||
rst
|
||||
(list rngs ...)
|
||||
(list dom-kwd-ctc ...)
|
||||
'(dom-kwd ...)
|
||||
#f
|
||||
outer-lambda))
|
||||
inner-args/body
|
||||
(syntax (dom-x ... rst-x rng-x ...)))))))]
|
||||
[any
|
||||
(let ([inner-args/body
|
||||
#`((args ... keyword-formal-parameters ... . rest-arg)
|
||||
#,(if (null? (syntax-e #'(dom-kwd ...)))
|
||||
#'(apply val (dom-x args) ... (rst-x rest-arg))
|
||||
#'(keyword-apply val
|
||||
'(dom-kwd ...)
|
||||
(list (dom-kwd-ctc-id dom-kwd-arg) ...)
|
||||
(dom-x args) ...
|
||||
(rst-x rest-arg))))])
|
||||
(with-syntax ([inner-lambda (with-syntax ([(args body) inner-args/body])
|
||||
(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)
|
||||
(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
|
||||
each values must match its respective contract.}
|
||||
|
||||
@defform*[#:literals (any)
|
||||
[(->* (expr ...) (res-expr ...))
|
||||
(->* (expr ...) rest-expr (res-expr ...))
|
||||
(->* (expr ...) any)
|
||||
(->* (expr ...) rest-expr any)]]{
|
||||
@;{
|
||||
@defform*/subs[#:literals (any)
|
||||
[(->* (mandatory-dom ...) (optional-dom ...) rest-expr range)
|
||||
(->* (mandatory-dom ...) (optional-dom ...) range)]
|
||||
([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
|
||||
and/or have ``rest'' arguments. The @scheme[expr]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.
|
||||
@defform*/subs[#:literals (any)
|
||||
[(->* (dom ...) (res-expr ...))
|
||||
(->* (dom ...) rest-expr (res-expr ...))
|
||||
(->* (dom ...) any)
|
||||
(->* (dom ...) rest-expr any)]
|
||||
([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
|
||||
returns one boolean would have the following contract:
|
||||
|
|
|
|||
|
|
@ -394,6 +394,82 @@
|
|||
'pos
|
||||
'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
|
||||
'contract-arrow-values1
|
||||
'(let-values ([(a b) ((contract (-> integer? (values integer? integer?))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user