added keywords to ->*
svn: r8049 original commit: a3f3dcb64d106142806d4febd5c02bc97352b923
This commit is contained in:
Robby Findler
parent
4c1acd1bb6
commit
1e8e36b48f
|
|
@ -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)])
|
||||||
|
|
|
||||||
|
|
@ -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