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 <schonb...@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.
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,
