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

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

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