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

New representation that accomodates mandatory and optional keyword args.

Browse Source
This commit is contained in:
Sam Tobin-Hochstadt 2008-09-04 17:02:33 -04:00
parent b27c3571d0
commit 79e3a0c4c6
3 changed files with 17 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/typed-scheme/private/base-env.ss
View File

@ -556,7 +556,7 @@
[values* (-polydots (a) (null (a a) . ->... . (make-ValuesDots null a 'a)))] [values* (-polydots (a) (null (a a) . ->... . (make-ValuesDots null a 'a)))]
[call-with-values* (-polydots (b a) ((-> (make-ValuesDots null a 'a)) (null (a a) . ->... . b) . -> . b))] [call-with-values* (-polydots (b a) ((-> (make-ValuesDots null a 'a)) (null (a a) . ->... . b) . -> . b))]
[foo (make-Function (list (make-arr (list N) B #f #f (list (cons '#:bar B)) null null)))] [foo (make-Function (list (make-arr (list N) B #f #f (list (make-Keyword '#:bar B #f)) null null)))]
) )
(begin-for-syntax (begin-for-syntax

7
collects/typed-scheme/private/tc-app-unit.ss
View File

@ -569,12 +569,13 @@
(define (tc-keywords form arities kws kw-args pos-args expected) (define (tc-keywords form arities kws kw-args pos-args expected)
(match arities (match arities
[(list (arr: dom rng rest #f (list (and ktys (cons formal-kws formal-kw-tys)) ...) _ _)) [(list (arr: dom rng rest #f (list (and ktys (Keyword: formal-kws formal-kw-tys (and #f required?))) ...) _ _))
(for ([k kws] (for ([k kws]
[ty (map tc-expr/t (syntax->list kw-args))]) [ty (map tc-expr/t (syntax->list kw-args))])
(cond [(assq k ktys) (cond [(for/or ([e ktys])
(and (eq? (Keyword-kw e) k) e))
=> =>
(match-lambda [(cons k kty) (match-lambda [(Keyword: k kty req?)
(unless (subtype ty kty) (unless (subtype ty kty)
(tc-error/delayed (tc-error/delayed
#:stx form #:stx form

16
collects/typed-scheme/private/type-rep.ss
View File

@ -90,18 +90,26 @@
pred-id pred-id
cert)]) cert)])
;; kw : keyword?
;; ty : Type
;; required? : Boolean
(dt Keyword (kw ty required?)
[#:frees (free-vars* ty)
(free-idxs* ty)]
[#:fold-rhs (*Keyword kw (type-rec-id ty))])
;; dom : Listof[Type] ;; dom : Listof[Type]
;; rng : Type ;; rng : Type
;; rest : Option[Type] ;; rest : Option[Type]
;; drest : Option[Cons[Type,Name or nat]] ;; drest : Option[Cons[Type,Name or nat]]
;; kws : Listof[Cons[Kw, Type]] ;; kws : Listof[Keyword]
;; rest and drest NOT both true ;; rest and drest NOT both true
;; thn-eff : Effect ;; thn-eff : Effect
;; els-eff : Effect ;; els-eff : Effect
;; arr is NOT a Type ;; arr is NOT a Type
(dt arr (dom rng rest drest kws thn-eff els-eff) (dt arr (dom rng rest drest kws thn-eff els-eff)
[#:frees (combine-frees (append (map flip-variances (map free-vars* (append (if rest (list rest) null) [#:frees (combine-frees (append (map flip-variances (map free-vars* (append (if rest (list rest) null)
(map cdr kws) (map Keyword-ty kws)
dom))) dom)))
(match drest (match drest
[(cons t (? symbol? bnd)) [(cons t (? symbol? bnd))
@ -112,7 +120,7 @@
(map make-invariant (map make-invariant
(map free-vars* (append thn-eff els-eff))))) (map free-vars* (append thn-eff els-eff)))))
(combine-frees (append (map flip-variances (map free-idxs* (append (if rest (list rest) null) (combine-frees (append (map flip-variances (map free-idxs* (append (if rest (list rest) null)
(map cdr kws) (map Keyword-ty kws)
dom))) dom)))
(match drest (match drest
[(cons t (? number? bnd)) [(cons t (? number? bnd))
@ -127,7 +135,7 @@
(and rest (type-rec-id rest)) (and rest (type-rec-id rest))
(and drest (cons (type-rec-id (car drest)) (cdr drest))) (and drest (cons (type-rec-id (car drest)) (cdr drest)))
(for/list ([kw kws]) (for/list ([kw kws])
(cons (car kw) (type-rec-id (cdr kw)))) (cons (Keyword-kw kw) (type-rec-id (Keyword-ty kw)) (Keyword-require? kw)))
(map effect-rec-id thn-eff) (map effect-rec-id thn-eff)
(map effect-rec-id els-eff))]) (map effect-rec-id els-eff))])