Updates for Obc
This commit is contained in:
Cédric Pasteur
Cédric Pasteur
parent
b0a5a7f13e
commit
226ddd5c28
4 changed files with 128 additions and 146 deletions
|
|
@ -1,4 +1,4 @@
|
|||
<global> or <utilities> or <minils> or <heptagon> or <main> or <sequential>:include
|
||||
<global> or <utilities> or <minils> or <heptagon> or <main> or <obc>:include
|
||||
<**/*.ml>: debug, dtypes
|
||||
<preproc.ml>: camlp4of, use_camlp4
|
||||
<**/hept_parser.ml>: use_menhirLib
|
||||
|
|
|
|||
|
|
@ -14,6 +14,7 @@
|
|||
open Minils
|
||||
open Ident
|
||||
open Misc
|
||||
open Obc
|
||||
|
||||
let var_from_name map x =
|
||||
begin try
|
||||
|
|
@ -32,50 +33,36 @@ let rec control map ck s =
|
|||
| Cbase | Cvar { contents = Cindex _ } -> s
|
||||
| Cvar { contents = Clink ck } -> control map ck s
|
||||
| Con(ck, c, n) ->
|
||||
let e = var_from_name map n in
|
||||
control map ck (Obc.Case(Obc.Lhs e, [(c, s)]))
|
||||
let x = var_from_name map n in
|
||||
control map ck [Acase(mk_exp (Elhs x), [(c, s)])]
|
||||
|
||||
let rec simplify act =
|
||||
match act with
|
||||
| Obc.Assgn (lhs, e) ->
|
||||
(match e with
|
||||
| Obc.Lhs l when l = lhs -> Obc.Nothing
|
||||
| _ -> act
|
||||
let is_deadcode = function
|
||||
| Aassgn (lhs, e) ->
|
||||
(match e.e_desc with
|
||||
| Elhs l -> l = lhs
|
||||
| _ -> false
|
||||
)
|
||||
| Obc.Case(lhs, h) ->
|
||||
(match simplify_handlers h with
|
||||
| [] -> Obc.Nothing
|
||||
| h -> Obc.Case(lhs, h)
|
||||
)
|
||||
| _ -> act
|
||||
| Acase (e, []) -> true
|
||||
| Afor(_, _, _, []) -> true
|
||||
| _ -> false
|
||||
|
||||
and simplify_handlers = function
|
||||
| [] -> []
|
||||
| (n,a)::h ->
|
||||
let h = simplify_handlers h in
|
||||
(match simplify a with
|
||||
| Obc.Nothing -> h
|
||||
| a -> (n,a)::h
|
||||
)
|
||||
|
||||
let rec join s1 s2 =
|
||||
match simplify s1, simplify s2 with
|
||||
| Obc.Case(Obc.Lhs(n), h1), Obc.Case(Obc.Lhs(m), h2) when n = m ->
|
||||
Obc.Case(Obc.Lhs(n), joinhandlers h1 h2)
|
||||
| s1, Obc.Nothing -> s1
|
||||
| Obc.Nothing, s2 -> s2
|
||||
| s1, Obc.Comp(s2, s3) -> Obc.Comp(join s1 s2, s3)
|
||||
| s1, s2 -> Obc.Comp(s1, s2)
|
||||
let rec joinlist l =
|
||||
let l = List.filter (fun a -> not (is_deadcode a)) l in
|
||||
match l with
|
||||
| [] -> []
|
||||
| [s1] -> [s1]
|
||||
| s1::s2::l ->
|
||||
match s1, s2 with
|
||||
| Acase(e1, h1),
|
||||
Acase(e2, h2) when e1.e_desc = e2.e_desc ->
|
||||
joinlist ((Acase(e1, joinhandlers h1 h2))::l)
|
||||
| s1, s2 -> s1::(joinlist (s2::l))
|
||||
|
||||
and joinhandlers h1 h2 =
|
||||
match h1 with
|
||||
| [] -> h2
|
||||
| (c1, s1) :: h1' ->
|
||||
let s1', h2' =
|
||||
try let s2, h2'' = find c1 h2 in join s1 s2, h2''
|
||||
with Not_found -> simplify s1, h2 in
|
||||
(c1, s1') :: joinhandlers h1' h2'
|
||||
|
||||
let rec joinlist = function
|
||||
| [] -> Obc.Nothing
|
||||
| s :: l -> join s (joinlist l)
|
||||
try let s2, h2'' = find c1 h2 in s1@s2, h2''
|
||||
with Not_found -> s1, h2 in
|
||||
(c1, joinlist s1') :: joinhandlers h1' h2'
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@ open Misc
|
|||
open Names
|
||||
open Ident
|
||||
open Types
|
||||
|
||||
open Location
|
||||
|
||||
type class_name = name
|
||||
type instance_name = longname
|
||||
|
|
@ -22,14 +22,19 @@ type op_name = longname
|
|||
type type_dec =
|
||||
{ t_name : name;
|
||||
t_desc : tdesc;
|
||||
t_loc : loc }
|
||||
t_loc : location }
|
||||
|
||||
and tdesc =
|
||||
| Type_abs
|
||||
| Type_enum of name list
|
||||
| Type_struct of (name * ty) list
|
||||
|
||||
type lhs = { l_desc : lhs_desc; l_ty : ty; l_loc : loc }
|
||||
type const_dec = {
|
||||
c_name : name;
|
||||
c_value : static_exp;
|
||||
c_loc : location }
|
||||
|
||||
type lhs = { l_desc : lhs_desc; l_ty : ty; l_loc : location }
|
||||
|
||||
and lhs_desc =
|
||||
| Lvar of var_ident
|
||||
|
|
@ -37,7 +42,7 @@ and lhs_desc =
|
|||
| Lfield of lhs * field_name
|
||||
| Larray of lhs * exp
|
||||
|
||||
and exp = { e_desc : exp_desc; e_ty : ty; e_loc : loc }
|
||||
and exp = { e_desc : exp_desc; e_ty : ty; e_loc : location }
|
||||
|
||||
and exp_desc =
|
||||
| Elhs of lhs
|
||||
|
|
@ -66,48 +71,49 @@ and block = act list
|
|||
type var_dec =
|
||||
{ v_ident : var_ident;
|
||||
v_type : ty; (* TODO should be here, v_controllable : bool*)
|
||||
v_loc : loc }
|
||||
v_loc : location }
|
||||
|
||||
type obj_dec =
|
||||
{ o_name : obj_name;
|
||||
o_class : instance_name;
|
||||
o_size : static_exp;
|
||||
o_loc : loc }
|
||||
o_size : static_exp option;
|
||||
o_loc : location }
|
||||
|
||||
type method_def =
|
||||
{ f_name : fun_name;
|
||||
f_inputs : var_dec list;
|
||||
f_outputs : var_dec list;
|
||||
f_locals : var_dec list;
|
||||
f_body : act list; }
|
||||
{ m_name : fun_name;
|
||||
m_inputs : var_dec list;
|
||||
m_outputs : var_dec list;
|
||||
m_locals : var_dec list;
|
||||
m_body : act list; }
|
||||
|
||||
type class_def =
|
||||
{ c_name : class_name;
|
||||
c_mems : var_dec list;
|
||||
c_objs : obj_dec list;
|
||||
c_methods: method_def list;
|
||||
c_loc : loc }
|
||||
{ cd_name : class_name;
|
||||
cd_mems : var_dec list;
|
||||
cd_objs : obj_dec list;
|
||||
cd_methods: method_def list;
|
||||
cd_loc : location }
|
||||
|
||||
type program =
|
||||
{ p_opened : name list;
|
||||
p_types : type_dec list;
|
||||
p_consts : const_dec list;
|
||||
p_defs : class_def list }
|
||||
|
||||
let mk_var_dec name ty =
|
||||
{ v_ident = name; v_type = ty }
|
||||
let mk_var_dec ?(loc=no_location) name ty =
|
||||
{ v_ident = name; v_type = ty; v_loc = loc }
|
||||
|
||||
let mk_exp ?(ty=invalid_type) desc =
|
||||
{ e_desc = desc; e_ty = ty }
|
||||
let mk_exp ?(ty=invalid_type) ?(loc=no_location) desc =
|
||||
{ e_desc = desc; e_ty = ty; e_loc = loc }
|
||||
|
||||
let mk_lhs ?(ty=invalid_type) desc =
|
||||
{ l_desc = desc; l_ty = ty }
|
||||
let mk_lhs ?(ty=invalid_type) ?(loc=no_location) desc =
|
||||
{ l_desc = desc; l_ty = ty; l_loc = loc }
|
||||
|
||||
let rec var_ident x =
|
||||
match x with
|
||||
let rec var_name x =
|
||||
match x.l_desc with
|
||||
| Lvar x -> x
|
||||
| Lmem x -> x
|
||||
| Lfield(x,_) -> var_ident x
|
||||
| Larray(l, _) -> var_ident l
|
||||
| Lfield(x,_) -> var_name x
|
||||
| Larray(l, _) -> var_name l
|
||||
|
||||
(** Returns whether an object of name n belongs to
|
||||
a list of var_dec. *)
|
||||
|
|
|
|||
|
|
@ -1,15 +1,9 @@
|
|||
open Obc
|
||||
open Format
|
||||
open Pp_tools
|
||||
|
||||
let rec print_type ff = function
|
||||
| Tint -> fprintf ff "int"
|
||||
| Tfloat -> fprintf ff "float"
|
||||
| Tbool -> fprintf ff "bool"
|
||||
| Tid(id) -> print_longname ff id
|
||||
| Tarray(ty, n) ->
|
||||
print_type ff ty;
|
||||
fprintf ff "^%d" n
|
||||
open Types
|
||||
open Ident
|
||||
open Names
|
||||
|
||||
let print_vd ff vd =
|
||||
fprintf ff "@[<v>";
|
||||
|
|
@ -18,27 +12,20 @@ let print_vd ff vd =
|
|||
print_type ff vd.v_type;
|
||||
fprintf ff "@]"
|
||||
|
||||
let print_obj ff { cls = cls; obj = obj; size = n } =
|
||||
fprintf ff "@[<v>"; print_name ff obj;
|
||||
fprintf ff " : "; print_longname ff cls;
|
||||
if n <> 1 then
|
||||
fprintf ff "[%d]" n;
|
||||
let print_obj ff o =
|
||||
fprintf ff "@[<v>"; print_name ff o.o_name;
|
||||
fprintf ff " : "; print_longname ff o.o_class;
|
||||
(match o.o_size with
|
||||
| Some se -> print_static_exp ff se;
|
||||
| None -> ());
|
||||
fprintf ff ";@]"
|
||||
|
||||
let rec print_c ff = function
|
||||
| Cint i -> fprintf ff "%d" i
|
||||
| Cfloat f -> fprintf ff "%f" f
|
||||
| Cconstr(tag) -> print_longname ff tag
|
||||
| Carray(n,c) ->
|
||||
print_c ff c;
|
||||
fprintf ff "^%d" n
|
||||
|
||||
let rec print_lhs ff e =
|
||||
match e with
|
||||
| Var x -> print_ident ff x
|
||||
| Mem x -> fprintf ff "mem("; print_ident ff x; fprintf ff ")"
|
||||
| Field (l, f) -> print_lhs ff l; fprintf ff ".%s" (shortname f)
|
||||
| Array(x, idx) ->
|
||||
match e.l_desc with
|
||||
| Lvar x -> print_ident ff x
|
||||
| Lmem x -> fprintf ff "mem("; print_ident ff x; fprintf ff ")"
|
||||
| Lfield (l, f) -> print_lhs ff l; fprintf ff ".%s" (shortname f)
|
||||
| Larray(x, idx) ->
|
||||
print_lhs ff x;
|
||||
fprintf ff "[";
|
||||
print_exp ff idx;
|
||||
|
|
@ -46,21 +33,22 @@ let rec print_lhs ff e =
|
|||
|
||||
and print_exps ff e_list = print_list_r print_exp "" "," "" ff e_list
|
||||
|
||||
and print_exp ff = function
|
||||
| Lhs lhs -> print_lhs ff lhs
|
||||
| Const c -> print_c ff c
|
||||
| Op(op, e_list) -> print_op ff op e_list
|
||||
| Struct_lit(_,f_e_list) ->
|
||||
fprintf ff "@[<v 1>";
|
||||
print_list_r
|
||||
(fun ff (field, e) -> print_longname ff field;fprintf ff " = ";
|
||||
print_exp ff e)
|
||||
"{" ";" "}" ff f_e_list;
|
||||
fprintf ff "@]"
|
||||
| Array_lit e_list ->
|
||||
fprintf ff "@[";
|
||||
print_list_r print_exp "[" ";" "]" ff e_list;
|
||||
fprintf ff "@]"
|
||||
and print_exp ff e =
|
||||
match e.e_desc with
|
||||
| Elhs lhs -> print_lhs ff lhs
|
||||
| Econst c -> print_static_exp ff c
|
||||
| Eop(op, e_list) -> print_op ff op e_list
|
||||
| Estruct(_,f_e_list) ->
|
||||
fprintf ff "@[<v 1>";
|
||||
print_list_r
|
||||
(fun ff (field, e) -> print_longname ff field;fprintf ff " = ";
|
||||
print_exp ff e)
|
||||
"{" ";" "}" ff f_e_list;
|
||||
fprintf ff "@]"
|
||||
| Earray e_list ->
|
||||
fprintf ff "@[";
|
||||
print_list_r print_exp "[" ";" "]" ff e_list;
|
||||
fprintf ff "@]"
|
||||
|
||||
and print_op ff op e_list =
|
||||
print_longname ff op;
|
||||
|
|
@ -72,38 +60,40 @@ let print_asgn ff pref x e =
|
|||
fprintf ff "@]"
|
||||
|
||||
let print_obj_call ff = function
|
||||
| Context o -> print_name ff o
|
||||
| Array_context (o, i) ->
|
||||
| Oobj o -> print_name ff o
|
||||
| Oarray (o, i) ->
|
||||
fprintf ff "%a[%a]"
|
||||
print_name o
|
||||
print_lhs i
|
||||
|
||||
let print_method_name ff = function
|
||||
| Mstep -> fprintf ff "step"
|
||||
| Mreset -> fprintf ff "reset"
|
||||
| Mmethod n -> fprintf ff "%s" n
|
||||
|
||||
let rec print_act ff a =
|
||||
match a with
|
||||
| Assgn (x, e) -> print_asgn ff "" x e
|
||||
| Comp (a1, a2) ->
|
||||
fprintf ff "@[<v>";
|
||||
print_act ff a1;
|
||||
fprintf ff ";@,";
|
||||
print_act ff a2;
|
||||
fprintf ff "@]"
|
||||
| Case(e, tag_act_list) ->
|
||||
| Aassgn (x, e) -> print_asgn ff "" x e
|
||||
| Acase(e, tag_act_list) ->
|
||||
fprintf ff "@[<v>@[<v 2>switch (";
|
||||
print_exp ff e; fprintf ff ") {@,";
|
||||
print_tag_act_list ff tag_act_list;
|
||||
fprintf ff "@]@,}@]"
|
||||
| For(x, i1, i2, act) ->
|
||||
fprintf ff "@[<v>@[<v 2>for %s=%d to %d : {@, %a @]@,}@]"
|
||||
(name x) i1 i2
|
||||
print_act act
|
||||
| Step_ap (var_list, o, es) ->
|
||||
| Afor(x, i1, i2, act_list) ->
|
||||
fprintf ff "@[<v>@[<v 2>for %s=%a to %a : {@, %a @]@,}@]"
|
||||
(name x)
|
||||
print_static_exp i1
|
||||
print_static_exp i2
|
||||
print_act_list act_list
|
||||
| Acall (var_list, o, meth, es) ->
|
||||
print_list print_lhs "(" "," ")" ff var_list;
|
||||
fprintf ff " = "; print_obj_call ff o; fprintf ff ".step(";
|
||||
fprintf ff " = "; print_obj_call ff o;
|
||||
fprintf ff ".%a(" print_method_name meth;
|
||||
fprintf ff "@["; print_exps ff es; fprintf ff "@]";
|
||||
fprintf ff ")"
|
||||
| Reinit o ->
|
||||
print_name ff o; fprintf ff ".reset()"
|
||||
| Nothing -> fprintf ff "()"
|
||||
|
||||
and print_act_list ff l =
|
||||
print_list_r print_act "" ";" "" ff l
|
||||
|
||||
and print_tag_act_list ff tag_act_list =
|
||||
print_list
|
||||
|
|
@ -111,32 +101,27 @@ and print_tag_act_list ff tag_act_list =
|
|||
fprintf ff "@[<hov 2>case@ ";
|
||||
print_longname ff tag;
|
||||
fprintf ff ":@ ";
|
||||
print_act ff a;
|
||||
print_act_list ff a;
|
||||
fprintf ff "@]") "" "" "" ff tag_act_list
|
||||
|
||||
let print_step ff { inp = inp; out = out; local = nl; bd = bd } =
|
||||
let print_method ff md =
|
||||
fprintf ff "@[<v 2>";
|
||||
fprintf ff "step(@[";
|
||||
print_list_r print_vd "(" ";" ")" ff inp;
|
||||
print_longname ff md.m_name;
|
||||
fprintf ff "(@[";
|
||||
print_list_r print_vd "(" ";" ")" ff md.m_inputs;
|
||||
fprintf ff "@]) returns ";
|
||||
print_list_r print_vd "(" ";" ")" ff out;
|
||||
print_list_r print_vd "(" ";" ")" ff md.m_outputs;
|
||||
fprintf ff "@]){@,";
|
||||
if nl <> [] then begin
|
||||
if md.m_locals <> [] then begin
|
||||
fprintf ff "@[<hov 4>var ";
|
||||
print_list_r print_vd "" ";" "" ff nl;
|
||||
print_list_r print_vd "" ";" "" ff md.m_locals;
|
||||
fprintf ff ";@]@,"
|
||||
end;
|
||||
print_act ff bd;
|
||||
fprintf ff "}@]"
|
||||
|
||||
let print_reset ff act =
|
||||
fprintf ff "@[<v 2>";
|
||||
fprintf ff "reset() {@,";
|
||||
print_act ff act;
|
||||
print_act_list ff md.m_body;
|
||||
fprintf ff "}@]"
|
||||
|
||||
let print_def ff
|
||||
{ cl_id = id; mem = mem; objs = objs; reset = reset; step = step } =
|
||||
{ cd_name = id; cd_mems = mem; cd_objs = objs; cd_methods = m_list } =
|
||||
fprintf ff "@[<v 2>machine "; print_name ff id; fprintf ff " =@,";
|
||||
if mem <> [] then begin
|
||||
fprintf ff "@[<hov 4>var ";
|
||||
|
|
@ -148,9 +133,7 @@ let print_def ff
|
|||
print_list print_obj "" ";" "" ff objs;
|
||||
fprintf ff ";@]@,"
|
||||
end;
|
||||
print_reset ff reset;
|
||||
fprintf ff "@,";
|
||||
print_step ff step;
|
||||
print_list_r print_method "" "\n" "" ff m_list;
|
||||
fprintf ff "@]"
|
||||
|
||||
let print_type_def ff { t_name = name; t_desc = tdesc } =
|
||||
|
|
@ -175,9 +158,15 @@ let print_open_module ff name =
|
|||
print_name ff name;
|
||||
fprintf ff "@.@]"
|
||||
|
||||
let print_prog ff { o_opened = modules; o_types = types; o_defs = defs } =
|
||||
let print_const_dec ff c =
|
||||
fprintf ff "const %a = %a" print_name c.c_name
|
||||
print_static_exp c.c_value
|
||||
|
||||
let print_prog ff { p_opened = modules; p_types = types;
|
||||
p_consts = consts; p_defs = defs } =
|
||||
List.iter (print_open_module ff) modules;
|
||||
List.iter (print_type_def ff) types;
|
||||
List.iter (print_const_dec ff) consts;
|
||||
List.iter (fun def -> (print_def ff def; fprintf ff "@ ")) defs
|
||||
|
||||
let print oc p =
|
||||
|
|
|
|||
Loading…
Reference in a new issue