diff --git a/collects/typed-scheme/private/infer-unit.ss b/collects/typed-scheme/private/infer-unit.ss index 27ec65707c..d04d5b36a1 100644 --- a/collects/typed-scheme/private/infer-unit.ss +++ b/collects/typed-scheme/private/infer-unit.ss @@ -111,15 +111,15 @@ (define (cgen/arr V X t-arr s-arr) (define (cg S T) (cgen V X S T)) (match* (t-arr s-arr) - [((arr: ts t #f #f t-thn-eff t-els-eff) - (arr: ss s #f #f s-thn-eff s-els-eff)) + [((arr: ts t #f #f '() t-thn-eff t-els-eff) + (arr: ss s #f #f '() s-thn-eff s-els-eff)) (cset-meet* (list (cgen/list V X ss ts) (cg t s) (cgen/eff/list V X t-thn-eff s-thn-eff) (cgen/eff/list V X t-els-eff s-els-eff)))] - [((arr: ts t t-rest #f t-thn-eff t-els-eff) - (arr: ss s s-rest #f s-thn-eff s-els-eff)) + [((arr: ts t t-rest #f '() t-thn-eff t-els-eff) + (arr: ss s s-rest #f '() s-thn-eff s-els-eff)) (let ([arg-mapping (cond [(and t-rest s-rest (<= (length ts) (length ss))) (cgen/list V X (cons s-rest ss) (cons t-rest (extend ss ts t-rest)))] @@ -135,8 +135,8 @@ (list arg-mapping ret-mapping (cgen/eff/list V X t-thn-eff s-thn-eff) (cgen/eff/list V X t-els-eff s-els-eff))))] - [((arr: ts t #f (cons dty dbound) t-thn-eff t-els-eff) - (arr: ss s #f #f s-thn-eff s-els-eff)) + [((arr: ts t #f (cons dty dbound) '() t-thn-eff t-els-eff) + (arr: ss s #f #f '() s-thn-eff s-els-eff)) (unless (memq dbound X) (fail! S T)) (unless (<= (length ts) (length ss)) @@ -148,8 +148,8 @@ (substitute (make-F var) dbound dty))] [new-cset (cgen/arr V (append vars X) (make-arr (append ts new-tys) t #f #f t-thn-eff t-els-eff) s-arr)]) (move-vars-to-dmap new-cset dbound vars))] - [((arr: ts t #f #f t-thn-eff t-els-eff) - (arr: ss s #f (cons dty dbound) s-thn-eff s-els-eff)) + [((arr: ts t #f #f '() t-thn-eff t-els-eff) + (arr: ss s #f (cons dty dbound) '() s-thn-eff s-els-eff)) (unless (memq dbound X) (fail! S T)) (unless (<= (length ss) (length ts)) @@ -161,8 +161,8 @@ (substitute (make-F var) dbound dty))] [new-cset (cgen/arr V (append vars X) t-arr (make-arr (append ss new-tys) s #f #f s-thn-eff s-els-eff))]) (move-vars-to-dmap new-cset dbound vars))] - [((arr: ts t #f (cons t-dty dbound) t-thn-eff t-els-eff) - (arr: ss s #f (cons s-dty dbound) s-thn-eff s-els-eff)) + [((arr: ts t #f (cons t-dty dbound) '() t-thn-eff t-els-eff) + (arr: ss s #f (cons s-dty dbound) '() s-thn-eff s-els-eff)) (unless (= (length ts) (length ss)) (fail! S T)) ;; If we want to infer the dotted bound, then why is it in both types? @@ -175,8 +175,8 @@ (list arg-mapping darg-mapping ret-mapping (cgen/eff/list V X t-thn-eff s-thn-eff) (cgen/eff/list V X t-els-eff s-els-eff))))] - [((arr: ts t #f (cons t-dty dbound) t-thn-eff t-els-eff) - (arr: ss s #f (cons s-dty dbound*) s-thn-eff s-els-eff)) + [((arr: ts t #f (cons t-dty dbound) '() t-thn-eff t-els-eff) + (arr: ss s #f (cons s-dty dbound*) '() s-thn-eff s-els-eff)) (unless (= (length ts) (length ss)) (fail! S T)) (let* ([arg-mapping (cgen/list V X ss ts)] @@ -186,8 +186,8 @@ (list arg-mapping darg-mapping ret-mapping (cgen/eff/list V X t-thn-eff s-thn-eff) (cgen/eff/list V X t-els-eff s-els-eff))))] - [((arr: ts t t-rest #f t-thn-eff t-els-eff) - (arr: ss s #f (cons s-dty dbound) s-thn-eff s-els-eff)) + [((arr: ts t t-rest #f '() t-thn-eff t-els-eff) + (arr: ss s #f (cons s-dty dbound) '() s-thn-eff s-els-eff)) (unless (memq dbound X) (fail! S T)) (if (<= (length ts) (length ss)) @@ -208,8 +208,8 @@ (make-arr (append ss new-tys) s #f (cons s-dty dbound) s-thn-eff s-els-eff))]) (move-vars+rest-to-dmap new-cset dbound vars)))] ;; If dotted <: starred is correct, add it below. Not sure it is. - [((arr: ts t #f (cons t-dty dbound) t-thn-eff t-els-eff) - (arr: ss s s-rest #f s-thn-eff s-els-eff)) + [((arr: ts t #f (cons t-dty dbound) '() t-thn-eff t-els-eff) + (arr: ss s s-rest #f '() s-thn-eff s-els-eff)) (unless (memq dbound X) (fail! S T)) (cond [(< (length ts) (length ss)) diff --git a/collects/typed-scheme/private/promote-demote.ss b/collects/typed-scheme/private/promote-demote.ss index bbb1d7b229..d24eda82d3 100644 --- a/collects/typed-scheme/private/promote-demote.ss +++ b/collects/typed-scheme/private/promote-demote.ss @@ -2,7 +2,7 @@ (require "type-effect-convenience.ss" "type-rep.ss" "type-utils.ss" "union.ss" - "signatures.ss" + "signatures.ss" "utils.ss" scheme/list) (import) @@ -26,7 +26,7 @@ [#:Param in out (make-Param (var-demote in V) (vp out))] - [#:arr dom rng rest drest thn els + [#:arr dom rng rest drest kws thn els (cond [(apply V-in? V (append thn els)) (make-arr null (Un) Univ #f null null)] @@ -35,6 +35,8 @@ (vp rng) (var-demote (car drest) V) #f + (for/list ([(kw kwt) (in-pairs kws)]) + (cons kw (var-demote kwt V))) thn els)] [else @@ -44,6 +46,8 @@ (and drest (cons (var-demote (car drest) V) (cdr drest))) + (for/list ([(kw kwt) (in-pairs kws)]) + (cons kw (var-demote kwt V))) thn els)])])) @@ -61,7 +65,7 @@ [#:Param in out (make-Param (var-promote in V) (vd out))] - [#:arr dom rng rest drest thn els + [#:arr dom rng rest drest kws thn els (cond [(apply V-in? V (append thn els)) (make-arr null (Un) Univ #f null null)] @@ -70,6 +74,8 @@ (vd rng) (var-promote (car drest) V) #f + (for/list ([(kw kwt) (in-pairs kws)]) + (cons kw (var-promote kwt V))) thn els)] [else @@ -79,5 +85,7 @@ (and drest (cons (var-promote (car drest) V) (cdr drest))) + (for/list ([(kw kwt) (in-pairs kws)]) + (cons kw (var-promote kwt V))) thn els)])])) diff --git a/collects/typed-scheme/private/rep-utils.ss b/collects/typed-scheme/private/rep-utils.ss index e3cf76e2d1..cd1d21b506 100644 --- a/collects/typed-scheme/private/rep-utils.ss +++ b/collects/typed-scheme/private/rep-utils.ss @@ -150,7 +150,9 @@ (lambda (s) (... (syntax-case s () - [(__ . fs) (quasisyntax/loc s (struct nm #, (syntax/loc #'fs (_ . fs))))])))) + [(__ . fs) + (with-syntax ([flds** (syntax/loc s (_ . fs))]) + (quasisyntax/loc s (struct nm flds**)))])))) (begin-for-syntax (hash-set! ht-stx 'kw-stx (list #'ex #'flds bfs-fold-rhs #'#,stx))) intern diff --git a/collects/typed-scheme/private/subtype.ss b/collects/typed-scheme/private/subtype.ss index 398fe7b226..3667f421a4 100644 --- a/collects/typed-scheme/private/subtype.ss +++ b/collects/typed-scheme/private/subtype.ss @@ -100,10 +100,13 @@ (match (list s t) ;; top for functions is above everything [(list _ (top-arr:)) A0] - [(list (arr: s1 s2 #f #f thn-eff els-eff) (arr: t1 t2 #f #f thn-eff els-eff)) - (let ([A1 (subtypes* A0 t1 s1)]) + [(list (arr: s1 s2 #f #f (list (cons kw s-kw-ty) ...) thn-eff els-eff) + (arr: t1 t2 #f #f (list (cons kw t-kw-ty) ...) thn-eff els-eff)) + (let* ([A1 (subtypes* A0 t1 s1)] + [A2 (subtypes* A1 t-kw-ty s-kw-ty)]) (subtype* A1 s2 t2))] - [(list (arr: s1 s2 s3 #f thn-eff els-eff) (arr: t1 t2 t3 #f thn-eff* els-eff*)) + [(list (arr: s1 s2 s3 #f (list (cons kw s-kw-ty) ...) thn-eff els-eff) + (arr: t1 t2 t3 #f (list (cons kw t-kw-ty) ...) thn-eff* els-eff*)) (unless (or (and (null? thn-eff*) (null? els-eff*)) (and (effects-equal? thn-eff thn-eff*) @@ -115,10 +118,11 @@ (andmap sub-eff els-eff els-eff*))) (fail! s t)) ;; either the effects have to be the same, or the supertype can't have effects - (let ([A (subtypes*/varargs A0 t1 s1 s3)]) + (let* ([A2 (subtypes*/varargs A0 t1 s1 s3)] + [A3 (subtypes* A2 t-kw-ty s-kw-ty)]) (if (not t3) - (subtype* A s2 t2) - (let ([A1 (subtype* A t3 s3)]) + (subtype* A3 s2 t2) + (let ([A1 (subtype* A3 t3 s3)]) (subtype* A1 s2 t2))))] [else (fail! s t)]))) diff --git a/collects/typed-scheme/private/tc-lambda-unit.ss b/collects/typed-scheme/private/tc-lambda-unit.ss index d91531536e..455d6acde8 100644 --- a/collects/typed-scheme/private/tc-lambda-unit.ss +++ b/collects/typed-scheme/private/tc-lambda-unit.ss @@ -180,7 +180,7 @@ (let loop ([expected expected]) (match expected [(Mu: _ _) (loop (unfold expected))] - [(Function: (list (arr: argss rets rests drests _ _) ...)) + [(Function: (list (arr: argss rets rests drests '() _ _) ...)) (for ([args argss] [ret rets] [rest rests] [drest drests]) (tc/lambda-clause/check (car (syntax->list formals)) (car (syntax->list bodies)) args ret rest drest)) expected] diff --git a/collects/typed-scheme/private/type-contract.ss b/collects/typed-scheme/private/type-contract.ss index f973666a48..acc0effe98 100644 --- a/collects/typed-scheme/private/type-contract.ss +++ b/collects/typed-scheme/private/type-contract.ss @@ -80,13 +80,13 @@ (define (f a) (define-values (dom* rngs* rst) (match a - [(arr: dom (Values: rngs) #f #f _ _) + [(arr: dom (Values: rngs) #f #f '() _ _) (values (map t->c dom) (map t->c rngs) #f)] - [(arr: dom rng #f #f _ _) + [(arr: dom rng #f #f '() _ _) (values (map t->c dom) (list (t->c rng)) #f)] - [(arr: dom (Values: rngs) rst #f _ _) + [(arr: dom (Values: rngs) rst #f '() _ _) (values (map t->c dom) (map t->c rngs) (t->c rst))] - [(arr: dom rng rst #f _ _) + [(arr: dom rng rst #f '() _ _) (values (map t->c dom) (list (t->c rng)) (t->c rst))])) (with-syntax ([(dom* ...) dom*] diff --git a/collects/typed-scheme/private/type-effect-convenience.ss b/collects/typed-scheme/private/type-effect-convenience.ss index 9ae26d5479..dbbf0ec393 100644 --- a/collects/typed-scheme/private/type-effect-convenience.ss +++ b/collects/typed-scheme/private/type-effect-convenience.ss @@ -80,9 +80,9 @@ (define make-arr* (case-lambda [(dom rng) (make-arr* dom rng #f (list) (list))] - [(dom rng rest) (make-arr dom rng rest #f (list) (list))] - [(dom rng rest eff1 eff2) (make-arr dom rng rest #f eff1 eff2)] - [(dom rng rest drest eff1 eff2) (make-arr dom rng rest drest eff1 eff2)])) + [(dom rng rest) (make-arr dom rng rest #f null (list) (list))] + [(dom rng rest eff1 eff2) (make-arr dom rng rest #f null eff1 eff2)] + [(dom rng rest drest eff1 eff2) (make-arr dom rng rest drest null eff1 eff2)])) (define (make-arr-dots dom rng dty dbound) (make-arr* dom rng #f (cons dty dbound) null null)) diff --git a/collects/typed-scheme/private/type-effect-printer.ss b/collects/typed-scheme/private/type-effect-printer.ss index d5c7957f7b..513f61bd04 100644 --- a/collects/typed-scheme/private/type-effect-printer.ss +++ b/collects/typed-scheme/private/type-effect-printer.ss @@ -46,9 +46,11 @@ (match a [(top-arr:) (fp "Procedure")] - [(arr: dom rng rest drest thn-eff els-eff) + [(arr: dom rng rest drest kws thn-eff els-eff) (fp "(") (for-each (lambda (t) (fp "~a " t)) dom) + (for ([kw kws]) + (fp "~a ~a " (car kw) (cdr kw))) (when rest (fp "~a* " rest)) (when drest @@ -102,7 +104,7 @@ (lambda (e) (fp " ") (print-arr e)) b) (fp ")")]))] - [(arr: _ _ _ _ _ _) (print-arr c)] + [(arr: _ _ _ _ _ _ _) (print-arr c)] [(Vector: e) (fp "(Vectorof ~a)" e)] [(Box: e) (fp "(Box ~a)" e)] [(Union: elems) (fp "~a" (cons 'U elems))] diff --git a/collects/typed-scheme/private/type-rep.ss b/collects/typed-scheme/private/type-rep.ss index 270ce36a76..df51d4c8b3 100644 --- a/collects/typed-scheme/private/type-rep.ss +++ b/collects/typed-scheme/private/type-rep.ss @@ -94,12 +94,15 @@ ;; rng : Type ;; rest : Option[Type] ;; drest : Option[Cons[Type,Name or nat]] +;; kws : Listof[Cons[Kw, Type]] ;; rest and drest NOT both true ;; thn-eff : Effect ;; els-eff : Effect ;; arr is NOT a Type -(dt arr (dom rng rest drest thn-eff els-eff) - [#:frees (combine-frees (append (map flip-variances (map free-vars* (append (if rest (list rest) null) dom))) +(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) + (map cdr kws) + dom))) (match drest [(cons t (? symbol? bnd)) (list (fix-bound (flip-variances (free-vars* t)) bnd))] @@ -108,7 +111,9 @@ (list (free-vars* rng)) (map make-invariant (map free-vars* (append thn-eff els-eff))))) - (combine-frees (append (map flip-variances (map free-idxs* (append (if rest (list rest) null) dom))) + (combine-frees (append (map flip-variances (map free-idxs* (append (if rest (list rest) null) + (map cdr kws) + dom))) (match drest [(cons t (? number? bnd)) (list (fix-bound (flip-variances (free-idxs* t)) bnd))] @@ -121,6 +126,8 @@ (type-rec-id rng) (and rest (type-rec-id rest)) (and drest (cons (type-rec-id (car drest)) (cdr drest))) + (for/list ([kw kws]) + (cons (car kw) (type-rec-id (cdr kw)))) (map effect-rec-id thn-eff) (map effect-rec-id els-eff))]) @@ -248,9 +255,11 @@ (define cl (quasisyntax/loc src (#,pat #,(body-f rid erid)))) cl) (syntax-case stx () - [(tc rec-id ty [kw pats ... es] ...) - #;(andmap (lambda (k) (keyword? (syntax-e k))) (syntax->list #'(kw ...))) - (syntax/loc stx (tc rec-id (lambda (e) (sub-eff rec-id e)) ty [kw pats ... es] ...))] + [(tc rec-id ty clauses ...) + (syntax-case #'(clauses ...) () + [([kw pats ... es] ...) #t] + [_ #f]) + (syntax/loc stx (tc rec-id (lambda (e) (sub-eff rec-id e)) ty clauses ...))] [(tc rec-id e-rec-id ty clauses ...) (begin (map add-clause (syntax->list #'(clauses ...))) @@ -296,7 +305,7 @@ ;; necessary to avoid infinite loops [#:Union elems (*Union (remove-dups (sort (map sb elems) type