Make Typ.struct_typ private and add Typ.mk_struct

Reviewed By: cristianoc

Differential Revision: D3791863

fbshipit-source-id: d792aea
master
Josh Berdine 8 years ago committed by Facebook Github Bot 6
parent ad31aeb2a2
commit 30b3881e52

@ -185,7 +185,7 @@ let has_objc_ref_counter tenv hpred =>
switch hpred { switch hpred {
| Hpointsto _ _ (Sizeof typ _ _) => | Hpointsto _ _ (Sizeof typ _ _) =>
switch (Tenv.expand_type tenv typ) { switch (Tenv.expand_type tenv typ) {
| Tstruct {instance_fields} => IList.exists Typ.is_objc_ref_counter_field instance_fields | Tstruct {fields} => IList.exists Typ.is_objc_ref_counter_field fields
| _ => false | _ => false
} }
| _ => false | _ => false

@ -93,28 +93,23 @@ let proc_extract_return_typ tenv pname_java =>
/** Get method that is being overriden by java_pname (if any) **/ /** Get method that is being overriden by java_pname (if any) **/
let get_overriden_method tenv pname_java => { let get_overriden_method tenv pname_java => {
let struct_typ_get_def_method_by_name struct_typ method_name => let struct_typ_get_method_by_name struct_typ method_name =>
IList.find IList.find (fun meth => method_name == Procname.get_method meth) struct_typ.Typ.methods;
(fun def_method => method_name == Procname.get_method def_method) struct_typ.Typ.def_methods; let rec get_overriden_method_in_supers pname_java supers =>
let rec get_overriden_method_in_superclasses pname_java superclasses => switch supers {
switch superclasses { | [superclass, ...supers_tail] =>
| [superclass, ...superclasses_tail] =>
switch (lookup tenv superclass) { switch (lookup tenv superclass) {
| Some struct_typ => | Some struct_typ =>
try ( try (Some (struct_typ_get_method_by_name struct_typ (Procname.java_get_method pname_java))) {
Some (struct_typ_get_def_method_by_name struct_typ (Procname.java_get_method pname_java))
) {
| Not_found => | Not_found =>
get_overriden_method_in_superclasses get_overriden_method_in_supers pname_java (supers_tail @ struct_typ.Typ.supers)
pname_java (superclasses_tail @ struct_typ.Typ.superclasses)
} }
| None => get_overriden_method_in_superclasses pname_java superclasses_tail | None => get_overriden_method_in_supers pname_java supers_tail
} }
| [] => None | [] => None
}; };
switch (proc_extract_declaring_class_typ tenv pname_java) { switch (proc_extract_declaring_class_typ tenv pname_java) {
| Some {Typ.superclasses: superclasses} => | Some {Typ.supers: supers} => get_overriden_method_in_supers pname_java supers
get_overriden_method_in_superclasses pname_java superclasses
| _ => None | _ => None
} }
}; };

@ -284,11 +284,11 @@ type struct_fields = list (Ident.fieldname, t, item_annotation)
/** Type for a structured value. */ /** Type for a structured value. */
and struct_typ = { and struct_typ = {
name: Typename.t, /** name */ name: Typename.t, /** name */
instance_fields: struct_fields, /** non-static fields */ fields: struct_fields, /** non-static fields */
static_fields: struct_fields, /** static fields */ statics: struct_fields, /** static fields */
superclasses: list Typename.t, /** list of superclasses */ supers: list Typename.t, /** list of superclasses */
def_methods: list Procname.t, /** methods defined */ methods: list Procname.t, /** methods defined */
struct_annotations: item_annotation /** annotations */ annots: item_annotation /** annotations */
} }
/** types for sil (structured) expressions */ /** types for sil (structured) expressions */
and t = and t =
@ -309,11 +309,11 @@ and struct_typ_compare struct_typ1 struct_typ2 =>
| (TN_csu (Class Java) _, TN_csu (Class Java) _) => | (TN_csu (Class Java) _, TN_csu (Class Java) _) =>
Typename.compare struct_typ1.name struct_typ2.name Typename.compare struct_typ1.name struct_typ2.name
| _ => | _ =>
let n = fld_typ_ann_list_compare struct_typ1.instance_fields struct_typ2.instance_fields; let n = fld_typ_ann_list_compare struct_typ1.fields struct_typ2.fields;
if (n != 0) { if (n != 0) {
n n
} else { } else {
let n = fld_typ_ann_list_compare struct_typ1.static_fields struct_typ2.static_fields; let n = fld_typ_ann_list_compare struct_typ1.statics struct_typ2.statics;
if (n != 0) { if (n != 0) {
n n
} else { } else {
@ -362,7 +362,7 @@ let struct_typ_equal struct_typ1 struct_typ2 => struct_typ_compare struct_typ1 s
let equal t1 t2 => compare t1 t2 == 0; let equal t1 t2 => compare t1 t2 == 0;
let rec pp_struct_typ pe pp_base f {instance_fields, name} => let rec pp_struct_typ pe pp_base f {fields, name} =>
if false { if false {
/* change false to true to print the details of struct */ /* change false to true to print the details of struct */
F.fprintf F.fprintf
@ -371,7 +371,7 @@ let rec pp_struct_typ pe pp_base f {instance_fields, name} =>
Typename.pp Typename.pp
name name
(pp_seq (fun f (fld, t, _) => F.fprintf f "%a %a" (pp_full pe) t Ident.pp_fieldname fld)) (pp_seq (fun f (fld, t, _) => F.fprintf f "%a %a" (pp_full pe) t Ident.pp_fieldname fld))
instance_fields fields
pp_base pp_base
() ()
} else { } else {
@ -451,6 +451,49 @@ let module Tbl = Hashtbl.Make {
let hash = Hashtbl.hash; let hash = Hashtbl.hash;
}; };
let mk_struct
default::default=?
fields::fields=?
statics::statics=?
methods::methods=?
supers::supers=?
annots::annots=?
name => {
let mk_struct_
name::name
default::
default={
name,
fields: [],
statics: [],
methods: [],
supers: [],
annots: item_annotation_empty
}
fields::fields=default.fields
statics::statics=default.statics
methods::methods=default.methods
supers::supers=default.supers
annots::annots=default.annots
() => {
name,
fields,
statics,
methods,
supers,
annots
};
mk_struct_
name::name
default::?default
fields::?fields
statics::?statics
methods::?methods
supers::?supers
annots::?annots
()
};
let name t => let name t =>
switch t { switch t {
| Tvar name | Tvar name
@ -486,11 +529,11 @@ let array_elem default_opt =>
let rec get_extensible_array_element_typ expand_type::expand_type typ => let rec get_extensible_array_element_typ expand_type::expand_type typ =>
switch (expand_type typ) { switch (expand_type typ) {
| Tarray typ _ => Some typ | Tarray typ _ => Some typ
| Tstruct {instance_fields} => | Tstruct {fields} =>
Option.map_default Option.map_default
(fun (_, fld_typ, _) => get_extensible_array_element_typ expand_type::expand_type fld_typ) (fun (_, fld_typ, _) => get_extensible_array_element_typ expand_type::expand_type fld_typ)
None None
(IList.last instance_fields) (IList.last fields)
| _ => None | _ => None
}; };
@ -503,7 +546,7 @@ let struct_typ_fld expand_type::expand_type default_opt f typ => {
| Tstruct struct_typ => | Tstruct struct_typ =>
try ( try (
(fun (_, y, _) => y) ( (fun (_, y, _) => y) (
IList.find (fun (_f, _, _) => Ident.fieldname_equal _f f) struct_typ.instance_fields IList.find (fun (_f, _, _) => Ident.fieldname_equal _f f) struct_typ.fields
) )
) { ) {
| Not_found => def () | Not_found => def ()
@ -519,8 +562,7 @@ let get_field_type_and_annotation expand_ptr_type::expand_ptr_type fn typ =>
try { try {
let (_, t, a) = let (_, t, a) =
IList.find IList.find
(fun (f, _, _) => Ident.fieldname_equal f fn) (fun (f, _, _) => Ident.fieldname_equal f fn) (struct_typ.fields @ struct_typ.statics);
(struct_typ.instance_fields @ struct_typ.static_fields);
Some (t, a) Some (t, a)
} { } {
| Not_found => None | Not_found => None

@ -137,13 +137,13 @@ type static_length = option IntLit.t;
type struct_fields = list (Ident.fieldname, t, item_annotation) type struct_fields = list (Ident.fieldname, t, item_annotation)
/** Type for a structured value. */ /** Type for a structured value. */
and struct_typ = { and struct_typ = private {
name: Typename.t, /** name */ name: Typename.t, /** name */
instance_fields: struct_fields, /** non-static fields */ fields: struct_fields, /** non-static fields */
static_fields: struct_fields, /** static fields */ statics: struct_fields, /** static fields */
superclasses: list Typename.t, /** list of superclasses */ supers: list Typename.t, /** list of supers */
def_methods: list Procname.t, /** methods defined */ methods: list Procname.t, /** methods defined */
struct_annotations: item_annotation /** annotations */ annots: item_annotation /** annotations */
} }
/** types for sil (structured) expressions */ /** types for sil (structured) expressions */
and t = and t =
@ -209,6 +209,18 @@ let module Map: Map.S with type key = t;
let module Tbl: Hashtbl.S with type key = t; let module Tbl: Hashtbl.S with type key = t;
/** Construct a struct_typ, normalizing field types */
let mk_struct:
default::struct_typ? =>
fields::struct_fields? =>
statics::struct_fields? =>
methods::list Procname.t? =>
supers::list Typename.t? =>
annots::item_annotation? =>
Typename.t =>
struct_typ;
/** The name of a type */ /** The name of a type */
let name: t => option Typename.t; let name: t => option Typename.t;

@ -423,8 +423,8 @@ let typ_get_recursive_flds tenv typ_exp =
| Exp.Sizeof (typ, _, _) -> | Exp.Sizeof (typ, _, _) ->
(match Tenv.expand_type tenv typ with (match Tenv.expand_type tenv typ with
| Typ.Tint _ | Typ.Tvoid | Typ.Tfun _ | Typ.Tptr _ | Typ.Tfloat _ -> [] | Typ.Tint _ | Typ.Tvoid | Typ.Tfun _ | Typ.Tptr _ | Typ.Tfloat _ -> []
| Typ.Tstruct { Typ.instance_fields } -> | Typ.Tstruct { fields } ->
IList.map (fun (x, _, _) -> x) (IList.filter (filter typ) instance_fields) IList.map (fun (x, _, _) -> x) (IList.filter (filter typ) fields)
| Typ.Tarray _ -> [] | Typ.Tarray _ -> []
| Typ.Tvar _ -> assert false) | Typ.Tvar _ -> assert false)
| Exp.Var _ -> [] (* type of |-> not known yet *) | Exp.Var _ -> [] (* type of |-> not known yet *)
@ -1003,11 +1003,11 @@ let cycle_has_weak_or_unretained_or_assign_field tenv cycle =
(* returns items annotation for field fn in struct t *) (* returns items annotation for field fn in struct t *)
let get_item_annotation t fn = let get_item_annotation t fn =
match Tenv.expand_type tenv t with match Tenv.expand_type tenv t with
| Typ.Tstruct { Typ.instance_fields; static_fields } -> | Tstruct { fields; statics } ->
let ia = ref [] in let ia = ref [] in
IList.iter (fun (fn', _, ia') -> IList.iter (fun (fn', _, ia') ->
if Ident.fieldname_equal fn fn' then ia := ia') if Ident.fieldname_equal fn fn' then ia := ia')
(instance_fields @ static_fields); (fields @ statics);
!ia !ia
| _ -> [] in | _ -> [] in
let rec has_weak_or_unretained_or_assign params = let rec has_weak_or_unretained_or_assign params =

@ -67,11 +67,11 @@ end = struct
let rec get_strexp_at_syn_offsets tenv se t syn_offs = let rec get_strexp_at_syn_offsets tenv se t syn_offs =
match se, Tenv.expand_type tenv t, syn_offs with match se, Tenv.expand_type tenv t, syn_offs with
| _, _, [] -> (se, t) | _, _, [] -> (se, t)
| Sil.Estruct (fsel, _), Typ.Tstruct { Typ.instance_fields }, Field (fld, _) :: syn_offs' -> | Sil.Estruct (fsel, _), Tstruct { fields }, Field (fld, _) :: syn_offs' ->
let se' = snd (IList.find (fun (f', _) -> Ident.fieldname_equal f' fld) fsel) in let se' = snd (IList.find (fun (f', _) -> Ident.fieldname_equal f' fld) fsel) in
let t' = (fun (_,y,_) -> y) let t' = (fun (_,y,_) -> y)
(IList.find (fun (f', _, _) -> (IList.find (fun (f', _, _) ->
Ident.fieldname_equal f' fld) instance_fields) in Ident.fieldname_equal f' fld) fields) in
get_strexp_at_syn_offsets tenv se' t' syn_offs' get_strexp_at_syn_offsets tenv se' t' syn_offs'
| Sil.Earray (_, esel, _), Typ.Tarray (t', _), Index ind :: syn_offs' -> | Sil.Earray (_, esel, _), Typ.Tarray (t', _), Index ind :: syn_offs' ->
let se' = snd (IList.find (fun (i', _) -> Exp.equal i' ind) esel) in let se' = snd (IList.find (fun (i', _) -> Exp.equal i' ind) esel) in
@ -87,11 +87,11 @@ end = struct
match se, Tenv.expand_type tenv t, syn_offs with match se, Tenv.expand_type tenv t, syn_offs with
| _, _, [] -> | _, _, [] ->
update se update se
| Sil.Estruct (fsel, inst), Typ.Tstruct { Typ.instance_fields }, Field (fld, _) :: syn_offs' -> | Sil.Estruct (fsel, inst), Tstruct { fields }, Field (fld, _) :: syn_offs' ->
let se' = snd (IList.find (fun (f', _) -> Ident.fieldname_equal f' fld) fsel) in let se' = snd (IList.find (fun (f', _) -> Ident.fieldname_equal f' fld) fsel) in
let t' = (fun (_,y,_) -> y) let t' = (fun (_,y,_) -> y)
(IList.find (fun (f', _, _) -> (IList.find (fun (f', _, _) ->
Ident.fieldname_equal f' fld) instance_fields) in Ident.fieldname_equal f' fld) fields) in
let se_mod = replace_strexp_at_syn_offsets tenv se' t' syn_offs' update in let se_mod = replace_strexp_at_syn_offsets tenv se' t' syn_offs' update in
let fsel' = let fsel' =
IList.map (fun (f'', se'') -> IList.map (fun (f'', se'') ->
@ -151,8 +151,8 @@ end = struct
if pred (path, se, typ) then found := (sigma, hpred, offs') :: !found if pred (path, se, typ) then found := (sigma, hpred, offs') :: !found
else begin else begin
match se, Tenv.expand_type tenv typ with match se, Tenv.expand_type tenv typ with
| Sil.Estruct (fsel, _), Typ.Tstruct { Typ.instance_fields } -> | Sil.Estruct (fsel, _), Tstruct { fields } ->
find_offset_fsel sigma_other hpred root offs fsel instance_fields typ find_offset_fsel sigma_other hpred root offs fsel fields typ
| Sil.Earray (_, esel, _), Typ.Tarray (t, _) -> | Sil.Earray (_, esel, _), Typ.Tarray (t, _) ->
find_offset_esel sigma_other hpred root offs esel t find_offset_esel sigma_other hpred root offs esel t
| _ -> () | _ -> ()

@ -584,11 +584,11 @@ let vpath_find tenv prop _exp : DExp.t option * Typ.t option =
let typo = match texp with let typo = match texp with
| Exp.Sizeof (typ, _, _) -> ( | Exp.Sizeof (typ, _, _) -> (
match Tenv.expand_type tenv typ with match Tenv.expand_type tenv typ with
| Tstruct {instance_fields} -> ( | Tstruct {fields} -> (
try try
let _, t, _ = let _, t, _ =
IList.find (fun (f', _, _) -> Ident.fieldname_equal f' f) IList.find (fun (f', _, _) -> Ident.fieldname_equal f' f)
instance_fields in fields in
Some t Some t
with Not_found -> None with Not_found -> None
) )

@ -504,7 +504,7 @@ let rec create_strexp_of_type tenv struct_init_mode (typ : Typ.t) len inst : Sil
match Tenv.expand_type tenv typ, len with match Tenv.expand_type tenv typ, len with
| (Tint _ | Tfloat _ | Tvoid | Tfun _ | Tptr _), None -> | (Tint _ | Tfloat _ | Tvoid | Tfun _ | Tptr _), None ->
Eexp (init_value (), inst) Eexp (init_value (), inst)
| Tstruct { Typ.instance_fields }, _ -> ( | Tstruct { fields }, _ -> (
match struct_init_mode with match struct_init_mode with
| No_init -> | No_init ->
Estruct ([], inst) Estruct ([], inst)
@ -516,7 +516,7 @@ let rec create_strexp_of_type tenv struct_init_mode (typ : Typ.t) len inst : Sil
((fld, Sil.Eexp (Exp.one, inst)) :: flds, None) ((fld, Sil.Eexp (Exp.one, inst)) :: flds, None)
else else
((fld, create_strexp_of_type tenv struct_init_mode t len inst) :: flds, None) in ((fld, create_strexp_of_type tenv struct_init_mode t len inst) :: flds, None) in
let flds, _ = IList.fold_right f instance_fields ([], len) in let flds, _ = IList.fold_right f fields ([], len) in
Estruct (flds, inst) Estruct (flds, inst)
) )
| Tarray (_, len_opt), None -> | Tarray (_, len_opt), None ->

@ -1477,15 +1477,12 @@ let expand_hpred_pointer tenv calc_index_frame hpred : bool * bool * Sil.hpred =
| _, Sizeof (cnt_typ, len, st) -> | _, Sizeof (cnt_typ, len, st) ->
(* type of struct at adr_base is unknown (typically Tvoid), but (* type of struct at adr_base is unknown (typically Tvoid), but
type of contents is known, so construct struct type for single fld:cnt_typ *) type of contents is known, so construct struct type for single fld:cnt_typ *)
Exp.Sizeof let struct_typ =
(Tstruct Typ.Tstruct
{ instance_fields = [(fld, cnt_typ, Typ.item_annotation_empty)]; (Typ.mk_struct
static_fields = []; ~fields: [(fld, cnt_typ, Typ.item_annotation_empty)]
name = TN_csu (Struct, Mangled.from_string "counterfeit"); (TN_csu (Struct, Mangled.from_string "counterfeit"))) in
superclasses = []; Exp.Sizeof (struct_typ, len, st)
def_methods = [];
struct_annotations = Typ.item_annotation_empty;
}, len, st)
| _ -> | _ ->
(* type of struct at adr_base and of contents are both unknown: give up *) (* type of struct at adr_base and of contents are both unknown: give up *)
raise (Failure "expand_hpred_pointer: Unexpected non-sizeof type in Lfield") in raise (Failure "expand_hpred_pointer: Unexpected non-sizeof type in Lfield") in
@ -1521,8 +1518,8 @@ struct
let is_interface tenv class_name = let is_interface tenv class_name =
match Tenv.lookup tenv class_name with match Tenv.lookup tenv class_name with
| Some ({ name = TN_csu (Class Java, _) } as struct_typ) -> | Some ({ name = TN_csu (Class Java, _) } as struct_typ) ->
(IList.length struct_typ.Typ.instance_fields = 0) && (IList.length struct_typ.fields = 0) &&
(IList.length struct_typ.Typ.def_methods = 0) (IList.length struct_typ.methods = 0)
| _ -> false | _ -> false
let is_root_class class_name = let is_root_class class_name =
@ -1538,8 +1535,8 @@ struct
let rec check cn = let rec check cn =
Typename.equal cn c2 || is_root_class c2 || Typename.equal cn c2 || is_root_class c2 ||
match Tenv.lookup tenv cn with match Tenv.lookup tenv cn with
| Some ({ name = TN_csu (Class _, _); superclasses }) -> | Some ({ name = TN_csu (Class _, _); supers }) ->
IList.exists check superclasses IList.exists check supers
| _ -> false in | _ -> false in
check c1 check c1
@ -1665,8 +1662,8 @@ let cast_exception tenv texp1 texp2 e1 subs =
let get_overrides_of tenv supertype pname = let get_overrides_of tenv supertype pname =
let typ_has_method pname typ = let typ_has_method pname typ =
match Tenv.expand_type tenv typ with match Tenv.expand_type tenv typ with
| Typ.Tstruct { Typ.def_methods } -> | Tstruct { methods } ->
IList.exists (fun m -> Procname.equal pname m) def_methods IList.exists (fun m -> Procname.equal pname m) methods
| _ -> false in | _ -> false in
let gather_overrides tname struct_typ overrides_acc = let gather_overrides tname struct_typ overrides_acc =
let typ = Typ.Tstruct struct_typ in let typ = Typ.Tstruct struct_typ in

@ -98,14 +98,14 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp
Ident.create kind !max_stamp in Ident.create kind !max_stamp in
let res = let res =
match Tenv.expand_type tenv t, off with match Tenv.expand_type tenv t, off with
| Typ.Tstruct _, [] -> | Tstruct _, [] ->
([], Sil.Estruct ([], inst), t) ([], Sil.Estruct ([], inst), t)
| Typ.Tstruct ({ Typ.instance_fields; static_fields } as struct_typ ), | Tstruct ({ fields; statics } as struct_typ ),
(Sil.Off_fld (f, _)):: off' -> (Sil.Off_fld (f, _)):: off' ->
let _, t', _ = let _, t', _ =
try try
IList.find (fun (f', _, _) -> Ident.fieldname_equal f f') IList.find (fun (f', _, _) -> Ident.fieldname_equal f f')
(instance_fields @ static_fields) (fields @ statics)
with Not_found -> with Not_found ->
raise (Exceptions.Bad_footprint __POS__) in raise (Exceptions.Bad_footprint __POS__) in
let atoms', se', res_t' = let atoms', se', res_t' =
@ -114,9 +114,10 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp
let se = Sil.Estruct ([(f, se')], inst) in let se = Sil.Estruct ([(f, se')], inst) in
let replace_typ_of_f (f', t', a') = let replace_typ_of_f (f', t', a') =
if Ident.fieldname_equal f f' then (f, res_t', a') else (f', t', a') in if Ident.fieldname_equal f f' then (f, res_t', a') else (f', t', a') in
let instance_fields' = let fields' =
IList.sort Typ.fld_typ_ann_compare (IList.map replace_typ_of_f instance_fields) in IList.sort Typ.fld_typ_ann_compare (IList.map replace_typ_of_f fields) in
(atoms', se, Typ.Tstruct { struct_typ with Typ.instance_fields = instance_fields'}) (atoms', se,
Typ.Tstruct (Typ.mk_struct ~default:struct_typ ~fields:fields' struct_typ.name))
| Typ.Tstruct _, (Sil.Off_index e):: off' -> | Typ.Tstruct _, (Sil.Off_index e):: off' ->
let atoms', se', res_t' = let atoms', se', res_t' =
create_struct_values create_struct_values
@ -205,12 +206,12 @@ let rec _strexp_extend_values
_strexp_extend_values _strexp_extend_values
pname tenv orig_prop footprint_part kind max_stamp se typ off_new inst pname tenv orig_prop footprint_part kind max_stamp se typ off_new inst
| (Sil.Off_fld (f, _)):: off', Sil.Estruct (fsel, inst'), | (Sil.Off_fld (f, _)):: off', Sil.Estruct (fsel, inst'),
Typ.Tstruct ({ Typ.instance_fields; static_fields } as struct_typ) -> Tstruct ({ fields; statics } as struct_typ) ->
let replace_fv new_v fv = if Ident.fieldname_equal (fst fv) f then (f, new_v) else fv in let replace_fv new_v fv = if Ident.fieldname_equal (fst fv) f then (f, new_v) else fv in
let _, typ', _ = let _, typ', _ =
try try
IList.find (fun (f', _, _) -> Ident.fieldname_equal f f') IList.find (fun (f', _, _) -> Ident.fieldname_equal f f')
(instance_fields @ static_fields) (fields @ statics)
with Not_found -> with Not_found ->
raise (Exceptions.Missing_fld (f, __POS__)) in raise (Exceptions.Missing_fld (f, __POS__)) in
begin begin
@ -223,10 +224,11 @@ let rec _strexp_extend_values
let replace_fse = replace_fv res_se' in let replace_fse = replace_fv res_se' in
let res_fsel' = IList.sort Sil.fld_strexp_compare (IList.map replace_fse fsel) in let res_fsel' = IList.sort Sil.fld_strexp_compare (IList.map replace_fse fsel) in
let replace_fta (f, t, a) = let f', t' = replace_fv res_typ' (f, t) in (f', t', a) in let replace_fta (f, t, a) = let f', t' = replace_fv res_typ' (f, t) in (f', t', a) in
let instance_fields' = let fields' =
IList.sort Typ.fld_typ_ann_compare (IList.map replace_fta instance_fields) in IList.sort Typ.fld_typ_ann_compare (IList.map replace_fta fields) in
let struct_typ = let struct_typ =
Typ.Tstruct { struct_typ with Typ.instance_fields = instance_fields' } in Typ.Tstruct
(Typ.mk_struct ~default:struct_typ ~fields:fields' struct_typ.name) in
(res_atoms', Sil.Estruct (res_fsel', inst'), struct_typ) :: acc in (res_atoms', Sil.Estruct (res_fsel', inst'), struct_typ) :: acc in
IList.fold_left replace [] atoms_se_typ_list' IList.fold_left replace [] atoms_se_typ_list'
with Not_found -> with Not_found ->
@ -235,9 +237,11 @@ let rec _strexp_extend_values
pname tenv orig_prop footprint_part kind max_stamp typ' off' inst in pname tenv orig_prop footprint_part kind max_stamp typ' off' inst in
let res_fsel' = IList.sort Sil.fld_strexp_compare ((f, se'):: fsel) in let res_fsel' = IList.sort Sil.fld_strexp_compare ((f, se'):: fsel) in
let replace_fta (f', t', a') = if Ident.fieldname_equal f' f then (f, res_typ', a') else (f', t', a') in let replace_fta (f', t', a') = if Ident.fieldname_equal f' f then (f, res_typ', a') else (f', t', a') in
let instance_fields' = let fields' =
IList.sort Typ.fld_typ_ann_compare (IList.map replace_fta instance_fields) in IList.sort Typ.fld_typ_ann_compare (IList.map replace_fta fields) in
let struct_typ = Typ.Tstruct { struct_typ with Typ.instance_fields = instance_fields' } in let struct_typ =
Typ.Tstruct
(Typ.mk_struct ~default:struct_typ ~fields:fields' struct_typ.name) in
[(atoms', Sil.Estruct (res_fsel', inst'), struct_typ)] [(atoms', Sil.Estruct (res_fsel', inst'), struct_typ)]
end end
| (Sil.Off_fld (_, _)):: _, _, _ -> | (Sil.Off_fld (_, _)):: _, _, _ ->
@ -1031,11 +1035,11 @@ let type_at_offset tenv texp off =
let rec strip_offset off typ = let rec strip_offset off typ =
match off, Tenv.expand_type tenv typ with match off, Tenv.expand_type tenv typ with
| [], _ -> Some typ | [], _ -> Some typ
| (Sil.Off_fld (f, _)):: off', Typ.Tstruct { Typ.instance_fields } -> | (Sil.Off_fld (f, _)):: off', Tstruct { fields } ->
(try (try
let typ' = let typ' =
(fun (_, y, _) -> y) (fun (_, y, _) -> y)
(IList.find (fun (f', _, _) -> Ident.fieldname_equal f f') instance_fields) in (IList.find (fun (f', _, _) -> Ident.fieldname_equal f f') fields) in
strip_offset off' typ' strip_offset off' typ'
with Not_found -> None) with Not_found -> None)
| (Sil.Off_index _) :: off', Typ.Tarray (typ', _) -> | (Sil.Off_index _) :: off', Typ.Tarray (typ', _) ->

@ -24,9 +24,9 @@ let rec unroll_type tenv typ off =
| Typ.Tvar _, _ -> | Typ.Tvar _, _ ->
let typ' = Tenv.expand_type tenv typ in let typ' = Tenv.expand_type tenv typ in
unroll_type tenv typ' off unroll_type tenv typ' off
| Typ.Tstruct { Typ.instance_fields; static_fields }, Sil.Off_fld (fld, _) -> | Typ.Tstruct { fields; statics }, Sil.Off_fld (fld, _) ->
begin begin
try fldlist_assoc fld (instance_fields @ static_fields) try fldlist_assoc fld (fields @ statics)
with Not_found -> with Not_found ->
L.d_strln ".... Invalid Field Access ...."; L.d_strln ".... Invalid Field Access ....";
L.d_strln ("Fld : " ^ Ident.fieldname_to_string fld); L.d_strln ("Fld : " ^ Ident.fieldname_to_string fld);
@ -158,9 +158,10 @@ let rec apply_offlist
let res_se = Sil.Estruct (IList.map replace_fse fsel, inst') in let res_se = Sil.Estruct (IList.map replace_fse fsel, inst') in
let replace_fta (f, t, a) = let replace_fta (f, t, a) =
if Ident.fieldname_equal fld f then (fld, res_t', a) else (f, t, a) in if Ident.fieldname_equal fld f then (fld, res_t', a) else (f, t, a) in
let instance_fields' = IList.map replace_fta struct_typ.Typ.instance_fields in let fields' = IList.map replace_fta struct_typ.fields in
let res_t = let res_t =
Typ.Tstruct { struct_typ with Typ.instance_fields = instance_fields' } in Typ.Tstruct
(Typ.mk_struct ~default:struct_typ ~fields:fields' struct_typ.name) in
(res_e', res_se, res_t, res_pred_insts_op') (res_e', res_se, res_t, res_pred_insts_op')
with Not_found -> with Not_found ->
pp_error(); pp_error();
@ -506,11 +507,11 @@ let resolve_method tenv class_name proc_name =
let right_proc_name = let right_proc_name =
Procname.replace_class proc_name (Typename.name class_name) in Procname.replace_class proc_name (Typename.name class_name) in
match Tenv.lookup tenv class_name with match Tenv.lookup tenv class_name with
| Some { name = TN_csu (Class _, _); def_methods; superclasses } -> | Some { name = TN_csu (Class _, _); methods; supers } ->
if method_exists right_proc_name def_methods then if method_exists right_proc_name methods then
Some right_proc_name Some right_proc_name
else else
(match superclasses with (match supers with
| super_classname:: _ -> | super_classname:: _ ->
if not (Typename.Set.mem super_classname !visited) if not (Typename.Set.mem super_classname !visited)
then resolve super_classname then resolve super_classname

@ -468,10 +468,10 @@ let texp_star tenv texp1 texp2 =
| _ -> ftal_sub ftal1 ftal2' end in | _ -> ftal_sub ftal1 ftal2' end in
let typ_star t1 t2 = let typ_star t1 t2 =
match Tenv.expand_type tenv t1, Tenv.expand_type tenv t2 with match Tenv.expand_type tenv t1, Tenv.expand_type tenv t2 with
| Typ.Tstruct { instance_fields = instance_fields1; name = TN_csu (csu1, _) }, | Tstruct { fields = fields1; name = TN_csu (csu1, _) },
Typ.Tstruct { instance_fields = instance_fields2; name = TN_csu (csu2, _) } Tstruct { fields = fields2; name = TN_csu (csu2, _) }
when csu1 = csu2 -> when csu1 = csu2 ->
if ftal_sub instance_fields1 instance_fields2 then t2 else t1 if ftal_sub fields1 fields2 then t2 else t1
| _ -> t1 in | _ -> t1 in
match texp1, texp2 with match texp1, texp2 with
| Exp.Sizeof (t1, len1, st1), Exp.Sizeof (t2, _, st2) -> | Exp.Sizeof (t1, len1, st1), Exp.Sizeof (t2, _, st2) ->

@ -355,8 +355,8 @@ let has_taint_annotation fieldname struct_typ =
let fld_has_taint_annot (fname, _, annot) = let fld_has_taint_annot (fname, _, annot) =
Ident.fieldname_equal fieldname fname && Ident.fieldname_equal fieldname fname &&
(Annotations.ia_is_privacy_source annot || Annotations.ia_is_integrity_source annot) in (Annotations.ia_is_privacy_source annot || Annotations.ia_is_integrity_source annot) in
IList.exists fld_has_taint_annot struct_typ.Typ.instance_fields || IList.exists fld_has_taint_annot struct_typ.Typ.fields ||
IList.exists fld_has_taint_annot struct_typ.Typ.static_fields IList.exists fld_has_taint_annot struct_typ.Typ.statics
(* add tainting attributes to a list of paramenters *) (* add tainting attributes to a list of paramenters *)
let get_params_to_taint tainted_param_nums formal_params = let get_params_to_taint tainted_param_nums formal_params =

@ -136,8 +136,8 @@ let is_allocator tenv pname =
let check_attributes check tenv pname = let check_attributes check tenv pname =
let check_class_attributes check tenv = function let check_class_attributes check tenv = function
| Procname.Java java_pname -> | Procname.Java java_pname ->
let check_class_annots { Typ.struct_annotations; } = let check_class_annots { Typ.annots; } =
check struct_annotations in check annots in
begin begin
match Tenv.proc_extract_declaring_class_typ tenv java_pname with match Tenv.proc_extract_declaring_class_typ tenv java_pname with
| Some current_class -> | Some current_class ->

@ -39,7 +39,7 @@ let suppressLint = "android.annotation.SuppressLint"
(** Return the annotations on the declaring class of [pname]. Only works for Java *) (** Return the annotations on the declaring class of [pname]. Only works for Java *)
let get_declaring_class_annotations pname tenv = let get_declaring_class_annotations pname tenv =
match Tenv.proc_extract_declaring_class_typ tenv pname with match Tenv.proc_extract_declaring_class_typ tenv pname with
| Some { Typ.struct_annotations } -> Some struct_annotations | Some { annots } -> Some annots
| None -> None | None -> None
let ia_iter f = let ia_iter f =

@ -222,8 +222,8 @@ let callback_check_write_to_parcel_java
let parcel_constructors tenv typ = let parcel_constructors tenv typ =
match Tenv.expand_ptr_type tenv typ with match Tenv.expand_ptr_type tenv typ with
| Typ.Tptr (Typ.Tstruct { Typ.def_methods }, _) -> | Tptr (Tstruct { methods }, _) ->
IList.filter is_parcel_constructor def_methods IList.filter is_parcel_constructor methods
| _ -> [] in | _ -> [] in
let check r_desc w_desc = let check r_desc w_desc =

@ -45,10 +45,10 @@ let callback_fragment_retains_view_java
let class_typename = let class_typename =
Typename.Java.from_string (Procname.java_get_class_name pname_java) in Typename.Java.from_string (Procname.java_get_class_name pname_java) in
match Tenv.lookup tenv class_typename with match Tenv.lookup tenv class_typename with
| Some ({ instance_fields } as struct_typ) | Some ({ fields } as struct_typ)
when AndroidFramework.is_fragment tenv struct_typ -> when AndroidFramework.is_fragment tenv struct_typ ->
let declared_view_fields = let declared_view_fields =
IList.filter (is_declared_view_typ class_typename) instance_fields in IList.filter (is_declared_view_typ class_typename) fields in
let fields_nullified = PatternMatch.get_fields_nullified proc_desc in let fields_nullified = PatternMatch.get_fields_nullified proc_desc in
(* report if a field is declared by C, but not nulled out in C.onDestroyView *) (* report if a field is declared by C, but not nulled out in C.onDestroyView *)
IList.iter IList.iter

@ -36,13 +36,13 @@ let java_proc_name_with_class_method pn_java class_with_path method_name =
with _ -> false) with _ -> false)
let get_direct_supers tenv = function let get_direct_supers tenv = function
| { Typ.name = TN_csu (Class _, _); superclasses } -> | { Typ.name = TN_csu (Class _, _); supers } ->
IList.map (Tenv.lookup tenv) superclasses IList.map (Tenv.lookup tenv) supers
|> IList.flatten_options |> IList.flatten_options
| _ -> | _ ->
[] []
(** get the superclasses of [typ]. does not include [typ] itself *) (** get the supers of [typ]. does not include [typ] itself *)
let strict_supertype_iter tenv f_typ orig_struct_typ = let strict_supertype_iter tenv f_typ orig_struct_typ =
let rec get_supers_rec struct_typ = let rec get_supers_rec struct_typ =
let direct_supers = get_direct_supers tenv struct_typ in let direct_supers = get_direct_supers tenv struct_typ in
@ -59,7 +59,7 @@ let strict_supertype_exists tenv f_typ orig_struct_typ =
get_supers_rec orig_struct_typ get_supers_rec orig_struct_typ
let is_immediate_subtype this_type super_type_name = let is_immediate_subtype this_type super_type_name =
IList.exists (Typename.equal super_type_name) this_type.Typ.superclasses IList.exists (Typename.equal super_type_name) this_type.Typ.supers
(** return true if [typ0] <: [typ1] *) (** return true if [typ0] <: [typ1] *)
let is_subtype tenv struct_typ0 struct_typ1 = let is_subtype tenv struct_typ0 struct_typ1 =
@ -80,9 +80,9 @@ let get_this_type proc_attributes = match proc_attributes.ProcAttributes.formals
let type_get_direct_supertypes tenv typ = let type_get_direct_supertypes tenv typ =
match Tenv.expand_ptr_type tenv typ with match Tenv.expand_ptr_type tenv typ with
| Typ.Tptr (Tstruct { superclasses }, _) | Tptr (Tstruct { supers }, _)
| Typ.Tstruct { superclasses } -> | Tstruct { supers } ->
superclasses supers
| _ -> | _ ->
[] []
@ -90,12 +90,11 @@ let type_get_class_name = function
| Typ.Tptr (typ, _) -> Typ.name typ | Typ.Tptr (typ, _) -> Typ.name typ
| _ -> None | _ -> None
let type_get_annotation tenv let type_get_annotation tenv (t: Typ.t): Typ.item_annotation option =
(t: Typ.t): Typ.item_annotation option =
match Tenv.expand_ptr_type tenv t with match Tenv.expand_ptr_type tenv t with
| Typ.Tptr (Typ.Tstruct { Typ.struct_annotations }, _) | Tptr (Tstruct { annots }, _)
| Typ.Tstruct { Typ.struct_annotations } -> | Tstruct { annots } ->
Some struct_annotations Some annots
| _ -> None | _ -> None
let type_has_direct_supertype tenv (typ : Typ.t) (class_name : Typename.t) = let type_has_direct_supertype tenv (typ : Typ.t) (class_name : Typename.t) =
@ -111,8 +110,8 @@ let type_has_supertype
else else
begin begin
match Tenv.expand_ptr_type tenv typ with match Tenv.expand_ptr_type tenv typ with
| Typ.Tptr (Typ.Tstruct { Typ.superclasses }, _) | Tptr (Tstruct { supers }, _)
| Typ.Tstruct { Typ.superclasses } -> | Tstruct { supers } ->
let match_supertype cn = let match_supertype cn =
let match_name () = Typename.equal cn class_name in let match_name () = Typename.equal cn class_name in
let has_indirect_supertype () = let has_indirect_supertype () =
@ -121,7 +120,7 @@ let type_has_supertype
has_supertype (Typ.Tstruct supertype) (Typ.Set.add typ visited) has_supertype (Typ.Tstruct supertype) (Typ.Set.add typ visited)
| None -> false in | None -> false in
(match_name () || has_indirect_supertype ()) in (match_name () || has_indirect_supertype ()) in
IList.exists match_supertype superclasses IList.exists match_supertype supers
| _ -> false | _ -> false
end in end in
has_supertype typ Typ.Set.empty has_supertype typ Typ.Set.empty
@ -141,12 +140,12 @@ let get_field_type_name tenv
(typ: Typ.t) (typ: Typ.t)
(fieldname: Ident.fieldname): string option = (fieldname: Ident.fieldname): string option =
match Tenv.expand_ptr_type tenv typ with match Tenv.expand_ptr_type tenv typ with
| Typ.Tstruct { Typ.instance_fields } | Tstruct { fields }
| Typ.Tptr (Typ.Tstruct { Typ.instance_fields }, _) -> ( | Tptr (Tstruct { fields }, _) -> (
try try
let _, ft, _ = IList.find let _, ft, _ = IList.find
(function | (fn, _, _) -> Ident.fieldname_equal fn fieldname) (function | (fn, _, _) -> Ident.fieldname_equal fn fieldname)
instance_fields in fields in
Some (get_type_name ft) Some (get_type_name ft)
with Not_found -> None) with Not_found -> None)
| _ -> None | _ -> None
@ -345,7 +344,7 @@ let proc_iter_overridden_methods f tenv proc_name =
let super_proc_name = let super_proc_name =
Procname.replace_class proc_name (Typename.name super_class_name) in Procname.replace_class proc_name (Typename.name super_class_name) in
match Tenv.lookup tenv super_class_name with match Tenv.lookup tenv super_class_name with
| Some ({ Typ.def_methods }) -> | Some ({ methods }) ->
let is_override pname = let is_override pname =
Procname.equal pname super_proc_name && Procname.equal pname super_proc_name &&
not (Procname.is_constructor pname) in not (Procname.is_constructor pname) in
@ -353,7 +352,7 @@ let proc_iter_overridden_methods f tenv proc_name =
(fun pname -> (fun pname ->
if is_override pname if is_override pname
then f pname) then f pname)
def_methods methods
| _ -> () in | _ -> () in
match proc_name with match proc_name with

@ -128,9 +128,9 @@ let curr_class_equal curr_class1 curr_class2 =
let create_curr_class tenv class_name ck = let create_curr_class tenv class_name ck =
let class_tn_name = Typename.TN_csu (Csu.Class ck, (Mangled.from_string class_name)) in let class_tn_name = Typename.TN_csu (Csu.Class ck, (Mangled.from_string class_name)) in
match Tenv.lookup tenv class_tn_name with match Tenv.lookup tenv class_tn_name with
| Some { Typ.superclasses } -> | Some { supers } ->
(let superclasses_names = IList.map Typename.name superclasses in (let supers_names = IList.map Typename.name supers in
match superclasses_names with match supers_names with
| superclass:: protocols -> | superclass:: protocols ->
ContextCls (class_name, Some superclass, protocols) ContextCls (class_name, Some superclass, protocols)
| [] -> ContextCls (class_name, None, [])) | [] -> ContextCls (class_name, None, []))

@ -21,10 +21,10 @@ let rec get_fields_super_classes tenv super_class =
Printing.log_out " ... Getting fields of superclass '%s'\n" (Typename.to_string super_class); Printing.log_out " ... Getting fields of superclass '%s'\n" (Typename.to_string super_class);
match Tenv.lookup tenv super_class with match Tenv.lookup tenv super_class with
| None -> [] | None -> []
| Some { Typ.instance_fields; superclasses = super_class :: _ } -> | Some { fields; supers = super_class :: _ } ->
let sc_fields = get_fields_super_classes tenv super_class in let sc_fields = get_fields_super_classes tenv super_class in
General_utils.append_no_duplicates_fields instance_fields sc_fields General_utils.append_no_duplicates_fields fields sc_fields
| Some { Typ.instance_fields } -> instance_fields | Some { fields } -> fields
let fields_superclass tenv interface_decl_info ck = let fields_superclass tenv interface_decl_info ck =
match interface_decl_info.Clang_ast_t.otdi_super with match interface_decl_info.Clang_ast_t.otdi_super with
@ -76,18 +76,14 @@ let rec get_fields type_ptr_to_sil_type tenv curr_class decl_list =
(* Add potential extra fields defined only in the implementation of the class *) (* Add potential extra fields defined only in the implementation of the class *)
(* to the info given in the interface. Update the tenv accordingly. *) (* to the info given in the interface. Update the tenv accordingly. *)
let add_missing_fields tenv class_name ck fields = let add_missing_fields tenv class_name ck missing_fields =
let mang_name = Mangled.from_string class_name in let mang_name = Mangled.from_string class_name in
let class_tn_name = Typename.TN_csu (Csu.Class ck, mang_name) in let class_tn_name = Typename.TN_csu (Csu.Class ck, mang_name) in
match Tenv.lookup tenv class_tn_name with match Tenv.lookup tenv class_tn_name with
| Some ({ Typ.instance_fields } as struct_typ) -> | Some ({ fields } as struct_typ) ->
let new_fields = General_utils.append_no_duplicates_fields instance_fields fields in let new_fields = General_utils.append_no_duplicates_fields fields missing_fields in
let class_type_info = { let class_type_info =
struct_typ with Typ.mk_struct ~default:struct_typ ~fields:new_fields ~statics:[] class_tn_name in
instance_fields = new_fields;
static_fields = [];
name = class_tn_name;
} in
Printing.log_out " Updating info for class '%s' in tenv\n" class_name; Printing.log_out " Updating info for class '%s' in tenv\n" class_name;
Tenv.add tenv class_tn_name class_type_info Tenv.add tenv class_tn_name class_type_info
| _ -> () | _ -> ()

@ -525,9 +525,9 @@ struct
let sort_fields_tenv tenv = let sort_fields_tenv tenv =
let sort_fields_struct typname st = let sort_fields_struct typname ({Typ.name; fields} as st) =
let st' = { st with Typ.instance_fields = (sort_fields st.Typ.instance_fields) } in Tenv.add tenv typname
Tenv.add tenv typname st' in (Typ.mk_struct ~default:st ~fields:(sort_fields fields) name) in
Tenv.iter sort_fields_struct tenv Tenv.iter sort_fields_struct tenv
let rec collect_list_tuples l (a, a1, b, c, d) = let rec collect_list_tuples l (a, a1, b, c, d) =

@ -230,7 +230,7 @@ let get_superclass_curr_class_objc context =
let iname = Typename.TN_csu (Csu.Class Csu.Objc, Mangled.from_string cname) in let iname = Typename.TN_csu (Csu.Class Csu.Objc, Mangled.from_string cname) in
Printing.log_out "Checking for superclass = '%s'\n\n%!" (Typename.to_string iname); Printing.log_out "Checking for superclass = '%s'\n\n%!" (Typename.to_string iname);
match Tenv.lookup (CContext.get_tenv context) iname with match Tenv.lookup (CContext.get_tenv context) iname with
| Some { Typ.superclasses = super_name :: _ } -> | Some { supers = super_name :: _ } ->
Typename.name super_name Typename.name super_name
| _ -> | _ ->
Printing.log_err "NOT FOUND superclass = '%s'\n\n%!" (Typename.to_string iname); Printing.log_err "NOT FOUND superclass = '%s'\n\n%!" (Typename.to_string iname);

@ -126,15 +126,7 @@ struct
Printing.log_out "-----> field: '%s'\n" (Ident.fieldname_to_string fn)) fields; Printing.log_out "-----> field: '%s'\n" (Ident.fieldname_to_string fn)) fields;
let mblock = Mangled.from_string block_name in let mblock = Mangled.from_string block_name in
let block_name = Typename.TN_csu (Csu.Class Csu.Objc, mblock) in let block_name = Typename.TN_csu (Csu.Class Csu.Objc, mblock) in
let block_struct_typ = let block_struct_typ = Typ.mk_struct ~fields block_name in
{
Typ.instance_fields = fields;
static_fields = [];
name = block_name;
superclasses = [];
def_methods = [];
struct_annotations = [];
} in
let block_type = Typ.Tstruct block_struct_typ in let block_type = Typ.Tstruct block_struct_typ in
Tenv.add tenv block_name block_struct_typ; Tenv.add tenv block_name block_struct_typ;
let trans_res = let trans_res =

@ -717,10 +717,10 @@ let var_or_zero_in_init_list tenv e typ ~return_zero:return_zero =
(match Tenv.lookup tenv tn with (match Tenv.lookup tenv tn with
| Some struct_typ -> var_or_zero_in_init_list' e (Typ.Tstruct struct_typ) tns | Some struct_typ -> var_or_zero_in_init_list' e (Typ.Tstruct struct_typ) tns
| _ -> [[(e, typ)]] (*This case is an error, shouldn't happen.*)) | _ -> [[(e, typ)]] (*This case is an error, shouldn't happen.*))
| Typ.Tstruct { Typ.instance_fields } as type_struct -> | Typ.Tstruct { fields } as type_struct ->
let lh_exprs = IList.map ( fun (fieldname, _, _) -> let lh_exprs = IList.map ( fun (fieldname, _, _) ->
Exp.Lfield (e, fieldname, type_struct) ) instance_fields in Exp.Lfield (e, fieldname, type_struct) ) fields in
let lh_types = IList.map ( fun (_, fieldtype, _) -> fieldtype) instance_fields in let lh_types = IList.map ( fun (_, fieldtype, _) -> fieldtype) fields in
let exp_types = zip lh_exprs lh_types in let exp_types = zip lh_exprs lh_types in
IList.map (fun (e, t) -> IList.map (fun (e, t) ->
IList.flatten (var_or_zero_in_init_list' e t tns)) exp_types IList.flatten (var_or_zero_in_init_list' e t tns)) exp_types

@ -18,25 +18,11 @@ module L = Logging
let add_predefined_objc_types tenv = let add_predefined_objc_types tenv =
let class_typename = CType_to_sil_type.get_builtin_objc_typename `ObjCClass in let class_typename = CType_to_sil_type.get_builtin_objc_typename `ObjCClass in
let objc_class_type_info = let objc_class_type_info =
{ Typ.mk_struct (TN_csu (Struct, Mangled.from_string CFrontend_config.objc_class)) in
Typ.instance_fields = [];
static_fields = [];
name = TN_csu (Struct, Mangled.from_string CFrontend_config.objc_class);
superclasses = [];
def_methods = [];
struct_annotations = [];
} in
Tenv.add tenv class_typename objc_class_type_info; Tenv.add tenv class_typename objc_class_type_info;
let id_typename = CType_to_sil_type.get_builtin_objc_typename `ObjCId in let id_typename = CType_to_sil_type.get_builtin_objc_typename `ObjCId in
let objc_object_type_info = let objc_object_type_info =
{ Typ.mk_struct (TN_csu (Struct, Mangled.from_string CFrontend_config.objc_object)) in
Typ.instance_fields = [];
static_fields = [];
name = TN_csu (Struct, Mangled.from_string CFrontend_config.objc_object);
superclasses = [];
def_methods = [];
struct_annotations = [];
} in
Tenv.add tenv id_typename objc_object_type_info Tenv.add tenv id_typename objc_object_type_info
(* Whenever new type are added manually to the translation in ast_expressions, *) (* Whenever new type are added manually to the translation in ast_expressions, *)
@ -207,25 +193,18 @@ and get_record_declaration_struct_type tenv decl =
let extra_fields = if CTrans_models.is_objc_memory_model_controlled name then let extra_fields = if CTrans_models.is_objc_memory_model_controlled name then
[Typ.objc_ref_counter_field] [Typ.objc_ref_counter_field]
else [] in else [] in
let struct_annotations = let annots =
if csu = Csu.Class Csu.CPP then Typ.cpp_class_annotation if csu = Csu.Class Csu.CPP then Typ.cpp_class_annotation
else Typ.item_annotation_empty (* No annotations for structs *) in else Typ.item_annotation_empty (* No annotations for structs *) in
if is_complete_definition then ( if is_complete_definition then (
Ast_utils.update_sil_types_map type_ptr (Typ.Tvar sil_typename); Ast_utils.update_sil_types_map type_ptr (Typ.Tvar sil_typename);
let non_static_fields = get_struct_fields tenv decl in let non_statics = get_struct_fields tenv decl in
let non_static_fields = let fields = General_utils.append_no_duplicates_fields non_statics extra_fields in
General_utils.append_no_duplicates_fields non_static_fields extra_fields in let statics = [] in (* Note: We treat static field same as global variables *)
let static_fields = [] in (* Note: We treat static field same as global variables *) let methods = get_class_methods name decl_list in (* C++ methods only *)
let def_methods = get_class_methods name decl_list in (* C++ methods only *) let supers = get_superclass_list_cpp decl in
let superclasses = get_superclass_list_cpp decl in let sil_type =
let sil_type = Typ.Tstruct { Typ.Tstruct (Typ.mk_struct ~fields ~statics ~methods ~supers ~annots sil_typename) in
Typ.instance_fields = non_static_fields;
static_fields;
name = sil_typename;
superclasses;
def_methods;
struct_annotations;
} in
Ast_utils.update_sil_types_map type_ptr sil_type; Ast_utils.update_sil_types_map type_ptr sil_type;
add_struct_to_tenv tenv sil_type; add_struct_to_tenv tenv sil_type;
sil_type sil_type
@ -240,14 +219,7 @@ and get_record_declaration_struct_type tenv decl =
(* Note: we know that this type will be wrapped with pointer type because *) (* Note: we know that this type will be wrapped with pointer type because *)
(* there was no full definition of that type yet. *) (* there was no full definition of that type yet. *)
let tvar_type = Typ.Tvar sil_typename in let tvar_type = Typ.Tvar sil_typename in
let empty_struct_type = Typ.Tstruct { let empty_struct_type = Typ.Tstruct (Typ.mk_struct ~fields:extra_fields sil_typename) in
Typ.instance_fields = extra_fields;
static_fields = [];
name = sil_typename;
superclasses = [];
def_methods = [];
struct_annotations;
} in
Ast_utils.update_sil_types_map type_ptr tvar_type; Ast_utils.update_sil_types_map type_ptr tvar_type;
add_struct_to_tenv tenv empty_struct_type; add_struct_to_tenv tenv empty_struct_type;
tvar_type) tvar_type)

@ -70,24 +70,20 @@ let get_base_class_name_from_category decl =
(* Add potential extra fields defined only in the category *) (* Add potential extra fields defined only in the category *)
(* to the corresponding class. Update the tenv accordingly.*) (* to the corresponding class. Update the tenv accordingly.*)
let process_category type_ptr_to_sil_type tenv curr_class decl_info decl_list = let process_category type_ptr_to_sil_type tenv curr_class decl_info decl_list =
let fields = CField_decl.get_fields type_ptr_to_sil_type tenv curr_class decl_list in let decl_fields = CField_decl.get_fields type_ptr_to_sil_type tenv curr_class decl_list in
let methods = ObjcProperty_decl.get_methods curr_class decl_list in let decl_methods = ObjcProperty_decl.get_methods curr_class decl_list in
let class_name = CContext.get_curr_class_name curr_class in let class_name = CContext.get_curr_class_name curr_class in
let mang_name = Mangled.from_string class_name in let mang_name = Mangled.from_string class_name in
let class_tn_name = Typename.TN_csu (Csu.Class Csu.Objc, mang_name) in let class_tn_name = Typename.TN_csu (Csu.Class Csu.Objc, mang_name) in
let decl_key = `DeclPtr decl_info.Clang_ast_t.di_pointer in let decl_key = `DeclPtr decl_info.Clang_ast_t.di_pointer in
Ast_utils.update_sil_types_map decl_key (Typ.Tvar class_tn_name); Ast_utils.update_sil_types_map decl_key (Typ.Tvar class_tn_name);
(match Tenv.lookup tenv class_tn_name with (match Tenv.lookup tenv class_tn_name with
| Some ({ Typ.instance_fields; def_methods } as struct_typ) -> | Some ({ fields; methods } as struct_typ) ->
let new_fields = General_utils.append_no_duplicates_fields fields instance_fields in let new_fields = General_utils.append_no_duplicates_fields decl_fields fields in
let new_methods = General_utils.append_no_duplicates_methods methods def_methods in let new_methods = General_utils.append_no_duplicates_methods decl_methods methods in
let class_type_info = { let class_type_info =
struct_typ with Typ.mk_struct
instance_fields = new_fields; ~default:struct_typ ~fields:new_fields ~statics:[] ~methods:new_methods class_tn_name in
static_fields = [];
name = class_tn_name;
def_methods = new_methods;
} in
Printing.log_out " Updating info for class '%s' in tenv\n" class_name; Printing.log_out " Updating info for class '%s' in tenv\n" class_name;
Tenv.add tenv class_tn_name class_type_info Tenv.add tenv class_tn_name class_type_info
| _ -> ()); | _ -> ());

@ -79,7 +79,7 @@ let add_class_implementation type_ptr_to_sil_type tenv idi =
(*The superclass is the first element in the list of super classes of structs in the tenv, *) (*The superclass is the first element in the list of super classes of structs in the tenv, *)
(* then come the protocols and categories. *) (* then come the protocols and categories. *)
let get_interface_superclasses super_opt protocols = let get_interface_supers super_opt protocols =
let super_class = let super_class =
match super_opt with match super_opt with
| None -> [] | None -> []
@ -90,13 +90,13 @@ let get_interface_superclasses super_opt protocols =
let super_classes = super_class@protocol_names in let super_classes = super_class@protocol_names in
super_classes super_classes
let create_superclasses_fields type_ptr_to_sil_type tenv curr_class decl_list let create_supers_fields type_ptr_to_sil_type tenv curr_class decl_list
otdi_super otdi_protocols = otdi_super otdi_protocols =
let super = get_super_interface_decl otdi_super in let super = get_super_interface_decl otdi_super in
let protocols = get_protocols otdi_protocols in let protocols = get_protocols otdi_protocols in
let superclasses = get_interface_superclasses super protocols in let supers = get_interface_supers super protocols in
let fields = CField_decl.get_fields type_ptr_to_sil_type tenv curr_class decl_list in let fields = CField_decl.get_fields type_ptr_to_sil_type tenv curr_class decl_list in
superclasses, fields supers, fields
(* Adds pairs (interface name, interface_type_info) to the global environment. *) (* Adds pairs (interface name, interface_type_info) to the global environment. *)
let add_class_to_tenv type_ptr_to_sil_type tenv curr_class decl_info name_info decl_list ocidi = let add_class_to_tenv type_ptr_to_sil_type tenv curr_class decl_info name_info decl_list ocidi =
@ -105,8 +105,8 @@ let add_class_to_tenv type_ptr_to_sil_type tenv curr_class decl_info name_info d
let interface_name = CTypes.mk_classname class_name Csu.Objc in let interface_name = CTypes.mk_classname class_name Csu.Objc in
let decl_key = `DeclPtr decl_info.Clang_ast_t.di_pointer in let decl_key = `DeclPtr decl_info.Clang_ast_t.di_pointer in
Ast_utils.update_sil_types_map decl_key (Typ.Tvar interface_name); Ast_utils.update_sil_types_map decl_key (Typ.Tvar interface_name);
let superclasses, fields = let supers, fields =
create_superclasses_fields type_ptr_to_sil_type tenv curr_class decl_list create_supers_fields type_ptr_to_sil_type tenv curr_class decl_list
ocidi.Clang_ast_t.otdi_super ocidi.Clang_ast_t.otdi_super
ocidi.Clang_ast_t.otdi_protocols in ocidi.Clang_ast_t.otdi_protocols in
let methods = ObjcProperty_decl.get_methods curr_class decl_list in let methods = ObjcProperty_decl.get_methods curr_class decl_list in
@ -115,13 +115,13 @@ let add_class_to_tenv type_ptr_to_sil_type tenv curr_class decl_info name_info d
Printing.log_out "----->SuperClass field: '%s' " (Ident.fieldname_to_string fn); Printing.log_out "----->SuperClass field: '%s' " (Ident.fieldname_to_string fn);
Printing.log_out "type: '%s'\n" (Typ.to_string ft)) fields_sc; Printing.log_out "type: '%s'\n" (Typ.to_string ft)) fields_sc;
(*In case we found categories, or partial definition of this class earlier and they are already in the tenv *) (*In case we found categories, or partial definition of this class earlier and they are already in the tenv *)
let fields, (superclasses : Typename.t list), methods = let fields, (supers : Typename.t list), methods =
match Tenv.lookup tenv interface_name with match Tenv.lookup tenv interface_name with
| Some ({ Typ.instance_fields; superclasses; def_methods }) -> | Some ({ fields; supers; methods }) ->
General_utils.append_no_duplicates_fields fields instance_fields, General_utils.append_no_duplicates_fields fields fields,
General_utils.append_no_duplicates_csu superclasses superclasses, General_utils.append_no_duplicates_csu supers supers,
General_utils.append_no_duplicates_methods methods def_methods General_utils.append_no_duplicates_methods methods methods
| _ -> fields, superclasses, methods in | _ -> fields, supers, methods in
let fields = General_utils.append_no_duplicates_fields fields fields_sc in let fields = General_utils.append_no_duplicates_fields fields fields_sc in
(* We add the special hidden counter_field for implementing reference counting *) (* We add the special hidden counter_field for implementing reference counting *)
let modelled_fields = Typ.objc_ref_counter_field :: CField_decl.modelled_field name_info in let modelled_fields = Typ.objc_ref_counter_field :: CField_decl.modelled_field name_info in
@ -129,14 +129,9 @@ let add_class_to_tenv type_ptr_to_sil_type tenv curr_class decl_info name_info d
Printing.log_out "Class %s field:\n" class_name; Printing.log_out "Class %s field:\n" class_name;
IList.iter (fun (fn, _, _) -> IList.iter (fun (fn, _, _) ->
Printing.log_out "-----> field: '%s'\n" (Ident.fieldname_to_string fn)) all_fields; Printing.log_out "-----> field: '%s'\n" (Ident.fieldname_to_string fn)) all_fields;
let interface_type_info = Typ.{ let interface_type_info =
instance_fields = all_fields; Typ.mk_struct ~fields: all_fields ~supers ~methods ~annots:Typ.objc_class_annotation
static_fields = []; interface_name in
name = interface_name;
superclasses;
def_methods = methods;
struct_annotations = objc_class_annotation;
} in
Tenv.add tenv interface_name interface_type_info; Tenv.add tenv interface_name interface_type_info;
Printing.log_out Printing.log_out
" >>>Verifying that Typename '%s' is in tenv\n" (Typename.to_string interface_name); " >>>Verifying that Typename '%s' is in tenv\n" (Typename.to_string interface_name);
@ -146,15 +141,15 @@ let add_class_to_tenv type_ptr_to_sil_type tenv curr_class decl_info name_info d
Typ.Tvar interface_name Typ.Tvar interface_name
let add_missing_methods tenv class_name ck decl_info decl_list curr_class = let add_missing_methods tenv class_name ck decl_info decl_list curr_class =
let methods = ObjcProperty_decl.get_methods curr_class decl_list in let decl_methods = ObjcProperty_decl.get_methods curr_class decl_list in
let class_tn_name = Typename.TN_csu (Csu.Class ck, (Mangled.from_string class_name)) in let class_tn_name = Typename.TN_csu (Csu.Class ck, (Mangled.from_string class_name)) in
let decl_key = `DeclPtr decl_info.Clang_ast_t.di_pointer in let decl_key = `DeclPtr decl_info.Clang_ast_t.di_pointer in
Ast_utils.update_sil_types_map decl_key (Typ.Tvar class_tn_name); Ast_utils.update_sil_types_map decl_key (Typ.Tvar class_tn_name);
begin begin
match Tenv.lookup tenv class_tn_name with match Tenv.lookup tenv class_tn_name with
| Some ({ static_fields = []; name = TN_csu (Class _, _); def_methods; } as struct_typ) -> | Some ({ statics = []; name = TN_csu (Class _, _); methods; } as struct_typ) ->
let methods = General_utils.append_no_duplicates_methods def_methods methods in let methods = General_utils.append_no_duplicates_methods methods decl_methods in
let struct_typ' = { struct_typ with Typ.def_methods = methods; } in let struct_typ' = Typ.mk_struct ~default:struct_typ ~methods struct_typ.name in
Tenv.add tenv class_tn_name struct_typ' Tenv.add tenv class_tn_name struct_typ'
| _ -> () | _ -> ()
end; end;

@ -32,15 +32,8 @@ let protocol_decl type_ptr_to_sil_type tenv decl =
let protocol_name = Typename.TN_csu (Csu.Protocol, mang_name) in let protocol_name = Typename.TN_csu (Csu.Protocol, mang_name) in
let decl_key = `DeclPtr decl_info.Clang_ast_t.di_pointer in let decl_key = `DeclPtr decl_info.Clang_ast_t.di_pointer in
Ast_utils.update_sil_types_map decl_key (Typ.Tvar protocol_name); Ast_utils.update_sil_types_map decl_key (Typ.Tvar protocol_name);
let def_methods = ObjcProperty_decl.get_methods curr_class decl_list in let methods = ObjcProperty_decl.get_methods curr_class decl_list in
let protocol_type_info = Typ.{ let protocol_type_info = Typ.mk_struct ~methods protocol_name in
instance_fields = [];
static_fields = [];
name = protocol_name;
superclasses = [];
def_methods;
struct_annotations = [];
} in
Tenv.add tenv protocol_name protocol_type_info; Tenv.add tenv protocol_name protocol_type_info;
add_protocol_super type_ptr_to_sil_type tenv obj_c_protocol_decl_info; add_protocol_super type_ptr_to_sil_type tenv obj_c_protocol_decl_info;
Typ.Tvar protocol_name Typ.Tvar protocol_name

@ -41,13 +41,13 @@ let print_tenv tenv =
| Typename.TN_csu (Csu.Class _, _) | Typename.TN_csu (Csu.Protocol, _) -> | Typename.TN_csu (Csu.Class _, _) | Typename.TN_csu (Csu.Protocol, _) ->
print_endline ( print_endline (
(Typename.to_string typname) ^ " " ^ (Typename.to_string typname) ^ " " ^
(Typ.item_annotation_to_string struct_t.struct_annotations) ^ "\n" ^ (Typ.item_annotation_to_string struct_t.annots) ^ "\n" ^
"---> superclass and protocols " ^ (IList.to_string (fun tn -> "---> superclass and protocols " ^ (IList.to_string (fun tn ->
"\t" ^ (Typename.to_string tn) ^ "\n") struct_t.superclasses) ^ "\t" ^ (Typename.to_string tn) ^ "\n") struct_t.supers) ^
"---> methods " ^ "---> methods " ^
(IList.to_string (fun x ->"\t" ^ (Procname.to_string x) ^ "\n") struct_t.def_methods) (IList.to_string (fun x ->"\t" ^ (Procname.to_string x) ^ "\n") struct_t.methods)
^ " " ^ ^ " " ^
"\t---> fields " ^ (IList.to_string field_to_string struct_t.instance_fields) ^ "\n") "\t---> fields " ^ (IList.to_string field_to_string struct_t.fields) ^ "\n")
| _ -> () | _ -> ()
) tenv ) tenv
@ -62,7 +62,7 @@ let print_tenv_struct_unions tenv =
| Typ.Tvar tname -> "tvar"^(Typename.to_string tname) | Typ.Tvar tname -> "tvar"^(Typename.to_string tname)
| Typ.Tstruct _ | _ -> | Typ.Tstruct _ | _ ->
"\t struct "^(Ident.fieldname_to_string fieldname)^" "^ "\t struct "^(Ident.fieldname_to_string fieldname)^" "^
(Typ.to_string typ)^"\n") struct_t.instance_fields (Typ.to_string typ)^"\n") struct_t.fields
) )
) )
| _ -> () | _ -> ()

@ -260,7 +260,7 @@ let check_constructor_initialization tenv
Option.map (Tenv.expand_ptr_type tenv) Option.map (Tenv.expand_ptr_type tenv)
(PatternMatch.get_this_type (Cfg.Procdesc.get_attributes curr_pdesc)) (PatternMatch.get_this_type (Cfg.Procdesc.get_attributes curr_pdesc))
with with
| Some (Tptr (Tstruct { instance_fields; name } as ts, _)) -> | Some (Tptr (Tstruct { fields; name } as ts, _)) ->
let do_field (fn, ft, _) = let do_field (fn, ft, _) =
let annotated_with f = match get_field_annotation tenv fn ts with let annotated_with f = match get_field_annotation tenv fn ts with
| None -> false | None -> false
@ -331,7 +331,7 @@ let check_constructor_initialization tenv
curr_pname; curr_pname;
end in end in
IList.iter do_field instance_fields IList.iter do_field fields
| _ -> () | _ -> ()
end end

@ -87,7 +87,7 @@ let is_android_lib_class class_name =
a list of method names [lifecycle_procs_strs], get the appropriate typ and procnames *) a list of method names [lifecycle_procs_strs], get the appropriate typ and procnames *)
let get_lifecycle_for_framework_typ_opt tenv lifecycle_typ lifecycle_proc_strs = let get_lifecycle_for_framework_typ_opt tenv lifecycle_typ lifecycle_proc_strs =
match Tenv.lookup tenv (Typename.TN_csu (Csu.Class Csu.Java, lifecycle_typ)) with match Tenv.lookup tenv (Typename.TN_csu (Csu.Class Csu.Java, lifecycle_typ)) with
| Some ({ name = TN_csu (Class _, _); def_methods } as lifecycle_typ) -> | Some ({ name = TN_csu (Class _, _); methods } as lifecycle_typ) ->
(* TODO (t4645631): collect the procedures for which is_java is returning false *) (* TODO (t4645631): collect the procedures for which is_java is returning false *)
let lookup_proc lifecycle_proc = let lookup_proc lifecycle_proc =
IList.find (fun decl_proc -> IList.find (fun decl_proc ->
@ -96,7 +96,7 @@ let get_lifecycle_for_framework_typ_opt tenv lifecycle_typ lifecycle_proc_strs =
lifecycle_proc = Procname.java_get_method decl_proc_java lifecycle_proc = Procname.java_get_method decl_proc_java
| _ -> | _ ->
false false
) def_methods in ) methods in
(* convert each of the framework lifecycle proc strings to a lifecycle method procname *) (* convert each of the framework lifecycle proc strings to a lifecycle method procname *)
let lifecycle_procs = let lifecycle_procs =
IList.fold_left (fun lifecycle_procs lifecycle_proc_str -> IList.fold_left (fun lifecycle_procs lifecycle_proc_str ->

@ -96,13 +96,13 @@ let rec inhabit_typ tenv typ cfg env =
* we are already inhabiting one of their argument types *) * we are already inhabiting one of their argument types *)
let get_all_suitable_constructors typ = let get_all_suitable_constructors typ =
match Tenv.expand_type tenv typ with match Tenv.expand_type tenv typ with
| Typ.Tstruct { name = TN_csu (Class _, _); def_methods } -> | Typ.Tstruct { name = TN_csu (Class _, _); methods } ->
let is_suitable_constructor p = let is_suitable_constructor p =
let try_get_non_receiver_formals p = let try_get_non_receiver_formals p =
get_non_receiver_formals (formals_from_name cfg p) in get_non_receiver_formals (formals_from_name cfg p) in
Procname.is_constructor p && IList.for_all (fun (_, typ) -> Procname.is_constructor p && IList.for_all (fun (_, typ) ->
not (TypSet.mem typ env.cur_inhabiting)) (try_get_non_receiver_formals p) in not (TypSet.mem typ env.cur_inhabiting)) (try_get_non_receiver_formals p) in
IList.filter (fun p -> is_suitable_constructor p) def_methods IList.filter (fun p -> is_suitable_constructor p) methods
| _ -> [] in | _ -> [] in
let (env, typ_class_name) = match get_all_suitable_constructors typ with let (env, typ_class_name) = match get_all_suitable_constructors typ with
| constructor :: _ -> | constructor :: _ ->

@ -108,12 +108,12 @@ let retrieve_fieldname fieldname =
let get_field_name program static tenv cn fs = let get_field_name program static tenv cn fs =
match Tenv.expand_type tenv (JTransType.get_class_type_no_pointer program tenv cn) with match Tenv.expand_type tenv (JTransType.get_class_type_no_pointer program tenv cn) with
| Typ.Tstruct { Typ.instance_fields; static_fields; name = TN_csu (Class _, _) } -> | Tstruct { fields; statics; name = TN_csu (Class _, _) } ->
let fieldname, _, _ = let fieldname, _, _ =
try try
IList.find IList.find
(fun (fieldname, _, _) -> retrieve_fieldname fieldname = JBasics.fs_name fs) (fun (fieldname, _, _) -> retrieve_fieldname fieldname = JBasics.fs_name fs)
(if static then static_fields else instance_fields) (if static then statics else fields)
with Not_found -> with Not_found ->
(* TODO: understand why fields cannot be found here *) (* TODO: understand why fields cannot be found here *)
JUtils.log "cannot find %s.%s@." (JBasics.cn_name cn) (JBasics.fs_name fs); JUtils.log "cannot find %s.%s@." (JBasics.cn_name cn) (JBasics.fs_name fs);

@ -217,12 +217,12 @@ let create_sil_class_field cn cf =
(** Collect static field if static is true, otherwise non-static ones. *) (** Collect static field if static is true, otherwise non-static ones. *)
let collect_class_field cn cf (static_fields, nonstatic_fields) = let collect_class_field cn cf (statics, nonstatics) =
let field = create_sil_class_field cn cf in let field = create_sil_class_field cn cf in
if Javalib.is_static_field (Javalib.ClassField cf) then if Javalib.is_static_field (Javalib.ClassField cf) then
(field :: static_fields, nonstatic_fields) (field :: statics, nonstatics)
else else
(static_fields, field :: nonstatic_fields) (statics, field :: nonstatics)
(** Collect an interface field. *) (** Collect an interface field. *)
@ -234,17 +234,6 @@ let collect_interface_field cn inf l =
(field_name, field_type, annotation) :: l (field_name, field_type, annotation) :: l
let dummy_type cn =
Typ.Tstruct {
Typ.instance_fields = [];
static_fields = [];
name = Typename.Java.from_string (JBasics.cn_name cn);
superclasses = [];
def_methods = [];
struct_annotations = Typ.item_annotation_empty;
}
let collect_models_class_fields classpath_field_map cn cf fields = let collect_models_class_fields classpath_field_map cn cf fields =
let static, nonstatic = fields in let static, nonstatic = fields in
let field_name, field_type, annotation = create_sil_class_field cn cf in let field_name, field_type, annotation = create_sil_class_field cn cf in
@ -265,12 +254,12 @@ let collect_models_class_fields classpath_field_map cn cf fields =
let add_model_fields program classpath_fields cn = let add_model_fields program classpath_fields cn =
let static_fields, nonstatic_fields = classpath_fields in let statics, nonstatics = classpath_fields in
let classpath_field_map = let classpath_field_map =
let collect_fields map = let collect_fields map =
IList.fold_left IList.fold_left
(fun map (fn, ft, _) -> Ident.FieldMap.add fn ft map) map in (fun map (fn, ft, _) -> Ident.FieldMap.add fn ft map) map in
collect_fields (collect_fields Ident.FieldMap.empty static_fields) nonstatic_fields in collect_fields (collect_fields Ident.FieldMap.empty statics) nonstatics in
try try
match JBasics.ClassMap.find cn (JClasspath.get_models program) with match JBasics.ClassMap.find cn (JClasspath.get_models program) with
| Javalib.JClass _ as jclass -> | Javalib.JClass _ as jclass ->
@ -286,10 +275,10 @@ let add_model_fields program classpath_fields cn =
let rec get_all_fields program tenv cn = let rec get_all_fields program tenv cn =
let extract_class_fields classname = let extract_class_fields classname =
match get_class_type_no_pointer program tenv classname with match get_class_type_no_pointer program tenv classname with
| Typ.Tstruct { Typ.instance_fields; static_fields } -> (static_fields, instance_fields) | Typ.Tstruct { fields; statics } -> (statics, fields)
| Typ.Tvar name -> ( | Typ.Tvar name -> (
match Tenv.lookup tenv name with match Tenv.lookup tenv name with
| Some { instance_fields; static_fields } -> (static_fields, instance_fields) | Some { fields; statics } -> (statics, fields)
| None -> assert false | None -> assert false
) )
| _ -> assert false in | _ -> assert false in
@ -311,20 +300,21 @@ let rec get_all_fields program tenv cn =
and create_sil_type program tenv cn = and create_sil_type program tenv cn =
match JClasspath.lookup_node cn program with match JClasspath.lookup_node cn program with
| None -> dummy_type cn | None ->
Typ.Tstruct (Typ.mk_struct (Typename.Java.from_string (JBasics.cn_name cn)))
| Some node -> | Some node ->
let create_super_list interface_names = let create_super_list interface_names =
IList.iter (fun cn -> ignore (get_class_type_no_pointer program tenv cn)) interface_names; IList.iter (fun cn -> ignore (get_class_type_no_pointer program tenv cn)) interface_names;
IList.map typename_of_classname interface_names in IList.map typename_of_classname interface_names in
let superclasses, instance_fields, static_fields, struct_annotations = let supers, fields, statics, annots =
match node with match node with
| Javalib.JInterface jinterface -> | Javalib.JInterface jinterface ->
let static_fields, _ = get_all_fields program tenv cn in let statics, _ = get_all_fields program tenv cn in
let sil_interface_list = create_super_list jinterface.Javalib.i_interfaces in let sil_interface_list = create_super_list jinterface.Javalib.i_interfaces in
let item_annotation = JAnnotation.translate_item jinterface.Javalib.i_annotations in let item_annotation = JAnnotation.translate_item jinterface.Javalib.i_annotations in
(sil_interface_list, [], static_fields, item_annotation) (sil_interface_list, [], statics, item_annotation)
| Javalib.JClass jclass -> | Javalib.JClass jclass ->
let static_fields, nonstatic_fields = let statics, nonstatics =
let classpath_static, classpath_nonstatic = get_all_fields program tenv cn in let classpath_static, classpath_nonstatic = get_all_fields program tenv cn in
add_model_fields program (classpath_static, classpath_nonstatic) cn in add_model_fields program (classpath_static, classpath_nonstatic) cn in
let item_annotation = JAnnotation.translate_item jclass.Javalib.c_annotations in let item_annotation = JAnnotation.translate_item jclass.Javalib.c_annotations in
@ -339,16 +329,11 @@ and create_sil_type program tenv cn =
| Typ.Tstruct { name } -> name | Typ.Tstruct { name } -> name
| _ -> assert false in | _ -> assert false in
super_classname :: interface_list in super_classname :: interface_list in
(super_classname_list, nonstatic_fields, static_fields, item_annotation) in (super_classname_list, nonstatics, statics, item_annotation) in
let def_methods = IList.map (fun j -> Procname.Java j) (get_class_procnames cn node) in let methods = IList.map (fun j -> Procname.Java j) (get_class_procnames cn node) in
Typ.Tstruct { Typ.Tstruct
Typ.instance_fields; (Typ.mk_struct ~fields ~statics ~methods ~supers ~annots
static_fields; (Typename.Java.from_string (JBasics.cn_name cn)))
name = Typename.Java.from_string (JBasics.cn_name cn);
superclasses;
def_methods;
struct_annotations;
}
and get_class_type_no_pointer program tenv cn = and get_class_type_no_pointer program tenv cn =
let named_type = typename_of_classname cn in let named_type = typename_of_classname cn in

Loading…
Cancel
Save