5.9. Mappings

Start ocaml section to src/flx_maps.mli[1 /1 ]
     1: # 1239 "./lpsrc/flx_types.ipk"
     2: open Flx_ast
     3: open Flx_types
     4: 
     5: val map_type:
     6:   (typecode_t -> typecode_t) -> typecode_t -> typecode_t
     7: 
     8: val map_b0type:
     9:   (b0typecode_t -> b0typecode_t) -> b0typecode_t -> b0typecode_t
    10: 
    11: val map_btype:
    12:   (btypecode_t -> btypecode_t) -> btypecode_t -> btypecode_t
    13: 
    14: val iter_b0type:
    15:   (b0typecode_t -> unit) -> b0typecode_t -> unit
    16: 
    17: val iter_btype:
    18:   (btypecode_t -> unit) -> btypecode_t -> unit
    19: 
    20: val iter_tbexpr:
    21:   (bid_t -> unit) ->
    22:   (tbexpr_t -> unit) ->
    23:   (btypecode_t -> unit) ->
    24:   tbexpr_t -> unit
    25: 
    26: val map_expr:
    27:   (expr_t -> expr_t) ->
    28:   expr_t ->
    29:   expr_t
    30: 
    31: val map_tbexpr:
    32:   (bid_t -> bid_t) ->
    33:   (tbexpr_t -> tbexpr_t) ->
    34:   (btypecode_t -> btypecode_t) ->
    35:   tbexpr_t -> tbexpr_t
    36: 
    37: val iter_bexe:
    38:   (bid_t -> unit) ->
    39:   (tbexpr_t -> unit) ->
    40:   (btypecode_t -> unit) ->
    41:   (string -> unit) ->
    42:   (string -> unit) ->
    43:   bexe_t -> unit
    44: 
    45: val map_bexe:
    46:   (bid_t -> bid_t) ->
    47:   (tbexpr_t -> tbexpr_t) ->
    48:   (btypecode_t -> btypecode_t) ->
    49:   (string -> string) ->
    50:   (string -> string) ->
    51:   bexe_t -> bexe_t
    52: 
    53: val reduce_tbexpr:
    54:   fully_bound_symbol_table_t ->
    55:   tbexpr_t -> tbexpr_t
    56: 
    57: val reduce_bexe:
    58:   fully_bound_symbol_table_t ->
    59:   bexe_t -> bexe_t
    60: 
    61: val reduce_type:
    62:   btypecode_t ->
    63:   btypecode_t
    64: 
    65: val scan_expr: expr_t -> range_srcref list
    66: 
End ocaml section to src/flx_maps.mli[1]
Start ocaml section to src/flx_maps.ml[1 /1 ]
     1: # 1306 "./lpsrc/flx_types.ipk"
     2: open Flx_ast
     3: open Flx_types
     4: open List
     5: open Flx_typing
     6: 
     7: let rec list_of_n_things thing lst n =
     8:   if n = 0 then lst
     9:   else list_of_n_things thing (thing::lst) (n-1)
    10: 
    11: let map_type f (t:typecode_t):typecode_t = match t with
    12:   | `AST_name (sr,name,ts) -> `AST_name (sr,name, map f ts)
    13:   | `AST_lookup (sr,(e,name,ts)) -> `AST_lookup (sr,(e,name,map f ts))
    14:   | `AST_suffix (sr,(qn,t)) -> `AST_suffix (sr,(qn, f t))
    15: 
    16:   | `AST_typed_case (sr,i,t) -> `AST_typed_case (sr,i, f t)
    17:   | `TYP_tuple ts -> `TYP_tuple (map f ts)
    18:   | `TYP_record ts -> `TYP_record (map (fun (s,t) -> s,f t) ts)
    19:   | `TYP_variant ts -> `TYP_variant (map (fun (s,t) -> s,f t) ts)
    20:   | `TYP_isin (a,b) -> `TYP_isin (f a, f b)
    21: 
    22:   (* we have to do this, so that a large unitsume
    23:      can be specified without overflowing the compiler
    24:      storage
    25:   *)
    26:   | `TYP_unitsum k ->
    27:     if k>0 then
    28:       let mapped_unit = f (`TYP_tuple []) in
    29:       match mapped_unit with
    30:       | `TYP_tuple [] ->
    31:         `TYP_unitsum k
    32:       | _ -> `TYP_tuple ( list_of_n_things mapped_unit [] k)
    33:     else `TYP_unitsum k
    34: 
    35:   (* here we don't need to go to a unitsum, since
    36:      we have already used up storage
    37:   *)
    38:   | `TYP_sum ts -> `TYP_sum (map f ts)
    39:   | `TYP_intersect ts -> `TYP_intersect (map f ts)
    40:   | `TYP_function (a,b) -> `TYP_function (f a, f b)
    41:   | `TYP_cfunction (a,b) -> `TYP_cfunction (f a, f b)
    42:   | `TYP_pointer t -> `TYP_pointer (f t)
    43:   | `TYP_lvalue t -> `TYP_lvalue (f t)
    44:   | `TYP_array (t1, t2) -> `TYP_array (f t1, f t2)
    45:   | `TYP_as (t,s) -> `TYP_as (f t,s)
    46: 
    47:   (* type sets *)
    48:   | `TYP_typeset ts -> `TYP_typeset (map f ts)
    49:   | `TYP_setintersection ts -> `TYP_setintersection (map f ts)
    50:   | `TYP_setunion ts -> `TYP_setunion (map f ts)
    51: 
    52:   (* destructors *)
    53:   | `TYP_dom t -> `TYP_dom (f t)
    54:   | `TYP_dual t -> `TYP_dual (f t)
    55:   | `TYP_cod t -> `TYP_cod (f t)
    56:   | `TYP_proj (i,t) -> `TYP_proj (i, f t)
    57:   | `TYP_case_arg (i,t) -> `TYP_case_arg (i, f t)
    58:   | `TYP_case (t1,ls,t2) -> `TYP_case (f t1, ls, f t2)
    59: 
    60:   (*
    61:   | `TYP_type_match (t,ps) ->
    62:     let ps = map (fun (p,t) -> p, f t) ps in
    63:     `TYP_type_match (f t, ps)
    64:   *)
    65:   | `TYP_type_match (t,ps) ->
    66:     let ps = map (fun (p,t) -> f p, f t) ps in
    67:     `TYP_type_match (f t, ps)
    68: 
    69:   (* meta constructors *)
    70:   | `TYP_apply (a,b) -> `TYP_apply (f a, f b)
    71:   | `TYP_typefun (ps, a, b) -> `TYP_typefun (ps, f a, f b)
    72:   | `TYP_type_tuple ts -> `TYP_type_tuple (map f ts)
    73:   | `TYP_lift t -> `TYP_lift (f t)
    74: 
    75: 
    76:   (* invariant ..?? *)
    77:   | `TYP_typeof _
    78:   | `AST_callback _
    79:   | `AST_case_tag _
    80:   | `AST_index _
    81:   | `AST_the _
    82:   | `TYP_glr_attr_type _
    83:   | `TYP_var _
    84:   | `AST_patvar _
    85:   | `AST_patany _
    86: 
    87:   (* absolute constants *)
    88:   | `AST_void _
    89:   | `TYP_ellipsis
    90:   | `TYP_type
    91:   | `TYP_none
    92: 
    93:     -> t
    94: 
    95: 
    96: let map_expr f (e:expr_t):expr_t = match e with
    97:   | `AST_patvar _
    98:   | `AST_patany _
    99:   | `AST_vsprintf _ -> e
   100:   | `AST_interpolate _ -> e
   101:   | `AST_map (sr,a,b) -> `AST_map (sr,f a, f b)
   102:   | `AST_noexpand (sr,x) -> e (* DO NOT EXPAND .. HMM .. *)
   103:   | `AST_name _ -> e
   104:   | `AST_callback _ -> e
   105:   | `AST_the _ -> e
   106:   | `AST_index _ -> e
   107:   | `AST_case_tag _ -> e
   108:   | `AST_typed_case _ -> e
   109:   | `AST_lookup (sr,(x,s,ts)) -> `AST_lookup (sr,(f x, s, ts))
   110:   | `AST_apply (sr,(a,b)) -> `AST_apply (sr,(f a, f b))
   111:   | `AST_tuple (sr,es) -> `AST_tuple (sr, map f es)
   112:   | `AST_record (sr,es) -> `AST_record (sr, map (fun (s,e) -> s,f e) es)
   113:   | `AST_variant (sr,(s,e)) -> `AST_variant (sr, (s,f e))
   114:   | `AST_arrayof (sr, es) -> `AST_arrayof (sr, map f es)
   115:   | `AST_coercion (sr, (x,t)) -> `AST_coercion (sr,(f x, t))
   116:   | `AST_suffix _ -> e
   117: 
   118:   | `AST_record_type (sr,ts) -> e
   119:   | `AST_variant_type (sr,ts) -> e
   120:   | `AST_void sr -> e
   121:   | `AST_ellipsis sr -> e
   122:   | `AST_product (sr,es) -> `AST_product (sr, map f es)
   123:   | `AST_sum (sr,es) -> `AST_sum (sr, map f es)
   124:   | `AST_setunion (sr,es) -> `AST_setunion (sr, map f es)
   125:   | `AST_setintersection (sr,es) -> `AST_setintersection (sr, map f es)
   126:   | `AST_orlist (sr,es) -> `AST_orlist (sr, map f es)
   127:   | `AST_andlist (sr,es) -> `AST_andlist (sr, map f es)
   128:   | `AST_arrow (sr,(a,b)) -> `AST_arrow (sr,(f a, f b))
   129:   | `AST_longarrow (sr,(a,b)) -> `AST_longarrow (sr,(f a, f b))
   130:   | `AST_superscript (sr,(a,b)) -> `AST_superscript (sr,(f a, f b))
   131: 
   132:   | `AST_literal _ -> e
   133:   | `AST_deref (sr,x) -> `AST_deref (sr,f x)
   134:   | `AST_ref (sr,x) -> `AST_ref (sr, f x)
   135:   | `AST_new (sr,x) -> `AST_new (sr, f x)
   136:   | `AST_lvalue (sr,x) -> `AST_lvalue (sr, f x)
   137:   | `AST_lift (sr,x) -> `AST_lift (sr, f x)
   138:   | `AST_method_apply (sr,(id,x,ts)) -> `AST_method_apply (sr,(id,f x,ts))
   139:   (*
   140:   | `AST_dot (sr,(x,id,ts)) -> `AST_dot (sr,(f x,id,ts))
   141:   *)
   142:   | `AST_dot (sr,(x,x2)) -> `AST_dot (sr,(f x,f x2))
   143: 
   144:   (* GIVE UP ON LAMBDAS FOR THE MOMENT .. NEEDS STATEMENT MAPPING TOO *)
   145:   (* | `AST_lambda of range_srcref * (vs_list_t * params_t list * typecode_t * statement_t list) *)
   146:   | `AST_lambda _ -> e
   147: 
   148:   | `AST_match_ctor (sr,(qn,x)) -> `AST_match_ctor (sr,(qn,f x))
   149:   | `AST_match_case (sr,(j,x)) -> `AST_match_case (sr,(j, f x))
   150: 
   151:   | `AST_ctor_arg (sr,(qn,x)) -> `AST_ctor_arg (sr,(qn,f x))
   152:   | `AST_case_arg (sr,(j,x)) -> `AST_case_arg (sr,(j, f x))
   153:   | `AST_case_index (sr,x) -> `AST_case_index (sr,f x)
   154: 
   155:   | `AST_letin (sr,(pat,a,b)) -> `AST_letin (sr,(pat,f a, f b))
   156: 
   157:   | `AST_get_n (sr,(j,x)) -> `AST_get_n (sr,(j,f x))
   158:   | `AST_get_named_variable (sr,(j,x)) -> `AST_get_named_variable (sr,(j,f x))
   159:   | `AST_get_named_method (sr,(j,k,ts,x)) -> `AST_get_named_method (sr,(j,k,ts,f x))
   160:   | `AST_as (sr,(x,s)) -> `AST_as (sr,(f x, s))
   161:   | `AST_match (sr,(a,pes)) ->
   162:     `AST_match (sr, (f a, map (fun (pat,x) -> pat, f x) pes))
   163: 
   164:   (* GIVE UP ON NASTY STUFF FOR THE MOMENT *)
   165:   (*
   166:   | `AST_parse of range_srcref * expr_t * (range_srcref * production_t * expr_t) list
   167:   | `AST_sparse of range_srcref * expr_t * string * int list
   168:   | `AST_regmatch of range_srcref * (expr_t * expr_t * (regexp_t * expr_t) list)
   169:   | `AST_reglex of range_srcref * (expr_t * expr_t * (regexp_t * expr_t) list)
   170:   *)
   171:   | `AST_parse _
   172:   | `AST_sparse _
   173:   | `AST_regmatch _
   174:   | `AST_string_regmatch _
   175:   | `AST_reglex _ -> e
   176: 
   177:   | `AST_typeof (sr,x) -> `AST_typeof (sr,f x)
   178:   | `AST_cond (sr,(a,b,c)) -> `AST_cond (sr, (f a, f b, f c))
   179: 
   180:   | `AST_expr _ -> e
   181:   | `AST_type_match _ -> e
   182:   | `AST_macro_ctor _ -> e
   183:   | `AST_macro_statements _ -> e
   184:   | `AST_case (sr,e1,ls,e2) -> `AST_case (sr,f e1, ls, f e2)
   185: 
   186: let iter_expr f (e:expr_t) =
   187:   f e;
   188:   match e with
   189:   | `AST_patvar _
   190:   | `AST_patany _
   191:   | `AST_vsprintf _
   192:   | `AST_interpolate _
   193:   | `AST_name _
   194:   | `AST_callback _
   195:   | `AST_the _
   196:   | `AST_index _
   197:   | `AST_case_tag _
   198:   | `AST_typed_case _
   199:   | `AST_record_type _
   200:   | `AST_variant_type _
   201:   | `AST_void _
   202:   | `AST_ellipsis _
   203:   | `AST_noexpand _
   204:   | `AST_suffix _
   205:   | `AST_literal _
   206:   | `AST_lambda _
   207:   | `AST_parse _
   208:   | `AST_sparse _
   209:   | `AST_regmatch _
   210:   | `AST_string_regmatch _
   211:   | `AST_reglex _
   212:   | `AST_expr _
   213:   | `AST_type_match _
   214:   | `AST_macro_ctor _
   215:   | `AST_macro_statements _
   216:     -> ()
   217: 
   218:   | `AST_variant (_,(_,x))
   219:   | `AST_typeof (_,x)
   220:   | `AST_as (_,(x,_))
   221:   | `AST_get_named_method (_,(_,_,_,x))
   222:   | `AST_get_n (_,(_,x))
   223:   | `AST_get_named_variable (_,(_,x))
   224:   | `AST_ctor_arg (_,(_,x))
   225:   | `AST_case_arg (_,(_,x))
   226:   | `AST_case_index (_,x)
   227:   | `AST_match_ctor (_,(_,x))
   228:   | `AST_match_case (_,(_,x))
   229:   | `AST_method_apply (_,(_,x,_))
   230:   | `AST_deref (_,x)
   231:   | `AST_ref (_,x)
   232:   | `AST_new (_,x)
   233:   | `AST_lvalue (_,x)
   234:   | `AST_lookup (_,(x,_,_))
   235:   | `AST_coercion (_, (x,_))
   236:   | `AST_lift (_,x)
   237:     -> f x
   238: 
   239:   | `AST_case (_,a,_,b)
   240:   | `AST_letin (_,(_,a,b))
   241:   | `AST_dot (_,(a,b))
   242:   | `AST_longarrow (_,(a,b))
   243:   | `AST_superscript (_,(a,b))
   244:   | `AST_arrow (_,(a,b))
   245:   | `AST_map (_,a,b)
   246:   | `AST_apply (_,(a,b))
   247:     -> f a; f b
   248: 
   249:   | `AST_tuple (_,es)
   250:   | `AST_product (_,es)
   251:   | `AST_sum (_,es)
   252:   | `AST_setunion (_,es)
   253:   | `AST_setintersection (_,es)
   254:   | `AST_orlist (_,es)
   255:   | `AST_andlist (_,es)
   256:   | `AST_arrayof (_, es) ->
   257:     iter f es
   258: 
   259:   | `AST_record (sr,es) -> iter (fun (s,e) -> f e) es
   260: 
   261:   | `AST_match (sr,(a,pes)) ->
   262:     f a; iter (fun (pat,x) -> f x) pes
   263: 
   264:   | `AST_cond (sr,(a,b,c)) -> f a; f b; f c
   265: 
   266: let scan_expr e =
   267:   let ls = ref [] in
   268:   let add x = ls := Flx_srcref.src_of_expr x :: !ls in
   269:   iter_expr add e;
   270:   Flx_util.uniq_list !ls
   271: 
   272: let all_units' ts =
   273:   try
   274:     iter (function
   275:       | `BTYP_tuple [] -> ()
   276:       | _ -> raise Not_found
   277:     )
   278:     ts;
   279:     true
   280:   with Not_found -> false
   281: 
   282: let map_b0type f = function
   283:   | `BTYP_inst (i,ts) -> `BTYP_inst (i, map f ts)
   284:   | `BTYP_tuple ts -> `BTYP_tuple (map f ts)
   285:   | `BTYP_record ts -> `BTYP_record (map (fun (s,t) -> s,f t) ts)
   286:   | `BTYP_variant ts -> `BTYP_variant (map (fun (s,t) -> s,f t) ts)
   287: 
   288:   | `BTYP_unitsum k ->
   289:     if k>0 then
   290:       let mapped_unit = f (`BTYP_tuple []) in
   291:       match mapped_unit with
   292:       | `BTYP_tuple [] ->
   293:         `BTYP_unitsum k
   294:       | _ -> `BTYP_tuple ( list_of_n_things mapped_unit [] k)
   295:     else `BTYP_unitsum k
   296: 
   297:   | `BTYP_intersect ts -> `BTYP_intersect (map f ts)
   298: 
   299:   | `BTYP_sum ts ->
   300:     let ts = map f ts in
   301:     if all_units' ts then
   302:       `BTYP_unitsum (length ts)
   303:     else
   304:       `BTYP_sum ts
   305: 
   306:   | `BTYP_function (a,b) -> `BTYP_function (f a, f b)
   307:   | `BTYP_cfunction (a,b) -> `BTYP_cfunction (f a, f b)
   308:   | `BTYP_pointer t->  `BTYP_pointer (f t)
   309:   | `BTYP_lvalue t->  `BTYP_lvalue (f t)
   310:   | `BTYP_array (t1,t2)->  `BTYP_array (f t1, f t2)
   311:   | x -> x
   312: 
   313: let map_btype f = function
   314:   | `BTYP_apply (a,b) -> `BTYP_apply (f a, f b)
   315:   | `BTYP_typefun (its, a, b) ->
   316:      `BTYP_typefun (map (fun (i,t) -> i, f t) its, f a , f b)
   317:   | `BTYP_type_tuple ts -> `BTYP_type_tuple (map f ts)
   318:   | `BTYP_type_match (t,ps) ->
   319:     (* this may be wrong .. hard to know .. *)
   320:     let g (tp,t) = {tp with pattern=f tp.pattern},f t in
   321:     `BTYP_type_match (f t, map g ps)
   322: 
   323:   | `BTYP_typeset ts ->
   324:     let g acc elt =
   325:       (* SHOULD USE UNIFICATIION! *)
   326:       let elt = f elt in
   327:       if mem elt acc then acc else elt::acc
   328:     in
   329:     let ts = rev(fold_left g [] ts) in
   330:     if length ts = 1 then hd ts else
   331:     `BTYP_typeset ts
   332: 
   333:   | `BTYP_typesetunion ls -> `BTYP_typesetunion (map f ls)
   334:   | `BTYP_typesetintersection ls -> `BTYP_typesetintersection (map f ls)
   335: 
   336:   | `BTYP_type i -> `BTYP_type i
   337:   | x -> map_b0type f x
   338: 
   339: let iter_b0type f = function
   340:   | `BTYP_inst (i,ts) -> iter f ts
   341:   | `BTYP_tuple ts -> iter f ts
   342:   | `BTYP_record ts -> iter (fun (s,t) -> f t) ts
   343:   | `BTYP_variant ts -> iter (fun (s,t) -> f t) ts
   344:   | `BTYP_unitsum k ->
   345:     let unitrep = `BTYP_tuple [] in
   346:     for i = 1 to k do f unitrep done
   347: 
   348:   | `BTYP_sum ts -> iter f ts
   349:   | `BTYP_function (a,b) -> f a; f b
   350:   | `BTYP_cfunction (a,b) -> f a; f b
   351:   | `BTYP_pointer t->  f t
   352:   | `BTYP_lvalue t->  f t
   353:   | `BTYP_array (t1,t2)->  f t1; f t2
   354:   | x -> ()
   355: 
   356: let iter_btype f = function
   357:   | `BTYP_apply (a,b) -> f a; f b
   358:   | `BTYP_typefun (its, a, b) ->
   359:      iter (fun (i,t) -> f t) its; f a; f b
   360:   | `BTYP_type_match (t,ps) ->
   361:     let g (tp,t) = f tp.pattern; f t in
   362:     f t;
   363:     iter g ps
   364: 
   365:   | `BTYP_type_tuple ts -> iter f ts
   366:   | `BTYP_typeset ts -> iter f ts
   367:   | `BTYP_typesetunion ts -> iter f ts
   368:   | `BTYP_typesetintersection ts -> iter f ts
   369: 
   370:   | x -> iter_b0type f x
   371: 
   372: (* type invariant mapping *)
   373: 
   374: let rec iter_tbexpr fi fe ft ((x,t) as e) =
   375:   fe e; ft t;
   376:   let fe e = iter_tbexpr fi fe ft e in
   377:   match x with
   378:   | `BEXPR_parse (e,iis) -> fe e; iter fi iis
   379:   | `BEXPR_deref e -> fe e
   380:   | `BEXPR_ref (i,ts) -> fi i; iter ft ts
   381:   | `BEXPR_new e -> fe e
   382: 
   383:   | `BEXPR_apply (e1,e2) -> fe e1; fe e2
   384: 
   385:   | `BEXPR_apply_prim (i,ts,e2) -> fi i; iter ft ts; fe e2
   386:   | `BEXPR_apply_direct (i,ts,e2) -> fi i; iter ft ts; fe e2
   387:   | `BEXPR_apply_method_direct (e1,i,ts,e2) -> fe e1; fi i; iter ft ts; fe e2
   388:   | `BEXPR_apply_struct (i,ts,e2) -> fi i; iter ft ts; fe e2
   389:   | `BEXPR_apply_stack (i,ts,e2) -> fi i; iter ft ts; fe e2
   390:   | `BEXPR_apply_method_stack (e1,i,ts,e2) -> fe e1; fi i; iter ft ts; fe e2
   391:   | `BEXPR_tuple  es -> iter fe es
   392:   | `BEXPR_record es -> iter (fun (s,e) -> fe e) es
   393:   | `BEXPR_variant (s,e) -> fe e
   394: 
   395:   | `BEXPR_get_n (i,e) -> fe e
   396:   | `BEXPR_get_named (i,e) -> fi i; fe e
   397: 
   398:   | `BEXPR_closure (i,ts) -> fi i; iter ft ts
   399:   | `BEXPR_method_closure (e,i,ts) -> fe e; fi i; iter ft ts
   400:   | `BEXPR_name (i,ts) -> fi i; iter ft ts
   401:   | `BEXPR_case (i,t') -> ft t'
   402:   | `BEXPR_match_case (i,e) -> fe e
   403:   | `BEXPR_case_arg (i,e) -> fe e
   404:   | `BEXPR_case_index e -> fe e
   405: 
   406:   | `BEXPR_literal x -> ft t
   407:   | `BEXPR_expr (s,t1) -> ft t1
   408:   | `BEXPR_range_check (e1,e2,e3) -> fe e1; fe e2; fe e3
   409:   | `BEXPR_coerce (e,t) -> fe e; ft t
   410: 
   411: let map_tbexpr fi fe ft e = match e with
   412:   | `BEXPR_parse (e,iis),t -> `BEXPR_parse (fe e,map fi iis), ft t
   413:   | `BEXPR_deref e,t -> `BEXPR_deref (fe e),ft t
   414:   | `BEXPR_ref (i,ts),t -> `BEXPR_ref (fi i, map ft ts), ft t
   415:   | `BEXPR_new e,t -> `BEXPR_new (fe e), ft t
   416: 
   417:   | `BEXPR_apply (e1,e2),t -> `BEXPR_apply (fe e1, fe e2), ft t
   418: 
   419:   | `BEXPR_apply_prim (i,ts,e2),t -> `BEXPR_apply_prim (fi i, map ft ts, fe e2),ft t
   420:   | `BEXPR_apply_direct (i,ts,e2),t -> `BEXPR_apply_direct (fi i, map ft ts, fe e2),ft t
   421:   | `BEXPR_apply_method_direct (e1,i,ts,e2),t -> `BEXPR_apply_method_direct (fe e1,fi i, map ft ts, fe e2),ft t
   422:   | `BEXPR_apply_struct (i,ts,e2),t -> `BEXPR_apply_struct (fi i, map ft ts, fe e2),ft t
   423:   | `BEXPR_apply_stack (i,ts,e2),t -> `BEXPR_apply_stack (fi i, map ft ts, fe e2),ft t
   424:   | `BEXPR_apply_method_stack (e1,i,ts,e2),t -> `BEXPR_apply_method_stack (fe e1,fi i, map ft ts, fe e2),ft t
   425: 
   426:   | `BEXPR_tuple  es,t -> `BEXPR_tuple (map fe es),ft t
   427:   | `BEXPR_record es,t -> `BEXPR_record (map (fun (s,e) -> s, fe e) es),ft t
   428:   | `BEXPR_variant (s,e),t -> `BEXPR_variant (s, fe e),ft t
   429: 
   430:   | `BEXPR_get_n (i,e),t -> `BEXPR_get_n (i, fe e),ft t
   431:   | `BEXPR_get_named (i,e),t -> `BEXPR_get_named (fi i, fe e),ft t
   432: 
   433:   | `BEXPR_closure (i,ts),t -> `BEXPR_closure (fi i, map ft ts),ft t
   434:   | `BEXPR_method_closure (e,i,ts),t -> `BEXPR_method_closure (fe e, fi i, map ft ts),ft t
   435:   | `BEXPR_name (i,ts),t -> `BEXPR_name (fi i, map ft ts), ft t
   436:   | `BEXPR_case (i,t'),t -> `BEXPR_case (i, ft t'),ft t
   437:   | `BEXPR_match_case (i,e),t -> `BEXPR_match_case (i, fe e),ft t
   438:   | `BEXPR_case_arg (i,e),t -> `BEXPR_case_arg (i, fe e),ft t
   439:   | `BEXPR_case_index e,t -> `BEXPR_case_index (fe e),ft t
   440: 
   441:   | `BEXPR_literal x,t -> `BEXPR_literal x, ft t
   442:   | `BEXPR_expr (s,t1),t2 -> `BEXPR_expr (s, ft t1), ft t2
   443:   | `BEXPR_range_check (e1,e2,e3),t -> `BEXPR_range_check (fe e1,fe e2, fe e3), ft t
   444:   | `BEXPR_coerce (e,t'),t -> `BEXPR_coerce (fe e, ft t'), ft t
   445: 
   446: let iter_bexe fi fe ft fl fldef exe =
   447:   match exe with
   448:   | `BEXE_call_prim (sr,i,ts,e2)
   449:   | `BEXE_call_stack (sr,i,ts,e2)
   450:   | `BEXE_call_direct (sr,i,ts,e2)
   451:   | `BEXE_jump_direct (sr,i,ts,e2)
   452:     -> fi i; iter ft ts; fe e2
   453: 
   454:   | `BEXE_call_method_direct (sr,e1,i,ts,e2)
   455:     -> fe e1; fi i; iter ft ts; fe e2
   456: 
   457:   | `BEXE_call_method_stack (sr,e1,i,ts,e2)
   458:     -> fe e1; fi i; iter ft ts; fe e2
   459: 
   460:   | `BEXE_assign (sr,e1,e2)
   461:   | `BEXE_call (sr,e1,e2)
   462:   | `BEXE_jump (sr,e1,e2)
   463:     -> fe e1; fe e2
   464: 
   465:   | `BEXE_apply_ctor (sr,i0, i1,ts,i2,e2)
   466:     -> fi i0; fi i1; iter ft ts; fi i2; fe e2
   467: 
   468:   | `BEXE_apply_ctor_stack (sr,i0, i1,ts,i2,e2)
   469:     -> fi i0; fi i1; iter ft ts; fi i2; fe e2
   470: 
   471:   | `BEXE_loop (sr,i,e)
   472:     -> fi i; fe e
   473: 
   474:   | `BEXE_ifgoto (sr,e,lab)
   475:   | `BEXE_ifnotgoto (sr,e,lab)
   476:     -> fe e; fl lab
   477: 
   478:   | `BEXE_label (sr,lab)
   479:     -> fldef lab
   480: 
   481:   | `BEXE_goto (sr,lab)
   482:     -> fl lab
   483: 
   484:   | `BEXE_fun_return (sr,e)
   485:     -> fe e
   486: 
   487:   | `BEXE_yield (sr,e)
   488:     -> fe e
   489: 
   490:   | `BEXE_axiom_check (_,e)
   491:     -> fe e
   492: 
   493:   | `BEXE_assert2 (_,_,e1,e2)
   494:     -> (match e1 with Some e -> fe e | None->()); fe e2
   495: 
   496:   | `BEXE_assert (_,e)
   497:     -> fe e
   498: 
   499:   | `BEXE_init (sr,i,e)
   500:     -> fi i; fe e
   501: 
   502:   | `BEXE_svc (sr,i)
   503:     -> fi i
   504: 
   505:   | `BEXE_halt _
   506:   | `BEXE_code _
   507:   | `BEXE_nonreturn_code _
   508:   | `BEXE_proc_return _
   509:   | `BEXE_comment _
   510:   | `BEXE_nop _
   511:   | `BEXE_begin
   512:   | `BEXE_end
   513:     -> ()
   514: 
   515: 
   516: let map_bexe fi fe ft fl fldef (exe:bexe_t):bexe_t =
   517:   match exe with
   518:   | `BEXE_call_prim (sr,i,ts,e2)  ->
   519:     `BEXE_call_prim (sr,fi i,map ft ts, fe e2)
   520: 
   521:   | `BEXE_call_stack (sr,i,ts,e2) ->
   522:     `BEXE_call_stack (sr,fi i, map ft ts, fe e2)
   523: 
   524:   | `BEXE_call_direct (sr,i,ts,e2) ->
   525:     `BEXE_call_direct (sr,fi i,map ft ts,fe e2)
   526: 
   527:   | `BEXE_call_method_direct (sr,e1,i,ts,e2) ->
   528:     `BEXE_call_method_direct (sr,fe e1,fi i,map ft ts,fe e2)
   529: 
   530:   | `BEXE_call_method_stack (sr,e1,i,ts,e2) ->
   531:     `BEXE_call_method_stack (sr,fe e1,fi i,map ft ts,fe e2)
   532: 
   533:   | `BEXE_jump_direct (sr,i,ts,e2) ->
   534:     `BEXE_jump_direct (sr,fi i,map ft ts,fe e2)
   535: 
   536:   | `BEXE_assign (sr,e1,e2) ->
   537:     `BEXE_assign (sr,fe e1,fe e2)
   538: 
   539:   | `BEXE_call (sr,e1,e2) ->
   540:     `BEXE_call (sr,fe e1, fe e2)
   541: 
   542:   | `BEXE_apply_ctor (sr,i1,i2,ts,i3,e2) ->
   543:     `BEXE_apply_ctor (sr,fi i1,fi i2, map ft ts, fi i3,fe e2)
   544: 
   545:   | `BEXE_apply_ctor_stack (sr,i1,i2,ts,i3,e2) ->
   546:     `BEXE_apply_ctor_stack (sr,fi i1,fi i2, map ft ts, fi i3,fe e2)
   547: 
   548:   | `BEXE_jump (sr,e1,e2) ->
   549:     `BEXE_jump (sr,fe e1, fe e2)
   550: 
   551:   | `BEXE_loop (sr,i,e) ->
   552:     `BEXE_loop (sr,fi i,fe e)
   553: 
   554:   | `BEXE_ifgoto (sr,e,lab)  ->
   555:     `BEXE_ifgoto (sr,fe e,fl lab)
   556: 
   557:   | `BEXE_ifnotgoto (sr,e,lab) ->
   558:     `BEXE_ifnotgoto (sr,fe e,fl lab)
   559: 
   560:   | `BEXE_label (sr,lab) ->
   561:     `BEXE_label (sr,fldef lab)
   562: 
   563:   | `BEXE_goto (sr,lab) ->
   564:     `BEXE_goto (sr,fl lab)
   565: 
   566:   | `BEXE_fun_return (sr,e) ->
   567:     `BEXE_fun_return (sr,fe e)
   568: 
   569:   | `BEXE_yield (sr,e) ->
   570:     `BEXE_yield (sr,fe e)
   571: 
   572:   | `BEXE_assert (sr,e) ->
   573:     `BEXE_assert (sr, fe e)
   574: 
   575:   | `BEXE_assert2 (sr,sr2,e1, e2) ->
   576:      let e1 = match e1 with Some e1 -> Some (fe e1) | None -> None in
   577:     `BEXE_assert2 (sr, sr2,e1, fe e2)
   578: 
   579:   | `BEXE_axiom_check (sr,e) ->
   580:     `BEXE_axiom_check (sr, fe e)
   581: 
   582:   | `BEXE_init (sr,i,e) ->
   583:     `BEXE_init (sr,fi i,fe e)
   584: 
   585:   | `BEXE_svc (sr,i) ->
   586:     `BEXE_svc (sr,fi i)
   587: 
   588:   | `BEXE_halt _
   589:   | `BEXE_code _
   590:   | `BEXE_nonreturn_code _
   591:   | `BEXE_proc_return _
   592:   | `BEXE_comment _
   593:   | `BEXE_nop _
   594:   | `BEXE_begin
   595:   | `BEXE_end
   596:     -> exe
   597: 
   598: let ident x = x
   599: let reduce_tbexpr bbdfns e =
   600:   let rec aux e =
   601:     match map_tbexpr ident aux ident e with
   602:     | `BEXPR_apply((`BEXPR_closure (i,ts),_),a),t ->
   603:       `BEXPR_apply_direct (i,ts,a),t
   604: 
   605:     | `BEXPR_apply((`BEXPR_method_closure (obj,i,ts),_),a),t ->
   606:       `BEXPR_apply_method_direct (obj,i,ts,a),t
   607: 
   608:     | `BEXPR_get_n (n,((`BEXPR_tuple ls),_)),_ ->
   609:       List.nth ls n
   610: 
   611:     | `BEXPR_deref (`BEXPR_ref (i,ts),_),t ->
   612:       `BEXPR_name (i,ts),t
   613: 
   614:     | x -> x
   615:   in aux e
   616: 
   617: let reduce_bexe bbdfns exe =
   618:   match map_bexe ident (reduce_tbexpr bbdfns) ident ident ident exe with
   619:   | `BEXE_call (sr,(`BEXPR_closure (i,ts),_),a) ->
   620:     `BEXE_call_direct (sr,i,ts,a)
   621: 
   622:   | `BEXE_call (sr,(`BEXPR_method_closure (obj,meth,ts),_),a) ->
   623:     `BEXE_call_method_direct (sr,obj,meth,ts,a)
   624: 
   625:   | x -> x
   626: 
   627: let rec reduce_type t =
   628:   match map_btype reduce_type t with
   629:   | `BTYP_record ts ->
   630:     begin match ts with
   631:     | [] -> `BTYP_tuple []
   632:     | _ ->
   633:      let rcmp (s1,_) (s2,_) = compare s1 s2 in
   634:      let ts = sort compare ts in
   635:      let ss,ts = split ts in
   636:      let ts = combine ss (map reduce_type ts) in
   637:      `BTYP_record ts
   638:     end
   639:   | `BTYP_variant ts ->
   640:     begin match ts with
   641:     | [] -> `BTYP_void
   642:     | _ ->
   643:      let rcmp (s1,_) (s2,_) = compare s1 s2 in
   644:      let ts = sort compare ts in
   645:      let ss,ts = split ts in
   646:      let ts = combine ss (map reduce_type ts) in
   647:      `BTYP_variant ts
   648:     end
   649:   | `BTYP_tuple ts -> typeoflist ts
   650:   | `BTYP_array (t',`BTYP_unitsum 0) -> `BTYP_tuple []
   651:   | `BTYP_array (t',`BTYP_unitsum 1) -> t'
   652:   | t -> t
   653: 
End ocaml section to src/flx_maps.ml[1]