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