jeltz/heptagon
1
0
Fork 0
Code Issues Pull requests Releases Activity

Last refactor ? and hept_mapred shows in !

Browse source
This commit is contained in:
Léonard Gérard 2010-07-07 15:11:32 +02:00 committed by Cédric Pasteur
parent 0e224bf368
commit 5baa30f7c1
14 changed files with 378 additions and 187 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
compiler/global/ident.ml
View file

@ -16,6 +16,8 @@ type ident = {
is_generated : bool;
}
type var_ident = ident
let compare id1 id2 = compare id1.num id2.num
let sourcename id = id.source
let name id =

3
compiler/global/ident.mli
View file

@ -7,6 +7,9 @@
(** The (abstract) type of identifiers*)
type ident
(** Type to be used for local variables *)
type var_ident = ident
(** Get the source name from an identifier*)
val sourcename : ident -> string
(** Get the full name of an identifier (it is guaranteed to be unique) *)

5
compiler/global/modules.ml
View file

@ -25,8 +25,9 @@ type env =
mutable values: node NamesEnv.t;
mutable types: type_def NamesEnv.t;
mutable constr: ty NamesEnv.t;
mutable structs : structure NamesEnv.t;
mutable fields : name NamesEnv.t;
mutable structs: structure NamesEnv.t;
mutable fields: name NamesEnv.t;
(* TODO CP mutable consts: const_def NamesEnv.t; *)
format_version : string;
}

11
compiler/global/names.ml
View file

@ -10,6 +10,17 @@ type longname =
and qualident = { qual: string; id: string }
type type_name = longname
type fun_name = longname
type field_name = longname
type constructor_name = longname
type constant_name = longname
module NamesM = struct
type t = name
let compare = compare

11
compiler/global/signature.ml
View file

@ -34,7 +34,6 @@ type structure = field list
type type_def = | Tabstract | Tenum of name list | Tstruct of structure
let names_of_arg_list l = List.map (fun ad -> ad.a_name) l
let types_of_arg_list l = List.map (fun ad -> ad.a_type) l
@ -46,9 +45,6 @@ let mk_param name ty = { p_name = name; p_type = ty }
let mk_field n ty = { f_name = n; f_type = ty }
let print_param ff p =
fprintf ff "%a:%a" Names.print_name p.p_name print_type p.p_type
let rec field_assoc f = function
| [] -> raise Not_found
| { f_name = n; f_type = ty }::l ->
@ -56,3 +52,10 @@ let rec field_assoc f = function
ty
else
field_assoc f l
open Format
let print_param ff p =
fprintf ff "%a:%a" Names.print_name p.p_name print_type p.p_type

48
compiler/global/static.ml
View file

@ -16,6 +16,7 @@
open Names
open Format
open Types
(** Constraints on size expressions. *)
@ -46,20 +47,21 @@ let apply_int_op op n1 n2 =
let n = if n2 = 0 then raise Instanciation_failed else n1 / n2 in
Sint n
| _ -> (* unknown operator, reconstrcut the op *)
Sop (op, Sint n1, Sint n2)
Sop (op, [mk_static_exp (Sint n1); mk_static_exp (Sint n2)]) (*TODO CP*)
(** [simplify env e] returns e simplified with the
variables values taken from env (mapping vars to integers).
Variables are replaced with their values and every operator
that can be computed is replaced with the value of the result. *)
let rec simplify env se =
match se with
| Sint _ | Sfloat _ | Sbool _ | Sconstructor -> se
| Svar id -> (try simplify env (NamesEnv.find id env) with | _ -> se)
match se.se_desc with
| Sint _ | Sfloat _ | Sbool _ | Sconstructor _ -> se
| Svar id ->
(try simplify env (NamesEnv.find (shortname id) env) with | _ -> se)
| Sop (op, [e1; e2]) ->
let e1 = simplify env e1 in
let e2 = simplify env e2 in
(match e1.e_desc, e2.e_desc with
(match e1.se_desc, e2.se_desc with
| Sint n1, Sint n2 -> { se with se_desc = apply_int_op op n1 n2 }
| _, _ -> { se with se_desc = Sop (op, [e1; e2]) }
)
@ -80,27 +82,27 @@ let rec simplify env se =
Instanciation_failed if it cannot be computed (if a var has no value).*)
let int_of_static_exp env e =
let e = simplify env e in
match e.e_desc with | Sint n -> n | _ -> raise Instanciation_failed
match e.se_desc with | Sint n -> n | _ -> raise Instanciation_failed
(** [is_true env constr] returns whether the constraint is satisfied
in the environment (or None if this can be decided)
and a simplified constraint. *)
let is_true env =
function
| Cequal e1, e2 when e1 = e2 ->
| Cequal (e1, e2) when e1 = e2 ->
Some true, Cequal (simplify env e1, simplify env e2)
| Cequal (e1, e2) ->
let e1 = simplify env e1 in
let e2 = simplify env e2
in
(match e1.e_desc, e2.e_desc with
(match e1.se_desc, e2.se_desc with
| Sint n1, Sint n2 -> Some (n1 = n2), Cequal (e1, e2)
| (_, _) -> None, Cequal (e1, e2))
| Clequal (e1, e2) ->
let e1 = simplify env e1 in
let e2 = simplify env e2
in
(match e1.e_desc, e2.e_desc with
(match e1.se_desc, e2.se_desc with
| Sint n1, Sint n2 -> Some (n1 <= n2), Clequal (e1, e2)
| _, _ -> None, Clequal (e1, e2))
| Cfalse -> None, Cfalse
@ -124,15 +126,15 @@ let rec solve const_env =
(** Substitutes variables in the size exp with their value
in the map (mapping vars to size exps). *)
let rec static_exp_subst m se =
let desc = match se.e_desc with
let desc = match se.se_desc with
| Svar n -> (try List.assoc n m with | Not_found -> Svar n)
| Sop (op, se_list) -> Sop (op, List.map (static_exp_subst m) se_list)
| Sarray_power (se, n) -> Sarray_power (static_exp_subst m se,
static_exp_subst m n)
| Sarray se_list -> Sarray (List.map (static_exp_subst env) se_list)
| Stuple se_list -> Stuple (List.map (static_exp_subst env) se_list)
| Sarray se_list -> Sarray (List.map (static_exp_subst m) se_list)
| Stuple se_list -> Stuple (List.map (static_exp_subst m) se_list)
| Srecord f_se_list ->
Srecord (List.map (fun (f,se) -> f, static_exp_subst env se) f_se_list)
Srecord (List.map (fun (f,se) -> f, static_exp_subst m se) f_se_list)
| s -> s
in
{ se with se_desc = desc }
@ -146,26 +148,8 @@ let instanciate_constr m constr =
| Cfalse -> Cfalse
in List.map (replace_one m) constr
let rec print_static_exp ff se = match se.e_desc with
| Sint i -> fprintf ff "%d" i
| Sbool b -> fprintf ff "%b" b
| Sfloat f -> fprintf ff "%f" f
| Sconstructor ln -> print_longname ff ln
| Svar id -> fprintf ff "%s" id
| Sop (op, se_list) ->
fprintf ff "@[<2>%a@,%a@]"
print_longname op print_static_exp_tuple se_list
| Sarray_power (se, n) ->
fprintf ff "%a^%a" print_static_exp se print_static_exp n
| Sarray se_list ->
fprintf ff "@[<2>%a@]" (print_list_r print_static_exp "["";""]") se_list
| Stuple se_list -> print_static_exp_tuple se_list
| Srecord f_se_list ->
print_record (print_couple print_longname
print_static_exp """ = """) ff f_se_list
and print_static_exp_tuple ff l =
fprintf ff "@[<2>%a@]" (print_list_r print_static_exp "("","")") l
open Format
let print_size_constraint ff = function
| Cequal (e1, e2) ->

35
compiler/global/types.ml
View file

@ -13,28 +13,49 @@ open Location
type static_exp = { se_desc: static_exp_desc; se_ty: ty; se_loc: location }
and static_exp_desc =
| Svar of name
| Svar of constant_name
| Sint of int
| Sfloat of float
| Sbool of bool
| Sconstructor of longname
| Sconstructor of constructor_name
| Stuple of static_exp list
| Sarray_power of static_exp * static_exp (** power : 0^n : [0,0,0,0,0,..] *)
| Sarray of static_exp list (** [ e1, e2, e3 ] *)
| Srecord of (longname * static_exp) list (** { f1 = e1; f2 = e2; ... } *)
| Sop of longname * static_exp list (** defined ops for now in pervasives *)
| Srecord of (field_name * static_exp) list (** { f1 = e1; f2 = e2; ... } *)
| Sop of fun_name * static_exp list (** defined ops for now in pervasives *)
type ty = | Tprod of ty list | Tid of longname | Tarray of ty * static_exp
and ty = | Tprod of ty list | Tid of type_name | Tarray of ty * static_exp
let invalid_type = Tprod []
let mk_static_exp ?(loc = no_location) ?(ty = invalid_type) =
let mk_static_exp ?(loc = no_location) ?(ty = invalid_type) desc =
{ se_desc = desc; se_ty = ty; se_loc = loc }
open Pp_tools
open Format
let rec print_type ff = function
let rec print_static_exp ff se = match se.se_desc with
| Sint i -> fprintf ff "%d" i
| Sbool b -> fprintf ff "%b" b
| Sfloat f -> fprintf ff "%f" f
| Sconstructor ln -> print_longname ff ln
| Svar id -> fprintf ff "%a" print_longname id
| Sop (op, se_list) ->
fprintf ff "@[<2>%a@,%a@]"
print_longname op print_static_exp_tuple se_list
| Sarray_power (se, n) ->
fprintf ff "%a^%a" print_static_exp se print_static_exp n
| Sarray se_list ->
fprintf ff "@[<2>%a@]" (print_list_r print_static_exp "["";""]") se_list
| Stuple se_list -> print_static_exp_tuple ff se_list
| Srecord f_se_list ->
print_record (print_couple print_longname
print_static_exp """ = """) ff f_se_list
and print_static_exp_tuple ff l =
fprintf ff "@[<2>%a@]" (print_list_r print_static_exp "("","")") l
and print_type ff = function
| Tprod ty_list ->
fprintf ff "@[<hov2>%a@]" (print_list_r print_type "(" " *" ")") ty_list
| Tid id -> print_longname ff id

149
compiler/heptagon/hept_mapred.ml Normal file
View file

@ -0,0 +1,149 @@
(**************************************************************************)
(* *)
(* Heptagon *)
(* *)
(* Author : Marc Pouzet *)
(* Organization : Demons, LRI, University of Paris-Sud, Orsay *)
(* *)
(**************************************************************************)
(* Generic mapred over Heptagon Ast *)
open Misc
open Heptagon
exception Fall_back
type exp = { e_desc : edesc }
and edesc =
| Econst of static_exp
| Evar of var_ident
| Elast of var_ident
| Epre of static_exp option * exp
| Efby of exp * exp
| Efield of exp * field_name
| Estruct of (field_name * exp) list
| Eapp of app * exp list * exp option
| Eiterator of iterator_type * app * static_exp * exp list * exp option
let exp_it funs acc e =
let ed, acc = funs.edesc_it funs acc e.edesc in
{ e with e_desc = ed }, acc
let edesc_it_default funs acc ed = match ed with
| Econst se -> let se, acc = funs.static_exp_it funs acc se in Econst se, acc
| Evar _ | Elast _ -> ed, acc
| Epre (None, e) -> let e, acc = funs.exp_it funs acc e in Epre (None, e), acc
| Epre (Some se, e) ->
let se, acc = funs.static_exp_it funs acc se in
let e, acc = funs.exp_it funs acc e in Epre (Some se, e), acc
| Efby (e1, e2) ->
let e1, acc = funs.exp_it funs acc e1 in
let e2, acc = funs.exp_it funs acc e2 in Efby (e1,e2), acc
| Efby of exp * exp
| Efield of exp * field_name
| Estruct of (field_name * exp) list
| Eapp of app * exp list * exp option
| Eiterator of iterator_type * app * static_exp * exp list * exp option
let edesc_it funs acc e =
try funs.edesc_it funs acc e
with Fall_back -> edesc_it_default funs acc e
(** const_dec : traverse static_exps *)
let const_it funs acc c =
let se, acc = funs.static_exp_it funs acc c.c_value in
{ c with c_value = se }, acc
and app = { a_op: op; a_params: static_exp list; a_unsafe: bool }
and pat =
| Etuplepat of pat list
| Evarpat of var_ident
type eq = { eq_desc : eqdesc; eq_statefull : bool; eq_loc : location }
and eqdesc =
| Eautomaton of state_handler list
| Eswitch of exp * switch_handler list
| Epresent of present_handler list * block
| Ereset of eq list * exp
| Eeq of pat * exp
and block = {
b_local : var_dec list;
b_equs : eq list;
mutable b_defnames : ty Env.t;
mutable b_statefull : bool;
b_loc : location }
and state_handler = {
s_state : state_name;
s_block : block;
s_until : escape list;
s_unless : escape list }
and escape = {
e_cond : exp;
e_reset : bool;
e_next_state : state_name }
and switch_handler = { w_name : constructor_name; w_block : block }
and present_handler = { p_cond : exp; p_block : block }
and var_dec = {
v_ident : var_ident;
mutable v_type : ty;
v_last : last;
v_loc : location }
and last = Var | Last of static_exp option
type contract = {
c_assume : exp;
c_enforce : exp;
c_local : var_dec list;
c_eq : eq list }
type node_dec = {
n_input : var_dec list;
n_output : var_dec list;
n_local : var_dec list;
n_equs : eq list }
(** const_dec : traverse static_exps *)
let const_it funs acc c =
let se, acc = funs.static_exp_it funs acc c.c_value in
{ c with c_value = se }, acc
(** program : traverse const_dec chained to node_dec *)
let program_it funs acc p =
let cd_list, acc = mapfold (funs.const_it funs) acc p.p_consts in
let nd_list, acc = mapfold (funs.node_it funs) acc p.p_nodes in
{ p with p_consts = cd_list; p_nodes = nd_list }, acc
let hept_mapfolds = { program_it .... }

133
compiler/heptagon/heptagon.ml
View file

@ -15,6 +15,8 @@ open Static
open Signature
open Types
type state_name = name
type iterator_type =
| Imap
| Ifold
@ -24,12 +26,12 @@ type exp = { e_desc : desc; e_ty : ty; e_loc : location }
and desc =
| Econst of static_exp
| Evar of ident
| Elast of ident
| Evar of var_ident
| Elast of var_ident
| Epre of static_exp option * exp
| Efby of exp * exp
| Efield of exp * longname
| Estruct of (longname * exp) list
| Efield of exp * field_name
| Estruct of (field_name * exp) list
| Eapp of app * exp list * exp option
| Eiterator of iterator_type * app * static_exp * exp list * exp option
@ -38,11 +40,11 @@ and app = { a_op: op; a_params: static_exp list; a_unsafe: bool }
and op =
| Etuple
| Efun of longname
| Enode of longname
| Efun of fun_name
| Enode of fun_name
| Eifthenelse
| Earrow
| Efield_update of longname (* field name args would be [record ; value] *)
| Efield_update of field_name (* field name args would be [record ; value] *)
| Earray
| Earray_fill
| Eselect
@ -53,7 +55,7 @@ and op =
and pat =
| Etuplepat of pat list
| Evarpat of ident
| Evarpat of var_ident
type eq = { eq_desc : eqdesc; eq_statefull : bool; eq_loc : location }
@ -65,86 +67,93 @@ and eqdesc =
| Eeq of pat * exp
and block = {
b_local : var_dec list; b_equs : eq list; mutable b_defnames : ty Env.t;
mutable b_statefull : bool; b_loc : location
}
b_local : var_dec list;
b_equs : eq list;
mutable b_defnames : ty Env.t;
mutable b_statefull : bool;
b_loc : location }
and state_handler = {
s_state : name; s_block : block; s_until : escape list;
s_unless : escape list
}
s_state : state_name;
s_block : block;
s_until : escape list;
s_unless : escape list }
and escape = {
e_cond : exp; e_reset : bool; e_next_state : name
}
e_cond : exp;
e_reset : bool;
e_next_state : state_name }
and switch_handler = {
w_name : longname; w_block : block
}
and switch_handler = { w_name : constructor_name; w_block : block }
and present_handler = {
p_cond : exp; p_block : block
}
and present_handler = { p_cond : exp; p_block : block }
and var_dec = {
v_ident : ident; mutable v_type : ty; v_last : last; v_loc : location
}
v_ident : var_ident;
mutable v_type : ty;
v_last : last;
v_loc : location }
and last =
| Var | Last of static_exp option
and last = Var | Last of static_exp option
type type_dec = {
t_name : name; t_desc : type_desc; t_loc : location
}
type type_dec = { t_name : name; t_desc : type_dec_desc; t_loc : location }
and type_desc =
| Type_abs | Type_enum of name list | Type_struct of structure
and type_dec_desc = Type_abs | Type_enum of name list | Type_struct of structure
type contract = {
c_assume : exp; c_enforce : exp; c_controllables : var_dec list;
c_local : var_dec list; c_eq : eq list
}
c_assume : exp;
c_enforce : exp;
c_local : var_dec list;
c_eq : eq list }
type node_dec = {
n_name : name; n_statefull : bool; n_input : var_dec list;
n_output : var_dec list; n_local : var_dec list;
n_contract : contract option; n_equs : eq list; n_loc : location;
n_name : name;
n_statefull : bool;
n_input : var_dec list;
n_output : var_dec list;
n_local : var_dec list;
n_contract : contract option;
n_equs : eq list; n_loc : location;
n_params : param list;
n_params_constraints : size_constraint list
}
n_params_constraints : size_constraint list }
type const_dec = {
c_name : name; c_type : ty; c_value : static_exp; c_loc : location }
c_name : name;
c_type : ty;
c_value : static_exp;
c_loc : location }
type program = {
p_pragmas : (name * string) list; p_opened : name list;
p_types : type_dec list; p_nodes : node_dec list;
p_consts : const_dec list
}
p_opened : name list;
p_types : type_dec list;
p_nodes : node_dec list;
p_consts : const_dec list }
type signature = {
sig_name : name; sig_inputs : arg list; sig_statefull : bool;
sig_outputs : arg list; sig_params : param list
}
sig_name : name;
sig_inputs : arg list;
sig_statefull : bool;
sig_outputs : arg list;
sig_params : param list }
type interface =
interface_decl list
type interface = interface_decl list
and interface_decl = {
interf_desc : interface_desc; interf_loc : location
}
and interface_decl = { interf_desc : interface_desc; interf_loc : location }
and interface_desc =
| Iopen of name | Itypedef of type_dec | Isignature of signature
| Iopen of name
| Itypedef of type_dec
| Isignature of signature
(* Helper functions to create AST. *)
let mk_exp desc ty =
{ e_desc = desc; e_ty = ty; e_loc = no_location; }
let mk_op op = { a_op = op; }
let mk_op ?(params=[]) ?(unsafe=false) op =
{ a_op = op; a_params = params; a_unsafe = unsafe }
let mk_op_desc ln params kind =
{ op_name = ln; op_params = params; op_kind = kind }
let mk_op_app ?(params=[]) ?(unsafe=false) ?(reset=None) op args =
Eapp(mk_op ~params:params ~unsafe:unsafe op, args, reset)
let mk_type_dec name desc =
{ t_name = name; t_desc = desc; t_loc = no_location; }
@ -160,11 +169,15 @@ let mk_block ?(statefull = true) defnames eqs =
{ b_local = []; b_equs = eqs; b_defnames = defnames;
b_statefull = statefull; b_loc = no_location }
let dfalse = mk_exp (Econst (Sconstructor Initial.pfalse)) (Tid Initial.pbool)
let dtrue = mk_exp (Econst (Sconstructor Initial.ptrue)) (Tid Initial.pbool)
let dfalse =
mk_exp (Econst (mk_static_exp (Sconstructor Initial.pfalse)))
(Tid Initial.pbool)
let dtrue =
mk_exp (Econst (mk_static_exp (Sconstructor Initial.ptrue)))
(Tid Initial.pbool)
let mk_ifthenelse e1 e2 e3 =
{ e3 with e_desc = Eapp(mk_op Eifthenelse, [e1; e2; e3]) }
{ e3 with e_desc = mk_op_app Eifthenelse [e1; e2; e3] }
let mk_simple_equation pat e =
mk_equation ~statefull:false (Eeq(pat, e))
@ -175,7 +188,7 @@ let mk_switch_equation ?(statefull = true) e l =
(** @return a size exp operator from a Heptagon operator. *)
let op_from_app app =
match app.a_op with
| Ecall ( { op_name = op; op_kind = Efun }, _) -> op_from_app_name op
| Efun op -> op_from_app_name op
| _ -> raise Not_static
(** Translates a Heptagon exp into a static size exp. *)

113
compiler/minils/minils.ml
View file

@ -21,36 +21,36 @@ type iterator_type =
| Ifold
| Imapfold
type type_dec =
{ t_name: name;
t_desc: tdesc;
t_loc: location }
type type_dec = {
t_name: name;
t_desc: tdesc;
t_loc: location }
and tdesc =
| Type_abs
| Type_enum of name list
| Type_struct of structure
and exp =
{ e_desc: edesc;
mutable e_ck: ck;
mutable e_ty: ty;
e_loc: location }
and exp = {
e_desc: edesc;
mutable e_ck: ck;
mutable e_ty: ty;
e_loc: location }
and edesc =
| Econst of static_exp
| Evar of ident
| Evar of var_ident
| Efby of static_exp option * exp
(** static_exp fby exp *)
| Eapp of app * exp list * ident option
| Eapp of app * exp list * var_ident option
(** app ~args=(exp,exp...) reset ~r=ident *)
| Ewhen of exp * longname * ident
| Ewhen of exp * constructor_name * var_ident
(** exp when Constructor(ident) *)
| Emerge of ident * (longname * exp) list
| Emerge of var_ident * (constructor_name * exp) list
(** merge ident (Constructor -> exp)+ *)
| Estruct of (longname * exp) list
| Estruct of (field_name * exp) list
(** { field=exp; ... } *)
| Eiterator of iterator_type * app * static_exp * exp list * ident option
| Eiterator of iterator_type * app * static_exp * exp list * var_ident option
(** map f <<n>> (exp,exp...) reset ident *)
and app = { a_op: op; a_params: static_exp list; a_unsafe: bool }
@ -59,8 +59,8 @@ and app = { a_op: op; a_params: static_exp list; a_unsafe: bool }
and op =
| Etuple (** (args) *)
| Efun of longname (** "Stateless" longname <<a_params>> (args) reset r *)
| Enode of longname (** "Stateful" longname <<a_params>> (args) reset r *)
| Efun of fun_name (** "Stateless" longname <<a_params>> (args) reset r *)
| Enode of fun_name (** "Stateful" longname <<a_params>> (args) reset r *)
| Eifthenelse (** if arg1 then arg2 else arg3 *)
| Efield (** arg1.a_param1 *)
| Efield_update (** { arg1 with a_param1 = arg2 } *)
@ -79,7 +79,7 @@ and ct =
and ck =
| Cbase
| Cvar of link ref
| Con of ck * longname * ident
| Con of ck * constructor_name * var_ident
and link =
| Cindex of int
@ -87,50 +87,46 @@ and link =
and pat =
| Etuplepat of pat list
| Evarpat of ident
| Evarpat of var_ident
type eq =
{ eq_lhs : pat;
eq_rhs : exp;
eq_loc : location }
type eq = {
eq_lhs : pat;
eq_rhs : exp;
eq_loc : location }
type var_dec =
{ v_ident : ident;
v_type : ty;
v_clock : ck }
type var_dec = {
v_ident : var_ident;
v_type : ty;
v_clock : ck }
type contract =
{ c_assume : exp;
c_enforce : exp;
c_controllables : var_dec list;
c_local : var_dec list;
c_eq : eq list }
type contract = {
c_assume : exp;
c_enforce : exp;
c_local : var_dec list;
c_eq : eq list }
type node_dec =
{ n_name : name;
n_input : var_dec list;
n_output : var_dec list;
n_contract : contract option;
n_local : var_dec list;
n_equs : eq list;
n_loc : location;
n_params : param list;
n_params_constraints : size_constraint list;
n_params_instances : (int list) list; }(*TODO commenter ou passer en env*)
type const_dec =
{ c_name : name;
c_value : static_exp;
c_loc : location }
type program =
{ p_pragmas: (name * string) list;
p_opened : name list;
p_types : type_dec list;
p_nodes : node_dec list;
p_consts : const_dec list }
type node_dec = {
n_name : name;
n_input : var_dec list;
n_output : var_dec list;
n_contract : contract option;
n_local : var_dec list;
n_equs : eq list;
n_loc : location;
n_params : param list; (** TODO CP mettre des petits commentaires *)
n_params_constraints : size_constr list;
n_params_instances : (static_exp list) list }
type const_dec = {
c_name : name;
c_value : static_exp;
c_loc : location }
type program = {
p_opened : name list;
p_types : type_dec list;
p_nodes : node_dec list;
p_consts : const_dec list }
(*Helper functions to build the AST*)
@ -138,8 +134,7 @@ let mk_exp ?(exp_ty = Tprod []) ?(clock = Cbase) ?(loc = no_location) desc =
{ e_desc = desc; e_ty = exp_ty; e_ck = clock; e_loc = loc }
let mk_var_dec ?(clock = Cbase) ident ty =
{ v_ident = ident; v_type = ty;
v_clock = clock }
{ v_ident = ident; v_type = ty; v_clock = clock }
let mk_equation ?(loc = no_location) pat exp =
{ eq_lhs = pat; eq_rhs = exp; eq_loc = loc }
@ -159,7 +154,7 @@ let mk_node
n_params_instances = pinst; }
let mk_type_dec ?(type_desc = Type_abs) ?(loc = no_location) name =
{ t_name = name; t_desc = type_desc; t_loc = loc }
t_name = name; t_desc = type_desc; t_loc = loc }
let mk_op ?(op_params = []) ?(op_kind = Enode) lname =
{ op_name = lname; op_params = op_params; op_kind = op_kind }

4
compiler/obc/java/java.ml
View file

@ -164,8 +164,8 @@ let print_types java_dir headers tps =
(******************************)
type answer =
| Sing of var_name
| Mult of var_name list
| Sing of var_ident
| Mult of var_ident list
let print_const ff c ts =
match c with

42
compiler/obc/obc.ml
View file

@ -13,33 +13,31 @@ open Names
open Ident
open Types
type var_name = ident
type type_name = longname
type fun_name = longname
type class_name = name
type instance_name = longname
type obj_name = name
type op_name = longname
type field_name = longname
type type_dec =
{ t_name : name;
t_desc : tdesc }
t_desc : tdesc;
t_loc : loc }
and tdesc =
| Type_abs
| Type_enum of name list
| Type_struct of (name * ty) list
type lhs = { l_desc : lhs_desc; l_ty : ty }
type lhs = { l_desc : lhs_desc; l_ty : ty; l_loc : loc }
and lhs_desc =
| Lvar of var_name
| Lmem of var_name
| Lvar of var_ident
| Lmem of var_ident
| Lfield of lhs * field_name
| Larray of lhs * exp
and exp = { e_desc : exp_desc; e_ty : ty }
and exp = { e_desc : exp_desc; e_ty : ty; e_loc : loc }
and exp_desc =
| Elhs of lhs
@ -55,24 +53,26 @@ type obj_call =
type method_name =
| Mreset
| Mstep
| Mother of name
| Mmethod of name
type act =
| Aassgn of lhs * exp
| Acall of lhs list * obj_call * method_name * exp list
| Acase of exp * (longname * block) list
| Afor of var_name * static_exp * static_exp * block
| Acase of exp * (constructor_name * block) list
| Afor of var_ident * static_exp * static_exp * block
and block = act list
type var_dec =
{ v_ident : var_name;
v_type : ty; (*v_controllable : bool*) }
{ v_ident : var_ident;
v_type : ty; (* TODO should be here, v_controllable : bool*)
v_loc : loc }
type obj_dec =
{ o_name : obj_name;
o_class : instance_name;
o_size : static_exp; }
o_size : static_exp;
o_loc : loc }
type method_def =
{ f_name : fun_name;
@ -85,11 +85,11 @@ type class_def =
{ c_name : class_name;
c_mems : var_dec list;
c_objs : obj_dec list;
c_methods: method_def list; }
c_methods: method_def list;
c_loc : loc }
type program =
{ p_pragmas: (name * string) list;
p_opened : name list;
{ p_opened : name list;
p_types : type_dec list;
p_defs : class_def list }
@ -102,12 +102,12 @@ let mk_exp ?(ty=invalid_type) desc =
let mk_lhs ?(ty=invalid_type) desc =
{ l_desc = desc; l_ty = ty }
let rec var_name x =
let rec var_ident x =
match x with
| Lvar x -> x
| Lmem x -> x
| Lfield(x,_) -> var_name x
| Larray(l, _) -> var_name l
| Lfield(x,_) -> var_ident x
| Larray(l, _) -> var_ident l
(** Returns whether an object of name n belongs to
a list of var_dec. *)

7
compiler/utilities/misc.ml
View file

@ -192,3 +192,10 @@ let rec assocd value = function
k
else
assocd value l
(** Mapfold *)
let mapfold f acc l =
let l,acc = List.fold_left (fun (l,acc) e -> let e,acc = f acc e in e::l, acc)
([],acc) l in
List.rev l, acc

2
compiler/utilities/misc.mli
View file

@ -153,3 +153,5 @@ val memd_assoc : 'b -> ('a * 'b) list -> bool
(** Same as List.assoc but searching for a data and returning the key. *)
val assocd: 'b -> ('a * 'b) list -> 'a
(** Mapfold *)
val mapfold: ('a -> 'b -> 'c * 'a) -> 'a -> 'b list -> 'c list * 'a