Commit 674264c7 by Kim Nguyễn

### Fix a subtle bug in Positive.decompose (for some complex recursive types,

```Positive.solve(Positive.decompose t) was not the identity but added spurious types at toplevel.

Added more test cases in poly-ok.cd to cover such regressions```
parent 411a2ab0
 ... ... @@ -37,7 +37,8 @@ max 42;; let f (_ : ('a | 'b | 'c)) (_ : (Int&'d&'e \1--3 )) : Any = raise "123";; let x = id even (even mmap) even;; (* same type as map_even *) let e = (even mmap) ;; let x = id (even (e even));; (* same type as map_even *) let twisted = id even (even mmap) even (mmap max [1 2 3 4 5 6]);; ... ... @@ -62,4 +63,5 @@ let f ( x : B('a) ) : 'a = ;; let v = f [[32]] ;; \ No newline at end of file ;;
 ... ... @@ -2688,8 +2688,13 @@ module Positive = struct let ty d = cons (`Type d) let var d = cons (`Variable d) let neg v = cons (`Neg v) let cup = function [ v ] -> v | vl -> cons (`Cup vl) let cap vl = cons (`Cap vl) let cup vl = match vl with [ v ] -> v | _ -> cons (`Cup vl) let cap vl = match vl with [ v ] -> v | _ -> cons (`Cap vl) let times v1 v2 = cons (`Times (v1,v2)) let arrow v1 v2 = cons (`Arrow (v1,v2)) let xml v1 v2 = cons (`Xml (v1,v2)) ... ... @@ -2702,7 +2707,7 @@ module Positive = struct let decompose t = let memo = DescrHash.create 17 in let decompose_conj acc f_atom sign ilist acc = let decompose_conj f_atom sign ilist acc = List.fold_left (fun acc e -> let ne = f_atom e in (sign ne) :: acc ... ... @@ -2710,11 +2715,16 @@ module Positive = struct in let decompose_dnf t_any f_atom dnf acc = List.fold_left (fun acc (ipos, ineg) -> let lacc = decompose_conj [] f_atom neg ineg in let lacc = decompose_conj lacc f_atom (fun x -> x) ipos [t_any] in match lacc with | [v] -> v::acc | l -> (cap l) :: acc) acc dnf let lacc = match ipos,ineg with [],[] -> [t_any] | _ -> [] in let lacc = decompose_conj f_atom neg ineg lacc in let lacc = decompose_conj f_atom (fun x -> x) ipos lacc in match lacc with | [] -> t_any::acc | [v] -> v::acc | l -> (cap l) :: acc) acc dnf in let or_var f = function |`Var x -> var x ... ... @@ -2745,20 +2755,25 @@ module Positive = struct let node_t = forward () in if no_var t then ty t else let () = DescrHash.add memo t node_t in let descr_t = decompose_kind Atom.any atom (BoolAtoms.get t.atoms) @@ decompose_kind Int.any interval (BoolIntervals.get t.ints) @@ decompose_kind Char.any char (BoolChars.get t.chars) @@ decompose_bdd Product.any times (BoolPair.get t.times) @@ decompose_bdd Product.any_xml xml (BoolPair.get t.xml) @@ decompose_bdd Arrow.any arrow (BoolPair.get t.arrow) @@ decompose_rec Record.any record (BoolRec.get t.record) @@ decompose_kind Abstract.any abstract (BoolAbstracts.get t.abstract) [] in node_t.def <- (cup descr_t).def; node_t in decompose_type t match check_var t with `Pos v -> var v | `Neg v -> neg (var v) | `NotVar -> let () = DescrHash.add memo t node_t in let descr_t = decompose_kind Atom.any atom (BoolAtoms.get t.atoms) @@ decompose_kind Int.any interval (BoolIntervals.get t.ints) @@ decompose_kind Char.any char (BoolChars.get t.chars) @@ decompose_bdd Product.any times (BoolPair.get t.times) @@ decompose_bdd Product.any_xml xml (BoolPair.get t.xml) @@ decompose_bdd Arrow.any arrow (BoolPair.get t.arrow) @@ decompose_rec Record.any record (BoolRec.get t.record) @@ decompose_kind Abstract.any abstract (BoolAbstracts.get t.abstract) [] in node_t.def <- (cup descr_t).def; node_t in decompose_type t let solve v = internalize (make_node v) ... ...
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!