5.59. C++ Code generator

Start ocaml section to src/flx_pgen.mli[1 /1 ]
     1: # 4 "./lpsrc/flx_pgen.ipk"
     2: open Flx_ast
     3: open Flx_types
     4: open Flx_mtypes1
     5: open Flx_mtypes2
     6: open Flx_label
     7: open Flx_ctypes
     8: 
     9: val gen_prim_call :
    10:   sym_state_t ->
    11:   fully_bound_symbol_table_t ->
    12:   (btypecode_t -> btypecode_t) ->
    13:   (range_srcref -> tbexpr_t -> cexpr_t) ->
    14:   string ->
    15:   btypecode_t list ->
    16:   tbexpr_t ->
    17:   string ->
    18:   range_srcref ->
    19:   range_srcref ->
    20:   string ->
    21:   cexpr_t
    22: 
    23: val shape_of:
    24:   fully_bound_symbol_table_t ->
    25:   (btypecode_t -> string) ->
    26:   btypecode_t ->
    27:   string
    28: 
End ocaml section to src/flx_pgen.mli[1]
Start ocaml section to src/flx_pgen.ml[1 /1 ]
     1: # 33 "./lpsrc/flx_pgen.ipk"
     2: open Flx_util
     3: open Flx_ast
     4: open Flx_types
     5: open Flx_mtypes1
     6: open Flx_mtypes2
     7: open Flx_print
     8: open Flx_typing
     9: open Flx_name
    10: open Flx_tgen
    11: open Flx_unify
    12: open Flx_csubst
    13: open Flx_exceptions
    14: open Flx_display
    15: open List
    16: open Flx_generic
    17: open Flx_label
    18: open Flx_ctypes
    19: open Flx_cexpr
    20: open Flx_maps
    21: 
    22: let shape_of bbdfns tn t =
    23:   match t with
    24:   | `BTYP_inst (i,ts) ->
    25:     let id,parent,sr,entry = Hashtbl.find bbdfns i in
    26:     begin match entry with
    27:     | `BBDCL_union (vs,idts) ->
    28:       let varmap = mk_varmap vs ts in
    29:       let cpts = map (fun (_,_,t) -> varmap_subst varmap t) idts in
    30:       if all_voids cpts then "_int_ptr_map"
    31:       else "_uctor_ptr_map"
    32:      | _ -> tn t ^ "_ptr_map"
    33:      end
    34:   | `BTYP_pointer _ -> "_ref_ptr_map"
    35:   | _ -> tn t ^ "_ptr_map"
    36: 
    37: let gen_prim_call
    38:   syms
    39:   (bbdfns:fully_bound_symbol_table_t)
    40:   (tsub:btypecode_t -> btypecode_t)
    41:   (ge: range_srcref -> tbexpr_t -> cexpr_t)
    42:   (ct:string)
    43:   (ts:btypecode_t list)
    44:   ((arg,argt as a) : tbexpr_t)
    45:   ret sr sr2 prec
    46: =
    47:   (*
    48:   print_endline ("ts= "^catmap "," (sbt syms.dfns) ts);
    49:   print_endline ("argt = " ^ sbt syms.dfns argt);
    50:   *)
    51:   let tn t = cpp_typename syms t in
    52:   let rt t = reduce_type (lstrip syms.dfns (tsub t)) in
    53:   let rtn t = tn (rt t) in
    54: 
    55:   let argt = rt argt in
    56:   let tt = tn argt in
    57:   let sh t = shape_of bbdfns tn t in
    58:   let gshapes = map sh ts in
    59:   let ts = map rtn ts in
    60:   let carg =
    61:     match argt with
    62:     | `BTYP_tuple []  -> ce_atom "UNIT_VALUE_ERROR"
    63:     | x -> ge sr a
    64:   in
    65:   let ashape = sh argt in
    66:   match arg,argt with
    67: 
    68:   (* the argument is explicitly a tuple *)
    69:   | (`BEXPR_tuple es,_) ->
    70:     let ess =
    71:       map
    72:       (fun e->
    73:         match e with
    74:         (* individual arguments which are unit values are never passed:
    75:           they CAN be passed as subcomponents though .. but they can't
    76:           be generated .. we need to fix this!
    77:         *)
    78:         | `BEXPR_tuple [],_ ->
    79:           (*
    80:           print_endline "Stripping unit";
    81:           *)
    82:           `Ce_atom "/*()*/"
    83: 
    84:         | _ -> ge sr e
    85:       )
    86:       es
    87:     in
    88:     let ets,ashapes =
    89:       match argt with
    90:       | `BTYP_tuple typs -> map rtn typs, map sh typs
    91:       | `BTYP_array (t,`BTYP_unitsum n) ->
    92:         let t = tn t
    93:         and s = sh t
    94:         in rev_map (fun _ -> t) (nlist n), rev_map (fun _ -> s) (nlist n)
    95:       | _ -> assert false
    96:     in
    97:     csubst sr sr2 ct carg ess ets tt ret ts prec ashape ashapes ["Error"] gshapes
    98: 
    99:   (* the argument isnt a tuple, but the type is *)
   100:   | (_,`BTYP_tuple typs) as x ->
   101:     let n = length typs in
   102:     let typs = map rt typs in
   103:     let es =
   104:       map2
   105:       (fun i t -> `BEXPR_get_n (i,x),t)
   106:       (nlist n) typs
   107:     in
   108:     let ess = map (ge sr) es in
   109:     let ets = map tn typs in
   110:     csubst sr sr2 ct carg ess ets tt ret ts prec ashape (map sh typs) ["Error"] gshapes
   111: 
   112:   (* the argument isnt a tuple, but the type is an array *)
   113:   | (_,(`BTYP_array(t,`BTYP_unitsum n) as ta)) as x ->
   114:     let t = rt t in
   115:     let typs = map (fun _ -> rt t) (nlist n) in
   116:     let es =
   117:       map
   118:       (fun i -> `BEXPR_get_n (i,x),t)
   119:       (nlist n)
   120:     in
   121:     let ess = map (ge sr) es in
   122:     let ets = map tn typs in
   123:     csubst sr sr2 ct carg ess ets tt ret ts prec ashape (map sh typs) ["error"] gshapes
   124: 
   125:   (* the argument isn't an explicit tuple, and the type
   126:      is neither an array nor tuple
   127:   *)
   128:   | (_,typ) ->
   129:     csubst sr sr2 ct carg [carg] [tt] tt ret ts prec ashape [ashape] ["Error"] gshapes
   130: 
   131: 
   132: 
End ocaml section to src/flx_pgen.ml[1]
Start ocaml section to src/flx_egen.mli[1 /1 ]
     1: # 3 "./lpsrc/flx_egen.ipk"
     2: open Flx_ast
     3: open Flx_types
     4: open Flx_mtypes1
     5: open Flx_mtypes2
     6: open Flx_label
     7: open Flx_ctypes
     8: 
     9: val gen_expr:
    10:   sym_state_t ->
    11:   fully_bound_symbol_table_t ->
    12:   int ->
    13:   tbexpr_t ->
    14:   bvs_t ->
    15:   btypecode_t list ->
    16:   range_srcref -> string
    17: 
    18: val gen_expr':
    19:   sym_state_t ->
    20:   fully_bound_symbol_table_t ->
    21:   int ->
    22:   tbexpr_t ->
    23:   bvs_t ->
    24:   btypecode_t list ->
    25:   range_srcref -> cexpr_t
    26: 
    27: val get_var_ref:
    28:   sym_state_t ->
    29:   fully_bound_symbol_table_t ->
    30:   int ->
    31:   int ->
    32:   btypecode_t list ->
    33:   string
    34: 
End ocaml section to src/flx_egen.mli[1]
Start ocaml section to src/flx_egen.ml[1 /1 ]
     1: # 38 "./lpsrc/flx_egen.ipk"
     2: open Flx_util
     3: open Flx_ast
     4: open Flx_types
     5: open Flx_mtypes1
     6: open Flx_mtypes2
     7: open Flx_print
     8: open Flx_typing
     9: open Flx_name
    10: open Flx_tgen
    11: open Flx_unify
    12: open Flx_csubst
    13: open Flx_exceptions
    14: open Flx_display
    15: open List
    16: open Flx_generic
    17: open Flx_label
    18: open Flx_unravel
    19: open Flx_ogen
    20: open Flx_ctypes
    21: open Flx_cexpr
    22: open Flx_maps
    23: open Flx_pgen
    24: open Flx_beta
    25: 
    26: let string_of_string = Flx_string.c_quote_of_string
    27: 
    28: (* HACKERY: this assumes library dependent things:
    29:   but we can't add literals in the library code :-(
    30: *)
    31: let csuffix_of_type s = match s with
    32:   | "tiny" -> ""
    33:   | "short" -> ""
    34:   | "int" -> ""
    35:   | "long" -> "l"
    36:   | "vlong" -> "ll"
    37:   | "utiny" -> "u"
    38:   | "ushort" -> "u"
    39:   | "uint" -> "u"
    40:   | "ulong" -> "ul"
    41:   | "uvlong" -> "ull"
    42:   | "int8" -> ""
    43:   | "int16" -> ""
    44:   | "int32" -> "l"
    45:   | "int64" -> "ll"
    46:   | "uint8" -> "u"
    47:   | "uint16" -> "u"
    48:   | "uint32" -> "ul"
    49:   | "uint64" -> "ull"
    50:   | "double" -> ""
    51:   | "float" -> "f"
    52:   | "ldouble" -> "l"
    53:   | _ -> failwith ("[csuffix_of_type]: Unexpected Type " ^ s)
    54: 
    55: let cstring_of_literal e = match e with
    56:   | `AST_int (s,i) -> (Big_int.string_of_big_int i)^csuffix_of_type s
    57:   | `AST_float (s,x) -> x ^ csuffix_of_type s
    58:   | `AST_string s -> string_of_string s
    59:   | `AST_cstring s -> string_of_string s
    60:   | `AST_wstring s -> "L" ^ string_of_string s
    61:   | `AST_ustring s -> "L" ^ string_of_string s
    62: 
    63: (* a native literal is one not needing a cast to get the type right *)
    64: let is_native_literal e = match e with
    65:   | `AST_int ("int",_)
    66:   | `AST_int ("long",_)
    67:   | `AST_int ("uint",_)
    68:   | `AST_int ("ulong",_)
    69:   | `AST_int ("vlong",_)
    70:   | `AST_int ("uvlong",_)
    71:   | `AST_float ("double",_) -> true
    72:   | _ -> false
    73: 
    74: let get_var_frame syms bbdfns this index ts : string =
    75:   match
    76:     try Hashtbl.find bbdfns index
    77:     with Not_found -> failwith ("[get_var_frame(1)] Can't find index " ^ si index)
    78:   with (id,parent,sr,entry) ->
    79:   match entry with
    80:   | `BBDCL_val (vs,t)
    81:   | `BBDCL_var (vs,t) ->
    82:     begin match parent with
    83:     | None -> "0"
    84:     | Some i ->
    85:       if i <> this
    86:       then "ptr" ^ cpp_instance_name syms bbdfns i ts
    87:       else "this"
    88:     end
    89:   | `BBDCL_tmp (vs,t) ->
    90:      failwith ("[get_var_frame] temporaries aren't framed: " ^ id)
    91: 
    92:   | _ -> failwith ("[get_var_frame] Expected name "^id^" to be variable or value")
    93: 
    94: let get_var_ref syms bbdfns this index ts : string =
    95:   match
    96:     try Hashtbl.find bbdfns index
    97:     with Not_found -> failwith ("[get_var_ref] Can't find index " ^ si index)
    98:   with (id,parent,sr,entry) ->
    99:   (*
   100:   print_endline ("get var ref for " ^ id ^ "<" ^ si index ^ ">["^catmap "," (string_of_btypecode syms.dfns) ts^"]");
   101:   *)
   102:   match entry with
   103:   | `BBDCL_val (vs,t)
   104:   | `BBDCL_var (vs,t) ->
   105:     begin match parent with
   106:     | None -> (* print_endline "No parent ...?"; *)
   107:       "PTF " ^ cpp_instance_name syms bbdfns index ts
   108:     | Some i ->
   109:       (*
   110:       print_endline ("Parent " ^ si i);
   111:       *)
   112:       (
   113:         if i <> this
   114:         then "ptr" ^ cpp_instance_name syms bbdfns i ts ^ "->"
   115:         else ""
   116:       ) ^
   117:       cpp_instance_name syms bbdfns index ts
   118:     end
   119: 
   120:   | `BBDCL_tmp (vs,t) ->
   121:       cpp_instance_name syms bbdfns index ts
   122: 
   123:   | _ -> failwith ("[get_var_ref(3)] Expected name "^id^" to be variable, value or temporary")
   124: 
   125: let nth_type ts i =
   126:   try match ts with
   127:   | `BTYP_tuple ts -> nth ts i
   128:   | `BTYP_array (t,`BTYP_unitsum n) -> assert (i<n); t
   129:   | _ -> assert false
   130:   with Not_found ->
   131:     failwith ("Can't find component " ^ si i ^ " of type!")
   132: 
   133: let rec gen_expr' syms bbdfns this (e,t) vs ts sr : cexpr_t =
   134:   (*
   135:   print_endline ("Generating expression " ^ string_of_bound_expression_with_type syms.dfns (e,t));
   136:   *)
   137:   let ge' e = gen_expr' syms bbdfns this e vs ts sr in
   138:   let ge e = gen_expr syms bbdfns this e vs ts sr in
   139:   let ge'' sr e = gen_expr' syms bbdfns this e vs ts sr in
   140:   if length ts <> length vs then
   141:   failwith
   142:   (
   143:     "[gen_expr} wrong number of args, expected vs = " ^
   144:     si (length vs) ^
   145:     ", got ts=" ^
   146:     si (length ts)
   147:   );
   148:   let tsub t = reduce_type (beta_reduce syms [] (tsubst vs ts t)) in
   149:   let tn t = cpp_typename syms (tsub (lower t)) in
   150: 
   151:   (* NOTE this function does not do a reduce_type *)
   152:   let raw_typename t = cpp_typename syms (beta_reduce syms [] (tsubst vs ts t)) in
   153:   let gen_case_index e =
   154:     let _,t = e in
   155:     let t = lstrip syms.dfns t in
   156:     begin match t with
   157:     | `BTYP_sum _
   158:     | `BTYP_unitsum _
   159:     | `BTYP_variant _ ->
   160:       if is_unitsum t then ge' e
   161:       else ce_dot (ge' e) "variant"
   162:     | `BTYP_inst (i,ts) ->
   163:       let ts = map tsub ts in
   164:       let id,_,_,entry =
   165:         try Hashtbl.find bbdfns i
   166:         with Not_found -> failwith ("[gen_expr: case_index] Can't find index " ^ si i)
   167:       in
   168:       begin match entry with
   169:       | `BBDCL_union (bvs,cts) ->
   170:         let tsub' t = reduce_type (beta_reduce syms [] (tsubst bvs ts t)) in
   171:         let cts = map (fun (_,_,t) -> tsub' t) cts in
   172:         if all_voids cts then ge' e
   173:         else ce_dot (ge' e) "variant"
   174:       | _ -> failwith ("Woops expected union, got " ^ id)
   175:       end
   176:     | _ -> failwith ("Woops expected union or sum, got " ^ sbt syms.dfns t)
   177:     end
   178: 
   179:   in
   180:   let ge_arg ((x,t) as a) =
   181:     let t = tsub t in
   182:     match t with
   183:     | `BTYP_tuple [] -> ""
   184:     | _ -> ge a
   185:   in
   186:   let id,parent,sr,entry =
   187:     try Hashtbl.find bbdfns this
   188:     with Not_found -> failwith ("[gen_expr] Can't find this = " ^ si this)
   189:   in
   190:   let our_display = get_display_list bbdfns this in
   191:   let our_level = length our_display in
   192:   let rt t = reduce_type (beta_reduce syms [] (lstrip syms.dfns (tsubst vs ts t))) in
   193:   let t = rt t in
   194:   match t with
   195:   | `BTYP_tuple [] ->
   196:       clierr sr
   197:      ("[egen] In "^sbe syms.dfns (e,t)^":\nunit value required, should have been eliminated")
   198: 
   199:      (* ce_atom ("UNIT_ERROR") *)
   200:   | _ ->
   201:   match e with
   202:   | `BEXPR_parse ((_,t')as e,ii) ->
   203:     let pn =
   204:       try Hashtbl.find syms.parsers (this,t',ii)
   205:       with Not_found -> failwith ("[gen_expr] parse can't find parser")
   206:     in
   207:     let ln =
   208:       try Hashtbl.find syms.lexers (this,e)
   209:       with Not_found -> failwith ("[gen_expr] parse can't find lexer")
   210:     in
   211:     let the_display =
   212:       "this"::
   213:       map (fun (i,vslen)-> "ptr"^ cpp_instance_name syms bbdfns i (list_prefix ts vslen))
   214:       our_display
   215:     in
   216: 
   217:     (* HACK PROPERTIES *)
   218:     let pdisplay = strd the_display [`Requires_ptf] in
   219:     let ldisplay = strd (the_display @[ge e]) [`Requires_ptf] in
   220:     let callstr =
   221:     "(Elk_" ^ si pn ^ pdisplay ^
   222:     ".apply((new ElkLex_" ^ si ln^ldisplay^")->init()))"
   223:     in
   224:       (*
   225:       print_endline ("Parse call : " ^ callstr);
   226:       *)
   227:       ce_atom callstr
   228: 
   229:   | `BEXPR_expr (s,_) -> ce_top s
   230: 
   231:   | `BEXPR_case_index e -> gen_case_index e
   232: 
   233:   | `BEXPR_range_check (e1,e2,e3) ->
   234:      let f,sl,sc,el,ec = sr in
   235:      let f = ce_atom ("\""^ f ^"\"") in
   236:      let sl = ce_atom (si sl) in
   237:      let sc = ce_atom (si sc) in
   238:      let el = ce_atom (si el) in
   239:      let ec = ce_atom (si ec) in
   240:      let sref = ce_call (ce_atom "flx::rtl::flx_range_srcref_t") [f;sl;sc;el;ec] in
   241:      let cf = ce_atom "__FILE__" in
   242:      let cl = ce_atom "__LINE__" in
   243:      let args : cexpr_t list =
   244:        [ ge' e1 ; ge' e2; ge' e3; sref; cf; cl]
   245:      in
   246:      ce_call (ce_atom "flx::rtl::range_check") args
   247: 
   248:   | `BEXPR_get_n (n,(e',t as e)) ->
   249:     begin match rt t with
   250:     | `BTYP_array (_,`BTYP_unitsum _) ->
   251:       ce_dot (ge' e) ("data["^si n^"]")
   252:     | `BTYP_record es ->
   253:       let field_name,_ =
   254:         try nth es n
   255:         with Not_found ->
   256:           failwith "Woops, index of non-existent struct field"
   257:       in
   258:       ce_dot (ge' e) field_name
   259: 
   260:     | `BTYP_inst (i,_) ->
   261:       begin match Hashtbl.find bbdfns i with
   262:       | _,_,_,`BBDCL_struct (_,ls)
   263:       | _,_,_,`BBDCL_cstruct (_,ls) ->
   264:         let name,_ =
   265:           try nth ls n
   266:           with _ ->
   267:             failwith "Woops, index of non-existent struct field"
   268:         in
   269:         ce_dot (ge' e) name
   270: 
   271:       | _ -> failwith "Instance expected to be (c)struct"
   272:       end
   273: 
   274:     | _ -> ce_dot (ge' e) ("mem_" ^ si n)
   275:     end
   276: 
   277:   | `BEXPR_get_named (n,(e',t as e)) ->
   278:     (*
   279:     print_endline "Handling get_named expression";
   280:     *)
   281:     begin match rt t with
   282:     | `BTYP_inst (i,ts) ->
   283:       begin match
   284:         try Hashtbl.find syms.dfns i
   285:         with Not_found -> assert false
   286:       with { id=class_name; symdef=symdef } ->
   287:       match symdef with
   288:       | `SYMDEF_class ->
   289:         begin match
   290:           try Hashtbl.find syms.dfns n
   291:           with Not_found -> failwith ("Can't find class "^class_name^"member " ^ si n);
   292:         with { id = name } ->
   293:           let cname = cpp_instance_name syms bbdfns n ts in
   294:           ce_arrow (ge' e) cname
   295:         end
   296:       | _ -> clierr sr ("[gen_expr'] Expecting "^si i^" to be class, got " ^ string_of_bbdcl syms.dfns entry i)
   297:       end
   298:     | _ -> assert false
   299:     end
   300: 
   301:   | `BEXPR_match_case (n,((e',t') as e)) ->
   302:     let t' = reduce_type (beta_reduce syms [] (lstrip syms.dfns t')) in
   303:     let x = gen_case_index e in
   304:     ce_infix "==" x (ce_atom (si n))
   305: 
   306:     (*
   307:     if is_unitsum t' then
   308:       ce_infix "==" (ge' e) (ce_atom (si n))
   309:     else
   310:       ce_infix "=="
   311:       (ce_dot (ge' e) "variant")
   312:       (ce_atom (si n))
   313:     *)
   314: 
   315:   | `BEXPR_case_arg (n,e) ->
   316:     (*
   317:     print_endline ("Decoding nonconst ctor type " ^ sbt syms.dfns t);
   318:     *)
   319:     begin match t with (* t is the result of the whole expression *)
   320:     | `BTYP_function _ ->
   321:       let cast = tn t in
   322:       ce_cast cast (ce_dot (ge' e) "data")
   323:     | _ ->
   324:       let cast = tn t ^ "*" in
   325:       ce_prefix "*" (ce_cast cast (ce_dot (ge' e) "data"))
   326:     end
   327: 
   328:   | `BEXPR_deref ((`BEXPR_ref index),`BTYP_pointer t) ->
   329:     ge' (`BEXPR_name index,t)
   330: 
   331:   | `BEXPR_deref e ->
   332:     let cast = tn t ^ "*" in
   333:     ce_prefix "*" (ce_cast cast (ce_dot (ge' e) "get_data()"))
   334: 
   335:   | `BEXPR_literal v ->
   336:     if is_native_literal v
   337:     then ce_atom (cstring_of_literal v)
   338:     else
   339:     let t = tn t in
   340:     ce_atom (t ^ "(" ^ cstring_of_literal v ^ ")")
   341: 
   342:   | `BEXPR_case (v,t') ->
   343:     begin match unfold syms.dfns t' with
   344:     | `BTYP_unitsum n ->
   345:       if v < 0 or v >= n
   346:       then
   347:         failwith
   348:         (
   349:           "Invalid case index " ^ si v ^
   350:           " of " ^ si n ^ " cases  in unitsum"
   351:         )
   352:      else ce_atom (si v)
   353: 
   354:     | `BTYP_sum ls ->
   355:        let s =
   356:          let n = length ls in
   357:          if v < 0 or v >= n
   358:          then
   359:            failwith
   360:            (
   361:              "Invalid case index " ^ si v ^
   362:              " of " ^ si n ^ " cases"
   363:            )
   364:          else let t' = nth ls v in
   365:          if t' = `BTYP_tuple []
   366:          then (* closure of const ctor is just the const value ???? *)
   367:            if is_unitsum t then
   368:              si v
   369:            else
   370:              "_uctor_(" ^ si v ^ ",0)"
   371:          else
   372:            failwith
   373:            (
   374:               "Can't handle closure of case " ^
   375:               si v ^
   376:               " of " ^
   377:               string_of_btypecode syms.dfns t
   378:            )
   379:        in ce_atom s
   380:        (* "(" ^ tn (lower t) ^ "*)_uctor_" *)
   381: 
   382:     | _ -> failwith "Case tag must have sum type"
   383:     end
   384: 
   385:   | `BEXPR_name (index,ts') ->
   386:     let id,parent,sr2,entry =
   387:       try Hashtbl.find bbdfns index
   388:       with _ ->
   389:         match
   390:           try Hashtbl.find syms.dfns index
   391:           with Not_found -> assert false
   392:         with
   393:         {id=id; sr=sr} -> syserr sr
   394:         ("[gen_expr(name)] Can't find "^ id ^ "<" ^ si index ^ ">")
   395:     in
   396:     let ts = map tsub ts' in
   397:     begin match entry with
   398:       | `BBDCL_var (_,t)
   399:       | `BBDCL_val (_,t)
   400:       | `BBDCL_tmp (_,t)
   401:         ->
   402:           ce_atom (get_var_ref syms bbdfns this index ts)
   403: 
   404:       | `BBDCL_const (_,_,ct,_) ->
   405:         begin match ct with
   406:         | `Str c
   407:         | `StrTemplate c when c = "#srcloc" ->
   408:            let filename, startline, startcol, endline, endcol = sr in
   409:            ce_atom ("flx::rtl::flx_range_srcref_t(" ^
   410:              string_of_string filename ^ "," ^
   411:              si startline ^ "," ^
   412:              si startcol ^ "," ^
   413:              si endline ^ "," ^
   414:              si endcol ^ ")"
   415:            )
   416: 
   417:         | `Str c
   418:         | `StrTemplate c when c = "#memcount" ->
   419:           let ts = map (lstrip syms.dfns) ts in
   420:           begin match ts with
   421:           | [`BTYP_unitsum n]
   422:           | [`BTYP_array (_,`BTYP_unitsum n)] -> ce_atom (si n)
   423:           | [`BTYP_sum ls]
   424:           | [`BTYP_tuple ls] -> let n = length ls in ce_atom (si n)
   425:           | [`BTYP_inst (i,_)] ->
   426:             let _,_,_,entry = Hashtbl.find bbdfns i in
   427:             begin match entry with
   428:               | `BBDCL_struct (_,ls) -> let n = length ls in ce_atom (si n)
   429:               | `BBDCL_cstruct (_,ls) -> let n = length ls in ce_atom (si n)
   430:               | `BBDCL_union (_,ls) -> let n = length ls in ce_atom (si n)
   431:               | `BBDCL_class (_,ls) -> let n = length ls in ce_atom (si n)
   432:               | _ ->
   433:                 clierr sr (
   434:                   "#memcount function requires type with members to count, got: " ^
   435:                   sbt syms.dfns (hd ts)
   436:                 )
   437:             end
   438:           | _ ->
   439:             clierr sr (
   440:               "#memcount function requires type with members to count, got : " ^
   441:               sbt syms.dfns (hd ts)
   442:             )
   443:           end
   444:         | `Str c -> ce_expr "expr" c
   445:         | `StrTemplate c ->
   446:           let ts = map tn ts in
   447:           csubst sr sr2 c (ce_atom "Error") [] [] "Error" "Error" ts "expr" "Error" ["Error"] ["Error"] ["Error"]
   448:         end
   449: 
   450:       (* | `BBDCL_function (_,_,([s,(_,`BTYP_void)],_),_,[`BEXE_fun_return e]) -> *)
   451:       | `BBDCL_function (_,_,([],_),_,[`BEXE_fun_return (_,e)]) ->
   452:         ge' e
   453: 
   454:       | `BBDCL_cstruct _
   455:       | `BBDCL_struct _
   456:       | `BBDCL_reglex _
   457:       | `BBDCL_regmatch _
   458:       | `BBDCL_function _
   459:       | `BBDCL_procedure _
   460:       | `BBDCL_fun _
   461:       | `BBDCL_proc _ ->
   462:          syserr sr
   463:          (
   464:            "[gen_expr: name] Open function '" ^
   465:            id ^ "'<"^si index^
   466:            "> in expression (closure required)"
   467:          )
   468:       | _ ->
   469:         syserr sr
   470:         (
   471:           "[gen_expr: name] Cannot use this kind of name '"^
   472:           id^"' in expression"
   473:         )
   474:     end
   475: 
   476:   | `BEXPR_closure (index,ts') ->
   477:     (*
   478:     print_endline ("Generating closure of " ^ si index);
   479:     *)
   480:     let id,parent,sr,entry =
   481:       try Hashtbl.find bbdfns index
   482:       with _ -> failwith ("[gen_expr(name)] Can't find index " ^ si index)
   483:     in
   484:     (*
   485:     Should not be needed now ..
   486:     let ts = adjust_ts syms index ts' in
   487:     *)
   488:     let ts = map tsub ts' in
   489:     begin match entry with
   490:     | `BBDCL_function (props,_,_,_,_)
   491:     | `BBDCL_procedure (props,_,_,_) ->
   492:       let the_display =
   493:         let d' =
   494:           map (fun (i,vslen) -> "ptr"^ cpp_instance_name syms bbdfns i (list_prefix ts vslen))
   495:           (get_display_list bbdfns index)
   496:         in
   497:           if length d' > our_level
   498:           then "this" :: tl d'
   499:           else d'
   500:       in
   501:       let name = cpp_instance_name syms bbdfns index ts in
   502:       ce_atom (
   503:       "(FLX_NEWP("^name^")" ^ strd the_display props ^")"
   504:       )
   505: 
   506:     | `BBDCL_callback _ ->
   507:       print_endline "Mapping closure of callback to C function pointer";
   508:       ce_atom id
   509: 
   510:     | `BBDCL_cstruct _
   511:     | `BBDCL_struct _
   512:     | `BBDCL_fun _
   513:     | `BBDCL_proc _ ->
   514:       failwith ("[gen_expr: closure] Can't wrap primitive proc, fun, or struct '"^id^"' yet")
   515:     | _ -> failwith ("[gen_expr: closure] Cannot use this kind of name '"^id^"' in expression")
   516:     end
   517: 
   518:   | `BEXPR_apply_method_stack (obj,meth,ts',a) ->
   519:     let id,parent,sr2,entry =
   520:       try Hashtbl.find bbdfns meth
   521:       with _ -> failwith ("[gen_expr(apply instance)] Can't find index " ^ si meth)
   522:     in
   523:     begin
   524:     (*
   525:     print_endline ("apply method closure of "^ id );
   526:     print_endline ("  .. argument is " ^ string_of_bound_expression syms.dfns a);
   527:     *)
   528:     match entry with
   529:     | `BBDCL_function (props,_,_,_,_) ->
   530:       (*
   531:       print_endline ("Generating closure[apply method stack] of " ^ si meth);
   532:       *)
   533:       let ts = map tsub ts' in
   534:       let the_display =
   535:         let d' =
   536:           map (fun (i,vslen)-> "ptr"^ cpp_instance_name syms bbdfns i (list_prefix ts vslen))
   537:           (get_display_list bbdfns meth)
   538:         in
   539:           let d' = tl d' in (* throw out class pointer *)
   540:           if length d' > our_level
   541:           then "this" :: tl d'
   542:           else d'
   543:       in
   544:       let class_frame = ge obj in
   545:       let the_display = class_frame :: the_display in
   546:       let name = cpp_instance_name syms bbdfns meth ts in
   547:       ce_atom (
   548:       name ^ strd the_display props ^
   549:       "\n      .apply(" ^ ge_arg a ^ ")"
   550:       )
   551:     | _ ->
   552:       failwith
   553:       (
   554:         "[gen_expr: apply_method_stack] Expected '"^id^"' to be generic function instance, got:\n" ^
   555:         string_of_bbdcl syms.dfns entry meth
   556:       )
   557:    end
   558: 
   559:   | `BEXPR_apply_method_direct (obj,meth,ts',a) ->
   560:     let id,parent,sr2,entry =
   561:       try Hashtbl.find bbdfns meth
   562:       with _ -> failwith ("[gen_expr(apply instance)] Can't find index " ^ si meth)
   563:     in
   564:     begin
   565:     (*
   566:     print_endline ("apply method closure of "^ id );
   567:     print_endline ("  .. argument is " ^ string_of_bound_expression syms.dfns a);
   568:     *)
   569:     match entry with
   570:     | `BBDCL_function (props,_,_,_,_) ->
   571:       (*
   572:       print_endline ("Generating closure[apply method direct] of " ^ si meth);
   573:       *)
   574:       let ts = map tsub ts' in
   575:       let the_display =
   576:         let d' =
   577:           map (fun (i,vslen)-> "ptr"^ cpp_instance_name syms bbdfns i (list_prefix ts vslen))
   578:           (get_display_list bbdfns meth)
   579:         in
   580:           let d' = tl d' in (* throw out class pointer *)
   581:           if length d' > our_level
   582:           then "this" :: tl d'
   583:           else d'
   584:       in
   585:       let class_frame = ge obj in
   586:       let the_display = class_frame :: the_display in
   587:       let name = cpp_instance_name syms bbdfns meth ts in
   588:       ce_atom (
   589:       "(FLX_NEWP("^name^")"^ strd the_display props ^")"^
   590:       "\n      ->apply(" ^ ge_arg a ^ ")"
   591:       )
   592: 
   593:     | _ ->
   594:       failwith
   595:       (
   596:         "[gen_expr: apply_method_direct] Expected '"^id^"' to be generic function instance, got:\n" ^
   597:         string_of_bbdcl syms.dfns entry meth
   598:       )
   599:     end
   600: 
   601:   | `BEXPR_method_closure (e,index,ts') ->
   602:     (*
   603:     print_endline ("Generating method closure of " ^ si index);
   604:     *)
   605:     let id,parent,sr,entry =
   606:       try Hashtbl.find bbdfns index
   607:       with _ -> failwith ("[gen_expr(name)] Can't find index " ^ si index)
   608:     in
   609:     (*
   610:     Should not be needed now ..
   611:     let ts = adjust_ts syms index ts' in
   612:     *)
   613:     let ts = map tsub ts' in
   614:     begin match entry with
   615:     | `BBDCL_function (props,_,_,_,_)
   616:     | `BBDCL_procedure (props,_,_,_) ->
   617:       (*
   618:       print_endline ("Method " ^ id ^ (
   619:         if mem `Requires_ptf props then
   620:           " REQUIRES PTF" else " DOES NOT REQUIRE PTF"
   621:         )
   622:       );
   623:       *)
   624:       let the_display =
   625:         let d' =
   626:           map (fun (i,vslen) -> "ptr"^ cpp_instance_name syms bbdfns i (list_prefix ts vslen))
   627:           (get_display_list bbdfns index)
   628:         in
   629:         let d' = tl d' in (* throw out class pointer *)
   630: 
   631:           (*
   632:           print_endline ("Generated display is " ^ cat ", " d');
   633:           print_endline ("Display length = " ^ si (length d') ^ " .. our level = " ^ si our_level);
   634:           *)
   635: 
   636:           assert (length d' >= our_level);
   637:           if length d' > our_level
   638:           then "this" :: tl d'
   639:           else d'
   640:       in
   641:       (* A method closure requires the last entry in the display
   642:          to be the class. If we're cross calling from one
   643:          method to another, we should automatically get the
   644:          parent class environment, but I'm not sure ..
   645:       *)
   646:       let class_frame = ge e in
   647:       let the_display = class_frame :: the_display in
   648:       let name = cpp_instance_name syms bbdfns index ts in
   649:       ce_atom (
   650:       "(FLX_NEWP("^name^")" ^ strd the_display props ^")"
   651:       )
   652: 
   653:     | `BBDCL_cstruct _
   654:     | `BBDCL_struct _
   655:     | `BBDCL_fun _
   656:     | `BBDCL_proc _ ->
   657:       failwith ("[gen_expr: closure] Can't wrap primitive proc, fun, or struct '"^id^"' yet")
   658:     | _ -> failwith ("[gen_expr: closure] Cannot use this kind of name '"^id^"' in expression")
   659:     end
   660: 
   661:   | `BEXPR_ref (index,ts') ->
   662:     let ts = map tsub ts' in
   663:     let t = lower t in
   664:     let ref_type = tn (lower t) in
   665:     let frame_ptr, var_ptr =
   666:       match t with
   667:       | `BTYP_tuple [] -> "NULL","0"
   668:       | _ ->
   669:         let parent = match Hashtbl.find bbdfns index with _,parent,sr,_ -> parent in
   670:         if Some this = parent &&
   671:         (
   672:           let props = match entry with
   673:             | `BBDCL_procedure (props,_,_,_)
   674:             | `BBDCL_function (props,_,_,_,_) -> props
   675:             | _ -> assert false
   676:           in
   677:           mem `Pure props && not (mem `Heap_closure props)
   678:         )
   679:         then
   680:           "NULL","&"^get_var_ref syms bbdfns this index ts ^"-NULL"
   681:         else
   682:           get_var_frame syms bbdfns this index ts,
   683:           "&" ^ get_var_ref syms bbdfns this index ts
   684:     in
   685:     let reference = ref_type ^
   686:       "(" ^ frame_ptr ^ ", " ^ var_ptr ^ ")"
   687:     in
   688:     ce_atom reference
   689: 
   690:   (* Hackery -- we allow a constructor with no
   691:      arguments to be applied to a unit anyhow
   692:   *)
   693: 
   694:   | `BEXPR_variant (s,((_,t') as e)) ->
   695:     print_endline ("Variant " ^ s);
   696:     print_endline ("Type " ^ sbt syms.dfns t);
   697:     let
   698:       arg_typename = tn t' and
   699:       union_typename = tn t
   700:     in
   701:     let aval =
   702:       "new (*PTF gc, "^arg_typename^"_ptr_map) " ^
   703:       arg_typename ^ "(" ^ ge_arg e ^ ")"
   704:     in
   705:     let ls = match t with
   706:       | `BTYP_variant ls -> ls
   707:       | _ -> failwith "[egen] Woops variant doesn't have variant type"
   708:     in
   709:     let vidx = match list_assoc_index ls s with
   710:       | Some i -> i
   711:       | None -> failwith "[egen] Woops, variant field not in type"
   712:     in
   713:     print_endline ("Index " ^ si vidx);
   714:     let uval = "_uctor_("^si vidx^"," ^ aval ^")"  in
   715:     ce_atom uval
   716: 
   717:   | `BEXPR_coerce ((srcx,srct) as srce,dstt) ->
   718:     let srct = lstrip syms.dfns srct in
   719:     let vts =
   720:       match dstt with
   721:       | `BTYP_variant ls -> ls
   722:       | _ -> syserr sr "Coerce non-variant"
   723:     in
   724:     begin match srcx with
   725:     | `BEXPR_variant (s,argt) ->
   726:       print_endline "Coerce known variant!";
   727:       ge' (`BEXPR_variant (s,argt),t)
   728:     | _ ->
   729:       let i =
   730:         begin try
   731:           Hashtbl.find syms.variant_map (srct,dstt)
   732:         with Not_found ->
   733:           let i = !(syms.counter) in incr (syms.counter);
   734:           Hashtbl.add syms.variant_map (srct,dstt) i;
   735:           i
   736:       end
   737:       in
   738:       ce_atom ("_uctor_(vmap_"^si i^","^ge srce^")")
   739:     end
   740: 
   741:   | `BEXPR_apply
   742:      (
   743:        (`BEXPR_case (v,t),t'),
   744:        (a,t'')
   745:      ) ->
   746:        (* t is the type of the sum,
   747:           t' is the function type of the constructor,
   748:           t'' is the type of the argument
   749:        *)
   750:        let
   751:          arg_typename = tn (lower t'')
   752:        and
   753:          union_typename = tn (lower t)
   754:        in
   755:        let aval =
   756:          "new (*PTF gc, "^arg_typename^"_ptr_map) " ^
   757:          arg_typename ^ "(" ^ ge_arg (a,t'') ^ ")"
   758:        in
   759:        let uval =
   760:          if is_unitsum t then
   761:            si v
   762:          else
   763:          "_uctor_(" ^ si v ^ ", " ^ aval ^")"
   764:        in
   765:        let s = "(" ^ union_typename ^ ")" ^ uval in
   766:        ce_atom s
   767: 
   768:        (*
   769:        failwith
   770:        (
   771:          "Trapped application, case " ^
   772:          si v ^
   773:          " of " ^ string_of_btypecode syms.dfns t ^
   774:          "\ntype " ^ string_of_btypecode syms.dfns t' ^
   775:          "\nargument=" ^
   776:          string_of_bound_expression syms.dfns (a,t'') ^
   777:          "\ntype " ^ string_of_btypecode syms.dfns t''
   778:        )
   779:       *)
   780: 
   781: 
   782:   | `BEXPR_apply_prim (index,ts,(arg,argt as a)) ->
   783:     (*
   784:     print_endline ("Prim apply, arg=" ^ sbe syms.dfns a);
   785:     *)
   786:     let argt = tsub argt in
   787:     let id,parent,sr2,entry =
   788:       try Hashtbl.find bbdfns index
   789:       with _ -> failwith ("[gen_expr(apply instance)] Can't find index " ^ si index)
   790:     in
   791:     begin
   792:     match entry with
   793:     | `BBDCL_fun (props,vs,ps,retyp,ct,_,prec) ->
   794:       if length vs <> length ts then
   795:       failwith
   796:       (
   797:         "[get_expr:apply closure of fun] function " ^
   798:         id ^ "<" ^ si index ^">" ^
   799:         ", wrong number of args, expected vs = " ^
   800:         si (length vs) ^
   801:         ", got ts=" ^
   802:         si (length ts)
   803:       );
   804:       begin match ct with
   805:       | `Str s -> ce_expr prec s
   806:       | `StrTemplate s ->
   807:         let ts = map tsub ts in
   808:         let retyp = reduce_type (beta_reduce syms [] (lstrip syms.dfns (tsubst vs ts retyp))) in
   809:         let retyp = tn retyp in
   810:         gen_prim_call syms bbdfns tsub ge'' s ts (arg,argt) retyp sr sr2 prec
   811:       end
   812: 
   813:     | `BBDCL_callback (props,vs,ps_cf,ps_c,_,retyp,_,_) ->
   814:       assert (retyp <> `BTYP_void);
   815:       if length vs <> length ts then
   816:       clierr sr "[gen_prim_call] Wrong number of type arguments"
   817:       ;
   818:       let ts = map tsub ts in
   819:       let s = id ^ "($a)" in
   820:       let retyp = reduce_type (beta_reduce syms [] (lstrip syms.dfns (tsubst vs ts retyp))) in
   821:       let retyp = tn retyp in
   822:       gen_prim_call syms bbdfns tsub ge'' s ts (arg,argt) retyp sr sr2 "atom"
   823: 
   824:     (* but can't be a Felix function *)
   825:     | _ ->
   826:       failwith
   827:       (
   828:         "[gen_expr: apply prim] Expected '"^id^"' to be primitive function instance, got:\n" ^
   829:         string_of_bbdcl syms.dfns entry index
   830:       )
   831:     end
   832: 
   833:   | `BEXPR_apply_struct (index,ts,a) ->
   834:     let id,parent,sr2,entry =
   835:       try Hashtbl.find bbdfns index
   836:       with _ -> failwith ("[gen_expr(apply instance)] Can't find index " ^ si index)
   837:     in
   838:     let ts = map tsub ts in
   839:     begin match entry with
   840:     | `BBDCL_cstruct (vs,_) ->
   841:       let name = tn (`BTYP_inst (index,ts)) in
   842:       ce_atom ("reinterpret<"^ name ^">(" ^ ge a ^ ")")
   843: 
   844:     | `BBDCL_struct (vs,cts) ->
   845:       let name = tn (`BTYP_inst (index,ts)) in
   846:       if length cts > 1 then
   847:         (* argument must be an lvalue *)
   848:         ce_atom ("reinterpret<"^ name ^">(" ^ ge a ^ ")")
   849:       else if length cts = 0 then
   850:         ce_atom (name ^ "()")
   851:       else
   852:         ce_atom (name ^ "(" ^ ge a ^ ")")
   853: 
   854:     | `BBDCL_nonconst_ctor (vs,uidx,udt,cidx,ct) ->
   855:       (* due to some hackery .. the argument of a non-const
   856:          ctor can STILL be a unit .. prolly cause the stupid
   857:          compiler is checking for voids for these pests,
   858:          but units for sums .. hmm .. inconsistent!
   859:       *)
   860:       let ts = map tsub ts in
   861:       let ct = reduce_type (beta_reduce syms [] (tsubst vs ts ct)) in
   862:       let _,t = a in
   863:       let t = reduce_type (beta_reduce syms [] (tsubst vs ts t)) in
   864:       begin match t with
   865:       | `BTYP_tuple [] ->
   866:         ce_atom ( "_uctor_(" ^ si cidx ^ ", NULL)")
   867: 
   868:       (* function types are already pointers .. any use of this
   869:          should do a clone ..
   870:       *)
   871:       | `BTYP_function _ ->
   872:         ce_atom (
   873:           "_uctor_(" ^ si cidx ^ ", " ^ ge a ^")"
   874:         )
   875: 
   876:       | _ ->
   877:         let ctt = tn ct in
   878:         let ptrmap = shape_of bbdfns tn ct in
   879:         ce_atom (
   880:           "_uctor_(" ^ si cidx ^ ", new(*PTF gc,"^ ptrmap^")"^
   881:           ctt ^"("^ ge a ^"))"
   882:         )
   883:       end
   884:     | _ -> assert false
   885:     end
   886: 
   887:   | `BEXPR_apply_direct (index,ts,a) ->
   888:     let id,parent,sr2,entry =
   889:       try Hashtbl.find bbdfns index
   890:       with _ -> failwith ("[gen_expr(apply instance)] Can't find index " ^ si index)
   891:     in
   892:     begin
   893:     (*
   894:     print_endline ("apply closure of "^ id );
   895:     print_endline ("  .. argument is " ^ string_of_bound_expression syms.dfns a);
   896:     *)
   897:     match entry with
   898:     | `BBDCL_regmatch (props,_,_,_,_)
   899:     | `BBDCL_reglex (props,_,_,_,_,_)
   900:     | `BBDCL_function (props,_,_,_,_) ->
   901:       (*
   902:       print_endline ("Generating closure[apply direct] of " ^ si index);
   903:       *)
   904:       let ts = map tsub ts in
   905:       let the_display =
   906:         let d' =
   907:           map (fun (i,vslen)-> "ptr"^ cpp_instance_name syms bbdfns i (list_prefix ts vslen))
   908:           (get_display_list bbdfns index)
   909:         in
   910:           if length d' > our_level
   911:           then "this" :: tl d'
   912:           else d'
   913:       in
   914:       let name = cpp_instance_name syms bbdfns index ts in
   915:       ce_atom (
   916:       "(FLX_NEWP("^name^")"^ strd the_display props ^")"^
   917:       "\n      ->apply(" ^ ge_arg a ^ ")"
   918:       )
   919: 
   920:     | `BBDCL_fun _ -> assert false
   921:     (*
   922:       ge' (`BEXPR_apply_prim (index,ts,a),t)
   923:     *)
   924: 
   925:     | _ ->
   926:       failwith
   927:       (
   928:         "[gen_expr: apply_direct] Expected '"^id^"' to be generic function instance, got:\n" ^
   929:         string_of_bbdcl syms.dfns entry index
   930:       )
   931:     end
   932: 
   933:   | `BEXPR_apply_stack (index,ts,a) ->
   934:     let id,parent,sr2,entry =
   935:       try Hashtbl.find bbdfns index
   936:       with _ -> failwith ("[gen_expr(apply instance)] Can't find index " ^ si index)
   937:     in
   938:     begin
   939:     (*
   940:     print_endline ("apply closure of "^ id );
   941:     print_endline ("  .. argument is " ^ string_of_bound_expression syms.dfns a);
   942:     *)
   943:     match entry with
   944:     | `BBDCL_function (props,vs,(ps,traint),retyp,_) ->
   945:       let ts = map tsub ts in
   946:       let display = get_display_list bbdfns index in
   947:       let name = cpp_instance_name syms bbdfns index ts in
   948: 
   949:       (* C FUNCTION CALL *)
   950:       if mem `Pure props && not (mem `Heap_closure props) then
   951:         let s =
   952:           assert (length display = 0);
   953:           match ps with
   954:           | [] -> ""
   955:           | [_,(ix,t)] ->
   956:             if Hashtbl.mem syms.instances (ix,ts)
   957:             then ge_arg a
   958:             else ""
   959: 
   960:           | _ ->
   961:             begin match a with
   962:             | `BEXPR_tuple xs,_ ->
   963:               (*
   964:               print_endline ("Arg to C function is tuple " ^ sbe syms.dfns a);
   965:               *)
   966:               fold_left2
   967:               (fun s ((x,t) as xt) (_,(ix,_)) ->
   968:                 let x =
   969:                   if Hashtbl.mem syms.instances (ix,ts)
   970:                   then ge_arg xt
   971:                   else ""
   972:                 in
   973:                 if String.length x = 0 then s else
   974:                 s ^
   975:                 (if String.length s > 0 then ", " else "") ^ (* append a comma if needed *)
   976:                 x
   977:               )
   978:               ""
   979:               xs ps
   980: 
   981:             | _,tt ->
   982:               let tt = reduce_type (beta_reduce syms [] (lstrip syms.dfns (tsubst vs ts tt))) in
   983:               (* NASTY, EVALUATES EXPR MANY TIMES .. *)
   984:               let n = ref 0 in
   985:               fold_left
   986:               (fun s i ->
   987:                 (*
   988:                 print_endline ( "ps = " ^ catmap "," (fun (id,(p,t)) -> id) ps);
   989:                 print_endline ("tt=" ^ sbt syms.dfns tt);
   990:                 *)
   991:                 let t = nth_type tt i in
   992:                 let a' = `BEXPR_get_n (i,a),t in
   993:                 let x = ge_arg a' in
   994:                 incr n;
   995:                 if String.length x = 0 then s else
   996:                 s ^ (if String.length s > 0 then ", " else "") ^ x
   997:               )
   998:               ""
   999:               (nlist (length ps))
  1000:             end
  1001:         in
  1002:         let s =
  1003:           if mem `Requires_ptf props then
  1004:             if String.length s > 0 then "FLX_FPAR_PASS " ^ s
  1005:             else "FLX_FPAR_PASS_ONLY"
  1006:           else s
  1007:         in
  1008:           ce_atom (name ^ "(" ^ s ^ ")")
  1009:       else
  1010:         let the_display =
  1011:           let d' =
  1012:             map (fun (i,vslen)-> "ptr"^ cpp_instance_name syms bbdfns i (list_prefix ts vslen))
  1013:             display
  1014:           in
  1015:             if length d' > our_level
  1016:             then "this" :: tl d'
  1017:             else d'
  1018:         in
  1019:         let s =
  1020:           name^ strd the_display props
  1021:           ^
  1022:           "\n      .apply(" ^ ge_arg a ^ ")"
  1023:         in ce_atom s
  1024: 
  1025:     | _ ->
  1026:       failwith
  1027:       (
  1028:         "[gen_expr: apply_stack] Expected '"^id^"' to be generic function instance, got:\n" ^
  1029:         string_of_bbdcl syms.dfns entry index
  1030:       )
  1031:     end
  1032: 
  1033:   | `BEXPR_apply ((`BEXPR_closure (index,ts),_),a) ->
  1034:     assert false (* should have been factored out *)
  1035: 
  1036:   (* application of C function pointer, type
  1037:      f: a --> b
  1038:   *)
  1039:   | `BEXPR_apply ( (_,`BTYP_cfunction _) as f,a) ->
  1040:     ce_atom (
  1041:     (ge f) ^"(" ^ ge_arg a ^ ")"
  1042:     )
  1043: 
  1044:   (* General application*)
  1045:   | `BEXPR_apply (f,a) ->
  1046:     ce_atom (
  1047:     (ge f) ^ "->clone()\n      ->apply(" ^ ge_arg a ^ ")"
  1048:     )
  1049: 
  1050:   | `BEXPR_record es ->
  1051:     let rcmp (s1,_) (s2,_) = compare s1 s2 in
  1052:     let es = sort rcmp es in
  1053:     let es = map snd es in
  1054:     let ctyp = tn (lower t) in
  1055:     ce_atom (
  1056:     ctyp ^ "(" ^
  1057:       fold_left
  1058:       (fun s e ->
  1059:         let x = ge_arg e in
  1060:         if String.length x = 0 then s else
  1061:         s ^
  1062:         (if String.length s > 0 then ", " else "") ^
  1063:         x
  1064:       )
  1065:       ""
  1066:       es
  1067:     ^
  1068:     ")"
  1069:     )
  1070: 
  1071:   | `BEXPR_tuple es ->
  1072:     (*
  1073:     print_endline ("Eval tuple " ^ sbe syms.dfns (e,t));
  1074:     *)
  1075:     (* just apply the tuple type ctor to the arguments *)
  1076:     begin match t with
  1077:     | `BTYP_array (t',`BTYP_unitsum n) ->
  1078:       let tuple =
  1079:         let t'' = `BTYP_tuple (map (fun _ -> t') (nlist n)) in
  1080:         let ctyp = raw_typename t'' in
  1081:         ce_atom (
  1082:         ctyp ^ "(" ^
  1083:           fold_left
  1084:           (fun s e ->
  1085:             let x = ge_arg e in
  1086:             if String.length x = 0 then s else
  1087:             s ^
  1088:             (if String.length s > 0 then ", " else "") ^
  1089:             x
  1090:           )
  1091:           ""
  1092:           es
  1093:         ^
  1094:         ")"
  1095:         )
  1096:       in
  1097:         (* cast a tuple which is an array type to an array *)
  1098:         let atyp = tn (lower t) in
  1099:         ce_call
  1100:           (ce_atom ("reinterpret<" ^ atyp ^">"))
  1101:           [tuple]
  1102: 
  1103:     | `BTYP_tuple _ ->
  1104:       let ctyp = tn (lower t) in
  1105:       ce_atom (
  1106:       ctyp ^ "(" ^
  1107:         fold_left
  1108:         (fun s e ->
  1109:           let x = ge_arg e in
  1110:           if String.length x = 0 then s else
  1111:           s ^
  1112:           (if String.length s > 0 then ", " else "") ^
  1113:           x
  1114:         )
  1115:         ""
  1116:         es
  1117:       ^
  1118:       ")"
  1119:       )
  1120:     | _ -> assert false
  1121:     end
  1122: 
  1123: and gen_expr syms bbdfns this e vs ts sr =
  1124:   let e = Flx_maps.reduce_tbexpr bbdfns e in
  1125:   let s =
  1126:     try gen_expr' syms bbdfns this e vs ts sr
  1127:     with Unknown_prec p -> clierr sr
  1128:     ("[gen_expr] Unknown precedence name '"^p^"' in " ^ sbe syms.dfns e)
  1129:   in
  1130:   string_of_cexpr s
  1131: 
  1132: 
End ocaml section to src/flx_egen.ml[1]
Start ocaml section to src/flx_ctorgen.mli[1 /1 ]
     1: # 3 "./lpsrc/flx_ctorgen.ipk"
     2: open Flx_ast
     3: open Flx_types
     4: open Flx_mtypes1
     5: open Flx_mtypes2
     6: open Flx_label
     7: 
     8: val gen_ctor:
     9:   sym_state_t ->
    10:   fully_bound_symbol_table_t ->
    11:   string ->                   (* name *)
    12:   (int * int) list ->         (* display *)
    13:   (int * btypecode_t) list -> (* funs *)
    14:   (string * string) list ->   (* extra args *)
    15:   string list ->              (* extra inits *)
    16:   btypecode_t list ->         (* ts *)
    17:   property_t list ->          (* properties *)
    18:   string
    19: 
End ocaml section to src/flx_ctorgen.mli[1]
Start ocaml section to src/flx_ctorgen.ml[1 /1 ]
     1: # 23 "./lpsrc/flx_ctorgen.ipk"
     2: open Flx_util
     3: open Flx_ast
     4: open Flx_types
     5: open Flx_mtypes1
     6: open Flx_mtypes2
     7: open Flx_print
     8: open Flx_typing
     9: open Flx_name
    10: open Flx_tgen
    11: open Flx_unify
    12: open Flx_csubst
    13: open Flx_exceptions
    14: open Flx_display
    15: open List
    16: open Flx_generic
    17: open Flx_label
    18: open Flx_unravel
    19: open Flx_ogen
    20: open Flx_ctypes
    21: open Flx_cexpr
    22: open Flx_maps
    23: 
    24: let gen_ctor syms bbdfns name display funs extra_args extra_inits ts props =
    25:   let requires_ptf = mem `Requires_ptf props in
    26:   name^"::"^name^
    27:   (if length display + length extra_args = 0 then
    28:   (if requires_ptf then "(FLX_FPAR_DECL_ONLY)" else "()")
    29:   else
    30:   "\n  (\n" ^
    31:   (if requires_ptf then
    32:   "    FLX_FPAR_DECL\n"
    33:   else ""
    34:   )
    35:   ^
    36:   cat ",\n"
    37:   (
    38:     map
    39:     (
    40:       fun (i,vslen) ->
    41:         let instname = cpp_instance_name syms bbdfns i (list_prefix ts vslen) in
    42:       "    " ^ instname ^ " *pptr" ^ instname
    43:     )
    44:     display
    45:     @
    46:     map
    47:     (
    48:       fun (t,a) -> "    " ^ t ^ " _"^a
    49:     )
    50:     extra_args
    51:   )^
    52:   "\n  )\n"
    53:   )
    54:   ^
    55:   (if length display + length funs + length extra_args + length extra_inits = 0
    56:   then (if requires_ptf then "FLX_FMEM_INIT_ONLY" else "")
    57:   else
    58:   (if requires_ptf then
    59:   "  FLX_FMEM_INIT "
    60:   else " : "
    61:   )
    62:   ^
    63:   cat ",\n"
    64:   (
    65:     map
    66:     (
    67:       fun (i,vslen) -> let instname = cpp_instance_name syms bbdfns i (list_prefix ts vslen) in
    68:       "  ptr" ^ instname ^ "(pptr"^instname^")"
    69:     )
    70:     display
    71:     @
    72:     map
    73:     (fun (index,t)->
    74:       cpp_instance_name syms bbdfns index ts
    75:       ^ "(0)"
    76:     )
    77:     funs
    78:     @
    79:     map
    80:     (fun (t,a) -> "  " ^a ^ "(_"^a^")")
    81:     extra_args
    82:     @
    83:     map
    84:     (fun x -> "  " ^x)
    85:     extra_inits
    86:   )) ^
    87:   " {}\n"
    88: 
    89: 
End ocaml section to src/flx_ctorgen.ml[1]
Start ocaml section to src/flx_elkgen.mli[1 /1 ]
     1: # 3 "./lpsrc/flx_elkgen.ipk"
     2: open Flx_ast
     3: open Flx_types
     4: open Flx_mtypes1
     5: open Flx_mtypes2
     6: open Flx_label
     7: open Flx_ctorgen
     8: 
     9: val gen_elk_parser:
    10:   string ->
    11:   string ->
    12:   sym_state_t ->
    13:   fully_bound_symbol_table_t ->
    14:   int ->
    15:   range_srcref ->
    16:   btypecode_t ->
    17:   int ->
    18:   int list ->
    19:   unit
    20: 
    21: val gen_elk_lexer:
    22:   string ->
    23:   string ->
    24:   sym_state_t ->
    25:   fully_bound_symbol_table_t ->
    26:   int ->
    27:   range_srcref ->
    28:   tbexpr_t ->
    29:   int ->
    30:   unit
    31: 
    32: 
End ocaml section to src/flx_elkgen.mli[1]
Start ocaml section to src/flx_elkgen.ml[1 /1 ]
     1: # 36 "./lpsrc/flx_elkgen.ipk"
     2: open Flx_util
     3: open Flx_ast
     4: open Flx_types
     5: open Flx_mtypes1
     6: open Flx_mtypes2
     7: open Flx_print
     8: open Flx_typing
     9: open Flx_name
    10: open Flx_tgen
    11: open Flx_unify
    12: open Flx_csubst
    13: open Flx_exceptions
    14: open Flx_display
    15: open List
    16: open Flx_generic
    17: open Flx_label
    18: open Flx_unravel
    19: open Flx_ogen
    20: open Flx_ctypes
    21: open Flx_cexpr
    22: open Flx_maps
    23: open Flx_egen
    24: open Flx_pgen
    25: open Flx_ctorgen
    26: 
    27: let gen_elk_lexer filebase module_name syms bbdfns this sr ((_,t') as e) n  =
    28:   let lexer_name = "ElkLex_"^si n in
    29:   let ge e = gen_expr syms bbdfns this e [] [] sr in
    30:   let tn t = cpp_typename syms t in
    31:   let get_token_fun_type = tn t' in
    32: 
    33:   let display = cal_display bbdfns (Some this) in
    34:   let frame_dcls =
    35:     "  FLX_FMEM_DECL\n"
    36:   in
    37:   let display_string =
    38:     cat ""
    39:     (
    40:       map
    41:       (fun (i, vslen) ->
    42:        try
    43:        let instname = cpp_instance_name syms bbdfns i [] in
    44:        "  " ^ instname ^ " *ptr" ^ instname ^ ";\n"
    45:        with _ -> failwith "Can't cal display name"
    46:        )
    47:       display
    48:     )
    49:   and ctor_dcl =
    50:     "  "^lexer_name ^ "(\n" ^
    51:     "    FLX_FPAR_DECL\n" ^
    52:     cat ""
    53:     (
    54:       map
    55:       (
    56:         fun (i,vslen) ->
    57:         let instname = cpp_instance_name syms bbdfns i [] in
    58:         "    " ^ instname ^ "*,\n"
    59:       )
    60:       display
    61:     )^
    62:     "    "^get_token_fun_type ^"\n  );\n"
    63:   in
    64:   let filename = filebase ^ "_lexer_" ^ si n ^ ".hpp" in
    65:   if syms.compiler_options.print_flag then
    66:   print_endline ("Generating Elkhound lexer " ^ lexer_name ^ " in " ^ filename);
    67: 
    68:   let f = open_out filename in
    69:   let pe s = output_string f (s ^ "\n") in
    70: 
    71:   let token_type, token_type_name, token_id, cts =
    72:     match t' with
    73:     | `BTYP_function (`BTYP_tuple [],`BTYP_inst(i,[])) ->
    74:       let id,parent,sr',entry = Hashtbl.find bbdfns i in
    75:       let token_type = `BTYP_inst(i,[]) in
    76:       let token_type_name = tn token_type in
    77:       begin match entry with
    78:       | `BBDCL_union ([],cts) -> token_type, token_type_name, id, cts
    79:       | _ -> assert false
    80:       end
    81:     | _ -> assert false
    82:   in
    83:   pe ("#ifndef ELKLEX_"^si n);
    84:   pe ("#define ELKLEX_"^si n);
    85:   pe "#include \"elk_lexerint.h\"";
    86:   pe "";
    87:   pe ("struct "^lexer_name^": public LexerInterface {");
    88:   pe ("  //frame");
    89:   pe frame_dcls;
    90:   pe ("  //display");
    91:   pe display_string;
    92:   pe ("  // constructor");
    93:   pe ctor_dcl;
    94:   pe ("  " ^ get_token_fun_type ^ " get_token; // client token generator");
    95:   pe ("  collector_t &gc; // Felix garbage collector");
    96:   pe "  void setToken();  //fetch next token ";
    97:   pe ("  "^lexer_name^" *init(); //prime the lexer");
    98:   pe "";
    99:   pe "  //Elkhound API";
   100:   pe "  static void nextToken(LexerInterface *lex);";
   101:   pe "  NextTokenFunc getTokenFunc() const { return &nextToken; }";
   102:   pe "  sm_string tokenDesc() const;";
   103:   pe "  sm_string tokenKindDesc(int kind) const;";
   104:   pe "};";
   105:   pe "#endif";
   106:   close_out f;
   107: 
   108:   let filename = filebase ^ "_lexer_" ^ si n ^ ".cpp" in
   109:   let f = open_out filename in
   110:   let pe s = output_string f (s ^ "\n") in
   111:   pe ("#include \""^module_name^"_lexer_"^si n^".hpp\"");
   112:   pe ("//token type = " ^ token_type_name);
   113:   pe ("static char *"^token_id^"_desc["^si (length cts)^"]={");
   114:   iter (fun (nm,_,_) -> pe ("   \""^nm^"\",")) cts;
   115:   pe ("};");
   116:   pe "";
   117:   (* FUDGE PROPERTY LIST *)
   118:   let props : property_t list = [`Uses_gc; `Requires_ptf] in
   119:   pe (gen_ctor syms bbdfns lexer_name display [] [get_token_fun_type,"get_token"] ["gc(*PTF gc)"] [] props);
   120:   pe ("sm_string " ^ lexer_name ^ "::tokenDesc() const { return tokenKindDesc(type); }");
   121:   pe "";
   122:   pe ("sm_string " ^ lexer_name ^ "::tokenKindDesc(int kind) const {");
   123:   pe ("  return "^token_id^"_desc[kind];");
   124:   pe ("}");
   125:   pe "";
   126:   pe ("void " ^ lexer_name ^ "::setToken() {");
   127:   pe ("  _uctor_ token = get_token->apply();");
   128:   pe ("  type = token.variant;");
   129:   pe ("  sval =  (SemanticValue)token.data;");
   130:   pe ("}");
   131:   pe "";
   132:   pe ("void " ^ lexer_name ^ "::nextToken(LexerInterface *lex) {");
   133:   pe ("  (("^lexer_name^"*)lex)->setToken();");
   134:   pe ("}");
   135:   pe "";
   136:   pe (lexer_name^" *"^lexer_name^"::init(){");
   137:   pe ("  nextToken(this);");
   138:   pe ("  return this;");
   139:   pe ("}");
   140: 
   141:   close_out f
   142: 
   143: let gen_elk_parser filebase module_name syms bbdfns this sr t' n ii =
   144:   let filename = filebase ^ "_parser_" ^ si n ^ ".gr" in
   145:   let parser_name = "_" ^ si n in
   146:   if syms.compiler_options.print_flag then
   147:   print_endline ("Generating Elkhound parser " ^ filename)
   148:   ;
   149:   let f = open_out filename in
   150:   let pe s = output_string f (s ^ "\n") in
   151:   let ps s = output_string f s in
   152:   let ge_arg this ((x,t) as e) =
   153:     match t with
   154:     | `BTYP_tuple [] -> ""
   155:     | _ -> gen_expr syms bbdfns this e [] [] sr
   156:   in
   157:   let tn t = cpp_typename syms (reduce_type t) in
   158:   let string_of_bprod (n,g) =
   159:     (match n with | None -> "" | Some n -> cid_of_flxid n ^ ":") ^
   160:     (match g with
   161:     | `Term k ->
   162:       (match Hashtbl.find syms.dfns k with {id=id}->cid_of_flxid id)
   163:     | `Nonterm (k::_) ->
   164:       (match Hashtbl.find syms.dfns k with {id=id}->cid_of_flxid id)
   165:     | _ -> assert false
   166:     )
   167:   in
   168:   let print_production (this,p,xs) =
   169:     match xs with
   170:     | [`BEXE_fun_return (_,((_,t) as e))] ->
   171:       let t = tn t in
   172:       ps ("  -> ");
   173:       ps (catmap " " string_of_bprod p);
   174:       pe "";
   175:       pe "    {";
   176:       pe ("       "^t^" *_x = new "^t^"(" ^ ge_arg this e ^ ");");
   177:       iter
   178:       (function
   179:         | Some n, `Nonterm _ -> pe ("       delete " ^ n^";")
   180:         | _ -> ()
   181:       )
   182:       p;
   183:       pe ("       return _x;");
   184:       pe "    }";
   185:     | _ -> assert false
   186:   in
   187:   let set_of_list ii : IntSet.t = fold_left (fun s elt ->IntSet.add elt s) IntSet.empty ii in
   188:   let nts_of_prod p : IntSetSet.t =
   189:     fold_left
   190:     (fun x (_,k) -> match k with
   191:       | `Nonterm ii -> IntSetSet.add (set_of_list ii) x
   192:       | `Term _ -> x
   193:     )
   194:     IntSetSet.empty
   195:     p
   196:   in
   197:   let prod_of_glr i =
   198:     try
   199:     match Hashtbl.find bbdfns i with
   200:     | _,_,_,`BBDCL_glr (_,_,_,(p,_)) -> p
   201:     | id,_,_,entry -> failwith
   202:       ("Expected "^si i^"->BBDCL_glr, got " ^ string_of_bbdcl syms.dfns entry i)
   203: 
   204:     with Not_found -> failwith ("Can't find BBDCL_glr " ^ si i)
   205:   in
   206:   let nts_of_glr i : IntSetSet.t = nts_of_prod (prod_of_glr i) in
   207:   let nt_uses x : IntSetSet.t =
   208:     IntSet.fold
   209:     (fun i nts ->
   210:       IntSetSet.union nts (nts_of_glr i)
   211:     )
   212:     x
   213:     IntSetSet.empty
   214:   in
   215:   let make_closure ii =
   216:     let been_done = ref (IntSetSet.singleton (set_of_list ii)) in
   217:     let to_do = ref (nt_uses (set_of_list ii)) in
   218:     while not (IntSetSet.is_empty !to_do) do
   219:       let x = IntSetSet.choose !to_do in
   220:       to_do := IntSetSet.remove x !to_do;
   221:       if not (IntSetSet.mem x !been_done) then begin
   222:         been_done := IntSetSet.add x !been_done;
   223:         to_do := IntSetSet.union !to_do (nt_uses x)
   224:       end
   225:     done;
   226:     !been_done
   227:   in
   228:   let print_nonterm x =
   229:     let j = IntSet.choose x in
   230:     let id,parent,sr'',entry = Hashtbl.find bbdfns j in
   231:     begin match entry with
   232:     | `BBDCL_glr (_,_,t,(p,xs)) ->
   233:       let tt = tn t in
   234:       pe ("nonterm("^tt^"*) "^cid_of_flxid id^" {");
   235:       pe ("  fun dup(x) { return new " ^ tt ^ "(*x); }");
   236:       pe ("  fun del(x) { delete x; }");
   237:       IntSet.iter (fun i ->
   238:         let id,parent,sr'',entry = Hashtbl.find bbdfns i in
   239:         match entry with
   240:         | `BBDCL_glr (_,_,t,(p,xs)) -> print_production (i,p,xs)
   241:         | _ -> assert false
   242:       )
   243:       x;
   244:       pe "}";
   245:     | _ -> assert false
   246:     end
   247:   in
   248:   let display = cal_display bbdfns (Some this) in
   249:   let frame_dcls =
   250:     "  FLX_FMEM_DECL"
   251:   in
   252:   let display_string =
   253:     cat ""
   254:     (
   255:       map
   256:       (fun (i,vslen) ->
   257:        try
   258:        let instname = cpp_instance_name syms bbdfns i [] in
   259:        "  " ^ instname ^ " *ptr" ^ instname ^ ";\n"
   260:        with _ -> failwith "Can't cal display name"
   261:        )
   262:       display
   263:     )
   264:   and ctor_dcl =
   265:     "  Elk" ^parser_name^
   266:     (if length display = 0
   267:     then "(FLX_FPAR_DECL_ONLY);\n"
   268:     else (
   269:     "  (\n" ^
   270:     "    FLX_FPAR_DECL\n " ^
   271:     cat ",\n"
   272:       (
   273:         map
   274:         (
   275:           fun (i,vslen) ->
   276:           let instname = cpp_instance_name syms bbdfns i [] in
   277:           "    " ^ instname ^ "*"
   278:         )
   279:         display
   280:       )^
   281:       "\n  );\n"
   282:     ))
   283:   in
   284:     begin match t' with
   285:     | `BTYP_function (`BTYP_tuple [],`BTYP_inst(i,[])) ->
   286:       let token_id,parent,sr',entry = Hashtbl.find bbdfns i in
   287:       let token_type = `BTYP_inst(i,[]) in
   288:       let token_type_name = tn token_type in
   289:       begin match entry with
   290:       | `BBDCL_union ([],cts) ->
   291:         let j = hd ii in
   292:         let id,parent,sr'',entry = Hashtbl.find bbdfns j in
   293:         begin match entry with
   294:         | `BBDCL_glr (props,_,t,(p,xs)) ->
   295:           let result_type = tn t in
   296:           pe ("//Elkhound parser Elk" ^ parser_name ^ " -> " ^ result_type);
   297:           pe ("//Token type " ^ token_id ^ " -> " ^ token_type_name);
   298:           pe "terminals {";
   299:           let i = ref 0 in
   300:           iter (fun (id,j,t) ->
   301:             pe ("  " ^ si j^" : "^ cid_of_flxid id ^ ";")
   302:           )
   303:           cts;
   304: 
   305:         pe "";
   306:         iter (fun (id,_,t) ->
   307:           if t <> `BTYP_void then begin
   308:             pe ("  token("^tn t^"*) " ^ cid_of_flxid id ^ "{");
   309:             pe ("    fun dup(x) { return x; }");
   310:             pe ("    fun del(x) {}");
   311:             pe ("}");
   312:           end
   313:         )
   314:         cts;
   315: 
   316:         pe "}";
   317:         pe "";
   318:         pe ("context_class Elk"^parser_name^": public UserActions {");
   319:         pe ("public:");
   320:         pe frame_dcls;
   321:         ps display_string;
   322:         pe ctor_dcl;
   323:         pe ("  collector_t &gc;");
   324:         pe
   325:         (
   326:           (if t = `BTYP_tuple [] then "int" else "_uctor_") ^
   327:           " apply(LexerInterface *lex);"
   328:         );
   329:         pe "};";
   330:         pe "";
   331:         pe "impl_verbatim {";
   332:         pe (gen_ctor syms bbdfns ("Elk"^parser_name) display [] [] ["gc(*PTF gc)"] [] props);
   333:         pe "}";
   334:         pe "";
   335:         pe "impl_verbatim {";
   336:         pe "// Felix function to apply the parser to a lexer";
   337:         pe "// This returns a polymorphic option";
   338:         pe "// case 0- Parse failed";
   339:         pe "// case 1- Argument contains parser result";
   340:         pe ("// Type of parser result is " ^ sbt syms.dfns t);
   341: 
   342:         pe
   343:         (
   344:           (if t = `BTYP_tuple [] then "int" else "_uctor_") ^
   345:           " Elk"^parser_name^"::apply(LexerInterface *lex) {"
   346:         );
   347:         pe "  _uctor_ result(0,0);";
   348:         pe "  SemanticValue p=(SemanticValue)(void*)0;";
   349:         pe "  GLR glr(this,this->makeTables());";
   350:         pe "  glr.noisyFailedParse = true;";
   351:         pe "  result.variant = glr.glrParse(*lex,p);";
   352:         pe "";
   353:         pe "  if(result.variant==1)";
   354: 
   355:         if t = `BTYP_tuple [] then begin
   356:         pe "  delete (void*)p;";
   357:         pe "  return result.variant;";
   358:         end else begin
   359:         pe ("    result.data =");
   360:         pe ("      new(gc,"^shape_of bbdfns tn t^")");
   361:         pe ("      "^result_type^"(*("^result_type^"*)(void*)p)");
   362:         pe ("  ;");
   363:         pe "  delete (void*)p;";
   364:         pe "  return result;";
   365:         end;
   366:         pe "}";
   367:         pe "}";
   368:         pe "";
   369: 
   370:         pe ("nonterm("^result_type^"*) elk"^parser_name^" {");
   371:         print_production (j,p,xs);
   372:         iter (fun i ->
   373:           let id,parent,sr'',entry = Hashtbl.find bbdfns i in
   374:           match entry with
   375:           | `BBDCL_glr (_,vs,t,(p,xs)) -> print_production (i,p,xs)
   376:           | _ -> assert false
   377:         )
   378:         (tl ii)
   379:         ;
   380:         pe "}";
   381:         let cls = make_closure ii in
   382:         IntSetSet.iter print_nonterm cls;
   383:         pe "//End grammar"
   384: 
   385:       | _ -> assert false (* must be glr *)
   386:       end
   387: 
   388:     | _ ->
   389:       clierr sr
   390:       "Parser function must have unit domain and return a non-polymorphic union"
   391:     end
   392:   | _ ->
   393:     clierr sr
   394:     "Parser function must have unit domain and return a non-polymorphic union"
   395:   end
   396:   ;
   397:   close_out f
   398:   ;
   399:   let elkhound = syms.compiler_options.elkhound in
   400:   let retval = Unix.system(elkhound ^ " -tr nolines " ^ filename) in
   401:   begin match retval with
   402:   | Unix.WEXITED 0 -> ()
   403:   | _ -> failwith "Error executing flx_elkhound"
   404:   end
   405: 
   406: 
End ocaml section to src/flx_elkgen.ml[1]
//@head(1,'C++ Code generator')
Start ocaml section to src/flx_gen.mli[1 /1 ]
     1: # 4 "./lpsrc/flx_gen.ipk"
     2: open Flx_ast
     3: open Flx_types
     4: open Flx_mtypes1
     5: open Flx_mtypes2
     6: open Flx_label
     7: 
     8: val gen_functions:
     9:   sym_state_t ->
    10:   (bid_t, bid_t list) Hashtbl.t *
    11:   fully_bound_symbol_table_t ->
    12:   string
    13: 
    14: val gen_execute_methods:
    15:   string ->
    16:   sym_state_t ->
    17:   (bid_t, bid_t list) Hashtbl.t *
    18:   fully_bound_symbol_table_t ->
    19:   label_map_t * label_usage_t ->
    20:   int ref ->
    21:   out_channel ->
    22:   unit
    23: 
    24: val find_members:
    25:   sym_state_t ->
    26:   (bid_t, bid_t list) Hashtbl.t *
    27:   fully_bound_symbol_table_t ->
    28:   int ->
    29:   btypecode_t list ->
    30:   string
    31: 
    32: val gen_biface_headers:
    33:   sym_state_t ->
    34:   fully_bound_symbol_table_t ->
    35:   biface_t list ->
    36:   string
    37: 
    38: val gen_biface_bodies:
    39:   sym_state_t ->
    40:   fully_bound_symbol_table_t ->
    41:   biface_t list ->
    42:   string
    43: 
    44: val format_vars:
    45:   sym_state_t ->
    46:   fully_bound_symbol_table_t ->
    47:   bid_t list ->
    48:   btypecode_t list ->
    49:   string
    50: 
    51: val is_gc_pointer:
    52:   sym_state_t ->
    53:   fully_bound_symbol_table_t ->
    54:   range_srcref ->
    55:   btypecode_t ->
    56:   bool
    57: 
End ocaml section to src/flx_gen.mli[1]
Start ocaml section to src/flx_gen.ml[1 /1 ]
     1: # 62 "./lpsrc/flx_gen.ipk"
     2: open Flx_util
     3: open Flx_ast
     4: open Flx_types
     5: open Flx_mtypes1
     6: open Flx_mtypes2
     7: open Flx_print
     8: open Flx_typing
     9: open Flx_name
    10: open Flx_tgen
    11: open Flx_unify
    12: open Flx_csubst
    13: open Flx_exceptions
    14: open Flx_display
    15: open List
    16: open Flx_generic
    17: open Flx_label
    18: open Flx_unravel
    19: open Flx_ogen
    20: open Flx_ctypes
    21: open Flx_cexpr
    22: open Flx_maps
    23: open Flx_egen
    24: open Flx_pgen
    25: open Flx_ctorgen
    26: open Flx_child
    27: open Flx_beta
    28: 
    29: let find_variable_indices syms (child_map,bbdfns) index =
    30:   let children = find_children child_map index in
    31:   filter
    32:   (fun i ->
    33:     try match Hashtbl.find bbdfns i with _,_,_,entry ->
    34:       match entry with
    35:       | `BBDCL_var _
    36:       | `BBDCL_val _ -> true
    37:       | _ -> false
    38:     with Not_found -> false
    39:   )
    40:   children
    41: 
    42: let get_variable_typename syms bbdfns i ts =
    43:   let rt vs t = reduce_type (lstrip syms.dfns (beta_reduce syms [] (tsubst vs ts t))) in
    44:   let id,parent,sr,entry =
    45:     try Hashtbl.find bbdfns i
    46:     with Not_found -> failwith ("[get_variable_typename] can't find index " ^ si i)
    47:   in
    48:   match entry with
    49:   | `BBDCL_var (vs,t)
    50:   | `BBDCL_val (vs,t)
    51:   | `BBDCL_tmp (vs,t)
    52:   ->
    53:     let t = lower t in
    54:     if length ts <> length vs then
    55:     failwith
    56:     (
    57:       "[get_variable_typename} wrong number of args, expected vs = " ^
    58:       si (length vs) ^
    59:       ", got ts=" ^
    60:       si (length ts)
    61:     );
    62:     let t = rt vs t in
    63:     let n = cpp_typename syms t in
    64:     n
    65: 
    66:   | _ ->
    67:     failwith "[get_variable_typename] Expected variable"
    68: 
    69: let format_vars syms bbdfns vars ts =
    70:   catmap  ""
    71:   (fun idx ->
    72:     let instname =
    73:       try Some (cpp_instance_name syms bbdfns idx ts)
    74:       with _ -> None
    75:     in
    76:       match instname with
    77:       | Some instname ->
    78:         let typename = get_variable_typename syms bbdfns idx ts in
    79:         "  " ^ typename ^ " " ^ instname ^ ";\n"
    80:       | None -> "" (* ignore unused variables *)
    81:   )
    82:   vars
    83: 
    84: let find_members syms (child_map,bbdfns) index ts =
    85:   let variables = find_variable_indices syms (child_map,bbdfns) index in
    86:   match format_vars syms bbdfns variables ts with
    87:   | "" -> ""
    88:   | x ->
    89:   (*
    90:   "  //variables\n" ^
    91:   *)
    92:   x
    93: 
    94: let typeof_bparams ps: btypecode_t  =
    95:   typeoflist
    96:   (map
    97:   (fun (id,(ix,t)) ->t)
    98:   ps
    99:   )
   100: 
   101: let get_type bbdfns index =
   102:   let id,parent,sr,entry =
   103:     try Hashtbl.find bbdfns index
   104:     with _ -> failwith ("[get_type] Can't find index " ^ si index)
   105:   in
   106:   match entry with
   107:   | `BBDCL_function (props,vs,(ps,_),ret,_) ->
   108:       `BTYP_function (typeof_bparams ps,ret)
   109:   | `BBDCL_procedure (props,vs,(ps,_),_) ->
   110:       `BTYP_function (typeof_bparams ps,`BTYP_void)
   111:   | _ -> failwith "Only function and procedure types handles by get_type"
   112: 
   113: 
   114: let is_gc_pointer syms bbdfns sr t =
   115:   let t = lstrip syms.dfns t in
   116:   (*
   117:   print_endline ("[is_gc_ptr] Checking type " ^ sbt syms.dfns t);
   118:   *)
   119:   match t with
   120:   | `BTYP_function _ -> true
   121:   | `BTYP_inst (i,_) ->
   122:     let id,sr,parent,entry =
   123:       try Hashtbl.find bbdfns i
   124:       with Not_found ->
   125:         clierr sr ("[is_gc_pointer] Can't find nominal type " ^ si i);
   126:    in
   127:    begin match entry with
   128:    | `BBDCL_abs (_,tqs,_,_) -> mem `GC_pointer tqs
   129:    | _ -> false
   130:    end
   131:   | _ -> false
   132: 
   133: let gen_C_function syms (child_map,bbdfns) props index id vs bps ret' ts instance_no =
   134:   let rt vs t = reduce_type (lstrip syms.dfns (beta_reduce syms [] (tsubst vs ts t))) in
   135:   let requires_ptf = mem `Requires_ptf props in
   136:   let ps = map (fun (id,(ix,t)) -> id,t) bps in
   137:   let params = map (fun (id,(ix,t)) -> ix) bps in
   138:   if syms.compiler_options.print_flag then
   139:   print_endline
   140:   (
   141:     "//Generating C function inst " ^
   142:     si instance_no ^ "=" ^
   143:     id ^ "<" ^si index^">" ^
   144:     (
   145:       if length ts = 0 then ""
   146:       else "[" ^ catmap "," (string_of_btypecode syms.dfns) ts ^ "]"
   147:     )
   148:   );
   149:   let argtype = lower(typeof_bparams bps) in
   150:   if length ts <> length vs then
   151:   failwith
   152:   (
   153:     "[gen_function} wrong number of args, expected vs = " ^
   154:     si (length vs) ^
   155:     ", got ts=" ^
   156:     si (length ts)
   157:   );
   158:   let argtype = rt vs argtype in
   159:   let rt' vs t = reduce_type (beta_reduce syms [] (tsubst vs ts t)) in
   160:   let ret = rt' vs ret' in
   161:   let is_ref = match ret with `BTYP_lvalue _ -> true | _ -> false in
   162:   let ret = lstrip syms.dfns ret in
   163:   if ret = `BTYP_tuple [] then "// elided (returns unit)\n" else
   164: 
   165:   let funtype = fold syms.dfns (`BTYP_function (argtype, ret)) in
   166: 
   167:   let argtypename = cpp_typename syms argtype in
   168:   let display = get_display_list bbdfns index in
   169:   assert (length display = 0);
   170:   let name = cpp_instance_name syms bbdfns index ts in
   171:   let rettypename = cpp_typename syms ret in
   172:   rettypename ^ " " ^
   173:   (if is_ref then "& " else "") ^
   174:   "FLX_REGPARM "^
   175:   name ^ "(" ^
   176:   (
   177:     let s =
   178:       match length params with
   179:       | 0 -> ""
   180:       | 1 ->
   181:         let ix = hd params in
   182:         if Hashtbl.mem syms.instances (ix, ts)
   183:         && not (argtype = `BTYP_tuple [])
   184:         then argtypename else ""
   185:       | _ ->
   186:         let counter = ref 0 in
   187:         fold_left
   188:         (fun s (_,(i,t)) ->
   189:           let t = rt vs (lower t) in
   190:           if Hashtbl.mem syms.instances (i,ts) && not (t = `BTYP_tuple [])
   191:           then s ^
   192:             (if String.length s > 0 then ", " else " ") ^
   193:             cpp_typename syms t
   194:           else s (* elide initialisation of elided variable *)
   195:         )
   196:         ""
   197:         bps
   198:     in
   199:       (
   200:         if String.length s > 0
   201:         then (if requires_ptf then "FLX_FPAR_DECL " else "") ^s
   202:         else (if requires_ptf then "FLX_FPAR_DECL_ONLY" else "")
   203:       )
   204:   ) ^
   205:   ");\n"
   206: 
   207: let gen_class syms (child_map,bbdfns) props index id vs ts instance_no =
   208:   let rt vs t = reduce_type (lstrip syms.dfns (beta_reduce syms [] (tsubst vs ts t))) in
   209:   let requires_ptf = mem `Requires_ptf props in
   210:   if syms.compiler_options.print_flag then
   211:   print_endline
   212:   (
   213:     "//Generating class inst " ^
   214:     si instance_no ^ "=" ^
   215:     id ^ "<" ^si index^">" ^
   216:     (
   217:       if length ts = 0 then ""
   218:       else "[" ^ catmap "," (string_of_btypecode syms.dfns) ts ^ "]"
   219:     )
   220:   );
   221:   if length ts <> length vs then
   222:   failwith
   223:   (
   224:     "[gen_function} wrong number of args, expected vs = " ^
   225:     si (length vs) ^
   226:     ", got ts=" ^
   227:     si (length ts)
   228:   );
   229:   let display = get_display_list bbdfns index in
   230:   let frame_dcls =
   231:     if requires_ptf then
   232:     "  FLX_FMEM_DECL\n"
   233:     else ""
   234:   in
   235:   let display_string = match display with
   236:     | [] -> ""
   237:     | display ->
   238:       cat ""
   239:       (
   240:         map
   241:         (fun (i, vslen) ->
   242:          try
   243:          let instname = cpp_instance_name syms bbdfns i (list_prefix ts vslen) in
   244:          "  " ^ instname ^ " *ptr" ^ instname ^ ";\n"
   245:          with _ -> failwith "Can't cal display name"
   246:          )
   247:         display
   248:       )
   249:   and ctor_dcl name =
   250:     "  " ^name^
   251:     (if length display = 0
   252:     then (if requires_ptf then "(FLX_FPAR_DECL_ONLY);\n" else "();\n")
   253:     else (
   254:     "  (" ^
   255:     (if requires_ptf then
   256:     "FLX_FPAR_DECL "
   257:     else ""
   258:     )
   259:     ^
   260:     cat ","
   261:       (
   262:         map
   263:         (
   264:           fun (i,vslen) ->
   265:           let instname = cpp_instance_name syms bbdfns i (list_prefix ts vslen) in
   266:           instname ^ "*"
   267:         )
   268:         display
   269:       )^
   270:       ");\n"
   271:     ))
   272:   (*
   273:   and dtor_dcl name =
   274:     "  ~" ^ name ^"();\n"
   275:   *)
   276:   in
   277:   let members = find_members syms (child_map,bbdfns) index ts in
   278:   let name = cpp_instance_name syms bbdfns index ts in
   279:     let ctor = ctor_dcl name in
   280:   "struct " ^ name ^
   281:   " {\n" ^
   282:   (*
   283:   "  //os frames\n" ^
   284:   *)
   285:   frame_dcls ^
   286:   (*
   287:   "  //display\n" ^
   288:   *)
   289:   (
   290:     if String.length display_string = 0 then "" else
   291:     display_string ^ "\n"
   292:   )
   293:   ^
   294:   members ^
   295:   (*
   296:   "  //constructor\n" ^
   297:   *)
   298:   ctor ^
   299:   (
   300:     if mem `Heap_closure props then
   301:     (*
   302:     "  //clone\n" ^
   303:     *)
   304:     "  " ^name^"* clone()const;\n"
   305:     else ""
   306:   )
   307:   ^
   308:   (*
   309:   "  //call\n" ^
   310:   *)
   311:   "};\n"
   312: 
   313: 
   314: (* vs here is the (name,index) list of type variables *)
   315: let gen_function syms (child_map,bbdfns) props index id vs bps ret' ts instance_no =
   316:   let stackable = mem `Stack_closure props in
   317:   let heapable = mem `Heap_closure props in
   318:   let heapable = not stackable or heapable in
   319:   let rt vs t = reduce_type (lstrip syms.dfns (beta_reduce syms [] (tsubst vs ts t))) in
   320:   let requires_ptf = mem `Requires_ptf props in
   321:   (*
   322:   print_endline ("The function " ^ id ^ (if requires_ptf then " REQUIRES PTF" else "DOES NOT REQUIRE PTF"));
   323:   *)
   324:   let ps = map (fun (id,(ix,t)) -> id,t) bps in
   325:   if syms.compiler_options.print_flag then
   326:   print_endline
   327:   (
   328:     "//Generating function inst " ^
   329:     si instance_no ^ "=" ^
   330:     id ^ "<" ^si index^">" ^
   331:     (
   332:       if length ts = 0 then ""
   333:       else "[" ^ catmap "," (string_of_btypecode syms.dfns) ts ^ "]"
   334:     )
   335:   );
   336:   let argtype = lower(typeof_bparams bps) in
   337:   if length ts <> length vs then
   338:   failwith
   339:   (
   340:     "[gen_function} wrong number of args, expected vs = " ^
   341:     si (length vs) ^
   342:     ", got ts=" ^
   343:     si (length ts)
   344:   );
   345:   let argtype = rt vs argtype in
   346:   let rt' vs t = reduce_type (beta_reduce syms [] (tsubst vs ts t)) in
   347:   let ret = rt' vs ret' in
   348:   let is_ref = match ret with | `BTYP_lvalue _ -> true | _ -> false in
   349:   let ret = lstrip syms.dfns ret in
   350:   if ret = `BTYP_tuple [] then "// elided (returns unit)\n" else
   351: 
   352:   let funtype = fold syms.dfns (`BTYP_function (argtype, ret)) in
   353: 
   354:   let argtypename = cpp_typename syms argtype in
   355:   let funtypename =
   356:     if mem `Heap_closure props then
   357:       try Some (cpp_type_classname syms funtype)
   358:       with _ -> None
   359:     else None
   360:   in
   361:   let display = get_display_list bbdfns index in
   362:   let frame_dcls =
   363:     if requires_ptf then
   364:     "  FLX_FMEM_DECL\n"
   365:     else ""
   366:   in
   367:   let display_string = match display with
   368:     | [] -> ""
   369:     | display ->
   370:       cat ""
   371:       (
   372:         map
   373:         (fun (i, vslen) ->
   374:          try
   375:          let instname = cpp_instance_name syms bbdfns i (list_prefix ts vslen) in
   376:          "  " ^ instname ^ " *ptr" ^ instname ^ ";\n"
   377:          with _ -> failwith "Can't cal display name"
   378:          )
   379:         display
   380:       )
   381:   and ctor_dcl name =
   382:     "  " ^name^
   383:     (if length display = 0
   384:     then (if requires_ptf then "(FLX_FPAR_DECL_ONLY);\n" else "();\n")
   385:     else (
   386:     "  (" ^
   387:     (if requires_ptf then
   388:     "FLX_FPAR_DECL "
   389:     else ""
   390:     )
   391:     ^
   392:     cat ", "
   393:       (
   394:         map
   395:         (
   396:           fun (i,vslen) ->
   397:           let instname = cpp_instance_name syms bbdfns i (list_prefix ts vslen) in
   398:           instname ^ "*"
   399:         )
   400:         display
   401:       )^
   402:       ");\n"
   403:     ))
   404:   (*
   405:   and dtor_dcl name =
   406:     "  ~" ^ name ^"();\n"
   407:   *)
   408:   in
   409:   let members = find_members syms (child_map,bbdfns) index ts in
   410:   match ret with
   411:   | `BTYP_void ->
   412:     let name = cpp_instance_name syms bbdfns index ts in
   413:     let ctor = ctor_dcl name in
   414:     "struct " ^ name ^
   415:     (match funtypename with
   416:     | Some x -> ": "^x
   417:     | None -> if not heapable then "" else ": con_t"
   418:     )
   419:     ^
   420:     " {\n" ^
   421:     (*
   422:     "  //os frames\n" ^
   423:     *)
   424:     frame_dcls ^
   425:     (*
   426:     "  //display\n" ^
   427:     *)
   428:     display_string ^ "\n" ^
   429:     members ^
   430:     (*
   431:     "  //constructor\n" ^
   432:     *)
   433:     ctor ^
   434:     (
   435:       if mem `Heap_closure props then
   436:       (*
   437:       "  //clone\n" ^
   438:       *)
   439:       "  " ^name^"* clone()const;\n"
   440:       else ""
   441:     )
   442:     ^
   443:     (*
   444:     "  //call\n" ^
   445:     *)
   446:     (if argtype = `BTYP_tuple []
   447:     then
   448:       (if stackable then "  void stack_call();\n" else "") ^
   449:       (if heapable then "  con_t *call(con_t*);\n" else "")
   450:     else
   451:       (if stackable then "  void stack_call("^argtypename^" const &);\n" else "") ^
   452:       (if heapable then "  con_t *call(con_t*,"^argtypename^" const &);\n" else "")
   453:     ) ^
   454:     (*
   455:     "  //resume\n" ^
   456:     *)
   457:     (if heapable then "  con_t *resume();\n" else "")
   458:     ^
   459:     "};\n"
   460: 
   461:   | _ ->
   462:     let name = cpp_instance_name syms bbdfns index ts in
   463:     let rettypename = cpp_typename syms ret in
   464:     let ctor = ctor_dcl name in
   465:     "struct " ^ name ^
   466:     (match funtypename with
   467:     | Some x -> ": "^x
   468:     | None -> ""
   469:     )
   470:     ^
   471:     " {\n" ^
   472:     (*
   473:     "  //os frames\n" ^
   474:     *)
   475:     frame_dcls ^
   476:     (*
   477:     "  //display\n" ^
   478:     *)
   479:     display_string ^ "\n" ^
   480:     members ^
   481:     (*
   482:     "  //constructor\n" ^
   483:     *)
   484:     ctor ^
   485:     (
   486:       if mem `Heap_closure props then
   487:       (*
   488:       "  //clone\n" ^
   489:       *)
   490:       "  " ^name^"* clone()const;\n"
   491:       else ""
   492:     )
   493:     ^
   494:     (*
   495:     "  //apply\n" ^
   496:     *)
   497:     "  "^rettypename^
   498:     (if is_ref then "& " else "") ^
   499:     " apply(" ^
   500:     (if argtype = `BTYP_tuple[] then ""
   501:     else argtypename^" const &")^
   502:     ");\n"  ^
   503:     "};\n"
   504: 
   505: 
   506: (* This code generates the class declarations *)
   507: let gen_functions syms (child_map,bbdfns) =
   508:   let xxdfns = ref [] in
   509:   Hashtbl.iter
   510:   (fun x i ->
   511:     (* if proper_descendant syms.dfns parent then  *)
   512:     xxdfns := (i,x) :: !xxdfns
   513:   )
   514:   syms.instances
   515:   ;
   516: 
   517:   let s = Buffer.create 2000 in
   518:   iter
   519:   (fun (i,(index,ts)) ->
   520:     let tss =
   521:       if length ts = 0 then "" else
   522:       "[" ^ catmap "," (string_of_btypecode syms.dfns) ts^ "]"
   523:     in
   524:     match
   525:       try Hashtbl.find bbdfns index
   526:       with Not_found -> failwith ("[gen_functions] can't find index " ^ si index)
   527:     with (id,parent,sr,entry) ->
   528:     match entry with
   529:     | `BBDCL_function (props,vs,(ps,traint), ret, _) ->
   530:       bcat s ("\n//------------------------------\n");
   531:       if mem `Pure props && not (mem `Heap_closure props) then begin
   532:         bcat s ("//PURE C FUNCTION " ^ qualified_name_of_index syms.dfns index ^ tss ^ "\n");
   533:         bcat s
   534:         (gen_C_function syms (child_map,bbdfns) props index id vs ps ret ts i)
   535:       end else begin
   536:         bcat s ("//FUNCTION " ^ qualified_name_of_index syms.dfns index ^ tss ^ "\n");
   537:         bcat s
   538:         (gen_function syms (child_map,bbdfns) props index id vs ps ret ts i)
   539:       end
   540: 
   541:     | `BBDCL_callback (props,vs,ps_cf,ps_c,_,ret',_,_) ->
   542:       let instance_no = i in
   543:       bcat s ("\n//------------------------------\n");
   544:       if ret' = `BTYP_void then begin
   545:         bcat s ("//CALLBACK C PROC " ^ qualified_name_of_index syms.dfns index ^ tss ^ "\n");
   546:       end else begin
   547:         bcat s ("//CALLBACK C FUNCTION " ^ qualified_name_of_index syms.dfns index ^ tss ^ "\n");
   548:       end
   549:       ;
   550:       let rt vs t = reduce_type (lstrip syms.dfns (beta_reduce syms [] (tsubst vs ts t))) in
   551:       if syms.compiler_options.print_flag then
   552:       print_endline
   553:       (
   554:         "//Generating C callback function inst " ^
   555:         si instance_no ^ "=" ^
   556:         id ^ "<" ^si index^">" ^
   557:         (
   558:           if length ts = 0 then ""
   559:           else "[" ^ catmap "," (string_of_btypecode syms.dfns) ts ^ "]"
   560:         )
   561:       );
   562:       if length ts <> length vs then
   563:       failwith
   564:       (
   565:         "[gen_function} wrong number of args, expected vs = " ^
   566:         si (length vs) ^
   567:         ", got ts=" ^
   568:         si (length ts)
   569:       );
   570:       let ret = rt vs ret' in
   571:       (*
   572:       let name = cpp_instance_name syms bbdfns index ts in
   573:       *)
   574:       let name = id in (* callbacks can't be polymorphic .. for now anyhow *)
   575:       let rettypename = cpp_typename syms ret in
   576:       let sss =
   577:         "extern \"C\" " ^
   578:         rettypename ^ " " ^
   579:         name ^ "(" ^
   580:         (
   581:           match length ps_c with
   582:           | 0 -> ""
   583:           | 1 -> cpp_typename syms (hd ps_c)
   584:           | _ ->
   585:             fold_left
   586:             (fun s t ->
   587:               let t = rt vs (lower t) in
   588:               s ^
   589:               (if String.length s > 0 then ", " else "") ^
   590:               cpp_typename syms t
   591:             )
   592:             ""
   593:             ps_c
   594:         ) ^
   595:         ");\n"
   596:       in bcat s sss
   597: 
   598:     | `BBDCL_procedure (props,vs,(ps,traint),_) ->
   599:       bcat s ("\n//------------------------------\n");
   600:       if mem `Pure props && not (mem `Heap_closure props) then begin
   601:         bcat s ("//PURE C PROC " ^ qualified_name_of_index syms.dfns index ^ tss ^ "\n");
   602:         bcat s
   603:         (gen_C_function syms (child_map,bbdfns) props index id vs ps `BTYP_void ts i)
   604:       end else begin
   605:         bcat s ("//PROC " ^ qualified_name_of_index syms.dfns index ^ tss ^ "\n");
   606:         bcat s
   607:         (gen_function syms (child_map,bbdfns) props index id vs ps `BTYP_void ts i)
   608:       end
   609: 
   610:     | `BBDCL_regmatch (props,vs, (ps,traint), ret, regargs) ->
   611:       bcat s ("\n//------------------------------\n");
   612:       bcat s ("//REGMATCH " ^ qualified_name_of_index syms.dfns index ^ tss ^ "\n");
   613:       bcat s
   614:       (gen_function syms (child_map,bbdfns) props index id vs ps ret ts i)
   615: 
   616:     | `BBDCL_reglex (props, vs, (ps,traint), i, ret, regargs) ->
   617:       bcat s ("\n//------------------------------\n");
   618:       bcat s ("//REGLEX " ^ qualified_name_of_index syms.dfns index ^ tss ^ "\n");
   619:       bcat s
   620:       (gen_function syms (child_map,bbdfns) props index id vs ps ret ts i)
   621: 
   622:     | `BBDCL_class (props,vs) ->
   623:       bcat s ("\n//------------------------------\n");
   624:       bcat s ("//CLASS " ^ qualified_name_of_index syms.dfns index ^ tss ^ "\n");
   625:       let t = `BTYP_inst (index,ts) in
   626:       let j = try
   627:         Hashtbl.find syms.registry t with
   628:         Not_found -> failwith "Cannot find class type instance in type registry"
   629:       in
   630:       bcat s ("//CLASS " ^ si index ^ ", OBJECT INSTANCE " ^ si i ^ " TYPE INSTANCE " ^ si j ^ "\n");
   631:       bcat s
   632:       (gen_class syms (child_map,bbdfns) props index id vs ts i)
   633: 
   634:     | _ -> () (* bcat s ("//SKIPPING " ^ id ^ "\n") *)
   635:   )
   636:   (sort compare !xxdfns)
   637:   ;
   638:   Buffer.contents s
   639: 
   640: (*
   641: let gen_dtor syms bbdfns name display ts =
   642:   name^"::~"^name^"(){}\n"
   643: *)
   644: let is_closure_var bbdfns index =
   645:   let var_type bbdfns index =
   646:     let id,_,entry =
   647:       try Hashtbl.find bbdfns index
   648:       with Not_found -> failwith ("[var_type] ]Can't get index " ^ si index)
   649:     in match entry with
   650:     | `BBDCL_var (_,t)
   651:     | `BBDCL_val (_,t) -> lower t
   652:     | _ -> failwith ("[var_type] expected "^id^" to be variable")
   653:   in
   654:   match var_type bbdfns index with
   655:   | `BTYP_function _ -> true
   656:   | _ -> false
   657: 
   658: (* NOTE: it isn't possible to pass an explicit tuple as a single
   659: argument to a primitive, nor a single value of tuple/array type.
   660: In the latter case a cast/abstraction can defeat this, for the
   661: former you'll need to make a dummy variable.
   662: *)
   663: 
   664: 
   665: 
   666: type kind_t = Function | Procedure
   667: 
   668: let gen_exe filename syms
   669:   (child_map,bbdfns) (label_map,label_usage_map)
   670:   counter this vs ts instance_no needs_switch stackable (exe:bexe_t) : string =
   671:   if length ts <> length vs then
   672:   failwith
   673:   (
   674:     "[gen_exe} wrong number of args, expected vs = " ^
   675:     si (length vs) ^
   676:     ", got ts=" ^
   677:     si (length ts)
   678:   );
   679:   let sr = ("dummy",0,0,0,0) in
   680:   let src_str = string_of_bexe syms.dfns 0 exe in
   681:   let with_comments = syms.compiler_options.with_comments in
   682:   (*
   683:   print_endline ("generating exe " ^ string_of_bexe syms.dfns 0 exe);
   684:   print_endline ("vs = " ^ catmap "," (fun (s,i) -> s ^ "->" ^ si i) vs);
   685:   print_endline ("ts = " ^ catmap ","  (string_of_btypecode syms.dfns) ts);
   686:   *)
   687:   let tsub t = reduce_type (beta_reduce syms [] (tsubst vs ts t)) in
   688:   let ge sr e : string = gen_expr syms bbdfns this e vs ts sr in
   689:   let ge' sr e : cexpr_t = gen_expr' syms bbdfns this e vs ts sr in
   690:   let tn t : string = cpp_typename syms (tsub t) in
   691:   let id,parent,sr,entry =
   692:     try Hashtbl.find bbdfns this
   693:     with _ -> failwith ("[gen_exe] Can't find this " ^ si this)
   694:   in
   695:   let our_display = get_display_list bbdfns this in
   696:   let kind = match entry with
   697:     | `BBDCL_function (_,_,_,_,_) -> Function
   698:     | `BBDCL_procedure (_,_,_,_) -> Procedure
   699:     | _ -> failwith "Expected executable code to be in function or procedure"
   700:   in let our_level = length our_display in
   701: 
   702:   let handle_closure sr is_jump index ts subs a stack_call =
   703:     let subs =
   704:       catmap ""
   705:       (fun ((_,t) as e,s) ->
   706:         let t = cpp_ltypename syms t in
   707:         let e = ge sr e in
   708:         "      " ^ t ^ " " ^ s ^ " = " ^ e ^ ";\n"
   709:       )
   710:       subs
   711:     in
   712:     let sub_start =
   713:       if String.length subs = 0 then ""
   714:       else "      {\n" ^ subs
   715:     and sub_end =
   716:       if String.length subs = 0 then ""
   717:       else "      }\n"
   718:     in
   719:     let id,parent,sr2,entry =
   720:       try Hashtbl.find bbdfns index
   721:       with _ -> failwith ("[gen_exe(call)] Can't find index " ^ si index)
   722:     in
   723:     begin
   724:     match entry with
   725:     | `BBDCL_proc (props,vs,_,ct,_) ->
   726:       assert (not is_jump);
   727: 
   728:       if length vs <> length ts then
   729:       clierr sr "[gen_prim_call] Wrong number of type arguments"
   730:       ;
   731:       let s =
   732:         match ct with
   733:         | `Str s -> ce_expr "expr" s
   734:         | `StrTemplate s ->
   735:           gen_prim_call syms bbdfns tsub ge' s ts a "Error" sr sr2 "atom"
   736:       in
   737:       let s = sc "expr" s in
   738:       (if with_comments then "      // " ^ src_str ^ "\n" else "") ^
   739:       sub_start ^
   740:       "      " ^ s ^ "\n" ^
   741:       sub_end
   742: 
   743:     | `BBDCL_callback (props,vs,ps_cf,ps_c,_,ret,_,_) ->
   744:       assert (not is_jump);
   745:       assert (ret = `BTYP_void);
   746: 
   747:       if length vs <> length ts then
   748:       clierr sr "[gen_prim_call] Wrong number of type arguments"
   749:       ;
   750:       let s = id ^ "($a);" in
   751:       let s =
   752:         gen_prim_call syms bbdfns tsub ge' s ts a "Error" sr sr2 "atom"
   753:       in
   754:       let s = sc "expr" s in
   755:       (if with_comments then "      // " ^ src_str ^ "\n" else "") ^
   756:       sub_start ^
   757:       "      " ^ s ^ "\n" ^
   758:       sub_end
   759: 
   760: 
   761:     | `BBDCL_procedure (props,vs,ps,bexes) ->
   762:       if bexes = []
   763:       then
   764:       "      //call to empty procedure " ^ id ^ " elided\n"
   765:       else begin
   766:         let n = !counter in
   767:         incr counter;
   768:         let the_display =
   769:           let d' =
   770:             map (fun (i,vslen) -> "ptr"^cpp_instance_name syms bbdfns i (list_prefix ts vslen))
   771:             (get_display_list bbdfns index)
   772:           in
   773:             if length d' > our_level
   774:             then "this" :: tl d'
   775:             else d'
   776:         in
   777:         (* if we're calling from inside a function,
   778:            we pass a 0 continuation as the caller 'return address'
   779:            otherwise pass 'this' as the caller 'return address'
   780:            EXCEPT that stack calls don't pass a return address at all
   781:         *)
   782:         let this = match kind with
   783:           | Function ->
   784:             if is_jump
   785:             then
   786:               clierr sr "can't jump inside function"
   787:             else if stack_call then ""
   788:             else "0"
   789: 
   790:           | Procedure ->
   791:             if stack_call then "" else
   792:             if is_jump then "tmp"
   793:             else "this"
   794:         in
   795: 
   796:         let args = match a with
   797:           | _,`BTYP_tuple [] -> this
   798:           | _ ->
   799:             (
   800:               let a = ge sr a in
   801:               if this = "" then a else this ^ ", " ^ a
   802:             )
   803:         in
   804:         let name = cpp_instance_name syms bbdfns index ts in
   805:         if stack_call then begin
   806:           (*
   807:           print_endline "GENERATING STACK CALL";
   808:           *)
   809:           (if with_comments
   810:           then "      //run procedure " ^ src_str ^ "\n"
   811:           else "") ^
   812:           "      {\n" ^
   813:           subs ^
   814:           "      " ^ name ^ strd the_display props^ "\n" ^
   815:           "      .stack_call(" ^ args ^ ");\n" ^
   816:           "      }\n"
   817:         end
   818:         else
   819:         let ptrmap = name ^ "_ptr_map" in
   820:         begin
   821:           match kind with
   822:           | Function ->
   823:             (if with_comments
   824:             then "      //run procedure " ^ src_str ^ "\n"
   825:             else "") ^
   826:             "      {\n" ^
   827:             subs ^
   828:             "      con_t *_p =\n" ^
   829:             "      (FLX_NEWP(" ^ name ^ ")" ^ strd the_display props^ ")\n" ^
   830:             "      ->call(" ^ args ^ ");\n" ^
   831:             "      while(_p) _p=_p->resume();\n" ^
   832:             "      }\n"
   833: 
   834:           | Procedure ->
   835:             let call_string =
   836:               "      return (FLX_NEWP(" ^ name ^ ")"^strd the_display props ^ ")" ^
   837:               "\n      ->call(" ^ args ^ ");\n"
   838:             in
   839:             if is_jump
   840:             then
   841:               (if with_comments then
   842:               "      //jump to procedure " ^ src_str ^ "\n"
   843:               else "") ^
   844:               "      {\n" ^
   845:               subs ^
   846:               "      con_t *tmp = _caller;\n" ^
   847:               "      _caller = 0;\n" ^
   848:               call_string ^
   849:               "      }\n"
   850:             else
   851:             (
   852:               needs_switch := true;
   853:               (if with_comments then
   854:               "      //call procedure " ^ src_str ^ "\n"
   855:               else ""
   856:               )
   857:               ^
   858: 
   859:               sub_start ^
   860:               "      FLX_SET_PC(" ^ si n ^ ")\n" ^
   861:               call_string ^
   862:               sub_end ^
   863:               "    FLX_CASE_LABEL(" ^ si n ^ ")\n"
   864:             )
   865:         end
   866:       end
   867: 
   868:     | _ ->
   869:       failwith
   870:       (
   871:         "[gen_exe] Expected '"^id^"' to be procedure constant, got " ^
   872:         string_of_bbdcl syms.dfns entry index
   873:       )
   874:     end
   875:   in
   876:   let gen_nonlocal_goto pc frame s =
   877:     (* WHAT THIS CODE DOES: we pop the call stack until
   878:        we find the first ancestor containing the target label,
   879:        set the pc there, and return its continuation to the
   880:        driver; we know the address of this frame because
   881:        it must be in this function's display.
   882:     *)
   883:     let target_instance =
   884:       try Hashtbl.find syms.instances (frame, ts)
   885:       with Not_found -> failwith "Woops, bugged code, wrong type arguments for instance?"
   886:     in
   887:     let frame_ptr = "ptr" ^ cpp_instance_name syms bbdfns frame ts in
   888:     "      // non local goto " ^ s ^ "\n" ^
   889:     "      {\n" ^
   890:     "        con_t *tmp1 = this;\n" ^
   891:     "        while(tmp1 && " ^ frame_ptr ^ "!= tmp1)\n" ^
   892:     "        {\n" ^
   893:     "          con_t *tmp2 = tmp1->_caller;\n" ^
   894:     "          tmp1 -> _caller = 0;\n" ^
   895:     "          tmp1 = tmp2;\n" ^
   896:     "        }\n" ^
   897:     "      }\n" ^
   898:     "      " ^ frame_ptr ^ "->pc = FLX_FARTARGET("^si pc^","^si target_instance^","^s^");\n" ^
   899:     "      return " ^ frame_ptr ^ ";\n"
   900:   in
   901:   let forget_template s = match s with | `Str s -> s | `StrTemplate s -> s in
   902:   let rec gexe exe =
   903:     (*
   904:     print_endline (string_of_bexe syms.dfns 0 exe);
   905:     *)
   906:     match exe with
   907:     | `BEXE_axiom_check _ -> assert false
   908:     | `BEXE_code (_,s) -> forget_template s
   909:     | `BEXE_nonreturn_code (_,s) -> forget_template s
   910:     | `BEXE_comment (_,s) -> "/*" ^ s ^ "*/\n"
   911:     | `BEXE_label (_,s) ->
   912:       let local_labels =
   913:         try Hashtbl.find label_map this
   914:         with _ -> failwith ("[gen_exe] Can't find label map of " ^ si this)
   915:       in
   916:       let label_index =
   917:         try Hashtbl.find local_labels s
   918:         with _ -> failwith ("[gen_exe] In " ^ id ^ ": Can't find label " ^ s)
   919:       in
   920:       let label_kind = get_label_kind_from_index label_usage_map label_index in
   921:       (match kind with
   922:         | Procedure ->
   923:           begin match label_kind with
   924:           | `Far ->
   925:             needs_switch := true;
   926:             "    FLX_LABEL(" ^ si label_index ^ ","^si instance_no ^","^s^")\n"
   927:           | `Near ->
   928:             "    " ^ s ^ ":;\n"
   929:           | `Unused -> ""
   930:           end
   931: 
   932:         | Function ->
   933:           begin match label_kind with
   934:           | `Far -> assert false
   935:           | `Near ->
   936:             "    " ^ s ^ ":;\n"
   937:           | `Unused -> ""
   938:           end
   939:       )
   940: 
   941:     (* FIX THIS TO PUT SOURCE REFERENCE IN *)
   942:     | `BEXE_halt (sr,s) ->
   943:        "      // halt " ^ s ^ "\n" ^
   944:        "      throw flx::rtl::flx_exec_failure_t(\n" ^
   945:        "        \"" ^ Flx_srcref.short_string_of_src sr ^ "\",\n" ^
   946:        "        \"halt\",\n" ^
   947:        "        \"" ^ s ^ "\"\n" ^
   948:        "      );\n"
   949: 
   950:     | `BEXE_goto (sr,s) ->
   951:       begin match find_label bbdfns label_map this s with
   952:       | `Local _ -> "      goto " ^ s ^ ";\n"
   953:       | `Nonlocal (pc,frame) -> gen_nonlocal_goto pc frame s
   954:       | `Unreachable ->
   955:         clierr sr ("Jump to unreachable label " ^ s)
   956:       end
   957: 
   958:     | `BEXE_ifgoto (sr,e,s) ->
   959:       begin match find_label bbdfns label_map this s with
   960:       | `Local _ ->
   961:         "      if(" ^ ge sr e ^ ")goto " ^ s ^ ";\n"
   962:       | `Nonlocal (pc,frame) ->
   963:         let skip = "_" ^ si !(syms.counter) in
   964:         incr syms.counter;
   965:         let not_e = ce_prefix "!" (ge' sr e) in
   966:         let not_e = string_of_cexpr not_e in
   967:         "      if("^not_e^")goto " ^ skip ^ ";\n"  ^
   968:         gen_nonlocal_goto pc frame s ^
   969:         "    " ^ skip ^ ":;\n"
   970: 
   971:       | `Unreachable ->
   972:         clierr sr ("Jump to unreachable label " ^ s)
   973:       end
   974: 
   975:     | `BEXE_ifnotgoto (sr,e,s) ->
   976:       begin match find_label bbdfns label_map this s with
   977:       | `Local _ ->
   978:         (*
   979:         let not_e = ce_prefix "!" (ge' sr e) in
   980:         let not_e = string_of_cexpr not_e in
   981:         "      if("^not_e^")goto " ^ s ^ ";\n"
   982:         *)
   983:         "      ifnot(" ^ ge sr e ^ ")goto " ^ s ^ ";\n"
   984: 
   985:       | `Nonlocal (pc,frame) ->
   986:         let skip = "_" ^ si !(syms.counter) in
   987:         incr syms.counter;
   988:         "      if(" ^ ge sr e ^ ")goto " ^ skip ^ ";\n" ^
   989:         gen_nonlocal_goto pc frame  s ^
   990:         "    " ^ skip ^ ":;\n"
   991: 
   992:       | `Unreachable ->
   993:         clierr sr ("Jump to unreachable label " ^ s)
   994:       end
   995: 
   996:     (* Hmmm .. stack calls ?? *)
   997:     | `BEXE_call_stack (sr,index,ts,a)  ->
   998:       let id,parent,sr2,entry =
   999:         try Hashtbl.find bbdfns index
  1000:         with _ -> failwith ("[gen_expr(apply instance)] Can't find index " ^ si index)
  1001:       in
  1002:       let ge_arg ((x,t) as a) =
  1003:         let t = tsub t in
  1004:         match t with
  1005:         | `BTYP_tuple [] -> ""
  1006:         | _ -> ge sr a
  1007:       in
  1008:       let nth_type ts i = match ts with
  1009:         | `BTYP_tuple ts -> nth ts i
  1010:         | `BTYP_array (t,`BTYP_unitsum n) -> assert (i<n); t
  1011:         | _ -> assert false
  1012:       in
  1013:       begin match entry with
  1014:       | `BBDCL_procedure (props,vs,(ps,traint),_) ->
  1015:         let a = match a with (a,t) -> a, tsub t in
  1016:         let ts = map tsub ts in
  1017:         (* C FUNCTION CALL *)
  1018:         if mem `Pure props && not (mem `Heap_closure props) then
  1019:           let display = get_display_list bbdfns index in
  1020:           let name = cpp_instance_name syms bbdfns index ts in
  1021:           let s =
  1022:             assert (length display = 0);
  1023:             match ps with
  1024:             | [] -> ""
  1025:             | [_,(i,t)] ->
  1026:               if Hashtbl.mem syms.instances (i,ts)
  1027:               && not (t = `BTYP_tuple[])
  1028:               then
  1029:                 ge_arg a
  1030:               else ""
  1031: 
  1032:             | _ ->
  1033:               begin match a with
  1034:               | `BEXPR_tuple xs,_ ->
  1035:                 (*
  1036:                 print_endline ("Arg to C function is tuple " ^ sbe syms.dfns a);
  1037:                 *)
  1038:                 fold_left
  1039:                 (fun s (((x,t) as xt),(_,(i,_))) ->
  1040:                   let x =
  1041:                     if Hashtbl.mem syms.instances (i,ts)
  1042:                     && not (t = `BTYP_tuple[])
  1043:                     then ge_arg xt
  1044:                     else ""
  1045:                   in
  1046:                   if String.length x = 0 then s else
  1047:                   s ^
  1048:                   (if String.length s > 0 then ", " else "") ^ (* append a comma if needed *)
  1049:                   x
  1050:                 )
  1051:                 ""
  1052:                 (combine xs ps)
  1053: 
  1054:               | _,tt ->
  1055:                 let tt = reduce_type (beta_reduce syms [] (lstrip syms.dfns (tsubst vs ts tt))) in
  1056:                 (* NASTY, EVALUATES EXPR MANY TIMES .. *)
  1057:                 let n = ref 0 in
  1058:                 fold_left
  1059:                 (fun s (i,(_,(j,t))) ->
  1060:                   (*
  1061:                   print_endline ( "ps = " ^ catmap "," (fun (id,(p,t)) -> id) ps);
  1062:                   print_endline ("tt=" ^ sbt syms.dfns tt);
  1063:                   *)
  1064:                   let t = nth_type tt i in
  1065:                   let a' = `BEXPR_get_n (i,a),t in
  1066:                   let x =
  1067:                     if Hashtbl.mem syms.instances (j,ts)
  1068:                     && not (t = `BTYP_tuple[])
  1069:                     then ge_arg a'
  1070:                     else ""
  1071:                   in
  1072:                   incr n;
  1073:                   if String.length x = 0 then s else
  1074:                   s ^ (if String.length s > 0 then ", " else "") ^ x
  1075:                 )
  1076:                 ""
  1077:                 (combine (nlist (length ps)) ps)
  1078:               end
  1079:           in
  1080:           let s =
  1081:             if mem `Requires_ptf props then
  1082:               if String.length s > 0 then "FLX_FPAR_PASS " ^ s
  1083:               else "FLX_FPAR_PASS_ONLY"
  1084:             else s
  1085:           in
  1086:             "  " ^ name ^ "(" ^ s ^ ");\n"
  1087:         else
  1088:           let subs,x = unravel syms bbdfns a in
  1089:           let subs = map (fun ((e,t),s) -> (e,tsub t),s) subs in
  1090:           handle_closure sr false index ts subs x true
  1091:       | _ -> failwith "procedure expected"
  1092:       end
  1093: 
  1094: 
  1095:     | `BEXE_call_prim (sr,index,ts,a)
  1096:     | `BEXE_call_direct (sr,index,ts,a)
  1097:     | `BEXE_call (sr,(`BEXPR_closure (index,ts),_),a) ->
  1098:       let a = match a with (a,t) -> a, tsub t in
  1099:       let subs,x = unravel syms bbdfns a in
  1100:       let subs = map (fun ((e,t),s) -> (e,tsub t),s) subs in
  1101:       let ts = map tsub ts in
  1102:       handle_closure sr false index ts subs x false
  1103: 
  1104:     | `BEXE_call_method_stack (sr,obj,meth,ts,a) ->
  1105:       let obj = match obj with (a,t) -> a, tsub t in
  1106:       let a = match a with (a,t) -> a, tsub t in
  1107:       let ts = map tsub ts in
  1108:       let the_display =
  1109:         let d' =
  1110:           map (fun (i,vslen)-> "ptr"^ cpp_instance_name syms bbdfns i (list_prefix ts vslen))
  1111:           (get_display_list bbdfns meth)
  1112:         in
  1113:           let d' = tl d' in (* throw out class pointer *)
  1114:           if length d' > our_level
  1115:           then "this" :: tl d'
  1116:           else d'
  1117:       in
  1118:       let args = match a with
  1119:         | _,`BTYP_tuple [] -> ""
  1120:         | _ -> ge sr a
  1121:       in
  1122:       let class_frame = ge sr obj in
  1123:       let the_display = class_frame :: the_display in
  1124:       let meth_name = cpp_instance_name syms bbdfns meth ts in
  1125:       let meth_props =
  1126:         try match Hashtbl.find bbdfns meth with
  1127:           | _,_,_,`BBDCL_procedure (props,_,_,_)->props
  1128:           | _ -> failwith "Panic, index isn't procedure"
  1129:         with Not_found -> failwith "Panic, can't find procedure"
  1130:       in
  1131:       let labno = !counter in incr counter;
  1132:       let code =
  1133:         "      " ^ meth_name ^ strd (the_display) meth_props ^
  1134:         "\n      .stack_call(" ^ args ^ ");\n"
  1135:       in
  1136:       code
  1137: 
  1138:     | `BEXE_call_method_direct (sr,obj,meth,ts,a) ->
  1139:       let obj = match obj with (a,t) -> a, tsub t in
  1140:       let a = match a with (a,t) -> a, tsub t in
  1141:       let ts = map tsub ts in
  1142:       let the_display =
  1143:         let d' =
  1144:           map (fun (i,vslen)-> "ptr"^ cpp_instance_name syms bbdfns i (list_prefix ts vslen))
  1145:           (get_display_list bbdfns meth)
  1146:         in
  1147:           let d' = tl d' in (* throw out class pointer *)
  1148:           if length d' > our_level
  1149:           then "this" :: tl d'
  1150:           else d'
  1151:       in
  1152:       let args = match a with
  1153:         | _,`BTYP_tuple [] -> "this"
  1154:         | _ -> "this" ^ ", " ^ ge sr a
  1155:       in
  1156:       let class_frame = ge sr obj in
  1157:       let the_display = class_frame :: the_display in
  1158:       let meth_name = cpp_instance_name syms bbdfns meth ts in
  1159:       let meth_props =
  1160:         try match Hashtbl.find bbdfns meth with
  1161:           | _,_,_,`BBDCL_procedure (props,_,_,_)->props
  1162:           | _ -> failwith "Panic, index isn't procedure"
  1163:         with Not_found -> failwith "Panic, can't find procedure"
  1164:       in
  1165:       let labno = !counter in incr counter;
  1166:       let code =
  1167:         "      FLX_SET_PC(" ^ si labno ^ ")\n" ^
  1168:         "      return (FLX_NEWP(" ^ meth_name ^ ")"^strd (the_display) meth_props ^ ")" ^
  1169:         "\n      ->call(" ^ args ^ ");\n" ^
  1170:         "    FLX_CASE_LABEL(" ^ si labno ^ ")\n"
  1171:       in
  1172:       needs_switch := true;
  1173:       code
  1174: 
  1175:     | `BEXE_apply_ctor_stack (sr,i1,i2,ts,i3,a) ->
  1176:       let a = match a with (a,t) -> a, tsub t in
  1177:       let ts = map tsub ts in
  1178:       let the_display =
  1179:         let d' =
  1180:           map (fun (i,vslen) -> "ptr"^cpp_instance_name syms bbdfns i (list_prefix ts vslen))
  1181:           (get_display_list bbdfns i2)
  1182:         in
  1183:           if length d' > our_level
  1184:           then "this" :: tl d'
  1185:           else d'
  1186:       in
  1187:       (* let var_name = cpp_instance_name syms bbdfns i1 ts in *)
  1188:       (* dummy type in variable name .. : *)
  1189:       let var_name = ge sr (`BEXPR_name (i1, []),`BTYP_void) in
  1190:       let class_name = cpp_instance_name syms bbdfns i2 ts in
  1191:       let class_props =
  1192:         try match Hashtbl.find bbdfns i2 with
  1193:           | _,_,_,`BBDCL_class (props,_)->props
  1194:           | _ -> failwith "Panic, index isn't class"
  1195:         with Not_found -> failwith "Panic, can't find class"
  1196:       in
  1197:       let ctor_props =
  1198:         try match Hashtbl.find bbdfns i3 with
  1199:           | _,_,_,`BBDCL_procedure (props,_,_,_)->props
  1200:           | _ -> failwith "Panic, index isn't procedure"
  1201:         with Not_found -> failwith "Panic, can't find procedure"
  1202:       in
  1203:       let args = match a with
  1204:         | _,`BTYP_tuple [] -> ""
  1205:         | _ -> ge sr a
  1206:       in
  1207:       let ctor_name = cpp_instance_name syms bbdfns i3 ts in
  1208:       let labno = !counter in incr counter;
  1209:       let code =
  1210:           "      " ^ var_name ^ " = " ^
  1211:           " (FLX_NEWP(" ^ class_name ^ ")" ^ strd the_display class_props ^ ");\n" ^
  1212:           "      " ^ ctor_name ^ strd (var_name::the_display) ctor_props ^
  1213:           "\n      .stack_call(" ^ args ^ ");\n"
  1214:       in
  1215:       code
  1216: 
  1217:     | `BEXE_apply_ctor (sr,i1,i2,ts,i3,a) ->
  1218:       let a = match a with (a,t) -> a, tsub t in
  1219:       let ts = map tsub ts in
  1220:       let the_display =
  1221:         let d' =
  1222:           map (fun (i,vslen) -> "ptr"^cpp_instance_name syms bbdfns i (list_prefix ts vslen))
  1223:           (get_display_list bbdfns i2)
  1224:         in
  1225:           if length d' > our_level
  1226:           then "this" :: tl d'
  1227:           else d'
  1228:       in
  1229:       (* let var_name = cpp_instance_name syms bbdfns i1 ts in *)
  1230:       (* dummy type in variable name .. : *)
  1231:       let var_name = ge sr (`BEXPR_name (i1, []),`BTYP_void) in
  1232:       let class_name = cpp_instance_name syms bbdfns i2 ts in
  1233:       let class_props =
  1234:         try match Hashtbl.find bbdfns i2 with
  1235:           | _,_,_,`BBDCL_class (props,_)->props
  1236:           | _ -> failwith "Panic, index isn't class"
  1237:         with Not_found -> failwith "Panic, can't find class"
  1238:       in
  1239:       let ctor_props =
  1240:         try match Hashtbl.find bbdfns i3 with
  1241:           | _,_,_,`BBDCL_procedure (props,_,_,_)->props
  1242:           | _ -> failwith "Panic, index isn't procedure"
  1243:         with Not_found -> failwith "Panic, can't find procedure"
  1244:       in
  1245:       let args = match a with
  1246:         | _,`BTYP_tuple [] -> "this"
  1247:         | _ -> let a = ge sr a in "this" ^ ", " ^ a
  1248:       in
  1249:       let ctor_name = cpp_instance_name syms bbdfns i3 ts in
  1250:       let labno = !counter in incr counter;
  1251:       let code =
  1252:           needs_switch := true;
  1253:           "      " ^ var_name ^ " = " ^
  1254:           " (FLX_NEWP(" ^ class_name ^ ")" ^ strd the_display class_props ^ ");\n" ^
  1255:           "      FLX_SET_PC(" ^ si labno ^ ")\n" ^
  1256:           "      return (FLX_NEWP(" ^ ctor_name ^ ")"^strd (var_name::the_display) ctor_props ^ ")" ^
  1257:           "\n      ->call(" ^ args ^ ");\n" ^
  1258:           "    FLX_CASE_LABEL(" ^ si labno ^ ")\n"
  1259:       in
  1260:       code
  1261: 
  1262:     | `BEXE_jump (sr,((`BEXPR_closure (index,ts),_)),a)
  1263:     | `BEXE_jump_direct (sr,index,ts,a) ->
  1264:       let a = match a with (a,t) -> a, tsub t in
  1265:       let subs,x = unravel syms bbdfns a in
  1266:       let subs = map (fun ((e,t),s) -> (e,tsub t),s) subs in
  1267:       let ts = map tsub ts in
  1268:       handle_closure sr true index ts subs x false
  1269: 
  1270:     | `BEXE_loop (sr,i,a) ->
  1271:       let ptr =
  1272:         if i= this then "this"
  1273:         else "ptr"^cpp_instance_name syms bbdfns i ts
  1274:       in
  1275:         print_endline ("Looping to " ^ ptr);
  1276:         let args = ptr ^ "->" ^
  1277:           (match a with
  1278:           | _,`BTYP_tuple [] -> "_caller"
  1279:           | _ -> "_caller, " ^ ge sr a
  1280:           )
  1281:         in
  1282:         "      //"^ src_str ^ "\n" ^
  1283:         (
  1284:           if i <> this then
  1285:           "      {\n" ^
  1286:           "        con_t *res = " ^ ptr ^ "\n      ->call(" ^ args ^");\n" ^
  1287:           "        printf(\"unwinding from %p to %p\\n\",this,"^ptr^");\n" ^
  1288:           "        con_t *p = this;\n" ^
  1289:           "        while(res && res != "^ptr^") { res = p->_caller; printf(\"called by %p\\n\",p); }\n"^
  1290:           "        for(con_t *tmp=this; tmp != (con_t*)"^ptr^";){//unwind stack\n" ^
  1291:           "           con_t *tmp2 = tmp->_caller;\n" ^
  1292:           "           printf(\"unwinding %p, caller is %p\\n\",tmp,tmp2);\n" ^
  1293:           "           tmp->_caller = 0;\n" ^
  1294:           "           tmp = tmp2;\n"^
  1295:           "        }\n" ^
  1296:           "        return res;\n" ^
  1297:           "      }\n"
  1298:           else
  1299:           "      return " ^ ptr ^ "\n      ->call(" ^ args ^");\n"
  1300:         )
  1301: 
  1302:     (* If p is a variable containing a closure,
  1303:        and p recursively invokes the same closure,
  1304:        then the program counter and other state
  1305:        of the closure would be lost, so we clone it
  1306:        instead .. the closure variables is never
  1307:        used (a waste if it isn't re-entered .. oh well)
  1308:      *)
  1309: 
  1310:     | `BEXE_call (sr,p,a) ->
  1311:       let args =
  1312:         let this = match kind with
  1313:           | Procedure -> "this"
  1314:           | Function -> "0"
  1315:         in
  1316:         match a with
  1317:         | _,`BTYP_tuple [] -> this
  1318:         | _ -> this ^ ", " ^ ge sr a
  1319:       in
  1320:       begin match kind with
  1321:       | Function ->
  1322:         (if with_comments then
  1323:         "      //run procedure " ^ src_str ^ "\n"
  1324:         else "") ^
  1325:         "      {\n" ^
  1326:         "        con_t *_p = "^ge sr p ^ "->clone()\n      ->call("^args^");\n" ^
  1327:         "        while(_p) _p=_p->resume();\n" ^
  1328:         "      }\n"
  1329: 
  1330: 
  1331: 
  1332:       | Procedure ->
  1333:         needs_switch := true;
  1334:         let n = !counter in
  1335:         incr counter;
  1336:         (if with_comments then
  1337:         "      //"^ src_str ^ "\n"
  1338:         else "") ^
  1339:         "      FLX_SET_PC(" ^ si n ^ ")\n" ^
  1340:         "      return " ^ ge sr p ^ "->clone()\n      ->call(" ^ args ^");\n" ^
  1341:         "    FLX_CASE_LABEL(" ^ si n ^ ")\n"
  1342:       end
  1343: 
  1344:     | `BEXE_jump (sr,p,a) ->
  1345:       let args = match a with
  1346:         | _,`BTYP_tuple [] -> "tmp"
  1347:         | _ -> "tmp, " ^ ge sr a
  1348:       in
  1349:       (if with_comments then
  1350:       "      //"^ src_str ^ "\n"
  1351:       else "") ^
  1352:       "      {\n" ^
  1353:       "        con_t *tmp = _caller;\n" ^
  1354:       "        _caller=0;\n" ^
  1355:       "        return " ^ ge sr p ^ "\n      ->call(" ^ args ^");\n" ^
  1356:       "      }\n"
  1357: 
  1358:     | `BEXE_proc_return _ ->
  1359:       if stackable then
  1360:       "      return;\n"
  1361:       else
  1362:       "      FLX_RETURN\n"
  1363: 
  1364:     | `BEXE_svc (sr,index) ->
  1365:       let id,parent,sr,entry =
  1366:         try Hashtbl.find bbdfns index
  1367:         with _ -> failwith ("[gen_expr(name)] Can't find index " ^ si index)
  1368:       in
  1369:       let t =
  1370:         match entry with
  1371:         | `BBDCL_var (_,t) -> t
  1372:         | `BBDCL_val (_,t) -> t
  1373:         | _ -> syserr sr "Expected read argument to be variable"
  1374:       in
  1375:       let n = !counter in incr counter;
  1376:       needs_switch := true;
  1377:       "      //read variable\n" ^
  1378:       "      p_svc = &" ^ get_var_ref syms bbdfns this index ts^";\n" ^
  1379:       "      FLX_SET_PC(" ^ si n ^ ")\n" ^
  1380:       "      return this;\n" ^
  1381:       "    FLX_CASE_LABEL(" ^ si n ^ ")\n"
  1382: 
  1383: 
  1384:     | `BEXE_fun_return (sr,e) ->
  1385:       let _,t = e in
  1386:       (if with_comments then
  1387:       "      //" ^ src_str ^ ": type "^tn t^"\n"
  1388:       else "") ^
  1389:       "      return "^ge sr e^";\n"
  1390: 
  1391:     | `BEXE_nop (_,s) -> "      //Nop: " ^ s ^ "\n"
  1392: 
  1393:     | `BEXE_assign (sr,e1,(( _,t) as e2)) ->
  1394:       let t = lstrip syms.dfns (tsub t) in
  1395:       begin match t with
  1396:       | `BTYP_tuple [] -> ""
  1397:       | _ ->
  1398:       (if with_comments then "      //"^src_str^"\n" else "") ^
  1399:       "      "^ ge sr e1 ^ " = " ^ ge sr e2 ^
  1400:       ";\n"
  1401:       end
  1402: 
  1403:     | `BEXE_init (sr,v,((_,t) as e)) ->
  1404:       let t = lstrip syms.dfns (tsub t) in
  1405:       begin match t with
  1406:       | `BTYP_tuple [] -> ""
  1407:       | _ ->
  1408:         let id,_,_,entry =
  1409:           try Hashtbl.find bbdfns v with
  1410:           Not_found -> failwith ("[gen_expr(init) can't find index " ^ si v)
  1411:         in
  1412:         begin match entry with
  1413:           | `BBDCL_tmp _ ->
  1414:           (if with_comments then "      //"^src_str^"\n" else "") ^
  1415:           "      "^
  1416:           get_variable_typename syms bbdfns v [] ^
  1417:           " " ^
  1418:           get_var_ref syms bbdfns this v ts^
  1419:           " = " ^
  1420:           ge sr e ^
  1421:           ";\n"
  1422:           | `BBDCL_val _
  1423:           | `BBDCL_var _ ->
  1424:           (*
  1425:           print_endline ("INIT of " ^ si v ^ " inside " ^ si this);
  1426:           *)
  1427:           (if with_comments then "      //"^src_str^"\n" else "") ^
  1428:           "      "^
  1429:           get_var_ref syms bbdfns this v ts^
  1430:           " = " ^
  1431:           ge sr e ^
  1432:           ";\n"
  1433:           | _ -> assert false
  1434:         end
  1435:       end
  1436: 
  1437:     | `BEXE_begin -> "      {\n"
  1438:     | `BEXE_end -> "      }\n"
  1439: 
  1440:     | `BEXE_assert (sr,e) ->
  1441:        let f,sl,sc,el,ec = sr in
  1442:        let s = string_of_string f ^"," ^
  1443:          si sl ^ "," ^ si sc ^ "," ^
  1444:          si el ^ "," ^ si ec
  1445:        in
  1446:        "      {if(!(" ^ ge sr e ^ "))FLX_ASSERT_FAILURE("^s^");}\n"
  1447: 
  1448:     | `BEXE_assert2 (sr,sr2,e) ->
  1449:        let f,sl,sc,el,ec = sr in
  1450:        let s = string_of_string f ^"," ^
  1451:          si sl ^ "," ^ si sc ^ "," ^
  1452:          si el ^ "," ^ si ec
  1453:        in
  1454:        let f2,sl2,sc2,el2,ec2 = sr2 in
  1455:        let s2 = string_of_string f2 ^"," ^
  1456:          si sl2 ^ "," ^ si sc2 ^ "," ^
  1457:          si el2 ^ "," ^ si ec2
  1458:        in
  1459:        "      {if(!(" ^ ge sr e ^ "))FLX_ASSERT2_FAILURE("^s^"," ^ s2 ^");}\n"
  1460:   in gexe exe
  1461: 
  1462: let gen_exes filename syms bbdfns display label_info counter index exes vs ts instance_no stackable =
  1463:   let needs_switch = ref false in
  1464:   let s = cat ""
  1465:     (map (gen_exe filename syms bbdfns label_info counter index vs ts instance_no needs_switch stackable) exes)
  1466:   in
  1467:   s,!needs_switch
  1468: 
  1469: (* PROCEDURES are implemented by continuations.
  1470:    The constructor accepts the display vector to
  1471:    form the closure object. The call method accepts
  1472:    the callers continuation object as a return address,
  1473:    and the procedure argument, and returns a continuation.
  1474:    The resume method runs the continuation until
  1475:    it returns a continuation to some object, possibly
  1476:    the same object. A flag in the continuation object
  1477:    determines whether the yield of control is a request
  1478:    for data or not (if so, the dispatcher must place the data
  1479:    in the nominated place before calling the resume method again.
  1480: *)
  1481: 
  1482: (* FUNCTIONS are implemented as functoids:
  1483:   the constructor accepts the display vector so as
  1484:   to form a closure object, the apply method
  1485:   accepts the argument and runs the function.
  1486:   The machine stack is used for functions.
  1487: *)
  1488: let gen_C_function_body filename syms (child_map,bbdfns)
  1489:   label_info counter index ts instance_no
  1490: =
  1491:   let rt vs t = reduce_type (lstrip syms.dfns (beta_reduce syms [] (tsubst vs ts t))) in
  1492:   let id,parent,sr,entry =
  1493:     try Hashtbl.find bbdfns index
  1494:     with Not_found -> failwith ("gen_C_function_body] can't find " ^ si index)
  1495:   in
  1496:   if syms.compiler_options.print_flag then
  1497:   print_endline
  1498:   (
  1499:     "//Generating C function body inst " ^
  1500:     si instance_no ^ "=" ^
  1501:     id ^ "<" ^si index^">" ^
  1502:     (
  1503:       if length ts = 0 then ""
  1504:       else "[" ^ catmap "," (string_of_btypecode syms.dfns) ts ^ "]"
  1505:     )
  1506:   );
  1507:   match entry with
  1508:   | `BBDCL_function (props,vs,(bps,traint),ret',exes) ->
  1509:     let requires_ptf = mem `Requires_ptf props in
  1510:     if length ts <> length vs then
  1511:     failwith
  1512:     (
  1513:       "[get_function_methods] wrong number of type args, expected vs = " ^
  1514:       si (length vs) ^
  1515:       ", got ts=" ^
  1516:       si (length ts)
  1517:     );
  1518:     let name = cpp_instance_name syms bbdfns index ts in
  1519: 
  1520:     "//C FUNC " ^ name ^ "\n" ^
  1521: 
  1522:     let argtype = lower (typeof_bparams bps) in
  1523:     let argtype = rt vs argtype in
  1524:     let rt' vs t = reduce_type (beta_reduce syms [] (tsubst vs ts t)) in
  1525:     let ret = rt' vs ret' in
  1526:     let is_ref = match ret with | `BTYP_lvalue _ -> true | _ -> false in
  1527:     let ret = lstrip syms.dfns ret in
  1528:     if ret = `BTYP_tuple [] then "// elided (returns unit)\n\n" else
  1529: 
  1530: 
  1531:     let funtype = fold syms.dfns (`BTYP_function (argtype, ret)) in
  1532:     let argtypename = cpp_typename syms argtype in
  1533:     let rettypename = cpp_typename syms ret in
  1534: 
  1535:     let params = map (fun (id,(ix,t)) -> ix) bps in
  1536:     let exe_string,_ =
  1537:       try
  1538:         gen_exes filename syms (child_map,bbdfns) [] label_info counter index exes vs ts instance_no true
  1539:       with x ->
  1540:         print_endline (Printexc.to_string x);
  1541:         print_endline (catmap "\n" (string_of_bexe syms.dfns 1) exes);
  1542:         print_endline "Can't gen exes ..";
  1543:         raise x
  1544:     in
  1545:     let dcl_vars =
  1546:       let kids = find_children child_map index in
  1547:       let kids =
  1548:         fold_left
  1549:         (fun lst i ->
  1550:           let _,_,_,entry =
  1551:             try Hashtbl.find bbdfns i
  1552:             with Not_found -> failwith ("[C func body, vars] Can't find index " ^ si i);
  1553:           in
  1554:           match entry with
  1555:           | `BBDCL_var (vs,t)
  1556:           | `BBDCL_val (vs,t)
  1557:             when not (mem i params) ->
  1558:             (i, rt vs t) :: lst
  1559:           | _ -> lst
  1560:         )
  1561:         [] kids
  1562:       in
  1563:       fold_left
  1564:       (fun s (i,t) -> s ^ "  " ^
  1565:         cpp_typename syms t ^ " " ^
  1566:         cpp_instance_name syms bbdfns i ts ^ ";\n"
  1567:       )
  1568:       "" kids
  1569:     in
  1570:       rettypename ^ " " ^
  1571:       (if is_ref then "& " else "") ^
  1572:       "FLX_REGPARM " ^
  1573:       name ^ "(" ^
  1574:       (
  1575:         let s =
  1576:           match length params with
  1577:           | 0 -> ""
  1578:           | 1 ->
  1579:             let ix = hd params in
  1580:             if Hashtbl.mem syms.instances (ix, ts)
  1581:             && not (argtype = `BTYP_tuple [])
  1582:             then
  1583:               argtypename ^ "  " ^ cpp_instance_name syms bbdfns ix ts
  1584:             else ""
  1585:           | _ ->
  1586:               let counter = ref 0 in
  1587:               fold_left
  1588:               (fun s (_,(i,t)) ->
  1589:                 let t = rt vs (lower t) in
  1590:                 let n = !counter in incr counter;
  1591:                 if Hashtbl.mem syms.instances (i,ts) && not (t = `BTYP_tuple [])
  1592:                 then s ^
  1593:                   (if String.length s > 0 then ", " else " ") ^
  1594:                   cpp_typename syms t ^ " " ^
  1595:                   cpp_instance_name syms bbdfns i ts
  1596:                 else s (* elide initialisation of elided variable *)
  1597:               )
  1598:               ""
  1599:               bps
  1600:         in
  1601:           (
  1602:             if requires_ptf then
  1603:               if String.length s > 0
  1604:               then "FLX_APAR_DECL " ^ s
  1605:               else "FLX_APAR_DECL_ONLY"
  1606:             else s
  1607:           )
  1608:       )^
  1609:       "){\n" ^
  1610:       (*
  1611:       (if mem `Uses_gc props then
  1612:       "  collector_t &gc = *PTF gc;\n"
  1613:       else ""
  1614:       ) ^
  1615:       *)
  1616:       (* NO LONGER UNPACK ARGUMENT
  1617:       (
  1618:         match length params with
  1619:         | 0 -> ""
  1620:         | 1 ->
  1621:           let i = hd params in
  1622:           if Hashtbl.mem syms.instances (i, ts)
  1623:           && not (argtype = `BTYP_tuple [])
  1624:           then
  1625:             argtypename ^ "  " ^ cpp_instance_name syms bbdfns i ts ^ " = _arg;\n"
  1626:           else ""
  1627:         | _ ->
  1628:           let counter = ref 0 in fold_left
  1629:           (fun s i ->
  1630:             let n = !counter in incr counter;
  1631:             if Hashtbl.mem syms.instances (i,ts)
  1632:             then
  1633:               let memexpr,t =
  1634:                 match argtype with
  1635:                 | `BTYP_array (t,`BTYP_unitsum _) -> ".data["^si n^"]",t
  1636:                 | `BTYP_tuple ts -> ".mem_"^ si n,
  1637:                   begin try nth ts n
  1638:                   with Not_found ->
  1639:                   failwith ("Can't find component " ^ si n ^ " of " ^ sbt syms.dfns argtype)
  1640:                   end
  1641: 
  1642:                 | _ -> assert false
  1643:               in
  1644:               let t = cpp_typename syms t in
  1645:               s ^ "  " ^ t ^ "  " ^ cpp_instance_name syms bbdfns i ts ^ " = _arg"^ memexpr ^";\n"
  1646:             else s (* elide initialisation of elided variable *)
  1647:           )
  1648:           "" params
  1649:       )^
  1650:       *)
  1651:       dcl_vars ^
  1652:       exe_string ^
  1653:       "}\n"
  1654: 
  1655:   | _ -> failwith "function expected"
  1656: 
  1657: let gen_C_procedure_body filename syms (child_map,bbdfns)
  1658:   label_info counter index ts instance_no
  1659: =
  1660:   let rt vs t = reduce_type (lstrip syms.dfns (beta_reduce syms [] (tsubst vs ts t))) in
  1661:   let id,parent,sr,entry =
  1662:     try Hashtbl.find bbdfns index
  1663:     with Not_found -> failwith ("gen_C_function_body] can't find " ^ si index)
  1664:   in
  1665:   if syms.compiler_options.print_flag then
  1666:   print_endline
  1667:   (
  1668:     "//Generating C procedure body inst " ^
  1669:     si instance_no ^ "=" ^
  1670:     id ^ "<" ^si index^">" ^
  1671:     (
  1672:       if length ts = 0 then ""
  1673:       else "[" ^ catmap "," (string_of_btypecode syms.dfns) ts ^ "]"
  1674:     )
  1675:   );
  1676:   match entry with
  1677:   | `BBDCL_procedure (props,vs,(bps,traint),exes) ->
  1678:     let requires_ptf = mem `Requires_ptf props in
  1679:     if length ts <> length vs then
  1680:     failwith
  1681:     (
  1682:       "[get_function_methods] wrong number of type args, expected vs = " ^
  1683:       si (length vs) ^
  1684:       ", got ts=" ^
  1685:       si (length ts)
  1686:     );
  1687:     let name = cpp_instance_name syms bbdfns index ts in
  1688: 
  1689:     "//C PROC " ^ name ^ "\n" ^
  1690: 
  1691:     let argtype = lower (typeof_bparams bps) in
  1692:     let argtype = rt vs argtype in
  1693: 
  1694:     let funtype = fold syms.dfns (`BTYP_function (argtype, `BTYP_void)) in
  1695:     let argtypename = cpp_typename syms argtype in
  1696: 
  1697:     let params = map (fun (id,(ix,t)) -> ix) bps in
  1698:     let exe_string,_ =
  1699:       try
  1700:         gen_exes filename syms (child_map,bbdfns) [] label_info counter index exes vs ts instance_no true
  1701:       with x ->
  1702:         print_endline (Printexc.to_string x);
  1703:         print_endline (catmap "\n" (string_of_bexe syms.dfns 1) exes);
  1704:         print_endline "Can't gen exes ..";
  1705:         raise x
  1706:     in
  1707:     let dcl_vars =
  1708:       let kids = find_children child_map index in
  1709:       let kids =
  1710:         fold_left
  1711:         (fun lst i ->
  1712:           let _,_,_,entry =
  1713:             try Hashtbl.find bbdfns i
  1714:             with Not_found -> failwith ("[C func body, vars] Can't find index " ^ si i);
  1715:           in
  1716:           match entry with
  1717:           | `BBDCL_var (vs,t)
  1718:           | `BBDCL_val (vs,t)
  1719:             when not (mem i params) ->
  1720:             (i, rt vs t) :: lst
  1721:           | _ -> lst
  1722:         )
  1723:         [] kids
  1724:       in
  1725:       fold_left
  1726:       (fun s (i,t) -> s ^ "  " ^
  1727:         cpp_typename syms t ^ " " ^
  1728:         cpp_instance_name syms bbdfns i ts ^ ";\n"
  1729:       )
  1730:       "" kids
  1731:     in
  1732:       "void " ^
  1733:       "FLX_REGPARM " ^
  1734:       name ^ "(" ^
  1735:       (
  1736:         let s =
  1737:           match length params with
  1738:           | 0 -> ""
  1739:           | 1 ->
  1740:             let ix = hd params in
  1741:             if Hashtbl.mem syms.instances (ix, ts)
  1742:             && not (argtype = `BTYP_tuple [])
  1743:             then
  1744:               argtypename ^ "  " ^ cpp_instance_name syms bbdfns ix ts
  1745:             else ""
  1746:           | _ ->
  1747:               let counter = ref 0 in
  1748:               fold_left
  1749:               (fun s (_,(i,t)) ->
  1750:                 let t = rt vs (lower t) in
  1751:                 let n = !counter in incr counter;
  1752:                 if Hashtbl.mem syms.instances (i,ts) && not (t = `BTYP_tuple [])
  1753:                 then s ^
  1754:                   (if String.length s > 0 then ", " else " ") ^
  1755:                   cpp_typename syms t ^ " " ^
  1756:                   cpp_instance_name syms bbdfns i ts
  1757:                 else s (* elide initialisation of elided variable *)
  1758:               )
  1759:               ""
  1760:               bps
  1761:         in
  1762:           (
  1763:             if requires_ptf then
  1764:               if String.length s > 0
  1765:               then "FLX_APAR_DECL " ^ s
  1766:               else "FLX_APAR_DECL_ONLY"
  1767:             else s
  1768:           )
  1769:       )^
  1770:       "){\n" ^
  1771:       (*
  1772:       (if mem `Uses_gc props then
  1773:       "  collector_t &gc = *PTF gc;\n"
  1774:       else ""
  1775:       ) ^
  1776:       *)
  1777:       (* NO LONGER UNPACK ARGUMENT
  1778:       (
  1779:         match length params with
  1780:         | 0 -> ""
  1781:         | 1 ->
  1782:           let i = hd params in
  1783:           if Hashtbl.mem syms.instances (i, ts)
  1784:           && not (argtype = `BTYP_tuple [])
  1785:           then
  1786:             argtypename ^ "  " ^ cpp_instance_name syms bbdfns i ts ^ " = _arg;\n"
  1787:           else ""
  1788:         | _ ->
  1789:           let counter = ref 0 in fold_left
  1790:           (fun s i ->
  1791:             let n = !counter in incr counter;
  1792:             if Hashtbl.mem syms.instances (i,ts)
  1793:             then
  1794:               let memexpr,t =
  1795:                 match argtype with
  1796:                 | `BTYP_array (t,`BTYP_unitsum _) -> ".data["^si n^"]",t
  1797:                 | `BTYP_tuple ts -> ".mem_"^ si n,nth ts n
  1798:                 | _ -> assert false
  1799:               in
  1800:               let t = cpp_typename syms t in
  1801:               s ^ "  " ^ t ^ "  " ^ cpp_instance_name syms bbdfns i ts ^ " = _arg"^ memexpr ^";\n"
  1802:             else s (* elide initialisation of elided variable *)
  1803:           )
  1804:           "" params
  1805:       )^
  1806:       *)
  1807:       dcl_vars ^
  1808:       exe_string ^
  1809:       "}\n"
  1810: 
  1811:   | _ -> failwith "procedure expected"
  1812: 
  1813: let gen_function_methods filename syms (child_map,bbdfns)
  1814:   label_info counter index ts instance_no
  1815: =
  1816:   let rt vs t = reduce_type (lstrip syms.dfns (beta_reduce syms [] (tsubst vs ts t))) in
  1817:   let id,parent,sr,entry =
  1818:     try Hashtbl.find bbdfns index
  1819:     with Not_found -> failwith ("[gen_function_methods] can't find " ^ si index)
  1820:   in
  1821:   if syms.compiler_options.print_flag then
  1822:   print_endline
  1823:   (
  1824:     "//Generating function body inst " ^
  1825:     si instance_no ^ "=" ^
  1826:     id ^ "<" ^si index^">" ^
  1827:     (
  1828:       if length ts = 0 then ""
  1829:       else "[" ^ catmap "," (string_of_btypecode syms.dfns) ts ^ "]"
  1830:     )
  1831:   );
  1832:   match entry with
  1833:   | `BBDCL_function (props,vs,(bps,traint),ret',exes) ->
  1834:     if length ts <> length vs then
  1835:     failwith
  1836:     (
  1837:       "[get_function_methods} wrong number of args, expected vs = " ^
  1838:       si (length vs) ^
  1839:       ", got ts=" ^
  1840:       si (length ts)
  1841:     );
  1842:     let argtype = lower (typeof_bparams bps) in
  1843:     let argtype = rt vs argtype in
  1844:     let rt' vs t = reduce_type (beta_reduce syms [] (tsubst vs ts t)) in
  1845:     let ret = rt' vs ret' in
  1846:     let is_ref = match ret with | `BTYP_lvalue _ -> true | _ -> false in
  1847:     let ret = lstrip syms.dfns ret in
  1848:     if ret = `BTYP_tuple [] then "// elided (returns unit)\n" else
  1849: 
  1850:     let funtype = fold syms.dfns (`BTYP_function (argtype, ret)) in
  1851: 
  1852:     let argtypename = cpp_typename syms argtype in
  1853:     let name = cpp_instance_name syms bbdfns index ts in
  1854: 
  1855:     let display = get_display_list bbdfns index in
  1856: 
  1857:     let rettypename = cpp_typename syms ret in
  1858: 
  1859:     let ctor =
  1860:       let vars =  find_references syms (child_map,bbdfns) index ts in
  1861:       let funs = filter (fun (_,t) -> is_gc_pointer syms bbdfns sr t) vars in
  1862:       gen_ctor syms bbdfns name display funs [] [] ts props
  1863:     in
  1864:     let params = map (fun (id,(ix,t)) -> ix) bps in
  1865:     let exe_string,_ =
  1866:       try
  1867:         gen_exes filename syms (child_map,bbdfns) display label_info counter index exes vs ts instance_no false
  1868:       with x ->
  1869:         print_endline (Printexc.to_string x);
  1870:         print_endline (catmap "\n" (string_of_bexe syms.dfns 1) exes);
  1871:         print_endline "Can't gen exes ..";
  1872:         raise x
  1873:     in
  1874:     let cont = "con_t *" in
  1875:     let apply =
  1876:       rettypename^ " " ^name^
  1877:       "::apply("^
  1878:       (if argtype = `BTYP_tuple []
  1879:       then ""
  1880:       else argtypename ^" const &_arg ")^
  1881:       "){\n" ^
  1882:       (*
  1883:       (if mem `Uses_gc props then
  1884:       "  collector_t &gc = *PTF gc;\n"
  1885:       else ""
  1886:       )
  1887:       ^
  1888:       *)
  1889:       (
  1890:         match length params with
  1891:         | 0 -> ""
  1892:         | 1 ->
  1893:           let i = hd params in
  1894:           if Hashtbl.mem syms.instances (i, ts)
  1895:           && not (argtype = `BTYP_tuple [])
  1896:           then
  1897:             "  " ^ cpp_instance_name syms bbdfns i ts ^ " = _arg;\n"
  1898:           else ""
  1899:         | _ ->
  1900:           let counter = ref 0 in fold_left
  1901:           (fun s i ->
  1902:             let n = !counter in incr counter;
  1903:             if Hashtbl.mem syms.instances (i,ts)
  1904:             then
  1905:               let memexpr =
  1906:                 match argtype with
  1907:                 | `BTYP_array _ -> ".data["^si n^"]"
  1908:                 | `BTYP_tuple _ -> ".mem_"^ si n
  1909:                 | _ -> assert false
  1910:               in
  1911:               s ^ "  " ^ cpp_instance_name syms bbdfns i ts ^ " = _arg"^ memexpr ^";\n"
  1912:             else s (* elide initialisation of elided variable *)
  1913:           )
  1914:           "" params
  1915:       )^
  1916:       exe_string ^
  1917:       "}\n"
  1918:     and clone =
  1919:       "  " ^ name ^ "* "^name^"::clone()const {\n"^
  1920:       "  return new(*PTF gc,"^name^"_ptr_map) "^name^"(*this);\n"^
  1921:       "}\n"
  1922:     in
  1923:       let q = qualified_name_of_index syms.dfns index in
  1924:       "//FUNC " ^ q ^ ": Constructor\n" ^
  1925:       ctor^ "\n" ^
  1926:       (
  1927:         if mem `Heap_closure props then
  1928:         "\n//FUNC " ^ q ^ ": Clone method\n" ^
  1929:         clone^ "\n"
  1930:         else ""
  1931:       )
  1932:       ^
  1933:       "//FUNC " ^ q ^ ": Apply method\n" ^
  1934:       apply^ "\n"
  1935: 
  1936:   | _ -> failwith "function expected"
  1937: 
  1938: let gen_regexp_methods filename syms (child_map,bbdfns)
  1939:   label_info counter index ts instance_no
  1940: =
  1941:   let rt vs t = reduce_type (lstrip syms.dfns (beta_reduce syms [] (tsubst vs ts t))) in
  1942:   let id,parent,sr,entry =
  1943:     try Hashtbl.find bbdfns index
  1944:     with Not_found -> failwith ("[gen_regexp_methods] Can't find index " ^ si index)
  1945:   in
  1946:   if syms.compiler_options.print_flag then
  1947:   print_endline
  1948:   (
  1949:     "//Generating regmatch/reglex body inst " ^
  1950:     si instance_no ^ "=" ^
  1951:     id ^ "<" ^si index^">" ^
  1952:     (
  1953:       if length ts = 0 then ""
  1954:       else "[" ^ catmap "," (string_of_btypecode syms.dfns) ts ^ "]"
  1955:     )
  1956:   );
  1957:   let lexeme_start,buffer_end,lexeme_end,kind = match entry with
  1958:   | `BBDCL_regmatch (props,vs,(bps,traint),ret',cls) ->
  1959:     let p1 = fst (snd (hd bps)) in
  1960:     let p1' = cpp_instance_name syms bbdfns p1 ts in
  1961:     let p2 = fst (snd (hd (tl bps))) in
  1962:     let p2' = cpp_instance_name syms bbdfns p2 ts in
  1963:     p1',p2',None,`regmatch (p1',p2')
  1964: 
  1965:   | `BBDCL_reglex (props,vs,(bps,traint),i,ret',cls) ->
  1966:     let p1 = fst (snd (hd bps)) in
  1967:     let p1' = cpp_instance_name syms bbdfns p1 ts in
  1968:     let p2 = fst (snd (hd (tl bps))) in
  1969:     let p2' = cpp_instance_name syms bbdfns p2 ts in
  1970:     let v = cpp_instance_name syms bbdfns i ts in
  1971:     p1',p2',Some v,`reglex (p1',p2',v)
  1972: 
  1973:   | _ -> assert false
  1974:   in
  1975:   match entry with
  1976:   | `BBDCL_regmatch (props,vs,(bps,traint),ret',cls)
  1977:   | `BBDCL_reglex (props,vs,(bps,traint),_,ret',cls) ->
  1978:     if length ts <> length vs then
  1979:     failwith
  1980:     (
  1981:       "[get_function_methods} wrong number of args, expected vs = " ^
  1982:       si (length vs) ^
  1983:       ", got ts=" ^
  1984:       si (length ts)
  1985:     );
  1986:     let argtype = lower (typeof_bparams bps) in
  1987:     let argtype = rt vs argtype in
  1988:     let ret = rt vs (lower ret') in
  1989:     let funtype = fold syms.dfns (`BTYP_function (argtype, ret)) in
  1990: 
  1991:     let argtypename = cpp_typename syms argtype in
  1992:     let name = cpp_instance_name syms bbdfns index ts in
  1993: 
  1994:     let display = get_display_list bbdfns index in
  1995: 
  1996:     let rettypename = cpp_typename syms ret in
  1997: 
  1998:     let ctor =
  1999:       let vars =  find_references syms (child_map,bbdfns) index ts in
  2000:       let funs = filter (fun (_,t) -> is_gc_pointer syms bbdfns sr t) vars in
  2001:       gen_ctor syms bbdfns name display funs [] [] ts props
  2002:     in
  2003:     let params = map (fun (id,(ix,t)) -> ix) bps in
  2004:     let exe_string =
  2005:       let ge e : string = gen_expr syms bbdfns index e vs ts sr in
  2006:       let b = Buffer.create 2000 in
  2007:       Flx_regen.regen b sr cls kind ge;
  2008:       Buffer.contents b
  2009:     in
  2010:     let cont = "con_t *" in
  2011:     let apply =
  2012:       rettypename^ " " ^name^ "::apply("^
  2013:       argtypename ^" const &_arg ){\n" ^
  2014:       (*
  2015:       (if mem `Uses_gc props then
  2016:       "  collector_t &gc = *PTF gc;\n"
  2017:       else ""
  2018:       ) ^
  2019:       *)
  2020:       "  " ^ lexeme_start ^ " = _arg.data[0];\n" ^
  2021:       "  " ^ buffer_end ^ " = _arg.data[1];\n" ^
  2022:       exe_string ^
  2023:       "}\n"
  2024:     and clone =
  2025:       "  " ^ name ^ "* "^name^"::clone()const {\n"^
  2026:       "  return new(*PTF gc,"^name^"_ptr_map) "^name^"(*this);\n"^
  2027:       "}\n"
  2028:     in
  2029:       let q = qualified_name_of_index syms.dfns index in
  2030:       "//FUNC " ^ q ^ ": Constructor\n" ^
  2031:       ctor^ "\n" ^
  2032:       (
  2033:         if mem `Heap_closure props then
  2034:         "\n//FUNC " ^ q ^ ": Clone method\n" ^
  2035:         clone^ "\n"
  2036:         else ""
  2037:       )
  2038:       ^
  2039:       "//FUNC " ^ q ^ ": Apply method\n" ^
  2040:       apply^ "\n"
  2041: 
  2042:   | _ -> failwith "function expected"
  2043: 
  2044: 
  2045: let gen_class_methods filename syms (child_map,bbdfns)
  2046:   label_info counter index ts instance_no
  2047: =
  2048:   let rt vs t = reduce_type (lstrip syms.dfns (beta_reduce syms [] (tsubst vs ts t))) in
  2049:   let id,parent,sr,entry =
  2050:     try Hashtbl.find bbdfns index
  2051:     with Not_found -> failwith ("[gen_class_methods] Can't find index " ^ si index)
  2052:   in (* can't fail *)
  2053:   if syms.compiler_options.print_flag then
  2054:   print_endline
  2055:   (
  2056:     "//Generating class inst " ^
  2057:     si instance_no ^ "=" ^
  2058:     id ^ "<" ^si index^">" ^
  2059:     (
  2060:       if length ts = 0 then ""
  2061:       else "[" ^ catmap "," (string_of_btypecode syms.dfns) ts ^ "]"
  2062:     )
  2063:   );
  2064:   match entry with
  2065:   | `BBDCL_class (props,vs) ->
  2066:     if length ts <> length vs then
  2067:     failwith
  2068:     (
  2069:       "[get_class_methods} wrong number of args, expected vs = " ^
  2070:       si (length vs) ^
  2071:       ", got ts=" ^
  2072:       si (length ts)
  2073:     );
  2074: 
  2075:     let name = cpp_instance_name syms bbdfns index ts in
  2076:     let display = get_display_list bbdfns index in
  2077:     let ctor =
  2078:       let vars =  find_references syms (child_map,bbdfns) index ts in
  2079:       let funs = filter (fun (_,t) -> is_gc_pointer syms bbdfns sr t) vars in
  2080:       gen_ctor syms bbdfns name display funs [] [] ts props
  2081:     in
  2082: 
  2083:       let q =
  2084:         try qualified_name_of_index syms.dfns index
  2085:         with Not_found ->
  2086:           si instance_no ^ "=" ^
  2087:           id ^ "<" ^si index^">" ^
  2088:           (
  2089:             if length ts = 0 then ""
  2090:             else "[" ^ catmap "," (string_of_btypecode syms.dfns) ts ^ "]"
  2091:           )
  2092:       in
  2093:       "\n//CLASS " ^ q ^ "\n" ^
  2094:       "//CLASS " ^ q ^ ": Constructor\n" ^
  2095:       ctor
  2096: 
  2097:   | _ -> failwith "class expected"
  2098: 
  2099: let gen_procedure_methods filename syms (child_map,bbdfns)
  2100:   label_info counter index ts instance_no
  2101: =
  2102:   let rt vs t = reduce_type (lstrip syms.dfns (beta_reduce syms [] (tsubst vs ts t))) in
  2103:   let id,parent,sr,entry =
  2104:     try Hashtbl.find bbdfns index
  2105:     with Not_found -> failwith ("[gen_procedure_methods] Can't find index " ^ si index)
  2106:   in (* can't fail *)
  2107:   if syms.compiler_options.print_flag then
  2108:   print_endline
  2109:   (
  2110:     "//Generating procedure body inst " ^
  2111:     si instance_no ^ "=" ^
  2112:     id ^ "<" ^si index^">" ^
  2113:     (
  2114:       if length ts = 0 then ""
  2115:       else "[" ^ catmap "," (string_of_btypecode syms.dfns) ts ^ "]"
  2116:     )
  2117:   );
  2118:   match entry with
  2119:   | `BBDCL_procedure (props,vs,(bps,traint),exes) ->
  2120:     if length ts <> length vs then
  2121:     failwith
  2122:     (
  2123:       "[get_procedure_methods} wrong number of args, expected vs = " ^
  2124:       si (length vs) ^
  2125:       ", got ts=" ^
  2126:       si (length ts)
  2127:     );
  2128:     let stackable = mem `Stack_closure props in
  2129:     let heapable = mem `Heap_closure props in
  2130:     let heapable = not stackable or heapable in
  2131:     let argtype = lower (typeof_bparams bps) in
  2132:     let argtype = rt vs argtype in
  2133:     let funtype = fold syms.dfns (`BTYP_function (argtype, `BTYP_void)) in
  2134: 
  2135:     let argtypename = cpp_typename syms argtype in
  2136:     let name = cpp_instance_name syms bbdfns index ts in
  2137: 
  2138:     let display = get_display_list bbdfns index in
  2139: 
  2140:     let ctor =
  2141:       let vars =  find_references syms (child_map,bbdfns) index ts in
  2142:       let funs = filter (fun (i,t) -> is_gc_pointer syms bbdfns sr t) vars in
  2143:       gen_ctor syms bbdfns name display funs [] [] ts props
  2144:     in
  2145: 
  2146:     (*
  2147:     let dtor = gen_dtor syms bbdfns name display ts in
  2148:     *)
  2149:     let ps = map (fun (id,(ix,t)) -> id,t) bps in
  2150:     let params = map (fun (id,(ix,t)) -> ix) bps in
  2151:     let exe_string,needs_switch =
  2152:       gen_exes filename syms (child_map,bbdfns) display label_info counter index exes vs ts instance_no (stackable && not heapable)
  2153:     in
  2154: 
  2155:     let cont = "con_t *" in
  2156:     let heap_call_arg_sig, heap_call_arg =
  2157:       match argtype with
  2158:       | `BTYP_tuple [] -> cont ^ "_ptr_caller","0"
  2159:       | _ -> cont ^ "_ptr_caller, " ^ argtypename ^" const &_arg","0,_arg"
  2160:     and stack_call_arg_sig =
  2161:       match argtype with
  2162:       | `BTYP_tuple [] -> ""
  2163:       | _ -> argtypename ^" const &_arg"
  2164:     in
  2165:     let unpack_args =
  2166:         (match length bps with
  2167:         | 0 -> ""
  2168:         | 1 ->
  2169:           let _,(i,_) = hd bps in
  2170:           if Hashtbl.mem syms.instances (i,ts)
  2171:           && not (argtype = `BTYP_tuple[])
  2172:           then
  2173:             "  " ^ cpp_instance_name syms bbdfns i ts ^ " = _arg;\n"
  2174:           else ""
  2175: 
  2176:         | _ -> let counter = ref 0 in fold_left
  2177:           (fun s i ->
  2178:             let n = !counter in incr counter;
  2179:             if Hashtbl.mem syms.instances (i,ts)
  2180:             then
  2181:               let memexpr =
  2182:                 match argtype with
  2183:                 | `BTYP_array _ -> ".data["^si n^"]"
  2184:                 | `BTYP_tuple _ -> ".mem_"^ si n
  2185:                 | _ -> assert false
  2186:               in
  2187:               s ^ "  " ^ cpp_instance_name syms bbdfns i ts ^ " = _arg" ^ memexpr ^";\n"
  2188:             else s (* elide initialisation of elided variables *)
  2189:           )
  2190:           "" params
  2191:           )
  2192:     in
  2193:     let stack_call =
  2194:         "void " ^name^ "::stack_call(" ^ stack_call_arg_sig ^ "){\n" ^
  2195:         (
  2196:           if not heapable
  2197:           then unpack_args ^ exe_string
  2198:           else
  2199:             "  con_t *cc = call("^heap_call_arg^");\n" ^
  2200:             "  while(cc) cc = cc->resume();\n"
  2201:         ) ^ "\n}\n"
  2202:     and heap_call =
  2203:         cont ^ " " ^ name ^ "::call(" ^ heap_call_arg_sig ^ "){\n" ^
  2204:         "  _caller = _ptr_caller;\n" ^
  2205:         unpack_args ^
  2206:         "  INIT_PC\n" ^
  2207:         "  return this;\n}\n"
  2208:     and resume =
  2209:       if exes = []
  2210:       then
  2211:         cont^name^"::resume(){//empty\n"^
  2212:         "     FLX_RETURN\n" ^
  2213:         "}\n"
  2214:       else
  2215:         cont^name^"::resume(){\n"^
  2216:         (if needs_switch then
  2217:         "  FLX_START_SWITCH\n" else ""
  2218:         ) ^
  2219:         exe_string ^
  2220:         "    FLX_RETURN\n" ^ (* HACK .. should be in exe_string .. *)
  2221:         (if needs_switch then
  2222:         "  FLX_END_SWITCH\n" else ""
  2223:         )^
  2224:         "}\n"
  2225:     and clone =
  2226:       "  " ^name^"* "^name^"::clone()const {\n" ^
  2227:         "  return new(*PTF gc,"^name^"_ptr_map) "^name^"(*this);\n" ^
  2228:         "}\n"
  2229:     in
  2230:       let q =
  2231:         try qualified_name_of_index syms.dfns index
  2232:         with Not_found ->
  2233:           si instance_no ^ "=" ^
  2234:           id ^ "<" ^si index^">" ^
  2235:           (
  2236:             if length ts = 0 then ""
  2237:             else "[" ^ catmap "," (string_of_btypecode syms.dfns) ts ^ "]"
  2238:           )
  2239:       in
  2240:       "\n//PROC " ^ q ^ "\n" ^
  2241:       "//PROC " ^ q ^ ": Constructor\n" ^
  2242:       ctor^
  2243:       (
  2244:         if mem `Heap_closure props then
  2245:         "\n//PROC " ^ q ^ ": Clone method\n" ^
  2246:         clone
  2247:         else ""
  2248:       )
  2249:       ^
  2250:       "\n//PROC " ^ q ^ ": Call method\n" ^
  2251:       (if stackable then stack_call else "") ^
  2252:       (if heapable then heap_call else "") ^
  2253:       (if heapable then
  2254:         "\n//PROC " ^ q ^ ": Resume method\n" ^
  2255:         resume
  2256:         else ""
  2257:       )
  2258: 
  2259:   | _ -> failwith "procedure expected"
  2260: 
  2261: 
  2262: let gen_execute_methods filename syms (child_map,bbdfns) label_info counter bf =
  2263:   let s = Buffer.create 2000 in
  2264:   Hashtbl.iter
  2265:   (fun (index,ts) instance_no ->
  2266:   let id,parent,sr,entry =
  2267:     try Hashtbl.find bbdfns index
  2268:     with Not_found -> failwith ("[gen_execute_methods] Can't find index " ^ si index)
  2269:   in
  2270:   begin match entry with
  2271:   | `BBDCL_function (props,vs,(ps,traint), ret, _) ->
  2272:     bcat s ("//------------------------------\n");
  2273:     if mem `Pure props && not (mem `Heap_closure props) then
  2274:       bcat s (
  2275:         gen_C_function_body filename syms (child_map,bbdfns)
  2276:         label_info counter index ts instance_no
  2277:       )
  2278:     else
  2279:       bcat s (
  2280:         gen_function_methods filename syms (child_map,bbdfns)
  2281:         label_info counter index ts instance_no
  2282:       )
  2283: 
  2284:   | `BBDCL_callback (props,vs,ps_cf,ps_c,client_data_pos,ret',_,_) ->
  2285:       let tss =
  2286:         if length ts = 0 then "" else
  2287:         "[" ^ catmap "," (string_of_btypecode syms.dfns) ts^ "]"
  2288:       in
  2289:       bcat s ("\n//------------------------------\n");
  2290:       if ret' = `BTYP_void then begin
  2291:         bcat s ("//CALLBACK C PROC " ^ qualified_name_of_index syms.dfns index ^ tss ^ "\n");
  2292:       end else begin
  2293:         bcat s ("//CALLBACK C FUNCTION " ^ qualified_name_of_index syms.dfns index ^ tss ^ "\n");
  2294:       end
  2295:       ;
  2296:       let rt vs t = reduce_type (lstrip syms.dfns (beta_reduce syms [] (tsubst vs ts t))) in
  2297:       let ps_c = map (rt vs) ps_c in
  2298:       let ps_cf = map (rt vs) ps_cf in
  2299:       let ret = rt vs ret' in
  2300:       if syms.compiler_options.print_flag then
  2301:       print_endline
  2302:       (
  2303:         "//Generating C callback function inst " ^
  2304:         si instance_no ^ "=" ^
  2305:         id ^ "<" ^si index^">" ^
  2306:         (
  2307:           if length ts = 0 then ""
  2308:           else "[" ^ catmap "," (string_of_btypecode syms.dfns) ts ^ "]"
  2309:         )
  2310:       );
  2311:       if length ts <> length vs then
  2312:       failwith
  2313:       (
  2314:         "[gen_function} wrong number of args, expected vs = " ^
  2315:         si (length vs) ^
  2316:         ", got ts=" ^
  2317:         si (length ts)
  2318:       );
  2319:       (*
  2320:       let name = cpp_instance_name syms bbdfns index ts in
  2321:       *)
  2322:       let name = id in (* callbacks can't be polymorphic .. for now anyhow *)
  2323:       let rettypename = cpp_typename syms ret in
  2324:       let n = length ps_c in
  2325:       let flx_fun_atypes =
  2326:         rev
  2327:         (
  2328:           fold_left
  2329:           (fun lst (t,i) ->
  2330:             if i = client_data_pos
  2331:             then lst
  2332:             else (t,i)::lst
  2333:           )
  2334:           []
  2335:           (combine ps_c (nlist n))
  2336:         )
  2337:       in
  2338:       let flx_fun_atype =
  2339:         if length flx_fun_atypes = 1 then fst (hd flx_fun_atypes)
  2340:         else `BTYP_tuple (map fst flx_fun_atypes)
  2341:       in
  2342:       let flx_fun_reduced_atype = rt vs flx_fun_atype in
  2343:       let flx_fun_atype_name = cpp_typename syms flx_fun_atype in
  2344:       let flx_fun_reduced_atype_name = cpp_typename syms flx_fun_reduced_atype in
  2345:       let flx_fun_args = map (fun (_,i) -> "_a"^si i) flx_fun_atypes in
  2346:       let flx_fun_arg = match length flx_fun_args with
  2347:         | 0 -> ""
  2348:         | 1 -> hd flx_fun_args
  2349:         | _ ->
  2350:           (* argument tuple *)
  2351:           let a = flx_fun_atype_name ^ "(" ^ String.concat "," flx_fun_args ^")" in
  2352:           if flx_fun_reduced_atype_name <> flx_fun_atype_name
  2353:           then "reinterpret<" ^ flx_fun_reduced_atype_name ^ ">("^a^")"
  2354:           else a
  2355: 
  2356:       in
  2357:       let sss =
  2358:         (* return type *)
  2359:         rettypename ^ " " ^
  2360: 
  2361:         (* function name *)
  2362:         name ^ "(" ^
  2363:         (
  2364:           (* parameter list *)
  2365:           match length ps_c with
  2366:           | 0 -> ""
  2367:           | 1 -> cpp_typename syms (hd ps_c) ^ " _a0"
  2368:           | _ ->
  2369:             fold_left
  2370:             (fun s (t,j) ->
  2371:               s ^
  2372:               (if String.length s > 0 then ", " else "") ^
  2373:               cpp_typename syms t ^ " _a" ^ si j
  2374:             )
  2375:             ""
  2376:             (combine ps_c (nlist n))
  2377:         ) ^
  2378:         "){\n"^
  2379:         (
  2380:           (* body *)
  2381:           let flx_fun_type = nth ps_cf client_data_pos in
  2382:           let flx_fun_type_name = cpp_typename syms flx_fun_type in
  2383:           (* cast *)
  2384:           "  " ^ flx_fun_type_name ^ " callback = ("^flx_fun_type_name^")_a" ^ si client_data_pos ^ ";\n" ^
  2385:           (
  2386:             if ret = `BTYP_void then begin
  2387:               "  con_t *p = callback->call(0" ^
  2388:               (if String.length flx_fun_arg > 0 then "," ^ flx_fun_arg else "") ^
  2389:               ");\n" ^
  2390:               "  while(p)p = p->resume();\n"
  2391:             end else begin
  2392:               "  return callback->apply(" ^ flx_fun_arg ^ ");\n";
  2393:             end
  2394:           )
  2395:         )^
  2396:         "  }\n"
  2397:       in bcat s sss
  2398: 
  2399:   | `BBDCL_procedure (props,vs,(ps,traint),_) ->
  2400:     bcat s ("//------------------------------\n");
  2401:     if mem `Pure props && not (mem `Heap_closure props) then
  2402:       bcat s (
  2403:         gen_C_procedure_body filename syms (child_map,bbdfns)
  2404:         label_info counter index ts instance_no
  2405:       )
  2406:     else
  2407:       bcat s (
  2408:         gen_procedure_methods filename syms (child_map,bbdfns)
  2409:         label_info counter index ts instance_no
  2410:       )
  2411: 
  2412:   | `BBDCL_regmatch _
  2413:   | `BBDCL_reglex _ ->
  2414:     bcat s ("//------------------------------\n");
  2415:     bcat s (
  2416:       gen_regexp_methods filename syms (child_map,bbdfns) label_info counter index ts instance_no
  2417:     )
  2418: 
  2419:   | `BBDCL_class _ ->
  2420:     bcat s ("//------------------------------\n");
  2421:     bcat s (
  2422:       gen_class_methods filename syms (child_map,bbdfns) label_info counter index ts instance_no
  2423:     )
  2424: 
  2425:   | _ -> ()
  2426:   end
  2427:   ;
  2428:   output_string bf (Buffer.contents s);
  2429:   Buffer.clear s
  2430:   )
  2431:   syms.instances
  2432: 
  2433: let gen_biface_header syms bbdfns biface = match biface with
  2434:   | `BIFACE_export_fun (sr,index, export_name) ->
  2435:     let id,parent,sr,entry =
  2436:       try Hashtbl.find bbdfns index
  2437:       with Not_found -> failwith ("[gen_biface_header] Can't find index " ^ si index)
  2438:     in
  2439:     begin match entry with
  2440:     | `BBDCL_function (props,vs,(ps,traint), ret, _) ->
  2441:       let display = get_display_list bbdfns index in
  2442:       if length display <> 0
  2443:       then clierr sr "Can't export nested function";
  2444: 
  2445:       let argtypes =
  2446:         map
  2447:         (fun (_,(_,x)) -> cpp_typename syms x)
  2448:         ps
  2449:       in
  2450:       let arglist = "  " ^
  2451:         (if length argtypes = 0 then "FLX_FPAR_DECL_ONLY"
  2452:         else "FLX_FPAR_DECL\n" ^ cat ",\n  " argtypes
  2453:         )
  2454:       in
  2455:       let rettypename = cpp_typename syms ret in
  2456: 
  2457:       "//EXPORT FUNCTION " ^ cpp_instance_name syms bbdfns index [] ^
  2458:       " as " ^ export_name ^ "\n" ^
  2459:       "extern \"C\" FLX_EXPORT " ^ rettypename ^" " ^ export_name ^ "(\n" ^ arglist ^ "\n);\n"
  2460: 
  2461:     | `BBDCL_procedure (props,vs,(ps,traint), _) ->
  2462:       let display = get_display_list bbdfns index in
  2463:       if length display <> 0
  2464:       then clierr sr "Can't export nested proc";
  2465: 
  2466:       let argtypes =
  2467:         map
  2468:         (fun (_,(_,x)) -> cpp_typename syms x)
  2469:         ps
  2470:       in
  2471:       let arglist = "  " ^
  2472:         (if length argtypes = 0 then "FLX_FPAR_DECL_ONLY"
  2473:         else "FLX_FPAR_DECL\n" ^ cat ",\n  " argtypes
  2474:         )
  2475:       in
  2476: 
  2477:       "//EXPORT PROCEDURE " ^ cpp_instance_name syms bbdfns index [] ^
  2478:       " as " ^ export_name ^ "\n" ^
  2479:       "extern \"C\" FLX_EXPORT con_t * "  ^ export_name ^ "(\n" ^ arglist ^ "\n);\n"
  2480: 
  2481:     | _ -> failwith "Not implemented: export non-function/procedure"
  2482:     end
  2483: 
  2484:   | `BIFACE_export_type (sr, typ, export_name) ->
  2485:     "//EXPORT type " ^ sbt  syms.dfns typ ^ " as " ^ export_name  ^ "\n" ^
  2486:     "typedef " ^ cpp_type_classname syms typ ^ " " ^ export_name ^ "_class;\n" ^
  2487:     "typedef " ^ cpp_typename syms typ ^ " " ^ export_name ^ ";\n"
  2488: 
  2489: let gen_biface_body syms bbdfns biface = match biface with
  2490:   | `BIFACE_export_fun (sr,index, export_name) ->
  2491:     let id,parent,sr,entry =
  2492:       try Hashtbl.find bbdfns index
  2493:       with Not_found -> failwith ("[gen_biface_body] Can't find index " ^ si index)
  2494:     in
  2495:     begin match entry with
  2496:     | `BBDCL_function (props,vs,(ps,traint), ret, _) ->
  2497:       if length vs <> 0
  2498:       then clierr sr ("Can't export generic function " ^ id)
  2499:       ;
  2500:       let display = get_display_list bbdfns index in
  2501:       if length display <> 0
  2502:       then clierr sr "Can't export nested function";
  2503: 
  2504:       let argtypes =
  2505:         map
  2506:         (fun (id,(ix,t)) -> cpp_typename syms t ^ " " ^ id)
  2507:         ps
  2508:       in
  2509:       let arglist = "  " ^
  2510:         (if length argtypes = 0 then "FLX_FPAR_DECL_ONLY"
  2511:         else "FLX_FPAR_DECL\n" ^ cat ",\n  " argtypes
  2512:         )
  2513:       in
  2514:       (*
  2515:       if mem `Stackable props then print_endline ("Stackable " ^ export_name);
  2516:       if mem `Stack_closure props then print_endline ("Stack_closure" ^ export_name);
  2517:       *)
  2518:       let is_C_fun = mem `Pure props && not (mem `Heap_closure props) in
  2519:       let requires_ptf = mem `Requires_ptf props in
  2520: 
  2521:       let rettypename = cpp_typename syms ret in
  2522:       let class_name = cpp_instance_name syms bbdfns index [] in
  2523: 
  2524:       "//EXPORT FUNCTION " ^ class_name ^
  2525:       " as " ^ export_name ^ "\n" ^
  2526:       rettypename ^" " ^ export_name ^ "(\n" ^ arglist ^ "\n){\n" ^
  2527:       (if is_C_fun then
  2528:       "  return " ^ class_name ^ "(" ^
  2529:       (
  2530:         if requires_ptf
  2531:         then "_PTFV" ^ (if length ps > 0 then "," else "")
  2532:         else ""
  2533:       )
  2534:       ^cat ", " (map fst ps) ^ ");\n"
  2535:       else
  2536:       "  return (new(*_PTF gc,"^class_name^"_ptr_map)\n" ^
  2537:       "    " ^ class_name ^ "(_PTFV)\n" ^
  2538:       "    ->apply(" ^ cat ", " (map fst ps) ^ ");\n"
  2539:       )^
  2540:       "}\n"
  2541: 
  2542:     | `BBDCL_procedure (props,vs,(ps,traint),_) ->
  2543:       let stackable = mem `Stack_closure props in
  2544:       if length vs <> 0
  2545:       then clierr sr ("Can't export generic procedure " ^ id)
  2546:       ;
  2547:       let display = get_display_list bbdfns index in
  2548:       if length display <> 0
  2549:       then clierr sr "Can't export nested function";
  2550: 
  2551:       let argtypes =
  2552:         map
  2553:         (fun (id,(_,t)) -> cpp_typename syms t ^ " " ^ id)
  2554:         ps
  2555:       in
  2556:       let arglist = "  " ^
  2557:         (if length argtypes = 0 then "FLX_FPAR_DECL_ONLY"
  2558:         else "FLX_FPAR_DECL\n" ^ cat ",\n  " argtypes
  2559:         )
  2560:       in
  2561:       let class_name = cpp_instance_name syms bbdfns index [] in
  2562: 
  2563:       "//EXPORT PROC " ^ cpp_instance_name syms bbdfns index [] ^
  2564:       " as " ^ export_name ^ "\n" ^
  2565:       "con_t *" ^ export_name ^ "(\n" ^ arglist ^ "\n){\n" ^
  2566:       (
  2567:         if stackable then
  2568:         (
  2569:           if mem `Pure props && not (mem `Heap_closure props) then
  2570:           (
  2571:             "  " ^ class_name ^"(" ^
  2572:             (
  2573:               if mem `Requires_ptf props then
  2574:                 if length argtypes = 0
  2575:                 then "FLX_APAR_PASS_ONLY "
  2576:                 else "FLX_APAR_PASS "
  2577:               else ""
  2578:             )
  2579:             ^
  2580:             cat ", " (map fst ps) ^ ");\n"
  2581:           )
  2582:           else
  2583:           (
  2584:             "  " ^ class_name ^ "(_PTFV)\n" ^
  2585:             "    .stack_call(" ^ cat ", " (map fst ps) ^ ");\n"
  2586:           )
  2587:         )
  2588:         ^
  2589:         "  return 0;\n"
  2590:         else
  2591:         "  return (new(*_PTF gc,"^class_name^"_ptr_map)\n" ^
  2592:         "    " ^ class_name ^ "(_PTFV))" ^
  2593:         "\n      ->call(" ^ cat ", " ("0"::(map fst ps)) ^ ");\n"
  2594:       )
  2595:       ^
  2596:       "}\n"
  2597: 
  2598:     | _ -> failwith "Not implemented: export non-function/procedure"
  2599:     end
  2600: 
  2601:   | `BIFACE_export_type _ -> ""
  2602: 
  2603: let gen_biface_headers syms bbdfns bifaces =
  2604:   cat "" (map (gen_biface_header syms bbdfns) bifaces)
  2605: 
  2606: let gen_biface_bodies syms bbdfns bifaces =
  2607:   cat "" (map (gen_biface_body syms bbdfns) bifaces)
  2608: 
End ocaml section to src/flx_gen.ml[1]
Start ocaml section to src/flxg.ml[1 /1 ]
     1: # 2671 "./lpsrc/flx_gen.ipk"
     2: open Flx_util
     3: open Flx_ast
     4: open Flx_types
     5: open Flx_mtypes1
     6: open Flx_mtypes2
     7: open Flx_print
     8: open Flx_srcref
     9: open Flx_desugar
    10: open Flx_bbind
    11: open Flx_name
    12: open Flx_tgen
    13: open Flx_gen
    14: open Flx_symtab
    15: open Flx_getopt
    16: open Flx_version
    17: open Flx_exceptions
    18: open Flx_flxopt
    19: open Flx_ogen
    20: open Flx_elkgen
    21: ;;
    22: 
    23: let print_help () = print_options(); exit(0)
    24: ;;
    25: 
    26: let reverse_return_parity = ref false
    27: ;;
    28: 
    29: let last_time = ref 0.0
    30: ;;
    31: let tim() =
    32:   let now = (Unix.times()).Unix.tms_utime in
    33:   let elapsed = now -. !last_time in
    34:   last_time := now;
    35:   elapsed
    36: ;;
    37: 
    38: let format_time tm =
    39:   si (tm.Unix.tm_year + 1900) ^ "/" ^
    40:   si (tm.Unix.tm_mon + 1) ^ "/" ^
    41:   si tm.Unix.tm_mday ^ " " ^
    42:   si tm.Unix.tm_hour ^ ":" ^
    43:   si tm.Unix.tm_min ^ ":" ^
    44:   si tm.Unix.tm_sec
    45: ;;
    46: try
    47:   (* Time initialisation *)
    48:   let compile_start = Unix.time () in
    49:   let compile_start_gm = Unix.gmtime compile_start in
    50:   let compile_start_local = Unix.localtime compile_start in
    51:   let compile_start_gm_string = format_time compile_start_gm ^ " UTC" in
    52:   let compile_start_local_string = format_time compile_start_local ^ " (local)" in
    53: 
    54: 
    55:   (* Argument parsing *)
    56:   let argc = Array.length Sys.argv in
    57:   if argc <= 1
    58:   then begin
    59:     print_endline "usage: flxg --key=value ... filename; -h for help";
    60:     exit 0
    61:   end
    62:   ;
    63:   let raw_options = parse_options Sys.argv in
    64:   let compiler_options = get_felix_options raw_options in
    65:   reverse_return_parity := compiler_options.reverse_return_parity
    66:   ;
    67:   let syms = make_syms compiler_options in
    68:   if check_keys raw_options ["h"; "help"]
    69:   then print_help ()
    70:   ;
    71:   if check_key raw_options "version"
    72:   then (print_endline ("Felix Version " ^ !version_data.version_string))
    73:   ;
    74:   if compiler_options.print_flag then begin
    75:     print_string "//Include directories = ";
    76:     List.iter (fun d -> print_string (d ^ " "))
    77:     compiler_options.include_dirs;
    78:     print_endline ""
    79:   end
    80:   ;
    81: 
    82:  (* main filename processing *)
    83:  let filename =
    84:     match get_key_value raw_options "" with
    85:     | Some s -> s
    86:     | None -> exit 0
    87:   in
    88:   let filebase = filename in
    89:   let input_file_name = filebase ^ ".flx"
    90:   and iface_file_name = filebase ^ ".fix"
    91:   and header_file_name = filebase ^ ".hpp"
    92:   and body_file_name = filebase ^ ".cpp"
    93:   and package_file_name = filebase ^ ".resh"
    94:   and rtti_file_name = filebase ^ ".rtti"
    95:   and report_file_name = filebase ^ ".xref"
    96:   and module_name =
    97:     let n = String.length filebase in
    98:     let i = ref (n-1) in
    99:     while !i <> -1 && filebase.[!i] <> '/' && filebase.[!i] <> '\\' do decr i done;
   100:     String.sub filebase (!i+1) (n - !i - 1)
   101:   in
   102: 
   103:   let include_dirs =  (* (Filename.dirname input_file_name) :: *) compiler_options.include_dirs in
   104:   let compiler_options = { compiler_options with include_dirs = include_dirs } in
   105:   let syms = { syms with compiler_options = compiler_options } in
   106: 
   107:   (* PARSE THE IMPLEMENTATION FILE *)
   108: 
   109:   if compiler_options.print_flag
   110:   then print_endline ("//Parsing Implementation " ^ input_file_name);
   111:   let parse_tree =
   112:     Flx_desugar.include_file syms input_file_name false
   113:   in
   114:   if compiler_options.print_flag
   115:   then print_endline (Flx_print.string_of_compilation_unit parse_tree);
   116: 
   117:   let parse_time = tim() in
   118:   if compiler_options.print_flag
   119:   then print_endline ("//PARSE OK time " ^ string_of_float parse_time);
   120: 
   121:   if compiler_options.print_flag
   122:   then print_endline "//DESUGARING";
   123: 
   124:   let deblocked =
   125:     desugar_program syms module_name parse_tree
   126:   in
   127:   let desugar_time = tim() in
   128:   if compiler_options.print_flag
   129:   then print_endline ("//DESUGAR time " ^ string_of_float desugar_time);
   130: 
   131:   (* THIS IS A HACK! *)
   132:   let root = !(syms.counter) in
   133:   if compiler_options.print_flag
   134:   then print_endline ("//Top level module '"^module_name^"' has index " ^ si root);
   135: 
   136: 
   137:   if compiler_options.print_flag
   138:   then print_endline "//BUILDING TABLES";
   139: 
   140:   let pubtab, _, exes, ifaces,dirs =
   141:     build_tables syms "root" 0 None None root false deblocked
   142:   in
   143:   let build_table_time = tim() in
   144:   if compiler_options.print_flag
   145:   then print_endline ("//BUILDING TABLES time " ^ string_of_float build_table_time);
   146: 
   147: 
   148:   if compiler_options.print_flag
   149:   then print_endline "//BINDING EXECUTABLE CODE"
   150:   ;
   151:   let bbdfns = bbind syms in
   152: 
   153:   (* generate axiom checks *)
   154:   if compiler_options.generate_axiom_checks then
   155:   Flx_axiom.axiom_check syms bbdfns;
   156: 
   157:   let child_map = cal_children syms bbdfns in
   158:   syms.bifaces <- bind_ifaces syms ifaces;
   159:   Hashtbl.clear syms.ticache;
   160: 
   161:   let binding_time = tim() in
   162: 
   163:   if compiler_options.print_flag
   164:   then print_endline ("//Binding complete time " ^ string_of_float binding_time);
   165: 
   166:   if compiler_options.print_flag
   167:   then print_endline "//CHECKING ROOT";
   168: 
   169:   let root_proc =
   170:     match
   171:       try Hashtbl.find syms.dfns root
   172:       with Not_found ->
   173:         failwith
   174:         (
   175:           "Can't find root module " ^ si root ^
   176:           " in symbol table?"
   177:         )
   178:     with {id=id; sr=sr; parent=parent;vs=vs;pubmap=name_map;symdef=entry} ->
   179:     begin match entry with
   180:       | `SYMDEF_module -> ()
   181:       | _ -> failwith "Expected to find top level module ''"
   182:     end
   183:     ;
   184:     let entry =
   185:       try Hashtbl.find name_map "_init_"
   186:       with Not_found ->
   187:         failwith "Can't find name _init_ in top level module's name map"
   188:     in
   189:     let index = match entry with
   190:       | FunctionEntry [x] -> x
   191:       | FunctionEntry [] -> failwith "Couldn't find '_init_'"
   192:       | FunctionEntry _ -> failwith "Too many top level procedures called '_init_'"
   193:       | NonFunctionEntry _ -> failwith "_init_ found but not procedure"
   194:     in
   195:     if compiler_options.print_flag
   196:     then print_endline ("//root module's init procedure has index " ^ si index);
   197:     index
   198:   in
   199: 
   200:   if compiler_options.print_flag
   201:   then print_endline "//OPTIMISING";
   202:   let () = Flx_use.find_roots syms bbdfns root_proc syms.bifaces in
   203:   let bbdfns = Flx_use.copy_used syms bbdfns in
   204:   let child_map = cal_children syms bbdfns in
   205: 
   206:   if compiler_options.max_inline_length > 0 then
   207:   begin
   208:     (*
   209:     print_functions syms.dfns !bbdfns;
   210:     *)
   211:     if compiler_options.print_flag then
   212:     print_endline "//INLINING";
   213: 
   214:     syms.reductions <- List.filter
   215:     (fun (id,bvs,bps,e1,_) ->
   216:       let psi = List.map (fun (_,(i,_)) -> i) bps in
   217:       let ui i =
   218:         let used = List.mem i psi or Hashtbl.mem bbdfns i in
   219:         if not used then begin
   220:           if compiler_options.print_flag then
   221:           print_endline ("ELIDING USELESS REDUCTION " ^ id ^ " because " ^ si i ^ " isn't found");
   222:           raise Not_found
   223:         end
   224:       in
   225:       begin
   226:         try
   227:           Flx_maps.iter_tbexpr ui ignore ignore e1;
   228:           true
   229:         with
   230:         | Not_found -> false
   231:       end
   232:     )
   233:     syms.reductions
   234:     ;
   235:     Flx_inline.heavy_inlining syms (child_map,bbdfns);
   236:     (*
   237:     print_endline "INLINING DONE: RESULT:";
   238:     print_functions syms.dfns bbdfns;
   239:     *)
   240:   end
   241:   ;
   242:   let bbdfns = Flx_use.copy_used syms bbdfns in
   243:   let child_map = cal_children syms bbdfns in
   244: 
   245:   let elim_init maybe_unused exes =
   246:     List.filter (function
   247:       | `BEXE_init (_,i,_) -> not (IntSet.mem i maybe_unused)
   248:       | _ -> true
   249:     )
   250:     exes
   251:   in
   252:   let elim_pass () =
   253:     (* check for unused things .. possible, just a diagnostic for now *)
   254:     let full_use = Flx_use.full_use_closure syms bbdfns in
   255:     let partial_use = Flx_use.cal_use_closure syms bbdfns false in
   256:     let maybe_unused = IntSet.diff full_use partial_use in
   257: 
   258:     Hashtbl.iter
   259:     (fun i (id,parent,sr,entry) -> match entry with
   260:     | `BBDCL_procedure (props ,bvs,(ps,tr),exes) ->
   261:       let exes = elim_init maybe_unused exes in
   262:       let entry = `BBDCL_procedure (props,bvs,(ps,tr),exes) in
   263:       Hashtbl.replace bbdfns i (id,parent,sr,entry)
   264: 
   265:     | `BBDCL_function (props,bvs,(ps,rt),ret,exes) ->
   266:       let exes = elim_init maybe_unused exes in
   267:       let entry = `BBDCL_function (props,bvs,(ps,rt),ret,exes) in
   268:       Hashtbl.replace bbdfns i (id,parent,sr,entry)
   269: 
   270:     | `BBDCL_glr (props,bvs,ret,(p,exes)) ->
   271:       let exes = elim_init maybe_unused exes in
   272:       let entry =  `BBDCL_glr (props,bvs,ret,(p,exes)) in
   273:       Hashtbl.replace bbdfns i (id,parent,sr,entry)
   274:     | _ -> ()
   275:     )
   276:     bbdfns
   277:     ;
   278: 
   279:     IntSet.iter
   280:     (fun i->
   281:       let id,_,_,_ = Hashtbl.find bbdfns i in
   282:       if compiler_options.print_flag then
   283:       print_endline ("Removing unused " ^ id ^ "<" ^ si i ^ ">");
   284:       Hashtbl.remove bbdfns i
   285:     )
   286:     maybe_unused
   287:     ;
   288:     IntSet.is_empty maybe_unused
   289:   in
   290: 
   291:   while not (elim_pass ()) do () done;
   292: 
   293: 
   294:   (*
   295:   print_functions syms.dfns bbdfns;
   296:   *)
   297: 
   298:   if compiler_options.print_flag
   299:   then print_endline "//Calculating stackable calls";
   300:   let label_map = Flx_label.create_label_map bbdfns syms.counter in
   301:   let label_usage = Flx_label.create_label_usage syms bbdfns label_map in
   302:   let label_info = label_map, label_usage in
   303: 
   304:   Flx_stack_calls.make_stack_calls syms (child_map,bbdfns);
   305: 
   306:   let opt_time = tim() in
   307: 
   308:   if compiler_options.print_flag
   309:   then print_endline ("//Optimisation complete time " ^ string_of_float opt_time);
   310: 
   311: 
   312:   if compiler_options.print_flag
   313:   then print_endline "//Generating primitive wrapper closures";
   314:   Flx_mkcls.make_closures syms bbdfns;
   315:   let child_map = cal_children syms bbdfns in
   316: 
   317:   if compiler_options.print_flag then
   318:   begin
   319:     let f = open_out report_file_name in
   320:     Flx_call.print_call_report syms bbdfns f;
   321:     close_out f
   322:   end
   323:   ;
   324: 
   325:   if compiler_options.print_flag
   326:   then print_endline "//Finding which functions use globals";
   327:   let bbdfns = Flx_use.copy_used syms bbdfns in
   328:   Flx_global.set_globals syms bbdfns;
   329: 
   330:   if compiler_options.print_flag
   331:   then print_endline "//instantiating";
   332: 
   333:   Flx_inst.instantiate syms bbdfns root_proc syms.bifaces;
   334:   let top_class =
   335:     try cpp_instance_name syms bbdfns root_proc []
   336:     with Not_found ->
   337:       failwith ("can't name instance of root _init_ procedure index " ^ si root_proc)
   338:   in
   339: 
   340:   (* fix up root procedures so if they're not stackable,
   341:      then they need a heap closure -- wrappers require
   342:      one or the other
   343:   *)
   344:   IntSet.iter (fun i ->
   345:     let id,parent,sr,entry = Hashtbl.find bbdfns i in
   346:     match entry with
   347:     | `BBDCL_procedure (props,vs,p,exes) ->
   348:       let props = ref props in
   349:       if List.mem `Stackable !props then begin
   350:         if not (List.mem `Stack_closure !props)
   351:         then props := `Stack_closure :: !props
   352:       end else begin
   353:         if not (List.mem `Heap_closure !props)
   354:         then props := `Heap_closure :: !props
   355:       end
   356:       ;
   357:       if not (List.mem `Requires_ptf !props)
   358:       then props := `Requires_ptf :: !props
   359:       ;
   360:       let entry = `BBDCL_procedure (!props, vs,p,exes) in
   361:       Hashtbl.replace bbdfns i (id,parent,sr,entry)
   362:     | _ -> ()
   363: 
   364:   )
   365:   !(syms.roots)
   366:   ;
   367:   (* FUDGE the init procedure to make interfacing a bit simpler *)
   368:   let topclass_props =
   369:     let id,parent,sr,entry = Hashtbl.find bbdfns root_proc in
   370:     match entry with
   371:     | `BBDCL_procedure (props,vs,p,exes) -> props
   372:     | _ -> syserr sr "Expected root to be procedure"
   373:   in
   374:   if compiler_options.print_flag
   375:   then print_endline ("//root module's init procedure has name " ^
   376:     top_class
   377:   );
   378: 
   379:   let instantiation_time = tim() in
   380: 
   381:   if compiler_options.print_flag
   382:   then print_endline ("//instantiation time " ^ string_of_float instantiation_time);
   383: 
   384:   if compiler_options.compile_only
   385:   then exit (if compiler_options.reverse_return_parity then 1 else 0)
   386:   ;
   387: 
   388:   begin let cnt = ref 1 in
   389:   let find_parsers this e = match e with
   390:     | `BEXPR_parse ((_,t') as e,ii),_ ->
   391:       if not (Hashtbl.mem syms.parsers (this,t',ii)) then begin
   392:         let n = !cnt in incr cnt;
   393:         Hashtbl.add syms.parsers (this,t',ii) n;
   394:         (*
   395:         print_endline ("PARSER " ^ si n)
   396:         *)
   397:       end
   398:       ;
   399:       if not (Hashtbl.mem syms.lexers (this,e)) then begin
   400:         let n = !cnt in incr cnt;
   401:         Hashtbl.add syms.lexers (this,e) n;
   402:         (*
   403:         print_endline ("LEXER " ^ si n ^ " = " ^ sbe syms.dfns e);
   404:         *)
   405:       end
   406:     | _ -> ()
   407:   in
   408: 
   409:   let nul x = () in
   410:   Hashtbl.iter
   411:   (fun i (_,_,_,entry) -> match entry with
   412:   | `BBDCL_function (_,_,_,_,exes)
   413:   | `BBDCL_procedure (_,_,_,exes) ->
   414:     List.iter (Flx_maps.iter_bexe nul (find_parsers i) nul nul nul) exes
   415:   | _ -> ()
   416:   )
   417:   bbdfns
   418:   end
   419:   ;
   420: 
   421:   let sr = ("unknown",0,0,0,0) in
   422:   Hashtbl.iter
   423:   (fun (this,t',ii) n ->  gen_elk_parser filebase module_name syms bbdfns this sr t' n ii)
   424:   syms.parsers
   425:   ;
   426: 
   427:   Hashtbl.iter
   428:   (fun (this,e) n ->  gen_elk_lexer filebase module_name syms bbdfns this sr e n)
   429:   syms.lexers
   430:   ;
   431: 
   432:   let hf = open_out header_file_name in
   433:   let bf = open_out body_file_name in
   434:   let pf = open_out package_file_name in
   435:   let rf = open_out rtti_file_name in
   436:   let psh s = output_string hf s in
   437:   let psb s = output_string bf s in
   438:   let psp s = output_string pf s in
   439:   let psr s = output_string rf s in
   440:   let plh s = psh s; psh  "\n" in
   441:   let plb s = psb s; psb "\n" in
   442:   let plr s = psr s; psr "\n" in
   443:   let plp s = psp s; psp "\n" in
   444: 
   445:   if compiler_options.print_flag
   446:   then print_endline "//GENERATING Package Requirements";
   447: 
   448:   (* These must be in order: build a list and sort it *)
   449:   begin
   450:     let dfnlist = ref [] in
   451:     Hashtbl.iter
   452:     (fun (i,ts) _ -> dfnlist := (i,ts) :: !dfnlist)
   453:     syms.instances
   454:     ;
   455:     let insts = Hashtbl.create 97 in
   456:     List.iter
   457:     (fun (i,ts)->
   458:       match
   459:         try Hashtbl.find bbdfns i
   460:         with Not_found -> failwith ("[package] can't find index " ^ si i)
   461:       with (id,parent,sr,entry) ->
   462:       match entry with
   463:       | `BBDCL_insert (_,s,`Package,_) ->
   464:         begin match s with
   465:         | `Str "" | `StrTemplate "" -> ()
   466:         | _ ->
   467:           let s =
   468:             match s with
   469:             | `Str s -> Flx_cexpr.ce_expr "atom" s
   470:             | `StrTemplate s ->
   471:               (* do we need tsubst vs ts t? *)
   472:               let tn t = cpp_typename syms (Flx_typing.lower t) in
   473:               let ts = List.map tn ts in
   474:               Flx_csubst.csubst sr sr s (Flx_cexpr.ce_atom "Error") [] [] "Error" "Error" ts "atom" "Error" ["Error"] ["Error"] ["Error"]
   475:           in
   476:           let s = Flx_cexpr.sc "expr" s in
   477:           if not (Hashtbl.mem insts s) then
   478:           begin
   479:             Hashtbl.add insts s ();
   480:             plp s
   481:           end
   482:         end
   483:       | _ -> ()
   484:     )
   485:     (List.sort compare !dfnlist)
   486:   end
   487:   ;
   488: 
   489: 
   490:   if compiler_options.print_flag
   491:   then print_endline "//GENERATING C++: user headers";
   492: 
   493:   plh ("#ifndef _FLX_GUARD_" ^ module_name);
   494:   plh ("#define _FLX_GUARD_" ^ module_name);
   495:   plh ("//Input file: " ^ input_file_name);
   496:   plh ("//Generated by Felix Version " ^ !version_data.version_string);
   497:   plh ("//Timestamp: " ^ compile_start_gm_string);
   498:   plh ("//Timestamp: " ^ compile_start_local_string);
   499:   plh "";
   500:   plh "//FELIX RUNTIME";
   501:   plh "#include \"flx_rtl.hpp\"";
   502:   plh "using namespace flx::rtl;";
   503:   plh "#include \"flx_gc.hpp\"";
   504:   plh "using namespace flx::gc::generic;";
   505:   plh "";
   506: 
   507:   plh "\n//-----------------------------------------";
   508:   plh "//USER HEADERS";
   509:   (* These must be in order: build a list and sort it *)
   510:   begin
   511:     let dfnlist = ref [] in
   512:     Hashtbl.iter
   513:     (fun (i,ts) _ -> dfnlist := (i,ts) :: !dfnlist)
   514:     syms.instances
   515:     ;
   516:     let insts = Hashtbl.create 97 in
   517:     List.iter
   518:     (fun (i,ts)->
   519:       match
   520:         try Hashtbl.find bbdfns i
   521:         with Not_found -> failwith ("[user header] can't find index " ^ si i)
   522:       with (id,parent,sr,entry) ->
   523:       match entry with
   524:       | `BBDCL_insert (_,s,`Header,_) ->
   525:         begin match s with
   526:         | `Str "" | `StrTemplate "" -> ()
   527:         | _ ->
   528:           let s =
   529:             match s with
   530:             | `Str s -> Flx_cexpr.ce_expr "atom" s
   531:             | `StrTemplate s ->
   532:               (* do we need tsubst vs ts t? *)
   533:               let tn t = cpp_typename syms (Flx_typing.lower t) in
   534:               let ts = List.map tn ts in
   535:               Flx_csubst.csubst sr sr s (Flx_cexpr.ce_atom "Error") [] [] "Error" "Error" ts "atom" "Error" ["Error"] ["Error"] ["Error"]
   536:           in
   537:           let s = Flx_cexpr.sc "expr" s in
   538:           if not (Hashtbl.mem insts s) then
   539:           begin
   540:             Hashtbl.add insts s ();
   541:             plh s
   542:           end
   543:         end
   544:       | _ -> ()
   545:     )
   546:     (List.sort compare !dfnlist)
   547:   end
   548:   ;
   549: 
   550:   (* HACKERY FOR ELKHOUND -- we force include library files
   551:     into the global namespace, macro guards should prevent
   552:     subsequent inclusion in the module namespace
   553:   *)
   554:   if Hashtbl.length syms.lexers <> 0 then begin
   555:     plh "#include \"elk_lexerint.h\""
   556:   end
   557:   ;
   558: 
   559:   if Hashtbl.length syms.parsers <> 0 then begin
   560:     plh "#include \"elk_useract.h\""
   561:   end
   562:   ;
   563: 
   564:   plh "\n//-----------------------------------------";
   565:   List.iter plh [
   566:   "//FELIX SYSTEM";
   567:   "namespace flxusr { namespace "^module_name^ " {";
   568:   "struct thread_frame_t;"
   569:   ]
   570:   ;
   571:   if compiler_options.print_flag then
   572:   print_endline "//GENERATING C++: collect types";
   573:   let types = ref [] in
   574:     Hashtbl.iter
   575:     (fun t index-> types := (index, t) :: !types)
   576:     syms.registry
   577:   ;
   578:   let types =
   579:     List.sort
   580:     (
   581:       fun a1 a2 -> compare (fst a1) (fst a2)
   582:     )
   583:     !types
   584:   in
   585:   (*
   586:   List.iter
   587:   (fun (_,t) -> print_endline (string_of_btypecode dfns t))
   588:   types
   589:   ;
   590:   *)
   591: 
   592:   if compiler_options.print_flag then
   593:   print_endline "//GENERATING C++: type class names";
   594:   plh "\n//-----------------------------------------";
   595:   plh "//NAME THE TYPES";
   596:   plh  (gen_type_names syms bbdfns types);
   597: 
   598:   if compiler_options.print_flag then
   599:   print_endline "//GENERATING C++: type class definitions";
   600:   plh "\n//-----------------------------------------";
   601:   plh  "//DEFINE THE TYPES";
   602:   plh  (gen_types syms bbdfns types);
   603: 
   604:   if not (Hashtbl.length syms.parsers + Hashtbl.length syms.lexers = 0) then begin
   605:   plp "elk";
   606:   plh "\n//-----------------------------------------";
   607:   plh  "//ELKHOUND OBJECTS, forward declaration";
   608:   Hashtbl.iter
   609:   (fun _ n -> plh ("struct ElkLex_"^si n^";"))
   610:   syms.lexers
   611:   ;
   612:   Hashtbl.iter
   613:   (fun _ n -> plh ("struct Elk_"^si n^";"))
   614:   syms.parsers
   615:   end
   616:   ;
   617:   if compiler_options.print_flag then
   618:   print_endline "//GENERATING C++: function and procedure classes";
   619:   plh "\n//-----------------------------------------";
   620:   plh  "//DEFINE FUNCTION CLASSES";
   621:   plh  (gen_functions syms (child_map,bbdfns));
   622: 
   623:   if not (Hashtbl.length syms.parsers + Hashtbl.length syms.lexers = 0) then begin
   624:   plh "\n//-----------------------------------------";
   625:   plh  "//INCLUDE ELKHOUND PARSERS";
   626:   Hashtbl.iter
   627:   (fun _ n -> plh ("#include \""^module_name^"_lexer_"^si n^".hpp\""))
   628:   syms.lexers
   629:   ;
   630:   Hashtbl.iter
   631:   (fun _ n -> plh ("#include \""^module_name^"_parser_"^si n^".h\""))
   632:   syms.parsers
   633:   end
   634:   ;
   635: 
   636:   let topvars_with_type = find_thread_vars_with_type bbdfns in
   637:   let topvars = List.map fst topvars_with_type in
   638:   List.iter plh
   639:   [
   640:   "struct thread_frame_t {";
   641:   "  int argc;";
   642:   "  char **argv;";
   643:   "  FILE *flx_stdin;";
   644:   "  FILE *flx_stdout;";
   645:   "  FILE *flx_stderr;";
   646:   "  collector_t *gc;";
   647:   "  thread_frame_t(";
   648:   "    collector_t*";
   649:   "  );";
   650:   ]
   651:   ;
   652:   plh (format_vars syms bbdfns topvars []);
   653:   plh "};";
   654:   plh "";
   655:   plh "FLX_DCL_THREAD_FRAME";
   656:   plh "";
   657:   plh ("}} // namespace flxusr::" ^ module_name);
   658: 
   659:   (* BODY *)
   660:   if compiler_options.print_flag then
   661:   print_endline "//GENERATING C++: GC ptr maps & offsets";
   662: 
   663:   plb ("//Input file: " ^ input_file_name);
   664:   plb ("//Generated by Felix Version " ^ !version_data.version_string);
   665:   plb ("//Timestamp: " ^ compile_start_gm_string);
   666:   plb ("//Timestamp: " ^ compile_start_local_string);
   667: 
   668:   plb ("#include \"" ^ module_name ^ ".hpp\"");
   669:   plb "#include <stdio.h>"; (* for diagnostics *)
   670: 
   671:   if Hashtbl.length syms.parsers <> 0 then begin
   672:     plb "#include \"elk_glr.h\""
   673:   end
   674:   ;
   675: 
   676:   plb "#define comma ,";
   677:   plb "#define ifnot(x) if(!(x))";
   678:   plb "\n//-----------------------------------------";
   679:   plb "//EMIT USER BODY CODE";
   680:   (* These must be in order: build a list and sort it *)
   681:   begin
   682:     let dfnlist = ref [] in
   683:     Hashtbl.iter
   684:     (fun (i,ts) _ -> dfnlist := (i,ts) :: !dfnlist)
   685:     syms.instances
   686:     ;
   687:     let insts = Hashtbl.create 97 in
   688:     List.iter
   689:     (fun (i,ts) ->
   690:       match
   691:         try Hashtbl.find bbdfns i
   692:         with Not_found -> failwith ("[user body] can't find index " ^ si i)
   693:       with (id,parent,sr,entry) ->
   694:       match entry with
   695:       | `BBDCL_insert (_,s,`Body,_) ->
   696:         begin match s with
   697:         | `Str "" | `StrTemplate "" -> ()
   698:         | _ ->
   699:           let s =
   700:             match s with
   701:             | `Str s -> Flx_cexpr.ce_expr "atom" s
   702:             | `StrTemplate s ->
   703:               (* do we need tsubst vs ts t? *)
   704:               let tn t = cpp_typename syms (Flx_typing.lower t) in
   705:               let ts = List.map tn ts in
   706:               Flx_csubst.csubst sr sr s (Flx_cexpr.ce_atom "Error") [] [] "Error" "Error" ts "atom" "Error" ["Error"] ["Error"] ["Error"]
   707:           in
   708:           let s = Flx_cexpr.sc "expr" s in
   709:           if not (Hashtbl.mem insts s) then
   710:           begin
   711:             Hashtbl.add insts s ();
   712:             plb s
   713:           end
   714:         end
   715:       | _ -> ()
   716:     )
   717:     (List.sort compare !dfnlist)
   718:   end
   719:   ;
   720: 
   721:   plb "\n//-----------------------------------------";
   722:   plb ("namespace flxusr { namespace " ^ module_name ^ " {");
   723: 
   724:   plb "FLX_DEF_THREAD_FRAME";
   725:   plb "//Thread Frame Constructor";
   726: 
   727:   let sr = "Thread Frame",0,0,0,0 in
   728:   let topfuns = List.filter (fun (_,t) -> is_gc_pointer syms bbdfns sr t) topvars_with_type in
   729:   let topfuns = List.map fst topfuns in
   730:   let topinits =
   731:     [
   732:       "  gc(gc_a)"
   733:     ]
   734:     @
   735:     List.map
   736:     (fun index ->
   737:       "  " ^
   738:       cpp_instance_name syms bbdfns index [] ^
   739:       "(0)"
   740:     )
   741:     topfuns
   742:   in
   743:   let topinits = String.concat ",\n" topinits in
   744:   List.iter plb
   745:   [
   746:   "thread_frame_t::thread_frame_t(";
   747:   "  collector_t *gc_a";
   748:   ") :";
   749:   topinits;
   750:   "{}"
   751:   ];
   752: 
   753: 
   754: 
   755:   plb "\n//-----------------------------------------";
   756:   plb "//DEFINE OFFSET tables for GC";
   757:   plb ("#include \""^module_name^".rtti\"");
   758:   plr "//DEFINE OFFSET tables for GC";
   759: 
   760:   plr (Flx_ogen.gen_offset_tables syms (child_map,bbdfns) module_name);
   761: 
   762:   plb "\n//-----------------------------------------";
   763:   plb "#ifdef FLX_CGOTO";
   764:   plb "//DEFINE LABELS for GNUC ASSEMBLER LABEL HACK";
   765:   Hashtbl.iter
   766:   (fun (fno,_) inst ->
   767:     try
   768:       let labels = Hashtbl.find label_map fno in
   769:       Hashtbl.iter
   770:       (fun lab lno ->
   771:         match Flx_label.get_label_kind_from_index label_usage lno with
   772:         | `Far ->
   773:           plb ("FLX_DECLARE_LABEL(" ^ si lno ^ ","^ si inst ^ "," ^ lab^")")
   774:         | `Near -> ()
   775:         | `Unused -> ()
   776:       )
   777:       labels
   778:     with Not_found -> ()
   779:   )
   780:   syms.instances
   781:   ;
   782:   plb "#endif";
   783: 
   784:   if not (Hashtbl.length syms.parsers + Hashtbl.length syms.lexers = 0) then begin
   785:   plb "\n//-----------------------------------------";
   786:   plb  "//INCLUDE ELKHOUND PARSERS";
   787:   Hashtbl.iter
   788:   (fun _ n -> plb ("#include \""^module_name^"_lexer_"^si n^".cpp\""))
   789:   syms.lexers
   790:   ;
   791: 
   792:   plb "#include \"elk_glr.h\"";
   793:   Hashtbl.iter
   794:   (fun _ n -> plb ("#include \""^module_name^"_parser_"^si n^".cc\""))
   795:   syms.parsers
   796:   end
   797:   ;
   798: 
   799:   if compiler_options.print_flag then
   800:   print_endline "//GENERATING C++: method bodies";
   801: 
   802:   plb "\n//-----------------------------------------";
   803:   plb "//DEFINE FUNCTION CLASS METHODS";
   804:   gen_execute_methods body_file_name syms (child_map,bbdfns) label_info syms.counter bf;
   805: 
   806:   if compiler_options.print_flag then print_endline "//GENERATING C++: interface";
   807:   plb "\n//-----------------------------------------";
   808:   plb ("}} // namespace flxusr::" ^ module_name);
   809: 
   810:   plb "//CREATE STANDARD EXTERNAL INTERFACE";
   811:   plb ("FLX_FRAME_WRAPPERS(flxusr::"^module_name^")");
   812:   (if List.mem `Pure topclass_props then
   813:     plb ("FLX_C_START_WRAPPER(flxusr::"^module_name^","^top_class^")")
   814:   else if List.mem `Stackable topclass_props then
   815:     plb ("FLX_STACK_START_WRAPPER(flxusr::"^module_name^","^top_class^")")
   816:   else
   817:     plb ("FLX_START_WRAPPER(flxusr::"^module_name^","^top_class^")")
   818:   );
   819:   plb "\n//-----------------------------------------";
   820: 
   821:   plh ("using namespace flxusr::" ^ module_name ^ ";");
   822:   if List.length syms.bifaces > 0 then begin
   823:     plh "//DECLARE USER EXPORTS";
   824:     plh (gen_biface_headers syms bbdfns syms.bifaces);
   825:     plb "//DEFINE EXPORTS";
   826:     plb (gen_biface_bodies syms bbdfns syms.bifaces);
   827:   end
   828:   ;
   829: 
   830:   (* rather late: generate variant remapping tables *)
   831:   if Hashtbl.length syms.variant_map > 0 then begin
   832:     plr "// VARIANT REMAP ARRAYS";
   833:     Hashtbl.iter
   834:     (fun (srct,dstt) vidx ->
   835:       match srct,dstt with
   836:       | `BTYP_variant srcls, `BTYP_variant dstls ->
   837:         begin
   838:           let rcmp (s,_) (s',_) = compare s s' in
   839:           let srcls = List.sort rcmp srcls in
   840:           let dstls = List.sort rcmp dstls in
   841:           let n = List.length srcls in
   842:           let remap =
   843:             List.map
   844:             (fun (s,_) ->
   845:               match Flx_util.list_assoc_index dstls s with
   846:               | Some i -> i
   847:               | None -> assert false
   848:             )
   849:             srcls
   850:           in
   851:           plr ("static int vmap_" ^ si vidx^ "["^si n^"]={" ^
   852:             catmap "," (fun i -> si i) remap ^
   853:           "};")
   854:         end
   855:       | _ -> failwith "Remap non variant types??"
   856:     )
   857:     syms.variant_map
   858:   end
   859:   ;
   860:   plh "//header complete";
   861:   plh "#endif";
   862:   plb "//body complete";
   863:   close_out hf;
   864:   close_out bf;
   865:   plp "flx";
   866:   plp "flx_gc";  (* RF: flx apps now need flx_gc. is this the way to do it? *)
   867:   close_out pf;
   868:   close_out rf;
   869:   let code_generation_time = tim() in
   870:   if compiler_options.print_flag then
   871:   print_endline ("//code generation time " ^ string_of_float code_generation_time);
   872: 
   873:   let total_time =
   874:     parse_time +.
   875:     desugar_time +.
   876:     build_table_time +.
   877:     binding_time +.
   878:     opt_time +.
   879:     instantiation_time +.
   880:     code_generation_time
   881:   in
   882:   if compiler_options.print_flag then
   883:   print_endline ("//Felix compiler time " ^ string_of_float total_time);
   884:   let fname = "flxg_stats.txt" in
   885:   let
   886:     old_parse_time,
   887:     old_desugar_time,
   888:     old_build_table_time,
   889:     old_binding_time,
   890:     old_opt_time,
   891:     old_instantiation_time,
   892:     old_code_generation_time,
   893:     old_total_time
   894:   =
   895:   let zeroes = 0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0 in
   896:   let f = try Some (open_in fname) with _ -> None in
   897:   begin match f with
   898:   | None -> zeroes
   899:   | Some f ->
   900:     let x =
   901:       try
   902:         let id x1 x2 x3 x4 x5 x6 x7 x8 = x1, x2, x3, x4, x5, x6, x7, x8 in
   903:         Scanf.fscanf f
   904:         "parse=%f desugar=%f build=%f bind=%f opt=%f inst=%f gen=%f tot=%f"
   905:         id
   906:       with _ -> zeroes
   907:     in close_in f; x
   908:   end
   909:   in
   910:     let f = open_out fname in
   911:     Printf.fprintf
   912:       f
   913:       "parse=%f\ndesugar=%f\nbuild=%f\nbind=%f\nopt=%f\ninst=%f\ngen=%f\ntot=%f\n"
   914:       (old_parse_time +. parse_time)
   915:       (old_desugar_time +. desugar_time)
   916:       (old_build_table_time +. build_table_time)
   917:       (old_binding_time +. binding_time)
   918:       (old_opt_time +. opt_time)
   919:       (old_instantiation_time +. instantiation_time)
   920:       (old_code_generation_time +. code_generation_time)
   921:       (old_total_time +. total_time)
   922:     ;
   923:     close_out f
   924:   ;
   925:   exit (if compiler_options.reverse_return_parity then 1 else 0)
   926: 
   927: with x -> Flx_terminate.terminate !reverse_return_parity x
   928: ;;
   929: 
End ocaml section to src/flxg.ml[1]