Commit 31af7785 authored by MARCHE Claude's avatar MARCHE Claude

transformation detect_polymorphism: meta to ignore some polymorphic symbols

parent 6657f7c2
...@@ -27,7 +27,7 @@ theory BuiltIn ...@@ -27,7 +27,7 @@ theory BuiltIn
syntax type int "Int" syntax type int "Int"
syntax type real "Real" syntax type real "Real"
syntax predicate (=) "(= %1 %2)" syntax predicate (=) "(= %1 %2)"
meta "encoding:ignore_polymorphism_ls" predicate (=)
meta "encoding : kept" type int meta "encoding : kept" type int
end end
......
...@@ -3,9 +3,17 @@ ...@@ -3,9 +3,17 @@
printer "why3" printer "why3"
filename "%f-%t-%g.why" filename "%f-%t-%g.why"
(* transformation "detect_polymorphism" *)
theory BuiltIn theory BuiltIn
syntax type int "int" syntax type int "int"
syntax type real "real" syntax type real "real"
syntax predicate (=) "(%1 = %2)" syntax predicate (=) "(%1 = %2)"
(* meta "encoding:ignore_polymorphism_ls" predicate (=) *)
end end
(*
theory list.List
meta "encoding:ignore_polymorphism_ts" type list
end
*)
...@@ -15,125 +15,101 @@ open Theory ...@@ -15,125 +15,101 @@ open Theory
let debug = Debug.register_info_flag "detect_poly" let debug = Debug.register_info_flag "detect_poly"
~desc:"Print@ debugging@ messages@ of@ the@ 'detect_polymorphism'@ transformation." ~desc:"Print@ debugging@ messages@ of@ the@ 'detect_polymorphism'@ transformation."
(* metas to attach to symbols or propositions to tell their polymorphic
nature can be ignored because it will be treated specifically by
drivers *)
let meta_ignore_polymorphism_ts =
register_meta
"encoding:ignore_polymorphism_ts" [MTtysymbol]
~desc:"Ignore@ polymorphism@ of@ given@ type@ symbol."
let meta_ignore_polymorphism_ls =
register_meta
"encoding:ignore_polymorphism_ls" [MTlsymbol]
~desc:"Ignore@ polymorphism@ of@ given@ logic@ symbol."
let meta_ignore_polymorphism_pr =
register_meta
"encoding:ignore_polymorphism_pr" [MTprsymbol]
~desc:"Ignore@ polymorphism@ of@ given@ proposition."
(* exclusive meta that is set by the transformation when no
polymorphic definition is found *)
let meta_monomorphic_types_only = let meta_monomorphic_types_only =
register_meta_excl "encoding:monomorphic_only" [] register_meta_excl "encoding:monomorphic_only" []
~desc:"Set@ when@ no@ occurrences@ of@ type@ variables@ occur." ~desc:"Set@ when@ no@ occurrences@ of@ type@ variables@ occur."
(*
let meta_has_polymorphic_types =
register_meta_excl "encoding:polymorphic_types" []
~desc:"Set@ when@ occurrences@ of@ type@ variables@ occur."
*)
exception Found
open Term let check_ts ign_ts ts =
ts.Ty.ts_args <> [] && not (Ty.Sts.mem ts ign_ts)
let check_ts ts = let check_ls ign_ls ls =
if ts.Ty.ts_args <> [] then not (Term.Sls.mem ls ign_ls) &&
(Debug.dprintf debug "====== Type %a is polymorphic =======@." List.fold_left
Pretty.print_ts ts; (fun acc ty -> acc || not (Ty.ty_closed ty))
raise Found) false
ls.Term.ls_args
let check_ls ls = let detect_polymorphism_in_decl ign_ts ign_ls ign_pr d =
if not (ls_equal ls ps_equ) then Debug.dprintf debug "[detect_polymorphism] |sts|=%d |sls|=%d |spr|=%d@."
try (Ty.Sts.cardinal ign_ts)
List.iter (fun ty -> if not (Ty.ty_closed ty) then raise Found) (Term.Sls.cardinal ign_ls)
ls.ls_args (Spr.cardinal ign_pr);
with Found -> Debug.dprintf debug "[detect_polymorphism] decl %a@."
Debug.dprintf debug "====== Symbol %a is polymorphic =======@." Pretty.print_decl d;
Pretty.print_ls ls;
raise Found
let check_term t =
let s = Term.t_ty_freevars Ty.Stv.empty t in
if not (Ty.Stv.is_empty s) then raise Found
let find_in_decl d =
match d.d_node with match d.d_node with
| Dtype ts -> | Dtype ts -> check_ts ign_ts ts
Debug.dprintf debug "@[Dtype %a@]@." Pretty.print_ts ts;
check_ts ts
| Ddata dl -> | Ddata dl ->
Debug.dprintf debug "@[Ddata %a@]@." List.fold_left (fun acc (ts,_) -> acc || check_ts ign_ts ts) false dl
(Pp.print_list Pp.space Pretty.print_data_decl) dl;
List.iter (fun (ts,_) -> check_ts ts) dl
| Dparam ls -> | Dparam ls ->
Debug.dprintf debug "@[Dparam %a@]@." Pretty.print_ls ls; Debug.dprintf debug "[detect_polymorphism] param %a@."
check_ls ls Pretty.print_ls ls;
check_ls ign_ls ls
| Dlogic dl -> | Dlogic dl ->
Debug.dprintf debug "@[Dlogic %a@]@." (* note: we don't need to check also that definition bodies are
(Pp.print_list Pp.space Pretty.print_ls) (List.map fst dl); monomorphic, since it is checked by typing *)
List.iter (fun (ls,_) -> check_ls ls) dl List.fold_left (fun acc (ls,_) -> acc || check_ls ign_ls ls) false dl
(* TODO: check also that definition bodies are monomorphic ? *)
| Dind (_,indl) -> | Dind (_,indl) ->
Debug.dprintf debug "@[Dind %a@]@." (* note: we don't need to check also that clauses are
(Pp.print_list Pp.space Pretty.print_ls) (List.map fst indl); monomorphic, since it is checked by typing *)
List.iter (fun (ls,_) -> check_ls ls) indl List.fold_left (fun acc (ls,_) -> acc || check_ls ign_ls ls) false indl
(* TODO: check also that clauses are monomorphic ? *)
| Dprop (_,pr,t) -> | Dprop (_,pr,t) ->
Debug.dprintf debug "@[Dprop %a@]@." Pretty.print_pr pr; not (Spr.mem pr ign_pr) &&
try check_term t let s = Term.t_ty_freevars Ty.Stv.empty t in
with Found -> not (Ty.Stv.is_empty s)
Debug.dprintf debug "====== prop is polymorphic =======@.";
raise Found
let detect_polymorphism_in_task_hd ign_ts ign_l ign_pr t acc =
match t.Task.task_decl.td_node with
(**) | Decl d -> acc || detect_polymorphism_in_decl ign_ts ign_l ign_pr d
| Use _ | Clone _ | Meta _ -> acc
let (*
rec find_in_theory th = List.iter find_in_tdecl th.th_decls
let detect_polymorphism_in_task =
and Trans.on_tagged_ts
*) meta_ignore_polymorphism_ts
find_in_tdecl td = (fun sts ->
match td.td_node with Trans.on_tagged_ls
| Decl d -> find_in_decl d meta_ignore_polymorphism_ls
| Use _th -> (fun sls ->
(* Debug.dprintf debug "Look up in used theory %a@." Pretty.print_th th; *) Trans.on_tagged_pr
(* find_in_theory th *) meta_ignore_polymorphism_pr
() (* no need to traverse used theories *) (fun spr ->
| Clone (_th,_) -> Trans.fold
(* Debug.dprintf debug "Look up in cloned theory %a@." Pretty.print_th th; *) (detect_polymorphism_in_task_hd sts sls spr)
(* find_in_theory th *) false)))
() (* no need to traverse used theories *)
| Meta _ -> ()
let rec find_in_task task =
match task with
| None -> ()
| Some t -> find_in_task t.Task.task_prev ; find_in_tdecl t.Task.task_decl
let detect_polymorphism task = let detect_polymorphism task =
try if Trans.apply detect_polymorphism_in_task task then task else
find_in_task task;
try try
let g,t = Task.task_separate_goal task in let g,t = Task.task_separate_goal task in
let ta = Task.add_meta t meta_monomorphic_types_only [] in let ta = Task.add_meta t meta_monomorphic_types_only [] in
Task.add_tdecl ta g Task.add_tdecl ta g
with Task.GoalNotFound -> with Task.GoalNotFound ->
Task.add_meta task meta_monomorphic_types_only [] Task.add_meta task meta_monomorphic_types_only []
with Found -> task
let () = Trans.register_transform "detect_polymorphism" let () = Trans.register_transform "detect_polymorphism"
(Trans.store detect_polymorphism) (Trans.store detect_polymorphism)
~desc:"Detect if task has polymorphic types somewhere." ~desc:"Detect if task has polymorphic types somewhere."
(* A variant, not satisfactory
let check_decl d =
try
find_in_decl d;
[Theory.create_decl d]
with Found ->
[Theory.create_meta meta_has_polymorphic_types [];
Theory.create_decl d]
let detect_polymorphism = Trans.tdecl check_decl None
let () = Trans.register_transform "detect_polymorphism"
detect_polymorphism
~desc:"Detect if task has polymorphic types somewhere."
*)
...@@ -8,6 +8,10 @@ use import int.Int ...@@ -8,6 +8,10 @@ use import int.Int
goal g : 2+2 = 5 goal g : 2+2 = 5
(* bin/why3prove.byte tests/test-poly.why --debug detect_poly -a detect_polymorphism -D why3 -T Mono -G g *)
end end
...@@ -36,6 +40,8 @@ goal g4 : match x with I y -> y=A | J y (D z) -> z=A | J B z -> z=C | J A C -> t ...@@ -36,6 +40,8 @@ goal g4 : match x with I y -> y=A | J y (D z) -> z=A | J B z -> z=C | J A C -> t
goal g5 : match x with I y -> y | J y _ -> y end = A goal g5 : match x with I y -> y | J y _ -> y end = A
(* bin/why3prove.byte tests/test-poly.why --debug detect_poly -a detect_polymorphism -D why3 -T MonoType -G g0 *)
end end
...@@ -73,6 +79,8 @@ theory PolySymb ...@@ -73,6 +79,8 @@ theory PolySymb
function id (x:'a) : 'a = x function id (x:'a) : 'a = x
meta "encoding:ignore_polymorphism_ls" function id
goal g: forall x:int. id x = x goal g: forall x:int. id x = x
(* bin/why3prove.byte tests/test-poly.why --debug detect_poly -a detect_polymorphism -D why3 -T PolySymb -G g *) (* bin/why3prove.byte tests/test-poly.why --debug detect_poly -a detect_polymorphism -D why3 -T PolySymb -G g *)
......
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