Commit 99d1849f authored by François Bobot's avatar François Bobot

core : use supermap to make some rewritting

parent ac0c4f10
...@@ -234,11 +234,10 @@ let check_termination ldl = ...@@ -234,11 +234,10 @@ let check_termination ldl =
in in
let syms = List.fold_left add Mls.empty ldl in let syms = List.fold_left add Mls.empty ldl in
Mls.iter (build_call_graph cgr syms) syms; Mls.iter (build_call_graph cgr syms) syms;
let check ls _ acc = let check ls _ =
let cl = build_call_list cgr ls in let cl = build_call_list cgr ls in
Mls.add ls (check_call_list ls cl) acc check_call_list ls cl in
in Mls.mapi check syms
Mls.fold check syms Mls.empty
(** Inductive predicate declaration *) (** Inductive predicate declaration *)
......
...@@ -67,28 +67,32 @@ module Compile (X : Action) = struct ...@@ -67,28 +67,32 @@ module Compile (X : Action) = struct
in in
(* dispatch every case to a primitive constructor/wild case *) (* dispatch every case to a primitive constructor/wild case *)
let cases,wilds = let cases,wilds =
let add_case fs pl a cases = let change_case fs pl a cases =
let rl = Mls.find_default fs [] cases in Mls.change fs (function
Mls.add fs ((pl,a)::rl) cases | None -> Some [pl,a]
in | Some rl -> Some ((pl,a)::rl)) cases in
let add_wild pl a fs ql cases = let union_cases pl a types cases =
let make_wild pl a ql =
let add pl q = pat_wild q.pat_ty :: pl in let add pl q = pat_wild q.pat_ty :: pl in
add_case fs (List.fold_left add pl ql) a cases [List.fold_left add pl ql,a]
in in
let types = Mls.map (make_wild pl a) types in
Mls.union (fun _ pla rl -> Some (List.append pla rl))
types cases in
let rec dispatch (pl,a) (cases,wilds) = let rec dispatch (pl,a) (cases,wilds) =
let p = List.hd pl in let pl = List.tl pl in let p = List.hd pl in let pl = List.tl pl in
match p.pat_node with match p.pat_node with
| Papp (fs,pl') -> | Papp (fs,pl') ->
add_case fs (List.rev_append pl' pl) a cases, wilds change_case fs (List.rev_append pl' pl) a cases, wilds
| Por (p,q) -> | Por (p,q) ->
dispatch (p::pl, a) (dispatch (q::pl, a) (cases,wilds)) dispatch (p::pl, a) (dispatch (q::pl, a) (cases,wilds))
| Pas (p,x) -> | Pas (p,x) ->
dispatch (p::pl, mk_let x t a) (cases,wilds) dispatch (p::pl, mk_let x t a) (cases,wilds)
| Pvar x -> | Pvar x ->
let a = mk_let x t a in let a = mk_let x t a in
Mls.fold (add_wild pl a) types cases, (pl,a)::wilds union_cases pl a types cases, (pl,a)::wilds
| Pwild -> | Pwild ->
Mls.fold (add_wild pl a) types cases, (pl,a)::wilds union_cases pl a types cases, (pl,a)::wilds
in in
List.fold_right dispatch rl (Mls.empty,[]) List.fold_right dispatch rl (Mls.empty,[])
in in
...@@ -125,7 +129,7 @@ module Compile (X : Action) = struct ...@@ -125,7 +129,7 @@ module Compile (X : Action) = struct
if Mls.mem cs types then comp_cases cs al else comp_wilds () if Mls.mem cs types then comp_cases cs al else comp_wilds ()
| _ -> | _ ->
let base = let base =
if Sls.for_all (fun cs -> Mls.mem cs types) css if Mls.submap (fun _ () _ -> true) css types
then [] else [mk_branch (pat_wild ty) (comp_wilds ())] then [] else [mk_branch (pat_wild ty) (comp_wilds ())]
in in
let add cs ql acc = let add cs ql acc =
......
...@@ -142,14 +142,16 @@ let remove_prop pr = ...@@ -142,14 +142,16 @@ let remove_prop pr =
let get_syntax_map task = let get_syntax_map task =
let add_ts td m = match td.td_node with let add_ts td m = match td.td_node with
| Meta (_,[MAts ts; MAstr s]) -> | Meta (_,[MAts ts; MAstr s]) ->
if Mid.mem ts.ts_name m then raise (KnownTypeSyntax ts); Mid.change ts.ts_name (function
Mid.add ts.ts_name s m | None -> Some s
| Some _ -> raise (KnownTypeSyntax ts)) m
| _ -> assert false | _ -> assert false
in in
let add_ls td m = match td.td_node with let add_ls td m = match td.td_node with
| Meta (_,[MAls ls; MAstr s]) -> | Meta (_,[MAls ls; MAstr s]) ->
if Mid.mem ls.ls_name m then raise (KnownLogicSyntax ls); Mid.change ls.ls_name (function
Mid.add ls.ls_name s m | None -> Some s
| Some _ -> raise (KnownLogicSyntax ls)) m
| _ -> assert false | _ -> assert false
in in
let m = Mid.empty in let m = Mid.empty in
...@@ -176,8 +178,7 @@ let get_remove_set task = ...@@ -176,8 +178,7 @@ let get_remove_set task =
let s = Stdecl.fold add_pr (find_meta task meta_remove_prop).tds_set s in let s = Stdecl.fold add_pr (find_meta task meta_remove_prop).tds_set s in
s s
let query_syntax sm id = let query_syntax sm id = Mid.find_option id sm
try Some (Mid.find id sm) with Not_found -> None
(** {2 exceptions to use in transformations and printers} *) (** {2 exceptions to use in transformations and printers} *)
......
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