From: Arnaud Charlet <charlet@adacore.com>
To: gcc-patches@gcc.gnu.org
Cc: Ed Schonberg <schonberg@adacore.com>
Subject: [Ada] Legality checks on calls to a Generic_Dispatching_Constructor.
Date: Thu, 12 Nov 2015 11:38:00 -0000 [thread overview]
Message-ID: <20151112113843.GA44606@adacore.com> (raw)
[-- 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,
reply other threads:[~2015-11-12 11:38 UTC|newest]
Thread overview: [no followups] expand[flat|nested] mbox.gz Atom feed
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20151112113843.GA44606@adacore.com \
--to=charlet@adacore.com \
--cc=gcc-patches@gcc.gnu.org \
--cc=schonberg@adacore.com \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).