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 <[email protected]>
* 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;
