Commit 496c41bd authored by Kim Nguyễn's avatar Kim Nguyễn

Revert "Implement a cache for the positive equation solver (partial results are stored in nodes)"

This reverts commit a8ba6ab6.

This commit introduces a regression where suprious type variables are introduced in the final type.
parent a8ba6ab6
...@@ -41,7 +41,7 @@ let balance ( Unbalanced('a) -> Rtree('a) ; 'b & RBtree('a) -> 'b & RBtree('a) ) ...@@ -41,7 +41,7 @@ let balance ( Unbalanced('a) -> Rtree('a) ; 'b & RBtree('a) -> 'b & RBtree('a) )
| x -> x | x -> x
;; ;;
let [] = []
(* *) (* *)
(* Version 2: restrict the first branch to Unbalanced trees whatever *) (* Version 2: restrict the first branch to Unbalanced trees whatever *)
(* type it contains *) (* type it contains *)
...@@ -182,8 +182,8 @@ let cardinal ( RBtree('a) -> Int ) (* better type: [] -> 0, Any\[] -> [1--*] * ...@@ -182,8 +182,8 @@ let cardinal ( RBtree('a) -> Int ) (* better type: [] -> 0, Any\[] -> [1--*] *
raise "impossible" raise "impossible"
| <(c) elem=e>[ l r ] -> | <(c) elem=e>[ l r ] ->
(<black elem=e>[ l (balance (redify r)) ], (c = `black)) (<black elem=e>[ l (balance (redify r)) ], (c = `black))
(*
let remove(x : 'a)(t : RBtree('a) ) : RBtree('a) = let remove(x : 'a)(t : RBtree('a) ) : RBtree('a) =
let remove_aux(RBtree('a) -> (RBtree('a),Bool) ) let remove_aux(RBtree('a) -> (RBtree('a),Bool) )
| [] -> | [] ->
...@@ -206,5 +206,4 @@ let remove(x : 'a)(t : RBtree('a) ) : RBtree('a) = ...@@ -206,5 +206,4 @@ let remove(x : 'a)(t : RBtree('a) ) : RBtree('a) =
let tree = <(c) elem=z>[ ll r] in let tree = <(c) elem=z>[ ll r] in
if d then bubble_left tree else (tree, `false) if d then bubble_left tree else (tree, `false)
in in
let (sol,_) = remove_aux t in sol let (sol,_) = remove_aux t in sol
*) \ No newline at end of file
...@@ -64,7 +64,6 @@ sig ...@@ -64,7 +64,6 @@ sig
val mapi: (Elem.t -> 'a -> 'b) -> 'a map -> 'b map val mapi: (Elem.t -> 'a -> 'b) -> 'a map -> 'b map
val constant: 'a -> t -> 'a map val constant: 'a -> t -> 'a map
val num: int -> t -> int map val num: int -> t -> int map
val init : (Elem.t -> 'a) -> t -> 'a map
val map_to_list: ('a -> 'b) -> 'a map -> 'b list val map_to_list: ('a -> 'b) -> 'a map -> 'b list
val mapi_to_list: (Elem.t -> 'a -> 'b) -> 'a map -> 'b list val mapi_to_list: (Elem.t -> 'a -> 'b) -> 'a map -> 'b list
val assoc: Elem.t -> 'a map -> 'a val assoc: Elem.t -> 'a map -> 'a
...@@ -98,9 +97,9 @@ module Make(X : Custom.T) = struct ...@@ -98,9 +97,9 @@ module Make(X : Custom.T) = struct
let hash l = hash 1 l let hash l = hash 1 l
let rec compare l1 l2 = let rec compare l1 l2 =
if l1 == l2 then 0 if l1 == l2 then 0
else match (l1,l2) with else match (l1,l2) with
| x1::l1, x2::l2 -> | x1::l1, x2::l2 ->
let c = Elem.compare x1 x2 in if c <> 0 then c let c = Elem.compare x1 x2 in if c <> 0 then c
else compare l1 l2 else compare l1 l2
| [],_ -> -1 | [],_ -> -1
...@@ -116,7 +115,7 @@ module Make(X : Custom.T) = struct ...@@ -116,7 +115,7 @@ module Make(X : Custom.T) = struct
external get: t -> Elem.t list = "%identity" external get: t -> Elem.t list = "%identity"
let singleton x = [ x ] let singleton x = [ x ]
let pick = function x::_ -> Some x | _ -> None let pick = function x::_ -> Some x | _ -> None
let choose = function x::_ -> x | _ -> raise Not_found let choose = function x::_ -> x | _ -> raise Not_found
let length = List.length let length = List.length
...@@ -126,13 +125,13 @@ module Make(X : Custom.T) = struct ...@@ -126,13 +125,13 @@ module Make(X : Custom.T) = struct
let rec disjoint l1 l2 = let rec disjoint l1 l2 =
if l1 == l2 then l1 == [] else if l1 == l2 then l1 == [] else
match (l1,l2) with match (l1,l2) with
| (t1::q1, t2::q2) -> | (t1::q1, t2::q2) ->
let c = Elem.compare t1 t2 in let c = Elem.compare t1 t2 in
if c < 0 then disjoint q1 l2 if c < 0 then disjoint q1 l2
else if c > 0 then disjoint l1 q2 else if c > 0 then disjoint l1 q2
else false else false
| _ -> true | _ -> true
let rec cup l1 l2 = let rec cup l1 l2 =
if l1 == l2 then l1 else if l1 == l2 then l1 else
match (l1,l2) with match (l1,l2) with
...@@ -145,7 +144,7 @@ module Make(X : Custom.T) = struct ...@@ -145,7 +144,7 @@ module Make(X : Custom.T) = struct
| (l1,[]) -> l1 | (l1,[]) -> l1
let add x l = cup [x] l let add x l = cup [x] l
let rec split l1 l2 = let rec split l1 l2 =
match (l1,l2) with match (l1,l2) with
| (t1::q1, t2::q2) -> | (t1::q1, t2::q2) ->
...@@ -154,8 +153,8 @@ module Make(X : Custom.T) = struct ...@@ -154,8 +153,8 @@ module Make(X : Custom.T) = struct
else if c < 0 then let (l1,i,l2) = split q1 l2 in (t1::l1,i,l2) else if c < 0 then let (l1,i,l2) = split q1 l2 in (t1::l1,i,l2)
else let (l1,i,l2) = split l1 q2 in (l1,i,t2::l2) else let (l1,i,l2) = split l1 q2 in (l1,i,t2::l2)
| _ -> (l1,[],l2) | _ -> (l1,[],l2)
let rec diff l1 l2 = let rec diff l1 l2 =
if l1 == l2 then [] else if l1 == l2 then [] else
match (l1,l2) with match (l1,l2) with
...@@ -178,7 +177,7 @@ module Make(X : Custom.T) = struct ...@@ -178,7 +177,7 @@ module Make(X : Custom.T) = struct
else cap l1 q2 else cap l1 q2
| _ -> [] | _ -> []
let rec subset l1 l2 = let rec subset l1 l2 =
(l1 == l2) || (l1 == l2) ||
match (l1,l2) with match (l1,l2) with
...@@ -197,8 +196,8 @@ module Make(X : Custom.T) = struct ...@@ -197,8 +196,8 @@ module Make(X : Custom.T) = struct
else if c < 0 then false else if c < 0 then false
else subset l1 q2 else subset l1 q2
| [],_ -> true | _ -> false | [],_ -> true | _ -> false
let from_list l = let from_list l =
let rec initlist = function let rec initlist = function
| [] -> [] | [] -> []
| e::rest -> [e] :: initlist rest in | e::rest -> [e] :: initlist rest in
...@@ -210,14 +209,14 @@ module Make(X : Custom.T) = struct ...@@ -210,14 +209,14 @@ module Make(X : Custom.T) = struct
| [l] -> l | [l] -> l
| llist -> mergeall (merge2 llist) in | llist -> mergeall (merge2 llist) in
mergeall (initlist l) mergeall (initlist l)
let map f l = let map f l =
from_list (List.map f l) from_list (List.map f l)
let rec mem l x = let rec mem l x =
match l with match l with
| [] -> false | [] -> false
| t::q -> | t::q ->
let c = Elem.compare x t in let c = Elem.compare x t in
(c = 0) || ((c > 0) && (mem q x)) (c = 0) || ((c > 0) && (mem q x))
...@@ -248,7 +247,7 @@ module Make(X : Custom.T) = struct ...@@ -248,7 +247,7 @@ module Make(X : Custom.T) = struct
let rec assoc_remove_aux v r = function let rec assoc_remove_aux v r = function
| ((x,y) as a)::l -> | ((x,y) as a)::l ->
let c = Elem.compare x v in let c = Elem.compare x v in
if c = 0 then (r := Some y; l) if c = 0 then (r := Some y; l)
else if c < 0 then a :: (assoc_remove_aux v r l) else if c < 0 then a :: (assoc_remove_aux v r l)
else raise Not_found else raise Not_found
| [] -> raise Not_found | [] -> raise Not_found
...@@ -324,7 +323,7 @@ module Make(X : Custom.T) = struct ...@@ -324,7 +323,7 @@ module Make(X : Custom.T) = struct
let rec mem x l = let rec mem x l =
match l with match l with
| [] -> false | [] -> false
| (t,_)::q -> | (t,_)::q ->
let c = Elem.compare x t in let c = Elem.compare x t in
(c = 0) || ((c > 0) && (mem x q)) (c = 0) || ((c > 0) && (mem x q))
...@@ -346,7 +345,7 @@ module Make(X : Custom.T) = struct ...@@ -346,7 +345,7 @@ module Make(X : Custom.T) = struct
else restrict l1 q2 else restrict l1 q2
| _ -> [] | _ -> []
let from_list f l = let from_list f l =
let rec initlist = function let rec initlist = function
| [] -> [] | [] -> []
| e::rest -> [e] :: initlist rest in | e::rest -> [e] :: initlist rest in
...@@ -359,7 +358,7 @@ module Make(X : Custom.T) = struct ...@@ -359,7 +358,7 @@ module Make(X : Custom.T) = struct
| llist -> mergeall (merge2 llist) in | llist -> mergeall (merge2 llist) in
mergeall (initlist l) mergeall (initlist l)
let from_list_disj l = let from_list_disj l =
let rec initlist = function let rec initlist = function
| [] -> [] | [] -> []
| e::rest -> [e] :: initlist rest in | e::rest -> [e] :: initlist rest in
...@@ -375,7 +374,7 @@ module Make(X : Custom.T) = struct ...@@ -375,7 +374,7 @@ module Make(X : Custom.T) = struct
let rec map_from_slist f = function let rec map_from_slist f = function
| x::l -> (x,f x)::(map_from_slist f l) | x::l -> (x,f x)::(map_from_slist f l)
| [] -> [] | [] -> []
let rec collide f l1 l2 = let rec collide f l1 l2 =
match (l1,l2) with match (l1,l2) with
| (_,y1)::l1, (_,y2)::l2 -> f y1 y2; collide f l1 l2 | (_,y1)::l1, (_,y2)::l2 -> f y1 y2; collide f l1 l2
...@@ -411,14 +410,10 @@ module Make(X : Custom.T) = struct ...@@ -411,14 +410,10 @@ module Make(X : Custom.T) = struct
| (x,y)::l -> (f y)::(map_to_list f l) | (x,y)::l -> (f y)::(map_to_list f l)
| [] -> [] | [] -> []
let rec init f = function
[] -> []
| x :: l -> (x, f x) :: (init f l)
let rec assoc v = function let rec assoc v = function
| (x,y)::l -> | (x,y)::l ->
let c = Elem.compare x v in let c = Elem.compare x v in
if c = 0 then y if c = 0 then y
else if c < 0 then assoc v l else if c < 0 then assoc v l
else raise Not_found else raise Not_found
| [] -> raise Not_found | [] -> raise Not_found
...@@ -431,7 +426,7 @@ module Make(X : Custom.T) = struct ...@@ -431,7 +426,7 @@ module Make(X : Custom.T) = struct
| [] -> assert false | [] -> assert false
let rec compare f l1 l2 = let rec compare f l1 l2 =
if l1 == l2 then 0 if l1 == l2 then 0
else match (l1,l2) with else match (l1,l2) with
| (x1,y1)::l1, (x2,y2)::l2 -> | (x1,y1)::l1, (x2,y2)::l2 ->
let c = Elem.compare x1 x2 in if c <> 0 then c let c = Elem.compare x1 x2 in if c <> 0 then c
...@@ -453,13 +448,13 @@ module Make(X : Custom.T) = struct ...@@ -453,13 +448,13 @@ module Make(X : Custom.T) = struct
let rec check f = function let rec check f = function
| (x,a)::((y,b)::_ as tl) -> | (x,a)::((y,b)::_ as tl) ->
Elem.check x; f a; Elem.check x; f a;
assert (Elem.compare x y < 0); check f tl assert (Elem.compare x y < 0); check f tl
| [x,a] -> Elem.check x; f a | [x,a] -> Elem.check x; f a
| _ -> () | _ -> ()
end (* Map *) end (* Map *)
module MakeMap(Y : Custom.T) = struct module MakeMap(Y : Custom.T) = struct
...@@ -469,10 +464,10 @@ module Make(X : Custom.T) = struct ...@@ -469,10 +464,10 @@ module Make(X : Custom.T) = struct
in types.ml... *) in types.ml... *)
let hash x = Map.hash Y.hash x let hash x = Map.hash Y.hash x
let compare x y = Map.compare Y.compare x y let compare x y = Map.compare Y.compare x y
let equal x y = Map.equal Y.equal x y let equal x y = Map.equal Y.equal x y
let check l = Map.check Y.check l let check l = Map.check Y.check l
let dump ppf l = let dump ppf l =
List.iter (fun (x,y) -> List.iter (fun (x,y) ->
Format.fprintf ppf "(%a->%a)" Elem.dump x Y.dump y) l Format.fprintf ppf "(%a->%a)" Elem.dump x Y.dump y) l
...@@ -512,7 +507,7 @@ module FiniteCofinite(X : Custom.T) = struct ...@@ -512,7 +507,7 @@ module FiniteCofinite(X : Custom.T) = struct
let compare l1 l2 = let compare l1 l2 =
match (l1,l2) with match (l1,l2) with
| Finite l1, Finite l2 | Finite l1, Finite l2
| Cofinite l1, Cofinite l2 -> SList.compare l1 l2 | Cofinite l1, Cofinite l2 -> SList.compare l1 l2
| Finite _, Cofinite _ -> -1 | Finite _, Cofinite _ -> -1
| _ -> 1 | _ -> 1
...@@ -560,11 +555,11 @@ module FiniteCofinite(X : Custom.T) = struct ...@@ -560,11 +555,11 @@ module FiniteCofinite(X : Custom.T) = struct
let neg = function let neg = function
| Finite s -> Cofinite s | Finite s -> Cofinite s
| Cofinite s -> Finite s | Cofinite s -> Finite s
let contains x = function let contains x = function
| Finite s -> SList.mem s x | Finite s -> SList.mem s x
| Cofinite s -> not (SList.mem s x) | Cofinite s -> not (SList.mem s x)
let disjoint s t = let disjoint s t =
match (s,t) with match (s,t) with
| (Finite s, Finite t) -> SList.disjoint s t | (Finite s, Finite t) -> SList.disjoint s t
...@@ -586,79 +581,79 @@ struct ...@@ -586,79 +581,79 @@ struct
let sample = function let sample = function
| Cofinite _ -> None | Cofinite _ -> None
| Finite l -> (match T.get l with | Finite l -> (match T.get l with
| [] -> raise Not_found | [] -> raise Not_found
| (x,y)::_ -> Some (x, SymbolSet.sample y)) | (x,y)::_ -> Some (x, SymbolSet.sample y))
let get = function let get = function
| Finite l -> `Finite (T.get l) | Finite l -> `Finite (T.get l)
| Cofinite l -> `Cofinite (T.get l) | Cofinite l -> `Cofinite (T.get l)
let check = function let check = function
| Finite l | Cofinite l -> TMap.check l | Finite l | Cofinite l -> TMap.check l
let dump ppf = function let dump ppf = function
| Finite s -> Format.fprintf ppf "Finite[%a]" TMap.dump s | Finite s -> Format.fprintf ppf "Finite[%a]" TMap.dump s
| Cofinite s -> Format.fprintf ppf "Cofinite[%a]" TMap.dump s | Cofinite s -> Format.fprintf ppf "Cofinite[%a]" TMap.dump s
let empty = Finite T.empty let empty = Finite T.empty
let any = Cofinite T.empty let any = Cofinite T.empty
let any_in_ns ns = Finite (T.singleton ns SymbolSet.any) let any_in_ns ns = Finite (T.singleton ns SymbolSet.any)
let finite l = let finite l =
let l = let l =
T.filter T.filter
(fun _ x -> match x with SymbolSet.Finite [] -> false | _ -> true) (fun _ x -> match x with SymbolSet.Finite [] -> false | _ -> true)
l in l in
Finite l Finite l
let cofinite l = let cofinite l =
let l = let l =
T.filter T.filter
(fun _ x -> match x with SymbolSet.Finite [] -> false | _ -> true) (fun _ x -> match x with SymbolSet.Finite [] -> false | _ -> true)
l in l in
Cofinite l Cofinite l
let atom (ns,x) = Finite (T.singleton ns (SymbolSet.atom x)) let atom (ns,x) = Finite (T.singleton ns (SymbolSet.atom x))
let cup s t = let cup s t =
match (s,t) with match (s,t) with
| (Finite s, Finite t) -> finite (T.merge SymbolSet.cup s t) | (Finite s, Finite t) -> finite (T.merge SymbolSet.cup s t)
| (Finite s, Cofinite t) -> cofinite (T.sub SymbolSet.diff t s) | (Finite s, Cofinite t) -> cofinite (T.sub SymbolSet.diff t s)
| (Cofinite s, Finite t) -> cofinite (T.sub SymbolSet.diff s t) | (Cofinite s, Finite t) -> cofinite (T.sub SymbolSet.diff s t)
| (Cofinite s, Cofinite t) -> cofinite (T.cap SymbolSet.cap s t) | (Cofinite s, Cofinite t) -> cofinite (T.cap SymbolSet.cap s t)
let cap s t = let cap s t =
match (s,t) with match (s,t) with
| (Finite s, Finite t) -> finite (T.cap SymbolSet.cap s t) | (Finite s, Finite t) -> finite (T.cap SymbolSet.cap s t)
| (Finite s, Cofinite t) -> finite (T.sub SymbolSet.diff s t) | (Finite s, Cofinite t) -> finite (T.sub SymbolSet.diff s t)
| (Cofinite s, Finite t) -> finite (T.sub SymbolSet.diff t s) | (Cofinite s, Finite t) -> finite (T.sub SymbolSet.diff t s)
| (Cofinite s, Cofinite t) -> cofinite (T.merge SymbolSet.cup s t) | (Cofinite s, Cofinite t) -> cofinite (T.merge SymbolSet.cup s t)
let diff s t = let diff s t =
match (s,t) with match (s,t) with
| (Finite s, Cofinite t) -> finite (T.cap SymbolSet.cap s t) | (Finite s, Cofinite t) -> finite (T.cap SymbolSet.cap s t)
| (Finite s, Finite t) -> finite (T.sub SymbolSet.diff s t) | (Finite s, Finite t) -> finite (T.sub SymbolSet.diff s t)
| (Cofinite s, Cofinite t) -> finite (T.sub SymbolSet.diff t s) | (Cofinite s, Cofinite t) -> finite (T.sub SymbolSet.diff t s)
| (Cofinite s, Finite t) -> cofinite (T.merge SymbolSet.cup s t) | (Cofinite s, Finite t) -> cofinite (T.merge SymbolSet.cup s t)
let is_empty = function let is_empty = function
| Finite l -> T.is_empty l | Finite l -> T.is_empty l
| _ -> false | _ -> false
let hash = function let hash = function
| Finite l -> 1 + 17 * (TMap.hash l) | Finite l -> 1 + 17 * (TMap.hash l)
| Cofinite l -> 2 + 17 * (TMap.hash l) | Cofinite l -> 2 + 17 * (TMap.hash l)
let compare l1 l2 = let compare l1 l2 =
match (l1,l2) with match (l1,l2) with
| Finite l1, Finite l2 | Finite l1, Finite l2
| Cofinite l1, Cofinite l2 -> TMap.compare l1 l2 | Cofinite l1, Cofinite l2 -> TMap.compare l1 l2
| Finite _, Cofinite _ -> -1 | Finite _, Cofinite _ -> -1
| _ -> 1 | _ -> 1
let equal t1 t2 = let equal t1 t2 =
compare t1 t2 = 0 compare t1 t2 = 0
let symbol_set ns = function let symbol_set ns = function
...@@ -668,12 +663,12 @@ struct ...@@ -668,12 +663,12 @@ struct
(try SymbolSet.neg (T.assoc ns s) with Not_found -> SymbolSet.any) (try SymbolSet.neg (T.assoc ns s) with Not_found -> SymbolSet.any)
let contains (ns,x) = function let contains (ns,x) = function
| Finite s -> | Finite s ->
(try SymbolSet.contains x (T.assoc ns s) with Not_found -> false) (try SymbolSet.contains x (T.assoc ns s) with Not_found -> false)
| Cofinite s -> | Cofinite s ->
(try not (SymbolSet.contains x (T.assoc ns s)) with Not_found -> true) (try not (SymbolSet.contains x (T.assoc ns s)) with Not_found -> true)
let disjoint s t = let disjoint s t =
is_empty (cap t s) (* TODO: OPT *) is_empty (cap t s) (* TODO: OPT *)
end end
...@@ -64,7 +64,6 @@ sig ...@@ -64,7 +64,6 @@ sig
val mapi: (Elem.t -> 'a -> 'b) -> 'a map -> 'b map val mapi: (Elem.t -> 'a -> 'b) -> 'a map -> 'b map
val constant: 'a -> t -> 'a map val constant: 'a -> t -> 'a map
val num: int -> t -> int map val num: int -> t -> int map
val init : (Elem.t -> 'a) -> t -> 'a map
val map_to_list: ('a -> 'b) -> 'a map -> 'b list val map_to_list: ('a -> 'b) -> 'a map -> 'b list
val mapi_to_list: (Elem.t -> 'a -> 'b) -> 'a map -> 'b list val mapi_to_list: (Elem.t -> 'a -> 'b) -> 'a map -> 'b list
val assoc: Elem.t -> 'a map -> 'a val assoc: Elem.t -> 'a map -> 'a
...@@ -104,7 +103,7 @@ module FiniteCofinite(X : Custom.T) : FiniteCofinite with type elem = X.t ...@@ -104,7 +103,7 @@ module FiniteCofinite(X : Custom.T) : FiniteCofinite with type elem = X.t
module FiniteCofiniteMap(X : Custom.T)(SymbolSet : FiniteCofinite) : module FiniteCofiniteMap(X : Custom.T)(SymbolSet : FiniteCofinite) :
sig sig
include Custom.T include Custom.T
val empty: t val empty: t
val any: t val any: t
val any_in_ns: X.t -> t val any_in_ns: X.t -> t
...@@ -118,7 +117,7 @@ sig ...@@ -118,7 +117,7 @@ sig
val contains: X.t * SymbolSet.elem -> t -> bool val contains: X.t * SymbolSet.elem -> t -> bool
val disjoint: t -> t -> bool val disjoint: t -> t -> bool
val get: t -> [ `Finite of (X.t * SymbolSet.t) list val get: t -> [ `Finite of (X.t * SymbolSet.t) list
| `Cofinite of (X.t * SymbolSet.t) list ] | `Cofinite of (X.t * SymbolSet.t) list ]
val sample: t -> (X.t * SymbolSet.elem option) option val sample: t -> (X.t * SymbolSet.elem option) option
......
This diff is collapsed.
...@@ -155,16 +155,13 @@ module Positive : sig ...@@ -155,16 +155,13 @@ module Positive : sig
val xml: v -> v -> v val xml: v -> v -> v
val solve: v -> Node.t val solve: v -> Node.t
val substitute : t -> (Var.var * t) -> t
val substitute_list : t -> (Var.var * t) list -> t
val solve_rectype : t -> Var.var -> t
val substitute_free : Var.Set.t -> t -> t
val clean_type : Var.Set.t -> t -> t
end end
module Substitution :
sig
val apply : t -> (Var.var * t) list -> t
val apply_single : t -> (Var.var * t) -> t
val refresh_type : Var.Set.t -> t -> t
val solve_fixpoint : t -> Var.var -> t
end
(** Normalization **) (** Normalization **)
module Product : sig module Product : sig
......
...@@ -548,7 +548,7 @@ module IType = struct ...@@ -548,7 +548,7 @@ module IType = struct
(Printf.sprintf "Wrong number of parameters for parametric type %s" (U.to_string id)); (Printf.sprintf "Wrong number of parameters for parametric type %s" (U.to_string id));
| Error s -> raise_loc_generic loc s | Error s -> raise_loc_generic loc s
in in
mk_type ((*Types.Positive.substitute_list*) Types.Substitution.apply t l) mk_type (Types.Positive.substitute_list t l)
with Not_found -> with Not_found ->
assert (rest == []); assert (rest == []);
if args != [] then if args != [] then
...@@ -618,20 +618,15 @@ module IType = struct ...@@ -618,20 +618,15 @@ module IType = struct
raise_loc_generic loc raise_loc_generic loc
(Printf.sprintf "Definition of type %s contains unbound type variables" (Printf.sprintf "Definition of type %s contains unbound type variables"
(Ident.to_string v)); (Ident.to_string v));
let nargs = List.map (fun x ->
let v = (Var.mk (U.to_string x)) in v, Types.var v
) args in
(*
Not needed ?
let vars_mapping = (* create a sequence 'a -> 'a_0 for all variables *) let vars_mapping = (* create a sequence 'a -> 'a_0 for all variables *)
List.map (fun v -> let vv = Var.mk (U.to_string v) in vv, Var.fresh vv) args List.map (fun v -> let vv = Var.mk (U.to_string v) in vv, Var.fresh vv) args
in in
let sub_list = List.map (fun (v,vt) -> v, Types.var vt) vars_mapping in let sub_list = List.map (fun (v,vt) -> v, Types.var vt) vars_mapping in
let t_rhs = let t_rhs =
(*Types.Positive.substitute_list t_rhs*)Types.Substitution.apply t_rhs sub_list Types.Positive.substitute_list t_rhs sub_list
in in
let nargs = List.map2 (fun (_, v) (_, vt) -> v, vt) vars_mapping sub_list let nargs = List.map2 (fun (_, v) (_, vt) -> v, vt) vars_mapping sub_list
in *) in
(v,t_rhs,nargs) (v,t_rhs,nargs)
) (List.rev b) ) (List.rev b)
in in
...@@ -667,7 +662,7 @@ module IType = struct ...@@ -667,7 +662,7 @@ module IType = struct
current_params := (idx,params,map); current_params := (idx,params,map);
type_defs env b type_defs env b
) env b in ) env b in
clean_params ();r clean_params (); r
with exn -> clean_on_err (); raise exn with exn -> clean_on_err (); raise exn
let typ env t = let typ env t =
...@@ -1145,8 +1140,8 @@ and type_check' loc env ed constr precise = match ed with ...@@ -1145,8 +1140,8 @@ and type_check' loc env ed constr precise = match ed with
(fun v -> (fun v ->
let open Types in let open Types in
match v with match v with
| Val t -> Val (Substitution.refresh_type env.delta t) | Val t -> Val (Positive.substitute_free env.delta t)
| EVal (a,b,t) -> EVal (a,b,Substitution.refresh_type env.delta t) | EVal (a,b,t) -> EVal (a,b,Positive.substitute_free env.delta t)
| x -> x) | x -> x)
env.ids } env.ids }
in in
...@@ -1222,7 +1217,7 @@ and type_check' loc env ed constr precise = match ed with ...@@ -1222,7 +1217,7 @@ and type_check' loc env ed constr precise = match ed with
| Apply (e1,e2) -> | Apply (e1,e2) ->
let t1 = type_check env e1 Types.Arrow.any true in let t1 = type_check env e1 Types.Arrow.any true in
let t1arrow = Types.Arrow.get t1 in let t1arrow = Types.Arrow.get t1 in
let t1 = Types.Substitution.refresh_type env.delta t1 in let t1 = Types.Positive.substitute_free env.delta t1 in
(* t [_delta 0 -> 1 *) (* t [_delta 0 -> 1 *)
begin try begin try
ignore(Types.Tallying.tallying env.delta [(t1,Types.Arrow.any)]) ignore(Types.Tallying.tallying env.delta [(t1,Types.Arrow.any)])
...@@ -1232,7 +1227,7 @@ and type_check' loc env ed constr precise = match ed with ...@@ -1232,7 +1227,7 @@ and type_check' loc env ed constr precise = match ed with
let dom = Types.Arrow.domain(t1arrow) in let dom = Types.Arrow.domain(t1arrow) in
let t2 = type_check env e2 Types.any true in let t2 = type_check env e2 Types.any true in
let t2 = Types.Substitution.refresh_type env.delta t2 in let t2 = Types.Positive.substitute_free env.delta t2 in
let (sl,res) = let (sl,res) =
if not (Types.no_var dom) || if not (Types.no_var dom) ||
not (Types.no_var t2) then not (Types.no_var t2) then
......
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