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: