5.31. Cil to Felix

Start ocaml section to src/flx_ciltoflx.mli[1 /1 ]
     1: # 4 "./lpsrc/flx_ciltoflx.ipk"
     2: open Flx_ast
     3: open Flx_cil_cil
     4: val handle_global: global -> statement_t list
     5: 
End ocaml section to src/flx_ciltoflx.mli[1]
Start ocaml section to src/flx_ciltoflx.ml[1 /1 ]
     1: # 10 "./lpsrc/flx_ciltoflx.ipk"
     2: 
     3: (* CIL HANDLING .. MOVE ELSEWHERE *)
     4: open Flx_cil_cabs
     5: open Flx_cil_cil
     6: open Flx_ctypes
     7: open Flxcc_util
     8: open Flx_ast
     9: open List
    10: 
    11: let generated = ("Generated by desugaring",0,0,0,0)
    12: let dfltvs_aux = { raw_type_constraint=`TYP_tuple []; raw_typeclass_reqs=[]}
    13: let dfltvs = [],dfltvs_aux
    14: 
    15: let rpltname s = s
    16: let rplname s = s
    17: 
    18: let litint n = match n with
    19: | Const (CInt64 (i,_,_)) -> Int64.to_int i
    20: | _ -> failwith "Literal integer required for array bound"
    21: 
    22: let rec ctyp_of_ciltyp t : ctype_t =
    23:   let foc t = ctyp_of_ciltyp t in
    24:   let foa (name,t,a) = foc t in
    25:   match t with
    26:   | TVoid a -> `Ct_base "void_t"
    27:   | TInt (ik,a) -> `Ct_base (soi ik)
    28:   | TFloat (fk,a) -> `Ct_base (sof fk)
    29:   | TPtr (TVoid a',a) -> `Ct_base ((cvqual a')^"address")
    30:   | TPtr (TFun _,a) -> failwith "cant do functions yet"
    31:     (*
    32:     let t' = typeSig t in
    33:     begin try
    34:       fst (Hashtbl.find stab.registry t')
    35:     with
    36:       Not_found ->
    37:       let name = stab.stab_module ^"_cft_" ^ si !(stab.counter) in
    38:       incr stab.counter;
    39:       let sr = locUnknown in
    40:       let t = remove_pnames t in
    41:       let si = {tname=name;ttype=t;treferenced=true } in
    42:       let gt =  GType (si,sr) in
    43:       let d = defaultCilPrinter#pGlobal () gt in
    44:       let s = Flx_cil_pretty.sprint 65 d in
    45:       let s = reformatc s in
    46:       Hashtbl.add stab.registry t' (name,s);
    47:       name
    48:     end
    49:     *)
    50: 
    51:   | TPtr (t',a) ->
    52:     let t = foc t' in
    53:     begin match cvqual (attrof t') with
    54:     | "" -> `Ct_ptr t
    55:     | "c" -> `Ct_cptr t
    56:     | "v" -> `Ct_vptr t
    57:     | "cv" -> `Ct_cvptr t
    58:     | _ -> assert false
    59:     end
    60: 
    61:   | TArray (t',Some n,a)->
    62:     let t = foc t' in
    63:     let cv = cvqual (attrof t') in (* unused at the moment *)
    64:     let n = litint n in
    65:     `Ct_array (n,t)
    66: 
    67:   | TArray (t',None,a)->
    68:     let t = foc t' in
    69:     let cv = cvqual (attrof t') in (* unused at the moment *)
    70:     `Ct_varray (t)
    71: 
    72:   | TFun (t',Some ps,false,a) ->
    73:     let ret = foc t' in
    74:     let argts = map foa ps in
    75:     `Ct_fun (ret,argts)
    76: 
    77:   | TFun (t',None,false,a) ->
    78:     let ret = foc t' in
    79:     `Ct_fun (ret,[])
    80: 
    81:   | TFun (t',_,_,a) -> failwith "CANT HANDLE THIS FUN"
    82: 
    83:   | TNamed (ti,a) ->
    84:     let name = ptname ti in
    85:     let name' = rpltname name in
    86:     `Ct_base name'
    87: 
    88:   | TComp (ci,a) ->
    89:     let name = pci ci in
    90:     `Ct_base (rpltname name)
    91: 
    92:   | TEnum (ei,a) -> `Ct_base "int"
    93:   | TBuiltin_va_list a ->
    94:     failwith "Can't handle varargs yet";
    95:     `Ct_base "__builtin_va_list"
    96: 
    97: let rec ftyp_of_ctyp sr t =
    98:   let foc t = ftyp_of_ctyp sr t in
    99:   match t with
   100:   | `Ct_base name -> `AST_name (sr,name,[])
   101:   | `Ct_ptr t -> `AST_name (sr,"ptr", [foc t])
   102:   | `Ct_cptr t -> `AST_name (sr,"cptr", [foc t])
   103:   | `Ct_vptr t -> `AST_name (sr, "vptr", [foc t])
   104:   | `Ct_cvptr t -> `AST_name (sr, "cvptr", [foc t])
   105:   | `Ct_ptm (s,t)
   106:   | `Ct_cptm (s,t)
   107:   | `Ct_vptm (s,t)
   108:   | `Ct_cvptm (s,t)
   109:      -> failwith "can't handle pointer to member yet"
   110: 
   111:   | `Ct_array (n,t) -> `TYP_array (foc t,`TYP_unitsum n)
   112: 
   113:   | `Ct_varray t -> `AST_name (sr,"ptr", [foc t])
   114:   | `Ct_fun (ret,ps) ->
   115:     let ps = map foc ps in
   116:     let ps = match ps with
   117:       | [x] -> x
   118:       | _ -> `TYP_tuple ps
   119:     in
   120:     `TYP_cfunction (ps,foc ret)
   121: 
   122:   | `Ct_vfun (ret,ps) ->
   123:     let ps = map foc ps in
   124:     let ps = rev (`TYP_ellipsis :: rev ps) in
   125:     let ps = `TYP_tuple ps in
   126:     `TYP_cfunction (ps,foc ret)
   127: 
   128: (* name with replacement *)
   129: let flx_name x = match flx_name' x with
   130: | Some x -> Some (rplname x)
   131: | None -> None
   132: 
   133: (* type name with replacement *)
   134: let flx_tname x = match flx_name' x with
   135: | Some x -> rpltname x
   136: | None -> "error!!"
   137: 
   138: let sr_of_loc {file=f; line=l} = f,l,0,l+1,0
   139: 
   140: let handle_global g =
   141:   let loc = get_globalLoc g in
   142:   let sr: range_srcref = sr_of_loc loc in
   143:   let name = flx_tname g in
   144:   print_endline ("Defining name = " ^ name);
   145:   match g with
   146:   | GType (ti,loc) ->
   147:     begin
   148:       match ti with {ttype=ttype} ->
   149:       match  ttype with
   150:       | TComp (ci,_) ->  print_endline "plain";
   151:         []
   152: 
   153:       | TEnum (ei,_) ->
   154:         print_endline "typedef enum";
   155:         []
   156: 
   157:       | TFun (_,_,true,_) ->
   158:         (* HACK: varargs function typedef *)
   159:         print_endline "function type";
   160:         []
   161: 
   162:       | t ->
   163:         if isanont t then begin
   164:           print_endline "Anonymous typedef?"; []
   165:         end else begin
   166:           let typ = ctyp_of_ciltyp  t in
   167:           let typ : typecode_t = ftyp_of_ctyp sr typ in
   168:           let stmt : statement_t = `AST_type_alias (sr,name,dfltvs,typ) in
   169:           [stmt]
   170:         end
   171:     end
   172: 
   173:   | GCompTag (ci,loc) ->
   174:     begin match ci with {
   175:       cname=cname;
   176:       cfields=cfields;
   177:       cstruct=cstruct
   178:     } ->
   179:       print_endline "struct";
   180:     end
   181:     ;
   182:     []
   183: 
   184: 
   185:   | GCompTagDecl (ci,loc) ->
   186:     print_endline "incomplete type";
   187:     []
   188: 
   189:   | GEnumTag (ei,loc) ->
   190:     print_endline "enum tag";
   191:     []
   192: 
   193:   | GEnumTagDecl (ci,loc) ->
   194:     print_endline "enum tag decl";
   195:     []
   196: 
   197:   | GVar (vi,_,loc)
   198:   | GFun ({svar=vi},loc)
   199:   | GVarDecl (vi,loc) ->
   200:     let vname, vtype=
   201:       match vi with {vname=vname; vtype=vtype}->vname,vtype
   202:     in
   203:     if ispublic vname then
   204:     begin match vtype with
   205:     | TFun _ -> print_endline "Function"
   206:     | _ -> print_endline "Variable"
   207:     end
   208:     ;
   209:     []
   210: 
   211:   | GAsm _ -> print_endline "GASM"; []
   212:   | GPragma _ -> print_endline "PRAGMA"; []
   213:   | GText _ -> print_endline "TEXT"; []
   214: 
   215: 
End ocaml section to src/flx_ciltoflx.ml[1]