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

[clang frontend] Simplify logging functions.

Browse Source
master
Cristiano Calcagno 10 years ago
parent 10970c4f51
commit 3a51764d4c
22 changed files with 245 additions and 250 deletions
Show Stats Download Patch File Download Diff File

6
infer/src/clang/cArithmetic_trans.ml
Unescape View File

@ -85,7 +85,7 @@ let binary_operation_instruction context boi e1 typ e2 loc rhs_owning_method =
(* These should be treated by compound_assignment_binary_operation_instruction*) (* These should be treated by compound_assignment_binary_operation_instruction*)
| bok -> | bok ->
Printing.log_stats Printing.log_stats
~fmt:"\nWARNING: Missing translation for Binary Operator Kind %s. Construct ignored...\n" "\nWARNING: Missing translation for Binary Operator Kind %s. Construct ignored...\n"
(Clang_ast_j.string_of_binary_operator_kind bok); (Clang_ast_j.string_of_binary_operator_kind bok);
(Sil.exp_minus_one, [], []) (Sil.exp_minus_one, [], [])
@ -128,7 +128,7 @@ let compound_assignment_binary_operation_instruction boi e1 typ e2 loc =
(e1, [Sil.Set (e1, typ, e1_xor_e2, loc)]) (e1, [Sil.Set (e1, typ, e1_xor_e2, loc)])
| bok -> | bok ->
Printing.log_stats Printing.log_stats
~fmt:"\nWARNING: Missing translation for CompoundAssignment Binary Operator Kind %s. Construct ignored...\n" "\nWARNING: Missing translation for CompoundAssignment Binary Operator Kind %s. Construct ignored...\n"
(Clang_ast_j.string_of_binary_operator_kind bok); (Clang_ast_j.string_of_binary_operator_kind bok);
(Sil.exp_minus_one, []) in (Sil.exp_minus_one, []) in
([id], e_res, instr1:: instr_op) ([id], e_res, instr1:: instr_op)
@ -168,7 +168,7 @@ let unary_operation_instruction uoi e typ loc =
| `AddrOf -> ([], e, []) | `AddrOf -> ([], e, [])
| `Real | `Imag | `Extension -> | `Real | `Imag | `Extension ->
Printing.log_stats Printing.log_stats
~fmt:"\nWARNING: Missing translation for Unary Operator Kind %s. The construct has been ignored...\n" uok; "\nWARNING: Missing translation for Unary Operator Kind %s. The construct has been ignored...\n" uok;
([], e, []) ([], e, [])
let bin_op_to_string boi = let bin_op_to_string boi =

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

@ -81,7 +81,7 @@ struct
let var_name = Mangled.from_string name in let var_name = Mangled.from_string name in
let global_var = CGlobal_vars.find var_name in let global_var = CGlobal_vars.find var_name in
let var = CGlobal_vars.var_get_name global_var in let var = CGlobal_vars.var_get_name global_var in
Printing.log_out ~fmt:" ...Variable '%s' found in globals!!\n" (Sil.pvar_to_string var); Printing.log_out " ...Variable '%s' found in globals!!@\n" (Sil.pvar_to_string var);
let typ = CGlobal_vars.var_get_typ global_var in let typ = CGlobal_vars.var_get_typ global_var in
var, typ var, typ
@ -99,36 +99,36 @@ struct
let print_stack var_name stack = let print_stack var_name stack =
Stack.iter Stack.iter
(fun (var_name, typ, level) -> (fun (var_name, typ, level) ->
Printing.log_out ~fmt:"var item %s:" (Mangled.to_string var_name); Printing.log_out "var item %s:" (Mangled.to_string var_name);
Printing.log_out ~fmt:"%s" (Sil.typ_to_string typ); Printing.log_out "%s" (Sil.typ_to_string typ);
Printing.log_out ~fmt:"- %s \n%!" (string_of_int level)) stack in Printing.log_out "- %s @." (string_of_int level)) stack in
Printing.log_out "LOCAL VARS:%s\n"; Printing.log_out "LOCAL VARS:@\n";
StringMap.iter print_stack context.local_vars_stack StringMap.iter print_stack context.local_vars_stack
let print_pointer_vars context = let print_pointer_vars context =
let print_pointer_var pointer var = let print_pointer_var pointer var =
Printing.log_out ~fmt:"%s ->" pointer; Printing.log_out "%s ->" pointer;
Printing.log_out ~fmt:" %s\n" (Sil.pvar_to_string var) in Printing.log_out " %s@\n" (Sil.pvar_to_string var) in
Printing.log_out "POINTER VARS:\n"; Printing.log_out "POINTER VARS:@\n";
StringMap.iter print_pointer_var context.local_vars_pointer StringMap.iter print_pointer_var context.local_vars_pointer
let add_pointer_var pointer var context = let add_pointer_var pointer var context =
Printing.log_out ~fmt:" ...Adding pointer '%s' " pointer; Printing.log_out " ...Adding pointer '%s' " pointer;
Printing.log_out ~fmt:"to the map with variable '%s'\n%!" (Sil.pvar_to_string var); Printing.log_out "to the map with variable '%s'@." (Sil.pvar_to_string var);
context.local_vars_pointer <- StringMap.add pointer var context.local_vars_pointer context.local_vars_pointer <- StringMap.add pointer var context.local_vars_pointer
let find_var_with_pointer context pointer = let find_var_with_pointer context pointer =
try try
StringMap.find pointer context.local_vars_pointer StringMap.find pointer context.local_vars_pointer
with Not_found -> with Not_found ->
(Printing.log_err ~fmt:" ...Variable for pointer %s not found!!\n%!" pointer); (Printing.log_err " ...Variable for pointer %s not found!!\n%!" pointer);
print_pointer_vars context; print_pointer_vars context;
assert false assert false
let lookup_var_locals context procname var_name = let lookup_var_locals context procname var_name =
let stack = lookup_var_map context var_name in let stack = lookup_var_map context var_name in
let (var_name, typ, level) = Stack.top stack in let (var_name, typ, level) = Stack.top stack in
Printing.log_out ~fmt:" ...Variable %s found in locals!!\n%!" (Mangled.to_string var_name); Printing.log_out " ...Variable %s found in locals!!@." (Mangled.to_string var_name);
(Sil.mk_pvar var_name procname), typ (Sil.mk_pvar var_name procname), typ
let lookup_var context pointer var_name kind = let lookup_var context pointer var_name kind =
@ -144,7 +144,7 @@ struct
try (* if it's a captured variable we need to look at the parameters list*) try (* if it's a captured variable we need to look at the parameters list*)
Some (fst (lookup_var_formals context procname var_name)) Some (fst (lookup_var_formals context procname var_name))
with Not_found -> with Not_found ->
Printing.log_err ~fmt:"Variable %s not found!!\n%!" var_name; Printing.log_err "Variable %s not found!!\n%!" var_name;
print_locals context; print_locals context;
None None
else None else None
@ -153,19 +153,19 @@ struct
Some (fst (lookup_var_formals context procname var_name)) Some (fst (lookup_var_formals context procname var_name))
with Not_found -> with Not_found ->
let list_to_string = list_to_string (fun (a, typ) -> a^":"^(Sil.typ_to_string typ)) in let list_to_string = list_to_string (fun (a, typ) -> a^":"^(Sil.typ_to_string typ)) in
Printing.log_err ~fmt:"Warning: Parameter %s not found!!\n%!" var_name; Printing.log_err "Warning: Parameter %s not found!!\n%!" var_name;
Printing.log_err ~fmt:"Formals of procdesc %s" (Procname.to_string procname); Printing.log_err "Formals of procdesc %s" (Procname.to_string procname);
Printing.log_err ~fmt:" are %s\n%!" (list_to_string (Cfg.Procdesc.get_formals context.procdesc)); Printing.log_err " are %s\n%!" (list_to_string (Cfg.Procdesc.get_formals context.procdesc));
Printing.print_failure_info pointer; Printing.print_failure_info pointer;
assert false assert false
else if (kind = `Function || kind = `ImplicitParam) then ( else if (kind = `Function || kind = `ImplicitParam) then (
(* ImplicitParam are 'self' and '_cmd'. These are never defined but they can be referred to in the code. *) (* ImplicitParam are 'self' and '_cmd'. These are never defined but they can be referred to in the code. *)
Printing.log_err ~fmt:"Creating a variable for '%s' \n%!" var_name; Printing.log_err "Creating a variable for '%s' \n%!" var_name;
Some (Sil.mk_pvar (Mangled.from_string var_name) procname)) Some (Sil.mk_pvar (Mangled.from_string var_name) procname))
else if (kind = `EnumConstant) then else if (kind = `EnumConstant) then
(Printing.print_failure_info pointer; (Printing.print_failure_info pointer;
assert false) assert false)
else (Printing.log_err ~fmt:"WARNING: In lookup_var kind %s not handled. Giving up!\n%!" (Clang_ast_j.string_of_decl_kind kind); else (Printing.log_err "WARNING: In lookup_var kind %s not handled. Giving up!\n%!" (Clang_ast_j.string_of_decl_kind kind);
Printing.print_failure_info pointer; Printing.print_failure_info pointer;
assert false) assert false)
@ -173,8 +173,8 @@ struct
Mangled.mangled name ((string_of_int(Block.depth ()))) Mangled.mangled name ((string_of_int(Block.depth ())))
let add_local_var context var_name typ pointer is_static = let add_local_var context var_name typ pointer is_static =
Printing.log_out ~fmt:" ...Creating var %s" var_name; Printing.log_out " ...Creating var %s" var_name;
Printing.log_out ~fmt:" with pointer %s\n" pointer; Printing.log_out " with pointer %s@\n" pointer;
if not (is_global_var context var_name) || is_static then if not (is_global_var context var_name) || is_static then
let var = get_variable_name var_name in let var = get_variable_name var_name in
context.local_vars <- context.local_vars@[(var, typ, is_static)] ; context.local_vars <- context.local_vars@[(var, typ, is_static)] ;

10
infer/src/clang/cEnum_decl.ml
Unescape View File

@ -45,7 +45,7 @@ let rec get_enum_constants context decl_list v =
| [] -> [] | [] -> []
| EnumConstantDecl(decl_info, name, qual_type, enum_constant_decl_info) :: decl_list' -> | EnumConstantDecl(decl_info, name, qual_type, enum_constant_decl_info) :: decl_list' ->
(match enum_constant_decl_info.Clang_ast_t.ecdi_init_expr with (match enum_constant_decl_info.Clang_ast_t.ecdi_init_expr with
| None -> Printing.log_out (" ...Defining Enum Constant ("^name^", "^(string_of_int v)); | None -> Printing.log_out "%s" (" ...Defining Enum Constant ("^name^", "^(string_of_int v));
(Mangled.from_string name, Sil.Cint (Sil.Int.of_int v)) (Mangled.from_string name, Sil.Cint (Sil.Int.of_int v))
:: get_enum_constants context decl_list' (v + 1) :: get_enum_constants context decl_list' (v + 1)
| Some stmt -> | Some stmt ->
@ -55,13 +55,13 @@ let rec get_enum_constants context decl_list v =
| Sil.Const c -> c | Sil.Const c -> c
| _ -> (* This is a hack to avoid failing in some strange definition of Enum *) | _ -> (* This is a hack to avoid failing in some strange definition of Enum *)
Sil.Cint Sil.Int.zero) in Sil.Cint Sil.Int.zero) in
Printing.log_out ~fmt:" ...Defining Enum Constant ('%s', " name; Printing.log_out " ...Defining Enum Constant ('%s', " name;
Printing.log_out ~fmt:"'%s')\n" (Sil.exp_to_string (Sil.Const const)); Printing.log_out "'%s')\n" (Sil.exp_to_string (Sil.Const const));
(Mangled.from_string name, const) :: get_enum_constants context decl_list' v) (Mangled.from_string name, const) :: get_enum_constants context decl_list' v)
| _ -> assert false | _ -> assert false
let enum_decl name tenv cfg cg namespace decl_list opt_type = let enum_decl name tenv cfg cg namespace decl_list opt_type =
Printing.log_out ~fmt:"ADDING: EnumDecl '%s'\n" name; Printing.log_out "ADDING: EnumDecl '%s'\n" name;
let context' = let context' =
CContext.create_context tenv cg cfg !global_procdesc namespace CContext.ContextNoCls CContext.create_context tenv cg cfg !global_procdesc namespace CContext.ContextNoCls
false [] false in false [] false in
@ -72,5 +72,5 @@ let enum_decl name tenv cfg cg namespace decl_list opt_type =
(* Here we could give "enum "^name but I want to check that this the type is always defined *) (* Here we could give "enum "^name but I want to check that this the type is always defined *)
let typename = Sil.TN_enum (Mangled.from_string name) in let typename = Sil.TN_enum (Mangled.from_string name) in
let typ = Sil.Tenum enum_constants in let typ = Sil.Tenum enum_constants in
Printing.log_out ~fmt:" TN_typename('%s')\n" (Sil.typename_to_string typename); Printing.log_out " TN_typename('%s')\n" (Sil.typename_to_string typename);
Sil.tenv_add tenv typename typ Sil.tenv_add tenv typename typ

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

@ -16,7 +16,7 @@ let mk_class_field_name class_name field_name =
Ident.create_fieldname (Mangled.mangled field_name (class_name^"_"^field_name)) 0 Ident.create_fieldname (Mangled.mangled field_name (class_name^"_"^field_name)) 0
let rec get_fields_super_classes tenv super_class = let rec get_fields_super_classes tenv super_class =
Printing.log_out ~fmt:" ... 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, _, _, _, (Sil.Class, sc):: _, _, _) ->
@ -37,8 +37,8 @@ let get_field_www name_field fl =
let rec scan_fields nn ll = let rec scan_fields nn ll =
match ll with match ll with
| [] -> [] | [] -> []
| (n, t, _):: ll' -> Printing.log_out ~fmt:">>>>>Searching for field '%s'." (Ident.fieldname_to_string n); | (n, t, _):: ll' -> Printing.log_out ">>>>>Searching for field '%s'." (Ident.fieldname_to_string n);
Printing.log_out ~fmt:" Seen '%s'.\n" nn; Printing.log_out " Seen '%s'.\n" nn;
if (Ident.fieldname_to_string n) = nn then if (Ident.fieldname_to_string n) = nn then
[(n, t)] [(n, t)]
else scan_fields nn ll' in else scan_fields nn ll' in
@ -58,15 +58,15 @@ let rec build_sil_field tenv class_name field_name qual_type prop_atts =
let ivar_property curr_class ivar = let ivar_property curr_class ivar =
match ObjcProperty_decl.Property.find_property_name_from_ivar curr_class ivar with match ObjcProperty_decl.Property.find_property_name_from_ivar curr_class ivar with
| Some pname' -> | Some pname' ->
(Printing.log_out ~fmt: "Found property name from ivar: '%s'" pname'; (Printing.log_out "Found property name from ivar: '%s'" pname';
try try
let _, atts, _, _, _, _ = ObjcProperty_decl.Property.find_property curr_class pname' in let _, atts, _, _, _, _ = ObjcProperty_decl.Property.find_property curr_class pname' in
let atts_str = list_map Clang_ast_j.string_of_property_attribute atts in let atts_str = list_map Clang_ast_j.string_of_property_attribute atts in
Some atts_str Some atts_str
with Not_found -> with Not_found ->
Printing.log_out ~fmt: "Didn't find property for pname '%s'" pname'; Printing.log_out "Didn't find property for pname '%s'" pname';
None) None)
| None -> Printing.log_out ~fmt: "Didn't find property for ivar '%s'" ivar; | None -> Printing.log_out "Didn't find property for ivar '%s'" ivar;
None None
(* Given a list of declarations in an interface returns a list of fields *) (* Given a list of declarations in an interface returns a list of fields *)
@ -78,12 +78,12 @@ let rec get_fields tenv curr_class decl_list =
let fields = get_fields tenv curr_class decl_list' in let fields = get_fields tenv curr_class decl_list' in
(* Doing a post visit here. Adding Ivar after all the declaration have been visited so that *) (* Doing a post visit here. Adding Ivar after all the declaration have been visited so that *)
(* ivar names will be added in the property list. *) (* ivar names will be added in the property list. *)
Printing.log_out ~fmt:" ...Adding Instance Variable '%s' \n" field_name; Printing.log_out " ...Adding Instance Variable '%s' \n" field_name;
let prop_attributes = ivar_property curr_class field_name in let prop_attributes = ivar_property curr_class field_name in
let (fname, typ, ia) = build_sil_field tenv class_name field_name qual_type prop_attributes in let (fname, typ, ia) = build_sil_field tenv class_name field_name qual_type prop_attributes in
Printing.log_out ~fmt:" ...Resulting sil field: (%s) with attributes:\n" ((Ident.fieldname_to_string fname) ^":"^(Sil.typ_to_string typ)); Printing.log_out " ...Resulting sil field: (%s) with attributes:\n" ((Ident.fieldname_to_string fname) ^":"^(Sil.typ_to_string typ));
list_iter (fun (ia', _) -> list_iter (fun (ia', _) ->
list_iter (fun a -> Printing.log_out ~fmt: " '%s' \n" a) ia'.Sil.parameters) ia; list_iter (fun a -> Printing.log_out " '%s' \n" a) ia'.Sil.parameters) ia;
(fname, typ, ia):: fields (fname, typ, ia):: fields
| ObjCPropertyImplDecl(decl_info, property_impl_decl_info):: decl_list' -> | ObjCPropertyImplDecl(decl_info, property_impl_decl_info):: decl_list' ->

6
infer/src/clang/cFrontend.ml
Unescape View File

@ -75,7 +75,7 @@ let rec translate_one_declaration tenv cg cfg namespace dec =
| EmptyDecl _ -> | EmptyDecl _ ->
Printing.log_out "Passing from EmptyDecl. Treated as skip\n"; Printing.log_out "Passing from EmptyDecl. Treated as skip\n";
| dec -> | dec ->
Printing.log_stats ~fmt:"\nWARNING: found Declaration %s skipped\n" (Ast_utils.string_of_decl dec) Printing.log_stats "\nWARNING: found Declaration %s skipped\n" (Ast_utils.string_of_decl dec)
(** Preprocess declarations to create method signatures of function declarations. *) (** Preprocess declarations to create method signatures of function declarations. *)
let preprocess_one_declaration tenv cg cfg dec = let preprocess_one_declaration tenv cg cfg dec =
@ -117,10 +117,10 @@ let do_source_file source_file ast =
init_global_state source_file; init_global_state source_file;
CLocation.init_curr_source_file source_file; CLocation.init_curr_source_file source_file;
Config.nLOC := FileLOC.file_get_loc (DB.source_file_to_string source_file); Config.nLOC := FileLOC.file_get_loc (DB.source_file_to_string source_file);
Printing.log_out ~fmt:"\n Start building call/cfg graph for '%s'....\n" Printing.log_out "\n Start building call/cfg graph for '%s'....\n"
(DB.source_file_to_string source_file); (DB.source_file_to_string source_file);
let call_graph, cfg = compute_icfg tenv (DB.source_file_to_string source_file) ast in let call_graph, cfg = compute_icfg tenv (DB.source_file_to_string source_file) ast in
Printing.log_out ~fmt:"\n End building call/cfg graph for '%s'.\n" Printing.log_out "\n End building call/cfg graph for '%s'.\n"
(DB.source_file_to_string source_file); (DB.source_file_to_string source_file);
(* This part below is a boilerplate in every frontends. *) (* This part below is a boilerplate in every frontends. *)
(* This could be moved in the cfg_infer module *) (* This could be moved in the cfg_infer module *)

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

@ -14,27 +14,20 @@ module F = Format
module Printing = module Printing =
struct struct
let log_out ?fmt s = let log_out fmt =
if !CFrontend_config.debug_mode then let pp = if !CFrontend_config.debug_mode then Format.fprintf else Format.ifprintf in
match fmt with pp Format.std_formatter fmt
| Some fmt' ->
Format.printf fmt' s let log_err fmt =
| None -> Format.printf "%s" s let pp = if !CFrontend_config.debug_mode then Format.fprintf else Format.ifprintf in
pp Format.err_formatter fmt
let log_err ?fmt s =
if !CFrontend_config.debug_mode then let log_stats fmt =
match fmt with let pp =
| Some fmt' -> if !CFrontend_config.stats_mode || !CFrontend_config.debug_mode
Format.eprintf fmt' s then Format.fprintf else Format.ifprintf in
| None -> Format.eprintf "%s" s pp Format.std_formatter fmt
let log_stats ?fmt s =
if !CFrontend_config.stats_mode ||
!CFrontend_config.debug_mode then
match fmt with
| Some fmt' ->
Format.printf fmt' s
| None -> Format.eprintf "%s" s
let print_tenv tenv = let print_tenv tenv =
Sil.tenv_iter (fun typname typ -> Sil.tenv_iter (fun typname typ ->
@ -237,10 +230,10 @@ struct
pointer_counter := !pointer_counter + 1; pointer_counter := !pointer_counter + 1;
CFrontend_config.pointer_prefix^(string_of_int (!pointer_counter)) CFrontend_config.pointer_prefix^(string_of_int (!pointer_counter))
let type_from_unary_expr_or_type_trait_expr_info info = let type_from_unary_expr_or_type_trait_expr_info info =
match info.uttei_qual_type with match info.uttei_qual_type with
| Some qt -> Some qt | Some qt -> Some qt
| None -> None | None -> None
end end
@ -309,8 +302,8 @@ struct
| Some sc -> sc = CFrontend_config.static | Some sc -> sc = CFrontend_config.static
| _ -> false | _ -> false
let block_procname_with_index defining_proc i = let block_procname_with_index defining_proc i =
Config.anonymous_block_prefix^(Procname.to_string defining_proc)^Config.anonymous_block_num_sep^(string_of_int i) Config.anonymous_block_prefix^(Procname.to_string defining_proc)^Config.anonymous_block_num_sep^(string_of_int i)
(* Makes a fresh name for a block defined inside the defining procedure.*) (* Makes a fresh name for a block defined inside the defining procedure.*)
(* It updates the global block_counter *) (* It updates the global block_counter *)
@ -318,8 +311,8 @@ let block_procname_with_index defining_proc i =
let name = block_procname_with_index defining_proc (get_fresh_block_index ()) in let name = block_procname_with_index defining_proc (get_fresh_block_index ()) in
Procname.mangled_objc_block name Procname.mangled_objc_block name
(* Returns the next fresh name for a block defined inside the defining procedure *) (* Returns the next fresh name for a block defined inside the defining procedure *)
(* It does not update the global block_counter *) (* It does not update the global block_counter *)
let get_next_block_pvar defining_proc = let get_next_block_pvar defining_proc =
let name = block_procname_with_index defining_proc (!block_counter +1) in let name = block_procname_with_index defining_proc (!block_counter +1) in
Sil.mk_pvar (Mangled.from_string (CFrontend_config.temp_var^"_"^name)) defining_proc Sil.mk_pvar (Mangled.from_string (CFrontend_config.temp_var^"_"^name)) defining_proc

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

@ -10,11 +10,11 @@ open Clang_ast_t
module Printing : module Printing :
sig sig
val log_out : ?fmt: (string -> unit, Format.formatter, unit) format -> string -> unit val log_out : ('a, Format.formatter, unit) format -> 'a
val log_err : ?fmt: (string -> unit, Format.formatter, unit) format -> string -> unit val log_err : ('a, Format.formatter, unit) format -> 'a
val log_stats : ?fmt: (string -> unit, Format.formatter, unit) format -> string -> unit val log_stats : ('a, Format.formatter, unit) format -> 'a
val print_failure_info : string -> unit val print_failure_info : string -> unit

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

@ -32,7 +32,7 @@ let make_var name typ =
let add name typ = let add name typ =
let name = (Mangled.from_string name) in let name = (Mangled.from_string name) in
let pvar = Sil.mk_pvar_global name in let pvar = Sil.mk_pvar_global name in
Printing.log_out ~fmt:"Adding global variable %s !!\n%!" (Sil.pvar_to_string pvar); Printing.log_out "Adding global variable %s !!@." (Sil.pvar_to_string pvar);
let var_el = make_var pvar typ in let var_el = make_var pvar typ in
varMap := MangledMap.add name var_el !varMap varMap := MangledMap.add name var_el !varMap

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

@ -122,7 +122,7 @@ let check_source_file source_file =
let extensions_allowed = [".m"; ".mm"; ".c"; ".cc"; ".cpp"; ".h"] in let extensions_allowed = [".m"; ".mm"; ".c"; ".cc"; ".cpp"; ".h"] in
let allowed = list_exists (fun ext -> Filename.check_suffix source_file ext) extensions_allowed in let allowed = list_exists (fun ext -> Filename.check_suffix source_file ext) extensions_allowed in
if not allowed then if not allowed then
(Printing.log_stats (Printing.log_stats "%s"
("\nThe source file "^source_file^ ("\nThe source file "^source_file^
" should end with "^(Utils.list_to_string (fun x -> x) extensions_allowed)^"\n\n"); " should end with "^(Utils.list_to_string (fun x -> x) extensions_allowed)^"\n\n");
assert false) assert false)

6
infer/src/clang/cMain.ml
Unescape View File

@ -101,8 +101,8 @@ let do_run source_path ast_path =
| None -> "stdin of " ^ source_path, validate_decl_from_stdin () in | None -> "stdin of " ^ source_path, validate_decl_from_stdin () in
let ast_decl' = CAstProcessor.preprocess_ast_decl ast_decl in let ast_decl' = CAstProcessor.preprocess_ast_decl ast_decl in
L.stdout "Original AST@.%a@." CAstProcessor.pp_ast_decl ast_decl; Printing.log_out "Original AST@.%a@." CAstProcessor.pp_ast_decl ast_decl;
L.stdout "AST with explicit locations:@.%a@." CAstProcessor.pp_ast_decl ast_decl'; Printing.log_out "AST with explicit locations:@.%a@." CAstProcessor.pp_ast_decl ast_decl';
CFrontend_config.json := ast_filename; CFrontend_config.json := ast_filename;
@ -112,7 +112,7 @@ let do_run source_path ast_path =
CFrontend.do_source_file source_file ast_decl'; CFrontend.do_source_file source_file ast_decl';
print_endline ("End translation AST file " ^ !CFrontend_config.json ^ "... OK!") print_endline ("End translation AST file " ^ !CFrontend_config.json ^ "... OK!")
with with
(Yojson.Json_error s) as exc -> Printing.log_err ~fmt:"%s\n" s; (Yojson.Json_error s) as exc -> Printing.log_err "%s\n" s;
raise exc raise exc
let _ = let _ =

14
infer/src/clang/cMethod_decl.ml
Unescape View File

@ -48,8 +48,8 @@ struct
let par_to_ms_par par = let par_to_ms_par par =
match par with match par with
| ParmVarDecl(decl_info, name, qtype, var_decl_info) -> | ParmVarDecl(decl_info, name, qtype, var_decl_info) ->
Printing.log_out ~fmt:"Adding param '%s' " name; Printing.log_out "Adding param '%s' " name;
Printing.log_out ~fmt:"with pointer %s@." decl_info.Clang_ast_t.di_pointer; Printing.log_out "with pointer %s@." decl_info.Clang_ast_t.di_pointer;
(name, CTypes.get_type qtype) (name, CTypes.get_type qtype)
| _ -> assert false in | _ -> assert false in
match function_method_decl_info with match function_method_decl_info with
@ -93,7 +93,7 @@ struct
let add_method tenv cg cfg class_decl_opt procname namespace instrs is_objc_method is_instance let add_method tenv cg cfg class_decl_opt procname namespace instrs is_objc_method is_instance
captured_vars is_anonym_block = captured_vars is_anonym_block =
Printing.log_out Printing.log_out
~fmt:"\n\n>>---------- ADDING METHOD: '%s' ---------<<\n" (Procname.to_string procname); "\n\n>>---------- ADDING METHOD: '%s' ---------<<\n" (Procname.to_string procname);
try try
(match Cfg.Procdesc.find_from_name cfg procname with (match Cfg.Procdesc.find_from_name cfg procname with
| Some procdesc -> | Some procdesc ->
@ -108,7 +108,7 @@ struct
Cfg.Procdesc.append_locals procdesc local_vars; Cfg.Procdesc.append_locals procdesc local_vars;
Cfg.Node.add_locals_ret_declaration start_node local_vars; Cfg.Node.add_locals_ret_declaration start_node local_vars;
Printing.log_out Printing.log_out
~fmt:"\n\n>>---------- Start translating the function: '%s' ---------<<" "\n\n>>---------- Start translating the function: '%s' ---------<<"
(Procname.to_string procname); (Procname.to_string procname);
let meth_body_nodes = T.instructions_trans context instrs exit_node in let meth_body_nodes = T.instructions_trans context instrs exit_node in
if (not is_anonym_block) then CContext.LocalVars.reset_block (); if (not is_anonym_block) then CContext.LocalVars.reset_block ();
@ -127,7 +127,7 @@ struct
() ()
let function_decl tenv cfg cg namespace is_instance di name qt fdecl_info captured_vars anonym_block_opt curr_class = let function_decl tenv cfg cg namespace is_instance di name qt fdecl_info captured_vars anonym_block_opt curr_class =
Printing.log_out ~fmt:"\nFound FunctionDecl '%s'. Processing...\n" name; Printing.log_out "\nFound FunctionDecl '%s'. Processing...\n" name;
Printing.log_out "\nResetting the goto_labels hashmap...\n"; Printing.log_out "\nResetting the goto_labels hashmap...\n";
CTrans_utils.GotoLabel.reset_all_labels (); (* C Language Std 6.8.6.1-1 *) CTrans_utils.GotoLabel.reset_all_labels (); (* C Language Std 6.8.6.1-1 *)
match create_function_signature di fdecl_info name qt is_instance anonym_block_opt with match create_function_signature di fdecl_info name qt is_instance anonym_block_opt with
@ -147,7 +147,7 @@ struct
let procname = CMethod_trans.mk_procname_from_method class_name method_name in let procname = CMethod_trans.mk_procname_from_method class_name method_name in
let method_decl = Meth_decl_info (method_decl_info, class_name) in let method_decl = Meth_decl_info (method_decl_info, class_name) in
let ms = build_method_signature decl_info procname method_decl false false in let ms = build_method_signature decl_info procname method_decl false false in
Printing.log_out ~fmt:" ....Processing implementation for method '%s'\n" (Procname.to_string procname); Printing.log_out " ....Processing implementation for method '%s'\n" (Procname.to_string procname);
(match method_body_to_translate decl_info ms method_decl_info.Clang_ast_t.omdi_body with (match method_body_to_translate decl_info ms method_decl_info.Clang_ast_t.omdi_body with
| Some body -> | Some body ->
let is_instance = CMethod_signature.ms_is_instance ms in let is_instance = CMethod_signature.ms_is_instance ms in
@ -167,7 +167,7 @@ struct
| EmptyDecl _ | ObjCIvarDecl _ -> () | EmptyDecl _ | ObjCIvarDecl _ -> ()
| d -> Printing.log_err | d -> Printing.log_err
~fmt:"\nWARNING: found Method Declaration '%s' skipped. NEED TO BE FIXED\n\n" (Ast_utils.string_of_decl d); "\nWARNING: found Method Declaration '%s' skipped. NEED TO BE FIXED\n\n" (Ast_utils.string_of_decl d);
() ()
let process_methods tenv cg cfg curr_class namespace decl_list = let process_methods tenv cg cfg curr_class namespace decl_list =

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

@ -49,12 +49,12 @@ let resolve_method tenv class_name method_name =
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 (Sil.Class, Mangled.from_string cname) in
Printing.log_out ~fmt:"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):: _, _, _) ->
Mangled.to_string super_name Mangled.to_string super_name
| _ -> | _ ->
Printing.log_err ~fmt:"NOT FOUND superclass = '%s'\n\n%!" (Sil.typename_to_string iname); Printing.log_err "NOT FOUND superclass = '%s'\n\n%!" (Sil.typename_to_string iname);
(match super_opt with (match super_opt with
| Some super -> super | Some super -> super
| _ -> assert false) in | _ -> assert false) in
@ -105,7 +105,7 @@ let captured_vars_from_block_info context cvl =
let find lv n = let find lv n =
try try
list_find (fun (n', _, _) -> Mangled.to_string n' = n) lv list_find (fun (n', _, _) -> Mangled.to_string n' = n) lv
with Not_found -> Printing.log_err ~fmt:"Trying to find variable %s@." n; assert false in with Not_found -> Printing.log_err "Trying to find variable %s@." n; assert false in
let rec f cvl' = let rec f cvl' =
match cvl' with match cvl' with
| [] -> [] | [] -> []
@ -117,7 +117,7 @@ let captured_vars_from_block_info context cvl =
if n = CFrontend_config.self && not context.is_instance then [] if n = CFrontend_config.self && not context.is_instance then []
else else
(let procdesc_formals = Cfg.Procdesc.get_formals context.procdesc in (let procdesc_formals = Cfg.Procdesc.get_formals context.procdesc in
(Printing.log_err ~fmt:"formals are %s@." (Utils.list_to_string (fun (x, _) -> x) procdesc_formals)); (Printing.log_err "formals are %s@." (Utils.list_to_string (fun (x, _) -> x) procdesc_formals));
let formals = list_map formal2captured procdesc_formals in let formals = list_map formal2captured procdesc_formals in
[find (context.local_vars @ formals) n]) [find (context.local_vars @ formals) n])
| _ -> assert false) | _ -> assert false)
@ -140,7 +140,7 @@ let create_local_procdesc cfg tenv ms fbody captured is_objc_inst_method =
(* Captured variables for blocks are treated as parameters *) (* Captured variables for blocks are treated as parameters *)
let formals = captured_str @formals in let formals = captured_str @formals in
let source_range = CMethod_signature.ms_get_loc ms in let source_range = CMethod_signature.ms_get_loc ms in
Printing.log_out ~fmt: Printing.log_out
"\n\n>>------------------------- Start creating a new procdesc for function: '%s' ---------<<\n" pname; "\n\n>>------------------------- Start creating a new procdesc for function: '%s' ---------<<\n" pname;
let loc_start = CLocation.get_sil_location_from_range source_range true in let loc_start = CLocation.get_sil_location_from_range source_range true in
let loc_exit = CLocation.get_sil_location_from_range source_range false in let loc_exit = CLocation.get_sil_location_from_range source_range false in
@ -183,7 +183,7 @@ let create_local_procdesc cfg tenv ms fbody captured is_objc_inst_method =
Cfg.Procdesc.set_exit_node procdesc exit_node) in Cfg.Procdesc.set_exit_node procdesc exit_node) in
match Cfg.Procdesc.find_from_name cfg procname with match Cfg.Procdesc.find_from_name cfg procname with
| Some prevoius_procdesc -> | Some prevoius_procdesc ->
Printing.log_err ~fmt:"\n\n!!!WARNING: procdesc for %s already defined \n" pname; Printing.log_err "\n\n!!!WARNING: procdesc for %s already defined \n" pname;
if defined && not (Cfg.Procdesc.is_defined prevoius_procdesc) then if defined && not (Cfg.Procdesc.is_defined prevoius_procdesc) then
(Cfg.Procdesc.remove cfg (Cfg.Procdesc.get_proc_name prevoius_procdesc) true; (Cfg.Procdesc.remove cfg (Cfg.Procdesc.get_proc_name prevoius_procdesc) true;
create_new_procdesc ()) create_new_procdesc ())

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

@ -75,9 +75,9 @@ struct
let item_annot = Sil.item_annotation_empty in let item_annot = Sil.item_annotation_empty in
fname, typ, item_annot in fname, typ, item_annot in
let fields = list_map mk_field_from_captured_var captured_vars in let fields = list_map mk_field_from_captured_var captured_vars in
Printing.log_out ~fmt:"Block %s field:\n" block_name; Printing.log_out "Block %s field:\n" block_name;
list_iter (fun (fn, ft, _) -> list_iter (fun (fn, ft, _) ->
Printing.log_out ~fmt:"-----> 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, [], Sil.Class, Some mblock, [], [], []) in
let block_name = Sil.TN_csu(Sil.Class, mblock) in let block_name = Sil.TN_csu(Sil.Class, mblock) in
@ -173,7 +173,7 @@ struct
| _ -> assert false | _ -> assert false
let stringLiteral_trans trans_state stmt_info expr_info str = let stringLiteral_trans trans_state stmt_info expr_info str =
Printing.log_out ~fmt:"Passing from StringLiteral '%s'\n" stmt_info.Clang_ast_t.si_pointer; Printing.log_out "Passing from StringLiteral '%s'\n" stmt_info.Clang_ast_t.si_pointer;
let typ = CTypes_decl.get_type_from_expr_info expr_info trans_state.context.tenv in let typ = CTypes_decl.get_type_from_expr_info expr_info trans_state.context.tenv in
let exp = Sil.Const (Sil.Cstr (str)) in let exp = Sil.Const (Sil.Cstr (str)) in
{ empty_res_trans with exps = [(exp, typ)]} { empty_res_trans with exps = [(exp, typ)]}
@ -183,7 +183,7 @@ struct
(* extension is typically only used by system headers, which define NULL as __null in C++ rather than using 0 *) (* extension is typically only used by system headers, which define NULL as __null in C++ rather than using 0 *)
(* (which is an integer that may not match the size of a pointer)". So we implement it as the constant zero *) (* (which is an integer that may not match the size of a pointer)". So we implement it as the constant zero *)
let gNUNullExpr_trans trans_state stmt_info expr_info = let gNUNullExpr_trans trans_state stmt_info expr_info =
Printing.log_out ~fmt:"Passing from GNUNullExpr '%s'\n" stmt_info.Clang_ast_t.si_pointer; Printing.log_out "Passing from GNUNullExpr '%s'\n" stmt_info.Clang_ast_t.si_pointer;
let typ = CTypes_decl.get_type_from_expr_info expr_info trans_state.context.tenv in let typ = CTypes_decl.get_type_from_expr_info expr_info trans_state.context.tenv in
let exp = Sil.Const (Sil.Cint (Sil.Int.zero)) in let exp = Sil.Const (Sil.Cint (Sil.Int.zero)) in
{ empty_res_trans with exps = [(exp, typ)]} { empty_res_trans with exps = [(exp, typ)]}
@ -192,24 +192,24 @@ struct
stringLiteral_trans trans_state stmt_info expr_info selector stringLiteral_trans trans_state stmt_info expr_info selector
let objCEncodeExpr_trans trans_state stmt_info expr_info qual_type = let objCEncodeExpr_trans trans_state stmt_info expr_info qual_type =
Printing.log_out ~fmt:"Passing from ObjCEncodeExpr '%s'\n" stmt_info.Clang_ast_t.si_pointer; Printing.log_out "Passing from ObjCEncodeExpr '%s'\n" stmt_info.Clang_ast_t.si_pointer;
stringLiteral_trans trans_state stmt_info expr_info (CTypes.get_type qual_type) stringLiteral_trans trans_state stmt_info expr_info (CTypes.get_type qual_type)
let objCProtocolExpr_trans trans_state stmt_info expr_info decl_ref = let objCProtocolExpr_trans trans_state stmt_info expr_info decl_ref =
Printing.log_out ~fmt:"Passing from ObjCProtocolExpr '%s'\n" stmt_info.Clang_ast_t.si_pointer; Printing.log_out "Passing from ObjCProtocolExpr '%s'\n" stmt_info.Clang_ast_t.si_pointer;
let name = (match decl_ref.Clang_ast_t.dr_name with let name = (match decl_ref.Clang_ast_t.dr_name with
| Some s -> s | Some s -> s
| _ -> "") in | _ -> "") in
stringLiteral_trans trans_state stmt_info expr_info name stringLiteral_trans trans_state stmt_info expr_info name
let characterLiteral_trans trans_state stmt_info expr_info n = let characterLiteral_trans trans_state stmt_info expr_info n =
Printing.log_out ~fmt:"Passing from CharacterLiteral '%s'\n" stmt_info.Clang_ast_t.si_pointer; Printing.log_out "Passing from CharacterLiteral '%s'\n" stmt_info.Clang_ast_t.si_pointer;
let typ = CTypes_decl.get_type_from_expr_info expr_info trans_state.context.tenv in let typ = CTypes_decl.get_type_from_expr_info expr_info trans_state.context.tenv in
let exp = Sil.Const (Sil.Cint (Sil.Int.of_int n)) in let exp = Sil.Const (Sil.Cint (Sil.Int.of_int n)) in
{ empty_res_trans with exps = [(exp, typ)]} { empty_res_trans with exps = [(exp, typ)]}
let floatingLiteral_trans trans_state stmt_info expr_info float_string = let floatingLiteral_trans trans_state stmt_info expr_info float_string =
Printing.log_out ~fmt:"Passing from FloatingLiteral '%s'\n" stmt_info.Clang_ast_t.si_pointer; Printing.log_out "Passing from FloatingLiteral '%s'\n" stmt_info.Clang_ast_t.si_pointer;
let typ = CTypes_decl.get_type_from_expr_info expr_info trans_state.context.tenv in let typ = CTypes_decl.get_type_from_expr_info expr_info trans_state.context.tenv in
let exp = Sil.Const (Sil.Cfloat (float_of_string float_string)) in let exp = Sil.Const (Sil.Cfloat (float_of_string float_string)) in
{ empty_res_trans with exps = [(exp, typ)]} { empty_res_trans with exps = [(exp, typ)]}
@ -217,7 +217,7 @@ struct
(* Note currently we don't have support for different qual *) (* Note currently we don't have support for different qual *)
(* type like long, unsigned long, etc *) (* type like long, unsigned long, etc *)
and integerLiteral_trans trans_state stmt_info expr_info integer_literal_info = and integerLiteral_trans trans_state stmt_info expr_info integer_literal_info =
Printing.log_out ~fmt:"Passing from IntegerLiteral '%s'\n" stmt_info.Clang_ast_t.si_pointer; Printing.log_out "Passing from IntegerLiteral '%s'\n" stmt_info.Clang_ast_t.si_pointer;
let typ = CTypes_decl.get_type_from_expr_info expr_info trans_state.context.tenv in let typ = CTypes_decl.get_type_from_expr_info expr_info trans_state.context.tenv in
let i = try let i = try
int_of_string (integer_literal_info.Clang_ast_t.ili_value) int_of_string (integer_literal_info.Clang_ast_t.ili_value)
@ -227,12 +227,12 @@ struct
{ empty_res_trans with exps = [(exp, typ)]} { empty_res_trans with exps = [(exp, typ)]}
let nullStmt_trans succ_nodes stmt_info = let nullStmt_trans succ_nodes stmt_info =
Printing.log_out ~fmt:"Passing from NullStmt '%s'.\n" stmt_info.Clang_ast_t.si_pointer; Printing.log_out "Passing from NullStmt '%s'.\n" stmt_info.Clang_ast_t.si_pointer;
{ empty_res_trans with root_nodes = succ_nodes } { empty_res_trans with root_nodes = succ_nodes }
(* The stmt seems to be always empty *) (* The stmt seems to be always empty *)
let unaryExprOrTypeTraitExpr_trans trans_state stmt_info expr_info unary_expr_or_type_trait_expr_info = let unaryExprOrTypeTraitExpr_trans trans_state stmt_info expr_info unary_expr_or_type_trait_expr_info =
Printing.log_out ~fmt:"Passing from UnaryExprOrTypeTraitExpr '%s' \n" stmt_info.Clang_ast_t.si_pointer; Printing.log_out "Passing from UnaryExprOrTypeTraitExpr '%s' \n" stmt_info.Clang_ast_t.si_pointer;
let typ = CTypes_decl.qual_type_to_sil_type trans_state.context.tenv expr_info.Clang_ast_t.ei_qual_type in let typ = CTypes_decl.qual_type_to_sil_type trans_state.context.tenv expr_info.Clang_ast_t.ei_qual_type in
match unary_expr_or_type_trait_expr_info.Clang_ast_t.uttei_kind with match unary_expr_or_type_trait_expr_info.Clang_ast_t.uttei_kind with
| `SizeOf -> | `SizeOf ->
@ -243,20 +243,20 @@ struct
| None -> typ in (* Some default type since the type is missing *) | None -> typ in (* Some default type since the type is missing *)
{ empty_res_trans with exps = [(Sil.Sizeof(sizeof_typ, Sil.Subtype.exact), sizeof_typ)]} { empty_res_trans with exps = [(Sil.Sizeof(sizeof_typ, Sil.Subtype.exact), sizeof_typ)]}
| k -> Printing.log_stats | k -> Printing.log_stats
~fmt:"\nWARNING: Missing translation of Uniry_Expression_Or_Trait of kind: %s . Expression ignored, returned -1... \n" "\nWARNING: Missing translation of Uniry_Expression_Or_Trait of kind: %s . Expression ignored, returned -1... \n"
(Clang_ast_j.string_of_unary_expr_or_type_trait_kind k); (Clang_ast_j.string_of_unary_expr_or_type_trait_kind k);
{ empty_res_trans with exps =[(Sil.exp_minus_one, typ)]} { empty_res_trans with exps =[(Sil.exp_minus_one, typ)]}
(* search the label into the hashtbl - create a fake node eventually *) (* search the label into the hashtbl - create a fake node eventually *)
(* connect that node with this stmt *) (* connect that node with this stmt *)
let gotoStmt_trans trans_state stmt_info label_name = let gotoStmt_trans trans_state stmt_info label_name =
Printing.log_out ~fmt:"\nPassing from `GotoStmt '%s'\n" stmt_info.Clang_ast_t.si_pointer; Printing.log_out "\nPassing from `GotoStmt '%s'\n" stmt_info.Clang_ast_t.si_pointer;
let sil_loc = get_sil_location stmt_info trans_state.parent_line_number trans_state.context in let sil_loc = get_sil_location stmt_info trans_state.parent_line_number trans_state.context in
let root_node' = GotoLabel.find_goto_label trans_state.context label_name sil_loc in let root_node' = GotoLabel.find_goto_label trans_state.context label_name sil_loc in
{ empty_res_trans with root_nodes = [root_node']; leaf_nodes = trans_state.succ_nodes } { empty_res_trans with root_nodes = [root_node']; leaf_nodes = trans_state.succ_nodes }
let declRefExpr_trans trans_state stmt_info expr_info decl_ref_expr_info d = let declRefExpr_trans trans_state stmt_info expr_info decl_ref_expr_info d =
Printing.log_out ~fmt:"Passing from DeclRefExpr '%s' \n" stmt_info.Clang_ast_t.si_pointer; Printing.log_out "Passing from DeclRefExpr '%s' \n" stmt_info.Clang_ast_t.si_pointer;
let context = trans_state.context in let context = trans_state.context in
let typ = CTypes_decl.qual_type_to_sil_type context.tenv expr_info.Clang_ast_t.ei_qual_type in let typ = CTypes_decl.qual_type_to_sil_type context.tenv expr_info.Clang_ast_t.ei_qual_type in
let name = get_name_decl_ref_exp_info decl_ref_expr_info stmt_info in let name = get_name_decl_ref_exp_info decl_ref_expr_info stmt_info in
@ -269,11 +269,11 @@ struct
let const_exp = (match CTypes.search_enum_type_by_name context.tenv name with let const_exp = (match CTypes.search_enum_type_by_name context.tenv name with
| Some v -> | Some v ->
let ce = Sil.Const v in let ce = Sil.Const v in
Printing.log_out ~fmt:" ....Found enum constant '%s', " name; Printing.log_out " ....Found enum constant '%s', " name;
Printing.log_out ~fmt:"replacing with integer '%s' \n" (Sil.exp_to_string ce); ce Printing.log_out "replacing with integer '%s' \n" (Sil.exp_to_string ce); ce
| None -> | None ->
Printing.log_stats Printing.log_stats
~fmt:" WARNING: Found enum constant '%s', but its value was not found in the tenv. Returning 0.\n" name; " WARNING: Found enum constant '%s', but its value was not found in the tenv. Returning 0.\n" name;
(Sil.Const(Sil.Cint Sil.Int.zero))) in (Sil.Const(Sil.Cint Sil.Int.zero))) in
{ root_nodes = []; leaf_nodes = []; ids = []; instrs = []; exps = [(const_exp, typ)]} { root_nodes = []; leaf_nodes = []; ids = []; instrs = []; exps = [(const_exp, typ)]}
) else if is_function then ( ) else if is_function then (
@ -321,12 +321,12 @@ struct
(CTypes_decl.get_type_curr_class context.tenv (CContext.get_curr_class context)) in (CTypes_decl.get_type_curr_class context.tenv (CContext.get_curr_class context)) in
[(e, typ)] [(e, typ)]
else [(e, typ)] in else [(e, typ)] in
Printing.log_out ~fmt:"\n\n PVAR ='%s'\n\n" (Sil.pvar_to_string pvar); Printing.log_out "\n\n PVAR ='%s'\n\n" (Sil.pvar_to_string pvar);
{ empty_res_trans with exps = exps } { empty_res_trans with exps = exps }
) )
let rec labelStmt_trans trans_state stmt_info stmt_list label_name = let rec labelStmt_trans trans_state stmt_info stmt_list label_name =
Printing.log_out ~fmt:"\nPassing from `LabelStmt '%s' \n" stmt_info.Clang_ast_t.si_pointer; Printing.log_out "\nPassing from `LabelStmt '%s' \n" stmt_info.Clang_ast_t.si_pointer;
(* go ahead with the translation *) (* go ahead with the translation *)
let res_trans = match stmt_list with let res_trans = match stmt_list with
| [stmt] -> | [stmt] ->
@ -340,7 +340,7 @@ struct
and arraySubscriptExpr_trans trans_state stmt_info expr_info stmt_list = and arraySubscriptExpr_trans trans_state stmt_info expr_info stmt_list =
Printing.log_out Printing.log_out
~fmt:"Passing from ArraySubscriptExpr '%s' \n" stmt_info.Clang_ast_t.si_pointer; "Passing from ArraySubscriptExpr '%s' \n" stmt_info.Clang_ast_t.si_pointer;
let typ = CTypes_decl.get_type_from_expr_info expr_info trans_state.context.tenv in let typ = CTypes_decl.get_type_from_expr_info expr_info trans_state.context.tenv in
let array_stmt, idx_stmt = (match stmt_list with let array_stmt, idx_stmt = (match stmt_list with
| [a; i] -> a, i (* Assumption: the statement list contains 2 elements, | [a; i] -> a, i (* Assumption: the statement list contains 2 elements,
@ -382,9 +382,9 @@ struct
and binaryOperator_trans trans_state binary_operator_info stmt_info expr_info stmt_list = and binaryOperator_trans trans_state binary_operator_info stmt_info expr_info stmt_list =
let bok = (Clang_ast_j.string_of_binary_operator_kind binary_operator_info.Clang_ast_t.boi_kind) in let bok = (Clang_ast_j.string_of_binary_operator_kind binary_operator_info.Clang_ast_t.boi_kind) in
Printing.log_out ~fmt:"Passing from BinaryOperator '%s' " bok; Printing.log_out "Passing from BinaryOperator '%s' " bok;
Printing.log_out ~fmt:"pointer = '%s' " stmt_info.Clang_ast_t.si_pointer; Printing.log_out "pointer = '%s' " stmt_info.Clang_ast_t.si_pointer;
Printing.log_out ~fmt:"priority node free = '%s'.\n" (string_of_bool (PriorityNode.is_priority_free trans_state)); Printing.log_out "priority node free = '%s'.\n" (string_of_bool (PriorityNode.is_priority_free trans_state));
let context = trans_state.context in let context = trans_state.context in
let parent_line_number = trans_state.parent_line_number in let parent_line_number = trans_state.parent_line_number in
let succ_nodes = trans_state.succ_nodes in let succ_nodes = trans_state.succ_nodes in
@ -473,14 +473,14 @@ struct
else if e2_has_nodes then res_trans_e2.leaf_nodes else if e2_has_nodes then res_trans_e2.leaf_nodes
else res_trans_e1.leaf_nodes in else res_trans_e1.leaf_nodes in
Printing.log_out ~fmt:"....BinaryOperator '%s' " bok; Printing.log_out "....BinaryOperator '%s' " bok;
Printing.log_out ~fmt:"has ids_to_ancestor |ids_to_ancestor|=%s " Printing.log_out "has ids_to_ancestor |ids_to_ancestor|=%s "
(string_of_int (list_length ids_to_ancestor)); (string_of_int (list_length ids_to_ancestor));
Printing.log_out ~fmt:" |nodes_e1|=%s .\n" Printing.log_out " |nodes_e1|=%s .\n"
(string_of_int (list_length res_trans_e1.root_nodes)); (string_of_int (list_length res_trans_e1.root_nodes));
Printing.log_out ~fmt:" |nodes_e2|=%s .\n" Printing.log_out " |nodes_e2|=%s .\n"
(string_of_int (list_length res_trans_e2.root_nodes)); (string_of_int (list_length res_trans_e2.root_nodes));
list_iter (fun id -> Printing.log_out ~fmt:" ... '%s'\n" list_iter (fun id -> Printing.log_out " ... '%s'\n"
(Ident.to_string id)) ids_to_ancestor; (Ident.to_string id)) ids_to_ancestor;
{ root_nodes = root_nodes_to_ancestor; { root_nodes = root_nodes_to_ancestor;
leaf_nodes = leaf_nodes_to_ancestor; leaf_nodes = leaf_nodes_to_ancestor;
@ -493,7 +493,7 @@ struct
let pln = trans_state.parent_line_number in let pln = trans_state.parent_line_number in
let context = trans_state.context in let context = trans_state.context in
let function_type = CTypes_decl.get_type_from_expr_info expr_info context.tenv in let function_type = CTypes_decl.get_type_from_expr_info expr_info context.tenv in
Printing.log_out ~fmt:"Passing from CallExpr '%s'.\n" si.Clang_ast_t.si_pointer; Printing.log_out "Passing from CallExpr '%s'.\n" si.Clang_ast_t.si_pointer;
let procname = Cfg.Procdesc.get_proc_name context.procdesc in let procname = Cfg.Procdesc.get_proc_name context.procdesc in
let sil_loc = get_sil_location si pln context in let sil_loc = get_sil_location si pln context in
let fun_exp_stmt, params_stmt = (match stmt_list with (* First stmt is the function expr and the rest are params*) let fun_exp_stmt, params_stmt = (match stmt_list with (* First stmt is the function expr and the rest are params*)
@ -573,14 +573,14 @@ struct
| _ -> assert false) (* by construction of red_id, we cannot be in this case *) | _ -> assert false) (* by construction of red_id, we cannot be in this case *)
and objCMessageExpr_trans trans_state si obj_c_message_expr_info stmt_list expr_info = and objCMessageExpr_trans trans_state si obj_c_message_expr_info stmt_list expr_info =
Printing.log_out ~fmt:"Passing from ObjMessageExpr '%s'.\n" si.Clang_ast_t.si_pointer; Printing.log_out "Passing from ObjMessageExpr '%s'.\n" si.Clang_ast_t.si_pointer;
let context = trans_state.context in let context = trans_state.context in
let parent_line_number = trans_state.parent_line_number in let parent_line_number = trans_state.parent_line_number in
let sil_loc = get_sil_location si parent_line_number context in let sil_loc = get_sil_location si parent_line_number context in
let selector, receiver_kind = get_selector_receiver obj_c_message_expr_info in let selector, receiver_kind = get_selector_receiver obj_c_message_expr_info in
let is_alloc_or_new = (selector = CFrontend_config.alloc) || (selector = CFrontend_config.new_str) in let is_alloc_or_new = (selector = CFrontend_config.alloc) || (selector = CFrontend_config.new_str) in
Printing.log_out ~fmt:"\n!!!!!!! Calling with selector = '%s' " selector; Printing.log_out "\n!!!!!!! Calling with selector = '%s' " selector;
Printing.log_out ~fmt:" receiver_kind= '%s'\n\n" (Clang_ast_j.string_of_receiver_kind receiver_kind); Printing.log_out " receiver_kind= '%s'\n\n" (Clang_ast_j.string_of_receiver_kind receiver_kind);
let method_type = CTypes_decl.get_type_from_expr_info expr_info context.tenv in let method_type = CTypes_decl.get_type_from_expr_info expr_info context.tenv in
let ret_id = if Sil.typ_equal method_type Sil.Tvoid then [] let ret_id = if Sil.typ_equal method_type Sil.Tvoid then []
else [Ident.create_fresh Ident.knormal] in else [Ident.create_fresh Ident.knormal] in
@ -655,7 +655,7 @@ struct
res_state res_state
and compoundStmt_trans trans_state stmt_info stmt_list = and compoundStmt_trans trans_state stmt_info stmt_list =
Printing.log_out ~fmt:"Passing from CompoundStmt '%s'.\n" stmt_info.Clang_ast_t.si_pointer; Printing.log_out "Passing from CompoundStmt '%s'.\n" stmt_info.Clang_ast_t.si_pointer;
let line_number = get_line stmt_info trans_state.parent_line_number in let line_number = get_line stmt_info trans_state.parent_line_number in
let trans_state' = { trans_state with parent_line_number = line_number } in let trans_state' = { trans_state with parent_line_number = line_number } in
instructions trans_state' (list_rev stmt_list) instructions trans_state' (list_rev stmt_list)
@ -667,7 +667,7 @@ struct
let procname = Cfg.Procdesc.get_proc_name context.procdesc in let procname = Cfg.Procdesc.get_proc_name context.procdesc in
let mk_temp_var id = let mk_temp_var id =
Sil.mk_pvar (Mangled.from_string ("SIL_temp_conditional___"^(string_of_int id))) procname in Sil.mk_pvar (Mangled.from_string ("SIL_temp_conditional___"^(string_of_int id))) procname in
Printing.log_out ~fmt:"Passing from ConditionalOperator '%s' \n" stmt_info.Clang_ast_t.si_pointer; Printing.log_out "Passing from ConditionalOperator '%s' \n" stmt_info.Clang_ast_t.si_pointer;
let sil_loc = get_sil_location stmt_info parent_line_number context in let sil_loc = get_sil_location stmt_info parent_line_number context in
let line_number = get_line stmt_info parent_line_number in let line_number = get_line stmt_info parent_line_number in
(* We have two different kind of join type for conditional operator. *) (* We have two different kind of join type for conditional operator. *)
@ -820,7 +820,7 @@ struct
| _ -> no_short_circuit_cond () | _ -> no_short_circuit_cond ()
and ifStmt_trans trans_state stmt_info stmt_list = and ifStmt_trans trans_state stmt_info stmt_list =
Printing.log_out ~fmt:"Passing from IfStmt '%s' \n" stmt_info.Clang_ast_t.si_pointer; Printing.log_out "Passing from IfStmt '%s' \n" stmt_info.Clang_ast_t.si_pointer;
let context = trans_state.context in let context = trans_state.context in
let pln = trans_state.parent_line_number in let pln = trans_state.parent_line_number in
let succ_nodes = trans_state.succ_nodes in let succ_nodes = trans_state.succ_nodes in
@ -853,7 +853,7 @@ struct
(* Assumption: the CompoundStmt can be made of different stmts, not just CaseStmts *) (* Assumption: the CompoundStmt can be made of different stmts, not just CaseStmts *)
and switchStmt_trans trans_state stmt_info switch_stmt_list = and switchStmt_trans trans_state stmt_info switch_stmt_list =
Printing.log_out ~fmt:"\nPassing from `SwitchStmt '%s' \n" stmt_info.Clang_ast_t.si_pointer; Printing.log_out "\nPassing from `SwitchStmt '%s' \n" stmt_info.Clang_ast_t.si_pointer;
let context = trans_state.context in let context = trans_state.context in
let pln = trans_state.parent_line_number in let pln = trans_state.parent_line_number in
let succ_nodes = trans_state.succ_nodes in let succ_nodes = trans_state.succ_nodes in
@ -975,7 +975,7 @@ struct
and stmtExpr_trans trans_state stmt_info stmt_list expr_info = and stmtExpr_trans trans_state stmt_info stmt_list expr_info =
let context = trans_state.context in let context = trans_state.context in
Printing.log_out ~fmt:"Passing from StmtExpr '%s'.\n" stmt_info.Clang_ast_t.si_pointer; Printing.log_out "Passing from StmtExpr '%s'.\n" stmt_info.Clang_ast_t.si_pointer;
let stmt = extract_stmt_from_singleton stmt_list "ERROR: StmtExpr should have only one statement.\n" in let stmt = extract_stmt_from_singleton stmt_list "ERROR: StmtExpr should have only one statement.\n" in
let res_trans_stmt = instruction trans_state stmt in let res_trans_stmt = instruction trans_state stmt in
let idl = res_trans_stmt.ids in let idl = res_trans_stmt.ids in
@ -1079,8 +1079,8 @@ struct
and compoundAssignOperator trans_state stmt_info binary_operator_info expr_info stmt_list = and compoundAssignOperator trans_state stmt_info binary_operator_info expr_info stmt_list =
let context = trans_state.context in let context = trans_state.context in
let pln = trans_state.parent_line_number in let pln = trans_state.parent_line_number in
Printing.log_out ~fmt:"Passing from CompoundAssignOperator '%s'" stmt_info.Clang_ast_t.si_pointer; Printing.log_out "Passing from CompoundAssignOperator '%s'" stmt_info.Clang_ast_t.si_pointer;
Printing.log_out ~fmt:"'%s' .\n" Printing.log_out "'%s' .\n"
(Clang_ast_j.string_of_binary_operator_kind binary_operator_info.Clang_ast_t.boi_kind); (Clang_ast_j.string_of_binary_operator_kind binary_operator_info.Clang_ast_t.boi_kind);
(* claim priority if no ancestors has claimed priority before *) (* claim priority if no ancestors has claimed priority before *)
let trans_state_pri = PriorityNode.try_claim_priority_node trans_state stmt_info in let trans_state_pri = PriorityNode.try_claim_priority_node trans_state stmt_info in
@ -1280,7 +1280,7 @@ struct
(* the init expression. We use the latter info. *) (* the init expression. We use the latter info. *)
and declStmt_trans trans_state decl_list stmt_info = and declStmt_trans trans_state decl_list stmt_info =
let succ_nodes = trans_state.succ_nodes in let succ_nodes = trans_state.succ_nodes in
Printing.log_out ~fmt:"Passing from DeclStmt '%s' \n" stmt_info.Clang_ast_t.si_pointer; Printing.log_out "Passing from DeclStmt '%s' \n" stmt_info.Clang_ast_t.si_pointer;
let line_number = get_line stmt_info trans_state.parent_line_number in let line_number = get_line stmt_info trans_state.parent_line_number in
let trans_state' = { trans_state with parent_line_number = line_number } in let trans_state' = { trans_state with parent_line_number = line_number } in
let res_trans = (match decl_list with let res_trans = (match decl_list with
@ -1296,14 +1296,14 @@ struct
{ res_trans with leaf_nodes = []} { res_trans with leaf_nodes = []}
and objCPropertyRefExpr_trans trans_state stmt_info stmt_list = and objCPropertyRefExpr_trans trans_state stmt_info stmt_list =
Printing.log_out ~fmt:"Passing from ObjCPropertyRefExpr '%s' \n" stmt_info.Clang_ast_t.si_pointer; Printing.log_out "Passing from ObjCPropertyRefExpr '%s' \n" stmt_info.Clang_ast_t.si_pointer;
(match stmt_list with (match stmt_list with
| [stmt] -> instruction trans_state stmt | [stmt] -> instruction trans_state stmt
| _ -> assert false) | _ -> assert false)
(* For OpaqueValueExpr we return the translation generated from its source expression*) (* For OpaqueValueExpr we return the translation generated from its source expression*)
and opaqueValueExpr_trans trans_state stmt_info opaque_value_expr_info = and opaqueValueExpr_trans trans_state stmt_info opaque_value_expr_info =
Printing.log_out ~fmt:"Passing from OpaqueValueExpr '%s' \n" stmt_info.Clang_ast_t.si_pointer; Printing.log_out "Passing from OpaqueValueExpr '%s' \n" stmt_info.Clang_ast_t.si_pointer;
(match opaque_value_expr_info.Clang_ast_t.ovei_source_expr with (match opaque_value_expr_info.Clang_ast_t.ovei_source_expr with
| Some stmt -> instruction trans_state stmt | Some stmt -> instruction trans_state stmt
| _ -> assert false) | _ -> assert false)
@ -1325,7 +1325,7 @@ struct
and pseudoObjectExpr_trans trans_state stmt_info stmt_list = and pseudoObjectExpr_trans trans_state stmt_info stmt_list =
let line_number = get_line stmt_info trans_state.parent_line_number in let line_number = get_line stmt_info trans_state.parent_line_number in
let trans_state' = { trans_state with parent_line_number = line_number } in let trans_state' = { trans_state with parent_line_number = line_number } in
Printing.log_out ~fmt:"Passing from PseudoObjectExpr '%s' \n" stmt_info.Clang_ast_t.si_pointer; Printing.log_out "Passing from PseudoObjectExpr '%s' \n" stmt_info.Clang_ast_t.si_pointer;
let rec do_semantic_elements el = let rec do_semantic_elements el =
(match el with (match el with
| OpaqueValueExpr _ :: el' -> do_semantic_elements el' | OpaqueValueExpr _ :: el' -> do_semantic_elements el'
@ -1340,7 +1340,7 @@ struct
and cast_exprs_trans trans_state stmt_info stmt_list expr_info cast_expr_info is_objc_bridged = and cast_exprs_trans trans_state stmt_info stmt_list expr_info cast_expr_info is_objc_bridged =
let context = trans_state.context in let context = trans_state.context in
let pln = trans_state.parent_line_number in let pln = trans_state.parent_line_number in
Printing.log_out ~fmt:"Passing from CastExpr '%s' \n" stmt_info.Clang_ast_t.si_pointer; Printing.log_out "Passing from CastExpr '%s' \n" stmt_info.Clang_ast_t.si_pointer;
let sil_loc = get_sil_location stmt_info pln context in let sil_loc = get_sil_location stmt_info pln context in
let stmt = extract_stmt_from_singleton stmt_list let stmt = extract_stmt_from_singleton stmt_list
"WARNING: In CastExpr There must be only one stmt defining the expression to be cast.\n" in "WARNING: In CastExpr There must be only one stmt defining the expression to be cast.\n" in
@ -1359,7 +1359,7 @@ struct
(* function used in the computation for both Member_Expr and ObjCIVarRefExpr *) (* function used in the computation for both Member_Expr and ObjCIVarRefExpr *)
and do_memb_ivar_ref_exp trans_state expr_info exp_stmt sil_loc nfield = and do_memb_ivar_ref_exp trans_state expr_info exp_stmt sil_loc nfield =
Printing.log_out ~fmt:"!!!!! Dealing with field '%s' @." nfield; Printing.log_out "!!!!! Dealing with field '%s' @." nfield;
let res_trans_exp_stmt = instruction trans_state exp_stmt in let res_trans_exp_stmt = instruction trans_state exp_stmt in
let (e, class_typ) = extract_exp_from_list res_trans_exp_stmt.exps let (e, class_typ) = extract_exp_from_list res_trans_exp_stmt.exps
"WARNING: in MemberExpr we expect the translation of the stmt to return an expression\n" in "WARNING: in MemberExpr we expect the translation of the stmt to return an expression\n" in
@ -1372,7 +1372,7 @@ struct
(match class_typ with (match class_typ with
| Sil.Tvoid -> Sil.exp_minus_one | Sil.Tvoid -> Sil.exp_minus_one
| _ -> | _ ->
Printing.log_out ~fmt:"Type is '%s' @." (Sil.typ_to_string class_typ); Printing.log_out "Type is '%s' @." (Sil.typ_to_string class_typ);
( match ObjcInterface_decl.find_field trans_state.context.tenv nfield (Some class_typ) false with ( match ObjcInterface_decl.find_field trans_state.context.tenv nfield (Some class_typ) false with
| Some (fn, _, _) -> Sil.Lfield (e, fn, class_typ) | Some (fn, _, _) -> Sil.Lfield (e, fn, class_typ)
| None -> assert false)) in | None -> assert false)) in
@ -1380,7 +1380,7 @@ struct
exps = [(exp, typ)] } exps = [(exp, typ)] }
and objCIvarRefExpr_trans trans_state stmt_info expr_info stmt_list obj_c_ivar_ref_expr_info = and objCIvarRefExpr_trans trans_state stmt_info expr_info stmt_list obj_c_ivar_ref_expr_info =
Printing.log_out ~fmt:"Passing from ObjCIvarRefExpr '%s'\n" stmt_info.Clang_ast_t.si_pointer; Printing.log_out "Passing from ObjCIvarRefExpr '%s'\n" stmt_info.Clang_ast_t.si_pointer;
let sil_loc = get_sil_location stmt_info trans_state.parent_line_number trans_state.context in let sil_loc = get_sil_location stmt_info trans_state.parent_line_number trans_state.context in
let exp_stmt = extract_stmt_from_singleton stmt_list let exp_stmt = extract_stmt_from_singleton stmt_list
"WARNING: in MemberExpr there must be only one stmt defining its expression.\n" in "WARNING: in MemberExpr there must be only one stmt defining its expression.\n" in
@ -1390,7 +1390,7 @@ struct
do_memb_ivar_ref_exp trans_state expr_info exp_stmt sil_loc name_field do_memb_ivar_ref_exp trans_state expr_info exp_stmt sil_loc name_field
and memberExpr_trans trans_state stmt_info expr_info stmt_list member_expr_info = and memberExpr_trans trans_state stmt_info expr_info stmt_list member_expr_info =
Printing.log_out ~fmt:"Passing from MemberExpr '%s'\n" stmt_info.Clang_ast_t.si_pointer; Printing.log_out "Passing from MemberExpr '%s'\n" stmt_info.Clang_ast_t.si_pointer;
let sil_loc = get_sil_location stmt_info trans_state.parent_line_number trans_state.context in let sil_loc = get_sil_location stmt_info trans_state.parent_line_number trans_state.context in
let exp_stmt = extract_stmt_from_singleton stmt_list let exp_stmt = extract_stmt_from_singleton stmt_list
"WARNING: in MemberExpr there must be only one stmt defining its expression.\n" in "WARNING: in MemberExpr there must be only one stmt defining its expression.\n" in
@ -1400,7 +1400,7 @@ struct
and unaryOperator_trans trans_state stmt_info expr_info stmt_list unary_operator_info = and unaryOperator_trans trans_state stmt_info expr_info stmt_list unary_operator_info =
let context = trans_state.context in let context = trans_state.context in
let pln = trans_state.parent_line_number in let pln = trans_state.parent_line_number in
Printing.log_out ~fmt:"Passing from UnaryOperator '%s'\n" stmt_info.Clang_ast_t.si_pointer; Printing.log_out "Passing from UnaryOperator '%s'\n" stmt_info.Clang_ast_t.si_pointer;
let sil_loc = get_sil_location stmt_info pln context in let sil_loc = get_sil_location stmt_info pln context in
let line_number = get_line stmt_info pln in let line_number = get_line stmt_info pln in
let trans_state_pri = PriorityNode.try_claim_priority_node trans_state stmt_info in let trans_state_pri = PriorityNode.try_claim_priority_node trans_state stmt_info in
@ -1445,7 +1445,7 @@ struct
let context = trans_state.context in let context = trans_state.context in
let pln = trans_state.parent_line_number in let pln = trans_state.parent_line_number in
let succ_nodes = trans_state.succ_nodes in let succ_nodes = trans_state.succ_nodes in
Printing.log_out ~fmt:"Passing from ReturnOperator '%s'.\n" stmt_info.Clang_ast_t.si_pointer; Printing.log_out "Passing from ReturnOperator '%s'.\n" stmt_info.Clang_ast_t.si_pointer;
let sil_loc = get_sil_location stmt_info pln context in let sil_loc = get_sil_location stmt_info pln context in
let line_number = get_line stmt_info pln in let line_number = get_line stmt_info pln in
let trans_state_pri = PriorityNode.try_claim_priority_node trans_state stmt_info in let trans_state_pri = PriorityNode.try_claim_priority_node trans_state stmt_info in
@ -1480,7 +1480,7 @@ struct
(* For ParenExpression we translate its body composed by the stmt_list. *) (* For ParenExpression we translate its body composed by the stmt_list. *)
(* In paren expression there should be only one stmt that defines the expression *) (* In paren expression there should be only one stmt that defines the expression *)
and parenExpr_trans trans_state stmt_info stmt_list = and parenExpr_trans trans_state stmt_info stmt_list =
Printing.log_out ~fmt:"Passing from ParenExpr '%s' \n" stmt_info.Clang_ast_t.si_pointer; Printing.log_out "Passing from ParenExpr '%s' \n" stmt_info.Clang_ast_t.si_pointer;
let line_number = get_line stmt_info trans_state.parent_line_number in let line_number = get_line stmt_info trans_state.parent_line_number in
let trans_state'= { trans_state with parent_line_number = line_number } in let trans_state'= { trans_state with parent_line_number = line_number } in
let stmt = extract_stmt_from_singleton stmt_list let stmt = extract_stmt_from_singleton stmt_list
@ -1539,13 +1539,13 @@ struct
(* For the same reason we also ignore the stmt_info that is related with the ObjCAtSynchronizedStmt construct *) (* For the same reason we also ignore the stmt_info that is related with the ObjCAtSynchronizedStmt construct *)
(* Finally we recursively work on the CompoundStmt, the second item of stmt_list *) (* Finally we recursively work on the CompoundStmt, the second item of stmt_list *)
and objCAtSynchronizedStmt_trans trans_state stmt_info stmt_list = and objCAtSynchronizedStmt_trans trans_state stmt_info stmt_list =
Printing.log_out ~fmt:"Passing from `ObjCAtSynchronizedStmt '%s' \n" stmt_info.Clang_ast_t.si_pointer; Printing.log_out "Passing from `ObjCAtSynchronizedStmt '%s' \n" stmt_info.Clang_ast_t.si_pointer;
(match stmt_list with (match stmt_list with
| [_; compound_stmt] -> instruction trans_state compound_stmt | [_; compound_stmt] -> instruction trans_state compound_stmt
| _ -> assert false) | _ -> assert false)
and blockExpr_trans trans_state stmt_info expr_info decl = and blockExpr_trans trans_state stmt_info expr_info decl =
Printing.log_out ~fmt:"Passing from BlockExpr '%s' \n" stmt_info.Clang_ast_t.si_pointer; Printing.log_out "Passing from BlockExpr '%s' \n" stmt_info.Clang_ast_t.si_pointer;
let context = trans_state.context in let context = trans_state.context in
let pln = trans_state.parent_line_number in let pln = trans_state.parent_line_number in
let procname = Cfg.Procdesc.get_proc_name context.procdesc in let procname = Cfg.Procdesc.get_proc_name context.procdesc in
@ -1609,7 +1609,7 @@ struct
gotoStmt_trans trans_state stmt_info label_name gotoStmt_trans trans_state stmt_info label_name
| LabelStmt(stmt_info, stmt_list, label_name) -> | LabelStmt(stmt_info, stmt_list, label_name) ->
Printing.log_out ~fmt:"\nPassing from `LabelStmt '%s' \n" stmt_info.Clang_ast_t.si_pointer; Printing.log_out "\nPassing from `LabelStmt '%s' \n" stmt_info.Clang_ast_t.si_pointer;
labelStmt_trans trans_state stmt_info stmt_list label_name labelStmt_trans trans_state stmt_info stmt_list label_name
| ArraySubscriptExpr(stmt_info, stmt_list, expr_info) -> | ArraySubscriptExpr(stmt_info, stmt_list, expr_info) ->
@ -1786,16 +1786,16 @@ struct
(match stmts with (match stmts with
| [stmt1; ostmt1; ostmt2; stmt2] when contains_opaque_value_expr ostmt1 && contains_opaque_value_expr ostmt2 -> | [stmt1; ostmt1; ostmt2; stmt2] when contains_opaque_value_expr ostmt1 && contains_opaque_value_expr ostmt2 ->
conditionalOperator_trans trans_state stmt_info [stmt1; stmt1; stmt2] expr_info conditionalOperator_trans trans_state stmt_info [stmt1; stmt1; stmt2] expr_info
| _ -> Printing.log_stats ~fmt: "BinaryConditionalOperator not translated %s @." (Ast_utils.string_of_stmt instr); | _ -> Printing.log_stats "BinaryConditionalOperator not translated %s @." (Ast_utils.string_of_stmt instr);
assert false) assert false)
| s -> (Printing.log_stats | s -> (Printing.log_stats
~fmt:"\n!!!!WARNING: found statement %s. \nACTION REQUIRED: Translation need to be defined. Statement ignored.... \n" "\n!!!!WARNING: found statement %s. \nACTION REQUIRED: Translation need to be defined. Statement ignored.... \n"
(Ast_utils.string_of_stmt s); (Ast_utils.string_of_stmt s);
assert false) assert false)
(* Given a translation state, this function traslates a list of clang statements. *) (* Given a translation state, this function traslates a list of clang statements. *)
and instructions trans_state clang_stmt_list = and instructions trans_state clang_stmt_list =
(* Printing.log_err ~fmt:"\n instruction list %i" (List.length clang_stmt_list); *) (* Printing.log_err "\n instruction list %i" (List.length clang_stmt_list); *)
match clang_stmt_list with match clang_stmt_list with
| [] -> { empty_res_trans with root_nodes = trans_state.succ_nodes } | [] -> { empty_res_trans with root_nodes = trans_state.succ_nodes }
| s:: clang_stmt_list' -> | s:: clang_stmt_list' ->

12
infer/src/clang/cTrans_utils.ml
Unescape View File

@ -19,7 +19,7 @@ module L = Logging
let extract_item_from_singleton l warning_string failure_val = let extract_item_from_singleton l warning_string failure_val =
match l with match l with
| [item] -> item | [item] -> item
| _ -> Printing.log_err warning_string; failure_val | _ -> Printing.log_err "%s" warning_string; failure_val
let dummy_exp = (Sil.exp_minus_one, Sil.Tint Sil.IInt) let dummy_exp = (Sil.exp_minus_one, Sil.Tint Sil.IInt)
@ -362,7 +362,7 @@ let cast_operation context cast_kind exps cast_typ sil_loc is_objc_bridged =
([], [], Sil.Cast(typ, exp)) ([], [], Sil.Cast(typ, exp))
| _ -> | _ ->
Printing.log_err Printing.log_err
~fmt:"\nWARNING: Missing translation for Cast Kind %s. The construct has been ignored...\n" "\nWARNING: Missing translation for Cast Kind %s. The construct has been ignored...\n"
(Clang_ast_j.string_of_cast_kind cast_kind); (Clang_ast_j.string_of_cast_kind cast_kind);
([],[], exp) ([],[], exp)
@ -451,14 +451,14 @@ let get_value_enum_constant tenv enum_type stmt =
let typename = Sil.TN_enum(Mangled.from_string enum_type) in let typename = Sil.TN_enum(Mangled.from_string enum_type) in
match Sil.tenv_lookup tenv typename with match Sil.tenv_lookup tenv typename with
| Some (Sil.Tenum enum_constants) -> | Some (Sil.Tenum enum_constants) ->
Printing.log_out ~fmt:">>>Found enum with typename TN_typename('%s')\n" (Sil.typename_to_string typename); Printing.log_out ">>>Found enum with typename TN_typename('%s')\n" (Sil.typename_to_string typename);
let _, v = try let _, v = try
list_find (fun (c, _) -> Mangled.equal c (Mangled.from_string constant)) enum_constants list_find (fun (c, _) -> Mangled.equal c (Mangled.from_string constant)) enum_constants
with _ -> (Printing.log_err with _ -> (Printing.log_err
~fmt:"Enumeration constant '%s' not found. Cannot continue...\n" constant; assert false) in "Enumeration constant '%s' not found. Cannot continue...\n" constant; assert false) in
v v
| _ -> Printing.log_err | _ -> Printing.log_err
~fmt:"Enum type '%s' not found in tenv. Cannot continue...\n" (Sil.typename_to_string typename); "Enum type '%s' not found in tenv. Cannot continue...\n" (Sil.typename_to_string typename);
assert false assert false
let get_selector_receiver obj_c_message_expr_info = let get_selector_receiver obj_c_message_expr_info =
@ -520,7 +520,7 @@ let rec get_type_from_exp_stmt stmt =
| ImplicitCastExpr(_, stmt_list, _, _) -> | ImplicitCastExpr(_, stmt_list, _, _) ->
get_type_from_exp_stmt (extract_stmt_from_singleton stmt_list "WARNING: We expect only one stmt.") get_type_from_exp_stmt (extract_stmt_from_singleton stmt_list "WARNING: We expect only one stmt.")
| DeclRefExpr(_, _, _, info) -> do_decl_ref_exp info | DeclRefExpr(_, _, _, info) -> do_decl_ref_exp info
| _ -> Printing.log_err ~fmt:"Failing with: %s \n%!" (Clang_ast_j.string_of_stmt stmt); | _ -> Printing.log_err "Failing with: %s \n%!" (Clang_ast_j.string_of_stmt stmt);
Printing.print_failure_info ""; Printing.print_failure_info "";
assert false assert false

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

@ -21,7 +21,7 @@ let get_function_return_type s =
match buf with match buf with
| ret:: _ -> | ret:: _ ->
let ret'= String.trim ret in let ret'= String.trim ret in
Printing.log_out ~fmt:"return type ='%s'@." ret'; Printing.log_out "return type ='%s'@." ret';
ret' ret'
| _ -> assert false | _ -> assert false
@ -38,24 +38,24 @@ let lookup_var_type context pvar =
let locals = Cfg.Procdesc.get_locals context.CContext.procdesc in let locals = Cfg.Procdesc.get_locals context.CContext.procdesc in
try try
let s, t = list_find (fun (s, t) -> s = (Sil.pvar_to_string pvar)) formals in let s, t = list_find (fun (s, t) -> s = (Sil.pvar_to_string pvar)) formals in
Printing.log_out ~fmt:"When looking for type of variable '%s' " (Sil.pvar_to_string pvar); Printing.log_out "When looking for type of variable '%s' " (Sil.pvar_to_string pvar);
Printing.log_out ~fmt:"found '%s' in formals.@." (Sil.typ_to_string t); Printing.log_out "found '%s' in formals.@." (Sil.typ_to_string t);
t t
with Not_found -> with Not_found ->
try try
let s, t = list_find (fun (s, t) -> Mangled.equal (Sil.pvar_get_name pvar) s) locals in let s, t = list_find (fun (s, t) -> Mangled.equal (Sil.pvar_get_name pvar) s) locals in
Printing.log_out ~fmt:"When looking for type of variable '%s' " (Sil.pvar_to_string pvar); Printing.log_out "When looking for type of variable '%s' " (Sil.pvar_to_string pvar);
Printing.log_out ~fmt:"found '%s' in locals.@." (Sil.typ_to_string t); Printing.log_out "found '%s' in locals.@." (Sil.typ_to_string t);
t t
with Not_found -> with Not_found ->
try try
let typ = CGlobal_vars.var_get_typ (CGlobal_vars.find (Sil.pvar_get_name pvar)) in let typ = CGlobal_vars.var_get_typ (CGlobal_vars.find (Sil.pvar_get_name pvar)) in
Printing.log_out ~fmt:"When looking for type of variable '%s'" (Sil.pvar_to_string pvar); Printing.log_out "When looking for type of variable '%s'" (Sil.pvar_to_string pvar);
Printing.log_out ~fmt:" found '%s' in globals.@." (Sil.typ_to_string typ); Printing.log_out " found '%s' in globals.@." (Sil.typ_to_string typ);
typ typ
with Not_found -> with Not_found ->
Printing.log_err Printing.log_err
~fmt:"WARNING: Variable '%s' not found in local+formal when looking for its type. Returning void.\n%!" "WARNING: Variable '%s' not found in local+formal when looking for its type. Returning void.\n%!"
(Sil.pvar_to_string pvar); (Sil.pvar_to_string pvar);
Sil.Tvoid Sil.Tvoid
@ -116,7 +116,7 @@ let extract_type_from_stmt s =
| UnaryOperator(_, _, expr_info, _) | UnaryOperator(_, _, expr_info, _)
| VAArgExpr (_, _, expr_info) -> expr_info.Clang_ast_t.ei_qual_type | VAArgExpr (_, _, expr_info) -> expr_info.Clang_ast_t.ei_qual_type
| _ -> (* For the other case we cannot get the type info *) | _ -> (* For the other case we cannot get the type info *)
Printing.log_err ~fmt:"WARNING: Could not get type of statement '%s'\n%!" (Clang_ast_j.string_of_stmt s); Printing.log_err "WARNING: Could not get type of statement '%s'\n%!" (Clang_ast_j.string_of_stmt s);
assert false assert false
let get_desugared_type t = let get_desugared_type t =
@ -127,7 +127,7 @@ let get_desugared_type t =
(* Remove the work 'struct' from a type name. Used to avoid repetition when typename are constructed*) (* Remove the work 'struct' from a type name. Used to avoid repetition when typename are constructed*)
(* E.g. 'struct struct s' *) (* E.g. 'struct struct s' *)
let cut_struct_union s = let cut_struct_union s =
Printing.log_out ~fmt:"Cutting '%s'@." s; Printing.log_out "Cutting '%s'@." 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 (*-> Printing.string_from_list l *) | "struct":: l (*-> Printing.string_from_list l *)
@ -145,7 +145,7 @@ let rec get_type_list nn ll =
| [] -> [] | [] -> []
| (n, t):: ll' -> (* Printing.log_out ">>>>>Searching for type '%s'. Seen '%s'.@." nn n; *) | (n, t):: ll' -> (* Printing.log_out ">>>>>Searching for type '%s'. Seen '%s'.@." nn n; *)
if n = nn then ( if n = nn then (
Printing.log_out ~fmt:">>>>>>>>>>>>>>>>>>>>>>>NOW Found, Its type is: '%s'@." (Sil.typ_to_string t); Printing.log_out ">>>>>>>>>>>>>>>>>>>>>>>NOW Found, Its type is: '%s'@." (Sil.typ_to_string t);
[t] [t]
) else get_type_list nn ll' ) else get_type_list nn ll'
@ -163,8 +163,10 @@ let classname_of_type typ =
| Sil.Tstruct(_, _, _, (Some name), _, _, _) | Sil.Tstruct(_, _, _, (Some name), _, _, _)
| Sil.Tvar (Sil.TN_typedef name) -> Mangled.to_string name | Sil.Tvar (Sil.TN_typedef name) -> Mangled.to_string name
| Sil.Tfun _ -> CFrontend_config.objc_object | Sil.Tfun _ -> CFrontend_config.objc_object
| _ -> (Printing.log_out | _ ->
~fmt:"Classname of type cannot be extracted in type %s" (Sil.typ_to_string typ)); assert false Printing.log_out
"Classname of type cannot be extracted in type %s" (Sil.typ_to_string typ);
assert false
let get_raw_qual_type_decl_ref_exp_info decl_ref_expr_info = let get_raw_qual_type_decl_ref_exp_info decl_ref_expr_info =
match decl_ref_expr_info.Clang_ast_t.drti_decl_ref with match decl_ref_expr_info.Clang_ast_t.drti_decl_ref with

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

@ -67,7 +67,7 @@ let rec search_for_named_type tenv typ =
(* parsing and then translating the type The parser is higher-order and *) (* parsing and then translating the type The parser is higher-order and *)
(* takes a tenv as needs to do look-ups *) (* takes a tenv as needs to do look-ups *)
let string_type_to_sil_type tenv s = let string_type_to_sil_type tenv s =
Printing.log_out ~fmt:" ...Trying parsing TYPE from string: '%s'@." s; Printing.log_out " ...Trying parsing TYPE from string: '%s'@." s;
if s = "" then ( if s = "" then (
Printing.log_stats "\n Empty string parsed as type Void.\n"; Printing.log_stats "\n Empty string parsed as type Void.\n";
Sil.Tvoid) Sil.Tvoid)
@ -91,16 +91,16 @@ let string_type_to_sil_type tenv s =
let t = let t =
try try
let t = CTypes_parser.parse (Ast_lexer.token) lexbuf in let t = CTypes_parser.parse (Ast_lexer.token) lexbuf in
Printing.log_out ~fmt: Printing.log_out
" ...Parsed. Translated with sil TYPE '%s'@." (Sil.typ_to_string t); t " ...Parsed. Translated with sil TYPE '%s'@." (Sil.typ_to_string t); t
with Parsing.Parse_error -> ( with Parsing.Parse_error -> (
Printing.log_stats Printing.log_stats
~fmt:"\nXXXXXXX PARSE ERROR for string '%s'. RETURNING Void.TODO@.@." s; "\nXXXXXXX PARSE ERROR for string '%s'. RETURNING Void.TODO@.@." s;
Sil.Tvoid) in Sil.Tvoid) in
try try
search_for_named_type tenv t search_for_named_type tenv t
with Typename_not_found -> Printing.log_stats with Typename_not_found -> Printing.log_stats
~fmt:"\nXXXXXX Parsed string '%s' as UNKNOWN type name. RETURNING a type name.TODO@.@." s; "\nXXXXXX Parsed string '%s' as UNKNOWN type name. RETURNING a type name.TODO@.@." s;
t) t)
let qual_type_to_sil_type_no_expansions tenv qt = let qual_type_to_sil_type_no_expansions tenv qt =
@ -120,12 +120,12 @@ let parse_func_type name func_type =
match arg_types with match arg_types with
| [Sil.Tvoid] -> [] | [Sil.Tvoid] -> []
| _ -> arg_types in | _ -> arg_types in
Printing.log_out ~fmt: Printing.log_out
" ...Parsed. Translated with sil return type '%s' @." " ...Parsed. Translated with sil return type '%s' @."
((Sil.typ_to_string return_type)^" <- "^(Utils.list_to_string (Sil.typ_to_string) arg_types)); ((Sil.typ_to_string return_type)^" <- "^(Utils.list_to_string (Sil.typ_to_string) arg_types));
Some (return_type, arg_types) Some (return_type, arg_types)
with Parsing.Parse_error -> ( with Parsing.Parse_error -> (
Printing.log_stats ~fmt:"\nXXXXXXX PARSE ERROR for string '%s'." func_type; Printing.log_stats "\nXXXXXXX PARSE ERROR for string '%s'." func_type;
None) None)
(*In case of typedef like *) (*In case of typedef like *)
@ -145,9 +145,9 @@ let rec disambiguate_typedef tenv namespace t mn =
(match Sil.tenv_lookup tenv tn with (match Sil.tenv_lookup tenv tn with
| Some _ -> | Some _ ->
(* There is a struct in tenv, so we make the typedef mn pointing to the struct*) (* There is a struct in tenv, so we make the typedef mn pointing to the struct*)
Printing.log_out ~fmt:" ...Found type TN_typdef('%s') " (Mangled.to_string mn); Printing.log_out " ...Found type TN_typdef('%s') " (Mangled.to_string mn);
Printing.log_out ~fmt:"in typedef of '%s'@." (Mangled.to_string mn); Printing.log_out "in typedef of '%s'@." (Mangled.to_string mn);
Printing.log_out ~fmt: Printing.log_out
"Avoid circular definition in tenv by pointing the typedef to struc TN_csu('%s')@." "Avoid circular definition in tenv by pointing the typedef to struc TN_csu('%s')@."
(Mangled.to_string mn); (Mangled.to_string mn);
Sil.Tvar(tn) Sil.Tvar(tn)
@ -168,9 +168,9 @@ and do_typedef_declaration tenv namespace decl_info name opt_type typedef_decl_i
let t = opt_type_to_sil_type tenv opt_type in let t = opt_type_to_sil_type tenv opt_type in
(* check for ambiguities in typedef that may create circularities in tenv*) (* check for ambiguities in typedef that may create circularities in tenv*)
let typ = disambiguate_typedef tenv namespace t mn in let typ = disambiguate_typedef tenv namespace t mn in
Printing.log_out ~fmt:"ADDING: TypedefDecl for '%s'" name; Printing.log_out "ADDING: TypedefDecl for '%s'" name;
Printing.log_out ~fmt:" with type '%s'\n" (Sil.typ_to_string typ); Printing.log_out " with type '%s'\n" (Sil.typ_to_string typ);
Printing.log_out ~fmt:" ...Adding entry to tenv with Typename TN_typedef = '%s'\n" Printing.log_out " ...Adding entry to tenv with Typename TN_typedef = '%s'\n"
(Sil.typename_to_string typename); (Sil.typename_to_string typename);
Sil.tenv_add tenv typename typ Sil.tenv_add tenv typename typ
@ -178,7 +178,7 @@ and get_struct_fields tenv namespace decl_list =
match decl_list with match decl_list with
| [] -> [] | [] -> []
| FieldDecl(decl_info, name, qual_type, field_decl_info):: decl_list' -> | FieldDecl(decl_info, name, qual_type, field_decl_info):: decl_list' ->
Printing.log_out ~fmt:" ...Defining field '%s'.\n" name; Printing.log_out " ...Defining field '%s'.\n" name;
let id = Ident.create_fieldname (Mangled.from_string name) 0 in let id = Ident.create_fieldname (Mangled.from_string name) 0 in
let typ = qual_type_to_sil_type tenv qual_type in let typ = qual_type_to_sil_type tenv qual_type in
let annotation_items = [] in (* For the moment we don't use them*) let annotation_items = [] in (* For the moment we don't use them*)
@ -193,8 +193,8 @@ and get_struct_fields tenv namespace decl_list =
| _ :: decl_list' -> get_struct_fields tenv namespace decl_list' | _ :: decl_list' -> get_struct_fields tenv namespace decl_list'
and do_record_declaration tenv namespace decl_info name opt_type decl_list decl_context_info record_decl_info = and do_record_declaration tenv namespace decl_info name opt_type decl_list decl_context_info record_decl_info =
Printing.log_out ~fmt:"ADDING: RecordDecl for '%s'" name; Printing.log_out "ADDING: RecordDecl for '%s'" name;
Printing.log_out ~fmt:" pointer= '%s'\n" decl_info.Clang_ast_t.di_pointer; Printing.log_out " pointer= '%s'\n" decl_info.Clang_ast_t.di_pointer;
if not record_decl_info.Clang_ast_t.rdi_is_complete_definition then if not record_decl_info.Clang_ast_t.rdi_is_complete_definition then
Printing.log_err " ...Warning, definition incomplete. The full definition will probably be later \n"; Printing.log_err " ...Warning, definition incomplete. The full definition will probably be later \n";
let typ = get_declaration_type tenv namespace decl_info name opt_type decl_list decl_context_info record_decl_info in let typ = get_declaration_type tenv namespace decl_info name opt_type decl_list decl_context_info record_decl_info in
@ -205,7 +205,7 @@ and do_record_declaration tenv namespace decl_info name opt_type decl_list decl_
and get_declaration_type tenv namespace decl_info n opt_type decl_list decl_context_info record_decl_info = and get_declaration_type tenv namespace decl_info n opt_type decl_list decl_context_info record_decl_info =
let ns_suffix = Ast_utils.namespace_to_string namespace in let ns_suffix = Ast_utils.namespace_to_string namespace in
let n = ns_suffix^n in let n = ns_suffix^n in
Printing.log_out ~fmt: "Record Declaration '%s' defined as struct\n" n; Printing.log_out "Record Declaration '%s' defined as struct\n" n;
let non_static_fields = get_struct_fields tenv namespace decl_list in let non_static_fields = get_struct_fields tenv namespace decl_list in
let non_static_fields = if CTrans_models.is_objc_memory_model_controlled n then let non_static_fields = if CTrans_models.is_objc_memory_model_controlled n then
append_no_duplicates_fields [Sil.objc_ref_counter_field] non_static_fields append_no_duplicates_fields [Sil.objc_ref_counter_field] non_static_fields
@ -229,7 +229,7 @@ and get_declaration_type tenv namespace decl_info n opt_type decl_list decl_cont
(* Look for a record definition that is defined after it is dereferenced. *) (* Look for a record definition that is defined after it is dereferenced. *)
(* It returns true if a new record definition has been added to tenv.*) (* It returns true if a new record definition has been added to tenv.*)
and add_late_defined_record tenv namespace typename = and add_late_defined_record tenv namespace typename =
Printing.log_out ~fmt:"!!!! Calling late-defined record '%s'\n" (Sil.typename_to_string typename) ; Printing.log_out "!!!! Calling late-defined record '%s'\n" (Sil.typename_to_string typename) ;
match typename with match typename with
| Sil.TN_csu(Sil.Struct, name) | Sil.TN_csu(Sil.Union, name) -> | Sil.TN_csu(Sil.Struct, name) | Sil.TN_csu(Sil.Union, name) ->
let rec scan decls = let rec scan decls =
@ -250,7 +250,7 @@ and add_late_defined_record tenv namespace typename =
if (Sil.typename_equal typename pot_struct_type || if (Sil.typename_equal typename pot_struct_type ||
Sil.typename_equal typename pot_union_type) && Sil.typename_equal typename pot_union_type) &&
record_decl_info.Clang_ast_t.rdi_is_complete_definition then ( record_decl_info.Clang_ast_t.rdi_is_complete_definition then (
Printing.log_out ~fmt:"!!!! Adding late-defined record '%s'\n" t; Printing.log_out "!!!! Adding late-defined record '%s'\n" t;
do_record_declaration tenv namespace decl_info record_name opt_type decl_list do_record_declaration tenv namespace decl_info record_name opt_type decl_list
decl_context_info record_decl_info; decl_context_info record_decl_info;
true) true)
@ -264,7 +264,7 @@ and add_late_defined_record tenv namespace typename =
(* Look for a typedef definition that is defined after it is used. *) (* Look for a typedef definition that is defined after it is used. *)
(* It returns true if a new typedef definition has been added to tenv.*) (* It returns true if a new typedef definition has been added to tenv.*)
and add_late_defined_typedef tenv namespace typename = and add_late_defined_typedef tenv namespace typename =
Printing.log_out ~fmt:"Calling late-defined typedef '%s'\n" (Sil.typename_to_string typename); Printing.log_out "Calling late-defined typedef '%s'\n" (Sil.typename_to_string typename);
match typename with match typename with
| Sil.TN_typedef name -> | Sil.TN_typedef name ->
let rec scan decls = let rec scan decls =
@ -274,7 +274,7 @@ and add_late_defined_typedef tenv namespace typename =
(match opt_type with (match opt_type with
| `Type t -> | `Type t ->
if (Mangled.to_string name) = name' then ( if (Mangled.to_string name) = name' then (
Printing.log_out ~fmt:"!!!! Adding late-defined typedef '%s'\n" t; Printing.log_out "!!!! Adding late-defined typedef '%s'\n" t;
do_typedef_declaration tenv namespace decl_info name' opt_type tdi; do_typedef_declaration tenv namespace decl_info name' opt_type tdi;
true) true)
else scan decls' else scan decls'
@ -291,7 +291,7 @@ and expand_structured_type tenv typ =
(match Sil.tenv_lookup tenv tn with (match Sil.tenv_lookup tenv tn with
| Some t -> | Some t ->
Printing.log_out Printing.log_out
~fmt:" Type expanded with type '%s' found in tenv@." (Sil.typ_to_string t); " Type expanded with type '%s' found in tenv@." (Sil.typ_to_string t);
if Sil.typ_equal t typ then if Sil.typ_equal t typ then
typ typ
else expand_structured_type tenv t else expand_structured_type tenv t
@ -309,16 +309,16 @@ and add_struct_to_tenv tenv typ =
| _ -> assert false in | _ -> assert false in
let mangled = CTypes.get_name_from_struct typ in let mangled = CTypes.get_name_from_struct typ in
let typename = Sil.TN_csu(csu, mangled) in let typename = Sil.TN_csu(csu, mangled) in
Printing.log_out ~fmt:" >>>Adding struct to tenv mangled='%s'\n" (Mangled.to_string mangled); Printing.log_out " >>>Adding struct to tenv mangled='%s'\n" (Mangled.to_string mangled);
Printing.log_out ~fmt:" >>>Adding struct to tenv typ='%s'\n" (Sil.typ_to_string typ); Printing.log_out " >>>Adding struct to tenv typ='%s'\n" (Sil.typ_to_string typ);
Printing.log_out ~fmt:" >>>with Key Typename TN_csu('%s')\n" (Sil.typename_to_string typename); Printing.log_out " >>>with Key Typename TN_csu('%s')\n" (Sil.typename_to_string typename);
Printing.log_out ~fmt:" >>>Adding entry to tenv ('%s'," (Sil.typename_to_string typename); Printing.log_out " >>>Adding entry to tenv ('%s'," (Sil.typename_to_string typename);
Printing.log_out ~fmt:"'%s')\n" (Sil.typ_to_string typ); Printing.log_out "'%s')\n" (Sil.typ_to_string typ);
Sil.tenv_add tenv typename typ; Sil.tenv_add tenv typename typ;
Printing.log_out ~fmt:" >>>Verifying that Typename TN_csu('%s') is in tenv\n" Printing.log_out " >>>Verifying that Typename TN_csu('%s') is in tenv\n"
(Sil.typename_to_string typename); (Sil.typename_to_string typename);
(match Sil.tenv_lookup tenv typename with (match Sil.tenv_lookup tenv typename with
| Some t -> Printing.log_out ~fmt:" >>>OK. Found typ='%s'\n" (Sil.typ_to_string t) | Some t -> Printing.log_out " >>>OK. Found typ='%s'\n" (Sil.typ_to_string t)
| None -> Printing.log_out " >>>NOT Found!!\n") | None -> Printing.log_out " >>>NOT Found!!\n")
and qual_type_to_sil_type_general tenv qt no_pointer = and qual_type_to_sil_type_general tenv qt no_pointer =

2
infer/src/clang/cTypes_parser.mly
Unescape View File

@ -217,7 +217,7 @@ clang_type:
| VOLATILE pointer_clang_type { $2 } | VOLATILE pointer_clang_type { $2 }
| ident ANONYM_IDENT { CFrontend_utils.Printing.log_out " ...Found just an identifier modified with a protocol. Ignoring protocol!. Parsing as Named Type!\n"; | ident ANONYM_IDENT { CFrontend_utils.Printing.log_out " ...Found just an identifier modified with a protocol. Ignoring protocol!. Parsing as Named Type!\n";
Sil.Tvar (Sil.TN_typedef(Mangled.from_string $1))} Sil.Tvar (Sil.TN_typedef(Mangled.from_string $1))}
| ident { CFrontend_utils.Printing.log_out ~fmt:" ...Found just an identifier. Parsing as Named Type %s !\n" $1; | ident { CFrontend_utils.Printing.log_out " ...Found just an identifier. Parsing as Named Type %s !\n" $1;
Sil.Tvar (Sil.TN_typedef(Mangled.from_string $1))} Sil.Tvar (Sil.TN_typedef(Mangled.from_string $1))}
| csu_sil ident_csu { let typename=Sil.TN_csu($1, Mangled.from_string $2) in | csu_sil ident_csu { let typename=Sil.TN_csu($1, Mangled.from_string $2) in
Sil.Tvar typename } Sil.Tvar typename }

42
infer/src/clang/cVar_decl.ml
Unescape View File

@ -15,8 +15,8 @@ module L = Logging
(* For a variable declaration it return/construct the type *) (* For a variable declaration it return/construct the type *)
let get_var_type tenv name t = let get_var_type tenv name t =
let typ = CTypes_decl.qual_type_to_sil_type tenv t in let typ = CTypes_decl.qual_type_to_sil_type tenv t in
Printing.log_out ~fmt:" Getting/Defining type for variable '%s'" name; Printing.log_out " Getting/Defining type for variable '%s'" name;
Printing.log_out ~fmt:" as sil type '%s'\n" (Sil.typ_to_string typ); Printing.log_out " as sil type '%s'\n" (Sil.typ_to_string typ);
typ typ
(* NOTE: Currently we use this function to avoid certain C++ global variable definition defined *) (* NOTE: Currently we use this function to avoid certain C++ global variable definition defined *)
@ -26,31 +26,31 @@ let global_to_be_added di =
(di.Clang_ast_t.di_parent_pointer = None) && (di.Clang_ast_t.di_previous_decl =`None) (di.Clang_ast_t.di_parent_pointer = None) && (di.Clang_ast_t.di_previous_decl =`None)
let global_var_decl tenv namespace decl_info name t = let global_var_decl tenv namespace decl_info name t =
Printing.log_out ~fmt:"PASSING: VarDecl for '%s' to global procdesc" name; Printing.log_out "PASSING: VarDecl for '%s' to global procdesc" name;
Printing.log_out ~fmt:" pointer= '%s'\n" decl_info.Clang_ast_t.di_pointer; Printing.log_out " pointer= '%s'\n" decl_info.Clang_ast_t.di_pointer;
if global_to_be_added decl_info then ( if global_to_be_added decl_info then (
let typ = get_var_type tenv name t in let typ = get_var_type tenv name t in
Printing.log_out ~fmt:" >>> Adding entry to global procdesc: ('%s', " name; Printing.log_out " >>> Adding entry to global procdesc: ('%s', " name;
Printing.log_out ~fmt:"'%s')\n" (Sil.typ_to_string typ); Printing.log_out "'%s')\n" (Sil.typ_to_string typ);
CGlobal_vars.add name typ) CGlobal_vars.add name typ)
else Printing.log_out ~fmt:"SKIPPING VarDecl for '%s'\n" name else Printing.log_out "SKIPPING VarDecl for '%s'\n" name
let rec lookup_ahead_for_vardecl context pointer var_name kind decl_list = let rec lookup_ahead_for_vardecl context pointer var_name kind decl_list =
match decl_list with match decl_list with
| [] -> Printing.log_out ~fmt:" Failing when looking ahead for variable '%s'\n" var_name; | [] -> Printing.log_out " Failing when looking ahead for variable '%s'\n" var_name;
assert false (* nothing has been found ahead, maybe something bad in the AST *) assert false (* nothing has been found ahead, maybe something bad in the AST *)
| VarDecl(decl_info, var_name', t, _) :: rest when var_name = var_name' -> | VarDecl(decl_info, var_name', t, _) :: rest when var_name = var_name' ->
if global_to_be_added decl_info then ( if global_to_be_added decl_info then (
let tenv = CContext.get_tenv context in let tenv = CContext.get_tenv context in
Printing.log_out ~fmt:"ADDING (later-defined): VarDecl '%s' to global procdesc\n" var_name'; Printing.log_out "ADDING (later-defined): VarDecl '%s' to global procdesc\n" var_name';
let typ = get_var_type tenv var_name' t in let typ = get_var_type tenv var_name' t in
Printing.log_out ~fmt:" >>> Adding (later-defined) entry to global procdesc: ('%s', " var_name'; Printing.log_out " >>> Adding (later-defined) entry to global procdesc: ('%s', " var_name';
Printing.log_out ~fmt:"'%s')\n" (Sil.typ_to_string typ); Printing.log_out "'%s')\n" (Sil.typ_to_string typ);
CGlobal_vars.add var_name' typ; CGlobal_vars.add var_name' typ;
let mangled_var_name = Mangled.from_string var_name' in let mangled_var_name = Mangled.from_string var_name' in
let global_var = CGlobal_vars.find mangled_var_name in let global_var = CGlobal_vars.find mangled_var_name in
CGlobal_vars.var_get_name global_var) CGlobal_vars.var_get_name global_var)
else (Printing.log_out ~fmt:"SKIPPING VarDecl for '%s'\n" var_name; else (Printing.log_out "SKIPPING VarDecl for '%s'\n" var_name;
lookup_ahead_for_vardecl context pointer var_name kind rest) lookup_ahead_for_vardecl context pointer var_name kind rest)
| _ :: rest -> | _ :: rest ->
lookup_ahead_for_vardecl context pointer var_name kind rest lookup_ahead_for_vardecl context pointer var_name kind rest
@ -74,11 +74,11 @@ let lookup_var_static_globals context name =
let pname = Cfg.Procdesc.get_proc_name context.CContext.procdesc in let pname = Cfg.Procdesc.get_proc_name context.CContext.procdesc in
let str_pname = remove_block_name pname in let str_pname = remove_block_name pname in
let static_name = Sil.mk_static_local_name str_pname name in let static_name = Sil.mk_static_local_name str_pname name in
Printing.log_out ~fmt:" ...Looking for variable '%s' in static globals...\n" static_name; Printing.log_out " ...Looking for variable '%s' in static globals...\n" static_name;
let var_name = Mangled.from_string static_name in let var_name = Mangled.from_string static_name in
let global_var = CGlobal_vars.find var_name in let global_var = CGlobal_vars.find var_name in
let var = CGlobal_vars.var_get_name global_var in let var = CGlobal_vars.var_get_name global_var in
Printing.log_out ~fmt:" ...Variable '%s' found in static globals!!\n" (Sil.pvar_to_string var); Printing.log_out " ...Variable '%s' found in static globals!!\n" (Sil.pvar_to_string var);
var var
let lookup_var stmt_info context pointer var_name kind = let lookup_var stmt_info context pointer var_name kind =
@ -89,7 +89,7 @@ let lookup_var stmt_info context pointer var_name kind =
try try
lookup_var_static_globals context var_name lookup_var_static_globals context var_name
with Not_found -> with Not_found ->
(Printing.log_out ~fmt:"Looking on later-defined decls for '%s'\n" var_name; (Printing.log_out "Looking on later-defined decls for '%s'\n" var_name;
let decl_list = !CFrontend_config.global_translation_unit_decls in let decl_list = !CFrontend_config.global_translation_unit_decls in
lookup_ahead_for_vardecl context pointer var_name kind decl_list ) lookup_ahead_for_vardecl context pointer var_name kind decl_list )
@ -105,7 +105,7 @@ let rec get_variables_stmt context (stmt : Clang_ast_t.stmt) : unit =
| DeclRefExpr(stmt_info, stmt_list, expr_info, decl_ref_expr_info) -> | DeclRefExpr(stmt_info, stmt_list, expr_info, decl_ref_expr_info) ->
(* Notice that DeclRefExpr is the reference to a declared var/function/enum... *) (* Notice that DeclRefExpr is the reference to a declared var/function/enum... *)
(* so no declaration here *) (* so no declaration here *)
Printing.log_out ~fmt:"Collecting variables, passing from DeclRefExpr '%s'\n" Printing.log_out "Collecting variables, passing from DeclRefExpr '%s'\n"
stmt_info.Clang_ast_t.si_pointer; stmt_info.Clang_ast_t.si_pointer;
let var_name = CTrans_utils.get_name_decl_ref_exp_info decl_ref_expr_info stmt_info in let var_name = CTrans_utils.get_name_decl_ref_exp_info decl_ref_expr_info stmt_info in
let kind = CTrans_utils.get_decl_kind decl_ref_expr_info in let kind = CTrans_utils.get_decl_kind decl_ref_expr_info in
@ -115,11 +115,11 @@ let rec get_variables_stmt context (stmt : Clang_ast_t.stmt) : unit =
let pvar = lookup_var stmt_info context stmt_info.Clang_ast_t.si_pointer var_name kind in let pvar = lookup_var stmt_info context stmt_info.Clang_ast_t.si_pointer var_name kind in
CContext.LocalVars.add_pointer_var stmt_info.Clang_ast_t.si_pointer pvar context) CContext.LocalVars.add_pointer_var stmt_info.Clang_ast_t.si_pointer pvar context)
| CompoundStmt(stmt_info, lstmt) -> | CompoundStmt(stmt_info, lstmt) ->
Printing.log_out ~fmt:"Collecting variables, passing from CompoundStmt '%s'\n" Printing.log_out "Collecting variables, passing from CompoundStmt '%s'\n"
stmt_info.Clang_ast_t.si_pointer; stmt_info.Clang_ast_t.si_pointer;
CContext.LocalVars.enter_and_leave_scope context get_fun_locals lstmt CContext.LocalVars.enter_and_leave_scope context get_fun_locals lstmt
| ForStmt(stmt_info, lstmt) -> | ForStmt(stmt_info, lstmt) ->
Printing.log_out ~fmt:"Collecting variables, passing from ForStmt '%s'\n" Printing.log_out "Collecting variables, passing from ForStmt '%s'\n"
stmt_info.Clang_ast_t.si_pointer; stmt_info.Clang_ast_t.si_pointer;
CContext.LocalVars.enter_and_leave_scope context get_fun_locals lstmt CContext.LocalVars.enter_and_leave_scope context get_fun_locals lstmt
| _ -> | _ ->
@ -138,7 +138,7 @@ and get_variables_decls context (decl_list : Clang_ast_t.decl list) : unit =
let do_one_decl decl = let do_one_decl decl =
match decl with match decl with
| VarDecl (decl_info, name, qual_type, var_decl_info) -> | VarDecl (decl_info, name, qual_type, var_decl_info) ->
Printing.log_out ~fmt:"Collecting variables, passing from VarDecl '%s'\n" decl_info.Clang_ast_t.di_pointer; Printing.log_out "Collecting variables, passing from VarDecl '%s'\n" decl_info.Clang_ast_t.di_pointer;
let typ = get_var_type context.CContext.tenv name qual_type in let typ = get_var_type context.CContext.tenv name qual_type in
(match var_decl_info.Clang_ast_t.vdi_storage_class with (match var_decl_info.Clang_ast_t.vdi_storage_class with
| Some "static" -> | Some "static" ->
@ -160,10 +160,10 @@ and get_variables_decls context (decl_list : Clang_ast_t.decl list) : unit =
decl_info name opt_type typedef_decl_info decl_info name opt_type typedef_decl_info
| StaticAssertDecl decl_info -> (* We do not treat Assertions. *) | StaticAssertDecl decl_info -> (* We do not treat Assertions. *)
Printing.log_out Printing.log_out
~fmt:"WARNING: When collecting variables, passing from StaticAssertDecl '%s'. Skipped.\n" "WARNING: When collecting variables, passing from StaticAssertDecl '%s'. Skipped.\n"
decl_info.Clang_ast_t.di_pointer decl_info.Clang_ast_t.di_pointer
| _ -> Printing.log_out | _ -> Printing.log_out
~fmt:"!!! When collecting locals of a function found '%s'. Cannot continue\n\n" "!!! When collecting locals of a function found '%s'. Cannot continue\n\n"
(Clang_ast_j.string_of_decl decl); (Clang_ast_j.string_of_decl decl);
assert false in assert false in
list_iter do_one_decl decl_list list_iter do_one_decl decl_list

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

@ -39,7 +39,7 @@ let get_category_name_from_category_impl category_impl_info =
(* to the corresponding class. Update the tenv accordingly.*) (* to the corresponding class. Update the tenv accordingly.*)
let process_category tenv name class_name decl_list = let process_category tenv name class_name decl_list =
let name = if name ="" then noname_category class_name else name in let name = if name ="" then noname_category class_name else name in
Printing.log_out ~fmt:"Now name is '%s'\n" name; Printing.log_out "Now name is '%s'\n" name;
let curr_class = CContext.ContextCategory (name, class_name) in let curr_class = CContext.ContextCategory (name, class_name) in
let fields = CField_decl.get_fields tenv curr_class decl_list in let fields = CField_decl.get_fields tenv curr_class decl_list in
let methods = ObjcProperty_decl.get_methods curr_class decl_list in let methods = ObjcProperty_decl.get_methods curr_class decl_list in
@ -53,19 +53,19 @@ let process_category tenv name class_name decl_list =
Sil.Tstruct ( Sil.Tstruct (
new_fields, [], Sil.Class, Some mang_name, superclass, new_methods, annotation new_fields, [], Sil.Class, Some mang_name, superclass, new_methods, annotation
) in ) in
Printing.log_out ~fmt:" 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;
curr_class curr_class
| _ -> assert false | _ -> assert false
let category_decl tenv name category_decl_info decl_list = let category_decl tenv name category_decl_info decl_list =
Printing.log_out ~fmt:"ADDING: ObjCCategoryDecl for '%s'\n" name; Printing.log_out "ADDING: ObjCCategoryDecl for '%s'\n" name;
let class_name = get_class_from_category_decl category_decl_info in let class_name = get_class_from_category_decl category_decl_info in
process_category tenv name class_name decl_list process_category tenv name class_name decl_list
let category_impl_decl tenv name decl_info category_impl_decl_info decl_list = let category_impl_decl tenv name decl_info category_impl_decl_info decl_list =
let category_name = get_category_name_from_category_impl category_impl_decl_info in let category_name = get_category_name_from_category_impl category_impl_decl_info in
Printing.log_out ~fmt:"ADDING: ObjCCategoryImplDecl for '%s'\n" category_name; Printing.log_out "ADDING: ObjCCategoryImplDecl for '%s'\n" category_name;
let cat_class = get_class_from_category_impl category_impl_decl_info in let cat_class = get_class_from_category_impl category_impl_decl_info in
process_category tenv category_name cat_class decl_list process_category tenv category_name cat_class decl_list

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

@ -20,21 +20,21 @@ module L = Logging
let objc_class_str = "ObjC-Class" let objc_class_str = "ObjC-Class"
let objc_class_annotation = let objc_class_annotation =
[({ Sil.class_name=objc_class_str; Sil.parameters=[]}, true)] [({ Sil.class_name = objc_class_str; Sil.parameters =[]}, true)]
let is_objc_class_annotation a = let is_objc_class_annotation a =
match a with match a with
| [({Sil.class_name=n; Sil.parameters=[]},true)] when n=objc_class_str -> true | [({ Sil.class_name = n; Sil.parameters =[]}, true)] when n = objc_class_str -> true
| _ -> false | _ -> false
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 (Sil.Class, cname)), _) ->
(match Sil.tenv_lookup tenv (Sil.TN_csu (Sil.Class, cname)) with (match Sil.tenv_lookup tenv (Sil.TN_csu (Sil.Class, cname)) with
| Some Sil.Tstruct(_, _, Sil.Class, _, _, _, a) when is_objc_class_annotation a -> true | Some Sil.Tstruct(_, _, Sil.Class, _, _, _, a) when is_objc_class_annotation a -> true
| _ -> false) | _ -> false)
| Sil.Tptr (Sil.Tstruct(_, _, Sil.Class, _, _, _, a), _) when | Sil.Tptr (Sil.Tstruct(_, _, Sil.Class, _, _, _, a), _) when
is_objc_class_annotation a -> true is_objc_class_annotation a -> true
| _ -> false | _ -> false
let get_super_interface_decl otdi_super = let get_super_interface_decl otdi_super =
@ -89,7 +89,7 @@ let update_curr_class curr_class superclasses =
(* 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 tenv class_name decl_list obj_c_interface_decl_info = let add_class_to_tenv tenv class_name decl_list obj_c_interface_decl_info =
Printing.log_out ~fmt:"ADDING: ObjCInterfaceDecl for '%s'\n" class_name; Printing.log_out "ADDING: ObjCInterfaceDecl for '%s'\n" class_name;
let interface_name = CTypes.mk_classname class_name in let interface_name = CTypes.mk_classname class_name in
let curr_class, superclasses, fields = let curr_class, superclasses, fields =
create_curr_class_and_superclasses_fields tenv decl_list class_name create_curr_class_and_superclasses_fields tenv decl_list class_name
@ -98,8 +98,8 @@ let add_class_to_tenv tenv class_name decl_list obj_c_interface_decl_info =
let methods = ObjcProperty_decl.get_methods curr_class decl_list in let methods = ObjcProperty_decl.get_methods curr_class decl_list in
let fields_sc = CField_decl.fields_superclass tenv obj_c_interface_decl_info in let fields_sc = CField_decl.fields_superclass tenv obj_c_interface_decl_info in
list_iter (fun (fn, ft, _) -> list_iter (fun (fn, ft, _) ->
Printing.log_out ~fmt:"----->SuperClass field: '%s' " (Ident.fieldname_to_string fn); Printing.log_out "----->SuperClass field: '%s' " (Ident.fieldname_to_string fn);
Printing.log_out ~fmt:"type: '%s'\n" (Sil.typ_to_string ft)) fields_sc; Printing.log_out "type: '%s'\n" (Sil.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, methods = let fields, superclasses, methods =
match Sil.tenv_lookup tenv interface_name with match Sil.tenv_lookup tenv interface_name with
@ -111,17 +111,17 @@ let add_class_to_tenv tenv class_name decl_list obj_c_interface_decl_info =
let fields = append_no_duplicates_fields fields fields_sc in let fields = 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 fields = append_no_duplicates_fields [Sil.objc_ref_counter_field] fields in let fields = append_no_duplicates_fields [Sil.objc_ref_counter_field] fields in
Printing.log_out ~fmt:"Class %s field:\n" class_name; Printing.log_out "Class %s field:\n" class_name;
list_iter (fun (fn, ft, _) -> list_iter (fun (fn, ft, _) ->
Printing.log_out ~fmt:"-----> 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, [], Sil.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
~fmt:" >>>Verifying that Typename '%s' is in tenv\n" (Sil.typename_to_string interface_name); " >>>Verifying that Typename '%s' is in tenv\n" (Sil.typename_to_string interface_name);
(match Sil.tenv_lookup tenv interface_name with (match Sil.tenv_lookup tenv interface_name with
| Some t -> Printing.log_out ~fmt:" >>>OK. Found typ='%s'\n" (Sil.typ_to_string t) | Some t -> Printing.log_out " >>>OK. Found typ='%s'\n" (Sil.typ_to_string t)
| None -> Printing.log_out " >>>NOT Found!!\n"); | None -> Printing.log_out " >>>NOT Found!!\n");
curr_class curr_class
@ -134,7 +134,7 @@ let add_missing_fields tenv class_name decl_list idi =
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 (Sil.Class, mang_name) in
Printing.log_out Printing.log_out
~fmt:" >>>Verifying that Typename TN_csu('%s') is in tenv\n" " >>>Verifying that Typename TN_csu('%s') is in tenv\n"
(Sil.typename_to_string class_tn_name); (Sil.typename_to_string class_tn_name);
let curr_class = let curr_class =
(match Sil.tenv_lookup tenv class_tn_name with (match Sil.tenv_lookup tenv class_tn_name with
@ -144,19 +144,19 @@ let add_missing_fields tenv class_name decl_list idi =
let missing_field f = not (list_mem equal_fields f intf_fields) in let missing_field f = not (list_mem equal_fields f intf_fields) in
list_filter missing_field fields in list_filter missing_field fields in
Printing.log_out Printing.log_out
~fmt:" Looking for extra fields defined only in the implementation of '%s'\n" " Looking for extra fields defined only in the implementation of '%s'\n"
class_name; class_name;
let extra_fields = compute_extra_fields fields intf_fields in let extra_fields = compute_extra_fields fields intf_fields in
list_iter (fun (fn, _, _) -> list_iter (fun (fn, _, _) ->
Printing.log_out Printing.log_out
~fmt:" ---> Extra non-static field: '%s'\n" (Ident.fieldname_to_string fn)) " ---> Extra non-static field: '%s'\n" (Ident.fieldname_to_string fn))
extra_fields; extra_fields;
let new_fields = append_no_duplicates_fields extra_fields intf_fields in let new_fields = append_no_duplicates_fields extra_fields intf_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, [], Sil.Class, Some mang_name, superclass, methods, annotation
) in ) in
Printing.log_out ~fmt:" 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;
update_curr_class curr_class superclass ) update_curr_class curr_class superclass )
| _ -> assert false) in | _ -> assert false) in
@ -181,7 +181,7 @@ let interface_declaration tenv class_name decl_list obj_c_interface_decl_info =
let interface_impl_declaration tenv class_name decl_list implementation_decl_info = let interface_impl_declaration tenv class_name decl_list implementation_decl_info =
let curr_class = add_missing_fields tenv class_name decl_list implementation_decl_info in let curr_class = add_missing_fields tenv class_name decl_list implementation_decl_info in
add_missing_methods tenv class_name decl_list curr_class; add_missing_methods tenv class_name decl_list curr_class;
Printing.log_out ~fmt:"ADDING: ObjCImplementationDecl for class '%s'\n" class_name; Printing.log_out "ADDING: ObjCImplementationDecl for class '%s'\n" class_name;
Printing.log_out " Processing method declarations...\n"; Printing.log_out " Processing method declarations...\n";
curr_class curr_class
@ -217,9 +217,9 @@ let rec find_field tenv nfield str searched_late_defined =
| Some _ -> nfield | Some _ -> nfield
| None -> (Mangled.to_string cname)^"_"^nfield in *) | None -> (Mangled.to_string cname)^"_"^nfield in *)
let print_error name_field fields = let print_error name_field fields =
Printing.log_err ~fmt:"\nFaild to find name field '%s'\n\n" (Ident.fieldname_to_string name_field) ; Printing.log_err "\nFaild to find name field '%s'\n\n" (Ident.fieldname_to_string name_field) ;
Printing.log_err "In the following list of fields\n"; Printing.log_err "In the following list of fields\n";
list_iter (fun (fn, _, _) -> Printing.log_err ~fmt:"\nField name: '%s'\n\n" (Ident.fieldname_to_string fn)) fields; list_iter (fun (fn, _, _) -> Printing.log_err "\nField name: '%s'\n\n" (Ident.fieldname_to_string fn)) fields;
Printing.print_failure_info "" in Printing.print_failure_info "" in
let rec search_super s = let rec search_super s =
match s with match s with

18
infer/src/clang/objcProperty_decl.ml
Unescape View File

@ -150,7 +150,7 @@ struct
let key = (curr_class, property_name) in let key = (curr_class, property_name) in
let getter_name = get_getter_name property_name attributes in let getter_name = get_getter_name property_name attributes in
let setter_name = get_setter_name property_name attributes in let setter_name = get_setter_name property_name attributes in
Printing.log_out ~fmt:" ...Using '%s' in property table\n" (property_key_to_string key); Printing.log_out " ...Using '%s' in property table\n" (property_key_to_string key);
PropertyTableHash.add property_table key PropertyTableHash.add property_table key
(qt, attributes, decl_info, (getter_name, None), (setter_name, None), None) (qt, attributes, decl_info, (getter_name, None), (setter_name, None), None)
end end
@ -194,7 +194,7 @@ let check_for_property curr_class method_name meth_decl body =
if is_getter then (method_name = getter_name) if is_getter then (method_name = getter_name)
else (method_name = setter_name) in else (method_name = setter_name) in
if found then if found then
(Printing.log_out ~fmt:" Found property '%s' defined in property table\n" (Printing.log_out " Found property '%s' defined in property table\n"
(Property.property_key_to_string (curr_class, property_name)); (Property.property_key_to_string (curr_class, property_name));
upgrade_property_accessor upgrade_property_accessor
(curr_class, property_name) property_type meth_decl defined is_getter) in (curr_class, property_name) property_type meth_decl defined is_getter) in
@ -211,7 +211,7 @@ let prepare_dynamic_property curr_class decl_info property_impl_decl_info =
| None -> None) in | None -> None) in
(* update property info with proper ivar name *) (* update property info with proper ivar name *)
Property.replace_property (curr_class, pname) (qt', atts, di, getter, setter, ivar); Property.replace_property (curr_class, pname) (qt', atts, di, getter, setter, ivar);
Printing.log_out ~fmt: "Updated property table by adding ivar name for property pname '%s'\n" pname; Printing.log_out "Updated property table by adding ivar name for property pname '%s'\n" pname;
Some qt' Some qt'
with Not_found -> L.err "Property '%s' not found in the table. Ivar not updated and qual_type not found.@." pname; with Not_found -> L.err "Property '%s' not found in the table. Ivar not updated and qual_type not found.@." pname;
None) in None) in
@ -263,12 +263,12 @@ let get_memory_management_attribute attributes =
let make_getter_setter cfg curr_class decl_info property_impl_decl_info = let make_getter_setter cfg curr_class decl_info property_impl_decl_info =
let class_name = CContext.get_curr_class_name curr_class in let class_name = CContext.get_curr_class_name curr_class in
let prop_name = Ast_utils.property_name property_impl_decl_info in let prop_name = Ast_utils.property_name property_impl_decl_info in
Printing.log_out ~fmt:"ADDING: ObjCPropertyImplDecl for property '%s' " prop_name; Printing.log_out "ADDING: ObjCPropertyImplDecl for property '%s' " prop_name;
Printing.log_out ~fmt:"pointer = '%s'\n" decl_info.Clang_ast_t.di_pointer; Printing.log_out "pointer = '%s'\n" decl_info.Clang_ast_t.di_pointer;
let qt, attributes, decl_info, (getter_name, getter), (setter_name, setter), _ = (try let qt, attributes, decl_info, (getter_name, getter), (setter_name, setter), _ = (try
Property.find_property curr_class prop_name Property.find_property curr_class prop_name
with _ -> with _ ->
Printing.log_out ~fmt:"Property %s not found@." prop_name; Printing.log_out "Property %s not found@." prop_name;
assert false) in assert false) in
let ivar_name = get_ivarname_property property_impl_decl_info in let ivar_name = get_ivarname_property property_impl_decl_info in
let make_getter () = let make_getter () =
@ -354,7 +354,7 @@ let rec get_methods curr_class decl_list =
match decl_list with match decl_list with
| [] -> [] | [] -> []
| (ObjCMethodDecl(decl_info, method_name, method_decl_info) as d):: decl_list' -> | (ObjCMethodDecl(decl_info, method_name, method_decl_info) as d):: decl_list' ->
Printing.log_out ~fmt:" ...Adding Method '%s' \n" (class_name^"_"^method_name); Printing.log_out " ...Adding Method '%s' \n" (class_name^"_"^method_name);
let methods = get_methods curr_class decl_list' in let methods = get_methods curr_class decl_list' in
let _ = check_for_property curr_class method_name d method_decl_info.Clang_ast_t.omdi_body in let _ = check_for_property curr_class method_name d method_decl_info.Clang_ast_t.omdi_body in
let meth_name = CMethod_trans.mk_procname_from_method class_name method_name in let meth_name = CMethod_trans.mk_procname_from_method class_name method_name in
@ -363,8 +363,8 @@ let rec get_methods curr_class decl_list =
| ObjCPropertyDecl(decl_info, pname, pdi):: decl_list' -> | ObjCPropertyDecl(decl_info, pname, pdi):: decl_list' ->
(* Property declaration register the property on the property table to be *) (* Property declaration register the property on the property table to be *)
(* used later on in case getter and setters need to be synthesized by ObjCPropertyImplDecl *) (* used later on in case getter and setters need to be synthesized by ObjCPropertyImplDecl *)
Printing.log_out ~fmt:" ...Adding Property Declaration '%s' " pname; Printing.log_out " ...Adding Property Declaration '%s' " pname;
Printing.log_out ~fmt:" pointer= '%s' \n" decl_info.Clang_ast_t.di_pointer; Printing.log_out " pointer= '%s' \n" decl_info.Clang_ast_t.di_pointer;
Property.add_property (curr_class, pname) pdi.opdi_qual_type pdi.opdi_property_attributes decl_info; Property.add_property (curr_class, pname) pdi.opdi_qual_type pdi.opdi_property_attributes decl_info;
get_methods curr_class decl_list' (* TODO maybe add prop_name here *) get_methods curr_class decl_list' (* TODO maybe add prop_name here *)

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

@ -13,7 +13,7 @@ let protocol_decl tenv name decl_list =
(* Protocol_type_info contains the methods composing the protocol. *) (* Protocol_type_info contains the methods composing the protocol. *)
(* Here we are giving a similar treatment as interfaces (see above)*) (* Here we are giving a similar treatment as interfaces (see above)*)
(* 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 ~fmt:"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 curr_class = CContext.ContextProtocol name in let curr_class = CContext.ContextProtocol name in
let protocol_name = Sil.TN_csu(Sil.Protocol, mang_name) in let protocol_name = Sil.TN_csu(Sil.Protocol, mang_name) in

Write Preview
Loading…
Cancel
Save