1 files changed, 164 insertions, 0 deletions
diff --git a/minijazz/src/global/mapfold.ml b/minijazz/src/global/mapfold.ml
new file mode 100644
index 0000000..50ffbaf
--- /dev/null
+++ b/minijazz/src/global/mapfold.ml
@@ -0,0 +1,164 @@
+open Ast
+open Static
+open Misc
+
+exception Fallback
+
+type 'a it_funs = {
+  static_exp : 'a it_funs -> 'a -> static_exp -> static_exp * 'a;
+  static_exp_desc : 'a it_funs -> 'a -> static_exp_desc -> static_exp_desc * 'a;
+  ty : 'a it_funs -> 'a -> ty -> ty * 'a;
+  link : 'a it_funs -> 'a -> link -> link * 'a;
+  edesc : 'a it_funs -> 'a -> edesc -> edesc * 'a;
+  exp : 'a it_funs -> 'a -> exp -> exp * 'a;
+  pat : 'a it_funs -> 'a -> pat -> pat * 'a;
+  equation : 'a it_funs -> 'a -> equation -> equation * 'a;
+  var_dec : 'a it_funs -> 'a -> var_dec -> var_dec * 'a;
+  block : 'a it_funs -> 'a -> block -> block * 'a;
+  node_dec : 'a it_funs -> 'a -> node_dec -> node_dec * 'a;
+  const_dec : 'a it_funs -> 'a -> const_dec -> const_dec * 'a;
+  program : 'a it_funs -> 'a -> program -> program * 'a;
+}
+
+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 acc e.e_ty in
+  { e with e_desc = e_desc; e_ty = e_ty }, acc
+
+and edesc_it funs acc ed =
+  try funs.edesc funs acc ed
+  with Fallback -> edesc funs acc ed
+and edesc funs acc ed = match ed with
+  | Econst v -> Econst v, acc
+  | Evar id -> Evar id, acc
+  | Ereg e ->
+      let e, acc = exp_it funs acc e in
+      Ereg e, acc
+  | Emem(k, addr_size, word_size, s, args) ->
+      let addr_size, acc = static_exp_it funs acc addr_size in
+      let word_size, acc = static_exp_it funs acc word_size in
+      let args, acc = mapfold (exp_it funs) acc args in
+      Emem(k, addr_size, word_size, s, args), acc
+  | Ecall(id, params, args) ->
+      let params, acc = mapfold (static_exp_it funs) acc params in
+      let args, acc = mapfold (exp_it funs) acc args in
+      Ecall(id, params, args), acc
+
+and static_exp_it funs acc sd =
+  try funs.static_exp funs acc sd
+  with Fallback -> static_exp funs acc sd
+and static_exp funs acc se =
+  let se_desc, acc = static_exp_desc_it funs acc se.se_desc in
+  { se with se_desc = se_desc }, acc
+
+and static_exp_desc_it funs acc sed =
+  try funs.static_exp_desc funs acc sed
+  with Fallback -> static_exp_desc funs acc sed
+and static_exp_desc funs acc sed = match sed with
+  | SInt _ | SBool _ | SVar _ -> sed, acc
+  | SBinOp (sop, se1, se2) ->
+      let se1, acc = static_exp_it funs acc se1 in
+      let se2, acc = static_exp_it funs acc se2 in
+      SBinOp(sop, se1, se2), acc
+  | SIf(c, se1, se2) ->
+      let c, acc = static_exp_it funs acc c in
+      let se1, acc = static_exp_it funs acc se1 in
+      let se2, acc = static_exp_it funs acc se2 in
+      SIf(c, se1, se2), acc
+
+and ty_it funs acc t = try funs.ty funs acc t with Fallback -> ty funs acc t
+and ty funs acc t = match t with
+  | TUnit | TBit -> t, acc
+  | TBitArray se ->
+      let se, acc = static_exp_it funs acc se in
+      TBitArray se, acc
+  | TProd t_l ->
+      let t_l, acc = mapfold (ty_it funs) acc t_l in
+      TProd t_l, acc
+  | TVar link ->
+      let link_v, acc = link_it funs acc !link in
+      link := link_v;
+      TVar link, 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
+  | TIndex _ -> l, acc
+  | TLink ty ->
+      let ty, acc = ty_it funs acc ty in
+      TLink ty, acc
+
+and pat_it funs acc p =
+  try funs.pat funs acc p
+  with Fallback -> pat funs acc p
+and pat funs acc p = p, acc
+
+and equation_it funs acc eq = funs.equation funs acc eq
+and equation funs acc (pat, e) =
+  let pat, acc = pat_it funs acc pat in
+  let e, acc = exp_it funs acc e in
+  (pat, e), acc
+
+and block_it funs acc b =
+  try funs.block funs acc b
+  with Fallback -> block funs acc b
+and block funs acc b = match b with
+  | BEqs(eqs, vds) ->
+      let vds, acc = mapfold (var_dec_it funs) acc vds in
+      let eqs, acc = mapfold (equation_it funs) acc eqs in
+      BEqs (eqs, vds), acc
+  | BIf(se, b1, b2) ->
+      let se, acc = static_exp_it funs acc se in
+      let b1, acc = block_it funs acc b1 in
+      let b2, acc = block_it funs acc b2 in
+      BIf(se, b1, b2), acc
+
+and var_dec_it funs acc vd = funs.var_dec funs acc vd
+and var_dec funs acc vd =
+  let v_ty, acc = ty_it funs acc vd.v_ty in
+  { vd with v_ty = v_ty }, acc
+
+
+and node_dec_it funs acc nd = funs.node_dec funs acc nd
+and node_dec funs acc nd =
+  let n_inputs, acc = mapfold (var_dec_it funs) acc nd.n_inputs in
+  let n_outputs, acc = mapfold (var_dec_it funs) acc nd.n_outputs in
+  let n_constraints, acc = mapfold (static_exp_it funs) acc nd.n_constraints in
+  let n_body, acc = block_it funs acc nd.n_body in
+  { nd with
+      n_inputs = n_inputs;
+      n_outputs = n_outputs;
+      n_body = n_body;
+      n_constraints = n_constraints }
+  , acc
+
+
+and const_dec_it funs acc c = funs.const_dec funs acc c
+and const_dec funs acc c =
+  let c_value, acc = static_exp_it funs acc c.c_value in
+  { c with c_value = c_value }, acc
+
+and program_it funs acc p = funs.program funs acc p
+and program funs acc p =
+  let p_consts, acc = mapfold (const_dec_it funs) acc p.p_consts in
+  let p_nodes, acc = mapfold (node_dec_it funs) acc p.p_nodes in
+  { p_nodes = p_nodes; p_consts = p_consts }, acc
+
+
+let defaults = {
+  static_exp = static_exp;
+  static_exp_desc = static_exp_desc;
+  ty = ty;
+  link = link;
+  edesc = edesc;
+  exp = exp;
+  pat = pat;
+  equation = equation;
+  var_dec = var_dec;
+  block = block;
+  node_dec = node_dec;
+  const_dec = const_dec;
+  program = program;
+}