5.59. The back end

Start ocaml section to src/flx_name.mli[1 /1 ]
     1: # 3 "./lpsrc/flx_name.ipk"
     2: open Flx_types
     3: open Flx_mtypes2
     4: 
     5: val cpp_name :
     6:   fully_bound_symbol_table_t ->
     7:   int ->
     8:   string
     9: 
    10: val cpp_instance_name :
    11:   sym_state_t ->
    12:   fully_bound_symbol_table_t ->
    13:   int ->
    14:   btypecode_t list ->
    15:   string
    16: 
    17: val cpp_type_classname :
    18:   sym_state_t ->
    19:   btypecode_t ->
    20:   string
    21: 
    22: val cpp_typename :
    23:   sym_state_t ->
    24:   btypecode_t ->
    25:   string
    26: 
    27: 
    28: val cpp_ltypename :
    29:   sym_state_t ->
    30:   btypecode_t ->
    31:   string
    32: 
    33: 
    34: (** mangle a Felix identifier to a C one *)
    35: val cid_of_flxid:
    36:  string-> string
    37: 
End ocaml section to src/flx_name.mli[1]
Start ocaml section to src/flx_name.ml[1 /1 ]
     1: # 41 "./lpsrc/flx_name.ipk"
     2: open Flx_types
     3: open Flx_mtypes2
     4: open Flx_unify
     5: open Flx_print
     6: open Flx_util
     7: open Flx_exceptions
     8: open List
     9: 
    10: (* these words are either keywords or peculiar to the
    11:    compiler code generator, so we have to avoid a clash.
    12:    This list has been constructed by trial and error ..
    13: 
    14:    note the RHS value is irrelevant, it just has to be different
    15:    to the LHS value ..
    16: *)
    17: 
    18: let fixups = [
    19:   (* special names in thread frame *)
    20:   "argc","_argc";
    21:   "argv","_argv";
    22:   "flx_stdin","_flx_stdin";
    23:   "flx_stdout","_flx_stdout";
    24:   "flx_stderr","_flx_stderr";
    25:   "gc","_gc";
    26: # 67 "./lpsrc/flx_name.ipk"
    27:   "asm","_asm";
    28: # 67 "./lpsrc/flx_name.ipk"
    29:   "auto","_auto";
    30: # 67 "./lpsrc/flx_name.ipk"
    31:   "bool","_bool";
    32: # 67 "./lpsrc/flx_name.ipk"
    33:   "break","_break";
    34: # 67 "./lpsrc/flx_name.ipk"
    35:   "case","_case";
    36: # 67 "./lpsrc/flx_name.ipk"
    37:   "catch","_catch";
    38: # 67 "./lpsrc/flx_name.ipk"
    39:   "charclass","_charclass";
    40: # 67 "./lpsrc/flx_name.ipk"
    41:   "const","_const";
    42: # 67 "./lpsrc/flx_name.ipk"
    43:   "const_cast","_const_cast";
    44: # 67 "./lpsrc/flx_name.ipk"
    45:   "continue","_continue";
    46: # 67 "./lpsrc/flx_name.ipk"
    47:   "default","_default";
    48: # 67 "./lpsrc/flx_name.ipk"
    49:   "delete","_delete";
    50: # 67 "./lpsrc/flx_name.ipk"
    51:   "do","_do";
    52: # 67 "./lpsrc/flx_name.ipk"
    53:   "double","_double";
    54: # 67 "./lpsrc/flx_name.ipk"
    55:   "dynamic_cast","_dynamic_cast";
    56: # 67 "./lpsrc/flx_name.ipk"
    57:   "else","_else";
    58: # 67 "./lpsrc/flx_name.ipk"
    59:   "enum","_enum";
    60: # 67 "./lpsrc/flx_name.ipk"
    61:   "explicit","_explicit";
    62: # 67 "./lpsrc/flx_name.ipk"
    63:   "extern","_extern";
    64: # 67 "./lpsrc/flx_name.ipk"
    65:   "false","_false";
    66: # 67 "./lpsrc/flx_name.ipk"
    67:   "float","_float";
    68: # 67 "./lpsrc/flx_name.ipk"
    69:   "for","_for";
    70: # 67 "./lpsrc/flx_name.ipk"
    71:   "friend","_friend";
    72: # 67 "./lpsrc/flx_name.ipk"
    73:   "goto","_goto";
    74: # 67 "./lpsrc/flx_name.ipk"
    75:   "if","_if";
    76: # 67 "./lpsrc/flx_name.ipk"
    77:   "inline","_inline";
    78: # 67 "./lpsrc/flx_name.ipk"
    79:   "int","_int";
    80: # 67 "./lpsrc/flx_name.ipk"
    81:   "long","_long";
    82: # 67 "./lpsrc/flx_name.ipk"
    83:   "mutable","_mutable";
    84: # 67 "./lpsrc/flx_name.ipk"
    85:   "namespace","_namespace";
    86: # 67 "./lpsrc/flx_name.ipk"
    87:   "new","_new";
    88: # 67 "./lpsrc/flx_name.ipk"
    89:   "operator","_operator";
    90: # 67 "./lpsrc/flx_name.ipk"
    91:   "private","_private";
    92: # 67 "./lpsrc/flx_name.ipk"
    93:   "protected","_protected";
    94: # 67 "./lpsrc/flx_name.ipk"
    95:   "public","_public";
    96: # 67 "./lpsrc/flx_name.ipk"
    97:   "register","_register";
    98: # 67 "./lpsrc/flx_name.ipk"
    99:   "reinterpret_cast","_reinterpret_cast";
   100: # 67 "./lpsrc/flx_name.ipk"
   101:   "return","_return";
   102: # 67 "./lpsrc/flx_name.ipk"
   103:   "short","_short";
   104: # 67 "./lpsrc/flx_name.ipk"
   105:   "signed","_signed";
   106: # 67 "./lpsrc/flx_name.ipk"
   107:   "sizeof","_sizeof";
   108: # 67 "./lpsrc/flx_name.ipk"
   109:   "static","_static";
   110: # 67 "./lpsrc/flx_name.ipk"
   111:   "static_cast","_static_cast";
   112: # 67 "./lpsrc/flx_name.ipk"
   113:   "struct","_struct";
   114: # 67 "./lpsrc/flx_name.ipk"
   115:   "switch","_switch";
   116: # 67 "./lpsrc/flx_name.ipk"
   117:   "template","_template";
   118: # 67 "./lpsrc/flx_name.ipk"
   119:   "this","_this";
   120: # 67 "./lpsrc/flx_name.ipk"
   121:   "throw","_throw";
   122: # 67 "./lpsrc/flx_name.ipk"
   123:   "true","_true";
   124: # 67 "./lpsrc/flx_name.ipk"
   125:   "try","_try";
   126: # 67 "./lpsrc/flx_name.ipk"
   127:   "typedef","_typedef";
   128: # 67 "./lpsrc/flx_name.ipk"
   129:   "typeid","_typeid";
   130: # 67 "./lpsrc/flx_name.ipk"
   131:   "typename","_typename";
   132: # 67 "./lpsrc/flx_name.ipk"
   133:   "union","_union";
   134: # 67 "./lpsrc/flx_name.ipk"
   135:   "unsigned","_unsigned";
   136: # 67 "./lpsrc/flx_name.ipk"
   137:   "using","_using";
   138: # 67 "./lpsrc/flx_name.ipk"
   139:   "virtual","_virtual";
   140: # 67 "./lpsrc/flx_name.ipk"
   141:   "void","_void";
   142: # 67 "./lpsrc/flx_name.ipk"
   143:   "volatile","_volatile";
   144: # 67 "./lpsrc/flx_name.ipk"
   145:   "wchar_t","_wchar_t";
   146: # 67 "./lpsrc/flx_name.ipk"
   147:   "while","_while";
   148: ]
   149: 
   150: let cid_of_flxid s =
   151:   let n = String.length s in
   152:   let id = Buffer.create (n+10) in
   153:   for i=0 to n - 1 do
   154:     (* from http://www.w3.org/TR/html4/sgml/entities.html *)
   155:     match s.[i] with
   156:     | ' '  -> Buffer.add_string id "__sp_"
   157:     | '!'  -> Buffer.add_string id "__excl_"
   158:     | '"'  -> Buffer.add_string id "__quot_"
   159:     | '#'  -> Buffer.add_string id "__num_"
   160:     | '$'  -> Buffer.add_string id "__dollar_"
   161:     | '%'  -> Buffer.add_string id "__percnt_"
   162:     | '&'  -> Buffer.add_string id "__amp_"
   163:     | '\'' -> Buffer.add_string id "__apos_"
   164:     | '('  -> Buffer.add_string id "__lpar_"
   165:     | ')'  -> Buffer.add_string id "__rpar_"
   166:     | '*'  -> Buffer.add_string id "__ast_"
   167:     | '+'  -> Buffer.add_string id "__plus_"
   168:     | ','  -> Buffer.add_string id "__comma_"
   169:     | '-'  -> Buffer.add_string id "__hyphen_"
   170:     | '.'  -> Buffer.add_string id "__period_"
   171:     | '/'  -> Buffer.add_string id "__sol_"
   172:     | ':'  -> Buffer.add_string id "__colon_"
   173:     | ';'  -> Buffer.add_string id "__semi_"
   174:     | '<'  -> Buffer.add_string id "__lt_"
   175:     | '='  -> Buffer.add_string id "__equals_"
   176:     | '>'  -> Buffer.add_string id "__gt_"
   177:     | '?'  -> Buffer.add_string id "__quest_"
   178:     | '@'  -> Buffer.add_string id "__commat_"
   179:     | '['  -> Buffer.add_string id "__lsqb_"
   180:     | '\\' -> Buffer.add_string id "__bsol_"
   181:     | ']'  -> Buffer.add_string id "__rsqb_"
   182:     | '^'  -> Buffer.add_string id "__caret_"
   183:     (* | '_'  -> Buffer.add_string id "__lowbar_" *)
   184:     | '`'  -> Buffer.add_string id "__grave_"
   185:     | '{'  -> Buffer.add_string id "__lcub_"
   186:     | '|'  -> Buffer.add_string id "__verbar_"
   187:     | '}'  -> Buffer.add_string id "__rcub_"
   188:     | '~'  -> Buffer.add_string id "__tilde_"
   189:     | x    -> Buffer.add_char id x
   190:   done;
   191:   let name = Buffer.contents id in
   192:   try assoc name fixups with Not_found -> name
   193: 
   194: (* basic name mangler *)
   195: let cpp_name bbdfns index =
   196:   let id,parent,sr,entry =
   197:     try Hashtbl.find bbdfns index
   198:     with _ -> failwith ("[cpp_name] Can't find index " ^ si index)
   199:   in
   200:   (match entry with
   201:   | `BBDCL_function _ -> "_f"
   202:   | `BBDCL_callback _ -> "_cf"
   203:   | `BBDCL_procedure _  -> "_p"
   204:   | `BBDCL_regmatch _  -> "_rm"
   205:   | `BBDCL_reglex _  -> "_rl"
   206:   | `BBDCL_var _ -> "_v"
   207:   | `BBDCL_val _ -> "_v"
   208:   | `BBDCL_ref _ -> "_v"
   209:   | `BBDCL_tmp _ -> "_tmp"
   210:   | `BBDCL_class _ -> "_cl"
   211:   | _ -> syserr sr "cpp_name expected func,proc,var,val,class,reglex or regmatch"
   212:   ) ^ si index ^ "_" ^ cid_of_flxid id
   213: 
   214: let cpp_instance_name' syms bbdfns index ts =
   215:   let inst =
   216:     try Hashtbl.find syms.instances (index,ts)
   217:     with Not_found ->
   218:     let id =
   219:       try
   220:         let id,parent,sr,entry = Hashtbl.find bbdfns index in id
   221:       with Not_found ->
   222:       try
   223:         match Hashtbl.find syms.dfns index with
   224:         {id=id} -> id ^ "[unbound]"
   225:       with Not_found ->
   226:       "unknown"
   227:     in
   228:     let has_variables =
   229:       fold_left
   230:       (fun truth t -> truth || var_occurs t)
   231:       false
   232:       ts
   233:     in
   234:     failwith
   235:     (
   236:       "[cpp_instance_name] unable to find instance " ^ id ^
   237:       "<" ^ si index ^ ">[" ^catmap ", " (string_of_btypecode syms.dfns) ts ^ "]"
   238:       ^ (if has_variables then " .. a subscript contains a type variable" else "")
   239:     )
   240:   in
   241:   "_i" ^ si inst ^ cpp_name bbdfns index
   242: 
   243: let is_export syms id =
   244:   let bifaces = syms.bifaces in
   245:   try
   246:     iter
   247:     (function
   248:       | `BIFACE_export_fun (_,_,s)
   249:       | `BIFACE_export_type (_,_,s) ->
   250:         if id = s then raise Not_found
   251:      )
   252:      bifaces;
   253:      false
   254:   with Not_found -> true
   255: 
   256: let cpp_instance_name syms bbdfns index ts =
   257:   let long_name = cpp_instance_name' syms bbdfns index ts in
   258:   if syms.compiler_options.mangle_names then long_name else
   259:   let id,parent,sr,entry =
   260:     try Hashtbl.find bbdfns index
   261:     with _ -> failwith ("[cpp_name] Can't find index " ^ si index)
   262:   in
   263:   let id' = cid_of_flxid id in
   264:   if id = id' then
   265:   begin
   266:     let inst =
   267:       try Hashtbl.find syms.quick_names id
   268:       with Not_found ->
   269:         Hashtbl.add syms.quick_names id (index,ts);
   270:         index,ts
   271:     in
   272:       if (index,ts) <> inst then long_name else
   273:       if is_export syms id then long_name else id
   274:   end
   275:   else long_name
   276: 
   277: let tix syms t =
   278:   let t =
   279:     match t with
   280:     | `BTYP_function (`BTYP_void,cod) -> `BTYP_function (`BTYP_tuple [],cod)
   281:     | x -> x
   282:   in
   283:   try Hashtbl.find syms.registry t
   284:   with Not_found ->
   285:     failwith ("Cannot find type " ^sbt syms.dfns t ^" in registry")
   286: 
   287: let rec cpp_type_classname syms t =
   288:   let tix t = tix syms t in
   289:   let t = fold syms.dfns (lstrip syms.dfns t) in
   290:   try match unfold syms.dfns t with
   291:   | `BTYP_var (i,mt) -> failwith ("[cpp_type_classname] Can't name type variable " ^ si i ^":"^ sbt syms.dfns mt)
   292:   | `BTYP_fix i -> failwith "[cpp_type_classname] Can't name type fixpoint"
   293:   | `BTYP_void -> "void" (* failwith "void doesn't have a classname" *)
   294:   | `BTYP_tuple [] -> "unit"
   295: 
   296:   | `BTYP_pointer t' ->
   297:     "_rt" ^ cpp_type_classname syms t'
   298: 
   299:   | `BTYP_function (_,`BTYP_void) ->
   300:     "_pt" ^ si (tix t)
   301: 
   302:   | `BTYP_function _ ->
   303:     "_ft" ^ si (tix t)
   304: 
   305:   | `BTYP_cfunction _ ->
   306:     "_cft" ^ si (tix t)
   307: 
   308:   | `BTYP_array _ ->
   309:     "_at" ^ si (tix t)
   310: 
   311:   | `BTYP_tuple _ ->
   312:     "_tt" ^ si (tix t)
   313: 
   314:   | `BTYP_record _ ->
   315:     "_art" ^ si (tix t)
   316: 
   317:   | `BTYP_variant _ ->
   318:     "_avt" ^ si (tix t)
   319: 
   320:   | `BTYP_sum _ ->
   321:     "_st" ^ si (tix t)
   322: 
   323:   | `BTYP_unitsum k ->
   324:     "_us" ^ si k
   325: 
   326: 
   327:   | `BTYP_inst (i,ts) ->
   328:     let cal_prefix = function
   329:       | `SYMDEF_struct _  -> "_s"
   330:       | `SYMDEF_union _   -> "_u"
   331:       | `SYMDEF_abs _  -> "_a"
   332:       | `SYMDEF_class -> "_cl"
   333:       | `SYMDEF_newtype _ -> "_abstr_"
   334:       | _ -> "_unk_"
   335:     in
   336:     if ts = [] then
   337:       match
   338:         try
   339:           match Hashtbl.find syms.dfns i with
   340:           { id=id; symdef=symdef } -> Some (id,symdef )
   341:         with Not_found -> None
   342:       with
   343:       | Some (id,`SYMDEF_cstruct _) -> id
   344:       | Some (id,`SYMDEF_cclass _) -> id^"*"
   345:       | Some (_,`SYMDEF_abs (_,`Str "char",_)) -> "char" (* hack .. *)
   346:       | Some (_,`SYMDEF_abs (_,`Str "int",_)) -> "int" (* hack .. *)
   347:       | Some (_,`SYMDEF_abs (_,`Str "short",_)) -> "short" (* hack .. *)
   348:       | Some (_,`SYMDEF_abs (_,`Str "long",_)) -> "long" (* hack .. *)
   349:       | Some (_,`SYMDEF_abs (_,`Str "float",_)) -> "float" (* hack .. *)
   350:       | Some (_,`SYMDEF_abs (_,`Str "double",_)) -> "double" (* hack .. *)
   351:       | Some (_,`SYMDEF_abs (_,`StrTemplate "char",_)) -> "char" (* hack .. *)
   352:       | Some (_,`SYMDEF_abs (_,`StrTemplate "int",_)) -> "int" (* hack .. *)
   353:       | Some (_,`SYMDEF_abs (_,`StrTemplate "short",_)) -> "short" (* hack .. *)
   354:       | Some (_,`SYMDEF_abs (_,`StrTemplate "long",_)) -> "long" (* hack .. *)
   355:       | Some (_,`SYMDEF_abs (_,`StrTemplate "float",_)) -> "float" (* hack .. *)
   356:       | Some (_,`SYMDEF_abs (_,`StrTemplate "double",_)) -> "double" (* hack .. *)
   357:       | Some (_,data)  ->
   358:         let prefix = cal_prefix data in
   359:         prefix ^ si i ^ "t_" ^ si (tix t)
   360:       | None ->
   361:          "_unk_" ^ si i ^ "t_" ^ si (tix t)
   362:     else
   363:       "_poly_" ^ si i ^ "t_" ^ si (tix t)
   364: 
   365:   | _ ->
   366:     failwith
   367:     (
   368:       "[cpp_type_classname] Unexpected " ^
   369:       string_of_btypecode syms.dfns t
   370:     )
   371:   with Not_found ->
   372:     failwith
   373:     (
   374:       "[cpp_type_classname] Expected type "^
   375:       string_of_btypecode syms.dfns t ^
   376:       " to be in registry"
   377:     )
   378: 
   379: 
   380: let cpp_typename syms t =
   381:   match unfold syms.dfns (lstrip syms.dfns t) with
   382:   | `BTYP_function _ -> cpp_type_classname syms t ^ "*"
   383:   | `BTYP_cfunction _ -> cpp_type_classname syms t ^ "*"
   384:   (*
   385:   | `BTYP_inst (i,ts) ->
   386:     begin match
   387:       try
   388:         match Hashtbl.find syms.dfns i with
   389:         { symdef=symdef } -> Some ( symdef )
   390:       with Not_found -> None
   391:     with
   392:     | Some (`SYMDEF_class ) -> cpp_type_classname syms t ^ "*"
   393:     | _ -> cpp_type_classname syms t
   394:     end
   395:   *)
   396:   | _ -> cpp_type_classname syms t
   397: 
   398: let cpp_ltypename syms t =
   399:  cpp_typename syms t ^
   400:  (
   401:    match t with
   402:    | `BTYP_lvalue _ -> "&"
   403:    | _ -> ""
   404:  )
   405: 
   406: 
   407: 
End ocaml section to src/flx_name.ml[1]