let global vardefs g =
let pos = get_globalLoc g in
CurrentLoc.set pos;
let dnodes = match g with
| GType _ -> []
| GCompTag(compinfo,pos) when compinfo.cstruct ->
let field fi =
let this =
default_field_modifiers,
ctype ?bitsize:fi.fsize_in_bits fi.ftype,
fi.fname, fi.fsize_in_bits
in
let padding_size =
match fi.fpadding_in_bits with None -> assert false | Some i -> i
in
if padding_size = 0 then [this] else
let padding =
default_field_modifiers,
type_of_padding, unique_name "padding", fi.fpadding_in_bits
in
[this;padding]
in
let fields =
List.fold_right (fun fi acc ->
let repfi = Retype.FieldUnion.repr fi in
if FieldinfoComparable.equal fi repfi then
field fi @ acc
else acc
) compinfo.cfields []
in
let _parent = None in
let ty = TComp(compinfo, empty_size_cache (), []) in
begin try
let parentty = TypeHashtbl.find Retype.type_to_parent_type ty in
let parent = get_struct_name parentty in
[
JCDtag(compinfo.cname,[],Some (parent,[]),fields,[])
]
with Not_found ->
try
ignore(TypeHashtbl.find Norm.generated_union_types ty);
[JCDtag(compinfo.cname,[],None,fields,[])]
with Not_found ->
let id = mkidentifier compinfo.cname pos in
[
JCDtag(compinfo.cname,[],None,fields,[]);
JCDvariant_type(compinfo.cname,[id])
]
end
| GCompTag(compinfo,pos) ->
assert (not compinfo.cstruct);
let field fi =
let ty = pointed_type fi.ftype in
mkidentifier (get_struct_name ty) pos
in
let union_id = mkidentifier compinfo.cname pos in
let union_size = match compinfo.cfields with
| [] -> 0
| fi::_ ->
Pervasives.(+) (the fi.fsize_in_bits) (the fi.fpadding_in_bits)
in
let padding =
if union_size = 0 then [] else
[default_field_modifiers,
type_of_padding, unique_name "padding", Some union_size]
in
let union_tag = JCDtag(compinfo.cname,[],None,padding,[]) in
let fields = List.map field compinfo.cfields in
let rec has_pointer ty =
match unrollType ty with
| TComp(compinfo,_,_) ->
List.exists (fun fi -> has_pointer fi.ftype) compinfo.cfields
| TPtr _ ->
if is_reference_type ty then
has_pointer (pointed_type ty)
else true
| TVoid _
| TInt _
| TFloat _
| TEnum _ -> false
| TArray _ -> assert false
| TFun _ ->
unsupported "Function pointer type %a not allowed"
!Ast_printer.d_type ty
| TNamed _ -> assert false
| TBuiltin_va_list _ -> assert false
in
let discr = has_pointer (TComp(compinfo, empty_size_cache (),[])) in
[JCDunion_type(compinfo.cname,discr,union_id :: fields); union_tag]
| GCompTagDecl _ -> []
| GEnumTag(enuminfo,_pos) ->
assert (not (enuminfo.eitems = []));
let enums =
List.map
(fun {eival = enum} -> value_of_integral_expr enum) enuminfo.eitems
in
let emin =
List.fold_left (fun acc enum ->
if acc < enum then acc else enum) (List.hd enums) enums
in
let min = Num.num_of_string (Int64.to_string emin) in
let emax =
List.fold_left (fun acc enum ->
if acc > enum then acc else enum) (List.hd enums) enums
in
let max = Num.num_of_string (Int64.to_string emax) in
[JCDenum_type(enuminfo.ename,min,max)]
| GEnumTagDecl _ -> []
| GVarDecl(_,v,pos) ->
if List.mem v vardefs
|| (isFunctionType v.vtype &&
(v.vname = name_of_assert
|| v.vname = name_of_free
|| v.vname = name_of_malloc))
then []
else if isFunctionType v.vtype then
let rtyp = match unrollType v.vtype with
| TFun(rt,_,_,_) -> rt
| _ -> assert false
in
let id = mkidentifier v.vname pos in
let kf = Globals.Functions.get v in
let funspec = Kernel_function.get_spec kf in
let params = Globals.Functions.get_params kf in
let formal v = true, ctype v.vtype, unique_name_if_empty v.vname in
let formals = List.map formal params in
[JCDfun(ctype rtyp,id,formals,spec funspec,None)]
else
[JCDvar(ctype v.vtype,v.vname,None)]
| GVar(v,{init=None},_pos) ->
[JCDvar(ctype v.vtype,v.vname,None)]
| GVar(_v,_iinfo,_pos) ->
assert false
| GFun(f,pos) ->
set_curFundec f;
if f.svar.vname = name_of_assert
|| f.svar.vname = name_of_free then []
else
let rty = match unrollType f.svar.vtype with
| TFun(ty,_,_,_) -> ty
| _ -> assert false
in
let formal v = true, ctype v.vtype, v.vname in
let formals = List.map formal f.sformals in
let id = mkidentifier f.svar.vname f.svar.vdecl in
let funspec =
Kernel_function.get_spec (Globals.Functions.get f.svar)
in
begin try
let local v =
mkexpr (JCPEdecl(ctype v.vtype,v.vname,None)) v.vdecl
in
let locals = List.rev (List.rev_map local f.slocals) in
let body = mkexpr (JCPEblock(statement_list f.sbody.bstmts)) pos in
let body = locals @ [body] in
let body = mkexpr (JCPEblock body) pos in
ignore
(reg_pos ~id:f.svar.vname
~name:("Function " ^ f.svar.vname) f.svar.vdecl);
[JCDfun(ctype rty,id,formals,spec funspec,Some body)]
with (Unsupported _ | NotImplemented _) ->
warning "Dropping definition of function %s@." f.svar.vname ;
[JCDfun(ctype rty,id,formals,spec funspec,None)]
end
| GAsm _ ->
unsupported "assembly code"
| GPragma _ -> []
| GText _ -> []
| GAnnot(la,pos) -> annotation false la pos
in
List.map (fun dnode -> mkdecl dnode pos) dnodes