5.67. C++ Code generator

Start ocaml section to src/flx_pgen.mli[1 /1 ]
     1: # 4 "./lpsrc/flx_pgen.ipk"
     2: open Flx_ast
     3: open Flx_types
     4: open Flx_mtypes1
     5: open Flx_mtypes2
     6: open Flx_label
     7: open Flx_ctypes
     8: 
     9: val gen_prim_call :
    10:   sym_state_t ->
    11:   fully_bound_symbol_table_t ->
    12:   (btypecode_t -> btypecode_t) ->
    13:   (range_srcref -> tbexpr_t -> cexpr_t) ->
    14:   string ->
    15:   btypecode_t list ->
    16:   tbexpr_t ->
    17:   string ->
    18:   range_srcref ->
    19:   range_srcref ->
    20:   string ->
    21:   cexpr_t
    22: 
    23: val shape_of:
    24:   sym_state_t ->
    25:   fully_bound_symbol_table_t ->
    26:   (btypecode_t -> string) ->
    27:   btypecode_t ->
    28:   string
    29: 
End ocaml section to src/flx_pgen.mli[1]
Start ocaml section to src/flx_pgen.ml[1 /1 ]
     1: # 34 "./lpsrc/flx_pgen.ipk"
     2: open Flx_util
     3: open Flx_ast
     4: open Flx_types
     5: open Flx_mtypes1
     6: open Flx_mtypes2
     7: open Flx_print
     8: open Flx_typing
     9: open Flx_name
    10: open Flx_tgen
    11: open Flx_unify
    12: open Flx_csubst
    13: open Flx_exceptions
    14: open Flx_display
    15: open List
    16: open Flx_generic
    17: open Flx_label
    18: open Flx_ctypes
    19: open Flx_cexpr
    20: open Flx_maps
    21: 
    22: let shape_of syms bbdfns tn t =
    23:   match t with
    24:   | `BTYP_inst (i,ts) ->
    25:     let id,parent,sr,entry = Hashtbl.find bbdfns i in
    26:     begin match entry with
    27:     | `BBDCL_union (vs,idts) ->
    28:       let varmap = mk_varmap vs ts in
    29:       let cpts = map (fun (_,_,t) -> varmap_subst varmap t) idts in
    30:       if all_voids cpts then "_int_ptr_map"
    31:       else "_uctor_ptr_map"
    32:     | `BBDCL_class _ ->
    33:       cpp_instance_name syms bbdfns i ts ^ "_ptr_map"
    34:     | _ -> tn t ^ "_ptr_map"
    35:     end
    36:   | `BTYP_pointer _ -> "_ref_ptr_map"
    37:   | _ -> tn t ^ "_ptr_map"
    38: 
    39: let gen_prim_call
    40:   syms
    41:   (bbdfns:fully_bound_symbol_table_t)
    42:   (tsub:btypecode_t -> btypecode_t)
    43:   (ge: range_srcref -> tbexpr_t -> cexpr_t)
    44:   (ct:string)
    45:   (ts:btypecode_t list)
    46:   ((arg,argt as a) : tbexpr_t)
    47:   ret sr sr2 prec
    48: =
    49:   (*
    50:   print_endline ("ts= "^catmap "," (sbt syms.dfns) ts);
    51:   print_endline ("argt = " ^ sbt syms.dfns argt);
    52:   *)
    53:   let tn t = cpp_typename syms t in
    54:   let rt t = reduce_type (lstrip syms.dfns (tsub t)) in
    55:   let rtn t = tn (rt t) in
    56: 
    57:   let argt = rt argt in
    58:   let tt = tn argt in
    59:   let sh t = shape_of syms bbdfns tn t in
    60:   let gshapes = map sh ts in
    61:   let ts = map rtn ts in
    62:   let carg =
    63:     match argt with
    64:     | `BTYP_tuple []  -> ce_atom "UNIT_VALUE_ERROR"
    65:     | x -> ge sr a
    66:   in
    67:   let ashape = sh argt in
    68:   match arg,argt with
    69: 
    70:   (* the argument is explicitly a tuple *)
    71:   | (`BEXPR_tuple es,_) ->
    72:     let ess =
    73:       map
    74:       (fun e->
    75:         match e with
    76:         (* individual arguments which are unit values are never passed:
    77:           they CAN be passed as subcomponents though .. but they can't
    78:           be generated .. we need to fix this!
    79:         *)
    80:         | `BEXPR_tuple [],_ ->
    81:           (*
    82:           print_endline "Stripping unit";
    83:           *)
    84:           `Ce_atom "/*()*/"
    85: 
    86:         | _ -> ge sr e
    87:       )
    88:       es
    89:     in
    90:     let ets,ashapes =
    91:       match argt with
    92:       | `BTYP_tuple typs -> map rtn typs, map sh typs
    93:       | `BTYP_array (t,`BTYP_unitsum n) ->
    94:         let t = tn t
    95:         and s = sh t
    96:         in rev_map (fun _ -> t) (nlist n), rev_map (fun _ -> s) (nlist n)
    97:       | _ -> assert false
    98:     in
    99:     csubst sr sr2 ct carg ess ets tt ret ts prec ashape ashapes ["Error"] gshapes
   100: 
   101:   (* the argument isnt a tuple, but the type is *)
   102:   | (_,`BTYP_tuple typs) as x ->
   103:     let n = length typs in
   104:     let typs = map rt typs in
   105:     let es =
   106:       map2
   107:       (fun i t -> `BEXPR_get_n (i,x),t)
   108:       (nlist n) typs
   109:     in
   110:     let ess = map (ge sr) es in
   111:     let ets = map tn typs in
   112:     csubst sr sr2 ct carg ess ets tt ret ts prec ashape (map sh typs) ["Error"] gshapes
   113: 
   114:   (* the argument isnt a tuple, but the type is an array *)
   115:   | (_,(`BTYP_array(t,`BTYP_unitsum n) as ta)) as x ->
   116:     let t = rt t in
   117:     let typs = map (fun _ -> rt t) (nlist n) in
   118:     let es =
   119:       map
   120:       (fun i -> `BEXPR_get_n (i,x),t)
   121:       (nlist n)
   122:     in
   123:     let ess = map (ge sr) es in
   124:     let ets = map tn typs in
   125:     csubst sr sr2 ct carg ess ets tt ret ts prec ashape (map sh typs) ["error"] gshapes
   126: 
   127:   (* the argument isn't an explicit tuple, and the type
   128:      is neither an array nor tuple
   129:   *)
   130:   | (_,typ) ->
   131:     csubst sr sr2 ct carg [carg] [tt] tt ret ts prec ashape [ashape] ["Error"] gshapes
   132: 
   133: 
   134: 
End ocaml section to src/flx_pgen.ml[1]
Start ocaml section to src/flx_egen.mli[1 /1 ]
     1: # 3 "./lpsrc/flx_egen.ipk"
     2: open Flx_ast
     3: open Flx_types
     4: open Flx_mtypes1
     5: open Flx_mtypes2
     6: open Flx_label
     7: open Flx_ctypes
     8: 
     9: val gen_expr:
    10:   sym_state_t ->
    11:   fully_bound_symbol_table_t ->
    12:   int ->
    13:   tbexpr_t ->
    14:   bvs_t ->
    15:   btypecode_t list ->
    16:   range_srcref -> string
    17: 
    18: val gen_expr':
    19:   sym_state_t ->
    20:   fully_bound_symbol_table_t ->
    21:   int ->
    22:   tbexpr_t ->
    23:   bvs_t ->
    24:   btypecode_t list ->
    25:   range_srcref -> cexpr_t
    26: 
    27: (* for use in an expression *)
    28: val get_var_ref:
    29:   sym_state_t ->
    30:   fully_bound_symbol_table_t ->
    31:   int ->
    32:   int ->
    33:   btypecode_t list ->
    34:   string
    35: 
    36: (* for definition/initialisation *)
    37: val get_ref_ref:
    38:   sym_state_t ->
    39:   fully_bound_symbol_table_t ->
    40:   int ->
    41:   int ->
    42:   btypecode_t list ->
    43:   string
    44: 
End ocaml section to src/flx_egen.mli[1]
Start ocaml section to src/flx_egen.ml[1 /1 ]
     1: # 48 "./lpsrc/flx_egen.ipk"
     2: open Flx_util
     3: open Flx_ast
     4: open Flx_types
     5: open Flx_mtypes1
     6: open Flx_mtypes2
     7: open Flx_print
     8: open Flx_typing
     9: open Flx_name
    10: open Flx_tgen
    11: open Flx_unify
    12: open Flx_csubst
    13: open Flx_exceptions
    14: open Flx_display
    15: open List
    16: open Flx_generic
    17: open Flx_label
    18: open Flx_unravel
    19: open Flx_ogen
    20: open Flx_ctypes
    21: open Flx_cexpr
    22: open Flx_maps
    23: open Flx_pgen
    24: open Flx_beta
    25: open Flx_srcref
    26: 
    27: let string_of_string = Flx_string.c_quote_of_string
    28: 
    29: (* HACKERY: this assumes library dependent things:
    30:   but we can't add literals in the library code :-(
    31: *)
    32: let csuffix_of_type s = match s with
    33:   | "tiny" -> ""
    34:   | "short" -> ""
    35:   | "int" -> ""
    36:   | "long" -> "l"
    37:   | "vlong" -> "ll"
    38:   | "utiny" -> "u"
    39:   | "ushort" -> "u"
    40:   | "uint" -> "u"
    41:   | "ulong" -> "ul"
    42:   | "uvlong" -> "ull"
    43:   | "int8" -> ""
    44:   | "int16" -> ""
    45:   | "int32" -> "l"
    46:   | "int64" -> "ll"
    47:   | "uint8" -> "u"
    48:   | "uint16" -> "u"
    49:   | "uint32" -> "ul"
    50:   | "uint64" -> "ull"
    51:   | "double" -> ""
    52:   | "float" -> "f"
    53:   | "ldouble" -> "l"
    54:   | _ -> failwith ("[csuffix_of_type]: Unexpected Type " ^ s)
    55: 
    56: let cstring_of_literal e = match e with
    57:   | `AST_int (s,i) -> (Big_int.string_of_big_int i)^csuffix_of_type s
    58:   | `AST_float (s,x) -> x ^ csuffix_of_type s
    59:   | `AST_string s -> string_of_string s
    60:   | `AST_cstring s -> string_of_string s
    61:   | `AST_wstring s -> "L" ^ string_of_string s
    62:   | `AST_ustring s -> "L" ^ string_of_string s
    63: 
    64: (* a native literal is one not needing a cast to get the type right *)
    65: let is_native_literal e = match e with
    66:   | `AST_int ("int",_)
    67:   | `AST_int ("long",_)
    68:   | `AST_int ("uint",_)
    69:   | `AST_int ("ulong",_)
    70:   | `AST_int ("vlong",_)
    71:   | `AST_int ("uvlong",_)
    72:   | `AST_float ("double",_) -> true
    73:   | _ -> false
    74: 
    75: let get_var_frame syms bbdfns this index ts : string =
    76:   match
    77:     try Hashtbl.find bbdfns index
    78:     with Not_found -> failwith ("[get_var_frame(1)] Can't find index " ^ si index)
    79:   with (id,parent,sr,entry) ->
    80:   match entry with
    81:   | `BBDCL_val (vs,t)
    82:   | `BBDCL_var (vs,t)
    83:   | `BBDCL_ref (vs,t) ->
    84:     begin match parent with
    85:     | None -> "ptf"
    86:     | Some i ->
    87:       if i <> this
    88:       then "ptr" ^ cpp_instance_name syms bbdfns i ts
    89:       else "this"
    90:     end
    91:   | `BBDCL_tmp (vs,t) ->
    92:      failwith ("[get_var_frame] temporaries aren't framed: " ^ id)
    93: 
    94:   | _ -> failwith ("[get_var_frame] Expected name "^id^" to be variable or value")
    95: 
    96: let get_var_ref syms bbdfns this index ts : string =
    97:   match
    98:     try Hashtbl.find bbdfns index
    99:     with Not_found -> failwith ("[get_var_ref] Can't find index " ^ si index)
   100:   with (id,parent,sr,entry) ->
   101:   (*
   102:   print_endline ("get var ref for " ^ id ^ "<" ^ si index ^ ">["^catmap "," (string_of_btypecode syms.dfns) ts^"]");
   103:   *)
   104:   match entry with
   105:   | `BBDCL_val (vs,t)
   106:   | `BBDCL_var (vs,t) ->
   107:     begin match parent with
   108:     | None -> (* print_endline "No parent ...?"; *)
   109:       "PTF " ^ cpp_instance_name syms bbdfns index ts
   110:     | Some i ->
   111:       (*
   112:       print_endline ("Parent " ^ si i);
   113:       *)
   114:       (
   115:         if i <> this
   116:         then "ptr" ^ cpp_instance_name syms bbdfns i ts ^ "->"
   117:         else ""
   118:       ) ^
   119:       cpp_instance_name syms bbdfns index ts
   120:     end
   121: 
   122:   | `BBDCL_ref (vs,t) ->
   123:     "(*(" ^
   124:     begin match parent with
   125:     | None -> (* print_endline "No parent ...?"; *)
   126:       "PTF " ^ cpp_instance_name syms bbdfns index ts
   127:     | Some i ->
   128:       (*
   129:       print_endline ("Parent " ^ si i);
   130:       *)
   131:       (
   132:         if i <> this
   133:         then "ptr" ^ cpp_instance_name syms bbdfns i ts ^ "->"
   134:         else ""
   135:       ) ^
   136:       cpp_instance_name syms bbdfns index ts
   137:     end
   138:     ^"))"
   139: 
   140: 
   141:   | `BBDCL_tmp (vs,t) ->
   142:       cpp_instance_name syms bbdfns index ts
   143: 
   144:   | _ -> failwith ("[get_var_ref(3)] Expected name "^id^" to be variable, value or temporary")
   145: 
   146: let get_ref_ref syms bbdfns this index ts : string =
   147:   match
   148:     try Hashtbl.find bbdfns index
   149:     with Not_found -> failwith ("[get_var_ref] Can't find index " ^ si index)
   150:   with (id,parent,sr,entry) ->
   151:   (*
   152:   print_endline ("get var ref for " ^ id ^ "<" ^ si index ^ ">["^catmap "," (string_of_btypecode syms.dfns) ts^"]");
   153:   *)
   154:   match entry with
   155:   | `BBDCL_val (vs,t)
   156:   | `BBDCL_var (vs,t)
   157:   | `BBDCL_ref (vs,t) ->
   158:     begin match parent with
   159:     | None -> (* print_endline "No parent ...?"; *)
   160:       "PTF " ^ cpp_instance_name syms bbdfns index ts
   161:     | Some i ->
   162:       (*
   163:       print_endline ("Parent " ^ si i);
   164:       *)
   165:       (
   166:         if i <> this
   167:         then "ptr" ^ cpp_instance_name syms bbdfns i ts ^ "->"
   168:         else ""
   169:       ) ^
   170:       cpp_instance_name syms bbdfns index ts
   171:     end
   172: 
   173:   | `BBDCL_tmp (vs,t) ->
   174:       cpp_instance_name syms bbdfns index ts
   175: 
   176:   | _ -> failwith ("[get_var_ref(3)] Expected name "^id^" to be variable, value or temporary")
   177: 
   178: let nth_type ts i =
   179:   try match ts with
   180:   | `BTYP_tuple ts -> nth ts i
   181:   | `BTYP_array (t,`BTYP_unitsum n) -> assert (i<n); t
   182:   | _ -> assert false
   183:   with Not_found ->
   184:     failwith ("Can't find component " ^ si i ^ " of type!")
   185: 
   186: let isclass bbdfns t : bool =
   187:   match t with
   188:   | `BTYP_inst (i,_) ->
   189:   begin let _,_,_,entry = Hashtbl.find bbdfns i in
   190:   match entry with
   191:   | `BBDCL_class _ -> true
   192:   | _ -> false
   193:   end
   194:   | _ -> false
   195: 
   196: let rec gen_expr' syms bbdfns this (e,t) vs ts sr : cexpr_t =
   197:   (*
   198:   print_endline ("Generating expression " ^ string_of_bound_expression_with_type syms.dfns (e,t));
   199:   print_endline ("Location " ^ short_string_of_src sr);
   200:   *)
   201:   let ge' e = gen_expr' syms bbdfns this e vs ts sr in
   202:   let ge e = gen_expr syms bbdfns this e vs ts sr in
   203:   let ge'' sr e = gen_expr' syms bbdfns this e vs ts sr in
   204:   if length ts <> length vs then
   205:   failwith
   206:   (
   207:     "[gen_expr} wrong number of args, expected vs = " ^
   208:     si (length vs) ^
   209:     ", got ts=" ^
   210:     si (length ts)
   211:   );
   212:   let tsub t = reduce_type (beta_reduce syms sr  (tsubst vs ts t)) in
   213:   let tn t = cpp_typename syms (tsub (lower t)) in
   214: 
   215:   (* NOTE this function does not do a reduce_type *)
   216:   let raw_typename t = cpp_typename syms (beta_reduce syms sr  (tsubst vs ts t)) in
   217:   let gen_case_index e =
   218:     let _,t = e in
   219:     let t = lstrip syms.dfns t in
   220:     begin match t with
   221:     | `BTYP_sum _
   222:     | `BTYP_unitsum _
   223:     | `BTYP_variant _ ->
   224:       if is_unitsum t then ge' e
   225:       else ce_dot (ge' e) "variant"
   226:     | `BTYP_inst (i,ts) ->
   227:       let ts = map tsub ts in
   228:       let id,_,_,entry =
   229:         try Hashtbl.find bbdfns i
   230:         with Not_found -> failwith ("[gen_expr: case_index] Can't find index " ^ si i)
   231:       in
   232:       begin match entry with
   233:       | `BBDCL_union (bvs,cts) ->
   234:         let tsub' t = reduce_type (beta_reduce syms sr  (tsubst bvs ts t)) in
   235:         let cts = map (fun (_,_,t) -> tsub' t) cts in
   236:         if all_voids cts then ge' e
   237:         else ce_dot (ge' e) "variant"
   238:       | _ -> failwith ("Woops expected union, got " ^ id)
   239:       end
   240:     | _ -> failwith ("Woops expected union or sum, got " ^ sbt syms.dfns t)
   241:     end
   242: 
   243:   in
   244:   let ge_arg ((x,t) as a) =
   245:     let t = tsub t in
   246:     match t with
   247:     | `BTYP_tuple [] -> ""
   248:     | _ -> ge a
   249:   in
   250:   let id,parent,_,entry =
   251:     try Hashtbl.find bbdfns this
   252:     with Not_found -> failwith ("[gen_expr] Can't find this = " ^ si this)
   253:   in
   254:   let our_display = get_display_list syms bbdfns this in
   255:   let our_level = length our_display in
   256:   let rt t = reduce_type (beta_reduce syms sr  (lstrip syms.dfns (tsubst vs ts t))) in
   257:   let t = rt t in
   258:   match t with
   259:   | `BTYP_tuple [] ->
   260:       clierr sr
   261:      ("[egen] In "^sbe syms.dfns (e,t)^":\nunit value required, should have been eliminated")
   262: 
   263:      (* ce_atom ("UNIT_ERROR") *)
   264:   | _ ->
   265:   match e with
   266:   | `BEXPR_parse ((_,t')as e,ii) ->
   267:     let pn =
   268:       try Hashtbl.find syms.parsers (this,t',ii)
   269:       with Not_found -> failwith ("[gen_expr] parse can't find parser")
   270:     in
   271:     let ln =
   272:       try Hashtbl.find syms.lexers (this,e)
   273:       with Not_found -> failwith ("[gen_expr] parse can't find lexer")
   274:     in
   275:     let the_display =
   276:       "this"::
   277:       map (fun (i,vslen)-> "ptr"^ cpp_instance_name syms bbdfns i (list_prefix ts vslen))
   278:       our_display
   279:     in
   280: 
   281:     (* HACK PROPERTIES *)
   282:     let pdisplay = strd the_display [`Requires_ptf] in
   283:     let ldisplay = strd (the_display @[ge e]) [`Requires_ptf] in
   284:     let callstr =
   285:     "(Elk_" ^ si pn ^ pdisplay ^
   286:     ".apply((new ElkLex_" ^ si ln^ldisplay^")->init()))"
   287:     in
   288:       (*
   289:       print_endline ("Parse call : " ^ callstr);
   290:       *)
   291:       ce_atom callstr
   292: 
   293:   | `BEXPR_expr (s,_) -> ce_top s
   294: 
   295:   | `BEXPR_case_index e -> gen_case_index e
   296: 
   297:   | `BEXPR_range_check (e1,e2,e3) ->
   298:      let f,sl,sc,el,ec = sr in
   299:      let f = ce_atom ("\""^ f ^"\"") in
   300:      let sl = ce_atom (si sl) in
   301:      let sc = ce_atom (si sc) in
   302:      let el = ce_atom (si el) in
   303:      let ec = ce_atom (si ec) in
   304:      let sref = ce_call (ce_atom "flx::rtl::flx_range_srcref_t") [f;sl;sc;el;ec] in
   305:      let cf = ce_atom "__FILE__" in
   306:      let cl = ce_atom "__LINE__" in
   307:      let args : cexpr_t list =
   308:        [ ge' e1 ; ge' e2; ge' e3; sref; cf; cl]
   309:      in
   310:      ce_call (ce_atom "flx::rtl::range_check") args
   311: 
   312:   | `BEXPR_get_n (n,(e',t as e)) ->
   313:     begin match rt t with
   314:     | `BTYP_array (_,`BTYP_unitsum _) ->
   315:       ce_dot (ge' e) ("data["^si n^"]")
   316:     | `BTYP_record es ->
   317:       let field_name,_ =
   318:         try nth es n
   319:         with Not_found ->
   320:           failwith "Woops, index of non-existent struct field"
   321:       in
   322:       ce_dot (ge' e) field_name
   323: 
   324:     | `BTYP_inst (i,_) ->
   325:       begin match Hashtbl.find bbdfns i with
   326:       | _,_,_,`BBDCL_struct (_,ls)
   327:       | _,_,_,`BBDCL_cstruct (_,ls) ->
   328:         let name,_ =
   329:           try nth ls n
   330:           with _ ->
   331:             failwith "Woops, index of non-existent struct field"
   332:         in
   333:         ce_dot (ge' e) name
   334: 
   335:       | _ -> failwith "Instance expected to be (c)struct"
   336:       end
   337: 
   338:     | _ -> ce_dot (ge' e) ("mem_" ^ si n)
   339:     end
   340: 
   341:   | `BEXPR_get_named (n,(e',t as e)) ->
   342:     (*
   343:     print_endline "Handling get_named expression";
   344:     *)
   345:     begin match rt t with
   346:     | `BTYP_inst (i,ts) ->
   347:       let cname = cpp_instance_name syms bbdfns n ts in
   348:       ce_arrow (ge' e) cname
   349:       (*
   350:       begin match
   351:         try Hashtbl.find syms.dfns i
   352:         with Not_found -> assert false
   353:       with { id=class_name; symdef=symdef } ->
   354:       match symdef with
   355:       | `SYMDEF_class ->
   356:         begin match
   357:           try Hashtbl.find syms.dfns n
   358:           with Not_found -> failwith ("Can't find class "^class_name^"member " ^ si n);
   359:         with { id = name } ->
   360:           let cname = cpp_instance_name syms bbdfns n ts in
   361:           ce_arrow (ge' e) cname
   362:         end
   363:       | _ -> clierr sr ("[gen_expr'] Expecting "^si i^" to be class, got " ^ string_of_bbdcl syms.dfns entry i)
   364:       end
   365:       *)
   366:     | _ -> assert false
   367:     end
   368: 
   369:   | `BEXPR_match_case (n,((e',t') as e)) ->
   370:     let t' = reduce_type (beta_reduce syms sr  (lstrip syms.dfns t')) in
   371:     let x = gen_case_index e in
   372:     ce_infix "==" x (ce_atom (si n))
   373: 
   374:     (*
   375:     if is_unitsum t' then
   376:       ce_infix "==" (ge' e) (ce_atom (si n))
   377:     else
   378:       ce_infix "=="
   379:       (ce_dot (ge' e) "variant")
   380:       (ce_atom (si n))
   381:     *)
   382: 
   383:   | `BEXPR_case_arg (n,e) ->
   384:     (*
   385:     print_endline ("Decoding nonconst ctor type " ^ sbt syms.dfns t);
   386:     *)
   387:     begin match t with (* t is the result of the whole expression *)
   388:     | `BTYP_function _ ->
   389:       let cast = tn t in
   390:       ce_cast cast (ce_dot (ge' e) "data")
   391:     | _ when isclass bbdfns t ->
   392:       let cast = tn t in
   393:       ce_cast cast (ce_dot (ge' e) "data")
   394: 
   395:     | _ ->
   396:       let cast = tn t ^ "*" in
   397:       ce_prefix "*" (ce_cast cast (ce_dot (ge' e) "data"))
   398:     end
   399: 
   400:   | `BEXPR_deref ((`BEXPR_ref (index,ts)),`BTYP_pointer t) ->
   401:     ge' (`BEXPR_name (index,ts),t)
   402: 
   403:   | `BEXPR_deref e ->
   404:     let cast = tn t ^ "*" in
   405:     ce_prefix "*" (ce_cast cast (ce_dot (ge' e) "get_data()"))
   406: 
   407:   | `BEXPR_new e ->
   408:     let ref_type = tn t in
   409:     let _,t' = e in
   410:     let pname = shape_of syms bbdfns tn t' in
   411:     let typ = tn t' in
   412:     let frame_ptr =
   413:       "new(*PTF gc,"^pname^") " ^
   414:       typ ^ "("^ge e ^")"
   415:     in
   416:     let reference = ref_type ^ "(" ^ frame_ptr ^ ")" in
   417:     ce_atom reference
   418: 
   419: 
   420:   | `BEXPR_literal v ->
   421:     if is_native_literal v
   422:     then ce_atom (cstring_of_literal v)
   423:     else
   424:     let t = tn t in
   425:     ce_atom (t ^ "(" ^ cstring_of_literal v ^ ")")
   426: 
   427:   | `BEXPR_case (v,t') ->
   428:     begin match unfold syms.dfns t' with
   429:     | `BTYP_unitsum n ->
   430:       if v < 0 or v >= n
   431:       then
   432:         failwith
   433:         (
   434:           "Invalid case index " ^ si v ^
   435:           " of " ^ si n ^ " cases  in unitsum"
   436:         )
   437:      else ce_atom (si v)
   438: 
   439:     | `BTYP_sum ls ->
   440:        let s =
   441:          let n = length ls in
   442:          if v < 0 or v >= n
   443:          then
   444:            failwith
   445:            (
   446:              "Invalid case index " ^ si v ^
   447:              " of " ^ si n ^ " cases"
   448:            )
   449:          else let t' = nth ls v in
   450:          if t' = `BTYP_tuple []
   451:          then (* closure of const ctor is just the const value ???? *)
   452:            if is_unitsum t then
   453:              si v
   454:            else
   455:              "_uctor_(" ^ si v ^ ",0)"
   456:          else
   457:            failwith
   458:            (
   459:               "Can't handle closure of case " ^
   460:               si v ^
   461:               " of " ^
   462:               string_of_btypecode syms.dfns t
   463:            )
   464:        in ce_atom s
   465: 
   466:     | _ -> failwith "Case tag must have sum type"
   467:     end
   468: 
   469:   | `BEXPR_name (index,ts') ->
   470:     let id,parent,sr2,entry =
   471:       try Hashtbl.find bbdfns index
   472:       with _ ->
   473:         match
   474:           try Hashtbl.find syms.dfns index
   475:           with Not_found -> assert false
   476:         with
   477:         {id=id; sr=sr} -> syserr sr
   478:         ("[gen_expr(name)] Can't find "^ id ^ "<" ^ si index ^ ">")
   479:     in
   480:     let ts = map tsub ts' in
   481:     begin match entry with
   482:       | `BBDCL_val (_,`BTYP_function (`BTYP_void,_))  ->
   483:           let ptr = (get_var_ref syms bbdfns this index ts) in
   484:           ce_call (ce_arrow (ce_atom ptr) "apply") []
   485: 
   486:       | `BBDCL_var (_,t)
   487:       | `BBDCL_val (_,t)
   488:       | `BBDCL_ref (_,t)
   489:       | `BBDCL_tmp (_,t)
   490:         ->
   491:           ce_atom (get_var_ref syms bbdfns this index ts)
   492: 
   493:       | `BBDCL_const (_,_,ct,_) ->
   494:         begin match ct with
   495:         | `Identity -> syserr sr ("Nonsense Idendity const" ^ id)
   496:         | `Virtual -> clierr2 sr sr2 ("Instantiate virtual const" ^ id)
   497:         | `Str c
   498:         | `StrTemplate c when c = "#srcloc" ->
   499:            let filename, startline, startcol, endline, endcol = sr in
   500:            ce_atom ("flx::rtl::flx_range_srcref_t(" ^
   501:              string_of_string filename ^ "," ^
   502:              si startline ^ "," ^
   503:              si startcol ^ "," ^
   504:              si endline ^ "," ^
   505:              si endcol ^ ")"
   506:            )
   507: 
   508:         | `Str c when c = "#this" ->
   509:           begin match parent with
   510:           | None -> clierr sr "Use 'this' outside class"
   511:           | Some p ->
   512:             let name = cpp_instance_name syms bbdfns p ts in
   513:             (*
   514:             print_endline ("class = " ^ si p ^ ", instance name = " ^ name);
   515:             *)
   516:             ce_atom("ptr"^name)
   517:           end
   518: 
   519:         | `Str c
   520:         | `StrTemplate c when c = "#memcount" ->
   521:           let ts = map (lstrip syms.dfns) ts in
   522:           begin match ts with
   523:           | [`BTYP_void] -> ce_atom "0"
   524:           | [`BTYP_unitsum n]
   525:           | [`BTYP_array (_,`BTYP_unitsum n)] -> ce_atom (si n)
   526:           | [`BTYP_sum ls]
   527:           | [`BTYP_tuple ls] -> let n = length ls in ce_atom (si n)
   528:           | [`BTYP_inst (i,_)] ->
   529:             let _,_,_,entry = Hashtbl.find bbdfns i in
   530:             begin match entry with
   531:               | `BBDCL_struct (_,ls) -> let n = length ls in ce_atom (si n)
   532:               | `BBDCL_cstruct (_,ls) -> let n = length ls in ce_atom (si n)
   533:               | `BBDCL_union (_,ls) -> let n = length ls in ce_atom (si n)
   534:               | `BBDCL_class (_,ls) -> let n = length ls in ce_atom (si n)
   535:               | _ ->
   536:                 clierr sr (
   537:                   "#memcount function requires type with members to count, got: " ^
   538:                   sbt syms.dfns (hd ts)
   539:                 )
   540:             end
   541:           | _ ->
   542:             clierr sr (
   543:               "#memcount function requires type with members to count, got : " ^
   544:               sbt syms.dfns (hd ts)
   545:             )
   546:           end
   547:         | `Str c -> ce_expr "expr" c
   548:         | `StrTemplate c ->
   549:           let ts = map tn ts in
   550:           csubst sr sr2 c (ce_atom "Error") [] [] "Error" "Error" ts "expr" "Error" ["Error"] ["Error"] ["Error"]
   551:         end
   552: 
   553:       (* | `BBDCL_function (_,_,([s,(_,`BTYP_void)],_),_,[`BEXE_fun_return e]) -> *)
   554:       | `BBDCL_function (_,_,([],_),_,[`BEXE_fun_return (_,e)]) ->
   555:         ge' e
   556: 
   557:       | `BBDCL_cstruct _
   558:       | `BBDCL_struct _
   559:       | `BBDCL_reglex _
   560:       | `BBDCL_regmatch _
   561:       | `BBDCL_function _
   562:       | `BBDCL_procedure _
   563:       | `BBDCL_fun _
   564:       | `BBDCL_proc _ ->
   565:          syserr sr
   566:          (
   567:            "[gen_expr: name] Open function '" ^
   568:            id ^ "'<"^si index^
   569:            "> in expression (closure required)"
   570:          )
   571:       | _ ->
   572:         syserr sr
   573:         (
   574:           "[gen_expr: name] Cannot use this kind of name '"^
   575:           id^"' in expression"
   576:         )
   577:     end
   578: 
   579:   | `BEXPR_closure (index,ts') ->
   580:     (*
   581:     print_endline ("Generating closure of " ^ si index);
   582:     *)
   583:     let id,parent,sr,entry =
   584:       try Hashtbl.find bbdfns index
   585:       with _ -> failwith ("[gen_expr(name)] Can't find index " ^ si index)
   586:     in
   587:     (*
   588:     Should not be needed now ..
   589:     let ts = adjust_ts syms index ts' in
   590:     *)
   591:     let ts = map tsub ts' in
   592:     begin match entry with
   593:     | `BBDCL_function (props,_,_,_,_)
   594:     | `BBDCL_procedure (props,_,_,_) ->
   595:       let the_display =
   596:         let d' =
   597:           map (fun (i,vslen) -> "ptr"^ cpp_instance_name syms bbdfns i (list_prefix ts vslen))
   598:           (get_display_list syms bbdfns index)
   599:         in
   600:           if length d' > our_level
   601:           then "this" :: tl d'
   602:           else d'
   603:       in
   604:       let name = cpp_instance_name syms bbdfns index ts in
   605:       if mem `Cfun props then ce_atom name
   606:       else
   607:         ce_atom (
   608:         "(FLX_NEWP("^name^")" ^ strd the_display props ^")"
   609:         )
   610: 
   611:     | `BBDCL_callback _ ->
   612:       print_endline "Mapping closure of callback to C function pointer";
   613:       ce_atom id
   614: 
   615:     | `BBDCL_cstruct _
   616:     | `BBDCL_struct _
   617:     | `BBDCL_fun _
   618:     | `BBDCL_proc _ ->
   619:       failwith ("[gen_expr: closure] Can't wrap primitive proc, fun, or struct '"^id^"' yet")
   620:     | _ -> failwith ("[gen_expr: closure] Cannot use this kind of name '"^id^"' in expression")
   621:     end
   622: 
   623:   | `BEXPR_apply_method_stack (obj,meth,ts',a) ->
   624:     let id,parent,sr2,entry =
   625:       try Hashtbl.find bbdfns meth
   626:       with _ -> failwith ("[gen_expr(apply instance)] Can't find index " ^ si meth)
   627:     in
   628:     begin
   629:     (*
   630:     print_endline ("apply method closure of "^ id );
   631:     print_endline ("  .. argument is " ^ string_of_bound_expression syms.dfns a);
   632:     *)
   633:     match entry with
   634:     | `BBDCL_function (props,_,_,_,_) ->
   635:       (*
   636:       print_endline ("Generating closure[apply method stack] of " ^ si meth);
   637:       *)
   638:       let ts = map tsub ts' in
   639:       let the_display =
   640:         let d' =
   641:           map (fun (i,vslen)-> "ptr"^ cpp_instance_name syms bbdfns i (list_prefix ts vslen))
   642:           (get_display_list  syms bbdfns meth)
   643:         in
   644:           let d' = tl d' in (* throw out class pointer *)
   645:           if length d' > our_level
   646:           then "this" :: tl d'
   647:           else d'
   648:       in
   649:       let class_frame = ge obj in
   650:       let the_display = class_frame :: the_display in
   651:       let name = cpp_instance_name syms bbdfns meth ts in
   652:       ce_atom (
   653:       name ^ strd the_display props ^
   654:       "\n      .apply(" ^ ge_arg a ^ ")"
   655:       )
   656:     | _ ->
   657:       failwith
   658:       (
   659:         "[gen_expr: apply_method_stack] Expected '"^id^"' to be generic function instance, got:\n" ^
   660:         string_of_bbdcl syms.dfns entry meth
   661:       )
   662:    end
   663: 
   664:   | `BEXPR_apply_method_direct (obj,meth,ts',a) ->
   665:     let id,parent,sr2,entry =
   666:       try Hashtbl.find bbdfns meth
   667:       with _ -> failwith ("[gen_expr(apply instance)] Can't find index " ^ si meth)
   668:     in
   669:     begin
   670:     (*
   671:     print_endline ("apply method closure of "^ id );
   672:     print_endline ("  .. argument is " ^ string_of_bound_expression syms.dfns a);
   673:     *)
   674:     match entry with
   675:     | `BBDCL_function (props,_,_,_,_) ->
   676:       (*
   677:       print_endline ("Generating closure[apply method direct] of " ^ si meth);
   678:       *)
   679:       let ts = map tsub ts' in
   680:       let the_display =
   681:         let d' =
   682:           map (fun (i,vslen)-> "ptr"^ cpp_instance_name syms bbdfns i (list_prefix ts vslen))
   683:           (get_display_list syms bbdfns meth)
   684:         in
   685:           let d' = tl d' in (* throw out class pointer *)
   686:           if length d' > our_level
   687:           then "this" :: tl d'
   688:           else d'
   689:       in
   690:       let class_frame = ge obj in
   691:       let the_display = class_frame :: the_display in
   692:       let name = cpp_instance_name syms bbdfns meth ts in
   693:       if mem `Cfun props then failwith "Not expecting `Cfun for apply_method_direct" else
   694:       ce_atom (
   695:       "(FLX_NEWP("^name^")"^ strd the_display props ^")"^
   696:       "\n      ->apply(" ^ ge_arg a ^ ")"
   697:       )
   698: 
   699:     | _ ->
   700:       failwith
   701:       (
   702:         "[gen_expr: apply_method_direct] Expected '"^id^"' to be generic function instance, got:\n" ^
   703:         string_of_bbdcl syms.dfns entry meth
   704:       )
   705:     end
   706: 
   707:   | `BEXPR_method_closure (e,index,ts') ->
   708:     (*
   709:     print_endline ("Generating method closure of " ^ si index);
   710:     *)
   711:     let id,parent,sr,entry =
   712:       try Hashtbl.find bbdfns index
   713:       with _ -> failwith ("[gen_expr(name)] Can't find index " ^ si index)
   714:     in
   715:     (*
   716:     Should not be needed now ..
   717:     let ts = adjust_ts syms index ts' in
   718:     *)
   719:     let ts = map tsub ts' in
   720:     begin match entry with
   721:     | `BBDCL_function (props,_,_,_,_)
   722:     | `BBDCL_procedure (props,_,_,_) ->
   723:       (*
   724:       print_endline ("Method " ^ id ^ (
   725:         if mem `Requires_ptf props then
   726:           " REQUIRES PTF" else " DOES NOT REQUIRE PTF"
   727:         )
   728:       );
   729:       *)
   730:       let the_display =
   731:         let d' =
   732:           map (fun (i,vslen) -> "ptr"^ cpp_instance_name syms bbdfns i (list_prefix ts vslen))
   733:           (get_display_list syms bbdfns index)
   734:         in
   735:         let d' = tl d' in (* throw out class pointer *)
   736: 
   737:           (*
   738:           print_endline ("Generated display is " ^ cat ", " d');
   739:           print_endline ("Display length = " ^ si (length d') ^ " .. our level = " ^ si our_level);
   740:           *)
   741: 
   742:           assert (length d' >= our_level);
   743:           if length d' > our_level
   744:           then "this" :: tl d'
   745:           else d'
   746:       in
   747:       (* A method closure requires the last entry in the display
   748:          to be the class. If we're cross calling from one
   749:          method to another, we should automatically get the
   750:          parent class environment, but I'm not sure ..
   751:       *)
   752:       let class_frame = ge e in
   753:       let the_display = class_frame :: the_display in
   754:       let name = cpp_instance_name syms bbdfns index ts in
   755:       if mem `Cfun props then failwith "Not expecting `Cfun for apply_method_direct" else
   756:       ce_atom (
   757:       "(FLX_NEWP("^name^")" ^ strd the_display props ^")"
   758:       )
   759: 
   760:     | `BBDCL_cstruct _
   761:     | `BBDCL_struct _
   762:     | `BBDCL_fun _
   763:     | `BBDCL_proc _ ->
   764:       failwith ("[gen_expr: closure] Can't wrap primitive proc, fun, or struct '"^id^"' yet")
   765:     | _ -> failwith ("[gen_expr: closure] Cannot use this kind of name '"^id^"' in expression")
   766:     end
   767: 
   768:   | `BEXPR_ref (index,ts') ->
   769:     let ts = map tsub ts' in
   770:     let t = lower t in
   771:     let ref_type = tn (lower t) in
   772:     let frame_ptr, var_ptr =
   773:       match t with
   774:       | `BTYP_tuple [] -> "NULL","0"
   775:       | _ ->
   776:         let parent = match Hashtbl.find bbdfns index with _,parent,sr,_ -> parent in
   777:         if Some this = parent &&
   778:         (
   779:           let props = match entry with
   780:             | `BBDCL_procedure (props,_,_,_)
   781:             | `BBDCL_function (props,_,_,_,_) -> props
   782:             | _ -> assert false
   783:           in
   784:           mem `Pure props && not (mem `Heap_closure props)
   785:         )
   786:         then
   787:           "NULL","&"^get_var_ref syms bbdfns this index ts ^"-NULL"
   788:         else
   789:           get_var_frame syms bbdfns this index ts,
   790:           "&" ^ get_var_ref syms bbdfns this index ts
   791:     in
   792:     let reference = ref_type ^
   793:       "(" ^ frame_ptr ^ ", " ^ var_ptr ^ ")"
   794:     in
   795:     ce_atom reference
   796: 
   797:   (* Hackery -- we allow a constructor with no
   798:      arguments to be applied to a unit anyhow
   799:   *)
   800: 
   801:   | `BEXPR_variant (s,((_,t') as e)) ->
   802:     print_endline ("Variant " ^ s);
   803:     print_endline ("Type " ^ sbt syms.dfns t);
   804:     let
   805:       arg_typename = tn t' and
   806:       union_typename = tn t
   807:     in
   808:     let aval =
   809:        if isclass bbdfns t' then ge_arg e else
   810:       "new (*PTF gc, "^arg_typename^"_ptr_map) " ^
   811:       arg_typename ^ "(" ^ ge_arg e ^ ")"
   812:     in
   813:     let ls = match t with
   814:       | `BTYP_variant ls -> ls
   815:       | _ -> failwith "[egen] Woops variant doesn't have variant type"
   816:     in
   817:     let vidx = match list_assoc_index ls s with
   818:       | Some i -> i
   819:       | None -> failwith "[egen] Woops, variant field not in type"
   820:     in
   821:     print_endline ("Index " ^ si vidx);
   822:     let uval = "_uctor_("^si vidx^"," ^ aval ^")"  in
   823:     ce_atom uval
   824: 
   825:   | `BEXPR_coerce ((srcx,srct) as srce,dstt) ->
   826:     let srct = lstrip syms.dfns srct in
   827:     let vts =
   828:       match dstt with
   829:       | `BTYP_variant ls -> ls
   830:       | _ -> syserr sr "Coerce non-variant"
   831:     in
   832:     begin match srcx with
   833:     | `BEXPR_variant (s,argt) ->
   834:       print_endline "Coerce known variant!";
   835:       ge' (`BEXPR_variant (s,argt),t)
   836:     | _ ->
   837:       let i =
   838:         begin try
   839:           Hashtbl.find syms.variant_map (srct,dstt)
   840:         with Not_found ->
   841:           let i = !(syms.counter) in incr (syms.counter);
   842:           Hashtbl.add syms.variant_map (srct,dstt) i;
   843:           i
   844:       end
   845:       in
   846:       ce_atom ("_uctor_(vmap_"^si i^","^ge srce^")")
   847:     end
   848: 
   849:   | `BEXPR_apply
   850:      (
   851:        (`BEXPR_case (v,t),t'),
   852:        (a,t'')
   853:      ) ->
   854:        (* t is the type of the sum,
   855:           t' is the function type of the constructor,
   856:           t'' is the type of the argument
   857:        *)
   858:        let
   859:          arg_typename = tn (lower t'')
   860:        and
   861:          union_typename = tn (lower t)
   862:        in
   863:        let aval =
   864:          if isclass bbdfns t'' then ge_arg (a,t'') else
   865:          "new (*PTF gc, "^arg_typename^"_ptr_map) " ^
   866:          arg_typename ^ "(" ^ ge_arg (a,t'') ^ ")"
   867:        in
   868:        let uval =
   869:          if is_unitsum t then
   870:            si v
   871:          else
   872:          "_uctor_(" ^ si v ^ ", " ^ aval ^")"
   873:        in
   874:        let s = "(" ^ union_typename ^ ")" ^ uval in
   875:        ce_atom s
   876: 
   877:        (*
   878:        failwith
   879:        (
   880:          "Trapped application, case " ^
   881:          si v ^
   882:          " of " ^ string_of_btypecode syms.dfns t ^
   883:          "\ntype " ^ string_of_btypecode syms.dfns t' ^
   884:          "\nargument=" ^
   885:          string_of_bound_expression syms.dfns (a,t'') ^
   886:          "\ntype " ^ string_of_btypecode syms.dfns t''
   887:        )
   888:       *)
   889: 
   890: 
   891:   | `BEXPR_apply_prim (index,ts,(arg,argt as a)) ->
   892:     (*
   893:     print_endline ("Prim apply, arg=" ^ sbe syms.dfns a);
   894:     *)
   895:     let argt = tsub argt in
   896:     let id,parent,sr2,entry =
   897:       try Hashtbl.find bbdfns index
   898:       with _ -> failwith ("[gen_expr(apply instance)] Can't find index " ^ si index)
   899:     in
   900:     begin
   901:     match entry with
   902:     | `BBDCL_fun (props,vs,ps,retyp,ct,_,prec) ->
   903:       if length vs <> length ts then
   904:       failwith
   905:       (
   906:         "[get_expr:apply closure of fun] function " ^
   907:         id ^ "<" ^ si index ^">" ^
   908:         ", wrong number of args, expected vs = " ^
   909:         si (length vs) ^
   910:         ", got ts=" ^
   911:         si (length ts)
   912:       );
   913:       begin match ct with
   914:       | `Identity -> ge' a
   915: 
   916:       | `Virtual ->
   917:         let ts = map tsub ts in
   918:         let index', ts' = Flx_typeclass.fixup_typeclass_instance syms bbdfns index ts in
   919:         if index <> index' then
   920:           clierr sr ("Virtual call of " ^ si index ^ " dispatches to " ^ si index')
   921:         ;
   922:         if index = index' then
   923:         begin
   924:           let entries =
   925:             try Hashtbl.find syms.typeclass_to_instance index
   926:             with Not_found -> (* print_endline ("Symbol " ^ si index ^ " Not instantiated?"); *) []
   927:           in
   928:           iter
   929:           (fun (bvs,t,ts,j) -> print_endline ("Candidate Instance " ^ si j ^ "[" ^ catmap "," (sbt syms.dfns) ts ^ "]"))
   930:           entries
   931:           ;
   932: 
   933:           clierr2 sr sr2 ("Instantiate virtual function(2) " ^ id ^ "<" ^si index ^
   934:             ">, no instance for ts="^ catmap "," (sbt syms.dfns) ts
   935:           )
   936:         end;
   937:         begin let _,_,sr3,entry =
   938:           try Hashtbl.find bbdfns index'
   939:           with Not_found -> syserr sr ("MISSING INSTANCE BBDCL " ^ si index')
   940:         in
   941:         match entry with
   942:         | `BBDCL_fun _ -> ge' (`BEXPR_apply_prim (index',ts',a),t)
   943:         | `BBDCL_function _ -> ge' (`BEXPR_apply_direct (index',ts',a),t)
   944:         | _ ->
   945:           clierr2 sr sr3 ("expected instance to be function " ^ id)
   946:         end
   947: 
   948:       | `Str s -> ce_expr prec s
   949:       | `StrTemplate s ->
   950:         let ts = map tsub ts in
   951:         let retyp = reduce_type (beta_reduce syms sr  (lstrip syms.dfns (tsubst vs ts retyp))) in
   952:         let retyp = tn retyp in
   953:         gen_prim_call syms bbdfns tsub ge'' s ts (arg,argt) retyp sr sr2 prec
   954:       end
   955: 
   956:     | `BBDCL_callback (props,vs,ps_cf,ps_c,_,retyp,_,_) ->
   957:       assert (retyp <> `BTYP_void);
   958:       if length vs <> length ts then
   959:       clierr sr "[gen_prim_call] Wrong number of type arguments"
   960:       ;
   961:       let ts = map tsub ts in
   962:       let s = id ^ "($a)" in
   963:       let retyp = reduce_type (beta_reduce syms sr  (lstrip syms.dfns (tsubst vs ts retyp))) in
   964:       let retyp = tn retyp in
   965:       gen_prim_call syms bbdfns tsub ge'' s ts (arg,argt) retyp sr sr2 "atom"
   966: 
   967:     (* but can't be a Felix function *)
   968:     | _ ->
   969:       failwith
   970:       (
   971:         "[gen_expr: apply prim] Expected '"^id^"' to be primitive function instance, got:\n" ^
   972:         string_of_bbdcl syms.dfns entry index
   973:       )
   974:     end
   975: 
   976:   | `BEXPR_apply_struct (index,ts,a) ->
   977:     let id,parent,sr2,entry =
   978:       try Hashtbl.find bbdfns index
   979:       with _ -> failwith ("[gen_expr(apply instance)] Can't find index " ^ si index)
   980:     in
   981:     let ts = map tsub ts in
   982:     begin match entry with
   983:     | `BBDCL_cstruct (vs,_) ->
   984:       let name = tn (`BTYP_inst (index,ts)) in
   985:       ce_atom ("reinterpret<"^ name ^">(" ^ ge a ^ ")")
   986: 
   987:     | `BBDCL_struct (vs,cts) ->
   988:       let name = tn (`BTYP_inst (index,ts)) in
   989:       if length cts > 1 then
   990:         (* argument must be an lvalue *)
   991:         ce_atom ("reinterpret<"^ name ^">(" ^ ge a ^ ")")
   992:       else if length cts = 0 then
   993:         ce_atom (name ^ "()")
   994:       else
   995:         ce_atom (name ^ "(" ^ ge a ^ ")")
   996: 
   997:     | `BBDCL_nonconst_ctor (vs,uidx,udt,cidx,ct,evs, etraint) ->
   998:       (* due to some hackery .. the argument of a non-const
   999:          ctor can STILL be a unit .. prolly cause the stupid
  1000:          compiler is checking for voids for these pests,
  1001:          but units for sums .. hmm .. inconsistent!
  1002:       *)
  1003:       let ts = map tsub ts in
  1004:       let ct = reduce_type (beta_reduce syms sr  (tsubst vs ts ct)) in
  1005:       let _,t = a in
  1006:       let t = reduce_type (beta_reduce syms sr  (tsubst vs ts t)) in
  1007:       begin match ct with
  1008:       | `BTYP_tuple [] ->
  1009:         ce_atom ( "_uctor_(" ^ si cidx ^ ", NULL)")
  1010: 
  1011:       (* function types are already pointers .. any use of this
  1012:          should do a clone .. class types are also pointers ..
  1013:       *)
  1014:       | `BTYP_function _ ->
  1015:         ce_atom (
  1016:           "_uctor_(" ^ si cidx ^ ", " ^ ge a ^")"
  1017:         )
  1018: 
  1019:       | _ when isclass bbdfns ct ->
  1020:         ce_atom (
  1021:           "_uctor_(" ^ si cidx ^ ", " ^ ge a ^")"
  1022:         )
  1023: 
  1024:       | _ ->
  1025:         let ctt = tn ct in
  1026:         let ptrmap = shape_of syms bbdfns tn ct in
  1027:         let txt =
  1028:            "_uctor_(" ^ si cidx ^ ", new(*PTF gc,"^ ptrmap^")"^
  1029:            ctt ^"("^ ge a ^"))"
  1030:         in
  1031:         ce_atom txt
  1032:       end
  1033:     | _ -> assert false
  1034:     end
  1035: 
  1036:   | `BEXPR_apply_direct (index,ts,a) ->
  1037:     let ts = map tsub ts in
  1038:     let index', ts' = Flx_typeclass.fixup_typeclass_instance syms bbdfns index ts in
  1039:     if index <> index' then
  1040:       clierr sr ("Virtual call of " ^ si index ^ " dispatches to " ^ si index')
  1041:     ;
  1042:     if index <> index' then
  1043:     begin
  1044:       let _,_,sr3,entry =
  1045:         try Hashtbl.find bbdfns index'
  1046:         with Not_found -> syserr sr ("MISSING INSTANCE BBDCL " ^ si index')
  1047:       in
  1048:       match entry with
  1049:       | `BBDCL_fun _ -> ge' (`BEXPR_apply_prim (index',ts',a),t)
  1050:       | `BBDCL_function _ -> ge' (`BEXPR_apply_direct (index',ts',a),t)
  1051:       | _ ->
  1052:           clierr2 sr sr3 ("expected instance to be function " ^ id)
  1053:     end else
  1054: 
  1055:     let id,parent,sr2,entry =
  1056:       try Hashtbl.find bbdfns index
  1057:       with _ -> failwith ("[gen_expr(apply instance)] Can't find index " ^ si index)
  1058:     in
  1059:     begin
  1060:     (*
  1061:     print_endline ("apply closure of "^ id );
  1062:     print_endline ("  .. argument is " ^ string_of_bound_expression syms.dfns a);
  1063:     *)
  1064:     match entry with
  1065:     | `BBDCL_regmatch (props,_,_,_,_)
  1066:     | `BBDCL_reglex (props,_,_,_,_,_)
  1067:     | `BBDCL_function (props,_,_,_,_) ->
  1068:       (*
  1069:       print_endline ("Generating closure[apply direct] of " ^ si index);
  1070:       *)
  1071:       let the_display =
  1072:         let d' =
  1073:           map (fun (i,vslen)-> "ptr"^ cpp_instance_name syms bbdfns i (list_prefix ts vslen))
  1074:           (get_display_list syms bbdfns index)
  1075:         in
  1076:           if length d' > our_level
  1077:           then "this" :: tl d'
  1078:           else d'
  1079:       in
  1080:       let name = cpp_instance_name syms bbdfns index ts in
  1081:       if mem `Cfun props
  1082:       then  (* this is probably wrong because it doesn't split arguments up *)
  1083:         ce_call (ce_atom name) [ce_atom (ge_arg a)]
  1084:       else
  1085:         ce_atom (
  1086:         "(FLX_NEWP("^name^")"^ strd the_display props ^")"^
  1087:         "\n      ->apply(" ^ ge_arg a ^ ")"
  1088:         )
  1089: 
  1090:     | `BBDCL_fun _ -> assert false
  1091:     (*
  1092:       ge' (`BEXPR_apply_prim (index,ts,a),t)
  1093:     *)
  1094: 
  1095:     | _ ->
  1096:       failwith
  1097:       (
  1098:         "[gen_expr: apply_direct] Expected '"^id^"' to be generic function instance, got:\n" ^
  1099:         string_of_bbdcl syms.dfns entry index
  1100:       )
  1101:     end
  1102: 
  1103:   | `BEXPR_apply_stack (index,ts,a) ->
  1104:     let ts = map tsub ts in
  1105:     let index', ts' = Flx_typeclass.fixup_typeclass_instance syms bbdfns index ts in
  1106:     if index <> index' then
  1107:       clierr sr ("Virtual call of " ^ si index ^ " dispatches to " ^ si index')
  1108:     ;
  1109:     if index <> index' then
  1110:     begin
  1111:       let _,_,sr3,entry =
  1112:         try Hashtbl.find bbdfns index'
  1113:         with Not_found -> syserr sr ("MISSING INSTANCE BBDCL " ^ si index')
  1114:       in
  1115:       match entry with
  1116:       | `BBDCL_fun _ -> ge' (`BEXPR_apply_prim (index',ts',a),t)
  1117:       | `BBDCL_function _ -> ge' (`BEXPR_apply_direct (index',ts',a),t)
  1118:       | _ ->
  1119:           clierr2 sr sr3 ("expected instance to be function " ^ id)
  1120:     end else
  1121: 
  1122:     let id,parent,sr2,entry =
  1123:       try Hashtbl.find bbdfns index
  1124:       with _ -> failwith ("[gen_expr(apply instance)] Can't find index " ^ si index)
  1125:     in
  1126:     begin
  1127:     (*
  1128:     print_endline ("apply closure of "^ id );
  1129:     print_endline ("  .. argument is " ^ string_of_bound_expression syms.dfns a);
  1130:     *)
  1131:     match entry with
  1132:     | `BBDCL_function (props,vs,(ps,traint),retyp,_) ->
  1133:       let display = get_display_list syms bbdfns index in
  1134:       let name = cpp_instance_name syms bbdfns index ts in
  1135: 
  1136:       (* C FUNCTION CALL *)
  1137:       if mem `Pure props && not (mem `Heap_closure props) then
  1138:         let s =
  1139:           assert (length display = 0);
  1140:           match ps with
  1141:           | [] -> ""
  1142:           | [{pindex=ix; ptyp=t}] ->
  1143:             if Hashtbl.mem syms.instances (ix,ts)
  1144:             then ge_arg a
  1145:             else ""
  1146: 
  1147:           | _ ->
  1148:             begin match a with
  1149:             | `BEXPR_tuple xs,_ ->
  1150:               (*
  1151:               print_endline ("Arg to C function is tuple " ^ sbe syms.dfns a);
  1152:               *)
  1153:               fold_left2
  1154:               (fun s ((x,t) as xt) {pindex=ix} ->
  1155:                 let x =
  1156:                   if Hashtbl.mem syms.instances (ix,ts)
  1157:                   then ge_arg xt
  1158:                   else ""
  1159:                 in
  1160:                 if String.length x = 0 then s else
  1161:                 s ^
  1162:                 (if String.length s > 0 then ", " else "") ^ (* append a comma if needed *)
  1163:                 x
  1164:               )
  1165:               ""
  1166:               xs ps
  1167: 
  1168:             | _,tt ->
  1169:               let tt = reduce_type (beta_reduce syms sr  (lstrip syms.dfns (tsubst vs ts tt))) in
  1170:               (* NASTY, EVALUATES EXPR MANY TIMES .. *)
  1171:               let n = ref 0 in
  1172:               fold_left
  1173:               (fun s i ->
  1174:                 (*
  1175:                 print_endline ( "ps = " ^ catmap "," (fun (id,(p,t)) -> id) ps);
  1176:                 print_endline ("tt=" ^ sbt syms.dfns tt);
  1177:                 *)
  1178:                 let t = nth_type tt i in
  1179:                 let a' = `BEXPR_get_n (i,a),t in
  1180:                 let x = ge_arg a' in
  1181:                 incr n;
  1182:                 if String.length x = 0 then s else
  1183:                 s ^ (if String.length s > 0 then ", " else "") ^ x
  1184:               )
  1185:               ""
  1186:               (nlist (length ps))
  1187:             end
  1188:         in
  1189:         let s =
  1190:           if mem `Requires_ptf props then
  1191:             if String.length s > 0 then "FLX_FPAR_PASS " ^ s
  1192:             else "FLX_FPAR_PASS_ONLY"
  1193:           else s
  1194:         in
  1195:           ce_atom (name ^ "(" ^ s ^ ")")
  1196:       else
  1197:         let the_display =
  1198:           let d' =
  1199:             map (fun (i,vslen)-> "ptr"^ cpp_instance_name syms bbdfns i (list_prefix ts vslen))
  1200:             display
  1201:           in
  1202:             if length d' > our_level
  1203:             then "this" :: tl d'
  1204:             else d'
  1205:         in
  1206:         let s =
  1207:           name^ strd the_display props
  1208:           ^
  1209:           "\n      .apply(" ^ ge_arg a ^ ")"
  1210:         in ce_atom s
  1211: 
  1212:     | _ ->
  1213:       failwith
  1214:       (
  1215:         "[gen_expr: apply_stack] Expected '"^id^"' to be generic function instance, got:\n" ^
  1216:         string_of_bbdcl syms.dfns entry index
  1217:       )
  1218:     end
  1219: 
  1220:   | `BEXPR_apply ((`BEXPR_closure (index,ts),_),a) ->
  1221:     assert false (* should have been factored out *)
  1222: 
  1223:   (* application of C function pointer, type
  1224:      f: a --> b
  1225:   *)
  1226:   | `BEXPR_apply ( (_,`BTYP_lvalue(`BTYP_cfunction _)) as f,a)
  1227:   | `BEXPR_apply ( (_,`BTYP_cfunction _) as f,a) ->
  1228:     ce_atom (
  1229:     (ge f) ^"(" ^ ge_arg a ^ ")"
  1230:     )
  1231: 
  1232:   (* General application*)
  1233:   | `BEXPR_apply (f,a) ->
  1234:     ce_atom (
  1235:     "("^(ge f) ^ ")->clone()\n      ->apply(" ^ ge_arg a ^ ")"
  1236:     )
  1237: 
  1238:   | `BEXPR_record es ->
  1239:     let rcmp (s1,_) (s2,_) = compare s1 s2 in
  1240:     let es = sort rcmp es in
  1241:     let es = map snd es in
  1242:     let ctyp = tn (lower t) in
  1243:     ce_atom (
  1244:     ctyp ^ "(" ^
  1245:       fold_left
  1246:       (fun s e ->
  1247:         let x = ge_arg e in
  1248:         if String.length x = 0 then s else
  1249:         s ^
  1250:         (if String.length s > 0 then ", " else "") ^
  1251:         x
  1252:       )
  1253:       ""
  1254:       es
  1255:     ^
  1256:     ")"
  1257:     )
  1258: 
  1259:   | `BEXPR_tuple es ->
  1260:     (*
  1261:     print_endline ("Eval tuple " ^ sbe syms.dfns (e,t));
  1262:     *)
  1263:     (* just apply the tuple type ctor to the arguments *)
  1264:     begin match t with
  1265:     | `BTYP_array (t',`BTYP_unitsum n) ->
  1266:       let tuple =
  1267:         let t'' = `BTYP_tuple (map (fun _ -> t') (nlist n)) in
  1268:         let ctyp = raw_typename t'' in
  1269:         ce_atom (
  1270:         ctyp ^ "(" ^
  1271:           fold_left
  1272:           (fun s e ->
  1273:             let x = ge_arg e in
  1274:             if String.length x = 0 then s else
  1275:             s ^
  1276:             (if String.length s > 0 then ", " else "") ^
  1277:             x
  1278:           )
  1279:           ""
  1280:           es
  1281:         ^
  1282:         ")"
  1283:         )
  1284:       in
  1285:         (* cast a tuple which is an array type to an array *)
  1286:         let atyp = tn (lower t) in
  1287:         ce_call
  1288:           (ce_atom ("reinterpret<" ^ atyp ^">"))
  1289:           [tuple]
  1290: 
  1291:     | `BTYP_tuple _ ->
  1292:       let ctyp = tn (lower t) in
  1293:       ce_atom (
  1294:       ctyp ^ "(" ^
  1295:         fold_left
  1296:         (fun s e ->
  1297:           let x = ge_arg e in
  1298:           if String.length x = 0 then s else
  1299:           s ^
  1300:           (if String.length s > 0 then ", " else "") ^
  1301:           x
  1302:         )
  1303:         ""
  1304:         es
  1305:       ^
  1306:       ")"
  1307:       )
  1308:     | _ -> assert false
  1309:     end
  1310: 
  1311: and gen_expr syms bbdfns this e vs ts sr =
  1312:   let e = Flx_maps.reduce_tbexpr bbdfns e in
  1313:   let s =
  1314:     try gen_expr' syms bbdfns this e vs ts sr
  1315:     with Unknown_prec p -> clierr sr
  1316:     ("[gen_expr] Unknown precedence name '"^p^"' in " ^ sbe syms.dfns e)
  1317:   in
  1318:   string_of_cexpr s
  1319: 
  1320: 
End ocaml section to src/flx_egen.ml[1]
Start ocaml section to src/flx_ctorgen.mli[1 /1 ]
     1: # 3 "./lpsrc/flx_ctorgen.ipk"
     2: open Flx_ast
     3: open Flx_types
     4: open Flx_mtypes1
     5: open Flx_mtypes2
     6: open Flx_label
     7: 
     8: val gen_ctor:
     9:   sym_state_t ->
    10:   fully_bound_symbol_table_t ->
    11:   string ->                   (* name *)
    12:   (int * int) list ->         (* display *)
    13:   (int * btypecode_t) list -> (* funs *)
    14:   (string * string) list ->   (* extra args *)
    15:   string list ->              (* extra inits *)
    16:   btypecode_t list ->         (* ts *)
    17:   property_t list ->          (* properties *)
    18:   string
    19: 
End ocaml section to src/flx_ctorgen.mli[1]
Start ocaml section to src/flx_ctorgen.ml[1 /1 ]
     1: # 23 "./lpsrc/flx_ctorgen.ipk"
     2: open Flx_util
     3: open Flx_ast
     4: open Flx_types
     5: open Flx_mtypes1
     6: open Flx_mtypes2
     7: open Flx_print
     8: open Flx_typing
     9: open Flx_name
    10: open Flx_tgen
    11: open Flx_unify
    12: open Flx_csubst
    13: open Flx_exceptions
    14: open Flx_display
    15: open List
    16: open Flx_generic
    17: open Flx_label
    18: open Flx_unravel
    19: open Flx_ogen
    20: open Flx_ctypes
    21: open Flx_cexpr
    22: open Flx_maps
    23: 
    24: let gen_ctor syms bbdfns name display funs extra_args extra_inits ts props =
    25:   let requires_ptf = mem `Requires_ptf props in
    26:   let requires_pc = mem `Yields props in
    27:   name^"::"^name^
    28:   (if length display + length extra_args = 0 then
    29:   (if requires_ptf then "(FLX_FPAR_DECL_ONLY)" else "()")
    30:   else
    31:   "\n  (\n" ^
    32:   (if requires_ptf then
    33:   "    FLX_FPAR_DECL\n"
    34:   else ""
    35:   )
    36:   ^
    37:   cat ",\n"
    38:   (
    39:     map
    40:     (
    41:       fun (i,vslen) ->
    42:         let instname = cpp_instance_name syms bbdfns i (list_prefix ts vslen) in
    43:       "    " ^ instname ^ " *pptr" ^ instname
    44:     )
    45:     display
    46:     @
    47:     map
    48:     (
    49:       fun (t,a) -> "    " ^ t ^ " _"^a
    50:     )
    51:     extra_args
    52:   )^
    53:   "\n  )\n"
    54:   )
    55:   ^
    56:   (if
    57:     length display + length funs +
    58:     length extra_args + length extra_inits +
    59:     (if requires_pc then 1 else 0)
    60:     = 0
    61:   then (if requires_ptf then "FLX_FMEM_INIT_ONLY" else "")
    62:   else
    63:   (if requires_ptf then
    64:   "  FLX_FMEM_INIT "
    65:   else " : "
    66:   )
    67:   ^
    68:   cat ",\n"
    69:   (
    70:     (if requires_pc then ["pc(0)"] else [])
    71:     @
    72:     map
    73:     (
    74:       fun (i,vslen) -> let instname = cpp_instance_name syms bbdfns i (list_prefix ts vslen) in
    75:       "  ptr" ^ instname ^ "(pptr"^instname^")"
    76:     )
    77:     display
    78:     @
    79:     map
    80:     (fun (index,t)->
    81:       cpp_instance_name syms bbdfns index ts
    82:       ^ "(0)"
    83:     )
    84:     funs
    85:     @
    86:     map
    87:     (fun (t,a) -> "  " ^a ^ "(_"^a^")")
    88:     extra_args
    89:     @
    90:     map
    91:     (fun x -> "  " ^x)
    92:     extra_inits
    93:   )) ^
    94:   " {}\n"
    95: 
    96: 
End ocaml section to src/flx_ctorgen.ml[1]
Start ocaml section to src/flx_elkgen.mli[1 /1 ]
     1: # 3 "./lpsrc/flx_elkgen.ipk"
     2: open Flx_ast
     3: open Flx_types
     4: open Flx_mtypes1
     5: open Flx_mtypes2
     6: open Flx_label
     7: open Flx_ctorgen
     8: 
     9: val gen_elk_parser:
    10:   string ->
    11:   string ->
    12:   sym_state_t ->
    13:   fully_bound_symbol_table_t ->
    14:   int ->
    15:   range_srcref ->
    16:   btypecode_t ->
    17:   int ->
    18:   int list ->
    19:   unit
    20: 
    21: val gen_elk_lexer:
    22:   string ->
    23:   string ->
    24:   sym_state_t ->
    25:   fully_bound_symbol_table_t ->
    26:   int ->
    27:   range_srcref ->
    28:   tbexpr_t ->
    29:   int ->
    30:   unit
    31: 
    32: 
End ocaml section to src/flx_elkgen.mli[1]
Start ocaml section to src/flx_elkgen.ml[1 /1 ]
     1: # 36 "./lpsrc/flx_elkgen.ipk"
     2: open Flx_util
     3: open Flx_ast
     4: open Flx_types
     5: open Flx_mtypes1
     6: open Flx_mtypes2
     7: open Flx_print
     8: open Flx_typing
     9: open Flx_name
    10: open Flx_tgen
    11: open Flx_unify
    12: open Flx_csubst
    13: open Flx_exceptions
    14: open Flx_display
    15: open List
    16: open Flx_generic
    17: open Flx_label
    18: open Flx_unravel
    19: open Flx_ogen
    20: open Flx_ctypes
    21: open Flx_cexpr
    22: open Flx_maps
    23: open Flx_egen
    24: open Flx_pgen
    25: open Flx_ctorgen
    26: 
    27: let gen_elk_lexer filebase module_name syms bbdfns this sr ((_,t') as e) n  =
    28:   let lexer_name = "ElkLex_"^si n in
    29:   let ge e = gen_expr syms bbdfns this e [] [] sr in
    30:   let tn t = cpp_typename syms t in
    31:   let get_token_fun_type = tn t' in
    32: 
    33:   let display = cal_display syms bbdfns (Some this) in
    34:   let frame_dcls =
    35:     "  FLX_FMEM_DECL\n"
    36:   in
    37:   let display_string =
    38:     cat ""
    39:     (
    40:       map
    41:       (fun (i, vslen) ->
    42:        try
    43:        let instname = cpp_instance_name syms bbdfns i [] in
    44:        "  " ^ instname ^ " *ptr" ^ instname ^ ";\n"
    45:        with _ -> failwith "Can't cal display name"
    46:        )
    47:       display
    48:     )
    49:   and ctor_dcl =
    50:     "  "^lexer_name ^ "(\n" ^
    51:     "    FLX_FPAR_DECL\n" ^
    52:     cat ""
    53:     (
    54:       map
    55:       (
    56:         fun (i,vslen) ->
    57:         let instname = cpp_instance_name syms bbdfns i [] in
    58:         "    " ^ instname ^ "*,\n"
    59:       )
    60:       display
    61:     )^
    62:     "    "^get_token_fun_type ^"\n  );\n"
    63:   in
    64:   let filename = filebase ^ "_lexer_" ^ si n ^ ".hpp" in
    65:   if syms.compiler_options.print_flag then
    66:   print_endline ("Generating Elkhound lexer " ^ lexer_name ^ " in " ^ filename);
    67: 
    68:   let f = open_out filename in
    69:   let pe s = output_string f (s ^ "\n") in
    70: 
    71:   let token_type, token_type_name, token_id, cts =
    72:     match t' with
    73:     | `BTYP_function (`BTYP_tuple [],`BTYP_inst(i,[])) ->
    74:       let id,parent,sr',entry = Hashtbl.find bbdfns i in
    75:       let token_type = `BTYP_inst(i,[]) in
    76:       let token_type_name = tn token_type in
    77:       begin match entry with
    78:       | `BBDCL_union ([],cts) -> token_type, token_type_name, id, cts
    79:       | _ -> assert false
    80:       end
    81:     | _ -> assert false
    82:   in
    83:   pe ("#ifndef ELKLEX_"^si n);
    84:   pe ("#define ELKLEX_"^si n);
    85:   pe "#include \"elk_lexerint.h\"";
    86:   pe "";
    87:   pe ("struct "^lexer_name^": public LexerInterface {");
    88:   pe ("  //frame");
    89:   pe frame_dcls;
    90:   pe ("  //display");
    91:   pe display_string;
    92:   pe ("  // constructor");
    93:   pe ctor_dcl;
    94:   pe ("  " ^ get_token_fun_type ^ " get_token; // client token generator");
    95:   pe ("  collector_t &gc; // Felix garbage collector");
    96:   pe "  void setToken();  //fetch next token ";
    97:   pe ("  "^lexer_name^" *init(); //prime the lexer");
    98:   pe "";
    99:   pe "  //Elkhound API";
   100:   pe "  static void nextToken(LexerInterface *lex);";
   101:   pe "  NextTokenFunc getTokenFunc() const { return &nextToken; }";
   102:   pe "  sm_string tokenDesc() const;";
   103:   pe "  sm_string tokenKindDesc(int kind) const;";
   104:   pe "};";
   105:   pe "#endif";
   106:   close_out f;
   107: 
   108:   let filename = filebase ^ "_lexer_" ^ si n ^ ".cpp" in
   109:   let f = open_out filename in
   110:   let pe s = output_string f (s ^ "\n") in
   111:   pe ("#include \""^module_name^"_lexer_"^si n^".hpp\"");
   112:   pe ("//token type = " ^ token_type_name);
   113:   pe ("static char *"^token_id^"_desc["^si (length cts)^"]={");
   114:   iter (fun (nm,_,_) -> pe ("   \""^nm^"\",")) cts;
   115:   pe ("};");
   116:   pe "";
   117:   (* FUDGE PROPERTY LIST *)
   118:   let props : property_t list = [`Uses_gc; `Requires_ptf] in
   119:   pe (gen_ctor syms bbdfns lexer_name display [] [get_token_fun_type,"get_token"] ["gc(*PTF gc)"] [] props);
   120:   pe ("sm_string " ^ lexer_name ^ "::tokenDesc() const { return tokenKindDesc(type); }");
   121:   pe "";
   122:   pe ("sm_string " ^ lexer_name ^ "::tokenKindDesc(int kind) const {");
   123:   pe ("  return "^token_id^"_desc[kind];");
   124:   pe ("}");
   125:   pe "";
   126:   pe ("void " ^ lexer_name ^ "::setToken() {");
   127:   pe ("  _uctor_ token = get_token->apply();");
   128:   pe ("  type = token.variant;");
   129:   pe ("  sval =  (SemanticValue)token.data;");
   130:   pe ("}");
   131:   pe "";
   132:   pe ("void " ^ lexer_name ^ "::nextToken(LexerInterface *lex) {");
   133:   pe ("  (("^lexer_name^"*)lex)->setToken();");
   134:   pe ("}");
   135:   pe "";
   136:   pe (lexer_name^" *"^lexer_name^"::init(){");
   137:   pe ("  nextToken(this);");
   138:   pe ("  return this;");
   139:   pe ("}");
   140: 
   141:   close_out f
   142: 
   143: let gen_elk_parser filebase module_name syms bbdfns this sr t' n ii =
   144:   let filename = filebase ^ "_parser_" ^ si n ^ ".gr" in
   145:   let parser_name = "_" ^ si n in
   146:   if syms.compiler_options.print_flag then
   147:   print_endline ("Generating Elkhound parser " ^ filename)
   148:   ;
   149:   let f = open_out filename in
   150:   let pe s = output_string f (s ^ "\n") in
   151:   let ps s = output_string f s in
   152:   let ge_arg this ((x,t) as e) =
   153:     match t with
   154:     | `BTYP_tuple [] -> ""
   155:     | _ -> gen_expr syms bbdfns this e [] [] sr
   156:   in
   157:   let tn t = cpp_typename syms (reduce_type t) in
   158:   let string_of_bprod (n,g) =
   159:     (match n with | None -> "" | Some n -> cid_of_flxid n ^ ":") ^
   160:     (match g with
   161:     | `Term k ->
   162:       (match Hashtbl.find syms.dfns k with {id=id}->cid_of_flxid id)
   163:     | `Nonterm (k::_) ->
   164:       (match Hashtbl.find syms.dfns k with {id=id}->cid_of_flxid id)
   165:     | _ -> assert false
   166:     )
   167:   in
   168:   let print_production (this,p,xs) =
   169:     match xs with
   170:     | [`BEXE_fun_return (_,((_,t) as e))] ->
   171:       let t = tn t in
   172:       ps ("  -> ");
   173:       ps (catmap " " string_of_bprod p);
   174:       pe "";
   175:       pe "    {";
   176:       pe ("       "^t^" *_x = new "^t^"(" ^ ge_arg this e ^ ");");
   177:       iter
   178:       (function
   179:         | Some n, `Nonterm _ -> pe ("       delete " ^ n^";")
   180:         | _ -> ()
   181:       )
   182:       p;
   183:       pe ("       return _x;");
   184:       pe "    }";
   185:     | _ -> assert false
   186:   in
   187:   let set_of_list ii : IntSet.t = fold_left (fun s elt ->IntSet.add elt s) IntSet.empty ii in
   188:   let nts_of_prod p : IntSetSet.t =
   189:     fold_left
   190:     (fun x (_,k) -> match k with
   191:       | `Nonterm ii -> IntSetSet.add (set_of_list ii) x
   192:       | `Term _ -> x
   193:     )
   194:     IntSetSet.empty
   195:     p
   196:   in
   197:   let prod_of_glr i =
   198:     try
   199:     match Hashtbl.find bbdfns i with
   200:     | _,_,_,`BBDCL_glr (_,_,_,(p,_)) -> p
   201:     | id,_,_,entry -> failwith
   202:       ("Expected "^si i^"->BBDCL_glr, got " ^ string_of_bbdcl syms.dfns entry i)
   203: 
   204:     with Not_found -> failwith ("Can't find BBDCL_glr " ^ si i)
   205:   in
   206:   let nts_of_glr i : IntSetSet.t = nts_of_prod (prod_of_glr i) in
   207:   let nt_uses x : IntSetSet.t =
   208:     IntSet.fold
   209:     (fun i nts ->
   210:       IntSetSet.union nts (nts_of_glr i)
   211:     )
   212:     x
   213:     IntSetSet.empty
   214:   in
   215:   let make_closure ii =
   216:     let been_done = ref (IntSetSet.singleton (set_of_list ii)) in
   217:     let to_do = ref (nt_uses (set_of_list ii)) in
   218:     while not (IntSetSet.is_empty !to_do) do
   219:       let x = IntSetSet.choose !to_do in
   220:       to_do := IntSetSet.remove x !to_do;
   221:       if not (IntSetSet.mem x !been_done) then begin
   222:         been_done := IntSetSet.add x !been_done;
   223:         to_do := IntSetSet.union !to_do (nt_uses x)
   224:       end
   225:     done;
   226:     !been_done
   227:   in
   228:   let print_nonterm x =
   229:     let j = IntSet.choose x in
   230:     let id,parent,sr'',entry = Hashtbl.find bbdfns j in
   231:     begin match entry with
   232:     | `BBDCL_glr (_,_,t,(p,xs)) ->
   233:       let tt = tn t in
   234:       pe ("nonterm("^tt^"*) "^cid_of_flxid id^" {");
   235:       pe ("  fun dup(x) { return new " ^ tt ^ "(*x); }");
   236:       pe ("  fun del(x) { delete x; }");
   237:       IntSet.iter (fun i ->
   238:         let id,parent,sr'',entry = Hashtbl.find bbdfns i in
   239:         match entry with
   240:         | `BBDCL_glr (_,_,t,(p,xs)) -> print_production (i,p,xs)
   241:         | _ -> assert false
   242:       )
   243:       x;
   244:       pe "}";
   245:     | _ -> assert false
   246:     end
   247:   in
   248:   let display = cal_display syms bbdfns (Some this) in
   249:   let frame_dcls =
   250:     "  FLX_FMEM_DECL"
   251:   in
   252:   let display_string =
   253:     cat ""
   254:     (
   255:       map
   256:       (fun (i,vslen) ->
   257:        try
   258:        let instname = cpp_instance_name syms bbdfns i [] in
   259:        "  " ^ instname ^ " *ptr" ^ instname ^ ";\n"
   260:        with _ -> failwith "Can't cal display name"
   261:        )
   262:       display
   263:     )
   264:   and ctor_dcl =
   265:     "  Elk" ^parser_name^
   266:     (if length display = 0
   267:     then "(FLX_FPAR_DECL_ONLY);\n"
   268:     else (
   269:     "  (\n" ^
   270:     "    FLX_FPAR_DECL\n " ^
   271:     cat ",\n"
   272:       (
   273:         map
   274:         (
   275:           fun (i,vslen) ->
   276:           let instname = cpp_instance_name syms bbdfns i [] in
   277:           "    " ^ instname ^ "*"
   278:         )
   279:         display
   280:       )^
   281:       "\n  );\n"
   282:     ))
   283:   in
   284:     begin match t' with
   285:     | `BTYP_function (`BTYP_tuple [],`BTYP_inst(i,[])) ->
   286:       let token_id,parent,sr',entry = Hashtbl.find bbdfns i in
   287:       let token_type = `BTYP_inst(i,[]) in
   288:       let token_type_name = tn token_type in
   289:       begin match entry with
   290:       | `BBDCL_union ([],cts) ->
   291:         let j = hd ii in
   292:         let id,parent,sr'',entry = Hashtbl.find bbdfns j in
   293:         begin match entry with
   294:         | `BBDCL_glr (props,_,t,(p,xs)) ->
   295:           let result_type = tn t in
   296:           pe ("//Elkhound parser Elk" ^ parser_name ^ " -> " ^ result_type);
   297:           pe ("//Token type " ^ token_id ^ " -> " ^ token_type_name);
   298:           pe "terminals {";
   299:           let i = ref 0 in
   300:           iter (fun (id,j,t) ->
   301:             pe ("  " ^ si j^" : "^ cid_of_flxid id ^ ";")
   302:           )
   303:           cts;
   304: 
   305:         pe "";
   306:         iter (fun (id,_,t) ->
   307:           if t <> `BTYP_void then begin
   308:             pe ("  token("^tn t^"*) " ^ cid_of_flxid id ^ "{");
   309:             pe ("    fun dup(x) { return x; }");
   310:             pe ("    fun del(x) {}");
   311:             pe ("}");
   312:           end
   313:         )
   314:         cts;
   315: 
   316:         pe "}";
   317:         pe "";
   318:         pe ("context_class Elk"^parser_name^": public UserActions {");
   319:         pe ("public:");
   320:         pe frame_dcls;
   321:         ps display_string;
   322:         pe ctor_dcl;
   323:         pe ("  collector_t &gc;");
   324:         pe
   325:         (
   326:           (if t = `BTYP_tuple [] then "int" else "_uctor_") ^
   327:           " apply(LexerInterface *lex);"
   328:         );
   329:         pe "};";
   330:         pe "";
   331:         pe "impl_verbatim {";
   332:         pe (gen_ctor syms bbdfns ("Elk"^parser_name) display [] [] ["gc(*PTF gc)"] [] props);
   333:         pe "}";
   334:         pe "";
   335:         pe "impl_verbatim {";
   336:         pe "// Felix function to apply the parser to a lexer";
   337:         pe "// This returns a polymorphic option";
   338:         pe "// case 0- Parse failed";
   339:         pe "// case 1- Argument contains parser result";
   340:         pe ("// Type of parser result is " ^ sbt syms.dfns t);
   341: 
   342:         pe
   343:         (
   344:           (if t = `BTYP_tuple [] then "int" else "_uctor_") ^
   345:           " Elk"^parser_name^"::apply(LexerInterface *lex) {"
   346:         );
   347:         pe "  _uctor_ result(0,0);";
   348:         pe "  SemanticValue p=(SemanticValue)(void*)0;";
   349:         pe "  GLR glr(this,this->makeTables());";
   350:         pe "  glr.noisyFailedParse = true;";
   351:         pe "  result.variant = glr.glrParse(*lex,p);";
   352:         pe "";
   353:         pe "  if(result.variant==1)";
   354: 
   355:         if t = `BTYP_tuple [] then begin
   356:         pe "  delete (void*)p;";
   357:         pe "  return result.variant;";
   358:         end else begin
   359:         pe ("    result.data =");
   360:         pe ("      new(gc,"^shape_of syms bbdfns tn t^")");
   361:         pe ("      "^result_type^"(*("^result_type^"*)(void*)p)");
   362:         pe ("  ;");
   363:         pe ("  delete ("^result_type^"*)(void*)p;");
   364:         pe "  return result;";
   365:         end;
   366:         pe "}";
   367:         pe "}";
   368:         pe "";
   369: 
   370:         pe ("nonterm("^result_type^"*) elk"^parser_name^" {");
   371:         print_production (j,p,xs);
   372:         iter (fun i ->
   373:           let id,parent,sr'',entry = Hashtbl.find bbdfns i in
   374:           match entry with
   375:           | `BBDCL_glr (_,vs,t,(p,xs)) -> print_production (i,p,xs)
   376:           | _ -> assert false
   377:         )
   378:         (tl ii)
   379:         ;
   380:         pe "}";
   381:         let cls = make_closure ii in
   382:         IntSetSet.iter print_nonterm cls;
   383:         pe "//End grammar"
   384: 
   385:       | _ -> assert false (* must be glr *)
   386:       end
   387: 
   388:     | _ ->
   389:       clierr sr
   390:       "Parser function must have unit domain and return a non-polymorphic union"
   391:     end
   392:   | _ ->
   393:     clierr sr
   394:     "Parser function must have unit domain and return a non-polymorphic union"
   395:   end
   396:   ;
   397:   close_out f
   398:   ;
   399:   let elkhound = syms.compiler_options.elkhound in
   400:   let retval = Unix.system(elkhound ^ " -tr nolines " ^ filename) in
   401:   begin match retval with
   402:   | Unix.WEXITED 0 -> ()
   403:   | _ -> failwith "Error executing flx_elkhound"
   404:   end
   405: 
   406: 
End ocaml section to src/flx_elkgen.ml[1]