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

mapfold over var_ident.

Browse source
This commit is contained in:
Léonard Gérard 2011-11-14 15:29:31 +01:00
parent d5858d6dd2
commit bdd85f5f81
4 changed files with 90 additions and 35 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

30
compiler/global/global_mapfold.ml
View file

@ -1,16 +1,18 @@
open Misc
open Errors
open Types
(*open Clocks*)
open Signature
open Clocks
open Idents
type 'a global_it_funs = {
static_exp : 'a global_it_funs -> 'a -> static_exp -> static_exp * 'a;
static_exp_desc : 'a global_it_funs -> 'a -> static_exp_desc -> static_exp_desc * 'a;
ty : 'a global_it_funs -> 'a -> ty -> ty * 'a;
(* ct : 'a global_it_funs -> 'a -> ct -> ct * 'a;
ct : 'a global_it_funs -> 'a -> ct -> ct * 'a;
ck : 'a global_it_funs -> 'a -> ck -> ck * 'a;
link : 'a global_it_funs -> 'a -> link -> link * 'a; *)
link : 'a global_it_funs -> 'a -> link -> link * 'a;
var_ident : 'a global_it_funs -> 'a -> var_ident -> var_ident * 'a;
param : 'a global_it_funs -> 'a -> param -> param * 'a;
arg : 'a global_it_funs -> 'a -> arg -> arg * 'a;
node : 'a global_it_funs -> 'a -> node -> node * 'a;
@ -58,8 +60,8 @@ and ty funs acc t = match t with
let se, acc = static_exp_it funs acc se in
Tarray (t, se), acc
| Tinvalid -> t, acc
(*
and ct_it funs acc c = try funs.ct funs acc c with Fallback -> ct funs acc t
and ct_it funs acc c = try funs.ct funs acc c with Fallback -> ct funs acc c
and ct funs acc c = match c with
| Ck(ck) -> let ck, acc = ck_it funs acc ck in Ck ck, acc
| Cprod(ct_l) ->
@ -71,16 +73,20 @@ and ck funs acc c = match c with
| Cvar(link_ref) ->
let l, acc = link_it funs acc link_ref.contents in
Cvar {link_ref with contents = l}, acc
| Con(ck, constructor_name, var_ident) ->
| Con(ck, constructor_name, v) ->
let ck, acc = ck_it funs acc ck in
Con (ck, constructor_name, var_ident), acc
let v, acc = var_ident_it funs acc v in
Con (ck, constructor_name, v), acc
and link_it funs acc c =
try funs.link funs acc c with Fallback -> link funs acc c
and link funs acc l = match l with
| Cindex _ -> l, acc
| Clink(ck) -> let ck, acc = ck_it funs acc ck in Clink ck, acc
*)
and var_ident_it funs acc i = funs.var_ident funs acc i
and var_ident funs acc i = i, acc
and structure_it funs acc s = funs.structure funs acc s
and structure funs acc s =
@ -118,6 +124,10 @@ let defaults = {
static_exp = static_exp;
static_exp_desc = static_exp_desc;
ty = ty;
ct = ct;
ck = ck;
link = link;
var_ident = var_ident;
structure = structure;
field = field;
param = param;
@ -133,6 +143,10 @@ let defaults_stop = {
static_exp = stop;
static_exp_desc = stop;
ty = stop;
ct = stop;
ck = stop;
link = stop;
var_ident = stop;
structure = stop;
field = stop;
param = stop;

27
compiler/heptagon/hept_mapfold.ml
View file

@ -80,7 +80,9 @@ let rec exp_it funs acc e = funs.exp funs acc e
and exp funs acc e =
let e_desc, acc = edesc_it funs acc e.e_desc in
let e_ty, acc = ty_it funs.global_funs acc e.e_ty in
{ e with e_desc = e_desc; e_ty = e_ty }, acc
let e_ct_annot, acc = optional_wacc (ct_it funs.global_funs) acc e.e_ct_annot in
let e_level_ck, acc = ck_it funs.global_funs acc e.e_level_ck in
{ e with e_desc = e_desc; e_ty = e_ty; e_ct_annot = e_ct_annot; e_level_ck = e_level_ck }, acc
and edesc_it funs acc ed =
try funs.edesc funs acc ed
@ -89,7 +91,12 @@ and edesc funs acc ed = match ed with
| Econst se ->
let se, acc = static_exp_it funs.global_funs acc se in
Econst se, acc
| Evar _ | Elast _ -> ed, acc
| Evar v ->
let v, acc = var_ident_it funs.global_funs acc v in
Evar v, acc
| Elast v ->
let v, acc = var_ident_it funs.global_funs acc v in
Elast v, acc
| Epre (se, e) ->
let se, acc = optional_wacc (static_exp_it funs.global_funs) acc se in
let e, acc = exp_it funs acc e in
@ -118,11 +125,14 @@ and edesc funs acc ed = match ed with
Eiterator (i, app, params, pargs, args, reset), acc
| Ewhen (e, c, n) ->
let e, acc = exp_it funs acc e in
let n, acc = var_ident_it funs.global_funs acc n in
Ewhen (e, c, n), acc
| Emerge (n, c_e_list) ->
let n, acc = var_ident_it funs.global_funs acc n in
let aux acc (c,e) =
let e, acc = exp_it funs acc e in
(c,e), acc in
(c,e), acc
in
let c_e_list, acc = mapfold aux acc c_e_list in
Emerge (n, c_e_list), acc
| Esplit (e1, e2) ->
@ -130,7 +140,6 @@ and edesc funs acc ed = match ed with
let e2, acc = exp_it funs acc e2 in
Esplit(e1, e2), acc
and app_it funs acc a = funs.app funs acc a
and app funs acc a =
let p, acc = mapfold (static_exp_it funs.global_funs) acc a.a_params in
@ -144,7 +153,9 @@ and pat funs acc p = match p with
| Etuplepat pl ->
let pl, acc = mapfold (pat_it funs) acc pl in
Etuplepat pl, acc
| Evarpat _ -> p, acc
| Evarpat v ->
let v, acc = var_ident_it funs.global_funs acc v in
Evarpat v, acc
and eq_it funs acc eq = funs.eq funs acc eq
@ -221,9 +232,11 @@ and present_handler funs acc ph =
and var_dec_it funs acc vd = funs.var_dec funs acc vd
and var_dec funs acc vd =
(* TODO v_type ??? *)
let v_type, acc = ty_it funs.global_funs acc vd.v_type in
let v, acc = var_ident_it funs.global_funs acc vd.v_ident in
let v_clock, acc = ck_it funs.global_funs acc vd.v_clock in
let v_last, acc = last_it funs acc vd.v_last in
{ vd with v_last = v_last }, acc
{ vd with v_last = v_last; v_type = v_type; v_clock = v_clock; v_ident = v }, acc
and last_it funs acc l =

42
compiler/minils/mls_mapfold.ml
View file

@ -40,14 +40,19 @@ type 'a mls_it_funs = {
let rec exp_it funs acc e = funs.exp funs acc e
and exp funs acc e =
let e_ty, acc = ty_it funs.global_funs acc e.e_ty in
let e_level_ck, acc = ck_it funs.global_funs acc e.e_level_ck in
let e_base_ck, acc = ck_it funs.global_funs acc e.e_base_ck in
let e_ct, acc = ct_it funs.global_funs acc e.e_ct in
let ed, acc = edesc_it funs acc e.e_desc in
{ e with e_desc = ed; e_ty = e_ty }, acc
{ e with e_desc = ed; e_ty = e_ty; e_level_ck = e_level_ck;
e_base_ck = e_base_ck; e_ct = e_ct }, acc
and extvalue_it funs acc w = funs.extvalue funs acc w
and extvalue funs acc w =
let w_ty, acc = ty_it funs.global_funs acc w.w_ty in
let w_ck, acc = ck_it funs.global_funs acc w.w_ck in
let wd, acc = extvalue_desc_it funs acc w.w_desc in
{ w with w_desc = wd; w_ty = w_ty }, acc
{ w with w_desc = wd; w_ty = w_ty; w_ck = w_ck }, acc
and extvalue_desc_it funs acc wd =
try funs.extvalue_desc funs acc wd
@ -56,12 +61,15 @@ and extvalue_desc funs acc wd = match wd with
| Wconst se ->
let se, acc = static_exp_it funs.global_funs acc se in
Wconst se, acc
| Wvar _ -> wd, acc
| Wvar v ->
let v, acc = var_ident_it funs.global_funs acc v in
Wvar v, acc
| Wfield (w,f) ->
let w, acc = extvalue_it funs acc w in
Wfield (w,f), acc
| Wwhen (w, c, v) ->
let w, acc = extvalue_it funs acc w in
let v, acc = var_ident_it funs.global_funs acc v in
Wwhen (w,c,v), acc
| Wreinit (w1, w2) ->
let w1, acc = extvalue_it funs acc w1 in
@ -78,32 +86,38 @@ and edesc funs acc ed = match ed with
| Efby (se, w) ->
let se, acc = optional_wacc (static_exp_it funs.global_funs) acc se in
let w, acc = extvalue_it funs acc w in
Efby (se, w), acc
Efby (se, w), acc
| Eapp(app, args, reset) ->
let app, acc = app_it funs acc app in
let args, acc = mapfold (extvalue_it funs) acc args in
Eapp (app, args, reset), acc
let reset, acc = optional_wacc (var_ident_it funs.global_funs) acc reset in
Eapp (app, args, reset), acc
| Emerge(x, c_w_list) ->
let aux acc (c,w) =
let w, acc = extvalue_it funs acc w in
(c,w), acc in
(c,w), acc
in
let c_w_list, acc = mapfold aux acc c_w_list in
Emerge(x, c_w_list), acc
let x, acc = var_ident_it funs.global_funs acc x in
Emerge(x, c_w_list), acc
| Ewhen(e,c,x) ->
let e, acc = exp_it funs acc e in
let x, acc = var_ident_it funs.global_funs acc x in
Ewhen(e,c,x), acc
| Estruct n_w_list ->
let aux acc (n,w) =
let w, acc = extvalue_it funs acc w in
(n,w), acc in
(n,w), acc
in
let n_w_list, acc = mapfold aux acc n_w_list in
Estruct n_w_list, acc
Estruct n_w_list, acc
| Eiterator (i, app, params, pargs, args, reset) ->
let app, acc = app_it funs acc app in
let params, acc = mapfold (static_exp_it funs.global_funs) acc params in
let pargs, acc = mapfold (extvalue_it funs) acc pargs in
let args, acc = mapfold (extvalue_it funs) acc args in
Eiterator (i, app, params, pargs, args, reset), acc
let reset, acc = optional_wacc (var_ident_it funs.global_funs) acc reset in
Eiterator (i, app, params, pargs, args, reset), acc
and app_it funs acc a = funs.app funs acc a
@ -119,7 +133,9 @@ and pat funs acc p = match p with
| Etuplepat pl ->
let pl, acc = mapfold (pat_it funs) acc pl in
Etuplepat pl, acc
| Evarpat _ -> p, acc
| Evarpat v ->
let v, acc = var_ident_it funs.global_funs acc v in
Evarpat v, acc
and eq_it funs acc eq = funs.eq funs acc eq
@ -135,7 +151,9 @@ and eqs funs acc eqs = mapfold (eq_it funs) acc eqs
and var_dec_it funs acc vd = funs.var_dec funs acc vd
and var_dec funs acc vd =
let v_type, acc = ty_it funs.global_funs acc vd.v_type in
{ vd with v_type = v_type }, acc
let v, acc = var_ident_it funs.global_funs acc vd.v_ident in
let v_clock, acc = ck_it funs.global_funs acc vd.v_clock in
{ vd with v_type = v_type; v_clock = v_clock; v_ident = v }, acc
and var_decs_it funs acc vds = funs.var_decs funs acc vds
and var_decs funs acc vds = mapfold (var_dec_it funs) acc vds

26
compiler/obc/obc_mapfold.ml
View file

@ -75,15 +75,19 @@ and lhsdesc_it funs acc ld =
try funs.lhsdesc funs acc ld
with Fallback -> lhsdesc funs acc ld
and lhsdesc funs acc ld = match ld with
| Lvar x -> Lvar x, acc
| Lmem x -> Lmem x, acc
| Lvar x ->
let x, acc = var_ident_it funs.global_funs acc x in
Lvar x, acc
| Lmem x ->
let x, acc = var_ident_it funs.global_funs acc x in
Lmem x, acc
| Lfield(lhs, f) ->
let lhs, acc = lhs_it funs acc lhs in
Lfield(lhs, f), acc
Lfield(lhs, f), acc
| Larray(lhs, e) ->
let lhs, acc = lhs_it funs acc lhs in
let e, acc = exp_it funs acc e in
Larray(lhs, e), acc
Larray(lhs, e), acc
and extvalue_it funs acc w = funs.extvalue funs acc w
and extvalue funs acc w =
@ -92,11 +96,15 @@ and extvalue funs acc w =
and evdesc_it funs acc wd = funs.evdesc funs acc wd
and evdesc funs acc wd = match wd with
| Wvar x -> Wvar x, acc
| Wvar x ->
let x, acc = var_ident_it funs.global_funs acc x in
Wvar x, acc
| Wconst c ->
let c, acc = static_exp_it funs.global_funs acc c in
Wconst c, acc
| Wmem x -> Wmem x, acc
| Wmem x ->
let x, acc = var_ident_it funs.global_funs acc x in
Wmem x, acc
| Wfield(w, f) ->
let w, acc = extvalue_it funs acc w in
Wfield(w, f), acc
@ -145,7 +153,8 @@ and block funs acc b =
and var_dec_it funs acc vd = funs.var_dec funs acc vd
and var_dec funs acc vd =
let v_type, acc = ty_it funs.global_funs acc vd.v_type in
{ vd with v_type = v_type }, acc
let v, acc = var_ident_it funs.global_funs acc vd.v_ident in
{ vd with v_type = v_type; v_ident = v }, acc
and var_decs_it funs acc vds = funs.var_decs funs acc vds
and var_decs funs acc vds = mapfold (var_dec_it funs) acc vds
@ -155,7 +164,8 @@ and obj_dec_it funs acc od = funs.obj_dec funs acc od
and obj_dec funs acc od =
let o_size, acc = optional_wacc
(mapfold (static_exp_it funs.global_funs)) acc od.o_size in
{ od with o_size = o_size }, acc
let v, acc = var_ident_it funs.global_funs acc od.o_ident in
{ od with o_size = o_size; o_ident = v }, acc
and obj_decs_it funs acc ods = funs.obj_decs funs acc ods
and obj_decs funs acc ods = mapfold (obj_dec_it funs) acc ods