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

added keywords to ->*

Browse Source 
svn: r8049

original commit: a3f3dcb64d106142806d4febd5c02bc97352b923
This commit is contained in:
Robby Findler 2007-12-18 20:19:11 +00:00
parent 4c1acd1bb6
commit 1e8e36b48f
2 changed files with 155 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

62
collects/scheme/private/contract-arrow.ss
View File

@ -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,24 +299,40 @@ 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 ...))
[(->* (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)))]
[(rng-x ...) (generate-temporaries (syntax (rngs ...)))]
[(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
(syntax ((args ... . rest-arg)
(let-values ([(rng-args ...) (apply val (dom-x args) ... (rst-x rest-arg))])
(values (rng-x rng-args) ...))))])
#`((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 ...)
(lambda (chk dom-x ... rst-x rng-x ... dom-kwd-ctc-id ...)
(lambda (val)
(chk val)
inner-lambda)))])
@ -324,27 +340,29 @@ Add both optional and mandatory keywords to opt-> and friends.
(list doms ...)
rst
(list rngs ...)
'()
'()
(list dom-kwd-ctc ...)
'(dom-kwd ...)
#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)))])
[any
(let ([inner-args/body
(syntax ((args ... . rest-arg)
(apply val (dom-x args) ... (rst-x rest-arg))))])
#`((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)
(lambda (chk dom-x ... rst-x ignored dom-kwd-ctc-id ...)
(lambda (val)
(chk val)
inner-lambda)))])
@ -352,12 +370,12 @@ Add both optional and mandatory keywords to opt-> and friends.
(list doms ...)
rst
(list any/c)
'()
'()
(list dom-kwd-ctc ...)
'(dom-kwd ...)
#t
outer-lambda))
inner-args/body
(syntax (dom-x ... rst-x)))))))]))
(syntax (dom-x ... rst-x))))))])))))]))
(define-syntax (->* stx)
(let-values ([(stx _1 _2) (->*/proc/main stx)])

76
collects/tests/mzscheme/contract-test.ss
View File

@ -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?))