5.52. Type generator

Start ocaml section to src/flx_tgen.mli[1 /1 ]
     1: # 4 "./lpsrc/flx_tgen.ipk"
     2: open Flx_types
     3: open Flx_mtypes2
     4: 
     5: val gen_types :
     6:   sym_state_t ->
     7:   fully_bound_symbol_table_t ->
     8:   (int * btypecode_t) list -> string
     9: 
    10: val gen_type_names :
    11:   sym_state_t ->
    12:   fully_bound_symbol_table_t ->
    13:   (int * btypecode_t) list -> string
    14: 
End ocaml section to src/flx_tgen.mli[1]
Start ocaml section to src/flx_tgen.ml[1 /2 ] Next Last
     1: # 19 "./lpsrc/flx_tgen.ipk"
     2: open Flx_util
     3: open Flx_types
     4: open Flx_mtypes1
     5: open Flx_mtypes2
     6: open Flx_print
     7: open Flx_typing
     8: open Flx_srcref
     9: open Flx_unify
    10: open Flx_name
    11: open Flx_cexpr
    12: open Flx_csubst
    13: open Flx_exceptions
    14: open Flx_treg
    15: open List
    16: open Flx_ctypes
    17: open Flx_ctype
    18: 
End ocaml section to src/flx_tgen.ml[1]
Now some code to generate the bases, given the hashtable. We also mangle c++ abstract type names.
Start ocaml section to src/flx_tgen.ml[2 /2 ] Prev First
    19: # 40 "./lpsrc/flx_tgen.ipk"
    20: let gen_tuple name tn typs =
    21:   let n = length typs in
    22:   "struct " ^ name ^ " {\n" ^
    23:   catmap ""
    24:   (fun (t,i) ->
    25:     if t = `BTYP_tuple []
    26:     then "  // elided mem_" ^ si i ^ "(type unit)\n"
    27:     else "  "^tn t^ " mem_" ^ si i ^ ";\n"
    28:   )
    29:   (combine typs (nlist n))
    30:   ^
    31:   "  " ^ name ^ "(){}\n" (* default constructor *)
    32:   ^
    33:   (
    34:     if fold_left (fun r t -> r && t = `BTYP_tuple []) true typs
    35:     then ""
    36:     else
    37:     "  " ^ name ^ "(" ^
    38:     fold_left
    39:     (fun s (t,i) ->
    40:       if t = `BTYP_tuple [] then s
    41:       else
    42:         s ^
    43:         (if String.length s > 0 then ", " else "") ^
    44:         tn t^" a" ^ si i
    45:     )
    46:     ""
    47:     (combine typs (nlist n))
    48:     ^
    49:     "):\n    "
    50:     ^
    51:     fold_left
    52:     (fun s (t,i) ->
    53:       if t = `BTYP_tuple [] then s
    54:       else
    55:         s ^
    56:         (if String.length s > 0 then ", " else "") ^
    57:         "mem_"^si i ^ "(a" ^ si i^")"
    58:     )
    59:     ""
    60:     (combine typs (nlist n))
    61:     ^
    62:     "{}\n"
    63:   )
    64:   ^
    65:   "};\n"
    66: 
    67: let gen_record name tn typs =
    68:   let n = length typs in
    69:   "struct " ^ name ^ " {\n" ^
    70:   catmap ""
    71:   (fun (n,t) ->
    72:     if t = `BTYP_tuple []
    73:     then "  // elided " ^ n ^ "(type unit)\n"
    74:     else "  "^tn t^ " " ^ n ^ ";\n"
    75:   )
    76:   typs
    77:   ^
    78:   "  " ^ name ^ "(){}\n" (* default constructor *)
    79:   ^
    80:   (
    81:     if fold_left (fun r (n,t) -> r && t = `BTYP_tuple []) true typs
    82:     then ""
    83:     else
    84:     "  " ^ name ^ "(" ^
    85:     fold_left
    86:     (fun s (n,t) ->
    87:       if t = `BTYP_tuple [] then s
    88:       else
    89:         s ^
    90:         (if String.length s > 0 then ", " else "") ^
    91:         tn t^" _" ^ n ^ "_a"
    92:     )
    93:     ""
    94:     typs
    95:     ^
    96:     "):\n    "
    97:     ^
    98:     fold_left
    99:     (fun s (n,t) ->
   100:       if t = `BTYP_tuple [] then s
   101:       else
   102:         s ^
   103:         (if String.length s > 0 then ", " else "") ^
   104:         n ^ "(_" ^ n ^"_a)"
   105:     )
   106:     ""
   107:     typs
   108:     ^
   109:     "{}\n"
   110:   )
   111:   ^
   112:   "};\n"
   113: 
   114: (* copy ctor, assignment, and destructor are generated;
   115:   we have to supply the pointer constructor and default
   116:   constructor though. Note that it matters not if this
   117:   type is sliced, since it's nothing more than a type
   118:   correct wrapper for its base
   119: *)
   120: let gen_ref name typ =
   121:   "struct " ^ name ^ ": _ref_ {\n" ^
   122:   "  "^name^"(){}\n" ^
   123:   "  "^name^"(void *f, " ^typ^" *d): _ref_(f,d){}\n" ^
   124:   "  "^typ^" *operator->()const { return ("^typ^"*)get_data(); }\n" ^
   125:   "  "^typ^" &operator*() const { return *("^typ^"*)get_data(); }\n" ^
   126:   "};\n"
   127: 
   128: (* this routine generates a typedef (for primitives)
   129: or struct declaration which names the type.
   130: *)
   131: 
   132: let gen_type_name syms bbdfns (index,typ) =
   133:   (*
   134:   print_endline (
   135:     "GENERATING TYPE NAME " ^
   136:     si index^": " ^
   137:     sbt syms.dfns typ
   138:   );
   139:   *)
   140:   let cn t = cpp_type_classname syms t in
   141:   let tn t = cpp_typename syms t in
   142:   let descr =
   143:     "\n//TYPE "^si index^": " ^ sbt syms.dfns typ ^ "\n"
   144:   in
   145:   let t = unfold syms.dfns typ in
   146:   match t with
   147:   | `BTYP_fix i -> ""
   148:   | `BTYP_var i -> failwith "[gen_type_name] Can't gen name of type variable"
   149: 
   150:   | `BTYP_tuple [] -> "" (* unit *)
   151: 
   152:   | `BTYP_pointer _
   153:   | `BTYP_tuple _
   154:   | `BTYP_record _
   155:   | `BTYP_array _
   156:   | `BTYP_function _ ->
   157:     descr ^
   158:     let name = cn typ in
   159:     "struct " ^ name ^ ";\n"
   160: 
   161:   | `BTYP_cfunction (d,c) ->
   162:     descr ^
   163:     let name = cn typ in
   164:     let ds = match d with
   165:       | `BTYP_tuple ls -> ls
   166:       | x -> [x]
   167:     in
   168:     let ctn t = `Ct_base (cpp_typename syms t) in
   169:     let t = `Ct_fun (ctn c,map ctn ds) in
   170:     let cdt = `Cdt_value t in
   171:     "typedef " ^ string_of_cdecl_type name cdt ^ ";\n"
   172: 
   173:   | `BTYP_unitsum k ->
   174:       "typedef int " ^ tn typ ^ ";\n"
   175: 
   176:   | `BTYP_sum ts ->
   177:     descr ^
   178:     if is_unitsum typ
   179:     then
   180:       "typedef int " ^ tn typ ^ ";\n"
   181:     else
   182:       "typedef _uctor_ " ^ tn typ ^ ";\n"
   183: 
   184:   | `BTYP_variant ts ->
   185:     "typedef _uctor_ " ^ tn typ ^ ";\n"
   186: 
   187:   | `BTYP_void -> ""
   188: 
   189:   | `BTYP_inst (i,ts) ->
   190:     let id,parent,sr,entry =
   191:       try Hashtbl.find bbdfns i
   192:       with _ -> failwith ("[gen_type_name] can't find type" ^ si i)
   193:     in
   194:     begin match entry with
   195:     | `BBDCL_abs (vs,quals,ct,_) ->
   196:       let complete = not (mem `Incomplete quals) in
   197:       let descr =
   198:         "\n//"^(if complete then "" else "INCOMPLETE ")^
   199:         "PRIMITIVE "^si i ^" INSTANCE " ^
   200:         si index^": " ^
   201:         sbt syms.dfns typ ^
   202:         "\n"
   203:       in
   204:       let instance_name = cn typ in
   205:       let tss = map tn ts in
   206:       let instance =
   207:         match ct with
   208:         | `Str c -> c
   209:         | `StrTemplate c ->
   210:         try sc "expr" (csubst sr sr c (Flx_cexpr.ce_atom "Error") [] [] "Error" "Error" tss "atom" "Error" ["Error"] ["Error"] ["Error"])
   211:         with Not_found -> failwith "[gen_type_name] Unexpected error in csubst"
   212:       in
   213: 
   214:       (* special hack to avoid 'typedef int int' when we decide
   215:       to use the native typename in generated code instead of
   216:       an alias
   217:       *)
   218:       (if instance = instance_name
   219:       then descr ^ "//"
   220:       else descr
   221:       )
   222:       ^
   223:       "typedef " ^ instance ^ " " ^ instance_name ^ ";\n"
   224: 
   225:     | `BBDCL_cstruct _ -> if ts = [] then "" else
   226:       let descr =
   227:         "\n//CSTRUCT "^si i ^" INSTANCE " ^
   228:         si index^": " ^
   229:         sbt syms.dfns typ ^
   230:         "\n"
   231:       in
   232:       let instance_name = cn typ in
   233:       let instance = id ^ "<" ^ catmap "," cn ts ^"> " in
   234:       descr ^
   235:       "typedef " ^ instance ^ " " ^ instance_name ^ ";\n"
   236: 
   237: 
   238:     | `BBDCL_class _ ->
   239:       begin
   240:         (*
   241:         print_endline "[gen_type_name] CLASS TYPE INSTANCE";
   242:         *)
   243:         let type_instance_name = cn typ in
   244:         let class_name = cpp_instance_name syms bbdfns i ts in
   245:         let class_instance =
   246:           try Hashtbl.find syms.instances (i,ts)
   247:           with Not_found -> assert false
   248:         in
   249:         let descr =
   250:           "\n//CLASS "^si i ^" TYPE INSTANCE " ^
   251:           si index^": " ^
   252:           sbt syms.dfns typ ^
   253:           ", CLASS INSTANCE " ^ si class_instance ^
   254:           "\n"
   255:         in
   256:         descr ^
   257:         "struct " ^ class_name ^"; // class instance \n"  ^
   258:         "typedef " ^ class_name ^" *"^type_instance_name^"; // type instance\n"
   259:       end
   260: 
   261:     | `BBDCL_cclass _ ->  if ts = [] then "" else
   262:       let descr =
   263:         "\n//CCLASS "^si i ^" INSTANCE " ^
   264:         si index^": " ^
   265:         sbt syms.dfns typ ^
   266:         "\n"
   267:       in
   268:       let instance_name = cn typ in
   269:       let instance = id ^ "<" ^ catmap "," cn ts ^"> " in
   270:       descr ^
   271:       "typedef " ^ instance ^ " *" ^ instance_name ^ ";\n"
   272: 
   273:     | `BBDCL_struct _ ->
   274:       let descr =
   275:         "\n//STRUCT "^si i ^" INSTANCE " ^
   276:         si index^": " ^
   277:         sbt syms.dfns typ ^
   278:         "\n"
   279:       in
   280:       let name = cn typ in
   281:       descr ^ "struct " ^ name ^ ";\n"
   282: 
   283:     | `BBDCL_union (vs,ls) ->
   284:       let descr =
   285:         "\n//UNION "^si i ^" INSTANCE " ^
   286:         si index^": " ^
   287:         sbt syms.dfns typ ^
   288:         "\n"
   289:       in
   290:       let name = cn typ in
   291:       descr ^
   292:       let lss = map (fun (_,_,t)->t) ls in
   293:       let lss = map (tsubst vs ts) lss in
   294:       let len = si (length lss) in
   295:       if all_voids lss
   296:       then
   297:         "typedef int " ^ name ^ "; //ncases="^len^"\n"
   298:       else
   299:         "typedef _uctor_ " ^ name ^ "; //ncases="^len^"\n"
   300: 
   301: 
   302:     | _ ->
   303:       failwith
   304:       (
   305:         "[gen_type_name] Expected definition "^si i^" to be generic primitive, got " ^
   306:         string_of_bbdcl syms.dfns entry i ^
   307:         " instance types [" ^
   308:         catmap ", " tn ts ^
   309:         "]"
   310:       )
   311:     end
   312: 
   313:   | _ -> failwith ("Unexpected metatype "^ sbt syms.dfns t ^ " in gen_type_name")
   314: 
   315: let mk_listwise_ctor syms i name typ cts ctss =
   316:   if length cts = 1 then
   317:   let ctn,ctt = hd ctss in
   318:     "  " ^ name ^ "("^ ctt ^ " const & _a): " ^
   319:     ctn^"(_a){}\n"
   320:   else ""
   321: 
   322: 
   323: (* This routine generates complete types when needed *)
   324: let gen_type syms bbdfns (index,typ) =
   325:   (*
   326:   print_endline (
   327:     "GENERATING TYPE " ^
   328:     si index^": " ^
   329:     sbt syms.dfns typ
   330:   );
   331:   *)
   332:   let tn t = cpp_typename syms t in
   333:   let cn t = cpp_type_classname syms t in
   334:   let descr =
   335:     "\n//TYPE "^ si index^ ": " ^
   336:     sbt syms.dfns typ ^
   337:     "\n"
   338:   in
   339:   let t = unfold syms.dfns typ in
   340:   match t with
   341:   | `BTYP_var _ -> failwith "[gen_type] can't gen type variable"
   342:   | `BTYP_fix _ -> failwith "[gen_type] can't gen type fixpoint"
   343: 
   344:   (* PROCEDURE *)
   345:   | `BTYP_cfunction _ -> ""
   346: 
   347:   | `BTYP_function (a,`BTYP_void) ->
   348:     descr ^
   349:     let name = cn typ
   350:     and argtype = tn a
   351:     and unitproc = a = `BTYP_tuple[]
   352:     in
   353:     "struct " ^ name ^
   354:     ": con_t {\n" ^
   355:     "  typedef void rettype;\n" ^
   356:     "  typedef " ^ (if unitproc then "void" else argtype) ^ " argtype;\n" ^
   357:     (if unitproc
   358:     then
   359:     "  virtual con_t *call(con_t *)=0;\n"
   360:     else
   361:     "  virtual con_t *call(con_t *, "^argtype^" const &)=0;\n"
   362:     ) ^
   363:     "  virtual "^name^" *clone()const=0;\n"  ^
   364:     "  virtual con_t *resume()=0;\n"  ^
   365:     "};\n"
   366: 
   367:   (* FUNCTION *)
   368:   | `BTYP_function (a,r) ->
   369:     descr ^
   370:     let name = cn typ
   371:     and argtype = tn a
   372:     and rettype = tn r
   373:     and unitfun = a = `BTYP_tuple[]
   374:     in
   375:     "struct " ^ name ^ " {\n" ^
   376:     "  typedef " ^ rettype ^ " rettype;\n" ^
   377:     "  typedef " ^ (if unitfun then "void" else argtype) ^ " argtype;\n" ^
   378:     "  virtual "^rettype^" apply("^
   379:     (if unitfun then "" else argtype^" const &") ^
   380:     ")=0;\n"  ^
   381:     "  virtual "^name^" *clone()const=0;\n"  ^
   382:     "  virtual ~"^name^"(){};\n" ^
   383:     "};\n"
   384: 
   385:   | `BTYP_unitsum _ -> "" (* union typedef *)
   386:   | `BTYP_sum _ -> "" (* union typedef *)
   387:   | `BTYP_variant _ -> ""
   388: 
   389:   | `BTYP_tuple [] -> ""
   390:   | `BTYP_tuple ts ->
   391:      descr ^
   392:      gen_tuple (cn typ) tn ts
   393: 
   394:   | `BTYP_record ts ->
   395:      descr ^
   396:      gen_record (cn typ) tn ts
   397: 
   398:   | `BTYP_void -> ""
   399:   | `BTYP_pointer t ->
   400:     let name = tn typ in
   401:     let t = tn t in
   402:     descr ^ gen_ref name t
   403: 
   404:   | `BTYP_array (v,i) ->
   405:     let name = tn typ in
   406:     let v = tn v in
   407:     let n =
   408:       match i with
   409:       | `BTYP_unitsum k -> k
   410:       | `BTYP_sum ls ->
   411:         if all_units ls then length ls
   412:         else
   413:           failwith
   414:           (
   415:             "Array index must be unit sum, got\n" ^
   416:             sbt syms.dfns i
   417:           )
   418:       | _ ->
   419:         failwith
   420:         (
   421:           "Array index must be unit sum, got\n" ^
   422:           sbt syms.dfns i
   423:         )
   424:     in
   425:     descr ^
   426:     "struct " ^ name ^ " {\n" ^
   427:     "  static size_t const len = " ^ si n ^ ";\n" ^
   428:     "  typedef " ^ v ^ " element_type;\n" ^
   429:     "  " ^ v ^ " data[" ^ si n ^ "];\n" ^
   430:     "};\n"
   431: 
   432: 
   433:   | `BTYP_inst (i,ts) ->
   434:     let id,parent,sr,entry =
   435:       try Hashtbl.find bbdfns i
   436:       with _ -> failwith ("[gen_type_name] can't find type" ^ si i)
   437:     in
   438:     begin match entry with
   439:     | `BBDCL_abs (vs,quals,ct,_) -> ""
   440:     | `BBDCL_cstruct (vs,cts) -> ""
   441:     | `BBDCL_cclass (vs,cts) -> ""
   442:     | `BBDCL_class vs ->
   443:       (*
   444:       print_endline "[gen_type] FOUND CLASS TYPE INSTANCE (doing nothing)";
   445:       *)
   446:       ""
   447: 
   448:       (*
   449:       let name = cn typ in
   450:       let descr =
   451:         "\n//GENERIC CLASS "^si i ^" INSTANCE TYPE " ^
   452:         si index^": " ^
   453:         sbt syms.dfns typ ^
   454:         "\n"
   455:       in
   456:       descr ^ "//see " ^ name ^ ";\n"
   457:       *)
   458: 
   459:     | `BBDCL_struct (vs,cts) ->
   460:       let cts = map (fun (name,typ) -> name, tsubst vs ts typ) cts in
   461:       let ctss = map (fun (name,typ) -> name, tn typ) cts in
   462:       let name = cn typ in
   463:       let listwise_ctor = mk_listwise_ctor syms i name typ cts ctss in
   464:       let descr =
   465:         "\n//GENERIC STRUCT "^si i ^" INSTANCE " ^
   466:         si index^": " ^
   467:         sbt syms.dfns typ ^
   468:         "\n"
   469:       in
   470:       descr ^ "struct " ^ name ^ " {\n"
   471:       ^
   472:       catmap ""
   473:       (fun (name,typ) -> "  " ^ typ ^ " " ^ name ^ ";\n")
   474:       ctss
   475:       ^
   476:       "  " ^ name ^ "(){}\n" ^
   477:       listwise_ctor
   478:       ^
   479:       "};\n"
   480: 
   481: 
   482:     | `BBDCL_union _ -> ""
   483: 
   484:     | _ ->
   485:       failwith
   486:       (
   487:         "[gen_type] Expected definition "^si i^" to be generic primitive, got " ^
   488:         string_of_bbdcl syms.dfns entry i ^
   489:         " instance types [" ^
   490:         catmap ", " tn ts ^
   491:         "]"
   492:       )
   493:     end
   494: 
   495:   | _ -> failwith ("[gen_type] Unexpected metatype " ^ sbt syms.dfns t)
   496: 
   497: let gen_type_names syms bbdfns ts =
   498:   (* print_endline "GENERATING TYPE NAMES"; *)
   499:   let s = Buffer.create 100 in
   500:   iter
   501:   (fun (i,t) ->
   502:     try
   503:       Buffer.add_string s (gen_type_name syms bbdfns (i,t))
   504:     with Not_found ->
   505:       failwith ("Can't gen type name " ^ si i ^ "=" ^ sbt syms.dfns t)
   506:   )
   507:   ts;
   508:   Buffer.contents s
   509: 
   510: let gen_types syms bbdfns ts =
   511:   (* print_endline "GENERATING TYPES"; *)
   512:   let s = Buffer.create 100 in
   513:   iter
   514:   (fun t ->
   515:     Buffer.add_string s (gen_type syms bbdfns t)
   516:   )
   517:   ts;
   518:   Buffer.contents s
   519: 
End ocaml section to src/flx_tgen.ml[2]