diff mbox

[Ada] For CodePeer, omit some tag checks which confuse gnat2scil

Message ID 20170425094617.GA8503@adacore.com
State New
Headers show

Commit Message

Arnaud Charlet April 25, 2017, 9:46 a.m. UTC 
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  <baird@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).
diff mbox

Patch

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;