Attention une mise à jour du service Gitlab va être effectuée le mardi 18 janvier (et non lundi 17 comme annoncé précédemment) entre 18h00 et 18h30. Cette mise à jour va générer une interruption du service dont nous ne maîtrisons pas complètement la durée mais qui ne devrait pas excéder quelques minutes.

Commit 53ace977 authored by Andrei Paskevich's avatar Andrei Paskevich
Browse files

another refactoring in Term (and Explicit_polymorphism)

parent d4518463
......@@ -74,6 +74,13 @@ let create_lsymbol name args value = {
let create_fsymbol nm al vl = create_lsymbol nm al (Some vl)
let create_psymbol nm al = create_lsymbol nm al (None)
let ls_ty_freevars ls =
let acc = match ls.ls_value with
| None -> Stv.empty
| Some ty -> ty_freevars Stv.empty ty
in
List.fold_left ty_freevars acc ls.ls_args
(** Patterns *)
type pattern = {
......@@ -950,29 +957,28 @@ let f_open_quant_cb fq =
(* constructors with type checking *)
let t_app_inst fs tl ty =
let s = match fs.ls_value with
| Some vty -> ty_match Mtv.empty vty ty
| _ -> raise (FunctionSymbolExpected fs)
let ls_app_inst ls tl ty =
let s = match ls.ls_value, ty with
| Some _, None -> raise (PredicateSymbolExpected ls)
| None, Some _ -> raise (FunctionSymbolExpected ls)
| Some vty, Some ty -> ty_match Mtv.empty vty ty
| None, None -> Mtv.empty
in
let mtch s ty t = ty_match s ty t.t_ty in
try List.fold_left2 mtch s fs.ls_args tl
with Invalid_argument _ -> raise (BadArity
(fs, List.length fs.ls_args, List.length tl))
let f_app_inst ps tl =
let s = match ps.ls_value with
| None -> Mtv.empty
| _ -> raise (PredicateSymbolExpected ps)
let s =
let mtch s ty t = ty_match s ty t.t_ty in
try List.fold_left2 mtch s ls.ls_args tl
with Invalid_argument _ -> raise (BadArity
(ls, List.length ls.ls_args, List.length tl))
in
let mtch s ty t = ty_match s ty t.t_ty in
try List.fold_left2 mtch s ps.ls_args tl
with Invalid_argument _ -> raise (BadArity
(ps, List.length ps.ls_args, List.length tl))
let add v acc = Mtv.add v (ty_inst s (ty_var v)) acc in
Stv.fold add (ls_ty_freevars ls) Mtv.empty
let fs_app_inst fs tl ty = ls_app_inst fs tl (Some ty)
let ps_app_inst ps tl = ls_app_inst ps tl None
let t_app fs tl ty = ignore (t_app_inst fs tl ty); t_app fs tl ty
let t_app fs tl ty = ignore (fs_app_inst fs tl ty); t_app fs tl ty
let f_app ps tl = ignore (f_app_inst ps tl); f_app ps tl
let f_app ps tl = ignore (ps_app_inst ps tl); f_app ps tl
let t_app_infer fs tl =
let mtch s ty t = ty_match s ty t.t_ty in
......
......@@ -55,6 +55,8 @@ val create_lsymbol : preid -> ty list -> ty option -> lsymbol
val create_fsymbol : preid -> ty list -> ty -> lsymbol
val create_psymbol : preid -> ty list -> lsymbol
val ls_ty_freevars : lsymbol -> Stv.t
(** {2 Exceptions} *)
exception EmptyCase
......@@ -221,6 +223,12 @@ val f_open_quant_cb :
fmla_quant -> vsymbol list * trigger list * fmla *
(vsymbol list -> trigger list -> fmla -> fmla_quant)
(** compute type instance *)
val ls_app_inst : lsymbol -> term list -> ty option -> ty Mtv.t
val fs_app_inst : lsymbol -> term list -> ty -> ty Mtv.t
val ps_app_inst : lsymbol -> term list -> ty Mtv.t
(** smart constructors for term *)
val t_var : vsymbol -> term
......@@ -237,7 +245,6 @@ val t_let_close : vsymbol -> term -> term -> term
val t_eps_close : vsymbol -> fmla -> term
val t_app_infer : lsymbol -> term list -> term
val t_app_inst : lsymbol -> term list -> ty -> ty Mtv.t
val t_label : label list -> term -> term
val t_label_add : label -> term -> term
......@@ -266,8 +273,6 @@ val f_quant_close : quant -> vsymbol list -> trigger list -> fmla -> fmla
val f_forall_close : vsymbol list -> trigger list -> fmla -> fmla
val f_exists_close : vsymbol list -> trigger list -> fmla -> fmla
val f_app_inst : lsymbol -> term list -> ty Mtv.t
val f_label : label list -> fmla -> fmla
val f_label_add : label -> fmla -> fmla
val f_label_copy : fmla -> fmla -> fmla
......
......@@ -64,28 +64,17 @@ module Transform = struct
Hashtbl.add tbl id new_image;
new_image
(** returns all type vars in given lsymbol *)
let l_find_type_vars l =
let acc = match l.ls_value with
| None -> Stv.empty
| Some ty -> ty_freevars Stv.empty ty in
let s = List.fold_left ty_freevars acc l.ls_args in
Stv.elements s
(** creates a new logic symbol, with a different type if the
given symbol was polymorphic *)
let logic_to_logic lsymbol =
if ls_equal lsymbol ps_equ || ls_equal lsymbol ps_neq then lsymbol else
let new_ty = l_find_type_vars lsymbol in
let new_ty = ls_ty_freevars lsymbol in
(* as many t as type vars *)
if new_ty = [] then lsymbol (* same type *) else
let new_ty = List.map (const my_t) new_ty in
let all_new_ty = new_ty @ lsymbol.ls_args in
if Stv.is_empty new_ty then lsymbol (* same type *) else
let add _ acc = my_t :: acc in
let args = Stv.fold add new_ty lsymbol.ls_args in
(* creates a new lsymbol with the same name but a different type *)
let new_lsymbol =
Term.create_lsymbol (id_clone lsymbol.ls_name)
all_new_ty lsymbol.ls_value in
new_lsymbol
Term.create_lsymbol (id_clone lsymbol.ls_name) args lsymbol.ls_value
(** creates a lsymbol associated with the given tysymbol *)
let type_to_logic ty =
......@@ -116,38 +105,29 @@ module Transform = struct
(** translation of terms *)
let rec term_transform tblT tblL varM t = match t.t_node with
| Tapp(f, terms) ->
let new_f = findL tblL f in
(* first, remember an order for type vars of new_f *)
let type_vars = l_find_type_vars f in
(* Debug.print_list Pretty.print_ty Format.std_formatter type_vars; *)
let tv_to_ty = t_app_inst f terms t.t_ty in
(* Debug.print_mtv Pretty.print_ty Format.err_formatter tv_to_ty; *)
(* fresh terms to be added at the beginning of the list of arguments *)
let find_ty v = ty_to_term tblT varM (ty_inst tv_to_ty (ty_var v)) in
let new_terms = List.map find_ty type_vars in
let transformed_terms = List.map (term_transform tblT tblL varM) terms in
t_app new_f (new_terms @ transformed_terms) t.t_ty
let terms = args_transform tblT tblL varM f terms (Some t.t_ty) in
t_app (findL tblL f) terms t.t_ty
| _ -> (* default case : traverse *)
t_map (term_transform tblT tblL varM) (fmla_transform tblT tblL varM) t
(** translation of formulae *)
and fmla_transform tblT tblL varM f = match f.f_node with
(* first case : predicate (not = or <>), we must translate it and its args *)
| Fapp(p,terms) when (not (ls_equal p ps_equ)) && not(ls_equal p ps_neq) ->
let new_p = findL tblL p in
(* first, remember an order for type vars of new_f *)
let type_vars = l_find_type_vars p in
(* Debug.print_list Pretty.print_ty Format.std_formatter type_vars; *)
let tv_to_ty = f_app_inst p terms in
(* Debug.print_mtv Pretty.print_ty Format.err_formatter tv_to_ty; *)
(* fresh terms to be added at the beginning of the list of arguments *)
let find_ty v = ty_to_term tblT varM (ty_inst tv_to_ty (ty_var v)) in
let new_terms = List.map find_ty type_vars in
let transformed_terms = List.map (term_transform tblT tblL varM) terms in
f_app new_p (new_terms @ transformed_terms)
(* first case : predicate (not =), we must translate it and its args *)
| Fapp(p,terms) when not (ls_equal p ps_equ || ls_equal p ps_neq) ->
let terms = args_transform tblT tblL varM p terms None in
f_app (findL tblL p) terms
| _ -> (* otherwise : just traverse and translate *)
f_map (term_transform tblT tblL varM) (fmla_transform tblT tblL varM) f
and args_transform tblT tblL varM ls args ty =
(* Debug.print_list Pretty.print_ty Format.std_formatter type_vars; *)
let tv_to_ty = ls_app_inst ls args ty in
(* Debug.print_mtv Pretty.print_ty Format.err_formatter tv_to_ty; *)
let args = List.map (term_transform tblT tblL varM) args in
(* fresh args to be added at the beginning of the list of arguments *)
let add _ ty acc = ty_to_term tblT varM ty :: acc in
Mtv.fold add tv_to_ty args
(** transforms a list of logic declarations into another.
Declares new lsymbols with explicit polymorphic signatures.
@param tblT binds type symbols to logic symbols
......@@ -157,20 +137,19 @@ module Transform = struct
let helper = function
| (lsymbol, Some ldef) ->
let new_lsymbol = findL tblL lsymbol in (* new lsymbol *)
let polymorphic_vars = l_find_type_vars lsymbol in
let new_vars = List.map
(fun _ -> Term.create_vsymbol (id_fresh "t") my_t)
polymorphic_vars in (* new vars for polymorphism *)
let varM = List.fold_left2 (fun m x v -> Mtv.add x v m)
Mtv.empty polymorphic_vars new_vars in
let vars,expr = open_ls_defn ldef in
let add v (vl,vm) =
let vs = Term.create_vsymbol (id_fresh "t") my_t in
vs :: vl, Mtv.add v vs vm
in
let vars,varM = Stv.fold add (ls_ty_freevars lsymbol) (vars,Mtv.empty) in
(match expr with
| Term t ->
let t = term_transform tblT tblL varM t in
Decl.make_fs_defn new_lsymbol (new_vars @ vars) t
Decl.make_fs_defn new_lsymbol vars t
| Fmla f ->
let f = fmla_transform tblT tblL varM f in
Decl.make_ps_defn new_lsymbol (new_vars @ vars) f)
Decl.make_ps_defn new_lsymbol vars f)
| (lsymbol, None) ->
let new_lsymbol = findL tblL lsymbol in
(new_lsymbol, None) in
......
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