From 7e4ee76e4e7b8db3a30bfe6f3b19893ae83b1728 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 3 Jun 2010 17:31:09 -0400 Subject: [PATCH] Various small assorted fixes. original commit: d886331807f55e5a2a4ebb464b50d50835e20393 --- .../typed-scheme/infer/constraint-structs.rkt | 13 ++++++++---- collects/typed-scheme/infer/dmap.rkt | 2 +- collects/typed-scheme/infer/infer-unit.rkt | 21 ++++++++++++++----- collects/typed-scheme/typecheck/tc-app.rkt | 17 +++++++++------ 4 files changed, 37 insertions(+), 16 deletions(-) diff --git a/collects/typed-scheme/infer/constraint-structs.rkt b/collects/typed-scheme/infer/constraint-structs.rkt index 19cb2591..4ad2c0c2 100644 --- a/collects/typed-scheme/infer/constraint-structs.rkt +++ b/collects/typed-scheme/infer/constraint-structs.rkt @@ -9,6 +9,9 @@ ;; fixed : Listof[c] ;; rest : option[c] +;; a constraint on an index variable +;; the index variable must be instantiated with |fixed| arguments, each meeting the appropriate constraint +;; and further instantions of the index variable must respect the rest constraint, if it exists (d-s/c dcon ([fixed (listof c?)] [rest (or/c c? #f)]) #:transparent) ;; fixed : Listof[c] @@ -19,8 +22,10 @@ ;; bound : var (d-s/c dcon-dotted ([type c?] [bound symbol?]) #:transparent) -;; map : hash mapping variable to dcon or dcon-dotted -(d-s/c dmap ([map (hash/c symbol? (or/c dcon? dcon-exact? dcon-dotted?))]) #:transparent) +(define dcon/c (or/c dcon? dcon-exact? dcon-dotted?)) + +;; map : hash mapping index variables to dcons +(d-s/c dmap ([map (hash/c symbol? dcon/c)]) #:transparent) ;; maps is a list of pairs of ;; - functional maps from vars to c's @@ -28,7 +33,7 @@ ;; we need a bunch of mappings for each cset to handle case-lambda ;; because case-lambda can generate multiple possible solutions, and we ;; don't want to rule them out too early -(d-s/c cset ([maps (listof (cons/c (hash/c symbol? c?) dmap?))]) #:transparent) +(d-s/c cset ([maps (listof (cons/c (hash/c symbol? c? #:immutable #t) dmap?))]) #:transparent) (define-match-expander c: (lambda (stx) @@ -37,4 +42,4 @@ #'(struct c (s x t))]))) (provide (struct-out cset) (struct-out dmap) (struct-out dcon) (struct-out dcon-dotted) (struct-out dcon-exact) (struct-out c) - c:) + c: dcon/c) diff --git a/collects/typed-scheme/infer/dmap.rkt b/collects/typed-scheme/infer/dmap.rkt index 7f88f291..6f613748 100644 --- a/collects/typed-scheme/infer/dmap.rkt +++ b/collects/typed-scheme/infer/dmap.rkt @@ -10,7 +10,7 @@ ;; dcon-meet : dcon dcon -> dcon (d/c (dcon-meet dc1 dc2) - (dcon? dcon? . -> . dcon?) + (dcon/c dcon/c . -> . dcon/c) (match* (dc1 dc2) [((struct dcon-exact (fixed1 rest1)) (or (struct dcon (fixed2 rest2)) (struct dcon-exact (fixed2 rest2)))) diff --git a/collects/typed-scheme/infer/infer-unit.rkt b/collects/typed-scheme/infer/infer-unit.rkt index ae882641..f60a2806 100644 --- a/collects/typed-scheme/infer/infer-unit.rkt +++ b/collects/typed-scheme/infer/infer-unit.rkt @@ -66,7 +66,13 @@ dmap))) cset)) -(define (move-vars-to-dmap cset dbound vars) +;; dbound : index variable +;; vars : listof[type variable] - temporary variables +;; cset : the constraints being manipulated +;; takes the constraints on vars and creates a dmap entry contstraining dbound to be |vars| +;; with the constraints that cset places on vars +(d/c (move-vars-to-dmap cset dbound vars) + (cset? symbol? (listof symbol?) . -> . cset?) (mover cset dbound vars (λ (cmap) (make-dcon (for/list ([v vars]) @@ -74,7 +80,11 @@ (λ () (int-err "No constraint for new var ~a" v)))) #f)))) -(define (move-rest-to-dmap cset dbound #:exact [exact? #f]) +;; dbound : index variable +;; cset : the constraints being manipulated +;; +(d/c (move-rest-to-dmap cset dbound #:exact [exact? #f]) + ((cset? symbol?) (#:exact boolean?) . ->* . cset?) (mover cset dbound (list dbound) (λ (cmap) ((if exact? make-dcon-exact make-dcon) @@ -82,7 +92,8 @@ (hash-ref cmap dbound (λ () (int-err "No constraint for bound ~a" dbound))))))) -(define (move-vars+rest-to-dmap cset dbound vars #:exact [exact? #f]) +(d/c (move-vars+rest-to-dmap cset dbound vars #:exact [exact? #f]) + ((cset? symbol? (listof symbol?)) (#:exact boolean?) . ->* . cset?) (mover cset dbound vars (λ (cmap) ((if exact? make-dcon-exact make-dcon) @@ -91,7 +102,6 @@ (hash-ref cmap dbound (λ () (int-err "No constraint for bound ~a" dbound))))))) -;; s and t must be *latent* filters (define (cgen/filter V X s t) (match* (s t) [(e e) (empty-cset X)] @@ -194,6 +204,7 @@ [ret-mapping (cg s t)]) (cset-meet* (list arg-mapping darg-mapping ret-mapping)))] + ;; * <: ... [((arr: ss s s-rest #f '()) (arr: ts t #f (cons t-dty dbound) '())) (unless (memq dbound X) @@ -460,7 +471,7 @@ (match v [(struct c (S X T)) ;; fixme - handle free indexes, remove Dotted - (let ([var (hash-ref (free-vars* R) (or variable X) Constant)]) + (let ([var (hash-ref (free-vars* R) (or variable X) (λ () (hash-ref (free-idxs* R) (or variable X) Constant)))]) ;(printf "variance was: ~a~nR was ~a~nX was ~a~nS T ~a ~a~n" var R (or variable X) S T) (evcase var [Constant S] diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt index b8887930..151e7d46 100644 --- a/collects/typed-scheme/typecheck/tc-app.rkt +++ b/collects/typed-scheme/typecheck/tc-app.rkt @@ -813,7 +813,7 @@ #:return (or expected (ret (Un))) (string-append "No function domains matched in function application:\n" (domain-mismatches t doms rests drests rngs argtys-t #f #f))))] - ;; any kind of polymorphic function + ;; any kind of dotted polymorphic function without mandatory keyword args [((tc-result1: (and t (PolyDots: (and vars (list fixed-vars ... dotted-var)) (Function: (list (and arrs (arr: doms rngs rests drests (list (Keyword: _ _ #f) ...))) ...))))) @@ -828,11 +828,16 @@ ;; only try to infer the free vars of the rng (which includes the vars in filters/objects) ;; note that we have to use argtys-t here, since argtys is a list of tc-results (lambda (dom rng rest drest a) - (if drest - (infer/dots fixed-vars dotted-var argtys-t dom (car drest) rng (fv rng) - #:expected (and expected (tc-results->values expected))) - (infer/vararg fixed-vars (list dotted-var) argtys-t dom rest rng - (and expected (tc-results->values expected))))) + (cond + [drest + (infer/dots fixed-vars dotted-var argtys-t dom (car drest) rng (fv rng) + #:expected (and expected (tc-results->values expected)))] + [rest + (infer/vararg fixed-vars (list dotted-var) argtys-t dom rest rng + (and expected (tc-results->values expected)))] + ;; no rest or drest + [else (infer fixed-vars (list dotted-var) argtys-t dom rng + (and expected (tc-results->values expected)))])) t argtys expected)] ;; regular polymorphic functions without dotted rest, and without mandatory keyword args [((tc-result1: