From 3f7ca52e370dfa0b81b5c9955c785bd429cda3d8 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 18 Jun 2010 15:22:59 -0400 Subject: [PATCH] Add fixed part to dcon-dotted. --- .../typed-scheme/infer/constraint-structs.rkt | 3 ++- collects/typed-scheme/infer/dmap.rkt | 9 ++++++--- collects/typed-scheme/infer/infer-unit.rkt | 17 ----------------- 3 files changed, 8 insertions(+), 21 deletions(-) diff --git a/collects/typed-scheme/infer/constraint-structs.rkt b/collects/typed-scheme/infer/constraint-structs.rkt index 4ad2c0c299..82e65033e9 100644 --- a/collects/typed-scheme/infer/constraint-structs.rkt +++ b/collects/typed-scheme/infer/constraint-structs.rkt @@ -18,9 +18,10 @@ ;; rest : c (d-s/c dcon-exact ([fixed (listof c?)] [rest c?]) #:transparent) +;; fixed : Listof[c] ;; type : c ;; bound : var -(d-s/c dcon-dotted ([type c?] [bound symbol?]) #:transparent) +(d-s/c dcon-dotted ([fixed (listof c?)] [type c?] [bound symbol?]) #:transparent) (define dcon/c (or/c dcon? dcon-exact? dcon-dotted?)) diff --git a/collects/typed-scheme/infer/dmap.rkt b/collects/typed-scheme/infer/dmap.rkt index 6f61374819..c76702bf50 100644 --- a/collects/typed-scheme/infer/dmap.rkt +++ b/collects/typed-scheme/infer/dmap.rkt @@ -52,10 +52,13 @@ [c2 (in-sequence-forever shorter srest)]) (c-meet c1 c2 (c-X c1))) (c-meet lrest srest (c-X lrest))))] - [((struct dcon-dotted (c1 bound1)) (struct dcon-dotted (c2 bound2))) - (unless (eq? bound1 bound2) + [((struct dcon-dotted (fixed1 c1 bound1)) (struct dcon-dotted (fixed2 c2 bound2))) + (unless (and (= (length fixed1) (length fixed2)) + (eq? bound1 bound2)) (fail! bound1 bound2)) - (make-dcon-dotted (c-meet c1 c2 bound1) bound1)] + (make-dcon-dotted (for/list ([c1 fixed1] [c2 fixed2]) + (c-meet c1 c2 (c-X c1))) + (c-meet c1 c2 bound1) bound1)] [((struct dcon _) (struct dcon-dotted _)) (fail! dc1 dc2)] [((struct dcon-dotted _) (struct dcon _)) diff --git a/collects/typed-scheme/infer/infer-unit.rkt b/collects/typed-scheme/infer/infer-unit.rkt index fe0d22f21f..fbb408e666 100644 --- a/collects/typed-scheme/infer/infer-unit.rkt +++ b/collects/typed-scheme/infer/infer-unit.rkt @@ -29,23 +29,6 @@ (define (seen? s t) (member (seen-before s t) (current-seen))) -(define (dmap-constraint dmap dbound v) - (let ([dc (hash-ref dmap dbound #f)]) - (match dc - [(struct dcon (fixed #f)) - (if (eq? dbound v) - (no-constraint v) - (hash-ref fixed v (no-constraint v)))] - [(struct dcon (fixed rest)) - (if (eq? dbound v) - rest - (hash-ref fixed v (no-constraint v)))] - [(struct dcon-dotted (type bound)) - (if (eq? bound v) - type - (no-constraint v))] - [_ (no-constraint v)]))) - (define (map/cset f cset) (make-cset (for/list ([(cmap dmap) (in-pairs (cset-maps cset))]) (f cmap dmap))))