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

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

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

2
collects/typed-scheme/rep/type-rep.ss
View File

@ -272,7 +272,7 @@
;; pos-flds : (Listof Type)
;; name-flds : (Listof (Tuple Symbol Type Boolean))
;; methods : (Listof (Tuple Symbol Function))
(dt Class ([pos-flds (listof Type/c)]
(dt Class ([pos-flds (listof Type/c)]
[name-flds (listof (list/c symbol? Type/c boolean?))]
[methods (listof (list/c symbol? Function?))])
[#:frees (combine-frees