Commit 084706a2 authored by François Bobot's avatar François Bobot

encoding_arrays : correct it

encoding_sort   : identity on meta lsymbol without definition
                  undefined symbol are defined before using them...

courses  WP_registerStudent : 0.53 s -> 0.03!!
parent 09547524
...@@ -133,8 +133,11 @@ theory int.EuclideanDivision ...@@ -133,8 +133,11 @@ theory int.EuclideanDivision
end end
theory transform.array.Array theory transform.array.Array
syntax logic get "(select %1 %2)" syntax logic get "(select %1 %2)"
syntax logic get "(store %1 %2)" syntax logic set "(store %1 %2)"
remove prop Select_eq
remove prop Select_neq
end end
(* (*
......
...@@ -65,15 +65,16 @@ type info = { ...@@ -65,15 +65,16 @@ type info = {
let rec print_type info fmt ty = match ty.ty_node with let rec print_type info fmt ty = match ty.ty_node with
| Tyvar _ -> unsupported "smt : you must encode the polymorphism" | Tyvar _ -> unsupported "smt : you must encode the polymorphism"
| Tyapp (ts, tl) -> begin match query_syntax info.info_syn ts.ts_name with | Tyapp (ts, []) -> begin match query_syntax info.info_syn ts.ts_name with
| Some s -> syntax_arguments s (print_type info) fmt tl | Some s -> syntax_arguments s (print_type info) fmt []
| None -> fprintf fmt "%a%a" (print_tyapp info) tl print_ident ts.ts_name | None -> fprintf fmt "%a" print_ident ts.ts_name
end end
| Tyapp (_, _) -> unsupported "smt : you must encode the complexe type"
and print_tyapp info fmt = function (* and print_tyapp info fmt = function *)
| [] -> () (* | [] -> () *)
| [ty] -> fprintf fmt "%a " (print_type info) ty (* | [ty] -> fprintf fmt "%a " (print_type info) ty *)
| tl -> fprintf fmt "(%a) " (print_list comma (print_type info)) tl (* | tl -> fprintf fmt "(%a) " (print_list comma (print_type info)) tl *)
let print_type info fmt = catch_unsupportedType (print_type info fmt) let print_type info fmt = catch_unsupportedType (print_type info fmt)
...@@ -223,15 +224,15 @@ let print_decl info fmt = catch_unsupportedDecl (print_decl info fmt) ...@@ -223,15 +224,15 @@ let print_decl info fmt = catch_unsupportedDecl (print_decl info fmt)
let barrays task = let barrays task =
let fold barrays = let fold barrays =
function function
| [MAts tst;MAts tsk;MAts tse] -> | [MAts tst;MAty tyk;MAty tye] ->
let extract_ty ts = (* let extract_ty ts = *)
if ts.ts_args <> [] then (* if ts.ts_args <> [] then *)
unsupported "smtv1 : type with argument are not supported"; (* unsupported "smtv1 : type with argument are not supported"; *)
match ts.ts_def with (* match ts.ts_def with *)
| Some ty -> ty (* | Some ty -> ty *)
| None -> ty_app ts [] in (* | None -> ty_app ts [] in *)
Mts.add tst (extract_ty tsk,extract_ty tse) barrays Mts.add tst (tyk,tye) barrays
| _ -> barrays in | _ -> assert false in
Task.on_meta Encoding_arrays.meta_mono_array fold Mts.empty task Task.on_meta Encoding_arrays.meta_mono_array fold Mts.empty task
let print_task pr thpr fmt task = let print_task pr thpr fmt task =
......
...@@ -219,12 +219,19 @@ let gen_tvar su = ...@@ -219,12 +219,19 @@ let gen_tvar su =
Ssubst.fold fold su su in Ssubst.fold fold su su in
Ssubst.fold aux su (Ssubst.singleton (Mtv.empty)) Ssubst.fold aux su (Ssubst.singleton (Mtv.empty))
(* find all the possible instantiation which can give a type of env.keep *)
let ty_quant env = let ty_quant env =
let rec add_vs s ty = let rec add_vs s ty =
let s = ty_fold add_vs s ty in let s = ty_fold add_vs s ty in
match ty.ty_node with match ty.ty_node with
| Tyapp(app,_) when ts_equal app env.poly_ts -> | Tyapp(app,_) when ts_equal app env.poly_ts ->
Mty.fold (fun uty _ s -> Ssubst.add (ty_match Mtv.empty ty uty) s) Mty.fold (fun uty _ s ->
try
Ssubst.add (ty_match Mtv.empty ty uty) s
with Ty.TypeMismatch _ ->
(* No instantiation possible *)
s
)
env.keep s env.keep s
| _ -> s in | _ -> s in
f_ty_fold add_vs Ssubst.empty f_ty_fold add_vs Ssubst.empty
...@@ -320,7 +327,7 @@ let collect_arrays poly_ts tds = ...@@ -320,7 +327,7 @@ let collect_arrays poly_ts tds =
Sts.fold extract tds Mty.empty Sts.fold extract tds Mty.empty
let meta_mono_array = register_meta "encoding_arrays : mono_arrays" let meta_mono_array = register_meta "encoding_arrays : mono_arrays"
[MTtysymbol;MTtysymbol;MTtysymbol] [MTtysymbol;MTty;MTty]
(* Some general env creation function *) (* Some general env creation function *)
let create_env env task thpoly tds = let create_env env task thpoly tds =
......
...@@ -150,7 +150,7 @@ let fold tenv taskpre task = ...@@ -150,7 +150,7 @@ let fold tenv taskpre task =
| ls, None -> conv_ls tenv ud ls, None | ls, None -> conv_ls tenv ud ls, None
| _ -> Printer.unsupportedDecl d "use eliminate_definition" | _ -> Printer.unsupportedDecl d "use eliminate_definition"
in in
decl_ud ud (add_logic_decl task (List.map conv ll)) add_logic_decl (decl_ud ud task) (List.map conv ll)
| Dind _ -> | Dind _ ->
Printer.unsupportedDecl d "use eliminate_inductive" Printer.unsupportedDecl d "use eliminate_inductive"
| Dprop _ -> | Dprop _ ->
...@@ -165,12 +165,13 @@ let fold tenv taskpre task = ...@@ -165,12 +165,13 @@ let fold tenv taskpre task =
| MAty ty -> MAty (conv_ty tenv ud ty) | MAty ty -> MAty (conv_ty tenv ud ty)
| MAts {ts_name = name; ts_args = []; ts_def = Some ty} -> | MAts {ts_name = name; ts_args = []; ts_def = Some ty} ->
MAts (conv_ts tenv ud name ty) MAts (conv_ts tenv ud name ty)
| MAts {ts_args = []; ts_def = None} as x -> x
| MAts _ -> raise Exit | MAts _ -> raise Exit
| MAls ls -> MAls (conv_ls tenv ud ls) | MAls ls -> MAls (conv_ls tenv ud ls)
| MApr _ -> raise Exit | MApr _ -> raise Exit
| MAstr _ as s -> s | MAstr _ as s -> s
| MAint _ as i -> i in | MAint _ as i -> i in
decl_ud ud (add_meta task meta (List.map map ml)) add_meta (decl_ud ud task) meta (List.map map ml)
with with
| Printer.UnsupportedType _ | Printer.UnsupportedType _
| Exit -> add_tdecl task taskpre.task_decl | Exit -> add_tdecl task taskpre.task_decl
......
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