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