5.9. Mappings

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