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

conversion to contracts for optional keywords

Browse Source 
svn: r17236
This commit is contained in:
Sam Tobin-Hochstadt 2009-12-07 15:34:54 +00:00
parent 70f085713d
commit eae4c140fa
2 changed files with 17 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
collects/typed-scheme/private/type-contract.ss
View File

@ -70,25 +70,33 @@
[(Function: arrs) [(Function: arrs)
(let () (let ()
(define (f a) (define (f a)
(define-values (dom* rngs* rst) (define-values (dom* opt-dom* rngs* rst)
(match a (match a
[(arr: dom (Values: (list (Result: rngs (LFilterSet: '() '()) (LEmpty:)) ...)) rst #f (list (Keyword: kws ktys #t) ...)) [(arr: dom (Values: (list (Result: rngs (LFilterSet: '() '()) (LEmpty:)) ...)) rst #f kws)
(values (append (map t->c/neg dom) (append-map (lambda (kw kty) (list kw (t->c/neg kty))) kws ktys)) (let-values ([(mand-kws opt-kws) (partition (match-lambda [(Keyword: _ _ mand?) mand?]) kws)]
(map t->c rngs) (and rst (t->c/neg rst)))] [(conv) (match-lambda [(Keyword: kw kty _) (list kw (t->c/neg kty))])])
(values (append (map t->c/neg dom) (append-map conv mand-kws))
(append-map conv opt-kws)
(map t->c rngs)
(and rst (t->c/neg rst))))]
[(arr: dom (Values: (list (Result: rngs _ _) ...)) rst #f '()) [(arr: dom (Values: (list (Result: rngs _ _) ...)) rst #f '())
(if (and out? pos?) (if (and out? pos?)
(values (map t->c/neg dom) (map t->c rngs) (and rst (t->c/neg rst))) (values (map t->c/neg dom)
null
(map t->c rngs)
(and rst (t->c/neg rst)))
(exit (fail)))] (exit (fail)))]
[_ (exit (fail))])) [_ (exit (fail))]))
(trace f) (trace f)
(with-syntax (with-syntax
([(dom* ...) dom*] ([(dom* ...) dom*]
[(opt-dom* ...) opt-dom*]
[rng* (match rngs* [rng* (match rngs*
[(list r) r] [(list r) r]
[_ #`(values #,@rngs*)])] [_ #`(values #,@rngs*)])]
[rst* rst]) [rst* rst])
(if rst (if (or rst (pair? (syntax-e #'(opt-dom* ...))))
#'((dom* ...) () #:rest (listof rst*) . ->* . rng*) #'((dom* ...) (opt-dom* ...) #:rest (listof rst*) . ->* . rng*)
#'(dom* ... . -> . rng*)))) #'(dom* ... . -> . rng*))))
(unless (no-duplicates (for/list ([t arrs]) (unless (no-duplicates (for/list ([t arrs])
(match t [(arr: dom _ _ _ _) (length dom)]))) (match t [(arr: dom _ _ _ _) (length dom)])))