Commit 674264c7 authored by Kim Nguyễn's avatar 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 <b>[<b>[<a>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!
Please register or to comment