CodePeer does not do anything useful with the various components of the record type Ada.Tags.Type_Specific_Data. Suppress generation of some checks which reference these components in cases where these checks cause CodePeer to generate unwanted messages.
This change has no user-visible effect except when Gnat2scil is running. Tested on x86_64-pc-linux-gnu, committed on trunk 2017-04-25 Steve Baird <ba...@adacore.com> * exp_ch6.adb (Expand_Simple_Function_Return): if CodePeer_Mode is True, then don't generate the accessibility check for the tag of a tagged result. * exp_intr.adb (Expand_Dispatching_Constructor_Call): if CodePeer_Mode is True, then don't generate the tag checks for the result of call to an instance of Ada.Tags.Generic_Dispatching_Constructor (i.e., both the "is a descendant of" check and the accessibility check).
Index: exp_ch6.adb =================================================================== --- exp_ch6.adb (revision 247136) +++ exp_ch6.adb (working copy) @@ -6635,15 +6635,20 @@ Attribute_Name => Name_Tag); end if; - Insert_Action (Exp, - Make_Raise_Program_Error (Loc, - Condition => - Make_Op_Gt (Loc, - Left_Opnd => Build_Get_Access_Level (Loc, Tag_Node), - Right_Opnd => - Make_Integer_Literal (Loc, - Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id)))), - Reason => PE_Accessibility_Check_Failed)); + if not CodePeer_Mode then + -- CodePeer doesn't do anything useful with + -- Ada.Tags.Type_Specific_Data components + + Insert_Action (Exp, + Make_Raise_Program_Error (Loc, + Condition => + Make_Op_Gt (Loc, + Left_Opnd => Build_Get_Access_Level (Loc, Tag_Node), + Right_Opnd => + Make_Integer_Literal (Loc, + Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id)))), + Reason => PE_Accessibility_Check_Failed)); + end if; end; -- AI05-0073: If function has a controlling access result, check that Index: exp_intr.adb =================================================================== --- exp_intr.adb (revision 247150) +++ exp_intr.adb (working copy) @@ -421,20 +421,22 @@ Result_Typ := Class_Wide_Type (Etype (Act_Constr)); -- Check that the accessibility level of the tag is no deeper than that - -- of the constructor function. + -- of the constructor function (unless CodePeer_Mode) - Insert_Action (N, - Make_Implicit_If_Statement (N, - Condition => - Make_Op_Gt (Loc, - Left_Opnd => - Build_Get_Access_Level (Loc, New_Copy_Tree (Tag_Arg)), - Right_Opnd => - Make_Integer_Literal (Loc, Scope_Depth (Act_Constr))), + if not CodePeer_Mode then + Insert_Action (N, + Make_Implicit_If_Statement (N, + Condition => + Make_Op_Gt (Loc, + Left_Opnd => + Build_Get_Access_Level (Loc, New_Copy_Tree (Tag_Arg)), + Right_Opnd => + Make_Integer_Literal (Loc, Scope_Depth (Act_Constr))), - Then_Statements => New_List ( - Make_Raise_Statement (Loc, - New_Occurrence_Of (RTE (RE_Tag_Error), Loc))))); + Then_Statements => New_List ( + Make_Raise_Statement (Loc, + New_Occurrence_Of (RTE (RE_Tag_Error), Loc))))); + end if; if Is_Interface (Etype (Act_Constr)) then @@ -505,10 +507,11 @@ -- Do not generate a run-time check on the built object if tag -- checks are suppressed for the result type or tagged type expansion - -- is disabled. + -- is disabled or if CodePeer_Mode. if Tag_Checks_Suppressed (Etype (Result_Typ)) or else not Tagged_Type_Expansion + or else CodePeer_Mode then null;