[Ada] Legality checks on calls to a Generic_Dispatching_Constructor.

[Ada] Legality checks on calls to a Generic_Dispatching_Constructor.

[Arnaud Charlet]

[-- Attachment #1: Type: text/plain, Size: 750 bytes --]

This patch adds several legality checks on calls to an instance of the
predefined Generic_Dispatchin_Constructor. The following three tests are
performed:

a) The tag argument is defined, i.e. is not No_Tag.

b) The  tag is not that of an abstract type.

c) The accessibility level of the type denoted by the tag is no greater than
that of the specified constructor function.

Tested in  ACATS 4.0H C390012.

Tested on x86_64-pc-linux-gnu, committed on trunk

2015-11-12  Ed Schonberg  <schonberg@adacore.com>

	* exp_intr.adb: Add legality checks on calls to a
	Generic_Dispatching_Constructor: the given tag must be defined,
	it cannot be the tag of an abstract type, and its accessibility
	level must not be greater than that of the constructor.


[-- Attachment #2: difs --]
[-- Type: text/plain, Size: 3836 bytes --]

Index: exp_intr.adb
===================================================================
--- exp_intr.adb	(revision 230223)
+++ exp_intr.adb	(working copy)
@@ -311,6 +311,31 @@
 
       Remove_Side_Effects (Tag_Arg);
 
+      --  Check that we have a proper tag
+
+      Insert_Action (N,
+        Make_Implicit_If_Statement (N,
+          Condition       => Make_Op_Eq (Loc,
+            Left_Opnd  => New_Copy_Tree (Tag_Arg),
+            Right_Opnd => New_Occurrence_Of (RTE (RE_No_Tag), Loc)),
+
+          Then_Statements => New_List (
+            Make_Raise_Statement (Loc,
+              New_Occurrence_Of (RTE (RE_Tag_Error), Loc)))));
+
+      --  Check that it is not the tag of an abstract type
+
+      Insert_Action (N,
+        Make_Implicit_If_Statement (N,
+          Condition       => Make_Function_Call (Loc,
+             Name                   =>
+               New_Occurrence_Of (RTE (RE_Type_Is_Abstract), Loc),
+             Parameter_Associations => New_List (New_Copy_Tree (Tag_Arg))),
+
+          Then_Statements => New_List (
+            Make_Raise_Statement (Loc,
+              New_Occurrence_Of (RTE (RE_Tag_Error), Loc)))));
+
       --  The subprogram is the third actual in the instantiation, and is
       --  retrieved from the corresponding renaming declaration. However,
       --  freeze nodes may appear before, so we retrieve the declaration
@@ -324,6 +349,22 @@
       Act_Constr := Entity (Name (Act_Rename));
       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.
+
+      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)))));
+
       if Is_Interface (Etype (Act_Constr)) then
 
          --  If the result type is not known to be a parent of Tag_Arg then we
@@ -390,7 +431,6 @@
       --  conversion of the call to the actual constructor.
 
       Rewrite (N, Convert_To (Result_Typ, Cnstr_Call));
-      Analyze_And_Resolve (N, Etype (Act_Constr));
 
       --  Do not generate a run-time check on the built object if tag
       --  checks are suppressed for the result type or tagged type expansion
@@ -458,6 +498,8 @@
                  Make_Raise_Statement (Loc,
                    Name => New_Occurrence_Of (RTE (RE_Tag_Error), Loc)))));
       end if;
+
+      Analyze_And_Resolve (N, Etype (Act_Constr));
    end Expand_Dispatching_Constructor_Call;
 
    ---------------------------
Index: rtsfind.ads
===================================================================
--- rtsfind.ads	(revision 230223)
+++ rtsfind.ads	(working copy)
@@ -640,6 +640,7 @@
      RE_Max_Predef_Prims,                -- Ada.Tags
      RE_Needs_Finalization,              -- Ada.Tags
      RE_No_Dispatch_Table_Wrapper,       -- Ada.Tags
+     RE_No_Tag,                          -- Ada.Tags
      RE_NDT_Prims_Ptr,                   -- Ada.Tags
      RE_NDT_TSD,                         -- Ada.Tags
      RE_Num_Prims,                       -- Ada.Tags
@@ -1871,6 +1872,7 @@
      RE_Max_Predef_Prims                 => Ada_Tags,
      RE_Needs_Finalization               => Ada_Tags,
      RE_No_Dispatch_Table_Wrapper        => Ada_Tags,
+     RE_No_Tag                           => Ada_Tags,
      RE_NDT_Prims_Ptr                    => Ada_Tags,
      RE_NDT_TSD                          => Ada_Tags,
      RE_Num_Prims                        => Ada_Tags,