pghs975uc
/
infer_clone
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Extract the kind of data structure, Class Struct or Union, into it own module

Browse Source 
Summary:
public
Move the representation of data-structure into it own module, so that it can be used by modules `Sil` depends from like `Procname`.

Reviewed By: jberdine

Differential Revision: D2772791

fb-gh-sync-id: cda4e3a
master
jrm 9 years ago committed by facebook-github-bot-5
parent bf9dc57a9b
commit 4143d4eb2d
36 changed files with 259 additions and 186 deletions
Show Stats Download Patch File Download Diff File

3
infer/src/backend/autounit.ml
Unescape View File

@ -420,7 +420,8 @@ let pp_texp_for_malloc fmt =
| Sil.Tptr (t, pk) -> | Sil.Tptr (t, pk) ->
Sil.Tptr (handle_arr_size t, pk) Sil.Tptr (handle_arr_size t, pk)
| Sil.Tstruct (ftal, sftal, csu, nameo, supers, def_mthds, iann) -> | Sil.Tstruct (ftal, sftal, csu, nameo, supers, def_mthds, iann) ->
Sil.Tstruct (IList.map (fun (f, t, a) -> (f, handle_arr_size t, a)) ftal, sftal, csu, nameo, supers, def_mthds, iann) Sil.Tstruct (IList.map (fun (f, t, a) ->
(f, handle_arr_size t, a)) ftal, sftal, csu, nameo, supers, def_mthds, iann)
| Sil.Tarray (t, e) -> | Sil.Tarray (t, e) ->
Sil.Tarray (handle_arr_size t, e) in Sil.Tarray (handle_arr_size t, e) in
function function

42
infer/src/backend/csu.ml
Unescape View File

@ -0,0 +1,42 @@
(*
* Copyright (c) 2015 - present Facebook, Inc.
* All rights reserved.
*
* This source code is licensed under the BSD style license found in the
* LICENSE file in the root directory of this source tree. An additional grant
* of patent rights can be found in the PATENTS file in the same directory.
*)
open Utils
(** Internal representation of data structure for Java, Objective-C and C++ classes,
C-style structs struct and union,
And Objective C protocol *)
type t =
| Class
| Struct
| Union
| Protocol
let name = function
| Class -> "class"
| Struct -> "struct"
| Union -> "union"
| Protocol -> "protocol"
let compare dstruct1 dstruct2 =
match dstruct1, dstruct2 with
| Class, Class -> 0
| Class, _ -> -1
| _, Class -> 1
| Struct, Struct -> 0
| Struct, _ -> -1
| _, Struct -> 1
| Union, Union -> 0
| Union, _ -> -1
| _, Union -> 1
| Protocol, Protocol -> 0
let equal tn1 tn2 =
compare tn1 tn2 = 0

24
infer/src/backend/csu.mli
Unescape View File

@ -0,0 +1,24 @@
(*
* Copyright (c) 2015 - present Facebook, Inc.
* All rights reserved.
*
* This source code is licensed under the BSD style license found in the
* LICENSE file in the root directory of this source tree. An additional grant
* of patent rights can be found in the PATENTS file in the same directory.
*)
(** Internal representation of data structure for Java, Objective-C and C++ classes,
C-style structs struct and union,
And Objective C protocol *)
type t =
| Class
| Struct
| Union
| Protocol
val name : t -> string
val compare : t -> t -> int
val equal : t -> t -> bool

2
infer/src/backend/localise.ml
Unescape View File

@ -597,7 +597,7 @@ let desc_leak hpred_type_opt value_str_opt resource_opt resource_action_opt loc
s, " to ", " on " in s, " to ", " on " in
let typ_str = let typ_str =
match hpred_type_opt with match hpred_type_opt with
| Some (Sil.Sizeof (Sil.Tstruct (_, _, Sil.Class, Some classname, _, _, _), _)) | Some (Sil.Sizeof (Sil.Tstruct (_, _, Csu.Class, Some classname, _, _, _), _))
when !Config.curr_language = Config.Java -> when !Config.curr_language = Config.Java ->
" of type " ^ Mangled.to_string classname ^ " " " of type " ^ Mangled.to_string classname ^ " "
| _ -> " " in | _ -> " " in

15
infer/src/backend/prop.ml
Unescape View File

@ -596,16 +596,23 @@ let sym_eval abs e =
(* progress: convert inner +I to +A *) (* progress: convert inner +I to +A *)
let e2' = Sil.BinOp (Sil.PlusA, e12, e2) in let e2' = Sil.BinOp (Sil.PlusA, e12, e2) in
eval (Sil.BinOp (Sil.PlusPI, e11, e2')) eval (Sil.BinOp (Sil.PlusPI, e11, e2'))
| Sil.BinOp (Sil.PlusA, (Sil.Sizeof (Sil.Tstruct (ftal, sftal, csu, name_opt, supers, def_mthds, iann), st) as e1), e2) -> (* pattern for extensible structs | Sil.BinOp
given a struct declatead as struct s { ... t arr[n] ... }, allocation pattern malloc(sizeof(struct s) + k * siezof(t)) (Sil.PlusA,
turn it into struct s { ... t arr[n + k] ... } *) (Sil.Sizeof
(Sil.Tstruct (ftal, sftal, csu, name_opt, supers, def_mthds, iann), st) as e1),
e2) ->
(* pattern for extensible structs given a struct declatead as struct s { ... t arr[n] ... },
allocation pattern malloc(sizeof(struct s) + k * siezof(t)) turn it into
struct s { ... t arr[n + k] ... } *)
let e1' = eval e1 in let e1' = eval e1 in
let e2' = eval e2 in let e2' = eval e2 in
(match IList.rev ftal, e2' with (match IList.rev ftal, e2' with
(fname, Sil.Tarray(typ, size), _):: ltfa, Sil.BinOp(Sil.Mult, num_elem, Sil.Sizeof (texp, st)) when ftal != [] && Sil.typ_equal typ texp -> (fname, Sil.Tarray(typ, size), _):: ltfa, Sil.BinOp(Sil.Mult, num_elem, Sil.Sizeof (texp, st)) when ftal != [] && Sil.typ_equal typ texp ->
let size' = Sil.BinOp(Sil.PlusA, size, num_elem) in let size' = Sil.BinOp(Sil.PlusA, size, num_elem) in
let ltfa' = (fname, Sil.Tarray(typ, size'), Sil.item_annotation_empty) :: ltfa in let ltfa' = (fname, Sil.Tarray(typ, size'), Sil.item_annotation_empty) :: ltfa in
Sil.Sizeof(Sil.Tstruct (IList.rev ltfa', sftal, csu, name_opt, supers, def_mthds, iann), st) Sil.Sizeof
(Sil.Tstruct
(IList.rev ltfa', sftal, csu, name_opt, supers, def_mthds, iann), st)
| _ -> Sil.BinOp(Sil.PlusA, e1', e2')) | _ -> Sil.BinOp(Sil.PlusA, e1', e2'))
| Sil.BinOp (Sil.PlusA as oplus, e1, e2) | Sil.BinOp (Sil.PlusA as oplus, e1, e2)
| Sil.BinOp (Sil.PlusPI as oplus, e1, e2) -> | Sil.BinOp (Sil.PlusPI as oplus, e1, e2) ->

31
infer/src/backend/prover.ml
Unescape View File

@ -1415,7 +1415,11 @@ let expand_hpred_pointer calc_index_frame hpred : bool * bool * Sil.hpred =
| _, Sil.Tstruct _ -> (* the struct type of fld is known *) | _, Sil.Tstruct _ -> (* the struct type of fld is known *)
Sil.Sizeof (typ_fld, Sil.Subtype.exact) Sil.Sizeof (typ_fld, Sil.Subtype.exact)
| Sil.Sizeof (_t, st), _ -> (* the struct type of fld is not known -- typically Tvoid *) | Sil.Sizeof (_t, st), _ -> (* the struct type of fld is not known -- typically Tvoid *)
Sil.Sizeof (Sil.Tstruct ([(fld, _t, Sil.item_annotation_empty)], [], Sil.Struct, None, [], [], Sil.item_annotation_empty), st) (* None as we don't know the stuct name *) Sil.Sizeof
(Sil.Tstruct
([(fld, _t, Sil.item_annotation_empty)],
[], Csu.Struct, None, [], [], Sil.item_annotation_empty), st)
(* None as we don't know the stuct name *)
| _ -> raise (Failure "expand_hpred_pointer: Unexpected non-sizeof type in Lfield") in | _ -> raise (Failure "expand_hpred_pointer: Unexpected non-sizeof type in Lfield") in
let hpred' = Sil.Hpointsto (e, Sil.Estruct ([(fld, se)], Sil.inst_none), t') in let hpred' = Sil.Hpointsto (e, Sil.Estruct ([(fld, se)], Sil.inst_none), t') in
expand true true hpred' expand true true hpred'
@ -1443,8 +1447,8 @@ let serializable_type = Mangled.from_string "java.io.Serializable"
let cloneable_type = Mangled.from_string "java.lang.Cloneable" let cloneable_type = Mangled.from_string "java.lang.Cloneable"
let is_interface tenv c = let is_interface tenv c =
match Sil.tenv_lookup tenv (Sil.TN_csu (Sil.Class, c)) with match Sil.tenv_lookup tenv (Sil.TN_csu (Csu.Class, c)) with
| Some (Sil.Tstruct (fields, sfields, Sil.Class, Some c1', supers1, methods, iann)) -> | Some (Sil.Tstruct (fields, sfields, Csu.Class, Some c1', supers1, methods, iann)) ->
(IList.length fields = 0) && (IList.length methods = 0) (IList.length fields = 0) && (IList.length methods = 0)
| _ -> false | _ -> false
@ -1452,11 +1456,11 @@ let is_interface tenv c =
let check_subclass_tenv tenv c1 c2 = let check_subclass_tenv tenv c1 c2 =
let rec check (_, c) = let rec check (_, c) =
Mangled.equal c c2 || (Mangled.equal c2 object_type) || Mangled.equal c c2 || (Mangled.equal c2 object_type) ||
match Sil.tenv_lookup tenv (Sil.TN_csu (Sil.Class, c)) with match Sil.tenv_lookup tenv (Sil.TN_csu (Csu.Class, c)) with
| Some (Sil.Tstruct (_, _, Sil.Class, Some c1', supers1, _, _)) -> | Some (Sil.Tstruct (_, _, Csu.Class, Some c1', supers1, _, _)) ->
IList.exists check supers1 IList.exists check supers1
| _ -> false in | _ -> false in
(check (Sil.Class, c1)) (check (Csu.Class, c1))
let check_subclass tenv c1 c2 = let check_subclass tenv c1 c2 =
let f = check_subclass_tenv tenv in let f = check_subclass_tenv tenv in
@ -1474,7 +1478,8 @@ let check_subtype_basic_type t1 t2 =
(** check if t1 is a subtype of t2 *) (** check if t1 is a subtype of t2 *)
let rec check_subtype tenv t1 t2 = let rec check_subtype tenv t1 t2 =
match t1, t2 with match t1, t2 with
| Sil.Tstruct (_, _, Sil.Class, Some c1, _, _, _), Sil.Tstruct (_, _, Sil.Class, Some c2, _, _, _) -> | Sil.Tstruct (_, _, Csu.Class, Some c1, _, _, _),
Sil.Tstruct (_, _, Csu.Class, Some c2, _, _, _) ->
(check_subclass tenv c1 c2) (check_subclass tenv c1 c2)
| Sil.Tarray (dom_type1, _), Sil.Tarray (dom_type2, _) -> | Sil.Tarray (dom_type1, _), Sil.Tarray (dom_type2, _) ->
@ -1483,14 +1488,15 @@ let rec check_subtype tenv t1 t2 =
| Sil.Tptr (dom_type1, _), Sil.Tptr (dom_type2, _) -> | Sil.Tptr (dom_type1, _), Sil.Tptr (dom_type2, _) ->
check_subtype tenv dom_type1 dom_type2 check_subtype tenv dom_type1 dom_type2
| Sil.Tarray _, Sil.Tstruct (_, _, Sil.Class, Some c2, _, _, _) -> | Sil.Tarray _, Sil.Tstruct (_, _, Csu.Class, Some c2, _, _, _) ->
(Mangled.equal c2 serializable_type) || (Mangled.equal c2 cloneable_type) || (Mangled.equal c2 object_type) (Mangled.equal c2 serializable_type) || (Mangled.equal c2 cloneable_type) || (Mangled.equal c2 object_type)
| _ -> (check_subtype_basic_type t1 t2) | _ -> (check_subtype_basic_type t1 t2)
let rec case_analysis_type tenv (t1, st1) (t2, st2) = let rec case_analysis_type tenv (t1, st1) (t2, st2) =
match t1, t2 with match t1, t2 with
| Sil.Tstruct (_, _, Sil.Class, Some c1, _, _, _), Sil.Tstruct (_, _, Sil.Class, Some c2, _, _, _) -> | Sil.Tstruct (_, _, Csu.Class, Some c1, _, _, _),
Sil.Tstruct (_, _, Csu.Class, Some c2, _, _, _) ->
(Sil.Subtype.case_analysis (c1, st1) (c2, st2) (check_subclass tenv) (is_interface tenv)) (Sil.Subtype.case_analysis (c1, st1) (c2, st2) (check_subclass tenv) (is_interface tenv))
| Sil.Tarray (dom_type1, _), Sil.Tarray (dom_type2, _) -> | Sil.Tarray (dom_type1, _), Sil.Tarray (dom_type2, _) ->
@ -1499,7 +1505,7 @@ let rec case_analysis_type tenv (t1, st1) (t2, st2) =
| Sil.Tptr (dom_type1, _), Sil.Tptr (dom_type2, _) -> | Sil.Tptr (dom_type1, _), Sil.Tptr (dom_type2, _) ->
(case_analysis_type tenv (dom_type1, st1) (dom_type2, st2)) (case_analysis_type tenv (dom_type1, st1) (dom_type2, st2))
| Sil.Tstruct (_, _, Sil.Class, Some c1, _, _, _), Sil.Tarray _ -> | Sil.Tstruct (_, _, Csu.Class, Some c1, _, _, _), Sil.Tarray _ ->
if ((Mangled.equal c1 serializable_type) || (Mangled.equal c1 cloneable_type) || (Mangled.equal c1 object_type)) && if ((Mangled.equal c1 serializable_type) || (Mangled.equal c1 cloneable_type) || (Mangled.equal c1 object_type)) &&
(st1 <> Sil.Subtype.exact) then (Some st1, None) (st1 <> Sil.Subtype.exact) then (Some st1, None)
else (None, Some st1) else (None, Some st1)
@ -1845,7 +1851,8 @@ and sigma_imply tenv calc_index_frame calc_missing subs prop1 sigma2 : (subst2 *
match !Config.curr_language with match !Config.curr_language with
| Config.C_CPP -> Sil.Sizeof (Sil.Tarray (Sil.Tint Sil.IChar, size), Sil.Subtype.exact) | Config.C_CPP -> Sil.Sizeof (Sil.Tarray (Sil.Tint Sil.IChar, size), Sil.Subtype.exact)
| Config.Java -> | Config.Java ->
let object_type = Sil.TN_csu (Sil.Class, Mangled.from_string "java.lang.String") in let object_type =
Sil.TN_csu (Csu.Class, Mangled.from_string "java.lang.String") in
let typ = match Sil.tenv_lookup tenv object_type with let typ = match Sil.tenv_lookup tenv object_type with
| Some typ -> typ | Some typ -> typ
| None -> assert false in | None -> assert false in
@ -1856,7 +1863,7 @@ and sigma_imply tenv calc_index_frame calc_missing subs prop1 sigma2 : (subst2 *
let sexp = (* TODO: add appropriate fields *) let sexp = (* TODO: add appropriate fields *)
Sil.Estruct ([(Ident.create_fieldname (Mangled.from_string "java.lang.Class.name") 0, Sil.Eexp ((Sil.Const (Sil.Cstr s), Sil.Inone)))], Sil.inst_none) in Sil.Estruct ([(Ident.create_fieldname (Mangled.from_string "java.lang.Class.name") 0, Sil.Eexp ((Sil.Const (Sil.Cstr s), Sil.Inone)))], Sil.inst_none) in
let class_texp = let class_texp =
let class_type = Sil.TN_csu (Sil.Class, Mangled.from_string "java.lang.Class") in let class_type = Sil.TN_csu (Csu.Class, Mangled.from_string "java.lang.Class") in
let typ = match Sil.tenv_lookup tenv class_type with let typ = match Sil.tenv_lookup tenv class_type with
| Some typ -> typ | Some typ -> typ
| None -> assert false in | None -> assert false in

13
infer/src/backend/rearrange.ml
Unescape View File

@ -104,7 +104,8 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp
match t, off with match t, off with
| Sil.Tstruct (ftal, sftal, _, _, _, _, _),[] -> | Sil.Tstruct (ftal, sftal, _, _, _, _, _),[] ->
([], Sil.Estruct ([], inst), t) ([], Sil.Estruct ([], inst), t)
| Sil.Tstruct (ftal, sftal, csu, nameo, supers, def_mthds, iann), (Sil.Off_fld (f, _)):: off' -> | Sil.Tstruct (ftal, sftal, csu, nameo, supers, def_mthds, iann),
(Sil.Off_fld (f, _)):: off' ->
let _, t', _ = let _, t', _ =
try IList.find (fun (f', _, _) -> Ident.fieldname_equal f f') ftal try IList.find (fun (f', _, _) -> Ident.fieldname_equal f f') ftal
with Not_found -> raise (Exceptions.Bad_footprint (try assert false with Assert_failure x -> x)) in with Not_found -> raise (Exceptions.Bad_footprint (try assert false with Assert_failure x -> x)) in
@ -196,7 +197,8 @@ let rec _strexp_extend_values
let off_new = Sil.Off_index(Sil.exp_zero):: off in let off_new = Sil.Off_index(Sil.exp_zero):: off in
_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.Tstruct (ftal, sftal, csu, nameo, supers, def_mthds, iann) -> | (Sil.Off_fld (f, _)):: off', Sil.Estruct (fsel, inst'),
Sil.Tstruct (ftal, sftal, csu, nameo, supers, def_mthds, iann) ->
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 (fun (x, y, z) -> y) (IList.find (fun (f', t', a') -> Ident.fieldname_equal f f') ftal) try (fun (x, y, z) -> y) (IList.find (fun (f', t', a') -> Ident.fieldname_equal f f') ftal)
@ -212,7 +214,9 @@ let rec _strexp_extend_values
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 res_ftl' = IList.sort Sil.fld_typ_ann_compare (IList.map replace_fta ftal) in let res_ftl' = IList.sort Sil.fld_typ_ann_compare (IList.map replace_fta ftal) in
(res_atoms', Sil.Estruct (res_fsel', inst'), Sil.Tstruct (res_ftl', sftal, csu, nameo, supers, def_mthds, iann)) :: acc in let struct_typ =
Sil.Tstruct (res_ftl', sftal, csu, nameo, supers, def_mthds, iann) 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 ->
let atoms', se', res_typ' = let atoms', se', res_typ' =
@ -221,7 +225,8 @@ let rec _strexp_extend_values
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 res_ftl' = IList.sort Sil.fld_typ_ann_compare (IList.map replace_fta ftal) in let res_ftl' = IList.sort Sil.fld_typ_ann_compare (IList.map replace_fta ftal) in
[(atoms', Sil.Estruct (res_fsel', inst'), Sil.Tstruct (res_ftl', sftal, csu, nameo, supers, def_mthds, iann))] let struct_typ = Sil.Tstruct (res_ftl', sftal, csu, nameo, supers, def_mthds, iann) in
[(atoms', Sil.Estruct (res_fsel', inst'), struct_typ)]
end end
| (Sil.Off_fld (f, _)):: off', _, _ -> | (Sil.Off_fld (f, _)):: off', _, _ ->
raise (Exceptions.Bad_footprint (try assert false with Assert_failure x -> x)) raise (Exceptions.Bad_footprint (try assert false with Assert_failure x -> x))

68
infer/src/backend/sil.ml
Unescape View File

@ -88,18 +88,11 @@ let get_sentinel_func_attribute_value attr_list =
| FA_sentinel (sentinel, null_pos) -> Some (sentinel, null_pos) | FA_sentinel (sentinel, null_pos) -> Some (sentinel, null_pos)
with Not_found -> None with Not_found -> None
(** Class, struct, union, (Obj C) protocol *)
type csu =
| Class
| Struct
| Union
| Protocol
(** Named types. *) (** Named types. *)
type typename = type typename =
| TN_typedef of Mangled.t | TN_typedef of Mangled.t
| TN_enum of Mangled.t | TN_enum of Mangled.t
| TN_csu of csu * Mangled.t | TN_csu of Csu.t * Mangled.t
(** Kind of global variables *) (** Kind of global variables *)
type pvar_kind = type pvar_kind =
@ -145,7 +138,8 @@ type binop =
| LAnd (** logical and. Does not always evaluate both operands. *) | LAnd (** logical and. Does not always evaluate both operands. *)
| LOr (** logical or. Does not always evaluate both operands. *) | LOr (** logical or. Does not always evaluate both operands. *)
| PtrFld (** field offset via pointer to field: takes the address of a csu and a Cptr_to_fld constant to form an Lfield expression (see prop.ml) *) | PtrFld (** field offset via pointer to field: takes the address of a
Csu.t and a Cptr_to_fld constant to form an Lfield expression (see prop.ml) *)
(** Kinds of integers *) (** Kinds of integers *)
type ikind = type ikind =
@ -648,7 +642,8 @@ and const =
| Cattribute of attribute (** attribute used in disequalities to annotate a value *) | Cattribute of attribute (** attribute used in disequalities to annotate a value *)
| Cexn of exp (** exception *) | Cexn of exp (** exception *)
| Cclass of Ident.name (** class constant *) | Cclass of Ident.name (** class constant *)
| Cptr_to_fld of Ident.fieldname * typ (** pointer to field constant, and type of the surrounding csu type *) | Cptr_to_fld of Ident.fieldname * typ (** pointer to field constant,
and type of the surrounding Csu.t type *)
| Ctuple of exp list (** tuple of values *) | Ctuple of exp list (** tuple of values *)
and struct_fields = (Ident.fieldname * typ * item_annotation) list and struct_fields = (Ident.fieldname * typ * item_annotation) list
@ -661,9 +656,10 @@ and typ =
| Tvoid (** void type *) | Tvoid (** void type *)
| Tfun of bool (** function type with noreturn attribute *) | Tfun of bool (** function type with noreturn attribute *)
| Tptr of typ * ptr_kind (** pointer type *) | Tptr of typ * ptr_kind (** pointer type *)
| Tstruct of struct_fields * struct_fields * csu * Mangled.t option * (csu * Mangled.t) list * Procname.t list * item_annotation (** structure type with class/struct/union flag and name and list of superclasses *) | Tstruct of struct_fields * struct_fields * Csu.t * Mangled.t option *
(** Structure type with nonstatic and static fields, class/struct/union flag, name, list of superclasses, (Csu.t * Mangled.t) list * Procname.t list * item_annotation
methods defined, and annotations. (** Structure type with nonstatic and static fields, class/struct/union flag, name,
list of superclasses, methods defined, and annotations.
The fld - typ pairs are always sorted. This means that we don't support programs that exploit specific layouts The fld - typ pairs are always sorted. This means that we don't support programs that exploit specific layouts
of C structs. *) of C structs. *)
| Tarray of typ * exp (** array type with fixed size *) | Tarray of typ * exp (** array type with fixed size *)
@ -1206,18 +1202,6 @@ let fkind_compare k1 k2 = match k1, k2 with
| _, FDouble -> 1 | _, FDouble -> 1
| FLongDouble, FLongDouble -> 0 | FLongDouble, FLongDouble -> 0
let csu_compare csu1 csu2 = match csu1, csu2 with
| Class, Class -> 0
| Class, _ -> -1
| _, Class -> 1
| Struct, Struct -> 0
| Struct, _ -> -1
| _, Struct -> 1
| Union, Union -> 0
| Union, _ -> -1
| _, Union -> 1
| Protocol, Protocol -> 0
let typename_compare tn1 tn2 = match tn1, tn2 with let typename_compare tn1 tn2 = match tn1, tn2 with
| TN_typedef n1, TN_typedef n2 -> Mangled.compare n1 n2 | TN_typedef n1, TN_typedef n2 -> Mangled.compare n1 n2
| TN_typedef _, _ -> - 1 | TN_typedef _, _ -> - 1
@ -1226,17 +1210,9 @@ let typename_compare tn1 tn2 = match tn1, tn2 with
| TN_enum _, _ -> -1 | TN_enum _, _ -> -1
| _, TN_enum _ -> 1 | _, TN_enum _ -> 1
| TN_csu (csu1, n1), TN_csu (csu2, n2) -> | TN_csu (csu1, n1), TN_csu (csu2, n2) ->
let n = csu_compare csu1 csu2 in let n = Csu.compare csu1 csu2 in
if n <> 0 then n else Mangled.compare n1 n2
let csu_name_compare tn1 tn2 = match tn1, tn2 with
| (csu1, n1), (csu2, n2) ->
let n = csu_compare csu1 csu2 in
if n <> 0 then n else Mangled.compare n1 n2 if n <> 0 then n else Mangled.compare n1 n2
let csu_name_equal tn1 tn2 =
csu_name_compare tn1 tn2 = 0
let typename_equal tn1 tn2 = let typename_equal tn1 tn2 =
typename_compare tn1 tn2 = 0 typename_compare tn1 tn2 = 0
@ -1321,10 +1297,11 @@ and typ_compare t1 t2 =
if n <> 0 then n else ptr_kind_compare pk1 pk2 if n <> 0 then n else ptr_kind_compare pk1 pk2
| Tptr _, _ -> - 1 | Tptr _, _ -> - 1
| _, Tptr _ -> 1 | _, Tptr _ -> 1
| Tstruct (ntal1, sntal1, csu1, nameo1, _, _, _), Tstruct (ntal2, sntal2, csu2, nameo2, _, _, _) -> | Tstruct (ntal1, sntal1, csu1, nameo1, _, _, _),
Tstruct (ntal2, sntal2, csu2, nameo2, _, _, _) ->
let n = fld_typ_ann_list_compare ntal1 ntal2 in let n = fld_typ_ann_list_compare ntal1 ntal2 in
if n <> 0 then n else let n = fld_typ_ann_list_compare sntal1 sntal2 in if n <> 0 then n else let n = fld_typ_ann_list_compare sntal1 sntal2 in
if n <> 0 then n else let n = csu_compare csu1 csu2 in if n <> 0 then n else let n = Csu.compare csu1 csu2 in
if n <> 0 then n else cname_opt_compare nameo1 nameo2 if n <> 0 then n else cname_opt_compare nameo1 nameo2
| Tstruct _, _ -> - 1 | Tstruct _, _ -> - 1
| _, Tstruct _ -> 1 | _, Tstruct _ -> 1
@ -1817,16 +1794,10 @@ let fkind_to_string = function
| FDouble -> "double" | FDouble -> "double"
| FLongDouble -> "long double" | FLongDouble -> "long double"
let csu_name = function
| Class -> "class"
| Struct -> "struct"
| Union -> "union"
| Protocol -> "protocol"
let typename_to_string = function let typename_to_string = function
| TN_enum name | TN_enum name
| TN_typedef name -> Mangled.to_string name | TN_typedef name -> Mangled.to_string name
| TN_csu (csu, name) -> csu_name csu ^ " " ^ Mangled.to_string name | TN_csu (csu, name) -> Csu.name csu ^ " " ^ Mangled.to_string name
let typename_name = function let typename_name = function
| TN_enum name | TN_enum name
@ -1994,15 +1965,16 @@ and pp_type_decl pe pp_base pp_size f = function
| Tptr (typ, pk) -> | Tptr (typ, pk) ->
let pp_base' fmt () = F.fprintf fmt "%s%a" (ptr_kind_string pk) pp_base () in let pp_base' fmt () = F.fprintf fmt "%s%a" (ptr_kind_string pk) pp_base () in
pp_type_decl pe pp_base' pp_size f typ pp_type_decl pe pp_base' pp_size f typ
| Tstruct (ftal, sftal, csu, Some name, _, _, _) when false -> (* remove "when false" to print the details of struct *) | Tstruct (ftal, sftal, csu, Some name, _, _, _) when false ->
F.fprintf f "%s %a {%a} %a" (csu_name csu) Mangled.pp name (* remove "when false" to print the details of struct *)
F.fprintf f "%s %a {%a} %a" (Csu.name csu) Mangled.pp name
(pp_seq (fun f (fld, t, ann) -> (pp_seq (fun f (fld, t, ann) ->
F.fprintf f "%a %a" (pp_typ_full pe) t Ident.pp_fieldname fld)) F.fprintf f "%a %a" (pp_typ_full pe) t Ident.pp_fieldname fld))
ftal pp_base () ftal pp_base ()
| Tstruct (ftal, sftal, csu, Some name, _, _, _) -> | Tstruct (ftal, sftal, csu, Some name, _, _, _) ->
F.fprintf f "%s %a %a" (csu_name csu) Mangled.pp name pp_base () F.fprintf f "%s %a %a" (Csu.name csu) Mangled.pp name pp_base ()
| Tstruct (ftal, sftal, csu, None, _, _, _) -> | Tstruct (ftal, sftal, csu, None, _, _, _) ->
F.fprintf f "%s {%a} %a" (csu_name csu) F.fprintf f "%s {%a} %a" (Csu.name csu)
(pp_seq (fun f (fld, t, ann) -> F.fprintf f "%a %a" (pp_typ_full pe) t Ident.pp_fieldname fld)) ftal pp_base () (pp_seq (fun f (fld, t, ann) -> F.fprintf f "%a %a" (pp_typ_full pe) t Ident.pp_fieldname fld)) ftal pp_base ()
| Tarray (typ, size) -> | Tarray (typ, size) ->
let pp_base' fmt () = F.fprintf fmt "%a[%a]" pp_base () (pp_size pe) size in let pp_base' fmt () = F.fprintf fmt "%a[%a]" pp_base () (pp_size pe) size in
@ -3808,7 +3780,7 @@ let tenv_add tenv name typ =
let get_typ name csu_option tenv = let get_typ name csu_option tenv =
let csu = match csu_option with let csu = match csu_option with
| Some t -> t | Some t -> t
| None -> Class in | None -> Csu.Class in
tenv_lookup tenv (TN_csu (csu, name)) tenv_lookup tenv (TN_csu (csu, name))
(** expand a type if it is a typename by looking it up in the type environment *) (** expand a type if it is a typename by looking it up in the type environment *)

23
infer/src/backend/sil.mli
Unescape View File

@ -12,18 +12,11 @@
open Utils open Utils
(** Class, struct, union, (Obj C) protocol *)
type csu =
| Class
| Struct
| Union
| Protocol
(** Named types. *) (** Named types. *)
type typename = type typename =
| TN_typedef of Mangled.t | TN_typedef of Mangled.t
| TN_enum of Mangled.t | TN_enum of Mangled.t
| TN_csu of csu * Mangled.t | TN_csu of Csu.t * Mangled.t
(** {2 Programs and Types} *) (** {2 Programs and Types} *)
@ -84,7 +77,8 @@ type binop =
| LAnd (** logical and. Does not always evaluate both operands. *) | LAnd (** logical and. Does not always evaluate both operands. *)
| LOr (** logical or. Does not always evaluate both operands. *) | LOr (** logical or. Does not always evaluate both operands. *)
| PtrFld (** field offset via pointer to field: takes the address of a csu and a Cptr_to_fld constant to form an Lfield expression (see prop.ml) *) | PtrFld (** field offset via pointer to field: takes the address of a
Csu.t and a Cptr_to_fld constant to form an Lfield expression (see prop.ml) *)
(** Kinds of integers *) (** Kinds of integers *)
type ikind = type ikind =
@ -283,7 +277,8 @@ and const =
| Cattribute of attribute (** attribute used in disequalities to annotate a value *) | Cattribute of attribute (** attribute used in disequalities to annotate a value *)
| Cexn of exp (** exception *) | Cexn of exp (** exception *)
| Cclass of Ident.name (** class constant *) | Cclass of Ident.name (** class constant *)
| Cptr_to_fld of Ident.fieldname * typ (** pointer to field constant, and type of the surrounding csu type *) | Cptr_to_fld of Ident.fieldname * typ (** pointer to field constant,
and type of the surrounding Csu.t type *)
| Ctuple of exp list (** tuple of values *) | Ctuple of exp list (** tuple of values *)
and struct_fields = (Ident.fieldname * typ * item_annotation) list and struct_fields = (Ident.fieldname * typ * item_annotation) list
@ -296,7 +291,8 @@ and typ =
| Tvoid (** void type *) | Tvoid (** void type *)
| Tfun of bool (** function type with noreturn attribute *) | Tfun of bool (** function type with noreturn attribute *)
| Tptr of typ * ptr_kind (** pointer type *) | Tptr of typ * ptr_kind (** pointer type *)
| Tstruct of struct_fields * struct_fields * csu * Mangled.t option * (csu * Mangled.t) list * Procname.t list * item_annotation | Tstruct of struct_fields * struct_fields * Csu.t * Mangled.t option *
(Csu.t * Mangled.t) list * Procname.t list * item_annotation
(** Structure type with nonstatic and static fields, class/struct/union flag, name, list of superclasses, (** Structure type with nonstatic and static fields, class/struct/union flag, name, list of superclasses,
methods defined, and annotations. methods defined, and annotations.
The fld - typ pairs are always sorted. This means that we don't support programs that exploit specific layouts The fld - typ pairs are always sorted. This means that we don't support programs that exploit specific layouts
@ -524,7 +520,7 @@ val tenv_lookup : tenv -> typename -> typ option
val tenv_add : tenv -> typename -> typ -> unit val tenv_add : tenv -> typename -> typ -> unit
(** look up the type for a mangled name in the current type environment *) (** look up the type for a mangled name in the current type environment *)
val get_typ : Mangled.t -> csu option -> tenv -> typ option val get_typ : Mangled.t -> Csu.t option -> tenv -> typ option
(** expand a type if it is a typename by looking it up in the type environment *) (** expand a type if it is a typename by looking it up in the type environment *)
val expand_type : tenv -> typ -> typ val expand_type : tenv -> typ -> typ
@ -646,9 +642,6 @@ val typename_compare : typename -> typename -> int
(** Equality for typenames *) (** Equality for typenames *)
val typename_equal : typename -> typename -> bool val typename_equal : typename -> typename -> bool
(** Equality for typenames *)
val csu_name_equal : (csu * Mangled.t) -> (csu * Mangled.t) -> bool
(** Comparision for ptr_kind *) (** Comparision for ptr_kind *)
val ptr_kind_compare : ptr_kind -> ptr_kind -> int val ptr_kind_compare : ptr_kind -> ptr_kind -> int

32
infer/src/backend/symExec.ml
Unescape View File

@ -156,7 +156,11 @@ let rec apply_offlist
| (Sil.Off_fld (fld, fld_typ)):: offlist', Sil.Estruct (fsel, inst') -> | (Sil.Off_fld (fld, fld_typ)):: offlist', Sil.Estruct (fsel, inst') ->
begin begin
let typ' = Sil.expand_type tenv typ in let typ' = Sil.expand_type tenv typ in
let ftal, sftal, csu, nameo, supers, def_mthds, iann = match typ' with Sil.Tstruct (ftal, sftal, csu, nameo, supers, def_mthds, iann) -> ftal, sftal, csu, nameo, supers, def_mthds, iann | _ -> assert false in let ftal, sftal, csu, nameo, supers, def_mthds, iann =
match typ' with
| Sil.Tstruct (ftal, sftal, csu, nameo, supers, def_mthds, iann) ->
ftal, sftal, csu, nameo, supers, def_mthds, iann
| _ -> assert false in
let t' = unroll_type tenv typ (Sil.Off_fld (fld, fld_typ)) in let t' = unroll_type tenv typ (Sil.Off_fld (fld, fld_typ)) in
try try
let _, se' = IList.find (fun fse -> Ident.fieldname_equal fld (fst fse)) fsel in let _, se' = IList.find (fun fse -> Ident.fieldname_equal fld (fst fse)) fsel in
@ -167,7 +171,9 @@ let rec apply_offlist
let replace_fse fse = if Sil.fld_equal fld (fst fse) then (fld, res_se') else fse in let replace_fse fse = if Sil.fld_equal fld (fst fse) then (fld, res_se') else fse in
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) = if Sil.fld_equal fld f then (fld, res_t', a) else (f, t, a) in let replace_fta (f, t, a) = if Sil.fld_equal fld f then (fld, res_t', a) else (f, t, a) in
let res_t = Sil.Tstruct (IList.map replace_fta ftal, sftal, csu, nameo, supers, def_mthds, iann) in let res_t =
Sil.Tstruct
(IList.map replace_fta ftal, sftal, csu, nameo, supers, def_mthds, iann) 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();
@ -599,14 +605,14 @@ let resolve_method tenv class_name proc_name =
if Procname.is_java proc_name then if Procname.is_java proc_name then
Procname.java_replace_class proc_name (Mangled.to_string class_name) Procname.java_replace_class proc_name (Mangled.to_string class_name)
else Procname.c_method_replace_class proc_name (Mangled.to_string class_name) in else Procname.c_method_replace_class proc_name (Mangled.to_string class_name) in
let type_name = Sil.TN_csu (Sil.Class, class_name) in let type_name = Sil.TN_csu (Csu.Class, class_name) in
match Sil.tenv_lookup tenv type_name with match Sil.tenv_lookup tenv type_name with
| Some (Sil.Tstruct (_, _, Sil.Class, cls, super_classes, methods, iann)) -> | Some (Sil.Tstruct (_, _, Csu.Class, cls, super_classes, methods, iann)) ->
if method_exists right_proc_name methods then if method_exists right_proc_name methods then
Some right_proc_name Some right_proc_name
else else
(match super_classes with (match super_classes with
| (Sil.Class, super_class):: interfaces -> | (Csu.Class, super_class):: interfaces ->
if not (Mangled.MangledSet.mem super_class !visited) if not (Mangled.MangledSet.mem super_class !visited)
then resolve super_class then resolve super_class
else None else None
@ -629,7 +635,8 @@ let resolve_typename prop arg =
| _ :: hpreds -> loop hpreds in | _ :: hpreds -> loop hpreds in
loop (Prop.get_sigma prop) in loop (Prop.get_sigma prop) in
match typexp_opt with match typexp_opt with
| Some (Sil.Sizeof (Sil.Tstruct (_, _, Sil.Class, class_name_opt, _, _, _), _)) -> class_name_opt | Some (Sil.Sizeof (Sil.Tstruct (_, _, Csu.Class, class_name_opt, _, _, _), _)) ->
class_name_opt
| _ -> None | _ -> None
(** If the dynamic type of the object calling a method is known, the method from the dynamic type (** If the dynamic type of the object calling a method is known, the method from the dynamic type
@ -650,7 +657,7 @@ let resolve_virtual_pname cfg tenv prop args pname : Procname.t =
let redirect_shared_ptr tenv cfg pname actual_params = let redirect_shared_ptr tenv cfg pname actual_params =
let class_shared_ptr typ = let class_shared_ptr typ =
try match Sil.expand_type tenv typ with try match Sil.expand_type tenv typ with
| Sil.Tstruct (_, _, Sil.Class, Some cl_name, _, _, _) -> | Sil.Tstruct (_, _, Csu.Class, Some cl_name, _, _, _) ->
let name = Mangled.to_string cl_name in let name = Mangled.to_string cl_name in
name = "shared_ptr" || name = "__shared_ptr" name = "shared_ptr" || name = "__shared_ptr"
| t -> false | t -> false
@ -980,7 +987,8 @@ let rec sym_exec cfg tenv pdesc _instr (_prop: Prop.normal Prop.t) path
(* iOS: check that NSNumber *'s are not used in conditionals without comparing to nil *) (* iOS: check that NSNumber *'s are not used in conditionals without comparing to nil *)
let lhs_normal = Prop.exp_normalize_prop _prop lhs in let lhs_normal = Prop.exp_normalize_prop _prop lhs in
let is_nsnumber = function let is_nsnumber = function
| Sil.Tvar (Sil.TN_csu (Sil.Class, name)) -> Mangled.to_string name = "NSNumber" | Sil.Tvar (Sil.TN_csu (Csu.Class, name)) ->
Mangled.to_string name = "NSNumber"
| _ -> false in | _ -> false in
let lhs_is_ns_ptr () = let lhs_is_ns_ptr () =
IList.exists IList.exists
@ -2448,7 +2456,7 @@ module ModelBuiltins = struct
sym_exec_generated false cfg tenv pdesc [alloc_instr] symb_state sym_exec_generated false cfg tenv pdesc [alloc_instr] symb_state
let execute_objc_NSArray_alloc_no_fail cfg pdesc tenv symb_state ret_ids loc = let execute_objc_NSArray_alloc_no_fail cfg pdesc tenv symb_state ret_ids loc =
let nsarray_typ = Sil.Tvar (Sil.TN_csu (Sil.Class, Mangled.from_string "NSArray")) in let nsarray_typ = Sil.Tvar (Sil.TN_csu (Csu.Class, Mangled.from_string "NSArray")) in
let nsarray_typ = Sil.expand_type tenv nsarray_typ in let nsarray_typ = Sil.expand_type tenv nsarray_typ in
execute_objc_alloc_no_fail cfg pdesc tenv symb_state ret_ids nsarray_typ loc execute_objc_alloc_no_fail cfg pdesc tenv symb_state ret_ids nsarray_typ loc
@ -2474,8 +2482,10 @@ module ModelBuiltins = struct
execute_NSArray_arrayWithObjects execute_NSArray_arrayWithObjects
let execute_objc_NSDictionary_alloc_no_fail cfg pdesc tenv symb_state ret_ids loc = let execute_objc_NSDictionary_alloc_no_fail cfg pdesc tenv symb_state ret_ids loc =
let nsdictionary_typ = Sil.Tvar (Sil.TN_csu (Sil.Class, Mangled.from_string "NSDictionary")) in let nsdictionary_typ =
let nsdictionary_typ = Sil.expand_type tenv nsdictionary_typ in Sil.Tvar (Sil.TN_csu (Csu.Class, Mangled.from_string "NSDictionary")) in
let nsdictionary_typ =
Sil.expand_type tenv nsdictionary_typ in
execute_objc_alloc_no_fail cfg pdesc tenv symb_state ret_ids nsdictionary_typ loc execute_objc_alloc_no_fail cfg pdesc tenv symb_state ret_ids nsdictionary_typ loc
let execute___objc_dictionary_literal cfg pdesc instr tenv prop path ret_ids args callee_pname loc = let execute___objc_dictionary_literal cfg pdesc instr tenv prop path ret_ids args callee_pname loc =

3
infer/src/backend/tabulation.ml
Unescape View File

@ -443,7 +443,8 @@ let texp_star texp1 texp2 =
| 0 -> ftal_sub ftal1' ftal2' | 0 -> ftal_sub ftal1' ftal2'
| _ -> ftal_sub ftal1 ftal2' end in | _ -> ftal_sub ftal1 ftal2' end in
let typ_star t1 t2 = match t1, t2 with let typ_star t1 t2 = match t1, t2 with
| Sil.Tstruct (ftal1, sftal1, csu1, _, _, _, _), Sil.Tstruct (ftal2, sftal2, csu2, _, _, _, _) when csu1 = csu2 -> | Sil.Tstruct (ftal1, sftal1, csu1, _, _, _, _),
Sil.Tstruct (ftal2, sftal2, csu2, _, _, _, _) when csu1 = csu2 ->
if ftal_sub ftal1 ftal2 then t2 else t1 if ftal_sub ftal1 ftal2 then t2 else t1
| _ -> t1 in | _ -> t1 in
match texp1, texp2 with match texp1, texp2 with

10
infer/src/backend/type_prop.ml
Unescape View File

@ -99,8 +99,8 @@ struct
let rec type_to_string typ = let rec type_to_string typ =
match typ with match typ with
| Sil.Tptr (typ , _) -> type_to_string typ | Sil.Tptr (typ , _) -> type_to_string typ
| Sil.Tstruct (_, _, Sil.Class, Some mangled, _, _, _) | Sil.Tstruct (_, _, Csu.Class, Some mangled, _, _, _)
| Sil.Tvar ( Sil.TN_csu (Sil.Class, (mangled))) -> Mangled.to_string mangled | Sil.Tvar ( Sil.TN_csu (Csu.Class, (mangled))) -> Mangled.to_string mangled
| _ -> Sil.typ_to_string typ | _ -> Sil.typ_to_string typ
let string_typ_to_string (s, typ) = let string_typ_to_string (s, typ) =
@ -311,8 +311,8 @@ let initial_node = ref (Cfg.Node.dummy ())
let rec super tenv t = let rec super tenv t =
match t with match t with
| Sil.Tstruct (_, _, Sil.Class, Some c2, (Sil.Class, super):: rest, _, _) -> | Sil.Tstruct (_, _, Csu.Class, Some c2, (Csu.Class, super):: rest, _, _) ->
Sil.tenv_lookup tenv (Sil.TN_csu (Sil.Class, super)) Sil.tenv_lookup tenv (Sil.TN_csu (Csu.Class, super))
| Sil.Tarray (dom_type, _) -> None | Sil.Tarray (dom_type, _) -> None
| Sil.Tptr (dom_type, p) -> | Sil.Tptr (dom_type, p) ->
let super_dom_type = super tenv dom_type in let super_dom_type = super tenv dom_type in
@ -412,7 +412,7 @@ struct
| Sil.Cfun fn -> assert false | Sil.Cfun fn -> assert false
| Sil.Cstr str -> | Sil.Cstr str ->
Sil.Tptr ( Sil.Tptr (
Sil.Tvar ( Sil.TN_csu (Sil.Class, (Mangled.from_string ( "java.lang.String")))), Sil.Tvar ( Sil.TN_csu (Csu.Class, (Mangled.from_string ( "java.lang.String")))),
Sil.Pk_pointer) Sil.Pk_pointer)
| Sil.Cattribute atr -> assert false | Sil.Cattribute atr -> assert false
| Sil.Cexn e -> assert false | Sil.Cexn e -> assert false

2
infer/src/checkers/callbackChecker.ml
Unescape View File

@ -94,7 +94,7 @@ let callback_checker_main all_procs get_procdesc idenv tenv proc_name proc_desc
let registered_callback_procs' = IList.fold_left let registered_callback_procs' = IList.fold_left
(fun callback_procs callback_typ -> (fun callback_procs callback_typ ->
match callback_typ with match callback_typ with
| Sil.Tptr (Sil.Tstruct(_, _, Sil.Class, Some class_name, _, methods, _), _) -> | Sil.Tptr (Sil.Tstruct(_, _, Csu.Class, Some class_name, _, methods, _), _) ->
IList.fold_left IList.fold_left
(fun callback_procs callback_proc -> (fun callback_procs callback_proc ->
if Procname.is_constructor callback_proc then callback_procs if Procname.is_constructor callback_proc then callback_procs

2
infer/src/checkers/eradicateChecks.ml
Unescape View File

@ -130,7 +130,7 @@ let check_condition case_zero find_canonical_duplicate get_proc_desc curr_pname
let throwable_found = ref false in let throwable_found = ref false in
let throwable_class = Mangled.from_string "java.lang.Throwable" in let throwable_class = Mangled.from_string "java.lang.Throwable" in
let typ_is_throwable = function let typ_is_throwable = function
| Sil.Tstruct (_, _, Sil.Class, Some c, _, _, _) -> | Sil.Tstruct (_, _, Csu.Class, Some c, _, _, _) ->
Mangled.equal c throwable_class Mangled.equal c throwable_class
| _ -> false in | _ -> false in
let do_instr = function let do_instr = function

25
infer/src/checkers/patternMatch.ml
Unescape View File

@ -45,7 +45,7 @@ let type_get_direct_supertypes = function
let type_get_class_name t = match t with let type_get_class_name t = match t with
| Sil.Tptr (Sil.Tstruct (_, _, _, Some cn, _, _, _), _) -> | Sil.Tptr (Sil.Tstruct (_, _, _, Some cn, _, _, _), _) ->
Some cn Some cn
| Sil.Tptr (Sil.Tvar (Sil.TN_csu (Sil.Class, cn)), _) -> | Sil.Tptr (Sil.Tvar (Sil.TN_csu (Csu.Class, cn)), _) ->
Some cn Some cn
| _ -> None | _ -> None
@ -65,7 +65,7 @@ let type_has_direct_supertype (t : Sil.typ) (s : Mangled.t) =
let type_find_supertype let type_find_supertype
(tenv: Sil.tenv) (tenv: Sil.tenv)
(typ: Sil.typ) (typ: Sil.typ)
(csu_option: Sil.csu option) (csu_opt: Csu.t option)
(filter: Mangled.t -> bool): bool = (filter: Mangled.t -> bool): bool =
let rec has_supertype typ visited = let rec has_supertype typ visited =
if Sil.TypSet.mem typ visited then if Sil.TypSet.mem typ visited then
@ -77,14 +77,15 @@ let type_find_supertype
| Sil.Tstruct (_, _, _, _, supertypes, _, _) -> | Sil.Tstruct (_, _, _, _, supertypes, _, _) ->
let match_supertype (csu, m) = let match_supertype (csu, m) =
let match_name () = filter m in let match_name () = filter m in
let match_csu () = match csu_option with let match_csu () = match csu_opt with
| Some c -> c = csu | Some c -> c = csu
| None -> true in | None -> true in
let has_indirect_supertype () = let has_indirect_supertype () =
match Sil.get_typ m csu_option tenv with match Sil.get_typ m csu_opt tenv with
| Some supertype -> has_supertype supertype (Sil.TypSet.add typ visited) | Some supertype -> has_supertype supertype (Sil.TypSet.add typ visited)
| None -> false in | None -> false in
(match_csu () && match_name () (* only and always visit name with expected csu *)) (match_csu () && match_name ()
(* only and always visit name with expected csu *))
|| has_indirect_supertype () in || has_indirect_supertype () in
IList.exists match_supertype supertypes IList.exists match_supertype supertypes
| _ -> false | _ -> false
@ -94,20 +95,20 @@ let type_find_supertype
let type_has_supertype let type_has_supertype
(tenv: Sil.tenv) (tenv: Sil.tenv)
(typ: Sil.typ) (typ: Sil.typ)
(csu_option: Sil.csu option) (csu_opt: Csu.t option)
(name: Mangled.t): bool = (name: Mangled.t): bool =
let filter m = Mangled.equal m name in let filter m = Mangled.equal m name in
type_find_supertype tenv typ csu_option filter type_find_supertype tenv typ csu_opt filter
let type_get_supertypes let type_get_supertypes
(tenv: Sil.tenv) (tenv: Sil.tenv)
(typ: Sil.typ) (typ: Sil.typ)
(csu_option: Sil.csu option) : Mangled.t list = (csu_opt: Csu.t option) : Mangled.t list =
let res = ref [] in let res = ref [] in
let filter m = let filter m =
res := m :: !res; res := m :: !res;
false in false in
let _ = type_find_supertype tenv typ csu_option filter in let _ = type_find_supertype tenv typ csu_opt filter in
IList.rev !res IList.rev !res
let type_is_nested_in_type t n = match t with let type_is_nested_in_type t n = match t with
@ -269,7 +270,7 @@ let initializer_methods = [
let type_has_initializer let type_has_initializer
(tenv: Sil.tenv) (tenv: Sil.tenv)
(t: Sil.typ): bool = (t: Sil.typ): bool =
let check_candidate cname = type_has_supertype tenv t (Some Sil.Class) cname in let check_candidate cname = type_has_supertype tenv t (Some Csu.Class) cname in
IList.exists check_candidate initializer_classes IList.exists check_candidate initializer_classes
(** Check if the method is one of the known initializer methods. *) (** Check if the method is one of the known initializer methods. *)
@ -328,7 +329,7 @@ let proc_iter_overridden_methods f tenv proc_name =
let do_super_type tenv super_class_name = let do_super_type tenv super_class_name =
let super_proc_name = let super_proc_name =
Procname.java_replace_class proc_name (Mangled.to_string super_class_name) in Procname.java_replace_class proc_name (Mangled.to_string super_class_name) in
let type_name = Sil.TN_csu (Sil.Class, super_class_name) in let type_name = Sil.TN_csu (Csu.Class, super_class_name) in
match Sil.tenv_lookup tenv type_name with match Sil.tenv_lookup tenv type_name with
| Some (Sil.Tstruct (_, _, _, _, _, methods, _)) -> | Some (Sil.Tstruct (_, _, _, _, _, methods, _)) ->
let is_override pname = let is_override pname =
@ -344,7 +345,7 @@ let proc_iter_overridden_methods f tenv proc_name =
if Procname.is_java proc_name then if Procname.is_java proc_name then
let type_name = let type_name =
let class_name = Procname.java_get_class proc_name in let class_name = Procname.java_get_class proc_name in
Sil.TN_csu (Sil.Class, Mangled.from_string class_name) in Sil.TN_csu (Csu.Class, Mangled.from_string class_name) in
match Sil.tenv_lookup tenv type_name with match Sil.tenv_lookup tenv type_name with
| Some curr_type -> | Some curr_type ->
IList.iter (do_super_type tenv) (type_get_direct_supertypes curr_type) IList.iter (do_super_type tenv) (type_get_direct_supertypes curr_type)

6
infer/src/checkers/patternMatch.mli
Unescape View File

@ -66,21 +66,21 @@ val type_get_class_name : Sil.typ -> Mangled.t option
val type_get_direct_supertypes : Sil.typ -> Mangled.t list val type_get_direct_supertypes : Sil.typ -> Mangled.t list
val type_get_supertypes : Sil.tenv -> Sil.typ -> Sil.csu option -> Mangled.t list val type_get_supertypes : Sil.tenv -> Sil.typ -> Csu.t option -> Mangled.t list
(** Is the type a class with the given name *) (** Is the type a class with the given name *)
val type_has_class_name : Sil.typ -> Mangled.t -> bool val type_has_class_name : Sil.typ -> Mangled.t -> bool
val type_has_direct_supertype : Sil.typ -> Mangled.t -> bool val type_has_direct_supertype : Sil.typ -> Mangled.t -> bool
val type_has_supertype : Sil.tenv -> Sil.typ -> Sil.csu option -> Mangled.t -> bool val type_has_supertype : Sil.tenv -> Sil.typ -> Csu.t option -> Mangled.t -> bool
(** Is the type a class type *) (** Is the type a class type *)
val type_is_class : Sil.typ -> bool val type_is_class : Sil.typ -> bool
val type_is_nested_in_direct_supertype : Sil.typ -> Mangled.t -> bool val type_is_nested_in_direct_supertype : Sil.typ -> Mangled.t -> bool
val type_is_nested_in_supertype : Sil.tenv -> Sil.typ -> Sil.csu option -> Mangled.t -> bool val type_is_nested_in_supertype : Sil.tenv -> Sil.typ -> Csu.t option -> Mangled.t -> bool
val type_is_nested_in_type : Sil.typ -> Mangled.t -> bool val type_is_nested_in_type : Sil.typ -> Mangled.t -> bool

2
infer/src/checkers/performanceCritical.ml
Unescape View File

@ -79,7 +79,7 @@ let is_modeled_expensive tenv pname =
| Some p -> p in | Some p -> p in
let classname = let classname =
Mangled.from_package_class package (Procname.java_get_simple_class pname) in Mangled.from_package_class package (Procname.java_get_simple_class pname) in
match Sil.get_typ classname (Some Sil.Class) tenv with match Sil.get_typ classname (Some Csu.Class) tenv with
| None -> false | None -> false
| Some typ -> | Some typ ->
AndroidFramework.is_view typ tenv AndroidFramework.is_view typ tenv

2
infer/src/clang/cContext.ml
Unescape View File

@ -116,7 +116,7 @@ let curr_class_hash curr_class =
| ContextNoCls -> Hashtbl.hash "no class" | ContextNoCls -> Hashtbl.hash "no class"
let create_curr_class tenv class_name = let create_curr_class tenv class_name =
let class_tn_name = Sil.TN_csu (Sil.Class, (Mangled.from_string class_name)) in let class_tn_name = Sil.TN_csu (Csu.Class, (Mangled.from_string class_name)) in
match Sil.tenv_lookup tenv class_tn_name with match Sil.tenv_lookup tenv class_tn_name with
| Some Sil.Tstruct(intf_fields, _, _, _, superclasses, methods, annotation) -> | Some Sil.Tstruct(intf_fields, _, _, _, superclasses, methods, annotation) ->
(let superclasses_names = IList.map (fun (_, name) -> Mangled.to_string name) superclasses in (let superclasses_names = IList.map (fun (_, name) -> Mangled.to_string name) superclasses in

8
infer/src/clang/cField_decl.ml
Unescape View File

@ -20,8 +20,8 @@ let rec get_fields_super_classes tenv super_class =
Printing.log_out " ... Getting fields of superclass '%s'\n" (Sil.typename_to_string super_class); Printing.log_out " ... Getting fields of superclass '%s'\n" (Sil.typename_to_string super_class);
match Sil.tenv_lookup tenv super_class with match Sil.tenv_lookup tenv super_class with
| None -> [] | None -> []
| Some Sil.Tstruct (fields, _, _, _, (Sil.Class, sc):: _, _, _) -> | Some Sil.Tstruct (fields, _, _, _, (Csu.Class, sc):: _, _, _) ->
let sc_fields = get_fields_super_classes tenv (Sil.TN_csu (Sil.Class, sc)) in let sc_fields = get_fields_super_classes tenv (Sil.TN_csu (Csu.Class, sc)) in
General_utils.append_no_duplicates_fields fields sc_fields General_utils.append_no_duplicates_fields fields sc_fields
| Some Sil.Tstruct (fields, _, _, _, _, _, _) -> fields | Some Sil.Tstruct (fields, _, _, _, _, _, _) -> fields
| Some _ -> [] | Some _ -> []
@ -77,14 +77,14 @@ let rec get_fields type_ptr_to_sil_type tenv curr_class decl_list =
(* 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 fields = let add_missing_fields tenv class_name fields =
let mang_name = Mangled.from_string class_name in let mang_name = Mangled.from_string class_name in
let class_tn_name = Sil.TN_csu (Sil.Class, mang_name) in let class_tn_name = Sil.TN_csu (Csu.Class, mang_name) in
match Sil.tenv_lookup tenv class_tn_name with match Sil.tenv_lookup tenv class_tn_name with
| Some Sil.Tstruct(intf_fields, _, _, _, superclass, methods, annotation) -> | Some Sil.Tstruct(intf_fields, _, _, _, superclass, methods, annotation) ->
let new_fields = General_utils.append_no_duplicates_fields fields intf_fields in let new_fields = General_utils.append_no_duplicates_fields fields intf_fields in
let new_fields = CFrontend_utils.General_utils.sort_fields new_fields in let new_fields = CFrontend_utils.General_utils.sort_fields new_fields in
let class_type_info = let class_type_info =
Sil.Tstruct ( Sil.Tstruct (
new_fields, [], Sil.Class, Some mang_name, superclass, methods, annotation new_fields, [], Csu.Class, Some mang_name, superclass, methods, annotation
) in ) 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;
Sil.tenv_add tenv class_tn_name class_type_info Sil.tenv_add tenv class_tn_name class_type_info

2
infer/src/clang/cFrontend_checkers.ml
Unescape View File

@ -40,7 +40,7 @@ let direct_atomic_property_access context stmt_info ivar_name =
General_utils.mk_class_field_name n, General_utils.mk_class_field_name n,
Ast_utils.get_class_name_from_member n Ast_utils.get_class_name_from_member n
| _ -> Ident.create_fieldname (Mangled.from_string "") 0, "" in | _ -> Ident.create_fieldname (Mangled.from_string "") 0, "" in
let tname = Sil.TN_csu (Sil.Class, Mangled.from_string cname) in let tname = Sil.TN_csu (Csu.Class, Mangled.from_string cname) in
let loc = CLocation.get_sil_location_from_range stmt_info.Clang_ast_t.si_source_range true in let loc = CLocation.get_sil_location_from_range stmt_info.Clang_ast_t.si_source_range true in
match Sil.tenv_lookup tenv tname with match Sil.tenv_lookup tenv tname with
| Some Sil.Tstruct (flds1, flds2, _, _, _, _, _) -> | Some Sil.Tstruct (flds1, flds2, _, _, _, _, _) ->

9
infer/src/clang/cFrontend_utils.ml
Unescape View File

@ -43,7 +43,7 @@ struct
let print_tenv tenv = let print_tenv tenv =
Sil.tenv_iter (fun typname typ -> Sil.tenv_iter (fun typname typ ->
match typname with match typname with
| Sil.TN_csu (Sil.Class, _) | Sil.TN_csu (Sil.Protocol, _) -> | Sil.TN_csu (Csu.Class, _) | Sil.TN_csu (Csu.Protocol, _) ->
(match typ with (match typ with
| Sil.Tstruct (fields, _, _, cls, super_classes, methods, iann) -> | Sil.Tstruct (fields, _, _, cls, super_classes, methods, iann) ->
print_endline ( print_endline (
@ -62,7 +62,7 @@ struct
let print_tenv_struct_unions tenv = let print_tenv_struct_unions tenv =
Sil.tenv_iter (fun typname typ -> Sil.tenv_iter (fun typname typ ->
match typname with match typname with
| Sil.TN_csu (Sil.Struct, _) | Sil.TN_csu (Sil.Union, _) -> | Sil.TN_csu (Csu.Struct, _) | Sil.TN_csu (Csu.Union, _) ->
(match typ with (match typ with
| (Sil.Tstruct (fields, static_fields, _, cls, super_classes, methods, iann)) -> | (Sil.Tstruct (fields, static_fields, _, cls, super_classes, methods, iann)) ->
(print_endline ( (print_endline (
@ -430,7 +430,10 @@ struct
| [] -> list1 | [] -> list1
let append_no_duplicates_csu list1 list2 = let append_no_duplicates_csu list1 list2 =
append_no_duplicates Sil.csu_name_equal list1 list2 append_no_duplicates
(fun (ds1, n1) (ds2, n2) ->
Csu.equal ds1 ds2 && Mangled.equal n1 n2)
list1 list2
let append_no_duplicates_methods list1 list2 = let append_no_duplicates_methods list1 list2 =
append_no_duplicates Procname.equal list1 list2 append_no_duplicates Procname.equal list1 list2

3
infer/src/clang/cFrontend_utils.mli
Unescape View File

@ -138,7 +138,8 @@ sig
val append_no_duplicates_fields : (Ident.fieldname * Sil.typ * Sil.item_annotation) list -> val append_no_duplicates_fields : (Ident.fieldname * Sil.typ * Sil.item_annotation) list ->
(Ident.fieldname * Sil.typ * Sil.item_annotation) list -> (Ident.fieldname * Sil.typ * Sil.item_annotation) list (Ident.fieldname * Sil.typ * Sil.item_annotation) list -> (Ident.fieldname * Sil.typ * Sil.item_annotation) list
val append_no_duplicates_csu : (Sil.csu * Mangled.t) list -> (Sil.csu * Mangled.t) list -> (Sil.csu * Mangled.t) list val append_no_duplicates_csu :
(Csu.t * Mangled.t) list -> (Csu.t * Mangled.t) list -> (Csu.t * Mangled.t) list
val append_no_duplicates_methods : Procname.t list -> Procname.t list -> Procname.t list val append_no_duplicates_methods : Procname.t list -> Procname.t list -> Procname.t list

2
infer/src/clang/cMethod_trans.ml
Unescape View File

@ -188,7 +188,7 @@ let get_method_name_from_clang tenv ms_opt =
let get_superclass_curr_class context = let get_superclass_curr_class context =
let retrive_super cname super_opt = let retrive_super cname super_opt =
let iname = Sil.TN_csu (Sil.Class, Mangled.from_string cname) in let iname = Sil.TN_csu (Csu.Class, Mangled.from_string cname) in
Printing.log_out "Checking for superclass = '%s'\n\n%!" (Sil.typename_to_string iname); Printing.log_out "Checking for superclass = '%s'\n\n%!" (Sil.typename_to_string iname);
match Sil.tenv_lookup (CContext.get_tenv context) iname with match Sil.tenv_lookup (CContext.get_tenv context) iname with
| Some Sil.Tstruct(_, _, _, _, (_, super_name):: _, _, _) -> | Some Sil.Tstruct(_, _, _, _, (_, super_name):: _, _, _) ->

4
infer/src/clang/cTrans.ml
Unescape View File

@ -118,8 +118,8 @@ struct
IList.iter (fun (fn, ft, _) -> IList.iter (fun (fn, ft, _) ->
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_type = Sil.Tstruct (fields, [], Sil.Class, Some mblock, [], [], []) in let block_type = Sil.Tstruct (fields, [], Csu.Class, Some mblock, [], [], []) in
let block_name = Sil.TN_csu (Sil.Class, mblock) in let block_name = Sil.TN_csu (Csu.Class, mblock) in
Sil.tenv_add tenv block_name block_type; Sil.tenv_add tenv block_name block_type;
let trans_res = CTrans_utils.alloc_trans trans_state loc (Ast_expressions.dummy_stmt_info ()) block_type true in let trans_res = CTrans_utils.alloc_trans trans_state loc (Ast_expressions.dummy_stmt_info ()) block_type true in
let id_block = match trans_res.exps with let id_block = match trans_res.exps with

4
infer/src/clang/cType_to_sil_type.ml
Unescape View File

@ -11,8 +11,8 @@ open CFrontend_utils
let get_builtin_objc_typename builtin_type = let get_builtin_objc_typename builtin_type =
match builtin_type with match builtin_type with
| `ObjCId -> Sil.TN_csu (Sil.Struct, (Mangled.from_string CFrontend_config.objc_object)) | `ObjCId -> Sil.TN_csu (Csu.Struct, (Mangled.from_string CFrontend_config.objc_object))
| `ObjCClass -> Sil.TN_csu (Sil.Struct, (Mangled.from_string CFrontend_config.objc_class)) | `ObjCClass -> Sil.TN_csu (Csu.Struct, (Mangled.from_string CFrontend_config.objc_class))
let get_builtin_objc_type builtin_type = let get_builtin_objc_type builtin_type =
let typ = Sil.Tvar (get_builtin_objc_typename builtin_type) in let typ = Sil.Tvar (get_builtin_objc_typename builtin_type) in

4
infer/src/clang/cTypes.ml
Unescape View File

@ -65,9 +65,9 @@ let search_enum_type_by_name tenv name =
Sil.tenv_iter f tenv; Sil.tenv_iter f tenv;
!found !found
let mk_classname n = Sil.TN_csu (Sil.Class, Mangled.from_string n) let mk_classname n = Sil.TN_csu (Csu.Class, Mangled.from_string n)
let mk_structname n = Sil.TN_csu (Sil.Struct, Mangled.from_string n) let mk_structname n = Sil.TN_csu (Csu.Struct, Mangled.from_string n)
let mk_enumname n = Sil.TN_enum (Mangled.from_string n) let mk_enumname n = Sil.TN_enum (Mangled.from_string n)

30
infer/src/clang/cTypes_decl.ml
Unescape View File

@ -17,21 +17,21 @@ exception Typename_not_found
let add_predefined_objc_types tenv = let add_predefined_objc_types tenv =
let objc_class_mangled = Mangled.from_string CFrontend_config.objc_class in let objc_class_mangled = Mangled.from_string CFrontend_config.objc_class in
let objc_class_name = Sil.TN_csu (Sil.Class, objc_class_mangled) in let objc_class_name = Sil.TN_csu (Csu.Class, objc_class_mangled) in
let objc_class_type_info = let objc_class_type_info =
Sil.Tstruct ([], [], Sil.Struct, Sil.Tstruct ([], [], Csu.Struct,
Some (Mangled.from_string CFrontend_config.objc_class), [], [], []) in Some (Mangled.from_string CFrontend_config.objc_class), [], [], []) in
Sil.tenv_add tenv objc_class_name objc_class_type_info; Sil.tenv_add tenv objc_class_name objc_class_type_info;
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 class_typ = Sil.Tvar (Sil.TN_csu (Sil.Struct, objc_class_mangled)) in let class_typ = Sil.Tvar (Sil.TN_csu (Csu.Struct, objc_class_mangled)) in
Sil.tenv_add tenv class_typename class_typ; Sil.tenv_add tenv class_typename class_typ;
let typename_objc_object = let typename_objc_object =
Sil.TN_csu (Sil.Struct, Mangled.from_string CFrontend_config.objc_object) in Sil.TN_csu (Csu.Struct, Mangled.from_string CFrontend_config.objc_object) in
let id_typedef = Sil.Tvar (typename_objc_object) in let id_typedef = Sil.Tvar (typename_objc_object) in
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
Sil.tenv_add tenv id_typename id_typedef; Sil.tenv_add tenv id_typename id_typedef;
let objc_object_type_info = let objc_object_type_info =
Sil.Tstruct ([], [], Sil.Struct, Sil.Tstruct ([], [], Csu.Struct,
Some (Mangled.from_string CFrontend_config.objc_object), [], [], []) in Some (Mangled.from_string CFrontend_config.objc_object), [], [], []) in
Sil.tenv_add tenv typename_objc_object objc_object_type_info Sil.tenv_add tenv typename_objc_object objc_object_type_info
@ -75,10 +75,10 @@ let create_csu opt_type =
| `Type s -> | `Type s ->
(let buf = Str.split (Str.regexp "[ \t]+") s in (let buf = Str.split (Str.regexp "[ \t]+") s in
match buf with match buf with
| "struct":: l ->Sil.Struct | "struct":: l ->Csu.Struct
| "class":: l -> Sil.Class | "class":: l -> Csu.Class
| "union":: l -> Sil.Union | "union":: l -> Csu.Union
| _ -> Sil.Struct) | _ -> Csu.Struct)
| _ -> assert false | _ -> assert false
(* We need to take the name out of the type as the struct can be anonymous*) (* We need to take the name out of the type as the struct can be anonymous*)
@ -88,12 +88,12 @@ let get_record_name_csu decl =
| RecordDecl (_, name_info, opt_type, _, _, _, _) -> name_info, opt_type, false | RecordDecl (_, name_info, opt_type, _, _, _, _) -> name_info, opt_type, false
| CXXRecordDecl (_, name_info, opt_type, _, _, _, _, cxx_record_info) | CXXRecordDecl (_, name_info, opt_type, _, _, _, _, cxx_record_info)
| ClassTemplateSpecializationDecl (_, name_info, opt_type, _, _, _, _, cxx_record_info) -> | ClassTemplateSpecializationDecl (_, name_info, opt_type, _, _, _, _, cxx_record_info) ->
(* we use Sil.Class for C++ because we expect Sil.Class csu from *) (* we use Csu.Class for C++ because we expect Csu.Class csu from *)
(* types that have methods. And in C++ struct/class/union can have methods *) (* types that have methods. And in C++ struct/class/union can have methods *)
name_info, opt_type, not cxx_record_info.xrdi_is_c_like name_info, opt_type, not cxx_record_info.xrdi_is_c_like
| _-> assert false in | _-> assert false in
let csu = create_csu opt_type in let csu = create_csu opt_type in
let csu' = if should_be_class then Sil.Class else csu in let csu' = if should_be_class then Csu.Class else csu in
let name = Ast_utils.get_qualified_name name_info in let name = Ast_utils.get_qualified_name name_info in
csu', name csu', name
@ -143,7 +143,7 @@ let get_superclass_decls decl =
let get_superclass_list decl = let get_superclass_list decl =
let base_decls = get_superclass_decls decl in let base_decls = get_superclass_decls decl in
let decl_to_mangled_name decl = Mangled.from_string (get_record_name decl) in let decl_to_mangled_name decl = Mangled.from_string (get_record_name decl) in
let get_super_field super_decl = (Sil.Class, decl_to_mangled_name super_decl) in let get_super_field super_decl = (Csu.Class, decl_to_mangled_name super_decl) in
IList.map get_super_field base_decls IList.map get_super_field base_decls
let add_struct_to_tenv tenv typ = let add_struct_to_tenv tenv typ =
@ -202,8 +202,8 @@ and get_struct_cpp_class_declaration_type tenv decl =
let methods = get_class_methods tenv name decl_list in (* C++ methods only *) let methods = get_class_methods tenv name decl_list in (* C++ methods only *)
let superclasses = get_superclass_list decl in let superclasses = get_superclass_list decl in
let item_annotation = Sil.item_annotation_empty in (* No annotations for struts *) let item_annotation = Sil.item_annotation_empty in (* No annotations for struts *)
let sil_type = Sil.Tstruct (sorted_non_static_fields, static_fields, csu, Some mangled_name, let sil_type = Sil.Tstruct (sorted_non_static_fields, static_fields, csu,
superclasses, methods, item_annotation) in Some mangled_name, superclasses, methods, item_annotation) 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
@ -249,5 +249,5 @@ let get_class_type_np tenv expr_info obj_c_message_expr_info =
let get_type_curr_class tenv curr_class_opt = let get_type_curr_class tenv curr_class_opt =
let name = CContext.get_curr_class_name curr_class_opt in let name = CContext.get_curr_class_name curr_class_opt in
let typ = Sil.Tvar (Sil.TN_csu (Sil.Class, (Mangled.from_string name))) in let typ = Sil.Tvar (Sil.TN_csu (Csu.Class, (Mangled.from_string name))) in
CTypes.expand_structured_type tenv typ CTypes.expand_structured_type tenv typ

4
infer/src/clang/objcCategory_decl.ml
Unescape View File

@ -73,7 +73,7 @@ let process_category type_ptr_to_sil_type tenv curr_class decl_info decl_list =
let methods = ObjcProperty_decl.get_methods curr_class decl_list in let 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 = Sil.TN_csu (Sil.Class, mang_name) in let class_tn_name = Sil.TN_csu (Csu.Class, 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 (Sil.Tvar class_tn_name); Ast_utils.update_sil_types_map decl_key (Sil.Tvar class_tn_name);
(match Sil.tenv_lookup tenv class_tn_name with (match Sil.tenv_lookup tenv class_tn_name with
@ -83,7 +83,7 @@ let process_category type_ptr_to_sil_type tenv curr_class decl_info decl_list =
let new_methods = General_utils.append_no_duplicates_methods methods intf_methods in let new_methods = General_utils.append_no_duplicates_methods methods intf_methods in
let class_type_info = let class_type_info =
Sil.Tstruct ( Sil.Tstruct (
new_fields, [], Sil.Class, Some mang_name, superclass, new_methods, annotation new_fields, [], Csu.Class, Some mang_name, superclass, new_methods, annotation
) in ) 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;
Sil.tenv_add tenv class_tn_name class_type_info Sil.tenv_add tenv class_tn_name class_type_info

22
infer/src/clang/objcInterface_decl.ml
Unescape View File

@ -31,11 +31,11 @@ let is_objc_class_annotation a =
let is_pointer_to_objc_class tenv typ = let is_pointer_to_objc_class tenv typ =
match typ with match typ with
| Sil.Tptr (Sil.Tvar (Sil.TN_csu (Sil.Class, cname)), _) -> | Sil.Tptr (Sil.Tvar (Sil.TN_csu (Csu.Class, cname)), _) ->
(match Sil.tenv_lookup tenv (Sil.TN_csu (Sil.Class, cname)) with (match Sil.tenv_lookup tenv (Sil.TN_csu (Csu.Class, cname)) with
| Some Sil.Tstruct(_, _, Sil.Class, _, _, _, a) when is_objc_class_annotation a -> true | Some Sil.Tstruct(_, _, Csu.Class, _, _, _, a) when is_objc_class_annotation a -> true
| _ -> false) | _ -> false)
| Sil.Tptr (Sil.Tstruct(_, _, Sil.Class, _, _, _, a), _) when | Sil.Tptr (Sil.Tstruct(_, _, Csu.Class, _, _, _, a), _) when
is_objc_class_annotation a -> true is_objc_class_annotation a -> true
| _ -> false | _ -> false
@ -92,9 +92,9 @@ let get_interface_superclasses super_opt protocols =
let super_class = let super_class =
match super_opt with match super_opt with
| None -> [] | None -> []
| Some super -> [(Sil.Class, Mangled.from_string super)] in | Some super -> [(Csu.Class, Mangled.from_string super)] in
let protocol_names = IList.map ( let protocol_names = IList.map (
fun name -> (Sil.Protocol, Mangled.from_string name) fun name -> (Csu.Protocol, Mangled.from_string name)
) protocols in ) protocols in
let super_classes = super_class@protocol_names in let super_classes = super_class@protocol_names in
super_classes super_classes
@ -138,7 +138,7 @@ let add_class_to_tenv type_ptr_to_sil_type tenv curr_class decl_info class_name
IList.iter (fun (fn, ft, _) -> IList.iter (fun (fn, ft, _) ->
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 interface_type_info = let interface_type_info =
Sil.Tstruct(fields, [], Sil.Class, Some (Mangled.from_string class_name), Sil.Tstruct(fields, [], Csu.Class, Some (Mangled.from_string class_name),
superclasses, methods, objc_class_annotation) in superclasses, methods, objc_class_annotation) in
Sil.tenv_add tenv interface_name interface_type_info; Sil.tenv_add tenv interface_name interface_type_info;
Printing.log_out Printing.log_out
@ -150,13 +150,15 @@ let add_class_to_tenv type_ptr_to_sil_type tenv curr_class decl_info class_name
let add_missing_methods tenv class_name decl_info decl_list curr_class = let add_missing_methods tenv class_name decl_info decl_list curr_class =
let methods = ObjcProperty_decl.get_methods curr_class decl_list in let methods = ObjcProperty_decl.get_methods curr_class decl_list in
let class_tn_name = Sil.TN_csu (Sil.Class, (Mangled.from_string class_name)) in let class_tn_name = Sil.TN_csu (Csu.Class, (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 (Sil.Tvar class_tn_name); Ast_utils.update_sil_types_map decl_key (Sil.Tvar class_tn_name);
(match Sil.tenv_lookup tenv class_tn_name with (match Sil.tenv_lookup tenv class_tn_name with
| Some Sil.Tstruct(fields, [], Sil.Class, Some name, superclass, existing_methods, annotation) -> | Some Sil.Tstruct (fields, [], Csu.Class, Some name,
superclass, existing_methods, annotation) ->
let methods = General_utils.append_no_duplicates_methods existing_methods methods in let methods = General_utils.append_no_duplicates_methods existing_methods methods in
let typ = Sil.Tstruct(fields, [], Sil.Class, Some name, superclass, methods, annotation) in let typ =
Sil.Tstruct (fields, [], Csu.Class, Some name, superclass, methods, annotation) in
Sil.tenv_add tenv class_tn_name typ Sil.tenv_add tenv class_tn_name typ
| _ -> ()); | _ -> ());
Sil.Tvar class_tn_name Sil.Tvar class_tn_name

4
infer/src/clang/objcProtocol_decl.ml
Unescape View File

@ -28,12 +28,12 @@ let protocol_decl type_ptr_to_sil_type tenv decl =
(* It may turn out that we need a more specific treatment for protocols*) (* It may turn out that we need a more specific treatment for protocols*)
Printing.log_out "ADDING: ObjCProtocolDecl for '%s'\n" name; Printing.log_out "ADDING: ObjCProtocolDecl for '%s'\n" name;
let mang_name = Mangled.from_string name in let mang_name = Mangled.from_string name in
let protocol_name = Sil.TN_csu (Sil.Protocol, mang_name) in let protocol_name = Sil.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 (Sil.Tvar protocol_name); Ast_utils.update_sil_types_map decl_key (Sil.Tvar protocol_name);
let 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 = let protocol_type_info =
Sil.Tstruct ([], [], Sil.Protocol, Some mang_name, [], methods, []) in Sil.Tstruct ([], [], Csu.Protocol, Some mang_name, [], methods, []) in
Sil.tenv_add tenv protocol_name protocol_type_info; Sil.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;
Sil.Tvar protocol_name Sil.Tvar protocol_name

12
infer/src/harness/androidFramework.ml
Unescape View File

@ -253,7 +253,7 @@ let android_callbacks =
(* TODO (t4644852): factor out subtyping functions into some sort of JavaUtil module *) (* TODO (t4644852): factor out subtyping functions into some sort of JavaUtil module *)
let get_all_supertypes typ tenv = let get_all_supertypes typ tenv =
let get_direct_supers = function let get_direct_supers = function
| Sil.Tstruct (_, _, Sil.Class, _, supers, _, _) -> supers | Sil.Tstruct (_, _, Csu.Class, _, supers, _, _) -> supers
| _ -> [] in | _ -> [] in
let rec add_typ name typs = match Sil.get_typ name None tenv with let rec add_typ name typs = match Sil.get_typ name None tenv with
| Some typ -> get_supers_rec typ tenv (TypSet.add typ typs) | Some typ -> get_supers_rec typ tenv (TypSet.add typ typs)
@ -269,7 +269,7 @@ let is_subtype (typ0 : Sil.typ) (typ1 : Sil.typ) tenv =
let is_subtype_package_class typ package classname tenv = let is_subtype_package_class typ package classname tenv =
let classname = Mangled.from_package_class package classname in let classname = Mangled.from_package_class package classname in
match Sil.get_typ classname (Some Sil.Class) tenv with match Sil.get_typ classname (Some Csu.Class) tenv with
| Some found_typ -> is_subtype typ found_typ tenv | Some found_typ -> is_subtype typ found_typ tenv
| _ -> false | _ -> false
@ -292,7 +292,7 @@ let is_callback_class_name class_name = Mangled.MangledSet.mem class_name androi
let is_callback_class typ tenv = let is_callback_class typ tenv =
let supertyps = get_all_supertypes typ tenv in let supertyps = get_all_supertypes typ tenv in
TypSet.exists (fun typ -> match typ with TypSet.exists (fun typ -> match typ with
| Sil.Tstruct (_, _, Sil.Class, Some classname, _, _, _) -> | Sil.Tstruct (_, _, Csu.Class, Some classname, _, _, _) ->
is_callback_class_name classname is_callback_class_name classname
| _ -> false) supertyps | _ -> false) supertyps
@ -353,7 +353,7 @@ let is_callback_register_method procname args tenv =
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 lifecycle_typ lifecycle_proc_strs tenv = let get_lifecycle_for_framework_typ_opt lifecycle_typ lifecycle_proc_strs tenv =
match Sil.get_typ lifecycle_typ None tenv with match Sil.get_typ lifecycle_typ None tenv with
| Some (Sil.Tstruct(_, _, Sil.Class, Some class_name, _, decl_procs, _) as lifecycle_typ) -> | Some (Sil.Tstruct(_, _, Csu.Class, Some class_name, _, decl_procs, _) 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 ->
@ -377,8 +377,8 @@ let is_runtime_exception tenv exn =
let lookup = Sil.tenv_lookup tenv in let lookup = Sil.tenv_lookup tenv in
let runtime_exception_typename = let runtime_exception_typename =
let name = Mangled.from_package_class "java.lang" "RuntimeException" in let name = Mangled.from_package_class "java.lang" "RuntimeException" in
Sil.TN_csu (Sil.Class, name) Sil.TN_csu (Csu.Class, name)
and exn_typename = Sil.TN_csu (Sil.Class, exn) in and exn_typename = Sil.TN_csu (Csu.Class, exn) in
match lookup runtime_exception_typename, lookup exn_typename with match lookup runtime_exception_typename, lookup exn_typename with
| Some runtime_exception_type, Some exn_type -> | Some runtime_exception_type, Some exn_type ->
is_subtype exn_type runtime_exception_type tenv is_subtype exn_type runtime_exception_type tenv

6
infer/src/harness/harness.ml
Unescape View File

@ -118,7 +118,7 @@ let find_registered_callbacks lifecycle_trace harness_name proc_file_map tenv =
(** if [typ] is a lifecycle type, generate a list of (method call, receiver) pairs constituting a (** if [typ] is a lifecycle type, generate a list of (method call, receiver) pairs constituting a
lifecycle trace *) lifecycle trace *)
let try_create_lifecycle_trace typ lifecycle_typ lifecycle_procs proc_file_map tenv = match typ with let try_create_lifecycle_trace typ lifecycle_typ lifecycle_procs proc_file_map tenv = match typ with
| Sil.Tstruct(_, _, Sil.Class, Some class_name, _, methods, _) | Sil.Tstruct(_, _, Csu.Class, Some class_name, _, methods, _)
when AndroidFramework.typ_is_lifecycle_typ typ lifecycle_typ tenv && when AndroidFramework.typ_is_lifecycle_typ typ lifecycle_typ tenv &&
not (AndroidFramework.is_android_lib_class class_name) -> not (AndroidFramework.is_android_lib_class class_name) ->
let ptr_to_typ = Some (Sil.Tptr (typ, Sil.Pk_pointer)) in let ptr_to_typ = Some (Sil.Tptr (typ, Sil.Pk_pointer)) in
@ -140,10 +140,10 @@ let extract_callbacks lifecycle_trace harness_procname proc_file_map tenv =
let fields = IList.map (fun (fld, typ, _) -> (fld, typ, [])) registered_cbs in let fields = IList.map (fun (fld, typ, _) -> (fld, typ, [])) registered_cbs in
(* create a new typ for the harness containing all of the cb extraction vars as static fields *) (* create a new typ for the harness containing all of the cb extraction vars as static fields *)
let harness_typ = let harness_typ =
Sil.Tstruct (fields, [], Sil.Class, Some harness_name, [], [harness_procname], []) in Sil.Tstruct (fields, [], Csu.Class, Some harness_name, [], [harness_procname], []) in
(* update the tenv with our created harness typ. we don't have to save the tenv to disk here (* update the tenv with our created harness typ. we don't have to save the tenv to disk here
* because this is done immediately after harness generation runs in jMain.ml *) * because this is done immediately after harness generation runs in jMain.ml *)
let harness_class = Sil.TN_csu (Sil.Class, harness_name) in let harness_class = Sil.TN_csu (Csu.Class, harness_name) in
Sil.tenv_add tenv harness_class harness_typ; Sil.tenv_add tenv harness_class harness_typ;
let cfgs_to_save = let cfgs_to_save =
IList.fold_left (fun cfgs_to_save (_, _, instrument_sil_f) -> IList.fold_left (fun cfgs_to_save (_, _, instrument_sil_f) ->

4
infer/src/harness/inhabit.ml
Unescape View File

@ -108,7 +108,7 @@ let rec inhabit_typ typ proc_file_map env =
(* select methods that are constructors and won't force us into infinite recursion because (* select methods that are constructors and won't force us into infinite recursion because
* we are already inhabiting one of their argument types *) * we are already inhabiting one of their argument types *)
let get_all_suitable_constructors typ = match typ with let get_all_suitable_constructors typ = match typ with
| Sil.Tstruct (_, _, Sil.Class, _, superclasses, methods, _) -> | Sil.Tstruct (_, _, Csu.Class, _, superclasses, 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 =
try get_non_receiver_formals (formals_from_name p proc_file_map) try get_non_receiver_formals (formals_from_name p proc_file_map)
@ -205,7 +205,7 @@ let inhabit_fld_trace flds proc_file_map env =
Sil.Letderef (lhs, fld_exp, fld_typ, env.pc) in Sil.Letderef (lhs, fld_exp, fld_typ, env.pc) in
let env = env_add_instr fld_read_instr [lhs] env in let env = env_add_instr fld_read_instr [lhs] env in
match fld_typ with match fld_typ with
| Sil.Tptr (Sil.Tstruct (_, _, Sil.Class, _, _, procs, _), _) -> | Sil.Tptr (Sil.Tstruct (_, _, Csu.Class, _, _, procs, _), _) ->
let inhabit_cb_call procname env = let inhabit_cb_call procname env =
try try
let procdesc = procdesc_from_name procname proc_file_map in let procdesc = procdesc_from_name procname proc_file_map in

4
infer/src/harness/stacktrace.ml
Unescape View File

@ -42,8 +42,8 @@ let try_resolve_frame str_frame exe_env tenv =
(* find the class name in the tenv and get the procedure(s) whose names match the procedure name (* find the class name in the tenv and get the procedure(s) whose names match the procedure name
* in the stack trace. Note that the stack trace does not have any type or argument information; * in the stack trace. Note that the stack trace does not have any type or argument information;
* the name is all that we have to go on *) * the name is all that we have to go on *)
match Sil.tenv_lookup tenv (Sil.TN_csu (Sil.Class, class_name)) with match Sil.tenv_lookup tenv (Sil.TN_csu (Csu.Class, class_name)) with
| Some Sil.Tstruct (_, _, Sil.Class, _, _, decl_procs, _) -> | Some Sil.Tstruct (_, _, Csu.Class, _, _, decl_procs, _) ->
let possible_calls = let possible_calls =
IList.filter IList.filter
(fun proc -> Procname.java_get_method proc = str_frame.method_str) (fun proc -> Procname.java_get_method proc = str_frame.method_str)

2
infer/src/java/jTrans.ml
Unescape View File

@ -107,7 +107,7 @@ let retrieve_fieldname fieldname =
let get_field_name program static tenv cn fs context = let get_field_name program static tenv cn fs context =
match JTransType.get_class_type_no_pointer program tenv cn with match JTransType.get_class_type_no_pointer program tenv cn with
| Sil.Tstruct (fields, sfields, Sil.Class, _, _, _, _) -> | Sil.Tstruct (fields, sfields, Csu.Class, _, _, _, _) ->
let fieldname, _, _ = let fieldname, _, _ =
try try
IList.find IList.find

16
infer/src/java/jTransType.ml
Unescape View File

@ -59,7 +59,7 @@ let const_type const =
let typename_of_classname cn = let typename_of_classname cn =
Sil.TN_csu (Sil.Class, (Mangled.from_string (JBasics.cn_name cn))) Sil.TN_csu (Csu.Class, (Mangled.from_string (JBasics.cn_name cn)))
let rec get_named_type vt = let rec get_named_type vt =
@ -91,7 +91,7 @@ let rec create_array_type typ dim =
let extract_cn_no_obj typ = let extract_cn_no_obj typ =
match typ with match typ with
| Sil.Tptr (Sil.Tstruct (_, _, Sil.Class, Some classname, _, _, _), Sil.Pk_pointer) -> | Sil.Tptr (Sil.Tstruct (_, _, Csu.Class, Some classname, _, _, _), Sil.Pk_pointer) ->
let class_name = (Mangled.to_string classname) in let class_name = (Mangled.to_string classname) in
if class_name = JConfig.object_cl then None if class_name = JConfig.object_cl then None
else else
@ -239,7 +239,7 @@ let collect_interface_field cn inf l =
let dummy_type cn = let dummy_type cn =
let classname = Mangled.from_string (JBasics.cn_name cn) in let classname = Mangled.from_string (JBasics.cn_name cn) in
Sil.Tstruct ([], [], Sil.Class, Some classname, [], [], Sil.item_annotation_empty) Sil.Tstruct ([], [], Csu.Class, Some classname, [], [], Sil.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 =
@ -311,7 +311,10 @@ and create_sil_type program tenv cn =
match node with match node with
| Javalib.JInterface jinterface -> | Javalib.JInterface jinterface ->
let static_fields, _ = get_all_fields program tenv cn in let static_fields, _ = get_all_fields program tenv cn in
let sil_interface_list = IList.map (fun c -> (Sil.Class, c)) (create_super_list jinterface.Javalib.i_interfaces) in let sil_interface_list =
IList.map
(fun c -> (Csu.Class, c))
(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, [], static_fields, item_annotation)
| Javalib.JClass jclass -> | Javalib.JClass jclass ->
@ -330,11 +333,12 @@ and create_sil_type program tenv cn =
| _ -> assert false in | _ -> assert false in
super_classname :: interface_list in super_classname :: interface_list in
let super_sil_classname_list = let super_sil_classname_list =
IList.map (fun c -> (Sil.Class, c)) super_classname_list in IList.map (fun c -> (Csu.Class, c)) super_classname_list in
(super_sil_classname_list, nonstatic_fields, static_fields, item_annotation) in (super_sil_classname_list, nonstatic_fields, static_fields, item_annotation) in
let classname = Mangled.from_string (JBasics.cn_name cn) in let classname = Mangled.from_string (JBasics.cn_name cn) in
let method_procnames = get_class_procnames cn node in let method_procnames = get_class_procnames cn node in
Sil.Tstruct (nonstatic_fields, static_fields, Sil.Class, Some classname, super_list, method_procnames, item_annotation) Sil.Tstruct (nonstatic_fields, static_fields, Csu.Class,
Some classname, super_list, method_procnames, item_annotation)
and get_class_type_no_pointer program tenv cn = and get_class_type_no_pointer program tenv cn =

Write Preview
Loading…
Cancel
Save