diff --git a/infer/src/clang/ast_expressions.ml b/infer/src/clang/ast_expressions.ml index b1554184f..1d783ec81 100644 --- a/infer/src/clang/ast_expressions.ml +++ b/infer/src/clang/ast_expressions.ml @@ -7,86 +7,81 @@ * of patent rights can be found in the PATENTS file in the same directory. *) -open Clang_ast_t open CFrontend_utils (** This module creates extra ast constructs that are needed for the translation *) let dummy_source_range () = let dummy_source_loc = { - sl_file = None; + Clang_ast_t.sl_file = None; sl_line = None; - sl_column = None + sl_column = None; } in (dummy_source_loc, dummy_source_loc) -let dummy_stmt_info () = - { - Clang_ast_t.si_pointer = Ast_utils.get_fresh_pointer (); - Clang_ast_t.si_source_range = dummy_source_range () - } +let dummy_stmt_info () = { + Clang_ast_t.si_pointer = Ast_utils.get_fresh_pointer (); + si_source_range = dummy_source_range (); +} (* given a stmt_info return the same stmt_info with a fresh pointer *) let fresh_stmt_info stmt_info = { stmt_info with Clang_ast_t.si_pointer = Ast_utils.get_fresh_pointer () } -let dummy_decl_info decl_info = - { - decl_info with - Clang_ast_t.di_pointer = Ast_utils.get_fresh_pointer (); - Clang_ast_t.di_source_range = dummy_source_range (); - } +let dummy_decl_info decl_info = { + decl_info with + Clang_ast_t.di_pointer = Ast_utils.get_fresh_pointer (); + di_source_range = dummy_source_range (); +} let dummy_decl_info_in_curr_file decl_info = let source_loc = { - sl_file = Some (DB.source_file_to_abs_path !CLocation.current_source_file); + Clang_ast_t.sl_file = Some (DB.source_file_to_abs_path !CLocation.current_source_file); sl_line = None; - sl_column = None + sl_column = None; } in { decl_info with Clang_ast_t.di_pointer = Ast_utils.get_fresh_pointer (); - Clang_ast_t.di_source_range = + di_source_range = if !CFrontend_config.testing_mode then decl_info.Clang_ast_t.di_source_range - else (source_loc, source_loc) + else (source_loc, source_loc); } let empty_decl_info = { Clang_ast_t.di_pointer = ""; - Clang_ast_t.di_parent_pointer = None; - Clang_ast_t.di_previous_decl = `None; - Clang_ast_t.di_source_range = dummy_source_range (); - Clang_ast_t.di_owning_module = None; - Clang_ast_t.di_is_hidden = false; - Clang_ast_t.di_is_implicit = false; - Clang_ast_t.di_is_used = true; - Clang_ast_t.di_is_this_declaration_referenced = true; - Clang_ast_t.di_is_invalid_decl = false; - Clang_ast_t.di_attributes = []; - Clang_ast_t.di_full_comment = None; + di_parent_pointer = None; + di_previous_decl = `None; + di_source_range = dummy_source_range (); + di_owning_module = None; + di_is_hidden = false; + di_is_implicit = false; + di_is_used = true; + di_is_this_declaration_referenced = true; + di_is_invalid_decl = false; + di_attributes = []; + di_full_comment = None; } let empty_var_decl_info = { Clang_ast_t.vdi_storage_class = None; - Clang_ast_t.vdi_tls_kind =`Tls_none; - Clang_ast_t.vdi_is_module_private = false; - Clang_ast_t.vdi_is_nrvo_variable = false; - Clang_ast_t.vdi_init_expr = None; + vdi_tls_kind =`Tls_none; + vdi_is_module_private = false; + vdi_is_nrvo_variable = false; + vdi_init_expr = None; } -let stmt_info_with_fresh_pointer stmt_info = - { - Clang_ast_t.si_pointer = Ast_utils.get_fresh_pointer (); - Clang_ast_t.si_source_range = stmt_info.si_source_range - } +let stmt_info_with_fresh_pointer stmt_info = { + Clang_ast_t.si_pointer = Ast_utils.get_fresh_pointer (); + si_source_range = stmt_info.Clang_ast_t.si_source_range; +} -let create_qual_type s = - { - Clang_ast_t.qt_raw = s; - Clang_ast_t.qt_desugared = Some s; - (* pointer needs to be set when we start using these, non trivial to do though *) - Clang_ast_t.qt_type_ptr = Ast_utils.get_invalid_pointer () - } +let create_qual_type s = { + Clang_ast_t.qt_raw = s; + qt_desugared = Some s; + (* pointer needs to be set when we start using these, non trivial to do though *) + qt_type_ptr = Ast_utils.get_invalid_pointer (); +} let create_pointer_type s = create_qual_type (s^" *") @@ -100,7 +95,11 @@ let create_id_type () = create_qual_type "id" let create_char_type () = create_qual_type "char *" (* pointer needs to be set when we start using these, non trivial to do though *) -let create_BOOL_type () = { qt_raw = "BOOL"; qt_desugared = Some("signed char"); qt_type_ptr = Ast_utils.get_invalid_pointer () } +let create_BOOL_type () = { + Clang_ast_t.qt_raw = "BOOL"; + qt_desugared = Some ("signed char"); + qt_type_ptr = Ast_utils.get_invalid_pointer (); +} let create_void_unsigned_long_type () = create_qual_type "void *(unsigned long)" @@ -112,47 +111,47 @@ let create_integer_literal stmt_info n = let stmt_info = dummy_stmt_info () in let expr_info = { Clang_ast_t.ei_qual_type = create_int_type (); - Clang_ast_t.ei_value_kind = `RValue; - Clang_ast_t.ei_object_kind = `Ordinary + ei_value_kind = `RValue; + ei_object_kind = `Ordinary; } in let integer_literal_info = { Clang_ast_t.ili_is_signed = true; - Clang_ast_t.ili_bitwidth = 32; - Clang_ast_t.ili_value = n + ili_bitwidth = 32; + ili_value = n; } in - IntegerLiteral (stmt_info, [], expr_info, integer_literal_info) + Clang_ast_t.IntegerLiteral (stmt_info, [], expr_info, integer_literal_info) let create_cstyle_cast_expr stmt_info stmts qt = let expr_info = { Clang_ast_t.ei_qual_type = create_void_type (); - Clang_ast_t.ei_value_kind = `RValue; - Clang_ast_t.ei_object_kind = `Ordinary + ei_value_kind = `RValue; + ei_object_kind = `Ordinary; } in let cast_expr = { Clang_ast_t.cei_cast_kind = `NullToPointer; - Clang_ast_t.cei_base_path = [] + cei_base_path = []; } in - CStyleCastExpr (stmt_info, stmts, expr_info, cast_expr, qt) + Clang_ast_t.CStyleCastExpr (stmt_info, stmts, expr_info, cast_expr, qt) let create_parent_expr stmt_info stmts = let expr_info = { Clang_ast_t.ei_qual_type = create_void_type (); - Clang_ast_t.ei_value_kind = `RValue; - Clang_ast_t.ei_object_kind = `Ordinary + ei_value_kind = `RValue; + ei_object_kind = `Ordinary; } in - ParenExpr (stmt_info, stmts, expr_info) + Clang_ast_t.ParenExpr (stmt_info, stmts, expr_info) let create_implicit_cast_expr stmt_info stmts typ cast_kind = let expr_info = { Clang_ast_t.ei_qual_type = typ; - Clang_ast_t.ei_value_kind = `RValue; - Clang_ast_t.ei_object_kind = `Ordinary + ei_value_kind = `RValue; + ei_object_kind = `Ordinary; } in let cast_expr_info = { Clang_ast_t.cei_cast_kind = cast_kind; - Clang_ast_t.cei_base_path = [] + cei_base_path = []; } in - ImplicitCastExpr (stmt_info, stmts, expr_info, cast_expr_info) + Clang_ast_t.ImplicitCastExpr (stmt_info, stmts, expr_info, cast_expr_info) let create_nil stmt_info = let integer_literal = create_integer_literal stmt_info "0" in @@ -164,15 +163,18 @@ let create_nil stmt_info = let dummy_stmt () = let pointer = Ast_utils.get_fresh_pointer () in let source_range = dummy_source_range () in - NullStmt({ Clang_ast_t.si_pointer = pointer; Clang_ast_t.si_source_range = source_range } ,[]) + Clang_ast_t.NullStmt({ Clang_ast_t.si_pointer = pointer; si_source_range = source_range } ,[]) -let make_stmt_info di = - { Clang_ast_t.si_pointer = di.Clang_ast_t.di_pointer; Clang_ast_t.si_source_range = di.Clang_ast_t.di_source_range } +let make_stmt_info di = { + Clang_ast_t.si_pointer = di.Clang_ast_t.di_pointer; + si_source_range = di.Clang_ast_t.di_source_range; +} let make_expr_info qt vk objc_kind = { Clang_ast_t.ei_qual_type = qt; - Clang_ast_t.ei_value_kind = vk; - Clang_ast_t.ei_object_kind = objc_kind;} + ei_value_kind = vk; + ei_object_kind = objc_kind; +} let make_expr_info_with_objc_kind qt objc_kind = make_expr_info qt `LValue objc_kind @@ -180,47 +182,41 @@ let make_expr_info_with_objc_kind qt objc_kind = let make_lvalue_obc_prop_expr_info qt = make_expr_info qt `LValue `ObjCProperty -let make_method_decl_info mdi body = { - Clang_ast_t.omdi_is_instance_method = mdi.Clang_ast_t.omdi_is_instance_method; - Clang_ast_t.omdi_result_type = mdi.Clang_ast_t.omdi_result_type; - Clang_ast_t.omdi_parameters = mdi.Clang_ast_t.omdi_parameters; - Clang_ast_t.omdi_is_variadic = mdi.Clang_ast_t.omdi_is_variadic; - Clang_ast_t.omdi_body = Some body; } +let make_method_decl_info mdi body = + { mdi with Clang_ast_t.omdi_body = Some body; } let make_decl_ref_exp stmt_info expr_info drei = let stmt_info = { Clang_ast_t.si_pointer = Ast_utils.get_fresh_pointer (); - Clang_ast_t.si_source_range = stmt_info.Clang_ast_t.si_source_range + si_source_range = stmt_info.Clang_ast_t.si_source_range } in - DeclRefExpr(stmt_info, [], expr_info, drei) - -let make_obj_c_message_expr_info_instance sel = - { - Clang_ast_t.omei_selector = sel; - Clang_ast_t.omei_receiver_kind = `Instance; - Clang_ast_t.omei_is_definition_found = false; - Clang_ast_t.omei_decl_pointer = None (* TODO look into it *) - } + Clang_ast_t.DeclRefExpr(stmt_info, [], expr_info, drei) -let make_obj_c_message_expr_info_class selector qt = - { - omei_selector = selector; - omei_receiver_kind = `Class (create_qual_type qt); - Clang_ast_t.omei_is_definition_found = false; - Clang_ast_t.omei_decl_pointer = None (* TODO look into it *) - } +let make_obj_c_message_expr_info_instance sel = { + Clang_ast_t.omei_selector = sel; + omei_receiver_kind = `Instance; + omei_is_definition_found = false; + omei_decl_pointer = None; (* TODO look into it *) +} + +let make_obj_c_message_expr_info_class selector qt = { + Clang_ast_t.omei_selector = selector; + omei_receiver_kind = `Class (create_qual_type qt); + omei_is_definition_found = false; + omei_decl_pointer = None (* TODO look into it *) +} let make_name_decl name = { Clang_ast_t.ni_name = name; - Clang_ast_t.ni_qual_name = [name]; + ni_qual_name = [name]; } let make_decl_ref k decl_ptr name is_hidden qt_opt = { Clang_ast_t.dr_kind = k; - Clang_ast_t.dr_decl_pointer = decl_ptr; - Clang_ast_t.dr_name = Some (make_name_decl name); - Clang_ast_t.dr_is_hidden = is_hidden ; - Clang_ast_t.dr_qual_type = qt_opt + dr_decl_pointer = decl_ptr; + dr_name = Some (make_name_decl name); + dr_is_hidden = is_hidden ; + dr_qual_type = qt_opt } let make_decl_ref_qt k decl_ptr name is_hidden qt = @@ -234,21 +230,21 @@ let make_decl_ref_invalid k name is_hidden qt = let make_decl_ref_self ptr qt = { Clang_ast_t.dr_kind = `ImplicitParam; - Clang_ast_t.dr_decl_pointer = ptr; - Clang_ast_t.dr_name = Some (make_name_decl "self"); - Clang_ast_t.dr_is_hidden = false ; - Clang_ast_t.dr_qual_type = Some qt + dr_decl_pointer = ptr; + dr_name = Some (make_name_decl "self"); + dr_is_hidden = false ; + dr_qual_type = Some qt } let make_decl_ref_expr_info decl_ref = { Clang_ast_t.drti_decl_ref = Some decl_ref; - Clang_ast_t.drti_found_decl_ref = None; + drti_found_decl_ref = None; } let make_obj_c_ivar_ref_expr_info k ptr n qt = { Clang_ast_t.ovrei_decl_ref = make_decl_ref_qt k ptr n false qt; - Clang_ast_t.ovrei_pointer = Ast_utils.get_fresh_pointer (); - Clang_ast_t.ovrei_is_free_ivar = true; + ovrei_pointer = Ast_utils.get_fresh_pointer (); + ovrei_is_free_ivar = true; } (* Build an AST cast expression of a decl_ref_expr *) @@ -258,9 +254,10 @@ let make_cast_expr qt di decl_ref_expr_info objc_kind = let decl_ref_exp = make_decl_ref_exp stmt_info expr_info decl_ref_expr_info in let cast_expr = { Clang_ast_t.cei_cast_kind = `LValueToRValue; - Clang_ast_t.cei_base_path = [] + cei_base_path = []; } in - let cast_exp_rhs = ImplicitCastExpr(stmt_info, [decl_ref_exp], expr_info, cast_expr) in + let cast_exp_rhs = + Clang_ast_t.ImplicitCastExpr(stmt_info, [decl_ref_exp], expr_info, cast_expr) in cast_exp_rhs (* Build AST expression self.field_name as `LValue *) @@ -268,9 +265,10 @@ let make_self_field class_type di qt field_name = let qt_class = create_qual_type class_type in let expr_info = make_expr_info_with_objc_kind qt `ObjCProperty in let stmt_info = make_stmt_info di in - let cast_exp = make_cast_expr qt_class di (make_decl_ref_expr_info (make_decl_ref_self di.di_pointer qt_class)) `ObjCProperty in - let obj_c_ivar_ref_expr_info = make_obj_c_ivar_ref_expr_info (`ObjCIvar) di.di_pointer field_name qt in - let ivar_ref_exp = ObjCIvarRefExpr(stmt_info, [cast_exp], expr_info, obj_c_ivar_ref_expr_info) in + let cast_exp = make_cast_expr qt_class di (make_decl_ref_expr_info (make_decl_ref_self di.Clang_ast_t.di_pointer qt_class)) `ObjCProperty in + let obj_c_ivar_ref_expr_info = make_obj_c_ivar_ref_expr_info (`ObjCIvar) di.Clang_ast_t.di_pointer field_name qt in + let ivar_ref_exp = + Clang_ast_t.ObjCIvarRefExpr(stmt_info, [cast_exp], expr_info, obj_c_ivar_ref_expr_info) in ivar_ref_exp (* Build AST expression for self.field_name casted as `RValue. *) @@ -278,42 +276,42 @@ let make_deref_self_field class_decl_opt di qt field_name = let stmt_info = make_stmt_info di in let ivar_ref_exp = make_self_field class_decl_opt di qt field_name in let expr_info' = make_expr_info_with_objc_kind qt `ObjCProperty in - let cast_exp_info = - { - Clang_ast_t.cei_cast_kind = `LValueToRValue; - Clang_ast_t.cei_base_path = [] - } in - let cast_exp' = ImplicitCastExpr(stmt_info, [ivar_ref_exp], expr_info', cast_exp_info) in + let cast_exp_info = { + Clang_ast_t.cei_cast_kind = `LValueToRValue; + cei_base_path = []; + } in + let cast_exp' = + Clang_ast_t.ImplicitCastExpr(stmt_info, [ivar_ref_exp], expr_info', cast_exp_info) in cast_exp' let make_objc_ivar_decl decl_info qt property_impl_decl_info ivar_name = let field_decl_info = { Clang_ast_t.fldi_is_mutable = true; - Clang_ast_t.fldi_is_module_private = true; - Clang_ast_t.fldi_init_expr = None; - Clang_ast_t.fldi_bit_width_expr = None } in + fldi_is_module_private = true; + fldi_init_expr = None; + fldi_bit_width_expr = None; + } in let obj_c_ivar_decl_info = { Clang_ast_t.ovdi_is_synthesize = true; (* NOTE: We set true here because we use this definition to synthesize the getter/setter*) - Clang_ast_t.ovdi_access_control = `Private } in - ObjCIvarDecl(decl_info, make_name_decl ivar_name, qt, field_decl_info, obj_c_ivar_decl_info) + ovdi_access_control = `Private; + } in + Clang_ast_t.ObjCIvarDecl(decl_info, make_name_decl ivar_name, qt, field_decl_info, obj_c_ivar_decl_info) -let make_expr_info qt = - { - Clang_ast_t.ei_qual_type = qt; - Clang_ast_t.ei_value_kind = `LValue; - Clang_ast_t.ei_object_kind = `ObjCProperty - } +let make_expr_info qt = { + Clang_ast_t.ei_qual_type = qt; + ei_value_kind = `LValue; + ei_object_kind = `ObjCProperty +} -let make_general_expr_info qt vk ok = - { - Clang_ast_t.ei_qual_type = qt; - Clang_ast_t.ei_value_kind = vk; - Clang_ast_t.ei_object_kind = ok - } +let make_general_expr_info qt vk ok = { + Clang_ast_t.ei_qual_type = qt; + ei_value_kind = vk; + ei_object_kind = ok +} let make_ObjCBoolLiteralExpr stmt_info value = let ei = make_expr_info (create_BOOL_type ()) in - ObjCBoolLiteralExpr((fresh_stmt_info stmt_info),[], ei, value) + Clang_ast_t.ObjCBoolLiteralExpr((fresh_stmt_info stmt_info),[], ei, value) let make_decl_ref_exp_var (var_name, var_qt, var_ptr) var_kind stmt_info = let stmt_info = stmt_info_with_fresh_pointer stmt_info in @@ -330,28 +328,30 @@ let make_message_expr param_qt selector decl_ref_exp stmt_info add_cast = else [decl_ref_exp] in let obj_c_message_expr_info = make_obj_c_message_expr_info_instance selector in let expr_info = make_expr_info_with_objc_kind param_qt `ObjCProperty in - ObjCMessageExpr (stmt_info, parameters, expr_info, obj_c_message_expr_info) + Clang_ast_t.ObjCMessageExpr (stmt_info, parameters, expr_info, obj_c_message_expr_info) let make_compound_stmt stmts stmt_info = let stmt_info = stmt_info_with_fresh_pointer stmt_info in - CompoundStmt (stmt_info, stmts) + Clang_ast_t.CompoundStmt (stmt_info, stmts) let make_binary_stmt stmt1 stmt2 stmt_info expr_info boi = let stmt_info = stmt_info_with_fresh_pointer stmt_info in - BinaryOperator(stmt_info, [stmt1; stmt2], expr_info, boi) + Clang_ast_t.BinaryOperator(stmt_info, [stmt1; stmt2], expr_info, boi) let make_next_object_exp stmt_info item items = let var_decl_ref, var_type = match item with - | DeclStmt (stmt_info, _, [VarDecl(di, name_info, var_type, _)]) -> + | Clang_ast_t.DeclStmt (stmt_info, _, [Clang_ast_t.VarDecl(di, name_info, var_type, _)]) -> let var_name = name_info.Clang_ast_t.ni_name in let decl_ptr = di.Clang_ast_t.di_pointer in let decl_ref = make_decl_ref_qt `Var decl_ptr var_name false var_type in let stmt_info_var = { - si_pointer = di.Clang_ast_t.di_pointer; + Clang_ast_t.si_pointer = di.Clang_ast_t.di_pointer; si_source_range = di.Clang_ast_t.di_source_range } in - DeclRefExpr(stmt_info_var, [], (make_expr_info_with_objc_kind var_type `ObjCProperty), (make_decl_ref_expr_info decl_ref)), + let expr_info = make_expr_info_with_objc_kind var_type `ObjCProperty in + let decl_ref_expr_info = make_decl_ref_expr_info decl_ref in + Clang_ast_t.DeclRefExpr (stmt_info_var, [], expr_info, decl_ref_expr_info), var_type | _ -> assert false in let message_call = make_message_expr (create_qual_type CFrontend_config.id_cl) @@ -360,11 +360,11 @@ let make_next_object_exp stmt_info item items = make_binary_stmt var_decl_ref message_call stmt_info (make_expr_info_with_objc_kind var_type `ObjCProperty) boi let empty_var_decl = { - vdi_storage_class = None; + Clang_ast_t.vdi_storage_class = None; vdi_tls_kind =`Tls_none; vdi_is_module_private = false; vdi_is_nrvo_variable = false; - vdi_init_expr = None + vdi_init_expr = None; } (* dispatch_once(v,block_def) is transformed as: *) @@ -374,9 +374,10 @@ let translate_dispatch_function block_name stmt_info stmt_list ei n = try Utils.list_nth stmt_list (n + 1) with Not_found -> assert false in let block_name_info = make_name_decl block_name in + let open Clang_ast_t in match block_expr with - | BlockExpr(bsi, bsl, bei, bd) -> - let qt = bei.Clang_ast_t.ei_qual_type in + | BlockExpr (bsi, bsl, bei, bd) -> + let qt = bei.ei_qual_type in let cast_info = { cei_cast_kind = `BitCast; cei_base_path =[]} in let block_def = ImplicitCastExpr(stmt_info,[block_expr], bei, cast_info) in let decl_info = { empty_decl_info @@ -403,12 +404,13 @@ let make_DeclStmt stmt_info di qt vname iexp = let ie = create_implicit_cast_expr stmt_info [iexp'] qt `IntegralCast in Some ie, [ie] | None -> None, [] in - let var_decl = VarDecl(di, vname, qt, { empty_var_decl_info with Clang_ast_t.vdi_init_expr = init_expr_opt;}) in - DeclStmt(stmt_info, init_expr_l, [var_decl]) + let var_decl_info = { empty_var_decl_info with Clang_ast_t.vdi_init_expr = init_expr_opt } in + let var_decl = Clang_ast_t.VarDecl (di, vname, qt, var_decl_info) in + Clang_ast_t.DeclStmt (stmt_info, init_expr_l, [var_decl]) let build_OpaqueValueExpr si source_expr ei = let opaque_value_expr_info = { Clang_ast_t.ovei_source_expr = Some source_expr } in - OpaqueValueExpr(si, [], ei, opaque_value_expr_info) + Clang_ast_t.OpaqueValueExpr (si, [], ei, opaque_value_expr_info) let pseudo_object_qt () = create_qual_type CFrontend_config.pseudo_object_type @@ -416,34 +418,34 @@ let pseudo_object_qt () = (* Create expression PseudoObjectExpr for 'o.m' *) let build_PseudoObjectExpr qt_m o_cast_decl_ref_exp mname = match o_cast_decl_ref_exp with - | ImplicitCastExpr(si, stmt_list, ei, cast_expr_info) -> + | Clang_ast_t.ImplicitCastExpr (si, stmt_list, ei, cast_expr_info) -> let ove = build_OpaqueValueExpr si o_cast_decl_ref_exp ei in let ei_opre = make_expr_info (pseudo_object_qt ()) in let obj_c_property_ref_expr_info = { Clang_ast_t.oprei_kind = - `PropertyRef (make_decl_ref_no_qt `ObjCProperty si.si_pointer CFrontend_config.count false); - Clang_ast_t.oprei_is_super_receiver = false; - Clang_ast_t.oprei_is_messaging_getter = true; - Clang_ast_t.oprei_is_messaging_setter = false; + `PropertyRef (make_decl_ref_no_qt `ObjCProperty si.Clang_ast_t.si_pointer CFrontend_config.count false); + oprei_is_super_receiver = false; + oprei_is_messaging_getter = true; + oprei_is_messaging_setter = false; } in - let opre = ObjCPropertyRefExpr(si, [ove], ei_opre, obj_c_property_ref_expr_info) in + let opre = Clang_ast_t.ObjCPropertyRefExpr (si, [ove], ei_opre, obj_c_property_ref_expr_info) in let ome = make_message_expr qt_m mname o_cast_decl_ref_exp si false in let poe_ei = make_general_expr_info qt_m `LValue `Ordinary in - PseudoObjectExpr(si, [opre; ove; ome], poe_ei) + Clang_ast_t.PseudoObjectExpr (si, [opre; ove; ome], poe_ei) | _ -> assert false let create_call stmt_info decl_pointer function_name qt parameters = let expr_info_call = { Clang_ast_t.ei_qual_type = create_void_type (); - Clang_ast_t.ei_value_kind = `XValue; - Clang_ast_t.ei_object_kind = `Ordinary + ei_value_kind = `XValue; + ei_object_kind = `Ordinary } in let expr_info_dre = make_expr_info_with_objc_kind qt `Ordinary in let decl_ref = make_decl_ref_qt `Function decl_pointer function_name false qt in let decl_ref_info = make_decl_ref_expr_info decl_ref in - let decl_ref_exp = DeclRefExpr(stmt_info, [], expr_info_dre, decl_ref_info) in + let decl_ref_exp = Clang_ast_t.DeclRefExpr (stmt_info, [], expr_info_dre, decl_ref_info) in let cast = create_implicit_cast_expr (fresh_stmt_info stmt_info) [decl_ref_exp] qt `FunctionToPointerDecay in - CallExpr(stmt_info, cast:: parameters, expr_info_call) + Clang_ast_t.CallExpr (stmt_info, cast:: parameters, expr_info_call) (* For a of type NSArray* Translate *) (* [a enumerateObjectsUsingBlock:^(id object, NSUInteger idx, BOOL * stop) { *) @@ -472,18 +474,18 @@ let translate_block_enumerate block_name stmt_info stmt_list ei = let rec get_name_pointers lp = match lp with | [] -> [] - | ParmVarDecl(di, name, qt, _):: lp' -> + | Clang_ast_t.ParmVarDecl (di, name, qt, _) :: lp' -> (name.Clang_ast_t.ni_name, di.Clang_ast_t.di_pointer, qt):: get_name_pointers lp' | _ -> assert false in let build_idx_decl pidx = match pidx with - | ParmVarDecl(di_idx, name_idx, qt_idx, _) -> + | Clang_ast_t.ParmVarDecl (di_idx, name_idx, qt_idx, _) -> let zero = create_integer_literal stmt_info "0" in (* qt_idx idx = 0; *) let idx_decl_stmt = make_DeclStmt (fresh_stmt_info stmt_info) di_idx qt_idx name_idx (Some zero) in let idx_ei = make_expr_info qt_idx in - let idx_decl_ref = make_decl_ref_qt `Var di_idx.di_pointer name_idx.Clang_ast_t.ni_name false qt_idx in + let idx_decl_ref = make_decl_ref_qt `Var di_idx.Clang_ast_t.di_pointer name_idx.Clang_ast_t.ni_name false qt_idx in let idx_drei = make_decl_ref_expr_info idx_decl_ref in let idx_decl_ref_exp = make_decl_ref_exp stmt_info idx_ei idx_drei in let idx_cast = create_implicit_cast_expr (fresh_stmt_info stmt_info) [idx_decl_ref_exp] qt_idx `LValueToRValue in @@ -499,12 +501,13 @@ let translate_block_enumerate block_name stmt_info stmt_list ei = (* build statement BOOL *stop = malloc(sizeof(BOOL)); *) let build_stop pstop = match pstop with - | ParmVarDecl(di, name, qt, _) -> + | Clang_ast_t.ParmVarDecl (di, name, qt, _) -> let qt_fun = create_void_unsigned_long_type () in - let parameter = UnaryExprOrTypeTraitExpr((fresh_stmt_info stmt_info), [], - make_expr_info (create_unsigned_long_type ()), - { Clang_ast_t.uttei_kind = `SizeOf; Clang_ast_t.uttei_qual_type = Some (create_BOOL_type ()) }) in - let malloc = create_call (fresh_stmt_info stmt_info) di.di_pointer CFrontend_config.malloc qt_fun [parameter] in + let parameter = Clang_ast_t.UnaryExprOrTypeTraitExpr + ((fresh_stmt_info stmt_info), [], + make_expr_info (create_unsigned_long_type ()), + { Clang_ast_t.uttei_kind = `SizeOf; Clang_ast_t.uttei_qual_type = Some (create_BOOL_type ()) }) in + let malloc = create_call (fresh_stmt_info stmt_info) di.Clang_ast_t.di_pointer CFrontend_config.malloc qt_fun [parameter] in let init_exp = create_implicit_cast_expr (fresh_stmt_info stmt_info) [malloc] qt `BitCast in make_DeclStmt (fresh_stmt_info stmt_info) di qt name (Some init_exp) | _ -> assert false in @@ -512,44 +515,49 @@ let translate_block_enumerate block_name stmt_info stmt_list ei = (* BOOL *stop =NO; *) let stop_equal_no pstop = match pstop with - | ParmVarDecl(di, name, qt, _) -> - let decl_ref = make_decl_ref_qt `Var di.di_pointer name.Clang_ast_t.ni_name false qt in + | Clang_ast_t.ParmVarDecl (di, name, qt, _) -> + let decl_ref = make_decl_ref_qt `Var di.Clang_ast_t.di_pointer name.Clang_ast_t.ni_name false qt in let cast = cast_expr decl_ref qt in - let lhs = UnaryOperator((fresh_stmt_info stmt_info), [cast], ei, { uoi_kind = `Deref; uoi_is_postfix = true }) in + let postfix_deref = { Clang_ast_t.uoi_kind = `Deref; uoi_is_postfix = true } in + let lhs = Clang_ast_t.UnaryOperator (fresh_stmt_info stmt_info, [cast], ei, postfix_deref) in let bool_NO = make_ObjCBoolLiteralExpr stmt_info 0 in - BinaryOperator((fresh_stmt_info stmt_info), [lhs; bool_NO], ei, { boi_kind = `Assign }) + let assign = { Clang_ast_t.boi_kind = `Assign } in + Clang_ast_t.BinaryOperator (fresh_stmt_info stmt_info, [lhs; bool_NO], ei, assign) | _ -> assert false in (* build statement free(stop); *) let free_stop pstop = match pstop with - | ParmVarDecl(di, name, qt, _) -> + | Clang_ast_t.ParmVarDecl (di, name, qt, _) -> let qt_fun = create_void_void_type () in - let decl_ref = make_decl_ref_qt `Var di.di_pointer name.Clang_ast_t.ni_name false qt in + let decl_ref = make_decl_ref_qt `Var di.Clang_ast_t.di_pointer name.Clang_ast_t.ni_name false qt in let cast = cast_expr decl_ref qt in let parameter = create_implicit_cast_expr (fresh_stmt_info stmt_info) [cast] (create_void_type ()) `BitCast in - create_call (fresh_stmt_info stmt_info) di.di_pointer CFrontend_config.free qt_fun [parameter] + create_call (fresh_stmt_info stmt_info) di.Clang_ast_t.di_pointer CFrontend_config.free qt_fun [parameter] | _ -> assert false in (* idx ei + | Clang_ast_t.ImplicitCastExpr (_, _, ei, _) -> ei | _ -> assert false in (* id object= objects[idx]; *) let build_object_DeclStmt pobj decl_ref_expr_array decl_ref_expr_idx qt_idx = + let open Clang_ast_t in match pobj with | ParmVarDecl(di_obj, name_obj, qt_obj, _) -> let poe_ei = make_general_expr_info qt_obj `LValue `Ordinary in @@ -557,15 +565,15 @@ let translate_block_enumerate block_name stmt_info stmt_list ei = let ove_array = build_OpaqueValueExpr (fresh_stmt_info stmt_info) decl_ref_expr_array ei_array in let ei_idx = get_ei_from_cast decl_ref_expr_idx in let ove_idx = build_OpaqueValueExpr (fresh_stmt_info stmt_info) decl_ref_expr_idx ei_idx in - let objc_sre = ObjCSubscriptRefExpr((fresh_stmt_info stmt_info), [ove_array; ove_idx], - make_expr_info (pseudo_object_qt ()), - { osrei_kind =`ArraySubscript; osrei_getter = None; osrei_setter = None; }) in + let objc_sre = ObjCSubscriptRefExpr (fresh_stmt_info stmt_info, [ove_array; ove_idx], + make_expr_info (pseudo_object_qt ()), + { osrei_kind =`ArraySubscript; osrei_getter = None; osrei_setter = None; }) in let obj_c_message_expr_info = make_obj_c_message_expr_info_instance CFrontend_config.object_at_indexed_subscript_m in - let ome = ObjCMessageExpr((fresh_stmt_info stmt_info), [ove_array; ove_idx], poe_ei, obj_c_message_expr_info) in - let pseudo_obj_expr = PseudoObjectExpr((fresh_stmt_info stmt_info), [objc_sre; ove_array; ove_idx; ome], poe_ei) in + let ome = ObjCMessageExpr (fresh_stmt_info stmt_info, [ove_array; ove_idx], poe_ei, obj_c_message_expr_info) in + let pseudo_obj_expr = PseudoObjectExpr (fresh_stmt_info stmt_info, [objc_sre; ove_array; ove_idx; ome], poe_ei) in let vdi = { empty_var_decl_info with vdi_init_expr = Some (pseudo_obj_expr) } in - let var_decl = VarDecl(di_obj, name_obj, qt_obj, vdi) in - DeclStmt((fresh_stmt_info stmt_info), [pseudo_obj_expr], [var_decl]) + let var_decl = VarDecl (di_obj, name_obj, qt_obj, vdi) in + DeclStmt (fresh_stmt_info stmt_info, [pseudo_obj_expr], [var_decl]) | _ -> assert false in (* NSArray *objects = a *) @@ -573,47 +581,47 @@ let translate_block_enumerate block_name stmt_info stmt_list ei = let di = { empty_decl_info with Clang_ast_t.di_pointer = Ast_utils.get_fresh_pointer () } in let qt = create_qual_type CFrontend_config.ns_array_ptr in (* init should be ImplicitCastExpr of array a *) - let vdi = { empty_var_decl_info with vdi_init_expr = Some (init) } in - let var_decl = VarDecl(di, make_name_decl CFrontend_config.objects, qt, vdi) in - DeclStmt((fresh_stmt_info stmt_info), [init], [var_decl]), [(CFrontend_config.objects, di.Clang_ast_t.di_pointer, qt)] in + let vdi = { empty_var_decl_info with Clang_ast_t.vdi_init_expr = Some (init) } in + let var_decl = Clang_ast_t.VarDecl (di, make_name_decl CFrontend_config.objects, qt, vdi) in + Clang_ast_t.DeclStmt (fresh_stmt_info stmt_info, [init], [var_decl]), [(CFrontend_config.objects, di.Clang_ast_t.di_pointer, qt)] in let make_object_cast_decl_ref_expr objects = match objects with - | DeclStmt(si, _, [VarDecl(di, name, qt, vdi)]) -> - let decl_ref = make_decl_ref_qt `Var si.si_pointer name.Clang_ast_t.ni_name false qt in + | Clang_ast_t.DeclStmt (si, _, [Clang_ast_t.VarDecl (di, name, qt, vdi)]) -> + let decl_ref = make_decl_ref_qt `Var si.Clang_ast_t.si_pointer name.Clang_ast_t.ni_name false qt in cast_expr decl_ref qt | _ -> assert false in let build_cast_decl_ref_expr_from_parm p = match p with - | ParmVarDecl(di, name, qt, _) -> - let decl_ref = make_decl_ref_qt `Var di.di_pointer name.Clang_ast_t.ni_name false qt in + | Clang_ast_t.ParmVarDecl (di, name, qt, _) -> + let decl_ref = make_decl_ref_qt `Var di.Clang_ast_t.di_pointer name.Clang_ast_t.ni_name false qt in cast_expr decl_ref qt | _ -> assert false in let make_block_decl be = match be with - | BlockExpr(bsi, _, bei, _) -> + | Clang_ast_t.BlockExpr (bsi, _, bei, _) -> let di = { empty_decl_info with Clang_ast_t.di_pointer = Ast_utils.get_fresh_pointer () } in - let vdi = { empty_var_decl_info with vdi_init_expr = Some (be) } in - let var_decl = VarDecl(di, make_name_decl block_name, bei.Clang_ast_t.ei_qual_type, vdi) in - DeclStmt(bsi, [be], [var_decl]), [(block_name, di.Clang_ast_t.di_pointer, bei.Clang_ast_t.ei_qual_type)] + let vdi = { empty_var_decl_info with Clang_ast_t.vdi_init_expr = Some (be) } in + let var_decl = Clang_ast_t.VarDecl (di, make_name_decl block_name, bei.Clang_ast_t.ei_qual_type, vdi) in + Clang_ast_t.DeclStmt (bsi, [be], [var_decl]), [(block_name, di.Clang_ast_t.di_pointer, bei.Clang_ast_t.ei_qual_type)] | _ -> assert false in let make_block_call block_qt object_cast idx_cast stop_cast = let decl_ref = make_decl_ref_invalid `Var block_name false block_qt in let fun_cast = cast_expr decl_ref block_qt in let ei_call = make_expr_info (create_void_type ()) in - CallExpr((fresh_stmt_info stmt_info), [fun_cast; object_cast; idx_cast; stop_cast], ei_call) in + Clang_ast_t.CallExpr (fresh_stmt_info stmt_info, [fun_cast; object_cast; idx_cast; stop_cast], ei_call) in (* build statement "if (stop) break;" *) let build_if_stop stop_cast = let bool_qt = create_BOOL_type () in let ei = make_expr_info bool_qt in - let unary_op = UnaryOperator((fresh_stmt_info stmt_info), [stop_cast], ei, { uoi_kind = `Deref; uoi_is_postfix = true }) in + let unary_op = Clang_ast_t.UnaryOperator (fresh_stmt_info stmt_info, [stop_cast], ei, { Clang_ast_t.uoi_kind = `Deref; uoi_is_postfix = true }) in let cond = create_implicit_cast_expr (fresh_stmt_info stmt_info) [unary_op] bool_qt `LValueToRValue in - let break_stmt = BreakStmt((fresh_stmt_info stmt_info),[]) in - IfStmt((fresh_stmt_info stmt_info), [dummy_stmt (); cond; break_stmt; dummy_stmt ()]) in + let break_stmt = Clang_ast_t.BreakStmt (fresh_stmt_info stmt_info, []) in + Clang_ast_t.IfStmt (fresh_stmt_info stmt_info, [dummy_stmt (); cond; break_stmt; dummy_stmt ()]) in let translate params array_cast_decl_ref_exp block_decl block_qt = match params with @@ -632,37 +640,37 @@ let translate_block_enumerate block_name stmt_info stmt_list ei = let if_stop = build_if_stop stop_cast in let free_stop = free_stop pstop in [ objects_decl; block_decl; decl_stop; assign_stop; - ForStmt(stmt_info, [idx_decl_stmt; dummy_stmt (); guard; incr; - CompoundStmt(stmt_info, [obj_assignment; call_block; if_stop])]); free_stop], op + Clang_ast_t.ForStmt (stmt_info, [idx_decl_stmt; dummy_stmt (); guard; incr; + Clang_ast_t.CompoundStmt(stmt_info, [obj_assignment; call_block; if_stop])]); free_stop], op | _ -> assert false in - + let open Clang_ast_t in match stmt_list with - | [s; BlockExpr(_, _, bei, BlockDecl(_, _, _, bdi)) as be] -> + | [s; BlockExpr (_, _, bei, BlockDecl (_, _, _, bdi)) as be] -> let block_decl, bv = make_block_decl be in - let vars_to_register = get_name_pointers bdi.Clang_ast_t.bdi_parameters in - let translated_stmt, op = translate bdi.Clang_ast_t.bdi_parameters s block_decl bei.Clang_ast_t.ei_qual_type in - CompoundStmt(stmt_info, translated_stmt), vars_to_register@op@bv + let vars_to_register = get_name_pointers bdi.bdi_parameters in + let translated_stmt, op = translate bdi.bdi_parameters s block_decl bei.ei_qual_type in + CompoundStmt (stmt_info, translated_stmt), vars_to_register @ op @ bv | _ -> (* When it is not the method we expect with only one parameter, we don't translate *) Printing.log_out "WARNING: Block Enumeration called at %s not translated." (Clang_ast_j.string_of_stmt_info stmt_info); - CompoundStmt(stmt_info, stmt_list), [] + CompoundStmt (stmt_info, stmt_list), [] (* We translate the logical negation of an integer with a conditional*) (* !x <=> x?0:1 *) let trans_negation_with_conditional stmt_info expr_info stmt_list = let stmt_list_cond = stmt_list @ [create_integer_literal stmt_info "0"] @ [create_integer_literal stmt_info "1"] in - ConditionalOperator(stmt_info, stmt_list_cond, expr_info) + Clang_ast_t.ConditionalOperator (stmt_info, stmt_list_cond, expr_info) let create_call stmt_info decl_pointer function_name qt parameters = let expr_info_call = { Clang_ast_t.ei_qual_type = qt; - Clang_ast_t.ei_value_kind = `XValue; - Clang_ast_t.ei_object_kind = `Ordinary + ei_value_kind = `XValue; + ei_object_kind = `Ordinary } in let expr_info_dre = make_expr_info_with_objc_kind qt `Ordinary in let decl_ref = make_decl_ref_qt `Function decl_pointer function_name false qt in let decl_ref_info = make_decl_ref_expr_info decl_ref in - let decl_ref_exp = DeclRefExpr(stmt_info, [], expr_info_dre, decl_ref_info) in - CallExpr(stmt_info, decl_ref_exp:: parameters, expr_info_call) + let decl_ref_exp = Clang_ast_t.DeclRefExpr (stmt_info, [], expr_info_dre, decl_ref_info) in + Clang_ast_t.CallExpr (stmt_info, decl_ref_exp:: parameters, expr_info_call) let create_assume_not_null_call decl_info var_name var_type = let stmt_info = stmt_info_with_fresh_pointer (make_stmt_info decl_info) in @@ -671,15 +679,15 @@ let create_assume_not_null_call decl_info var_name var_type = let decl_ref = make_decl_ref_qt `Var decl_ptr var_name false var_type in let stmt_info_var = dummy_stmt_info () in let decl_ref_info = make_decl_ref_expr_info decl_ref in - let var_decl_ref = DeclRefExpr(stmt_info_var, [], (make_expr_info var_type), decl_ref_info) in + let var_decl_ref = Clang_ast_t.DeclRefExpr (stmt_info_var, [], (make_expr_info var_type), decl_ref_info) in let var_decl_ptr = Ast_utils.get_invalid_pointer () in let expr_info = { Clang_ast_t.ei_qual_type = var_type; - Clang_ast_t.ei_value_kind = `RValue; - Clang_ast_t.ei_object_kind = `Ordinary + ei_value_kind = `RValue; + ei_object_kind = `Ordinary } in - let cast_info_call = { cei_cast_kind = `LValueToRValue; cei_base_path = [] } in - let decl_ref_exp_cast = ImplicitCastExpr(stmt_info, [var_decl_ref], expr_info, cast_info_call) in + let cast_info_call = { Clang_ast_t.cei_cast_kind = `LValueToRValue; cei_base_path = [] } in + let decl_ref_exp_cast = Clang_ast_t.ImplicitCastExpr (stmt_info, [var_decl_ref], expr_info, cast_info_call) in let null_expr = create_integer_literal stmt_info "0" in let bin_op = make_binary_stmt decl_ref_exp_cast null_expr stmt_info (make_lvalue_obc_prop_expr_info var_type) boi in let parameters = [bin_op] in diff --git a/infer/src/clang/cAstProcessor.ml b/infer/src/clang/cAstProcessor.ml index 6b8019118..c3990afa4 100644 --- a/infer/src/clang/cAstProcessor.ml +++ b/infer/src/clang/cAstProcessor.ml @@ -12,14 +12,15 @@ w.r.t. the previous one. This module processes the AST and makes locations explicit. *) open Utils -open Clang_ast_j module L = Logging module F = Format (** Get the sub-declarations of the current declaration. *) -let decl_get_sub_decls decl = match decl with +let decl_get_sub_decls decl = + let open Clang_ast_t in + match decl with | CXXRecordDecl (_, _, _, _, decl_list, _, _, _) | RecordDecl (_, _, _, _, decl_list, _, _) | ObjCInterfaceDecl (_, _, decl_list, _, _) @@ -36,7 +37,9 @@ let decl_get_sub_decls decl = match decl with (** Set the sub-declarations of the current declaration. *) -let decl_set_sub_decls decl decl_list' = match decl with +let decl_set_sub_decls decl decl_list' = + let open Clang_ast_t in + match decl with | CXXRecordDecl (decl_info, name, opt_type, type_ptr, decl_list, decl_context_info, record_decl_info, cxx_record_info) -> CXXRecordDecl (decl_info, name, opt_type, type_ptr, decl_list', decl_context_info, record_decl_info, cxx_record_info) | RecordDecl (decl_info, name, opt_type, type_ptr, decl_list, decl_context_info, record_decl_info) -> @@ -63,13 +66,13 @@ let decl_set_sub_decls decl decl_list' = match decl with (** Pretty print a source location. *) let pp_source_loc fmt source_loc = - let file = match source_loc.sl_file with + let file = match source_loc.Clang_ast_t.sl_file with | Some file -> file | None -> "None" in - let line = match source_loc.sl_line with + let line = match source_loc.Clang_ast_t.sl_line with | Some n -> string_of_int n | None -> "None" in - let column = match source_loc.sl_column with + let column = match source_loc.Clang_ast_t.sl_column with | Some n -> string_of_int n | None -> "None" in if file = "None" && line = "None" && column = "None" @@ -89,16 +92,17 @@ let pp_ast_decl fmt ast_decl = let stmt_str = Clang_ast_proj.get_stmt_kind_string stmt in let stmt_info, stmt_list = Clang_ast_proj.get_stmt_tuple stmt in let decl_list = match stmt with - | DeclStmt (_, _, decl_list) -> decl_list + | Clang_ast_t.DeclStmt (_, _, decl_list) -> decl_list | _ -> [] in F.fprintf fmt "%s%s %a@\n" prefix stmt_str - pp_source_range stmt_info.si_source_range; + pp_source_range stmt_info.Clang_ast_t.si_source_range; list_iter (dump_stmt prefix1) stmt_list; list_iter (dump_decl prefix1) decl_list and dump_decl prefix decl = let prefix1 = prefix ^ " " in + let open Clang_ast_t in match decl with | FunctionDecl (decl_info, name, qt, fdecl_info) -> F.fprintf fmt "%sFunctionDecl %s %a@\n" @@ -131,7 +135,7 @@ let pp_ast_decl fmt ast_decl = let decl_str = Clang_ast_proj.get_decl_kind_string ast_decl in match ast_decl with - | TranslationUnitDecl (_, decl_list, _, _) -> + | Clang_ast_t.TranslationUnitDecl (_, decl_list, _, _) -> F.fprintf fmt "%s (%d declarations)@\n" decl_str (list_length decl_list); list_iter (dump_decl "") decl_list | _ -> @@ -147,17 +151,17 @@ module LocComposer : sig val create : unit -> status (** Compose a new source_range to the current one. *) - val compose : status -> source_range -> source_range + val compose : status -> Clang_ast_t.source_range -> Clang_ast_t.source_range (** Set the current file if specified in the source_range. The composer will not descend into file included from the current one. For locations in included files, it will return instead the last known location of the current file. *) - val set_current_file : status -> source_range -> unit + val set_current_file : status -> Clang_ast_t.source_range -> unit end = struct type status = { mutable curr_file: string option; - mutable curr_source_range: source_range; + mutable curr_source_range: Clang_ast_t.source_range; mutable in_curr_file : bool } let empty_sloc = { Clang_ast_t.sl_file = None; sl_line = None; sl_column = None } @@ -168,7 +172,7 @@ end = struct in_curr_file = true; } let set_current_file st (sloc1, sloc2) = - match sloc1.sl_file, sloc2.sl_file with + match sloc1.Clang_ast_t.sl_file, sloc2.Clang_ast_t.sl_file with | _, Some fname | Some fname, None -> st.curr_file <- Some fname; @@ -176,7 +180,7 @@ end = struct | _ -> () - let sloc_is_current_file st sloc = match st.curr_file, sloc.sl_file with + let sloc_is_current_file st sloc = match st.curr_file, sloc.Clang_ast_t.sl_file with | Some curr_f, Some f -> Some (f = curr_f) | None, _ -> None @@ -195,6 +199,7 @@ end = struct then let update x_opt y_opt = if y_opt <> None then y_opt else x_opt in + let open Clang_ast_t in { sl_file = update old_sloc.sl_file new_sloc.sl_file; sl_line = update old_sloc.sl_line new_sloc.sl_line; sl_column = update old_sloc.sl_column new_sloc.sl_column } @@ -220,11 +225,13 @@ end (** Apply a location composer to the locations in a statement. *) let rec stmt_process_locs loc_composer stmt = let update (stmt_info, stmt_list) = + let range' = LocComposer.compose loc_composer stmt_info.Clang_ast_t.si_source_range in let stmt_info' = { stmt_info with - si_source_range = LocComposer.compose loc_composer stmt_info.si_source_range } in + Clang_ast_t.si_source_range = range' } in let stmt_list' = list_map (stmt_process_locs loc_composer) stmt_list in (stmt_info', stmt_list') in + let open Clang_ast_t in match Clang_ast_proj.update_stmt_tuple update stmt with | DeclStmt (stmt_info, stmt_list, decl_list) -> let decl_list' = list_map (decl_process_locs loc_composer) decl_list in @@ -236,12 +243,14 @@ let rec stmt_process_locs loc_composer stmt = and decl_process_locs loc_composer decl = let decl' = let update decl_info = + let range' = LocComposer.compose loc_composer decl_info.Clang_ast_t.di_source_range in { decl_info with - di_source_range = LocComposer.compose loc_composer decl_info.di_source_range } in + Clang_ast_t.di_source_range = range' } in let decl_list = decl_get_sub_decls decl in let decl1 = Clang_ast_proj.update_decl_tuple update decl in let decl_list' = list_map (decl_process_locs loc_composer) decl_list in decl_set_sub_decls decl1 decl_list' in + let open Clang_ast_t in let get_updated_fun_decl (decl_info', name, qt, fdecl_info) = let fdi_decls_in_prototype_scope' = list_map (decl_process_locs loc_composer) fdecl_info.fdi_decls_in_prototype_scope in @@ -280,13 +289,13 @@ let ast_decl_process_locs loc_composer ast_decl = let toplevel_decl_process_locs decl = let decl_info = Clang_ast_proj.get_decl_tuple decl in - LocComposer.set_current_file loc_composer decl_info.di_source_range; + LocComposer.set_current_file loc_composer decl_info.Clang_ast_t.di_source_range; decl_process_locs loc_composer decl in match ast_decl with - | TranslationUnitDecl (decl_info, decl_list, decl_context_info, type_list) -> + | Clang_ast_t.TranslationUnitDecl (decl_info, decl_list, decl_context_info, type_list) -> let decl_list' = list_map toplevel_decl_process_locs decl_list in - TranslationUnitDecl (decl_info, decl_list', decl_context_info, type_list) + Clang_ast_t.TranslationUnitDecl (decl_info, decl_list', decl_context_info, type_list) | _ -> assert false diff --git a/infer/src/clang/cContext.mli b/infer/src/clang/cContext.mli index e5d130e34..35bc2bd12 100644 --- a/infer/src/clang/cContext.mli +++ b/infer/src/clang/cContext.mli @@ -76,4 +76,3 @@ val create_context : Sil.tenv -> Cg.t -> Cfg.cfg -> Cfg.Procdesc.t -> string option -> curr_class -> bool -> (Mangled.t * Sil.typ * bool) list -> bool -> t val create_curr_class : Sil.tenv -> string -> curr_class - diff --git a/infer/src/clang/cEnum_decl.ml b/infer/src/clang/cEnum_decl.ml index 254c014ef..d3b9a2efd 100644 --- a/infer/src/clang/cEnum_decl.ml +++ b/infer/src/clang/cEnum_decl.ml @@ -11,7 +11,6 @@ (** translating the code and adding it to a fake procdesc *) open CFrontend_utils -open Clang_ast_t let create_empty_procdesc () = let procname = Procname.from_string_c_fun "__INFER_$GLOBAL_VAR_env" in @@ -49,7 +48,7 @@ let global_procdesc = ref (create_empty_procdesc ()) let rec get_enum_constants context decl_list v = match decl_list with | [] -> [] - | EnumConstantDecl(decl_info, name_info, qual_type, enum_constant_decl_info) :: decl_list' -> + | Clang_ast_t.EnumConstantDecl (decl_info, name_info, qual_type, enum_constant_decl_info) :: decl_list' -> let name = name_info.Clang_ast_t.ni_name in (match enum_constant_decl_info.Clang_ast_t.ecdi_init_expr with | None -> Printing.log_out "%s" (" ...Defining Enum Constant ("^name^", "^(string_of_int v)); diff --git a/infer/src/clang/cField_decl.ml b/infer/src/clang/cField_decl.ml index 9122959c8..dbe8ef1f2 100644 --- a/infer/src/clang/cField_decl.ml +++ b/infer/src/clang/cField_decl.ml @@ -11,8 +11,6 @@ open Utils open CFrontend_utils -open CFrontend_utils.General_utils -open Clang_ast_t module L = Logging @@ -24,7 +22,7 @@ let rec get_fields_super_classes tenv super_class = | None -> [] | Some Sil.Tstruct (fields, _, _, _, (Sil.Class, sc):: _, _, _) -> let sc_fields = get_fields_super_classes tenv (Sil.TN_csu (Sil.Class, sc)) in - append_no_duplicates_fields fields sc_fields + General_utils.append_no_duplicates_fields fields sc_fields | Some Sil.Tstruct (fields, _, _, _, _, _, _) -> fields | Some _ -> [] @@ -55,7 +53,7 @@ let build_sil_field tenv class_name field_name qual_type prop_atts = | Sil.Tptr (_, Sil.Pk_objc_weak) -> [Config.weak] | Sil.Tptr (_, Sil.Pk_objc_unsafe_unretained) -> [Config.unsafe_unret] | _ -> [] in - let fname = mk_class_field_name class_name field_name in + let fname = General_utils.mk_class_field_name class_name field_name in let typ = CTypes_decl.qual_type_to_sil_type tenv qual_type in let item_annotations = match prop_atts with | [] -> @@ -90,28 +88,25 @@ let build_sil_field_property curr_class tenv field_name qual_type prop_attribute (* Given a list of declarations in an interface returns a list of fields *) let rec get_fields tenv curr_class decl_list = + let open Clang_ast_t in match decl_list with | [] -> [] - | ObjCIvarDecl(decl_info, name_info, qual_type, field_decl_info, obj_c_ivar_decl_info) :: decl_list' -> + | ObjCIvarDecl (decl_info, name_info, qual_type, field_decl_info, obj_c_ivar_decl_info) :: decl_list' -> let fields = get_fields tenv curr_class decl_list' in let field_name = name_info.Clang_ast_t.ni_name in (* 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. *) Printing.log_out " ...Adding Instance Variable '%s' @." field_name; let (fname, typ, ia) = build_sil_field_property curr_class tenv field_name qual_type None in - Printing.log_out " ...Resulting sil field: (%s) with attributes:@." ((Ident.fieldname_to_string fname) ^":"^(Sil.typ_to_string typ)); list_iter (fun (ia', _) -> list_iter (fun a -> Printing.log_out " '%s'@." a) ia'.Sil.parameters) ia; (fname, typ, ia):: fields - - | ObjCPropertyImplDecl(decl_info, property_impl_decl_info):: decl_list' -> + | ObjCPropertyImplDecl (decl_info, property_impl_decl_info):: decl_list' -> let property_fields_decl = ObjcProperty_decl.prepare_dynamic_property curr_class decl_info property_impl_decl_info in get_fields tenv curr_class (property_fields_decl @ decl_list') - - | (d : Clang_ast_t.decl):: decl_list' -> - get_fields tenv curr_class decl_list' + | _ :: decl_list' -> get_fields tenv curr_class decl_list' (* Add potential extra fields defined only in the implementation of the class *) (* to the info given in the interface. Update the tenv accordingly. *) @@ -120,7 +115,7 @@ let add_missing_fields tenv class_name fields = let class_tn_name = Sil.TN_csu (Sil.Class, mang_name) in match Sil.tenv_lookup tenv class_tn_name with | Some Sil.Tstruct(intf_fields, _, _, _, superclass, methods, annotation) -> - let new_fields = append_no_duplicates_fields fields intf_fields in + let new_fields = General_utils.append_no_duplicates_fields fields intf_fields in let new_fields = CFrontend_utils.General_utils.sort_fields new_fields in let class_type_info = Sil.Tstruct ( diff --git a/infer/src/clang/cFrontend.ml b/infer/src/clang/cFrontend.ml index 1be7edf30..53a3cd0bf 100644 --- a/infer/src/clang/cFrontend.ml +++ b/infer/src/clang/cFrontend.ml @@ -18,7 +18,6 @@ module L = Logging open Utils open CFrontend_utils open CGen_trans -open Clang_ast_t (* Translate one global declaration *) let rec translate_one_declaration tenv cg cfg namespace parent_dec dec = @@ -27,6 +26,7 @@ let rec translate_one_declaration tenv cg cfg namespace parent_dec dec = CLocation.update_curr_file info; let source_range = info.Clang_ast_t.di_source_range in let should_translate_enum = CLocation.should_translate_enum source_range in + let open Clang_ast_t in match dec with | FunctionDecl(di, name_info, qt, fdecl_info) -> CMethod_declImpl.function_decl tenv cfg cg namespace dec None CContext.ContextNoCls diff --git a/infer/src/clang/cFrontend_utils.ml b/infer/src/clang/cFrontend_utils.ml index c6f937250..3020b8b9c 100644 --- a/infer/src/clang/cFrontend_utils.ml +++ b/infer/src/clang/cFrontend_utils.ml @@ -11,7 +11,6 @@ (** for transformations of ast nodes and general utility functions such as functions on lists *) open Utils -open Clang_ast_t module L = Logging module F = Format @@ -130,10 +129,11 @@ struct "<\"" ^ name ^ "\"> '" ^ info.Clang_ast_t.si_pointer ^ "'" let get_stmts_from_stmt stmt = + let open Clang_ast_t in match stmt with - | OpaqueValueExpr(_, lstmt, _, opaque_value_expr_info) -> + | OpaqueValueExpr (_, lstmt, _, opaque_value_expr_info) -> (match opaque_value_expr_info.Clang_ast_t.ovei_source_expr with - | Some stmt -> lstmt@[stmt] + | Some stmt -> lstmt @ [stmt] | _ -> lstmt) (* given that this has not been translated, looking up for variables *) (* inside leads to inconsistencies *) @@ -249,7 +249,7 @@ struct CFrontend_config.pointer_prefix^("INVALID") let type_from_unary_expr_or_type_trait_expr_info info = - match info.uttei_qual_type with + match info.Clang_ast_t.uttei_qual_type with | Some qt -> Some qt | None -> None diff --git a/infer/src/clang/cFrontend_utils.mli b/infer/src/clang/cFrontend_utils.mli index f0d21d010..2146195e4 100644 --- a/infer/src/clang/cFrontend_utils.mli +++ b/infer/src/clang/cFrontend_utils.mli @@ -9,7 +9,6 @@ (** Module for utility functions for the whole frontend. Includes functions for printing, *) (** for transformations of ast nodes and general utility functions such as functions on lists *) -open Clang_ast_t module Printing : sig @@ -49,15 +48,15 @@ sig val property_name : Clang_ast_t.obj_c_property_impl_decl_info -> string - val property_attribute_compare : property_attribute -> property_attribute -> int + val property_attribute_compare : Clang_ast_t.property_attribute -> Clang_ast_t.property_attribute -> int val generated_ivar_name : string -> string - val property_attribute_eq : property_attribute -> property_attribute -> bool + val property_attribute_eq : Clang_ast_t.property_attribute -> Clang_ast_t.property_attribute -> bool - val getter_attribute_opt : property_attribute list -> string option + val getter_attribute_opt : Clang_ast_t.property_attribute list -> string option - val setter_attribute_opt : property_attribute list -> string option + val setter_attribute_opt : Clang_ast_t.property_attribute list -> string option val get_memory_management_attributes : unit -> Clang_ast_t.property_attribute list diff --git a/infer/src/clang/cMain.ml b/infer/src/clang/cMain.ml index 19ff6de3e..b0b141e10 100644 --- a/infer/src/clang/cMain.ml +++ b/infer/src/clang/cMain.ml @@ -13,8 +13,6 @@ module L = Logging -open Clang_ast_j -open CFrontend_config open CFrontend_utils let arg_desc = @@ -27,7 +25,7 @@ let arg_desc = (filter Utils.base_arg_desc) @ [ "-c", - Arg.String (fun cfile -> source_file := Some cfile), + Arg.String (fun cfile -> CFrontend_config.source_file := Some cfile), Some "cfile", "C File to translate"; "-x", @@ -35,7 +33,7 @@ let arg_desc = Some "cfile", "Language (c, objective-c, c++, objc-++)"; "-ast", - Arg.String (fun file -> ast_file := Some file), + Arg.String (fun file -> CFrontend_config.ast_file := Some file), Some "file", "AST file for the translation"; "-dotty_cfg_libs", @@ -121,11 +119,11 @@ let do_run source_path ast_path = raise exc let _ = - Config.print_types:= true; - if Option.is_none !source_file then + Config.print_types := true; + if Option.is_none !CFrontend_config.source_file then (Printing.log_err "Incorrect command line arguments\n"; print_usage_exit ()) else - match !source_file with - | Some path -> do_run path !ast_file + match !CFrontend_config.source_file with + | Some path -> do_run path !CFrontend_config.ast_file | None -> assert false diff --git a/infer/src/clang/cMethod_decl.ml b/infer/src/clang/cMethod_decl.ml index e76435270..d1c05635d 100644 --- a/infer/src/clang/cMethod_decl.ml +++ b/infer/src/clang/cMethod_decl.ml @@ -11,8 +11,6 @@ open Utils open CFrontend_utils -open Clang_ast_t -open CContext module L = Logging @@ -46,7 +44,7 @@ struct | decl:: rest -> let rest_assume_calls = add_assume_not_null_calls rest attributes in (match decl with - | ParmVarDecl(decl_info, name_info, qtype, var_decl_info) + | Clang_ast_t.ParmVarDecl(decl_info, name_info, qtype, var_decl_info) when CFrontend_utils.Ast_utils.is_type_nonnull qtype attributes -> let name = name_info.Clang_ast_t.ni_name in let assume_call = Ast_expressions.create_assume_not_null_call decl_info name qtype in @@ -129,6 +127,7 @@ struct | None -> () let rec process_one_method_decl tenv cg cfg curr_class namespace dec = + let open Clang_ast_t in match dec with | CXXMethodDecl _ -> process_method_decl tenv cg cfg namespace curr_class dec ~is_objc:false @@ -150,6 +149,7 @@ struct let process_getter_setter context procname = let class_name = Procname.c_get_class procname in + let open CContext in let cls = CContext.create_curr_class context.tenv class_name in let method_name = Procname.c_get_method procname in match ObjcProperty_decl.method_is_property_accesor cls method_name with diff --git a/infer/src/clang/cMethod_trans.ml b/infer/src/clang/cMethod_trans.ml index f82f5e8e7..35bd541ef 100644 --- a/infer/src/clang/cMethod_trans.ml +++ b/infer/src/clang/cMethod_trans.ml @@ -12,8 +12,6 @@ open Utils open CFrontend_utils -open CContext -open Clang_ast_t module L = Logging @@ -59,11 +57,11 @@ let get_param_decls function_method_decl_info = let get_parameters function_method_decl_info = let par_to_ms_par par = match par with - | ParmVarDecl(decl_info, name_info, qtype, var_decl_info) -> + | Clang_ast_t.ParmVarDecl (decl_info, name_info, qtype, var_decl_info) -> let name = name_info.Clang_ast_t.ni_name in Printing.log_out "Adding param '%s' " name; Printing.log_out "with pointer %s@." decl_info.Clang_ast_t.di_pointer; - (name, CTypes.get_type qtype, var_decl_info.vdi_init_expr) + (name, CTypes.get_type qtype, var_decl_info.Clang_ast_t.vdi_init_expr) | _ -> assert false in let pars = list_map par_to_ms_par (get_param_decls function_method_decl_info) in @@ -87,14 +85,15 @@ let build_method_signature decl_info procname function_method_decl_info is_insta CMethod_signature.make_ms procname parameters qt attributes source_range is_instance_method is_generated let method_signature_of_decl curr_class meth_decl block_data_opt = + let open Clang_ast_t in match meth_decl, block_data_opt with - | FunctionDecl(decl_info, name_info, qt, fdi), _ -> - let name = name_info.Clang_ast_t.ni_name in + | FunctionDecl (decl_info, name_info, qt, fdi), _ -> + let name = name_info.ni_name in let func_decl = Func_decl_info (fdi, CTypes.get_type qt) in let procname = General_utils.mk_procname_from_function name (CTypes.get_type qt) in let ms = build_method_signature decl_info procname func_decl false false false in ms, fdi.Clang_ast_t.fdi_body, fdi.Clang_ast_t.fdi_parameters - | CXXMethodDecl(decl_info, name_info, qt, fdi), _ -> + | CXXMethodDecl (decl_info, name_info, qt, fdi), _ -> let class_name = CContext.get_curr_class_name curr_class in let method_name = name_info.Clang_ast_t.ni_name in let typ = CTypes.get_type qt in @@ -102,20 +101,21 @@ let method_signature_of_decl curr_class meth_decl block_data_opt = let method_decl = Cpp_Meth_decl_info (fdi, class_name, typ) in let ms = build_method_signature decl_info procname method_decl false false false in ms, fdi.Clang_ast_t.fdi_body, fdi.Clang_ast_t.fdi_parameters - | ObjCMethodDecl(decl_info, name_info, mdi), _ -> + | ObjCMethodDecl (decl_info, name_info, mdi), _ -> let class_name = CContext.get_curr_class_name curr_class in - let method_name = name_info.Clang_ast_t.ni_name in - let is_instance = mdi.Clang_ast_t.omdi_is_instance_method in + let method_name = name_info.ni_name in + let is_instance = mdi.omdi_is_instance_method in let method_kind = Procname.objc_method_kind_of_bool is_instance in let procname = General_utils.mk_procname_from_objc_method class_name method_name method_kind in let method_decl = ObjC_Meth_decl_info (mdi, class_name) in let is_generated = Ast_utils.is_generated name_info in let ms = build_method_signature decl_info procname method_decl false false is_generated in - ms, mdi.Clang_ast_t.omdi_body, mdi.Clang_ast_t.omdi_parameters - | BlockDecl(decl_info, decl_list, decl_context_info, bdi), Some (qt, is_instance, procname, _) -> + ms, mdi.omdi_body, mdi.omdi_parameters + | BlockDecl (decl_info, decl_list, decl_context_info, bdi), + Some (qt, is_instance, procname, _) -> let func_decl = Block_decl_info (bdi, CTypes.get_type qt) in let ms = build_method_signature decl_info procname func_decl is_instance true false in - ms, bdi.Clang_ast_t.bdi_body, bdi.Clang_ast_t.bdi_parameters + ms, bdi.bdi_body, bdi.bdi_parameters |_ -> assert false let get_superclass_curr_class context = @@ -187,12 +187,12 @@ let captured_vars_from_block_info context cvl = (match dr.Clang_ast_t.dr_name, dr.Clang_ast_t.dr_qual_type with | Some name_info, _ -> let n = name_info.Clang_ast_t.ni_name in - if n = CFrontend_config.self && not context.is_instance then [] + if n = CFrontend_config.self && not context.CContext.is_instance then [] else - (let procdesc_formals = Cfg.Procdesc.get_formals context.procdesc in + (let procdesc_formals = Cfg.Procdesc.get_formals context.CContext.procdesc in (Printing.log_err "formals are %s@." (Utils.list_to_string (fun (x, _) -> x) procdesc_formals)); let formals = list_map formal2captured procdesc_formals in - [find (context.local_vars @ formals) n]) + [find (context.CContext.local_vars @ formals) n]) | _ -> assert false) | None -> []) :: f cvl'' in list_flatten (f cvl) diff --git a/infer/src/clang/cTrans.ml b/infer/src/clang/cTrans.ml index e2ae074c9..40f96f5d0 100644 --- a/infer/src/clang/cTrans.ml +++ b/infer/src/clang/cTrans.ml @@ -9,14 +9,9 @@ (** Translates instructions: (statements and expressions) from the ast into sil *) -open CLocation -open CContext open Utils open CTrans_utils open CFrontend_utils -open CFrontend_utils.General_utils -open Clang_ast_t -open CFrontend_config open CTrans_utils.Nodes module L = Logging @@ -44,6 +39,7 @@ struct CMethod_trans.get_class_selector_instance context obj_c_message_expr_info act_params in let is_instance = mc_type != CMethod_trans.MCStatic in let method_kind = Procname.objc_method_kind_of_bool is_instance in + let open CContext in match CTrans_models.get_predefined_model_method_signature class_name method_name General_utils.mk_procname_from_objc_method with | Some ms -> @@ -62,7 +58,7 @@ struct callee_pn, mc_type let add_autorelease_call context exp typ sil_loc = - let method_name = Procname.c_get_method (Cfg.Procdesc.get_proc_name context.procdesc) in + let method_name = Procname.c_get_method (Cfg.Procdesc.get_proc_name context.CContext.procdesc) in if !Config.arc_mode && not (CTrans_utils.is_owning_name method_name) && ObjcInterface_decl.is_pointer_to_objc_class context.CContext.tenv typ then @@ -73,6 +69,7 @@ struct else ([], []) let rec is_block_expr s = + let open Clang_ast_t in match s with | BlockExpr _ -> true (* the block can be wrapped in ExprWithCleanups or ImplicitCastExpr*) @@ -86,7 +83,8 @@ struct | [_; _] -> true | _ -> false in match fun_exp_stmt with - | ImplicitCastExpr(_, _, ei, _) when is_block_qt ei.Clang_ast_t.ei_qual_type -> true + | Clang_ast_t.ImplicitCastExpr(_, _, ei, _) + when is_block_qt ei.Clang_ast_t.ei_qual_type -> true | _ -> false (* This function add in tenv a class representing an objc block. *) @@ -95,8 +93,8 @@ struct (* It allocates one element and sets its fields with the current values of the *) (* captured variables. This allocated instance is used to detect retain cycles involving the block.*) let allocate_block trans_state block_name captured_vars loc = - let tenv = trans_state.context.tenv in - let procdesc = trans_state.context.procdesc in + let tenv = trans_state.context.CContext.tenv in + let procdesc = trans_state.context.CContext.procdesc in let procname = Cfg.Procdesc.get_proc_name procdesc in let mk_field_from_captured_var (vname, typ, b) = let fname = General_utils.mk_class_field_name block_name (Mangled.to_string vname) in @@ -134,7 +132,8 @@ struct let fields_ids = list_combine fields ids in let set_fields = list_map (fun ((f, t, _), id) -> Sil.Set(Sil.Lfield(Sil.Var id_block, f, block_type), t, Sil.Var id, loc)) fields_ids in - (declare_block_local :: trans_res.instrs) @ [set_instr] @ captured_instrs @ set_fields @ block_nullify_instr , id_block:: ids + (declare_block_local :: trans_res.instrs) @ [set_instr] @ captured_instrs @ set_fields @ block_nullify_instr, + id_block :: ids (* From a list of expression extract blocks from tuples and *) (* returns block names and assignment to temp vars *) @@ -143,22 +142,22 @@ struct let ids = ref [] in let is_function_name t e = match e with - | Sil.Const(Sil.Cfun bn) -> + | Sil.Const (Sil.Cfun bn) -> let bn'= Procname.to_string bn in let bn''= Mangled.from_string bn' in - let block = Sil.Lvar(Sil.mk_pvar bn'' procname) in + let block = Sil.Lvar (Sil.mk_pvar bn'' procname) in let id = Ident.create_fresh Ident.knormal in - ids := id::!ids; - insts := Sil.Letderef(id, block, t, loc)::!insts; + ids := id :: !ids; + insts := Sil.Letderef (id, block, t, loc) :: !insts; [(Sil.Var id, t)] | _ -> [(e, t)] in let get_function_name t el = list_flatten(list_map (is_function_name t) el) in let rec f es = match es with | [] -> [] - | (Sil.Const(Sil.Ctuple el), (Sil.Tptr((Sil.Tfun _), _ ) as t)):: es' -> + | (Sil.Const(Sil.Ctuple el), (Sil.Tptr((Sil.Tfun _), _ ) as t)) :: es' -> get_function_name t el @ (f es') - | e:: es' -> e:: f es' in + | e :: es' -> e :: f es' in (f exps, !insts, !ids) (* If e is a block and the calling node has the priority then *) @@ -180,7 +179,7 @@ struct try f trans_state stmt with Self.SelfClassException class_name -> - let typ = CTypes_decl.type_name_to_sil_type trans_state.context.tenv class_name in + let typ = CTypes_decl.type_name_to_sil_type trans_state.context.CContext.tenv class_name in { empty_res_trans with exps = [(Sil.Sizeof(typ, Sil.Subtype.exact), typ)]} @@ -203,7 +202,7 @@ struct | _ -> assert false let stringLiteral_trans trans_state stmt_info expr_info str = - 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.CContext.tenv in let exp = Sil.Const (Sil.Cstr (str)) in { empty_res_trans with exps = [(exp, typ)]} @@ -212,12 +211,12 @@ struct (* 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 *) let gNUNullExpr_trans trans_state stmt_info expr_info = - 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.CContext.tenv in let exp = Sil.Const (Sil.Cint (Sil.Int.zero)) in { empty_res_trans with exps = [(exp, typ)]} let nullPtrExpr_trans trans_state stmt_info expr_info = - 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.CContext.tenv in { empty_res_trans with exps = [(Sil.exp_null, typ)]} let objCSelectorExpr_trans trans_state stmt_info expr_info selector = @@ -233,19 +232,19 @@ struct stringLiteral_trans trans_state stmt_info expr_info name let characterLiteral_trans trans_state stmt_info expr_info n = - 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.CContext.tenv in let exp = Sil.Const (Sil.Cint (Sil.Int.of_int n)) in { empty_res_trans with exps = [(exp, typ)]} let floatingLiteral_trans trans_state stmt_info expr_info float_string = - 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.CContext.tenv in let exp = Sil.Const (Sil.Cfloat (float_of_string float_string)) in { empty_res_trans with exps = [(exp, typ)]} (* Note currently we don't have support for different qual *) (* type like long, unsigned long, etc *) and integerLiteral_trans trans_state stmt_info expr_info integer_literal_info = - 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.CContext.tenv in let exp, ids = try let i = Int64.of_string integer_literal_info.Clang_ast_t.ili_value in @@ -266,13 +265,14 @@ struct (* The stmt seems to be always empty *) let unaryExprOrTypeTraitExpr_trans trans_state stmt_info expr_info unary_expr_or_type_trait_expr_info = - let typ = CTypes_decl.qual_type_to_sil_type trans_state.context.tenv expr_info.Clang_ast_t.ei_qual_type in + let tenv = trans_state.context.CContext.tenv in + let typ = CTypes_decl.qual_type_to_sil_type tenv expr_info.Clang_ast_t.ei_qual_type in match unary_expr_or_type_trait_expr_info.Clang_ast_t.uttei_kind with | `SizeOf -> let qt = Ast_utils.type_from_unary_expr_or_type_trait_expr_info unary_expr_or_type_trait_expr_info in let sizeof_typ = match qt with - | Some qt -> CTypes_decl.qual_type_to_sil_type trans_state.context.tenv qt + | Some qt -> CTypes_decl.qual_type_to_sil_type tenv qt | 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)]} | k -> Printing.log_stats @@ -283,11 +283,12 @@ struct (* search the label into the hashtbl - create a fake node eventually *) (* connect that node with this stmt *) let gotoStmt_trans trans_state stmt_info label_name = - let sil_loc = get_sil_location stmt_info trans_state.parent_line_number trans_state.context in + let sil_loc = CLocation.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 { 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 open CContext in Printing.log_out " priority node free = '%s'\n@." (string_of_bool (PriorityNode.is_priority_free trans_state)); let context = trans_state.context in @@ -317,8 +318,8 @@ struct let pname, type_opt = match qt with | Some v -> - mk_procname_from_function name v, CTypes_decl.parse_func_type name v - | None -> Procname.from_string_c_fun name, None in + (General_utils.mk_procname_from_function name v, CTypes_decl.parse_func_type name v) + | None -> (Procname.from_string_c_fun name, None) in let address_of_function = not context.CContext.is_callee_expression in (* If we are not translating a callee expression, then the address of the function is being taken.*) (* As e.g. in fun_ptr = foo; *) @@ -330,15 +331,15 @@ struct else Procname.from_string_c_fun name in let is_builtin = SymExec.function_is_builtin non_mangled_func_name in if is_builtin then (* malloc, free, exit, scanf, ... *) - { empty_res_trans with exps = [(Sil.Const (Sil.Cfun non_mangled_func_name), typ)]} + { empty_res_trans with exps = [(Sil.Const (Sil.Cfun non_mangled_func_name), typ)] } else begin if address_of_function then Cfg.set_procname_priority context.cfg pname; - { empty_res_trans with exps = [(Sil.Const (Sil.Cfun pname), typ)]} + { empty_res_trans with exps = [(Sil.Const (Sil.Cfun pname), typ)] } end ) else ( let pvar = - if not (Utils.string_is_prefix pointer_prefix stmt_info.si_pointer) then + if not (Utils.string_is_prefix CFrontend_config.pointer_prefix stmt_info.Clang_ast_t.si_pointer) then try CContext.LocalVars.find_var_with_pointer context stmt_info.Clang_ast_t.si_pointer with _ -> assert false @@ -364,18 +365,18 @@ struct instruction trans_state stmt | _ -> assert false (* expected a stmt or at most a compoundstmt *) in (* create the label root node into the hashtbl *) - let sil_loc = get_sil_location stmt_info trans_state.parent_line_number trans_state.context in + let sil_loc = CLocation.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 Cfg.Node.set_succs_exn root_node' res_trans.root_nodes []; { empty_res_trans with root_nodes = [root_node']; leaf_nodes = trans_state.succ_nodes } and arraySubscriptExpr_trans trans_state stmt_info expr_info stmt_list = - 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.CContext.tenv in let array_stmt, idx_stmt = (match stmt_list with | [a; i] -> a, i (* Assumption: the statement list contains 2 elements, the first is the array expr and the second the index *) | _ -> assert false) in (* Let's get notified if the assumption is wrong...*) - let line_number = get_line stmt_info trans_state.parent_line_number in + let line_number = CLocation.get_line stmt_info trans_state.parent_line_number in let trans_state'= { trans_state with parent_line_number = line_number } in let res_trans_a = instruction trans_state' array_stmt in let res_trans_idx = instruction trans_state' idx_stmt in @@ -410,6 +411,7 @@ struct exps = [(array_exp, typ)]} and binaryOperator_trans trans_state binary_operator_info stmt_info expr_info stmt_list = + let open Clang_ast_t in let bok = (Clang_ast_j.string_of_binary_operator_kind binary_operator_info.Clang_ast_t.boi_kind) in Printing.log_out " BinaryOperator '%s' " bok; Printing.log_out " priority node free = '%s'\n@." @@ -417,12 +419,12 @@ struct let context = trans_state.context in let parent_line_number = trans_state.parent_line_number in let succ_nodes = trans_state.succ_nodes in - let sil_loc = get_sil_location stmt_info parent_line_number context in - let typ = CTypes_decl.qual_type_to_sil_type context.tenv expr_info.Clang_ast_t.ei_qual_type in + let sil_loc = CLocation.get_sil_location stmt_info parent_line_number context in + let typ = CTypes_decl.qual_type_to_sil_type context.CContext.tenv expr_info.Clang_ast_t.ei_qual_type in (match stmt_list with | [s1; ImplicitCastExpr (stmt, [CompoundLiteralExpr (cle_stmt_info, stmts, expr_info)], _, cast_expr_info)] -> let di, line_number = get_decl_ref_info s1 parent_line_number in - let line_number = get_line cle_stmt_info line_number in + let line_number = CLocation.get_line cle_stmt_info line_number in let trans_state' = { trans_state with parent_line_number = line_number } in let res_trans_tmp = initListExpr_trans trans_state' stmt_info expr_info di stmts in { res_trans_tmp with leaf_nodes =[]} @@ -432,7 +434,7 @@ struct (* becomes the successor of the nodes that may be created when *) (* translating the operands. *) let trans_state_pri = PriorityNode.try_claim_priority_node trans_state stmt_info in - let line_number = get_line stmt_info parent_line_number in + let line_number = CLocation.get_line stmt_info parent_line_number in let trans_state'' = { trans_state_pri with parent_line_number = line_number; succ_nodes =[]} in let res_trans_e1 = exec_with_self_exception instruction trans_state'' s1 in let res_trans_e2 = @@ -521,16 +523,16 @@ struct and callExpr_trans trans_state si stmt_list expr_info = let pln = trans_state.parent_line_number in let context = trans_state.context in - let function_type = CTypes_decl.get_type_from_expr_info expr_info context.tenv in - let procname = Cfg.Procdesc.get_proc_name context.procdesc in - let sil_loc = get_sil_location si pln context in + let function_type = CTypes_decl.get_type_from_expr_info expr_info context.CContext.tenv in + let procname = Cfg.Procdesc.get_proc_name context.CContext.procdesc in + let sil_loc = CLocation.get_sil_location si pln context in (* First stmt is the function expr and the rest are params *) let fun_exp_stmt, params_stmt = (match stmt_list with - | fe:: params -> fe, params + | fe :: params -> fe, params | _ -> assert false) in let trans_state_pri = PriorityNode.try_claim_priority_node trans_state si in (* claim priority if no ancestors has claimed priority before *) - let line_number = get_line si pln in + let line_number = CLocation.get_line si pln in let context_callee = { context with CContext.is_callee_expression = true } in let trans_state_callee = { trans_state_pri with context = context_callee; parent_line_number = line_number; succ_nodes = []} in let is_call_to_block = objc_exp_of_type_block fun_exp_stmt in @@ -574,7 +576,7 @@ struct "WARNING: stmt_list and res_trans_par.exps must have same size. NEED TO BE FIXED\n\n"; fix_param_exps_mismatch params_stmt res_trans_par.exps) in let act_params = if is_cf_retain_release then - (Sil.Const (Sil.Cint Sil.Int.one), Sil.Tint Sil.IBool):: act_params + (Sil.Const (Sil.Cint Sil.Int.one), Sil.Tint Sil.IBool) :: act_params else act_params in match CTrans_utils.builtin_trans trans_state_pri sil_loc si function_type callee_pname_opt with | Some builtin -> builtin @@ -596,6 +598,7 @@ struct PriorityNode.compute_results_to_parent trans_state_pri sil_loc nname si res_trans_tmp in (match callee_pname_opt with | Some callee_pname -> + let open CContext in if not (SymExec.function_is_builtin callee_pname) then begin Cg.add_edge context.cg procname callee_pname; @@ -614,16 +617,16 @@ struct and cxxMemberCallExpr_trans trans_state si stmt_list expr_info = let pln = trans_state.parent_line_number in let context = trans_state.context in - let function_type = CTypes_decl.get_type_from_expr_info expr_info context.tenv in - let procname = Cfg.Procdesc.get_proc_name context.procdesc in - let sil_loc = get_sil_location si pln context in + let function_type = CTypes_decl.get_type_from_expr_info expr_info context.CContext.tenv in + let procname = Cfg.Procdesc.get_proc_name context.CContext.procdesc in + let sil_loc = CLocation.get_sil_location si pln context in (* First stmt is the method+this expr and the rest are params *) let fun_exp_stmt, params_stmt = (match stmt_list with - | fe:: params -> fe, params + | fe :: params -> fe, params | _ -> assert false) in let trans_state_pri = PriorityNode.try_claim_priority_node trans_state si in (* claim priority if no ancestors has claimed priority before *) - let line_number = get_line si pln in + let line_number = CLocation.get_line si pln in let trans_state_callee = { trans_state_pri with parent_line_number = line_number; succ_nodes = [] } in @@ -664,15 +667,16 @@ struct let nname = "Call " ^ (Sil.exp_to_string sil_method) in let result_trans_to_parent = PriorityNode.compute_results_to_parent trans_state_pri sil_loc nname si res_trans_tmp in - Cg.add_edge context.cg procname callee_pname; + Cg.add_edge context.CContext.cg procname callee_pname; + let cfg = context.CContext.cfg in (try let callee_ms = CMethod_signature.find callee_pname in - ignore (CMethod_trans.create_local_procdesc context.cfg context.tenv callee_ms [] [] false) + ignore (CMethod_trans.create_local_procdesc cfg context.CContext.tenv callee_ms [] [] false) with Not_found -> - CMethod_trans.create_external_procdesc context.cfg callee_pname false None); + CMethod_trans.create_external_procdesc cfg callee_pname false None); match ret_id with - | [] -> { result_trans_to_parent with exps =[] } - | [ret_id'] -> { result_trans_to_parent with exps =[(Sil.Var ret_id', function_type)] } + | [] -> { result_trans_to_parent with exps = [] } + | [ret_id'] -> { result_trans_to_parent with exps = [(Sil.Var ret_id', function_type)] } | _ -> 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 = @@ -680,21 +684,21 @@ struct (string_of_bool (PriorityNode.is_priority_free trans_state)); let context = trans_state.context 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 = CLocation.get_sil_location si parent_line_number context 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 Printing.log_out "\n!!!!!!! Calling with selector = '%s' " selector; 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.CContext.tenv in let ret_id = if Sil.typ_equal method_type Sil.Tvoid then [] else [Ident.create_fresh Ident.knormal] in let trans_state_pri = PriorityNode.try_claim_priority_node trans_state si in - let line_number = get_line si parent_line_number in + let line_number = CLocation.get_line si parent_line_number in let trans_state_param = { trans_state_pri with parent_line_number = line_number; succ_nodes = [] } in let obj_c_message_expr_info, res_trans_par = (match stmt_list with - | stmt:: rest -> + | stmt :: rest -> let obj_c_message_expr_info, fst_res_trans = (try let fst_res_trans = instruction trans_state_param stmt in @@ -716,12 +720,12 @@ struct else CTrans_utils.trans_assume_false sil_loc context trans_state.succ_nodes else - let procname = Cfg.Procdesc.get_proc_name context.procdesc in + let procname = Cfg.Procdesc.get_proc_name context.CContext.procdesc in let callee_name, method_call_type = get_callee_objc_method context obj_c_message_expr_info res_trans_par.exps in let res_trans_par = Self.add_self_parameter_for_super_instance context procname sil_loc obj_c_message_expr_info res_trans_par in let is_virtual = method_call_type = CMethod_trans.MCVirtual in - Cg.add_edge context.cg procname callee_name; + Cg.add_edge context.CContext.cg procname callee_name; let call_flags = { Sil.cf_virtual = is_virtual; Sil.cf_noreturn = false; Sil.cf_is_objc_block = false; } in let param_exps, instr_block_param, ids_block_param = extract_block_from_tuple procname res_trans_par.exps sil_loc in let stmt_call = Sil.Call(ret_id, (Sil.Const (Sil.Cfun callee_name)), param_exps, sil_loc, call_flags) in @@ -741,13 +745,13 @@ struct and dispatch_function_trans trans_state stmt_info stmt_list ei n = Printing.log_out "\n Call to a dispatch function treated as special case...\n"; - let procname = Cfg.Procdesc.get_proc_name trans_state.context.procdesc in + let procname = Cfg.Procdesc.get_proc_name trans_state.context.CContext.procdesc in let pvar = CFrontend_utils.General_utils.get_next_block_pvar procname in CContext.LocalVars.add_pointer_var stmt_info.Clang_ast_t.si_pointer pvar trans_state.context; let transformed_stmt, qt = Ast_expressions.translate_dispatch_function (Sil.pvar_to_string pvar) stmt_info stmt_list ei n in - let typ = CTypes_decl.qual_type_to_sil_type trans_state.context.tenv qt in - let loc = get_sil_location stmt_info trans_state.parent_line_number trans_state.context in + let typ = CTypes_decl.qual_type_to_sil_type trans_state.context.CContext.tenv qt in + let loc = CLocation.get_sil_location stmt_info trans_state.parent_line_number trans_state.context in let res_state = instruction trans_state transformed_stmt in (* Add declare locals to the first node *) list_iter (fun n -> Cfg.Node.prepend_instrs_temps n [Sil.Declare_locals([(pvar, typ)], loc)] []) res_state.root_nodes; @@ -764,23 +768,23 @@ struct list_iter (fun n -> Cfg.Node.append_instrs_temps n [Sil.Nullify(pvar, loc, true)] []) preds in Printing.log_out "\n Call to a block enumeration function treated as special case...\n@."; - let procname = Cfg.Procdesc.get_proc_name trans_state.context.procdesc in + let procname = Cfg.Procdesc.get_proc_name trans_state.context.CContext.procdesc in let pvar = CFrontend_utils.General_utils.get_next_block_pvar procname in let transformed_stmt, vars_to_register = Ast_expressions.translate_block_enumerate (Sil.pvar_to_string pvar) stmt_info stmt_list ei in let pvars_types = list_map (fun (v, pointer, qt) -> let pvar = Sil.mk_pvar (Mangled.from_string v) procname in - let typ = CTypes_decl.qual_type_to_sil_type trans_state.context.tenv qt in + let typ = CTypes_decl.qual_type_to_sil_type trans_state.context.CContext.tenv qt in CContext.LocalVars.add_pointer_var pointer pvar trans_state.context; (pvar, typ)) vars_to_register in - let loc = get_sil_location stmt_info trans_state.parent_line_number trans_state.context in + let loc = CLocation.get_sil_location stmt_info trans_state.parent_line_number trans_state.context in let res_state = instruction trans_state transformed_stmt in let preds = list_flatten (list_map (fun n -> Cfg.Node.get_preds n) trans_state.succ_nodes) in list_iter (declare_nullify_vars loc res_state res_state.root_nodes preds) pvars_types; res_state and compoundStmt_trans trans_state stmt_info stmt_list = - let line_number = get_line stmt_info trans_state.parent_line_number in + let line_number = CLocation.get_line stmt_info trans_state.parent_line_number in let trans_state' = { trans_state with parent_line_number = line_number } in instructions trans_state' (list_rev stmt_list) @@ -788,11 +792,11 @@ struct let context = trans_state.context in let parent_line_number = trans_state.parent_line_number in let succ_nodes = trans_state.succ_nodes in - let procname = Cfg.Procdesc.get_proc_name context.procdesc in + let procname = Cfg.Procdesc.get_proc_name context.CContext.procdesc in let mk_temp_var id = Sil.mk_pvar (Mangled.from_string ("SIL_temp_conditional___"^(string_of_int id))) procname 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 sil_loc = CLocation.get_sil_location stmt_info parent_line_number context in + let line_number = CLocation.get_line stmt_info parent_line_number in (* We have two different kind of join type for conditional operator. *) (* If it's a simple conditional operator then we use a standard join *) (* node. If it's a nested conditional operator then we need to *) @@ -850,7 +854,7 @@ struct (match stmt_list with | [cond; exp1; exp2] -> let typ = - CTypes_decl.qual_type_to_sil_type context.tenv expr_info.Clang_ast_t.ei_qual_type in + CTypes_decl.qual_type_to_sil_type context.CContext.tenv expr_info.Clang_ast_t.ei_qual_type in let join_node = compute_join_node typ in let pvar = mk_temp_var (Cfg.Node.get_id join_node) in let continuation' = mk_cond_continuation trans_state.continuation in @@ -876,7 +880,7 @@ struct let context = trans_state.context in let parent_line_number = trans_state.parent_line_number in let si, _ = Clang_ast_proj.get_stmt_tuple cond in - let sil_loc = get_sil_location si parent_line_number context in + let sil_loc = CLocation.get_sil_location si parent_line_number context in let mk_prune_node b e ids ins = create_prune_node b e ids ins sil_loc (Sil.Ik_if) context in let extract_exp el = @@ -932,6 +936,7 @@ struct instrs = res_trans_s1.instrs@res_trans_s2.instrs; exps = [(e_cond, typ1)] } in Printing.log_out "Translating Condition for Conditional/Loop \n"; + let open Clang_ast_t in match cond with | BinaryOperator(si, [s1; s2], expr_info, boi) -> (match boi.Clang_ast_t.boi_kind with @@ -946,8 +951,8 @@ struct let context = trans_state.context in let pln = trans_state.parent_line_number in let succ_nodes = trans_state.succ_nodes in - let sil_loc = get_sil_location stmt_info pln context in - let line_number = get_line stmt_info pln in + let sil_loc = CLocation.get_sil_location stmt_info pln context in + let line_number = CLocation.get_line stmt_info pln in let join_node = create_node (Cfg.Node.Join_node) [] [] sil_loc context in Cfg.Node.set_succs_exn join_node succ_nodes []; let trans_state' = { trans_state with parent_line_number = line_number; succ_nodes = [join_node]} in @@ -979,168 +984,181 @@ struct let pln = trans_state.parent_line_number in let succ_nodes = trans_state.succ_nodes in let continuation = trans_state.continuation in - let sil_loc = get_sil_location stmt_info pln context in - (match switch_stmt_list with - | [_; cond; CompoundStmt(stmt_info, stmt_list)] -> - let trans_state_pri = PriorityNode.try_claim_priority_node trans_state stmt_info in - let trans_state' ={ trans_state_pri with succ_nodes = []} in - let res_trans_cond = instruction trans_state' cond in - let switch_special_cond_node = - create_node (Cfg.Node.Stmt_node "Switch_stmt") [] res_trans_cond.instrs sil_loc context in - let trans_state_no_pri = if PriorityNode.own_priority_node trans_state_pri.priority stmt_info then - { trans_state_pri with priority = Free } - else trans_state_pri in - let (switch_e_cond', switch_e_cond'_typ) = - extract_exp_from_list res_trans_cond.exps - "\nWARNING: The condition of the SwitchStmt is not singleton. Need to be fixed\n" in - let switch_exit_point = succ_nodes in - let continuation' = - match continuation with - | Some cont -> Some { cont with break = switch_exit_point } - | None -> Some { break = switch_exit_point; continue = []; return_temp = false } in - let trans_state'' = { trans_state_no_pri with continuation = continuation'} in - let merge_into_cases stmt_list = (* returns list_of_cases * before_any_case_instrs *) - let rec aux rev_stmt_list acc cases = - (match rev_stmt_list with - | CaseStmt(info, a :: b :: (CaseStmt x) :: c) :: rest -> (* case x: case y: ... *) - if c <> [] then assert false; (* empty case with nested case, then followed by some instructions *) - let rest' = [CaseStmt(info, a :: b :: [])] @ rest in - let rev_stmt_list' = (CaseStmt x) :: rest' in - aux rev_stmt_list' acc cases - | CaseStmt(info, a :: b :: (DefaultStmt x) :: c) :: rest -> - (* case x: default: ... *) - if c <> [] then assert false; (* empty case with nested case, then followed by some instructions *) - let rest' = [CaseStmt(info, a :: b :: [])] @ rest in - let rev_stmt_list' = (DefaultStmt x) :: rest' in - aux rev_stmt_list' acc cases - | DefaultStmt(info, (CaseStmt x) :: c) :: rest -> (* default: case x: ... *) - if c <> [] then assert false; (* empty case with nested case, then followed by some instructions *) - let rest' = [DefaultStmt(info, [])] @ rest in - let rev_stmt_list' = (CaseStmt x) :: rest' in - aux rev_stmt_list' acc cases - | CaseStmt(info, a :: b :: c) :: rest -> - aux rest [] (CaseStmt(info, a :: b :: c@acc):: cases) - | DefaultStmt(info, c) :: rest -> (* default is always the last in the list *) - aux rest [] (DefaultStmt(info, c@acc) :: cases) - | x :: rest -> - aux rest (x:: acc) cases - | [] -> - cases, acc) in - aux (list_rev stmt_list) [] [] in - let list_of_cases, pre_case_stmts = merge_into_cases stmt_list in - let rec connected_instruction rev_instr_list successor_nodes = - (* returns the entry point of the translated set of instr *) - match rev_instr_list with - | [] -> successor_nodes - | instr :: rest -> - let trans_state''' = { trans_state'' with succ_nodes = successor_nodes } in - let res_trans_instr = instruction trans_state''' instr in - let instr_entry_points = res_trans_instr.root_nodes in - connected_instruction rest instr_entry_points in - let rec translate_and_connect_cases cases next_nodes next_prune_nodes = - let create_prune_nodes_for_case case = - match case with - | CaseStmt(stmt_info, case_const:: _:: _) -> - let trans_state_pri = - PriorityNode.try_claim_priority_node trans_state'' stmt_info in - let res_trans_case_const = instruction trans_state_pri case_const in - let e_const = res_trans_case_const.exps in - let e_const' = - match e_const with - | [(head, typ)] -> head - | _ -> assert false in - let sil_eq_cond = Sil.BinOp(Sil.Eq, switch_e_cond', e_const') in - let sil_loc = get_sil_location stmt_info pln context in - let true_prune_node = - create_prune_node true [(sil_eq_cond, switch_e_cond'_typ)] - res_trans_case_const.ids res_trans_case_const.instrs - sil_loc (Sil.Ik_switch) context in - let false_prune_node = - create_prune_node false [(sil_eq_cond, switch_e_cond'_typ)] - res_trans_case_const.ids res_trans_case_const.instrs - sil_loc (Sil.Ik_switch) context in - (true_prune_node, false_prune_node) - | _ -> assert false in - match cases with (* top-down to handle default cases *) - | [] -> next_nodes, next_prune_nodes - | CaseStmt(stmt_info, _ :: _ :: case_content) as case :: rest -> - let last_nodes, last_prune_nodes = translate_and_connect_cases rest next_nodes next_prune_nodes in - let case_entry_point = connected_instruction (list_rev case_content) last_nodes in - (* connects between cases, then continuation has priority about breaks *) - let prune_node_t, prune_node_f = create_prune_nodes_for_case case in - Cfg.Node.set_succs_exn prune_node_t case_entry_point []; - Cfg.Node.set_succs_exn prune_node_f last_prune_nodes []; - case_entry_point, [prune_node_t; prune_node_f] - | DefaultStmt(stmt_info, default_content) :: rest -> - let sil_loc = get_sil_location stmt_info pln context in - let placeholder_entry_point = - create_node (Cfg.Node.Stmt_node "DefaultStmt_placeholder") [] [] sil_loc context in - let last_nodes, last_prune_nodes = translate_and_connect_cases rest next_nodes [placeholder_entry_point] in - let default_entry_point = connected_instruction (list_rev default_content) last_nodes in - Cfg.Node.set_succs_exn placeholder_entry_point default_entry_point []; - default_entry_point, last_prune_nodes - | _ -> assert false in - let top_entry_point, top_prune_nodes = translate_and_connect_cases list_of_cases succ_nodes succ_nodes in - let _ = connected_instruction (list_rev pre_case_stmts) top_entry_point in - Cfg.Node.set_succs_exn switch_special_cond_node top_prune_nodes []; - let top_nodes = - match res_trans_cond.root_nodes with - | [] -> (* here if no root or if the translation of cond needed priority *) - [switch_special_cond_node] - | _ -> - list_iter (fun n' -> Cfg.Node.set_succs_exn n' [switch_special_cond_node] []) res_trans_cond.leaf_nodes; - res_trans_cond.root_nodes in - list_iter (fun n' -> Cfg.Node.append_instrs_temps n' [] res_trans_cond.ids) succ_nodes; (* succ_nodes will remove the temps *) - { root_nodes = top_nodes; leaf_nodes = succ_nodes; ids = []; instrs = []; exps =[]} - | _ -> assert false) + let sil_loc = CLocation.get_sil_location stmt_info pln context in + let open Clang_ast_t in + match switch_stmt_list with + | [_; cond; CompoundStmt(stmt_info, stmt_list)] -> + let trans_state_pri = PriorityNode.try_claim_priority_node trans_state stmt_info in + let trans_state' ={ trans_state_pri with succ_nodes = []} in + let res_trans_cond = instruction trans_state' cond in + let switch_special_cond_node = + create_node (Cfg.Node.Stmt_node "Switch_stmt") [] res_trans_cond.instrs sil_loc context in + let trans_state_no_pri = if PriorityNode.own_priority_node trans_state_pri.priority stmt_info then + { trans_state_pri with priority = Free } + else trans_state_pri in + let (switch_e_cond', switch_e_cond'_typ) = + extract_exp_from_list res_trans_cond.exps + "\nWARNING: The condition of the SwitchStmt is not singleton. Need to be fixed\n" in + let switch_exit_point = succ_nodes in + let continuation' = + match continuation with + | Some cont -> Some { cont with break = switch_exit_point } + | None -> Some { break = switch_exit_point; continue = []; return_temp = false } in + let trans_state'' = { trans_state_no_pri with continuation = continuation'} in + let merge_into_cases stmt_list = (* returns list_of_cases * before_any_case_instrs *) + let rec aux rev_stmt_list acc cases = + (match rev_stmt_list with + | CaseStmt (info, a :: b :: (CaseStmt x) :: c) :: rest -> (* case x: case y: ... *) + if c <> [] then assert false; (* empty case with nested case, then followed by some instructions *) + let rest' = [CaseStmt(info, a :: b :: [])] @ rest in + let rev_stmt_list' = (CaseStmt x) :: rest' in + aux rev_stmt_list' acc cases + | CaseStmt (info, a :: b :: (DefaultStmt x) :: c) :: rest -> + (* case x: default: ... *) + if c <> [] then assert false; (* empty case with nested case, then followed by some instructions *) + let rest' = [CaseStmt(info, a :: b :: [])] @ rest in + let rev_stmt_list' = (DefaultStmt x) :: rest' in + aux rev_stmt_list' acc cases + | DefaultStmt (info, (CaseStmt x) :: c) :: rest -> (* default: case x: ... *) + if c <> [] then assert false; (* empty case with nested case, then followed by some instructions *) + let rest' = [DefaultStmt(info, [])] @ rest in + let rev_stmt_list' = (CaseStmt x) :: rest' in + aux rev_stmt_list' acc cases + | CaseStmt (info, a :: b :: c) :: rest -> + aux rest [] (CaseStmt(info, a :: b :: c @ acc) :: cases) + | DefaultStmt (info, c) :: rest -> (* default is always the last in the list *) + aux rest [] (DefaultStmt(info, c @ acc) :: cases) + | x :: rest -> + aux rest (x :: acc) cases + | [] -> + cases, acc) in + aux (list_rev stmt_list) [] [] in + let list_of_cases, pre_case_stmts = merge_into_cases stmt_list in + let rec connected_instruction rev_instr_list successor_nodes = + (* returns the entry point of the translated set of instr *) + match rev_instr_list with + | [] -> successor_nodes + | instr :: rest -> + let trans_state''' = { trans_state'' with succ_nodes = successor_nodes } in + let res_trans_instr = instruction trans_state''' instr in + let instr_entry_points = res_trans_instr.root_nodes in + connected_instruction rest instr_entry_points in + let rec translate_and_connect_cases cases next_nodes next_prune_nodes = + let create_prune_nodes_for_case case = + match case with + | CaseStmt (stmt_info, case_const :: _ :: _) -> + let trans_state_pri = + PriorityNode.try_claim_priority_node trans_state'' stmt_info in + let res_trans_case_const = instruction trans_state_pri case_const in + let e_const = res_trans_case_const.exps in + let e_const' = + match e_const with + | [(head, typ)] -> head + | _ -> assert false in + let sil_eq_cond = Sil.BinOp (Sil.Eq, switch_e_cond', e_const') in + let sil_loc = CLocation.get_sil_location stmt_info pln context in + let true_prune_node = + create_prune_node true [(sil_eq_cond, switch_e_cond'_typ)] + res_trans_case_const.ids res_trans_case_const.instrs + sil_loc Sil.Ik_switch context in + let false_prune_node = + create_prune_node false [(sil_eq_cond, switch_e_cond'_typ)] + res_trans_case_const.ids res_trans_case_const.instrs + sil_loc Sil.Ik_switch context in + (true_prune_node, false_prune_node) + | _ -> assert false in + match cases with (* top-down to handle default cases *) + | [] -> next_nodes, next_prune_nodes + | CaseStmt(stmt_info, _ :: _ :: case_content) as case :: rest -> + let last_nodes, last_prune_nodes = translate_and_connect_cases rest next_nodes next_prune_nodes in + let case_entry_point = connected_instruction (list_rev case_content) last_nodes in + (* connects between cases, then continuation has priority about breaks *) + let prune_node_t, prune_node_f = create_prune_nodes_for_case case in + Cfg.Node.set_succs_exn prune_node_t case_entry_point []; + Cfg.Node.set_succs_exn prune_node_f last_prune_nodes []; + case_entry_point, [prune_node_t; prune_node_f] + | DefaultStmt(stmt_info, default_content) :: rest -> + let sil_loc = CLocation.get_sil_location stmt_info pln context in + let placeholder_entry_point = + create_node (Cfg.Node.Stmt_node "DefaultStmt_placeholder") [] [] sil_loc context in + let last_nodes, last_prune_nodes = translate_and_connect_cases rest next_nodes [placeholder_entry_point] in + let default_entry_point = connected_instruction (list_rev default_content) last_nodes in + Cfg.Node.set_succs_exn placeholder_entry_point default_entry_point []; + default_entry_point, last_prune_nodes + | _ -> assert false in + let top_entry_point, top_prune_nodes = translate_and_connect_cases list_of_cases succ_nodes succ_nodes in + let _ = connected_instruction (list_rev pre_case_stmts) top_entry_point in + Cfg.Node.set_succs_exn switch_special_cond_node top_prune_nodes []; + let top_nodes = + match res_trans_cond.root_nodes with + | [] -> (* here if no root or if the translation of cond needed priority *) + [switch_special_cond_node] + | _ -> + list_iter (fun n' -> Cfg.Node.set_succs_exn n' [switch_special_cond_node] []) res_trans_cond.leaf_nodes; + res_trans_cond.root_nodes in + list_iter (fun n' -> Cfg.Node.append_instrs_temps n' [] res_trans_cond.ids) succ_nodes; (* succ_nodes will remove the temps *) + { root_nodes = top_nodes; leaf_nodes = succ_nodes; ids = []; instrs = []; exps =[]} + | _ -> assert false and stmtExpr_trans trans_state stmt_info stmt_list expr_info = let context = trans_state.context 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 idl = res_trans_stmt.ids in - let exps'= list_rev res_trans_stmt.exps in - (match exps' with - | (last, typ):: _ -> - (* The StmtExpr contains a single CompoundStmt node, which it evaluates and *) - (* takes the value of the last subexpression.*) - (* Exp returned by StmtExpr is always a RValue. So we need to assign to a temp and return the temp.*) - let id = Ident.create_fresh Ident.knormal in - let loc = get_sil_location stmt_info trans_state.parent_line_number context in - let instr' = Sil.Letderef (id, last, typ, loc) in - { root_nodes = res_trans_stmt.root_nodes; - leaf_nodes = res_trans_stmt.leaf_nodes; - ids = id:: idl; - instrs = res_trans_stmt.instrs@[instr']; - exps = [(Sil.Var id, typ)]} - | _ -> assert false) + let exps' = list_rev res_trans_stmt.exps in + match exps' with + | (last, typ) :: _ -> + (* The StmtExpr contains a single CompoundStmt node, which it evaluates and *) + (* takes the value of the last subexpression.*) + (* Exp returned by StmtExpr is always a RValue. So we need to assign to a temp and return the temp.*) + let id = Ident.create_fresh Ident.knormal in + let loc = CLocation.get_sil_location stmt_info trans_state.parent_line_number context in + let instr' = Sil.Letderef (id, last, typ, loc) in + { root_nodes = res_trans_stmt.root_nodes; + leaf_nodes = res_trans_stmt.leaf_nodes; + ids = id :: idl; + instrs = res_trans_stmt.instrs @ [instr']; + exps = [(Sil.Var id, typ)]} + | _ -> assert false and loop_instruction trans_state loop_kind stmt_info = let outer_continuation = trans_state.continuation in let context = trans_state.context in let pln = trans_state.parent_line_number in let succ_nodes = trans_state.succ_nodes in - let sil_loc = get_sil_location stmt_info pln context in - let line_number = get_line stmt_info pln in - let join_node = create_node (Cfg.Node.Join_node) [] [] sil_loc context in + let sil_loc = CLocation.get_sil_location stmt_info pln context in + let line_number = CLocation.get_line stmt_info pln in + let join_node = create_node Cfg.Node.Join_node [] [] sil_loc context in let continuation = Some { break = succ_nodes; continue = [join_node]; return_temp = false } in (* set the flat to inform that we are translating a condition of a if *) let continuation_cond = mk_cond_continuation outer_continuation in let init_incr_nodes = match loop_kind with | Loops.For (init, cond, incr, body) -> - let trans_state' = { trans_state with succ_nodes = [join_node]; continuation = continuation; parent_line_number = line_number } in + let trans_state' = { + trans_state with + succ_nodes = [join_node]; + continuation = continuation; + parent_line_number = line_number; + } in let res_trans_init = instruction trans_state' init in let res_trans_incr = instruction trans_state' incr in Some (res_trans_init.root_nodes, res_trans_incr.root_nodes) | _ -> None in let cond_stmt = Loops.get_cond loop_kind in - let cond_line_number = get_line (fst (Clang_ast_proj.get_stmt_tuple cond_stmt)) line_number in - let trans_state_cond = { trans_state with continuation = continuation_cond; parent_line_number = cond_line_number; succ_nodes = [] } in + let cond_line_number = CLocation.get_line (fst (Clang_ast_proj.get_stmt_tuple cond_stmt)) line_number in + let trans_state_cond = { + trans_state with + continuation = continuation_cond; + parent_line_number = cond_line_number; + succ_nodes = []; + } in let res_trans_cond = cond_trans trans_state_cond cond_stmt in let body_succ_nodes = match loop_kind with - | Loops.For _ -> (match init_incr_nodes with | Some (nodes_init, nodes_incr) -> nodes_incr | None -> assert false) + | Loops.For _ -> (match init_incr_nodes with + | Some (nodes_init, nodes_incr) -> nodes_incr + | None -> assert false) | Loops.While _ -> [join_node] | Loops.DoWhile _ -> res_trans_cond.root_nodes in let body_continuation = match continuation, init_incr_nodes with @@ -1203,10 +1221,10 @@ struct (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 *) let trans_state_pri = PriorityNode.try_claim_priority_node trans_state stmt_info in - let sil_loc = get_sil_location stmt_info pln context in - let line_number = get_line stmt_info pln in + let sil_loc = CLocation.get_sil_location stmt_info pln context in + let line_number = CLocation.get_line stmt_info pln in let sil_typ = - CTypes_decl.qual_type_to_sil_type context.tenv expr_info.Clang_ast_t.ei_qual_type in + CTypes_decl.qual_type_to_sil_type context.CContext.tenv expr_info.Clang_ast_t.ei_qual_type in (match stmt_list with | [s1; s2] -> let trans_state' = { trans_state_pri with succ_nodes = []; parent_line_number = line_number } in @@ -1251,7 +1269,8 @@ struct let context = trans_state.context in let succ_nodes = trans_state.succ_nodes in let rec collect_right_hand_exprs ts stmt = match stmt with - | InitListExpr (stmt_info , stmts , expr_info) -> list_flatten (list_map (collect_right_hand_exprs ts) stmts) + | Clang_ast_t.InitListExpr (_ , stmts , _) -> + list_flatten (list_map (collect_right_hand_exprs ts) stmts) | _ -> let trans_state' = { ts with succ_nodes = []} in let res_trans_stmt = instruction trans_state' stmt in @@ -1260,15 +1279,17 @@ struct let is_owning_method = CTrans_utils.is_owning_method stmt in let is_method_call = CTrans_utils.is_method_call stmt in [(res_trans_stmt.ids, res_trans_stmt.instrs, exp, is_method_call, is_owning_method, typ)] in - let rec collect_left_hand_exprs e typ tns = match typ with - | (Sil.Tvar tn) -> - (match Sil.tenv_lookup context.tenv tn with + let rec collect_left_hand_exprs e typ tns = + let open General_utils in + match typ with + | Sil.Tvar tn -> + (match Sil.tenv_lookup context.CContext.tenv tn with | Some (Sil.Tstruct _ as str) -> collect_left_hand_exprs e str tns | Some ((Sil.Tvar typename) as tvar) -> if (StringSet.mem (Sil.typename_to_string typename) tns) then ([[(e, typ)]]) else (collect_left_hand_exprs e tvar (StringSet.add (Sil.typename_to_string typename) tns)); | _ -> [[(e, typ)]] (*This case is an error, shouldn't happen.*)) - | (Sil.Tstruct (struct_fields, _, _, _, _, _, _) as type_struct) -> + | Sil.Tstruct (struct_fields, _, _, _, _, _, _) as type_struct -> let lh_exprs = list_map ( fun (fieldname, fieldtype, _) -> Sil.Lfield (e, fieldname, type_struct) ) struct_fields in @@ -1288,7 +1309,7 @@ struct list_map (fun (e, t) -> list_flatten (collect_left_hand_exprs e t tns)) (zip lh_exprs lh_types) | _ -> [ [(e, typ)] ] in let trans_state_pri = PriorityNode.try_claim_priority_node trans_state stmt_info in - let var_type = CTypes_decl.qual_type_to_sil_type context.tenv expr_info.ei_qual_type in + let var_type = CTypes_decl.qual_type_to_sil_type context.CContext.tenv expr_info.Clang_ast_t.ei_qual_type in let pvar = CContext.LocalVars.find_var_with_pointer context di_pointer in let lh = list_flatten (collect_left_hand_exprs (Sil.Lvar pvar) var_type Utils.StringSet.empty) in let rh = list_flatten (list_map (collect_right_hand_exprs trans_state_pri) stmts ) in @@ -1297,7 +1318,7 @@ struct { empty_res_trans with root_nodes = succ_nodes } ) else ( (* Creating new instructions by assigning right hand side to left hand side expressions *) - let sil_loc = get_sil_location stmt_info trans_state_pri.parent_line_number context in + let sil_loc = CLocation.get_sil_location stmt_info trans_state_pri.parent_line_number context in let big_zip = list_map (fun ( (lh_exp, lh_t), (_, _, rh_exp, is_method_call, rhs_owning_method, rh_t) ) -> let is_pointer_object = ObjcInterface_decl.is_pointer_to_objc_class context.CContext.tenv rh_t in @@ -1309,7 +1330,7 @@ struct ([(e, lh_t)], instrs, ids) else ([], [Sil.Set (lh_exp, lh_t, rh_exp, sil_loc)], [])) - (zip lh rh) in + (General_utils.zip lh rh) in let rh_instrs = list_flatten ( list_map (fun (_, instrs, _, _, _, _) -> instrs) rh) in let assign_instrs = list_flatten(list_map (fun (_, instrs, _) -> instrs) big_zip) in let assign_ids = list_flatten(list_map (fun (_, _, ids) -> ids) big_zip) in @@ -1320,67 +1341,93 @@ struct let node_kind = Cfg.Node.Stmt_node "InitListExp" in let node = create_node node_kind (ids) (instructions) sil_loc context in Cfg.Node.set_succs_exn node succ_nodes []; - { root_nodes =[node]; leaf_nodes =[]; ids = rh_ids; instrs = instructions; exps = [(Sil.Lvar pvar, var_type)]} - ) else { root_nodes =[]; leaf_nodes =[]; ids = rh_ids; instrs = instructions; exps = [(Sil.Lvar pvar, var_type)]}) + { + root_nodes = [node]; + leaf_nodes = []; + ids = rh_ids; + instrs = instructions; + exps = [(Sil.Lvar pvar, var_type)]; + } + ) else { + root_nodes = []; + leaf_nodes = []; + ids = rh_ids; + instrs = instructions; + exps = [(Sil.Lvar pvar, var_type)]; + } + ) and collect_all_decl trans_state var_decls next_nodes stmt_info = + let open Clang_ast_t in let context = trans_state.context in let pln = trans_state.parent_line_number in let do_var_dec (di, var_name, qtype, vdi) next_node = - (match vdi.Clang_ast_t.vdi_init_expr with - | None -> { empty_res_trans with root_nodes = next_node } (* Nothing to do if no init expression *) - | Some (ImplicitValueInitExpr (_, stmt_list, _)) -> - (* Seems unclear what it does, so let's keep an eye on the stmts *) - (* and report a warning if it finds a non empty list of stmts *) - (match stmt_list with - | [] -> () - | _ -> Printing.log_stats "\n!!!!WARNING: found statement <\"ImplicitValueInitExpr\"> with non-empty stmt_list.\n"); - { empty_res_trans with root_nodes = next_node } - | Some (InitListExpr (stmt_info , stmts , expr_info)) - | Some (ExprWithCleanups(_, [InitListExpr (stmt_info , stmts , expr_info)], _, _)) -> - initListExpr_trans trans_state stmt_info expr_info di.Clang_ast_t.di_pointer stmts - | Some ie -> (*For init expr, translate how to compute it and assign to the var*) - let sil_loc = get_sil_location stmt_info pln context in - let trans_state_pri = PriorityNode.try_claim_priority_node trans_state stmt_info in - let next_node = - if PriorityNode.own_priority_node trans_state_pri.priority stmt_info then ( - let node_kind = Cfg.Node.Stmt_node "DeclStmt" in - let node = create_node node_kind [] [] sil_loc context in - Cfg.Node.set_succs_exn node next_node []; - [node] - ) else next_node in - let pvar = CContext.LocalVars.find_var_with_pointer context di.Clang_ast_t.di_pointer in - let line_number = get_line stmt_info pln in - (* if ie is a block the translation need to be done with the block special cases by exec_with_block_priority*) - let res_trans_ie = - let trans_state' = { trans_state_pri with succ_nodes = next_node; parent_line_number = line_number } in - exec_with_block_priority_exception (exec_with_self_exception instruction) trans_state' ie stmt_info in - let root_nodes = res_trans_ie.root_nodes in - let leaf_nodes = res_trans_ie.leaf_nodes in - let (sil_e1', ie_typ) = extract_exp_from_list res_trans_ie.exps - "WARNING: In DeclStmt we expect only one expression returned in recursive call\n" in - let rhs_owning_method = CTrans_utils.is_owning_method ie in - let _, instrs_assign, ids_assign = - if !Config.arc_mode && - (CTrans_utils.is_method_call ie || ObjcInterface_decl.is_pointer_to_objc_class context.CContext.tenv ie_typ) then - (* In arc mode, if it's a method call or we are initializing with a pointer to objc class *) - (* we need to add retain/release *) - let (e, instrs, ids) = - CArithmetic_trans.assignment_arc_mode context (Sil.Lvar pvar) ie_typ sil_e1' sil_loc rhs_owning_method true in - ([(e, ie_typ)], instrs, ids) - else ([], [Sil.Set (Sil.Lvar pvar, ie_typ, sil_e1', sil_loc)], []) in - let ids = res_trans_ie.ids@ids_assign in - let instrs = res_trans_ie.instrs@instrs_assign in - if PriorityNode.own_priority_node trans_state_pri.priority stmt_info then ( - let node = list_hd next_node in - Cfg.Node.append_instrs_temps node instrs ids; - list_iter (fun n -> Cfg.Node.set_succs_exn n [node] []) leaf_nodes; - let root_nodes = if (list_length root_nodes) = 0 then next_node else root_nodes in - { root_nodes = root_nodes; leaf_nodes =[]; ids = ids; instrs = instrs; exps = [(Sil.Lvar pvar, ie_typ)]} - ) else { root_nodes = root_nodes; leaf_nodes =[]; ids = ids; instrs = instrs; exps =[(Sil.Lvar pvar, ie_typ)]}) in + match vdi.Clang_ast_t.vdi_init_expr with + | None -> { empty_res_trans with root_nodes = next_node } (* Nothing to do if no init expression *) + | Some (ImplicitValueInitExpr (_, stmt_list, _)) -> + (* Seems unclear what it does, so let's keep an eye on the stmts *) + (* and report a warning if it finds a non empty list of stmts *) + (match stmt_list with + | [] -> () + | _ -> Printing.log_stats "\n!!!!WARNING: found statement <\"ImplicitValueInitExpr\"> with non-empty stmt_list.\n"); + { empty_res_trans with root_nodes = next_node } + | Some (InitListExpr (stmt_info , stmts , expr_info)) + | Some (ExprWithCleanups (_, [InitListExpr (stmt_info , stmts , expr_info)], _, _)) -> + initListExpr_trans trans_state stmt_info expr_info di.Clang_ast_t.di_pointer stmts + | Some ie -> (*For init expr, translate how to compute it and assign to the var*) + let sil_loc = CLocation.get_sil_location stmt_info pln context in + let trans_state_pri = PriorityNode.try_claim_priority_node trans_state stmt_info in + let next_node = + if PriorityNode.own_priority_node trans_state_pri.priority stmt_info then ( + let node_kind = Cfg.Node.Stmt_node "DeclStmt" in + let node = create_node node_kind [] [] sil_loc context in + Cfg.Node.set_succs_exn node next_node []; + [node] + ) else next_node in + let pvar = CContext.LocalVars.find_var_with_pointer context di.Clang_ast_t.di_pointer in + let line_number = CLocation.get_line stmt_info pln in + (* if ie is a block the translation need to be done with the block special cases by exec_with_block_priority*) + let res_trans_ie = + let trans_state' = { trans_state_pri with succ_nodes = next_node; parent_line_number = line_number } in + exec_with_block_priority_exception (exec_with_self_exception instruction) trans_state' ie stmt_info in + let root_nodes = res_trans_ie.root_nodes in + let leaf_nodes = res_trans_ie.leaf_nodes in + let (sil_e1', ie_typ) = extract_exp_from_list res_trans_ie.exps + "WARNING: In DeclStmt we expect only one expression returned in recursive call\n" in + let rhs_owning_method = CTrans_utils.is_owning_method ie in + let _, instrs_assign, ids_assign = + if !Config.arc_mode && + (CTrans_utils.is_method_call ie || ObjcInterface_decl.is_pointer_to_objc_class context.CContext.tenv ie_typ) then + (* In arc mode, if it's a method call or we are initializing with a pointer to objc class *) + (* we need to add retain/release *) + let (e, instrs, ids) = + CArithmetic_trans.assignment_arc_mode context (Sil.Lvar pvar) ie_typ sil_e1' sil_loc rhs_owning_method true in + ([(e, ie_typ)], instrs, ids) + else ([], [Sil.Set (Sil.Lvar pvar, ie_typ, sil_e1', sil_loc)], []) in + let ids = res_trans_ie.ids@ids_assign in + let instrs = res_trans_ie.instrs@instrs_assign in + if PriorityNode.own_priority_node trans_state_pri.priority stmt_info then ( + let node = list_hd next_node in + Cfg.Node.append_instrs_temps node instrs ids; + list_iter (fun n -> Cfg.Node.set_succs_exn n [node] []) leaf_nodes; + let root_nodes = if (list_length root_nodes) = 0 then next_node else root_nodes in + { + root_nodes = root_nodes; + leaf_nodes = []; + ids = ids; + instrs = instrs; + exps = [(Sil.Lvar pvar, ie_typ)]; + } + ) else { + root_nodes = root_nodes; + leaf_nodes = []; + ids = ids; + instrs = instrs; + exps = [(Sil.Lvar pvar, ie_typ)] + } in match var_decls with | [] -> { empty_res_trans with root_nodes = next_nodes } - | VarDecl(di, n, qt, vdi):: var_decls' -> + | VarDecl (di, n, qt, vdi) :: var_decls' -> (* Var are defined when procdesc is created, here we only take care of initialization*) let res_trans_vd = collect_all_decl trans_state var_decls' next_nodes stmt_info in let res_trans_tmp = do_var_dec (di, n, qt, vdi) res_trans_vd.root_nodes in @@ -1398,32 +1445,34 @@ struct (* the init expression. We use the latter info. *) and declStmt_trans trans_state decl_list stmt_info = let succ_nodes = trans_state.succ_nodes in - let line_number = get_line stmt_info trans_state.parent_line_number in + let line_number = CLocation.get_line stmt_info trans_state.parent_line_number in let trans_state' = { trans_state with parent_line_number = line_number } in - let res_trans = (match decl_list with - | VarDecl _ :: _ -> (* Case for simple variable declarations*) - collect_all_decl trans_state' decl_list succ_nodes stmt_info - | CXXRecordDecl _ :: var_decls (*C++/C record decl treated in the same way *) - | RecordDecl _:: var_decls -> (* Case for struct *) - collect_all_decl trans_state' decl_list succ_nodes stmt_info - | _ -> - Printing.log_stats - "WARNING: In DeclStmt found an unknown declaration type. RETURNING empty list of declaration. NEED TO BE FIXED"; - empty_res_trans) in - { res_trans with leaf_nodes = []} + let res_trans = + let open Clang_ast_t in + match decl_list with + | VarDecl _ :: _ -> (* Case for simple variable declarations*) + collect_all_decl trans_state' decl_list succ_nodes stmt_info + | CXXRecordDecl _ :: _ (*C++/C record decl treated in the same way *) + | RecordDecl _ :: _ -> (* Case for struct *) + collect_all_decl trans_state' decl_list succ_nodes stmt_info + | _ -> + Printing.log_stats + "WARNING: In DeclStmt found an unknown declaration type. RETURNING empty list of declaration. NEED TO BE FIXED"; + empty_res_trans in + { res_trans with leaf_nodes = [] } and objCPropertyRefExpr_trans trans_state stmt_info stmt_list = - (match stmt_list with - | [stmt] -> instruction trans_state stmt - | _ -> assert false) + match stmt_list with + | [stmt] -> instruction trans_state stmt + | _ -> assert false (* For OpaqueValueExpr we return the translation generated from its source expression*) and opaqueValueExpr_trans trans_state stmt_info opaque_value_expr_info = Printing.log_out " priority node free = '%s'\n@." (string_of_bool (PriorityNode.is_priority_free trans_state)); - (match opaque_value_expr_info.Clang_ast_t.ovei_source_expr with - | Some stmt -> instruction trans_state stmt - | _ -> assert false) + match opaque_value_expr_info.Clang_ast_t.ovei_source_expr with + | Some stmt -> instruction trans_state stmt + | _ -> assert false (* NOTE: This translation has several hypothesis. Need to be verified when we have more*) (* experience with this construct. Assert false will help to see if we encounter programs*) @@ -1440,19 +1489,20 @@ struct (* the stmt_list will be [x.f = a; x; a; CallToSetter] Among all element of the list we only need*) (* to translate the CallToSetter which is how x.f = a is actually implemented by the runtime.*) 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 = CLocation.get_line stmt_info trans_state.parent_line_number in let trans_state' = { trans_state with parent_line_number = line_number } in Printing.log_out " priority node free = '%s'\n@." (string_of_bool (PriorityNode.is_priority_free trans_state)); let rec do_semantic_elements el = - (match el with - | OpaqueValueExpr _ :: el' -> do_semantic_elements el' - | stmt:: _ -> instruction trans_state' stmt - | _ -> assert false) in - (match stmt_list with - | syntactic_form:: semantic_form -> - do_semantic_elements semantic_form - | _ -> assert false) + let open Clang_ast_t in + match el with + | OpaqueValueExpr _ :: el' -> do_semantic_elements el' + | stmt :: _ -> instruction trans_state' stmt + | _ -> assert false in + match stmt_list with + | syntactic_form :: semantic_form -> + do_semantic_elements semantic_form + | _ -> assert false (* Cast expression are treated the same apart from the cast operation kind*) and cast_exprs_trans trans_state stmt_info stmt_list expr_info cast_expr_info is_objc_bridged = @@ -1460,13 +1510,13 @@ struct let pln = trans_state.parent_line_number in Printing.log_out " priority node free = '%s'\n@." (string_of_bool (PriorityNode.is_priority_free trans_state)); - let sil_loc = get_sil_location stmt_info pln context in + let sil_loc = CLocation.get_sil_location stmt_info pln context in 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 - let line_number = get_line stmt_info pln in + let line_number = CLocation.get_line stmt_info pln in let trans_state' = { trans_state with parent_line_number = line_number } in let res_trans_stmt = instruction trans_state' stmt 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.CContext.tenv expr_info.Clang_ast_t.ei_qual_type in let cast_kind = cast_expr_info.Clang_ast_t.cei_cast_kind in (* This gives the differnece among cast operations kind*) let cast_ids, cast_inst, cast_exp = cast_operation context cast_kind res_trans_stmt.exps typ sil_loc is_objc_bridged in @@ -1484,7 +1534,7 @@ struct let field_qt = match decl_ref.Clang_ast_t.dr_qual_type with | Some t -> t | _ -> assert false in - let field_typ = CTypes_decl.qual_type_to_sil_type trans_state.context.tenv field_qt in + let field_typ = CTypes_decl.qual_type_to_sil_type trans_state.context.CContext.tenv field_qt in Printing.log_out "!!!!! Dealing with field '%s' @." field_name; let exp_stmt = extract_stmt_from_singleton stmt_list "WARNING: in MemberExpr there must be only one stmt defining its expression.\n" in @@ -1493,7 +1543,7 @@ struct "WARNING: in MemberExpr we expect the translation of the stmt to return an expression\n" in let class_typ = (match class_typ with - | Sil.Tptr (t, _) -> CTypes_decl.expand_structured_type trans_state.context.tenv t + | Sil.Tptr (t, _) -> CTypes_decl.expand_structured_type trans_state.context.CContext.tenv t | t -> t) in match decl_ref.Clang_ast_t.dr_kind with | `Field | `ObjCIvar -> @@ -1501,7 +1551,8 @@ struct | Sil.Tvoid -> Sil.exp_minus_one | _ -> Printing.log_out "Type is '%s' @." (Sil.typ_to_string class_typ); - (match ObjcInterface_decl.find_field trans_state.context.tenv field_name (Some class_typ) false with + let tenv = trans_state.context.CContext.tenv in + (match ObjcInterface_decl.find_field tenv field_name (Some class_typ) false with | Some (fn, _, _) -> Sil.Lfield (obj_sil, fn, class_typ) | None -> assert false) in { result_trans_exp_stmt with @@ -1510,9 +1561,9 @@ struct (* consider using context.CContext.is_callee_expression to deal with pointers to methods? *) let raw_type = field_qt.Clang_ast_t.qt_raw in let class_name = match class_typ with Sil.Tptr (t, _) | t -> CTypes.classname_of_type t in - let pname = mk_procname_from_cpp_method class_name field_name raw_type in + let pname = General_utils.mk_procname_from_cpp_method class_name field_name raw_type in let method_exp = (Sil.Const (Sil.Cfun pname), field_typ) in - Cfg.set_procname_priority trans_state.context.cfg pname; + Cfg.set_procname_priority trans_state.context.CContext.cfg pname; { result_trans_exp_stmt with exps = [method_exp; (obj_sil, class_typ)] } | _ -> assert false @@ -1527,8 +1578,8 @@ struct and unaryOperator_trans trans_state stmt_info expr_info stmt_list unary_operator_info = let context = trans_state.context in let pln = trans_state.parent_line_number in - let sil_loc = get_sil_location stmt_info pln context in - let line_number = get_line stmt_info pln in + let sil_loc = CLocation.get_sil_location stmt_info pln context in + let line_number = CLocation.get_line stmt_info pln in let trans_state_pri = PriorityNode.try_claim_priority_node trans_state stmt_info in let stmt = extract_stmt_from_singleton stmt_list "WARNING: We expect only one element in stmt list defining the operand in UnaryOperator. NEED FIXING\n" in @@ -1536,7 +1587,7 @@ struct let res_trans_stmt = instruction trans_state' stmt in (* Assumption: the operand does not create a cfg node*) let (sil_e', _) = extract_exp_from_list res_trans_stmt.exps "\nWARNING: Missing operand in unary operator. NEED FIXING.\n" in - let ret_typ = CTypes_decl.qual_type_to_sil_type context.tenv expr_info.Clang_ast_t.ei_qual_type in + let ret_typ = CTypes_decl.qual_type_to_sil_type context.CContext.tenv expr_info.Clang_ast_t.ei_qual_type in let ids_op, exp_op, instr_op = CArithmetic_trans.unary_operation_instruction unary_operator_info sil_e' ret_typ sil_loc in let node_kind = Cfg.Node.Stmt_node "UnaryOperator" in @@ -1571,19 +1622,19 @@ struct let context = trans_state.context in let pln = trans_state.parent_line_number in let succ_nodes = trans_state.succ_nodes in - let sil_loc = get_sil_location stmt_info pln context in - let line_number = get_line stmt_info pln in + let sil_loc = CLocation.get_sil_location stmt_info pln context in + let line_number = CLocation.get_line stmt_info pln in let trans_state_pri = PriorityNode.try_claim_priority_node trans_state stmt_info in let ret_node = create_node (Cfg.Node.Stmt_node "Return Stmt") [] [] sil_loc context in - Cfg.Node.set_succs_exn ret_node [(Cfg.Procdesc.get_exit_node context.procdesc)] []; + Cfg.Node.set_succs_exn ret_node [(Cfg.Procdesc.get_exit_node context.CContext.procdesc)] []; let trans_result = (match stmt_list with | [stmt] -> (* return exp; *) let trans_state' = { trans_state_pri with succ_nodes = [ret_node]; parent_line_number = line_number } in let res_trans_stmt = exec_with_self_exception instruction trans_state' stmt in let (sil_expr, sil_typ) = extract_exp_from_list res_trans_stmt.exps "WARNING: There should be only one return expression.\n" in - let ret_var = Cfg.Procdesc.get_ret_var context.procdesc in - let ret_type = Cfg.Procdesc.get_ret_type context.procdesc in + let ret_var = Cfg.Procdesc.get_ret_var context.CContext.procdesc in + let ret_type = Cfg.Procdesc.get_ret_type context.CContext.procdesc in let ret_instr = Sil.Set (Sil.Lvar ret_var, ret_type, sil_expr, sil_loc) in let autorelease_ids, autorelease_instrs = add_autorelease_call context sil_expr ret_type sil_loc in let instrs = res_trans_stmt.instrs @ [ret_instr] @ autorelease_instrs in @@ -1605,49 +1656,49 @@ struct (* For ParenExpression we translate its body composed by the stmt_list. *) (* In paren expression there should be only one stmt that defines the expression *) and parenExpr_trans trans_state stmt_info stmt_list = - let line_number = get_line stmt_info trans_state.parent_line_number in + let line_number = CLocation.get_line stmt_info trans_state.parent_line_number in let trans_state'= { trans_state with parent_line_number = line_number } in let stmt = extract_stmt_from_singleton stmt_list "WARNING: In ParenExpression there should be only one stmt.\n" in instruction trans_state' stmt and objCBoxedExpr_trans trans_state info sel stmt_info stmts = - let typ = CTypes_decl.class_from_pointer_type trans_state.context.tenv info.Clang_ast_t.ei_qual_type in + let typ = CTypes_decl.class_from_pointer_type trans_state.context.CContext.tenv info.Clang_ast_t.ei_qual_type in let obj_c_message_expr_info = Ast_expressions.make_obj_c_message_expr_info_class sel typ in - let message_stmt = ObjCMessageExpr(stmt_info, stmts, info, obj_c_message_expr_info) in + let message_stmt = Clang_ast_t.ObjCMessageExpr (stmt_info, stmts, info, obj_c_message_expr_info) in instruction trans_state message_stmt and objCArrayLiteral_trans trans_state info stmt_info stmts = - let typ = CTypes_decl.class_from_pointer_type trans_state.context.tenv info.Clang_ast_t.ei_qual_type in + let typ = CTypes_decl.class_from_pointer_type trans_state.context.CContext.tenv info.Clang_ast_t.ei_qual_type in let obj_c_message_expr_info = Ast_expressions.make_obj_c_message_expr_info_class CFrontend_config.array_with_objects_count_m typ in - let stmts = stmts@[Ast_expressions.create_nil stmt_info] in - let message_stmt = ObjCMessageExpr(stmt_info, stmts, info, obj_c_message_expr_info) in + let stmts = stmts @ [Ast_expressions.create_nil stmt_info] in + let message_stmt = Clang_ast_t.ObjCMessageExpr (stmt_info, stmts, info, obj_c_message_expr_info) in instruction trans_state message_stmt and objCDictionaryLiteral_trans trans_state info stmt_info stmts = - let typ = CTypes_decl.class_from_pointer_type trans_state.context.tenv info.Clang_ast_t.ei_qual_type in + let typ = CTypes_decl.class_from_pointer_type trans_state.context.CContext.tenv info.Clang_ast_t.ei_qual_type in let obj_c_message_expr_info = Ast_expressions.make_obj_c_message_expr_info_class CFrontend_config.dict_with_objects_and_keys_m typ in - let stmts = swap_elements_list stmts in - let stmts = stmts@[Ast_expressions.create_nil stmt_info] in - let message_stmt = ObjCMessageExpr(stmt_info, stmts, info, obj_c_message_expr_info) in + let stmts = General_utils.swap_elements_list stmts in + let stmts = stmts @ [Ast_expressions.create_nil stmt_info] in + let message_stmt = Clang_ast_t.ObjCMessageExpr (stmt_info, stmts, info, obj_c_message_expr_info) in instruction trans_state message_stmt and objCStringLiteral_trans trans_state stmt_info stmts info = let stmts = [Ast_expressions.create_implicit_cast_expr stmt_info stmts (Ast_expressions.create_char_type ()) `ArrayToPointerDecay] in - let typ = CTypes_decl.class_from_pointer_type trans_state.context.tenv info.Clang_ast_t.ei_qual_type in + let typ = CTypes_decl.class_from_pointer_type trans_state.context.CContext.tenv info.Clang_ast_t.ei_qual_type in let obj_c_message_expr_info = Ast_expressions.make_obj_c_message_expr_info_class CFrontend_config.string_with_utf8_m typ in - let message_stmt = ObjCMessageExpr(stmt_info, stmts, info, obj_c_message_expr_info) in + let message_stmt = Clang_ast_t.ObjCMessageExpr (stmt_info, stmts, info, obj_c_message_expr_info) in instruction trans_state message_stmt (** When objects are autoreleased, they get added a flag AUTORELEASE. All these objects will be ignored when checking for memory leaks. When the end of the block autoreleasepool is reached, then those objects are released and the autorelease flag is removed. *) and objcAutoreleasePool_trans trans_state stmt_info stmts = - let sil_loc = get_sil_location stmt_info trans_state.parent_line_number trans_state.context in + let sil_loc = CLocation.get_sil_location stmt_info trans_state.parent_line_number trans_state.context in let fname = SymExec.ModelBuiltins.__objc_release_autorelease_pool in let ret_id = Ident.create_fresh Ident.knormal in let autorelease_pool_vars = compute_autorelease_pool_vars trans_state.context stmts in @@ -1670,10 +1721,10 @@ struct and blockExpr_trans trans_state stmt_info expr_info decl = let context = trans_state.context 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.CContext.procdesc in let loc = (match stmt_info.Clang_ast_t.si_source_range with (l1, l2) -> - CLocation.clang_to_sil_location l1 pln (Some context.procdesc)) in + CLocation.clang_to_sil_location l1 pln (Some context.CContext.procdesc)) in (* Given a mangled name (possibly full) returns a plain mangled name *) let ensure_plain_mangling m = Mangled.from_string (Mangled.to_string m) in @@ -1682,7 +1733,7 @@ struct let cvar, typ = (match cv with | (cvar, typ, false) -> cvar, typ | (cvar, typ, true) -> (* static case *) - let formals = Cfg.Procdesc.get_formals context.procdesc in + let formals = Cfg.Procdesc.get_formals context.CContext.procdesc in let cvar' = ensure_plain_mangling cvar in (* we check if cvar' is a formal. In that case we need this plain mangled name *) (* otherwise it's a static variable defined among the locals *) @@ -1695,7 +1746,8 @@ struct let instr = Sil.Letderef (id, Sil.Lvar (Sil.mk_pvar cvar procname), typ, loc) in (id, instr) in match decl with - | BlockDecl(decl_info, decl_list, decl_context_info, block_decl_info) -> + | Clang_ast_t.BlockDecl (decl_info, decl_list, decl_context_info, block_decl_info) -> + let open CContext in let qual_type = expr_info.Clang_ast_t.ei_qual_type in let block_pname = CFrontend_utils.General_utils.mk_fresh_block_procname procname in let typ = CTypes_decl.qual_type_to_sil_type context.tenv qual_type in @@ -1717,15 +1769,15 @@ struct (Some block_data) context.curr_class; Cfg.set_procname_priority context.cfg block_pname; let captured_exps = list_map (fun id -> Sil.Var id) ids in - let tu = Sil.Ctuple ((Sil.Const (Sil.Cfun block_pname)):: captured_exps) in + let tu = Sil.Ctuple ((Sil.Const (Sil.Cfun block_pname)) :: captured_exps) in let alloc_block_instr, ids_block = allocate_block trans_state (Procname.to_string block_pname) all_captured_vars loc in { empty_res_trans with ids = ids_block @ ids; instrs = alloc_block_instr @ instrs; exps = [(Sil.Const tu, typ)]} | _ -> assert false and cxxNewExpr_trans trans_state stmt_info expr_info = let context = trans_state.context in - let typ = CTypes_decl.get_type_from_expr_info expr_info context.tenv in - let sil_loc = get_sil_location stmt_info trans_state.parent_line_number context in + let typ = CTypes_decl.get_type_from_expr_info expr_info context.CContext.tenv in + let sil_loc = CLocation.get_sil_location stmt_info trans_state.parent_line_number context in let trans_state_pri = PriorityNode.try_claim_priority_node trans_state stmt_info in cpp_new_trans trans_state_pri sil_loc stmt_info typ (* TODOs 7912220 - no usable information in json as of right now *) @@ -1734,7 +1786,7 @@ struct and cxxDeleteExpr_trans trans_state stmt_info stmt_list expr_info = let context = trans_state.context in - let sil_loc = get_sil_location stmt_info trans_state.parent_line_number context in + let sil_loc = CLocation.get_sil_location stmt_info trans_state.parent_line_number context in let fname = SymExec.ModelBuiltins.__delete in let param = match stmt_list with [p] -> p | _ -> assert false in let trans_state_pri = PriorityNode.try_claim_priority_node trans_state stmt_info in @@ -1759,6 +1811,7 @@ struct let stmt_info, _ = Clang_ast_proj.get_stmt_tuple instr in let stmt_pointer = stmt_info.Clang_ast_t.si_pointer in Printing.log_out "\nPassing from %s '%s' \n" stmt_kind stmt_pointer; + let open Clang_ast_t in match instr with | GotoStmt(stmt_info, _, { Clang_ast_t.gsi_label = label_name; _ }) -> gotoStmt_trans trans_state stmt_info label_name @@ -1880,7 +1933,7 @@ struct memberExpr_trans trans_state stmt_info expr_info stmt_list member_expr_info | UnaryOperator(stmt_info, stmt_list, expr_info, unary_operator_info) -> - if is_logical_negation_of_int trans_state.context.tenv expr_info unary_operator_info then + if is_logical_negation_of_int trans_state.context.CContext.tenv expr_info unary_operator_info then let conditional = Ast_expressions.trans_negation_with_conditional stmt_info expr_info stmt_list in instruction trans_state conditional else @@ -1968,7 +2021,7 @@ struct (* Printing.log_err "\n instruction list %i" (List.length clang_stmt_list); *) match clang_stmt_list with | [] -> { empty_res_trans with root_nodes = trans_state.succ_nodes } - | s:: clang_stmt_list' -> + | s :: clang_stmt_list' -> let res_trans_s = instruction trans_state s in let trans_state' = if res_trans_s.root_nodes <> [] diff --git a/infer/src/clang/cTrans_models.ml b/infer/src/clang/cTrans_models.ml index bcedb210a..447b0b3e7 100644 --- a/infer/src/clang/cTrans_models.ml +++ b/infer/src/clang/cTrans_models.ml @@ -9,9 +9,7 @@ open Utils open CFrontend_utils -open Clang_ast_t open Objc_models -open CFrontend_config let is_cf_non_null_alloc funct = match funct with @@ -38,8 +36,8 @@ let is_alloc_model typ funct = let rec get_func_type_from_stmt stmt = match stmt with - | DeclRefExpr(stmt_info, stmt_list, expr_info, decl_ref_expr_info) -> - Some expr_info.ei_qual_type + | Clang_ast_t.DeclRefExpr(stmt_info, stmt_list, expr_info, decl_ref_expr_info) -> + Some expr_info.Clang_ast_t.ei_qual_type | _ -> match CFrontend_utils.Ast_utils.get_stmts_from_stmt stmt with | stmt:: rest -> get_func_type_from_stmt stmt @@ -134,29 +132,34 @@ let get_predefined_ms_method condition class_name method_name method_kind mk_pro else None let get_predefined_ms_stringWithUTF8String class_name method_name mk_procname = - let condition = class_name = nsstring_cl && method_name = string_with_utf8_m in + let condition = + class_name = CFrontend_config.nsstring_cl + && method_name = CFrontend_config.string_with_utf8_m in get_predefined_ms_method condition class_name method_name Procname.Class_objc_method - mk_procname [("x", "char *", None)] id_cl [] None + mk_procname [("x", "char *", None)] CFrontend_config.id_cl [] None let get_predefined_ms_retain_release class_name method_name mk_procname = let condition = is_retain_or_release method_name in let return_type = if is_retain_method method_name || is_autorelease_method method_name - then id_cl else void in - get_predefined_ms_method condition nsobject_cl method_name Procname.Instance_objc_method - mk_procname [(self, class_name, None)] return_type [] (get_builtinname method_name) + then CFrontend_config.id_cl else CFrontend_config.void in + get_predefined_ms_method condition CFrontend_config.nsobject_cl method_name Procname.Instance_objc_method + mk_procname [(CFrontend_config.self, class_name, None)] return_type [] (get_builtinname method_name) let get_predefined_ms_autoreleasepool_init class_name method_name mk_procname = - let condition = (method_name = init) && (class_name = nsautorelease_pool_cl) in + let condition = + method_name = CFrontend_config.init + && class_name = CFrontend_config.nsautorelease_pool_cl in get_predefined_ms_method condition class_name method_name Procname.Instance_objc_method - mk_procname [(self, class_name, None)] void [] None + mk_procname [(CFrontend_config.self, class_name, None)] CFrontend_config.void [] None let get_predefined_ms_nsautoreleasepool_release class_name method_name mk_procname = - let condition = (method_name = release || method_name = drain) && - (class_name = nsautorelease_pool_cl) in + let condition = + (method_name = CFrontend_config.release || method_name = CFrontend_config.drain) + && class_name = CFrontend_config.nsautorelease_pool_cl in get_predefined_ms_method condition class_name method_name Procname.Instance_objc_method - mk_procname [(self, class_name, None)] - void [] (Some SymExec.ModelBuiltins.__objc_release_autorelease_pool) + mk_procname [(CFrontend_config.self, class_name, None)] + CFrontend_config.void [] (Some SymExec.ModelBuiltins.__objc_release_autorelease_pool) let get_predefined_model_method_signature class_name method_name mk_procname = match get_predefined_ms_nsautoreleasepool_release class_name method_name mk_procname with diff --git a/infer/src/clang/cTrans_utils.ml b/infer/src/clang/cTrans_utils.ml index 16ee5618a..173671285 100644 --- a/infer/src/clang/cTrans_utils.ml +++ b/infer/src/clang/cTrans_utils.ml @@ -11,8 +11,6 @@ open Utils open CFrontend_utils -open CContext -open Clang_ast_t module L = Logging @@ -279,7 +277,7 @@ let create_alloc_instrs context sil_loc function_type fname = | Sil.Tptr (styp, Sil.Pk_objc_weak) | Sil.Tptr (styp, Sil.Pk_objc_unsafe_unretained) | Sil.Tptr (styp, Sil.Pk_objc_autoreleasing) -> - function_type, CTypes_decl.expand_structured_type context.tenv styp + function_type, CTypes_decl.expand_structured_type context.CContext.tenv styp | _ -> Sil.Tptr (function_type, Sil.Pk_pointer), function_type in let sizeof_exp = Sil.Sizeof (function_type_np, Sil.Subtype.exact) in let exp = (sizeof_exp, function_type) in @@ -306,7 +304,7 @@ let objc_new_trans trans_state loc stmt_info cls_name function_type = let is_instance = true in let call_flags = { Sil.cf_virtual = is_instance; Sil.cf_noreturn = false; Sil.cf_is_objc_block = false; } in let pname = General_utils.mk_procname_from_objc_method cls_name CFrontend_config.init Procname.Instance_objc_method in - CMethod_trans.create_external_procdesc trans_state.context.cfg pname is_instance None; + CMethod_trans.create_external_procdesc trans_state.context.CContext.cfg pname is_instance None; let args = [(Sil.Var alloc_ret_id, alloc_ret_type)] in let init_stmt_call = Sil.Call([init_ret_id], (Sil.Const (Sil.Cfun pname)), args, loc, call_flags) in let instrs = [alloc_stmt_call; init_stmt_call] in @@ -317,7 +315,7 @@ let objc_new_trans trans_state loc stmt_info cls_name function_type = { res_trans with exps = [(Sil.Var init_ret_id, alloc_ret_type)]} let new_or_alloc_trans trans_state loc stmt_info class_name selector = - let function_type = CTypes_decl.type_name_to_sil_type trans_state.context.tenv class_name in + let function_type = CTypes_decl.type_name_to_sil_type trans_state.context.CContext.tenv class_name in if selector = CFrontend_config.alloc then alloc_trans trans_state loc stmt_info function_type true else if selector = CFrontend_config.new_str then @@ -335,7 +333,7 @@ let cpp_new_trans trans_state sil_loc stmt_info function_type = let create_cast_instrs context exp cast_from_typ cast_to_typ sil_loc = let ret_id = Ident.create_fresh Ident.knormal in let cast_typ_no_pointer = - CTypes_decl.expand_structured_type context.tenv (CTypes.remove_pointer_to_typ cast_to_typ) in + CTypes_decl.expand_structured_type context.CContext.tenv (CTypes.remove_pointer_to_typ cast_to_typ) in let sizeof_exp = Sil.Sizeof (cast_typ_no_pointer, Sil.Subtype.exact) in let pname = SymExec.ModelBuiltins.__objc_cast in let args = [(exp, cast_from_typ); (sizeof_exp, Sil.Tvoid)] in @@ -490,12 +488,12 @@ let extract_item_from_option op warning_string = let is_member_exp stmt = match stmt with - | MemberExpr _ -> true + | Clang_ast_t.MemberExpr _ -> true | _ -> false let is_enumeration_constant stmt = match stmt with - | DeclRefExpr(_, _, _, drei) -> + | Clang_ast_t.DeclRefExpr(_, _, _, drei) -> (match drei.Clang_ast_t.drti_decl_ref with | Some d -> (match d.Clang_ast_t.dr_kind with | `EnumConstant -> true @@ -505,7 +503,7 @@ let is_enumeration_constant stmt = let is_null_stmt s = match s with - | NullStmt _ -> true + | Clang_ast_t.NullStmt _ -> true | _ -> false let dummy_id () = @@ -524,6 +522,7 @@ let rec get_type_from_exp_stmt stmt = | Some n -> n | _ -> assert false ) | _ -> assert false in + let open Clang_ast_t in match stmt with | CXXOperatorCallExpr(_, _, ei) | CallExpr(_, _, ei) -> ei.Clang_ast_t.ei_qual_type @@ -551,7 +550,7 @@ struct if is_superinstance mei then let typ, self_expr, id, ins = let t' = CTypes.add_pointer_to_typ - (CTypes_decl.get_type_curr_class context.tenv context.curr_class) in + (CTypes_decl.get_type_curr_class context.CContext.tenv context.CContext.curr_class) in let e = Sil.Lvar (Sil.mk_pvar (Mangled.from_string CFrontend_config.self) procname) in let id = Ident.create_fresh Ident.knormal in t', Sil.Var id, [id], [Sil.Letderef (id, e, t', loc)] in @@ -600,7 +599,7 @@ let is_owning_name n = let rec is_owning_method s = match s with - | ObjCMessageExpr(_, _ , _, mei) -> + | Clang_ast_t.ObjCMessageExpr(_, _ , _, mei) -> is_owning_name mei.Clang_ast_t.omei_selector | _ -> (match snd (Clang_ast_proj.get_stmt_tuple s) with | [] -> false @@ -608,14 +607,14 @@ let rec is_owning_method s = let rec is_method_call s = match s with - | ObjCMessageExpr(_, _ , _, mei) -> true + | Clang_ast_t.ObjCMessageExpr (_, _ , _, mei) -> true | _ -> (match snd (Clang_ast_proj.get_stmt_tuple s) with | [] -> false | s'':: _ -> is_method_call s'') let rec get_decl_ref_info s parent_line_number = match s with - | DeclRefExpr (stmt_info, stmt_list, expr_info, decl_ref_expr_info) -> + | Clang_ast_t.DeclRefExpr (stmt_info, stmt_list, expr_info, decl_ref_expr_info) -> let line_number = CLocation.get_line stmt_info parent_line_number in stmt_info.Clang_ast_t.si_pointer, line_number | _ -> (match Clang_ast_proj.get_stmt_tuple s with @@ -626,18 +625,18 @@ let rec get_decl_ref_info s parent_line_number = let rec contains_opaque_value_expr s = match s with - | OpaqueValueExpr (_, _, _, _) -> true - | _ -> (match snd (Clang_ast_proj.get_stmt_tuple s) with - | [] -> false - | s'':: _ -> contains_opaque_value_expr s'') + | Clang_ast_t.OpaqueValueExpr _ -> true + | _ -> match snd (Clang_ast_proj.get_stmt_tuple s) with + | [] -> false + | s'':: _ -> contains_opaque_value_expr s'' let rec compute_autorelease_pool_vars context stmts = match stmts with | [] -> [] - | DeclRefExpr(si, sl, ei, drei):: stmts' -> + | Clang_ast_t.DeclRefExpr (si, sl, ei, drei):: stmts' -> let name = get_name_decl_ref_exp_info drei si in - let procname = Cfg.Procdesc.get_proc_name context.procdesc in - let local_vars = Cfg.Procdesc.get_locals context.procdesc in + let procname = Cfg.Procdesc.get_proc_name context.CContext.procdesc in + let local_vars = Cfg.Procdesc.get_locals context.CContext.procdesc in let mname = try list_filter (fun (m, t) -> Mangled.to_string m = name) local_vars with _ -> [] in @@ -646,9 +645,9 @@ let rec compute_autorelease_pool_vars context stmts = CFrontend_utils.General_utils.append_no_duplicated_pvars [(Sil.Lvar (Sil.mk_pvar m procname), t)] (compute_autorelease_pool_vars context stmts') | _ -> compute_autorelease_pool_vars context stmts') - | s:: stmts' -> + | s :: stmts' -> let sl = snd(Clang_ast_proj.get_stmt_tuple s) in - compute_autorelease_pool_vars context (sl@stmts') + compute_autorelease_pool_vars context (sl @ stmts') (* checks if a unary operator is a logic negation applied to integers*) let is_logical_negation_of_int tenv ei uoi = @@ -658,6 +657,7 @@ let is_logical_negation_of_int tenv ei uoi = (* Checks if stmt_list is a call to a special dispatch function *) let is_dispatch_function stmt_list = + let open Clang_ast_t in match stmt_list with | ImplicitCastExpr(_,[DeclRefExpr(_, _, _, di)], _, _):: stmts -> (match di.Clang_ast_t.drti_decl_ref with @@ -690,7 +690,7 @@ let assign_default_params params_stmt callee_pname_opt ~is_cxx_method = let params_args = list_combine params_stmt args in let replace_default_arg param = match param with - | CXXDefaultArgExpr(_, _, _), (_, _, Some default_instr) -> default_instr + | Clang_ast_t.CXXDefaultArgExpr _, (_, _, Some default_instr) -> default_instr | instr, _ -> instr in list_map replace_default_arg params_args with diff --git a/infer/src/clang/cTypes.ml b/infer/src/clang/cTypes.ml index 23bdf4e49..478e27982 100644 --- a/infer/src/clang/cTypes.ml +++ b/infer/src/clang/cTypes.ml @@ -10,9 +10,7 @@ (** Utility module for retrieving types *) open Utils -open Clang_ast_t open CFrontend_utils -open CFrontend_utils.General_utils module L = Logging let get_function_return_type s = @@ -66,13 +64,14 @@ let lookup_var_type context pvar = (* Extract the type out of a statement. This is useful when the statement *) (* denotes actually an expression *) let extract_type_from_stmt s = + let open Clang_ast_t in match s with - | BinaryConditionalOperator(_, _, expr_info) | ConditionalOperator(_, _, expr_info) - | AddrLabelExpr(_, _, expr_info, _) | ArraySubscriptExpr(_, _, expr_info) - | ArrayTypeTraitExpr(_, _, expr_info) | AsTypeExpr(_, _, expr_info) - | AtomicExpr(_, _, expr_info) | BinaryOperator(_, _, expr_info, _) - | CompoundAssignOperator(_, _, expr_info, _, _) - | BlockExpr(_, _, expr_info, _) | CXXBindTemporaryExpr (_, _ , expr_info, _) + | BinaryConditionalOperator (_, _, expr_info) | ConditionalOperator (_, _, expr_info) + | AddrLabelExpr (_, _, expr_info, _) | ArraySubscriptExpr (_, _, expr_info) + | ArrayTypeTraitExpr (_, _, expr_info) | AsTypeExpr (_, _, expr_info) + | AtomicExpr (_, _, expr_info) | BinaryOperator (_, _, expr_info, _) + | CompoundAssignOperator (_, _, expr_info, _, _) + | BlockExpr (_, _, expr_info, _) | CXXBindTemporaryExpr (_, _ , expr_info, _) | CXXBoolLiteralExpr (_, _, expr_info, _) | CXXConstructExpr (_, _, expr_info, _) | CXXTemporaryObjectExpr (_, _, expr_info, _) | CXXDefaultArgExpr (_, _, expr_info) | CXXDefaultInitExpr (_, _, expr_info) | CXXDeleteExpr (_, _, expr_info, _) @@ -136,7 +135,7 @@ let cut_struct_union s = match buf with | "struct":: l (*-> Printing.string_from_list l *) | "class":: l - | "union":: l -> string_from_list l + | "union":: l -> General_utils.string_from_list l | _ -> s let get_name_from_struct s = diff --git a/infer/src/clang/cTypes_decl.ml b/infer/src/clang/cTypes_decl.ml index 6d79ed064..f25b05224 100644 --- a/infer/src/clang/cTypes_decl.ml +++ b/infer/src/clang/cTypes_decl.ml @@ -10,9 +10,7 @@ (** Processes types and record declarations by adding them to the tenv *) open Utils -open Clang_ast_t open CFrontend_utils -open CFrontend_utils.General_utils module L = Logging exception Typename_not_found @@ -86,10 +84,10 @@ let string_type_to_sil_type tenv s = let s = (match Str.split (Str.regexp "[ \t]+") s with | "struct"::"(anonymous":: "struct":: s' -> (*Printing.log_out " ...Getting rid of the extra 'struct' word@."; *) - string_from_list ("struct"::"(anonymous":: s') + General_utils.string_from_list ("struct"::"(anonymous":: s') | "union"::"(anonymous":: "union":: s' -> (*Printing.log_out " ...Getting rid of the extra 'union' word@."; *) - string_from_list ("union"::"(anonymous":: s') + General_utils.string_from_list ("union"::"(anonymous":: s') | _ -> s) in let lexbuf = Lexing.from_string s in let t = @@ -140,6 +138,7 @@ let get_record_name opt_type = match opt_type with let get_method_decls parent decl_list = + let open Clang_ast_t in let rec traverse_decl parent decl = match decl with | CXXMethodDecl _ -> [(parent, decl)] | CXXRecordDecl (_, _, _, _, decl_list', _, _, _) @@ -195,12 +194,13 @@ and do_typedef_declaration tenv namespace decl_info name opt_type typedef_decl_i Sil.tenv_add tenv typename typ and get_struct_fields tenv record_name namespace decl_list = + let open Clang_ast_t in match decl_list with | [] -> [] | FieldDecl(decl_info, name_info, qual_type, field_decl_info):: decl_list' -> let field_name = name_info.Clang_ast_t.ni_name in Printing.log_out " ...Defining field '%s'.\n" field_name; - let id = mk_class_field_name record_name field_name in + let id = General_utils.mk_class_field_name record_name field_name in let typ = qual_type_to_sil_type tenv qual_type in let annotation_items = [] in (* For the moment we don't use them*) (id, typ, annotation_items):: get_struct_fields tenv record_name namespace decl_list' @@ -215,10 +215,10 @@ and get_struct_fields tenv record_name namespace decl_list = and get_class_methods tenv class_name namespace decl_list = let process_method_decl = function - | CXXMethodDecl (decl_info, name_info, qual_type, function_decl_info) -> - let method_name = name_info.ni_name in + | Clang_ast_t.CXXMethodDecl (decl_info, name_info, qual_type, function_decl_info) -> + let method_name = name_info.Clang_ast_t.ni_name in Printing.log_out " ...Declaring method '%s'.\n" method_name; - let method_proc = mk_procname_from_cpp_method class_name method_name (CTypes.get_type qual_type) in + let method_proc = General_utils.mk_procname_from_cpp_method class_name method_name (CTypes.get_type qual_type) in Some method_proc | _ -> None in (* poor mans list_filter_map *) @@ -241,7 +241,7 @@ and get_declaration_type tenv namespace decl_info n opt_type decl_list decl_cont Printing.log_out "Record Declaration '%s' defined as struct\n" n; let non_static_fields = get_struct_fields tenv name_str namespace decl_list in 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 + General_utils.append_no_duplicates_fields [Sil.objc_ref_counter_field] non_static_fields else non_static_fields in let non_static_fields = CFrontend_utils.General_utils.sort_fields non_static_fields in let static_fields = [] in (* Warning for the moment we do not treat static field. *) @@ -264,6 +264,7 @@ and add_late_defined_record tenv namespace typename = Printing.log_out "!!!! Calling late-defined record '%s'\n" (Sil.typename_to_string typename) ; match typename with | Sil.TN_csu(Sil.Struct, name) | Sil.TN_csu(Sil.Union, name) -> + let open Clang_ast_t in let rec scan decls = match decls with | [] -> false @@ -300,6 +301,7 @@ and add_late_defined_typedef tenv namespace typename = match typename with | Sil.TN_typedef name -> let rec scan decls = + let open Clang_ast_t in match decls with | [] -> false | TypedefDecl (decl_info, name_info, opt_type, _, tdi) :: decls' -> diff --git a/infer/src/clang/cVar_decl.ml b/infer/src/clang/cVar_decl.ml index d93ac05b6..0a2f92847 100644 --- a/infer/src/clang/cVar_decl.ml +++ b/infer/src/clang/cVar_decl.ml @@ -12,7 +12,6 @@ open Utils open CFrontend_utils -open Clang_ast_t module L = Logging @@ -43,7 +42,8 @@ let rec lookup_ahead_for_vardecl context pointer var_name kind decl_list = match decl_list with | [] -> 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 *) - | VarDecl(decl_info, var_info, t, _) :: rest when var_name = var_info.Clang_ast_t.ni_name -> + | Clang_ast_t.VarDecl (decl_info, var_info, t, _) :: rest + when var_name = var_info.Clang_ast_t.ni_name -> let var_name' = var_info.Clang_ast_t.ni_name in if global_to_be_added decl_info then ( let tenv = CContext.get_tenv context in @@ -103,11 +103,12 @@ let lookup_var stmt_info context pointer var_name kind = (* in the reference instructions, all the variable names are also saved in a map from pointers *) (* to variable names to be used in the translation of the method's body. *) let rec get_variables_stmt context (stmt : Clang_ast_t.stmt) : unit = + let open Clang_ast_t in match stmt with - | DeclStmt(_, lstmt, decl_list) -> + | DeclStmt (_, lstmt, decl_list) -> get_variables_decls context decl_list; get_fun_locals context lstmt; - | 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... *) (* so no declaration here *) Printing.log_out "Collecting variables, passing from DeclRefExpr '%s'\n" @@ -119,11 +120,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 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 "Collecting variables, passing from CompoundStmt '%s'\n" stmt_info.Clang_ast_t.si_pointer; CContext.LocalVars.enter_and_leave_scope context get_fun_locals lstmt - | ForStmt(stmt_info, lstmt) -> + | ForStmt (stmt_info, lstmt) -> Printing.log_out "Collecting variables, passing from ForStmt '%s'\n" stmt_info.Clang_ast_t.si_pointer; CContext.LocalVars.enter_and_leave_scope context get_fun_locals lstmt @@ -141,6 +142,7 @@ and get_fun_locals context (stmts : Clang_ast_t.stmt list) : unit = (* Collects the local of a function. *) and get_variables_decls context (decl_list : Clang_ast_t.decl list) : unit = let do_one_decl decl = + let open Clang_ast_t in match decl with | VarDecl (decl_info, name_info, qual_type, var_decl_info) -> Printing.log_out "Collecting variables, passing from VarDecl '%s'\n" decl_info.Clang_ast_t.di_pointer; @@ -156,8 +158,8 @@ and get_variables_decls context (decl_list : Clang_ast_t.decl list) : unit = | _ -> CContext.LocalVars.add_local_var context name typ decl_info.Clang_ast_t.di_pointer (CFrontend_utils.General_utils.is_static_var var_decl_info)) - | CXXRecordDecl(di, n_info, ot, _, dl, dci, rdi, _) - | RecordDecl(di, n_info, ot, _, dl, dci, rdi) -> + | CXXRecordDecl (di, n_info, ot, _, dl, dci, rdi, _) + | RecordDecl (di, n_info, ot, _, dl, dci, rdi) -> let typ = CTypes_decl.get_declaration_type context.CContext.tenv context.CContext.namespace di n_info.Clang_ast_t.ni_name ot dl dci rdi in CTypes_decl.add_struct_to_tenv context.CContext.tenv typ diff --git a/infer/src/clang/objcInterface_decl.ml b/infer/src/clang/objcInterface_decl.ml index 24fb9f0d8..80e15ed08 100644 --- a/infer/src/clang/objcInterface_decl.ml +++ b/infer/src/clang/objcInterface_decl.ml @@ -16,8 +16,6 @@ open Utils open CFrontend_utils -open CFrontend_utils.General_utils -open Clang_ast_t module L = Logging @@ -108,14 +106,14 @@ let add_class_to_tenv tenv class_name decl_list obj_c_interface_decl_info = let fields, superclasses, methods = match Sil.tenv_lookup tenv interface_name with | Some Sil.Tstruct(saved_fields, _, _, _, saved_superclasses, saved_methods, _) -> - append_no_duplicates_fields fields saved_fields, - append_no_duplicates_csu superclasses saved_superclasses, - append_no_duplicates_methods methods saved_methods + General_utils.append_no_duplicates_fields fields saved_fields, + General_utils.append_no_duplicates_csu superclasses saved_superclasses, + General_utils.append_no_duplicates_methods methods saved_methods | _ -> fields, superclasses, methods in - let fields = append_no_duplicates_fields fields fields_sc in + let fields = General_utils.append_no_duplicates_fields fields fields_sc in (* We add the special hidden counter_field for implementing reference counting *) - let fields = append_no_duplicates_fields [Sil.objc_ref_counter_field] fields in - let fields = CFrontend_utils.General_utils.sort_fields fields in + let fields = General_utils.append_no_duplicates_fields [Sil.objc_ref_counter_field] fields in + let fields = General_utils.sort_fields fields in Printing.log_out "Class %s field:\n" class_name; list_iter (fun (fn, ft, _) -> Printing.log_out "-----> field: '%s'\n" (Ident.fieldname_to_string fn)) fields; @@ -162,13 +160,14 @@ let interface_impl_declaration tenv class_name decl_list idi = (* ...Full definition of the interface I *) let lookup_late_defined_interface tenv cname = let rec scan decls = + let open Clang_ast_t in match decls with | [] -> () - | ObjCInterfaceDecl(decl_info, name_info, decl_list, decl_context_info, obj_c_interface_decl_info) + | ObjCInterfaceDecl (decl_info, name_info, decl_list, decl_context_info, obj_c_interface_decl_info) :: decls' when (Mangled.from_string name_info.Clang_ast_t.ni_name) = cname -> scan decls' - | ObjCInterfaceDecl(decl_info, name_info, decl_list, decl_context_info, obj_c_interface_decl_info) + | ObjCInterfaceDecl (decl_info, name_info, decl_list, decl_context_info, obj_c_interface_decl_info) :: decls' when (Mangled.from_string name_info.Clang_ast_t.ni_name) = cname -> (* Assumption: here we assume that the first interface declaration with non empty set of fields is the *) diff --git a/infer/src/clang/objcProperty_decl.ml b/infer/src/clang/objcProperty_decl.ml index a3ed2643a..978f33e70 100644 --- a/infer/src/clang/objcProperty_decl.ml +++ b/infer/src/clang/objcProperty_decl.ml @@ -17,8 +17,7 @@ open Utils open CFrontend_utils -open CFrontend_config -open Clang_ast_t + module L = Logging open CContext @@ -122,11 +121,11 @@ struct let print_item key (qt, attributes, decl_info, getter, setter, ivar) = let getter_str = match getter with - | getter_name, Some (ObjCMethodDecl(_, _, _), defined1) -> + | getter_name, Some (Clang_ast_t.ObjCMethodDecl _, defined1) -> getter_name | _ -> "" in let setter_str = match setter with - | setter_name, Some (ObjCMethodDecl(_, _, _), defined2) -> + | setter_name, Some (Clang_ast_t.ObjCMethodDecl _, defined2) -> setter_name | _ -> "" in Logging.out "Property item %s accessors %s and %s \n" @@ -254,7 +253,7 @@ let get_memory_management_attribute attributes = with Not_found -> None let create_generated_method_name name_info = - { ni_name = name_info.Clang_ast_t.ni_name; + { Clang_ast_t.ni_name = name_info.Clang_ast_t.ni_name; ni_qual_name = CFrontend_config.generated_suffix:: name_info.Clang_ast_t.ni_qual_name; } @@ -267,6 +266,7 @@ let make_getter curr_class prop_name prop_type = match prop_type with | qt, attributes, decl_info, (getter_name, getter), (setter_name, setter), ivar_opt -> let ivar_name = get_ivar_name prop_name ivar_opt in + let open Clang_ast_t in match getter with | Some (ObjCMethodDecl(di, name_info, mdi), _) -> let dummy_info = Ast_expressions.dummy_decl_info_in_curr_file di in @@ -286,6 +286,7 @@ let make_setter curr_class prop_name prop_type = match prop_type with | qt, attributes, decl_info, (getter_name, getter), (setter_name, setter), ivar_opt -> let ivar_name = get_ivar_name prop_name ivar_opt in + let open Clang_ast_t in match setter with | Some (ObjCMethodDecl(di, name, mdi), _) when not (is_property_read_only attributes) -> let dummy_info = Ast_expressions.dummy_decl_info_in_curr_file di in @@ -308,12 +309,12 @@ let make_setter curr_class prop_name prop_type = let code = if Ast_utils.is_retain memory_management_attribute then let param_decl = Ast_expressions.make_decl_ref_exp_var (param_name, qt_param, decl_ptr) `ParmVar stmt_info in - let retain_call = Ast_expressions.make_message_expr qt_param retain param_decl stmt_info true in - let release_call = Ast_expressions.make_message_expr qt_param release lhs_exp stmt_info true in + let retain_call = Ast_expressions.make_message_expr qt_param CFrontend_config.retain param_decl stmt_info true in + let release_call = Ast_expressions.make_message_expr qt_param CFrontend_config.release lhs_exp stmt_info true in [retain_call; release_call; setter] else if Ast_utils.is_copy memory_management_attribute then let param_decl = Ast_expressions.make_decl_ref_exp_var (param_name, qt_param, decl_ptr) `ParmVar stmt_info in - let copy_call = Ast_expressions.make_message_expr qt_param copy param_decl stmt_info true in + let copy_call = Ast_expressions.make_message_expr qt_param CFrontend_config.copy param_decl stmt_info true in let setter = Ast_expressions.make_binary_stmt lhs_exp copy_call stmt_info expr_info boi in [setter] else [setter] in @@ -349,12 +350,12 @@ let make_getter_setter curr_class decl_info prop_name = let add_properties_to_table curr_class decl_list = let add_property_to_table dec = match dec with - | ObjCPropertyDecl(decl_info, name_info, pdi) -> + | Clang_ast_t.ObjCPropertyDecl(decl_info, name_info, pdi) -> (* Property declaration register the property on the property table to be *) let pname = name_info.Clang_ast_t.ni_name in Printing.log_out "ADDING: ObjCPropertyDecl for property '%s' " pname; 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.Clang_ast_t.opdi_qual_type pdi.Clang_ast_t.opdi_property_attributes decl_info; | _ -> () in list_iter add_property_to_table decl_list @@ -364,7 +365,7 @@ let get_methods curr_class decl_list = add_properties_to_table curr_class decl_list; let get_method decl list_methods = match decl with - ObjCMethodDecl(decl_info, name_info, method_decl_info) -> + | Clang_ast_t.ObjCMethodDecl (decl_info, name_info, method_decl_info) -> let is_instance = method_decl_info.Clang_ast_t.omdi_is_instance_method in let method_kind = Procname.objc_method_kind_of_bool is_instance in let method_name = name_info.Clang_ast_t.ni_name in