Commit a22db1ec authored by Andrei Paskevich's avatar Andrei Paskevich

small cleanups

parent b8d3a796
......@@ -86,7 +86,6 @@ why3.conf
/bin/why3wc.opt
/bin/why3wc.byte
/bin/why3wc
/bin/style.css
# /doc/
/doc/version.tex
......@@ -123,9 +122,10 @@ why3.conf
/doc/apidoc/
/doc/stdlibdoc/
/doc/texput.log
/doc/q.log
# /lib
/lib/why3-cpulimit
/lib/why3-cpulimit.exe
/lib/why3cpulimit
/lib/why3cpulimit.exe
/lib/why3server
......@@ -133,7 +133,6 @@ why3.conf
# /lib/why3/
/lib/why3/META
/lib/why3-cpulimit
# /lib/ocaml/
/lib/ocaml/why3__BigInt_compat.ml
......
......@@ -235,6 +235,7 @@ let dty_unify_app ls unify (l1: 'a list) (l2: dty list) =
try List.iter2 unify l1 l2 with Invalid_argument _ ->
raise (BadArity (ls, List.length l1))
(* FIXME: can we convert every use of dty_unify_app to this one? *)
let dty_unify_app_map ls unify (l1: 'a list) (l2: dty list) =
try List.map2 unify l1 l2 with Invalid_argument _ ->
raise (BadArity (ls, List.length l1))
......@@ -274,6 +275,7 @@ let dpattern ?loc node =
dty, Mstr.singleton n dty
| DPapp (ls,dpl) ->
let dtyl, dty = specialize_cs ls in
(* FIXME: ignore (dty_unify_app_map ...) ? *)
dty_unify_app ls dpat_expected_type dpl dtyl;
let join n _ _ = raise (DuplicateVar n) in
let add acc dp = Mstr.union join acc dp.dp_vars in
......@@ -296,31 +298,25 @@ let dpattern ?loc node =
let slab_coercion = Slab.singleton Pretty.label_coercion
let apply_coercion ~loc l dt =
let apply_coercion l ({dt_loc = loc} as dt) =
let apply dt ls =
let (dtyl, dty) = specialize_ls ls in
let dtl = [dt] in
List.iter2 dterm_expected_type dtl dtyl;
let dt = { dt_node = DTapp (ls, dtl); dt_dty = dty; dt_loc = loc } in
let dtyl, dty = specialize_ls ls in
dterm_expected_type dt (List.hd dtyl);
let dt = { dt_node = DTapp (ls, [dt]); dt_dty = dty; dt_loc = loc } in
{ dt with dt_node = DTlabel (dt, slab_coercion) } in
List.fold_left apply dt l
(* coercions using just head tysymbols without type arguments: *)
(* TODO: this can be improved *)
let rec ts_of_dty = function
| Dvar { contents = Dval (Duty { ty_node = (Tyapp (ts, _)) })} ->
ts
| Dvar { contents = Dval dty } ->
| Dvar {contents = Dval dty} ->
ts_of_dty dty
| Dvar { contents = Dind _ } ->
let tv = create_tvsymbol (id_fresh "xi") in
raise (UndefinedTypeVar tv)
| Dapp (ts, _) ->
ts
| Duty { ty_node = (Tyapp (ts, _)) } ->
| Dvar {contents = Dind _}
| Duty {ty_node = Tyvar _} ->
raise Exit
| Duty {ty_node = Tyapp (ts,_)}
| Dapp (ts,_) ->
ts
| Duty { ty_node = Tyvar tv } ->
raise (UndefinedTypeVar tv)
let ts_of_dty = function
| Some dt_dty -> ts_of_dty dt_dty
......@@ -332,8 +328,8 @@ let dterm_expected tuc dt dty =
if (ts_equal ts1 ts2) then dt
else
let crc = Coercion.find tuc.Theory.uc_crcmap ts1 ts2 in
apply_coercion ~loc:dt.dt_loc crc dt
with Not_found | UndefinedTypeVar _ -> dt
apply_coercion crc dt
with Not_found | Exit -> dt
let dterm_expected_dterm tuc dt dty =
let dt = dterm_expected tuc dt (Some dty) in
......@@ -359,13 +355,15 @@ let dterm tuc ?loc node =
mk_dty (Some dty_real)
| DTapp (ls, dtl) when ls_equal ls ps_equ ->
let dtyl, dty = specialize_ls ls in
let dtl = dty_unify_app_map ls (dterm_expected_dterm tuc) (List.rev dtl) dtyl in
let dtl = dty_unify_app_map ls
(dterm_expected_dterm tuc) (List.rev dtl) dtyl in
{ dt_node = DTapp (ls, List.rev dtl);
dt_dty = dty;
dt_loc = loc }
| DTapp (ls, dtl) ->
let dtyl, dty = specialize_ls ls in
{ dt_node = DTapp (ls, dty_unify_app_map ls (dterm_expected_dterm tuc) dtl dtyl);
{ dt_node = DTapp (ls,
dty_unify_app_map ls (dterm_expected_dterm tuc) dtl dtyl);
dt_dty = dty;
dt_loc = loc }
| DTfapp ({dt_dty = Some res} as dt1,dt2) ->
......@@ -377,6 +375,7 @@ let dterm tuc ?loc node =
if not_arrow res then Loc.errorm ?loc:dt1.dt_loc
"This term has type %a,@ it cannot be applied" print_dty res;
let dtyl, dty = specialize_ls fs_func_app in
(* FIXME: why no conversion here? *)
dty_unify_app fs_func_app dterm_expected_type [dt1;dt2] dtyl;
mk_dty dty
| DTfapp ({dt_dty = None; dt_loc = loc},_) ->
......
......@@ -153,11 +153,11 @@ type theory = {
th_name : ident; (* theory name *)
th_path : string list; (* environment qualifiers *)
th_decls : tdecl list; (* theory declarations *)
th_crcmap : Coercion.t; (* implicit coercions *)
th_export : namespace; (* exported namespace *)
th_known : known_map; (* known identifiers *)
th_local : Sid.t; (* locally declared idents *)
th_used : Sid.t; (* used theories *)
th_crcmap : Coercion.t; (* coercions *)
}
and tdecl = {
......@@ -257,13 +257,13 @@ type theory_uc = {
uc_name : ident;
uc_path : string list;
uc_decls : tdecl list;
uc_crcmap : Coercion.t;
uc_prefix : string list;
uc_import : namespace list;
uc_export : namespace list;
uc_known : known_map;
uc_local : Sid.t;
uc_used : Sid.t;
uc_crcmap : Coercion.t;
}
exception CloseTheory
......@@ -273,13 +273,13 @@ let empty_theory n p = {
uc_name = id_register n;
uc_path = p;
uc_decls = [];
uc_crcmap = Coercion.empty;
uc_prefix = [];
uc_import = [empty_ns];
uc_export = [empty_ns];
uc_known = Mid.empty;
uc_local = Sid.empty;
uc_used = Sid.empty;
uc_crcmap = Coercion.empty;
}
let close_theory uc = match uc.uc_export with
......@@ -287,11 +287,11 @@ let close_theory uc = match uc.uc_export with
{ th_name = uc.uc_name;
th_path = uc.uc_path;
th_decls = List.rev uc.uc_decls;
th_crcmap = uc.uc_crcmap;
th_export = e;
th_known = uc.uc_known;
th_local = uc.uc_local;
th_used = uc.uc_used;
th_crcmap = uc.uc_crcmap }
th_used = uc.uc_used }
| _ -> raise CloseTheory
let get_namespace uc = List.hd uc.uc_import
......@@ -351,6 +351,7 @@ let add_tdecl uc td = match td.td_node with
{ uc with uc_decls = td :: uc.uc_decls }
| Meta (m,([MAls ls] as al)) when meta_equal m meta_coercion ->
known_meta uc.uc_known al;
(* FIXME: shouldn't we add the meta to the theory? *)
{ uc with uc_crcmap = Coercion.add uc.uc_crcmap ls }
| Meta (_,al) -> known_meta uc.uc_known al;
{ uc with uc_decls = td :: uc.uc_decls }
......
......@@ -84,11 +84,11 @@ type theory = private {
th_name : ident; (* theory name *)
th_path : string list; (* environment qualifiers *)
th_decls : tdecl list; (* theory declarations *)
th_crcmap : Coercion.t; (* implicit coercions *)
th_export : namespace; (* exported namespace *)
th_known : known_map; (* known identifiers *)
th_local : Sid.t; (* locally declared idents *)
th_used : Sid.t; (* used theories *)
th_crcmap : Coercion.t (* coercions *)
}
and tdecl = private {
......@@ -122,14 +122,13 @@ type theory_uc = private {
uc_name : ident;
uc_path : string list;
uc_decls : tdecl list;
uc_crcmap : Coercion.t;
uc_prefix : string list;
uc_import : namespace list;
uc_export : namespace list;
uc_known : known_map;
uc_local : Sid.t;
uc_used : Sid.t;
uc_crcmap : Coercion.t;
}
val create_theory : ?path:string list -> preid -> theory_uc
......
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