5.51. 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:   (* C++ keywords *)
    20:   "true","_true";
    21:   "false","_false";
    22: 
    23:   (* special names in thread frame *)
    24:   "argc","_argc";
    25:   "argv","_argv";
    26:   "flx_stdin","_flx_stdin";
    27:   "flx_stdout","_flx_stdout";
    28:   "flx_stderr","_flx_stderr";
    29:   "gc","_gc";
    30: 
    31:   (*
    32:   "read","_read";
    33:   "write","_write";
    34:   *)
    35: 
    36:   (* C keywords shouldnt occur because they should all be Felix keywords *)
    37:   "while","_while";
    38:   "continue","_continue";
    39:   "break","_break";
    40:   "for","_for";
    41:   "return","_return";
    42: ]
    43: 
    44: let cvt s =
    45:   let n = String.length s in
    46:   let id = Buffer.create (n+10) in
    47:   for i=0 to n - 1 do
    48:     match s.[i] with
    49:     | '\'' -> Buffer.add_string id "__p"
    50:     | '\\' -> Buffer.add_string id "__"
    51:     | x -> Buffer.add_char id x
    52:   done;
    53:   let name = Buffer.contents id in
    54:   try assoc name fixups with Not_found -> name
    55: 
    56: let cid_of_flxid s = cvt s
    57: 
    58: (* mangle a C++ type name into an identifier *)
    59: let mangle_cpp_typename ct =
    60:   let n = String.length ct in
    61:   let buf = Buffer.create (n+20) in
    62:   let tack_ch ch = Buffer.add_char buf ch in
    63:   let tack_str str = Buffer.add_string buf str in
    64:   for i=0 to n - 1 do
    65:     match ct.[i] with
    66:     | '*' -> tack_str "_p"
    67:     | ':'
    68:     | '<'
    69:     | '>'
    70:     | ' '
    71:     | '?'
    72:     | '$'
    73:     | '@'
    74:     | '#'
    75:     | '`'
    76:       -> tack_ch '_'
    77:     | x -> tack_ch x
    78:   done;
    79:   Buffer.contents buf
    80: 
    81: (* basic name mangler *)
    82: let cpp_name bbdfns index =
    83:   let id,parent,sr,entry =
    84:     try Hashtbl.find bbdfns index
    85:     with _ -> failwith ("[cpp_name] Can't find index " ^ si index)
    86:   in
    87:   (match entry with
    88:   | `BBDCL_function _ -> "_f"
    89:   | `BBDCL_callback _ -> "_cf"
    90:   | `BBDCL_procedure _  -> "_p"
    91:   | `BBDCL_regmatch _  -> "_rm"
    92:   | `BBDCL_reglex _  -> "_rl"
    93:   | `BBDCL_var _ -> "_v"
    94:   | `BBDCL_val _ -> "_v"
    95:   | `BBDCL_tmp _ -> "_tmp"
    96:   | `BBDCL_class _ -> "_cl"
    97:   | _ -> syserr sr "cpp_name expected func,proc,var,val,class,reglex or regmatch"
    98:   ) ^ si index ^ "_" ^ cvt id
    99: 
   100: let cpp_instance_name' syms bbdfns index ts =
   101:   let inst =
   102:     try Hashtbl.find syms.instances (index,ts)
   103:     with Not_found ->
   104:     let id =
   105:       try
   106:         let id,parent,sr,entry = Hashtbl.find bbdfns index in id
   107:       with Not_found ->
   108:       try
   109:         match Hashtbl.find syms.dfns index with
   110:         {id=id} -> id ^ "[unbound]"
   111:       with Not_found ->
   112:       "unknown"
   113:     in
   114:     let has_variables =
   115:       fold_left
   116:       (fun truth t -> truth || var_occurs t)
   117:       false
   118:       ts
   119:     in
   120:     failwith
   121:     (
   122:       "[cpp_instance_name] unable to find instance " ^ id ^
   123:       "<" ^ si index ^ ">[" ^catmap ", " (string_of_btypecode syms.dfns) ts ^ "]"
   124:       ^ (if has_variables then " .. a subscript contains a type variable" else "")
   125:     )
   126:   in
   127:   "_i" ^ si inst ^ cpp_name bbdfns index
   128: 
   129: let is_export syms id =
   130:   let bifaces = syms.bifaces in
   131:   try
   132:     iter
   133:     (function
   134:       | `BIFACE_export_fun (_,_,s)
   135:       | `BIFACE_export_type (_,_,s) ->
   136:         if id = s then raise Not_found
   137:      )
   138:      bifaces;
   139:      false
   140:   with Not_found -> true
   141: 
   142: let cpp_instance_name syms bbdfns index ts =
   143:   let long_name = cpp_instance_name' syms bbdfns index ts in
   144:   if syms.compiler_options.mangle_names then long_name else
   145:   let id,parent,sr,entry =
   146:     try Hashtbl.find bbdfns index
   147:     with _ -> failwith ("[cpp_name] Can't find index " ^ si index)
   148:   in
   149:   let id' = cvt id in
   150:   if id = id' then
   151:   begin
   152:     let inst =
   153:       try Hashtbl.find syms.quick_names id
   154:       with Not_found ->
   155:         Hashtbl.add syms.quick_names id (index,ts);
   156:         index,ts
   157:     in
   158:       if (index,ts) <> inst then long_name else
   159:       if is_export syms id then long_name else id
   160:   end
   161:   else long_name
   162: 
   163: let tix syms t =
   164:   try Hashtbl.find syms.registry t
   165:   with Not_found ->
   166:     failwith ("Cannot find type " ^sbt syms.dfns t ^" in registry")
   167: 
   168: let rec cpp_type_classname syms t =
   169:   let tix t = tix syms t in
   170:   let t = fold syms.dfns (lstrip syms.dfns t) in
   171:   try match unfold syms.dfns t with
   172:   | `BTYP_var (i,mt) -> failwith ("[cpp_type_classname] Can't name type variable " ^ si i ^":"^ sbt syms.dfns mt)
   173:   | `BTYP_fix i -> failwith "[cpp_type_classname] Can't name type fixpoint"
   174:   | `BTYP_void -> "void" (* failwith "void doesn't have a classname" *)
   175:   | `BTYP_tuple [] -> "unit"
   176: 
   177:   | `BTYP_pointer t' ->
   178:     "_rt" ^ cpp_type_classname syms t'
   179: 
   180:   | `BTYP_function (_,`BTYP_void) ->
   181:     "_pt" ^ si (tix t)
   182: 
   183:   | `BTYP_function _ ->
   184:     "_ft" ^ si (tix t)
   185: 
   186:   | `BTYP_cfunction _ ->
   187:     "_cft" ^ si (tix t)
   188: 
   189:   | `BTYP_array _ ->
   190:     "_at" ^ si (tix t)
   191: 
   192:   | `BTYP_tuple _ ->
   193:     "_tt" ^ si (tix t)
   194: 
   195:   | `BTYP_record _ ->
   196:     "_art" ^ si (tix t)
   197: 
   198:   | `BTYP_variant _ ->
   199:     "_avt" ^ si (tix t)
   200: 
   201:   | `BTYP_sum _ ->
   202:     "_st" ^ si (tix t)
   203: 
   204:   | `BTYP_unitsum k ->
   205:     "_us" ^ si k
   206: 
   207: 
   208:   | `BTYP_inst (i,ts) ->
   209:     let cal_prefix = function
   210:       | `SYMDEF_struct _  -> "_s"
   211:       | `SYMDEF_union _   -> "_u"
   212:       | `SYMDEF_abs _  -> "_a"
   213:       | `SYMDEF_class -> "_cl"
   214:       | _ -> "_unk_"
   215:     in
   216:     if ts = [] then
   217:       match
   218:         try
   219:           match Hashtbl.find syms.dfns i with
   220:           { id=id; symdef=symdef } -> Some (id,symdef )
   221:         with Not_found -> None
   222:       with
   223:       | Some (id,`SYMDEF_cstruct _) -> id
   224:       | Some (id,`SYMDEF_cclass _) -> id^"*"
   225:       | Some (_,`SYMDEF_abs (_,`Str "char",_)) -> "char" (* hack .. *)
   226:       | Some (_,`SYMDEF_abs (_,`Str "int",_)) -> "int" (* hack .. *)
   227:       | Some (_,`SYMDEF_abs (_,`Str "short",_)) -> "short" (* hack .. *)
   228:       | Some (_,`SYMDEF_abs (_,`Str "long",_)) -> "long" (* hack .. *)
   229:       | Some (_,`SYMDEF_abs (_,`Str "float",_)) -> "float" (* hack .. *)
   230:       | Some (_,`SYMDEF_abs (_,`Str "double",_)) -> "double" (* hack .. *)
   231:       | Some (_,`SYMDEF_abs (_,`StrTemplate "char",_)) -> "char" (* hack .. *)
   232:       | Some (_,`SYMDEF_abs (_,`StrTemplate "int",_)) -> "int" (* hack .. *)
   233:       | Some (_,`SYMDEF_abs (_,`StrTemplate "short",_)) -> "short" (* hack .. *)
   234:       | Some (_,`SYMDEF_abs (_,`StrTemplate "long",_)) -> "long" (* hack .. *)
   235:       | Some (_,`SYMDEF_abs (_,`StrTemplate "float",_)) -> "float" (* hack .. *)
   236:       | Some (_,`SYMDEF_abs (_,`StrTemplate "double",_)) -> "double" (* hack .. *)
   237:       | Some (_,data)  ->
   238:         let prefix = cal_prefix data in
   239:         prefix ^ si i ^ "t_" ^ si (tix t)
   240:       | None ->
   241:          "_unk_" ^ si i ^ "t_" ^ si (tix t)
   242:     else
   243:       "_poly_" ^ si i ^ "t_" ^ si (tix t)
   244: 
   245:   | _ ->
   246:     failwith
   247:     (
   248:       "[cpp_type_classname] Unexpected " ^
   249:       string_of_btypecode syms.dfns t
   250:     )
   251:   with Not_found ->
   252:     failwith
   253:     (
   254:       "[cpp_type_classname] Expected type "^
   255:       string_of_btypecode syms.dfns t ^
   256:       " to be in registry"
   257:     )
   258: 
   259: 
   260: let cpp_typename syms t =
   261:   match unfold syms.dfns (lstrip syms.dfns t) with
   262:   | `BTYP_function _ -> cpp_type_classname syms t ^ "*"
   263:   | `BTYP_cfunction _ -> cpp_type_classname syms t ^ "*"
   264:   (*
   265:   | `BTYP_inst (i,ts) ->
   266:     begin match
   267:       try
   268:         match Hashtbl.find syms.dfns i with
   269:         { symdef=symdef } -> Some ( symdef )
   270:       with Not_found -> None
   271:     with
   272:     | Some (`SYMDEF_class ) -> cpp_type_classname syms t ^ "*"
   273:     | _ -> cpp_type_classname syms t
   274:     end
   275:   *)
   276:   | _ -> cpp_type_classname syms t
   277: 
   278: let cpp_ltypename syms t =
   279:  cpp_typename syms t ^
   280:  (
   281:    match t with
   282:    | `BTYP_lvalue _ -> "&"
   283:    | _ -> ""
   284:  )
   285: 
   286: 
   287: 
End ocaml section to src/flx_name.ml[1]