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

made the optional arguments clause itself optional for ->*

Browse Source
This commit is contained in:
Robby Findler 2010-08-13 08:14:13 -05:00
parent 120e6a25ee
commit bdd37c58f0
2 changed files with 83 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

103
collects/racket/contract/private/arrow.rkt
View File

@ -239,8 +239,12 @@ v4 todo:
build-compound-type-name build-compound-type-name
'->* '->*
(apply build-compound-type-name (append doms/c (apply append (map list kwds kwds/c)))) (apply build-compound-type-name (append doms/c (apply append (map list kwds kwds/c))))
(apply build-compound-type-name (append optional-doms/c (apply append (map list optional-kwds optional-kwds/c)))) (append (let ([opts
(append (if doms-rest (apply build-compound-type-name (append optional-doms/c (apply append (map list optional-kwds optional-kwds/c))))])
(if (null? opts)
'()
(list opts)))
(if doms-rest
(list '#:rest doms-rest) (list '#:rest doms-rest)
(list)) (list))
(if pre (if pre
@ -537,7 +541,20 @@ v4 todo:
(raise-syntax-error #f "duplicate keyword" stx (car kwds)))))) (raise-syntax-error #f "duplicate keyword" stx (car kwds))))))
(define-for-syntax (parse-leftover->* stx leftover) (define-for-syntax (parse-leftover->* stx leftover)
(let*-values ([(rst leftover) (let*-values ([(raw-optional-doms leftover)
(syntax-case leftover ()
[(kwd . rst)
(keyword? (syntax-e #'kwd))
(values #'() leftover)]
[(rng #:post . rst)
(values #'() leftover)]
[(rng)
(values #'() leftover)]
[((raw-optional-dom ...) . leftover)
(values #'(raw-optional-dom ...) #'leftover)]
[_
(values #'() leftover)])]
[(rst leftover)
(syntax-case leftover () (syntax-case leftover ()
[(#:rest rest-expr . leftover) [(#:rest rest-expr . leftover)
(values #'rest-expr #'leftover)] (values #'rest-expr #'leftover)]
@ -567,53 +584,53 @@ v4 todo:
[else [else
(values #f leftover)])]) (values #f leftover)])])
(syntax-case leftover () (syntax-case leftover ()
[() (values rst pre rng post)] [() (values raw-optional-doms rst pre rng post)]
[x (raise-syntax-error #f "expected the end of the contract" stx #'x)]))) [x (raise-syntax-error #f "expected the end of the contract" stx #'x)])))
;; ->*/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names]) ;; ->*/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names])
(define-for-syntax (->*/proc/main stx) (define-for-syntax (->*/proc/main stx)
(syntax-case* stx (->* any) module-or-top-identifier=? (syntax-case* stx (->* any) module-or-top-identifier=?
[(->* (raw-mandatory-dom ...) (raw-optional-dom ...) . rst) [(->* (raw-mandatory-dom ...) . rst)
(with-syntax ([((mandatory-dom ...) ((mandatory-dom-kwd mandatory-dom-kwd-ctc) ...)) (let-values ([(raw-optional-doms rest-ctc pre rng-ctc post)
(split-doms stx '->* #'(raw-mandatory-dom ...))] ;; rest-ctc (or/c #f syntax) -- #f means no rest contract, syntax is the contract
[((optional-dom ...) ((optional-dom-kwd optional-dom-kwd-ctc) ...)) ;; rng-ctc (or/c #f syntax) -- #f means `any', syntax is a sequence of result values
(split-doms stx '->* #'(raw-optional-dom ...))]) (parse-leftover->* stx #'rst)])
;(check-duplicate-kwds stx (syntax->list #'(mandatory-dom-kwd ... optional-dom-kwd ...))) (with-syntax ([((mandatory-dom ...) ((mandatory-dom-kwd mandatory-dom-kwd-ctc) ...))
(with-syntax ([(mandatory-dom-proj ...) (generate-temporaries #'(mandatory-dom ...))] (split-doms stx '->* #'(raw-mandatory-dom ...))]
[(mandatory-dom-arg ...) (generate-temporaries #'(mandatory-dom ...))] [((optional-dom ...) ((optional-dom-kwd optional-dom-kwd-ctc) ...))
[(mandatory-dom-kwd-proj ...) (generate-temporaries #'(mandatory-dom-kwd ...))] (split-doms stx '->* raw-optional-doms)])
[(mandatory-dom-kwd-arg ...) (generate-temporaries #'(mandatory-dom-kwd ...))] ;(check-duplicate-kwds stx (syntax->list #'(mandatory-dom-kwd ... optional-dom-kwd ...)))
(with-syntax ([(mandatory-dom-proj ...) (generate-temporaries #'(mandatory-dom ...))]
[(optional-dom-proj ...) (generate-temporaries #'(optional-dom ...))] [(mandatory-dom-arg ...) (generate-temporaries #'(mandatory-dom ...))]
[(optional-dom-arg ...) (generate-temporaries #'(optional-dom ...))] [(mandatory-dom-kwd-proj ...) (generate-temporaries #'(mandatory-dom-kwd ...))]
[(optional-dom-kwd-proj ...) (generate-temporaries #'(optional-dom-kwd ...))] [(mandatory-dom-kwd-arg ...) (generate-temporaries #'(mandatory-dom-kwd ...))]
[(optional-dom-kwd-arg ...) (generate-temporaries #'(optional-dom-kwd ...))])
(with-syntax ([(mandatory-dom-kwd/var-seq ...) (apply append [(optional-dom-proj ...) (generate-temporaries #'(optional-dom ...))]
(map list [(optional-dom-arg ...) (generate-temporaries #'(optional-dom ...))]
(syntax->list #'(mandatory-dom-kwd ...)) [(optional-dom-kwd-proj ...) (generate-temporaries #'(optional-dom-kwd ...))]
(syntax->list #'(mandatory-dom-kwd-arg ...))))] [(optional-dom-kwd-arg ...) (generate-temporaries #'(optional-dom-kwd ...))])
[(optional-dom-kwd/var-seq ...) (apply append (with-syntax ([(mandatory-dom-kwd/var-seq ...) (apply append
(map list
(syntax->list #'(optional-dom-kwd ...))
(syntax->list #'([optional-dom-kwd-arg unspecified-dom] ...))))]
[(mandatory-dom-kwd-proj-apps ...) (apply append
(map list (map list
(syntax->list #'(mandatory-dom-kwd ...)) (syntax->list #'(mandatory-dom-kwd ...))
(syntax->list #'((mandatory-dom-kwd-proj mandatory-dom-kwd-arg) ...))))] (syntax->list #'(mandatory-dom-kwd-arg ...))))]
[((sorted-dom-kwd sorted-dom-kwd-arg sorted-dom-kwd-proj) ...) [(optional-dom-kwd/var-seq ...) (apply append
(sort-keywords stx (syntax->list (map list
#'((mandatory-dom-kwd mandatory-dom-kwd-arg mandatory-dom-kwd-proj) ... (syntax->list #'(optional-dom-kwd ...))
(optional-dom-kwd optional-dom-kwd-arg optional-dom-kwd-proj) ...)))]) (syntax->list #'([optional-dom-kwd-arg unspecified-dom] ...))))]
(with-syntax ([((rev-sorted-dom-kwd rev-sorted-dom-kwd-arg rev-sorted-dom-kwd-proj) ...) [(mandatory-dom-kwd-proj-apps ...) (apply append
(reverse (syntax->list #'((sorted-dom-kwd sorted-dom-kwd-arg sorted-dom-kwd-proj) ...)))] (map list
[(rev-optional-dom-arg ...) (reverse (syntax->list #'(optional-dom-arg ...)))] (syntax->list #'(mandatory-dom-kwd ...))
[(rev-optional-dom-proj ...) (reverse (syntax->list #'(optional-dom-proj ...)))]) (syntax->list #'((mandatory-dom-kwd-proj mandatory-dom-kwd-arg) ...))))]
[((sorted-dom-kwd sorted-dom-kwd-arg sorted-dom-kwd-proj) ...)
(sort-keywords stx (syntax->list
(let-values ([(rest-ctc pre rng-ctc post) #'((mandatory-dom-kwd mandatory-dom-kwd-arg mandatory-dom-kwd-proj) ...
;; rest-ctc (or/c #f syntax) -- #f means no rest contract, syntax is the contract (optional-dom-kwd optional-dom-kwd-arg optional-dom-kwd-proj) ...)))])
;; rng-ctc (or/c #f syntax) -- #f means `any', syntax is a sequence of result values (with-syntax ([((rev-sorted-dom-kwd rev-sorted-dom-kwd-arg rev-sorted-dom-kwd-proj) ...)
(parse-leftover->* stx #'rst)]) (reverse (syntax->list #'((sorted-dom-kwd sorted-dom-kwd-arg sorted-dom-kwd-proj) ...)))]
[(rev-optional-dom-arg ...) (reverse (syntax->list #'(optional-dom-arg ...)))]
[(rev-optional-dom-proj ...) (reverse (syntax->list #'(optional-dom-proj ...)))])
(with-syntax ([(rng-proj ...) (generate-temporaries (or rng-ctc '()))] (with-syntax ([(rng-proj ...) (generate-temporaries (or rng-ctc '()))]
[(rng ...) (generate-temporaries (or rng-ctc '()))] [(rng ...) (generate-temporaries (or rng-ctc '()))]
[(this-parameter ...) [(this-parameter ...)

26
collects/tests/racket/contract-test.rktl
View File

@ -778,6 +778,26 @@
(λ () 1) (λ () 1)
'pos 'pos
'neg))) 'neg)))
(test/spec-passed
'->*-opt-optional1
'((contract (->* () integer?) (lambda () 1) 'pos 'neg)))
(test/spec-passed
'->*-opt-optional2
'((contract (->* () (values boolean? integer?)) (lambda () (values #t 1)) 'pos 'neg)))
(test/spec-passed
'->*-opt-optional3
'((contract (->* () #:rest any/c integer?) (lambda x 1) 'pos 'neg)))
(test/spec-passed
'->*-opt-optional4
'((contract (->* () #:pre #t integer?) (lambda x 1) 'pos 'neg)))
(test/spec-passed
'->*-opt-optional5
'((contract (->* () integer? #:post #t) (lambda x 1) 'pos 'neg)))
; ;
; ;
@ -8647,11 +8667,11 @@ so that propagation occurs.
(test-name '(->* (integer? char? #:z string?) (boolean? #:i number?) #:rest (listof integer?) (values number? boolean? symbol?)) (test-name '(->* (integer? char? #:z string?) (boolean? #:i number?) #:rest (listof integer?) (values number? boolean? symbol?))
(->* (#:z string? integer? char?) (boolean? #:i number?) #:rest (listof integer?) (values number? boolean? symbol?))) (->* (#:z string? integer? char?) (boolean? #:i number?) #:rest (listof integer?) (values number? boolean? symbol?)))
(test-name '(->* (integer?) () #:pre ... integer?) (test-name '(->* (integer?) #:pre ... integer?)
(->* (integer?) () #:pre (= 1 2) integer?)) (->* (integer?) () #:pre (= 1 2) integer?))
(test-name '(->* (integer?) () integer? #:post ...) (test-name '(->* (integer?) integer? #:post ...)
(->* (integer?) () integer? #:post #f)) (->* (integer?) () integer? #:post #f))
(test-name '(->* (integer?) () #:pre ... integer? #:post ...) (test-name '(->* (integer?) #:pre ... integer? #:post ...)
(->* (integer?) () #:pre (= 1 2) integer? #:post #f)) (->* (integer?) () #:pre (= 1 2) integer? #:post #f))
(test-name '(->d () () any) (->d () () any)) (test-name '(->d () () any) (->d () () any))