diff options
author | Justin Squirek <squirek@adacore.com> | 2019-12-12 10:03:16 +0000 |
---|---|---|
committer | Pierre-Marie de Rodat <pmderodat@gcc.gnu.org> | 2019-12-12 10:03:16 +0000 |
commit | 2f0a921fadf4e8bcc2820db0da227366ecd50bf7 (patch) | |
tree | db15241aa01ccb45b31015adf51b81c4cde81b63 /gcc/ada | |
parent | 4bcf29692fd5ee57cc857157912e9ef492205075 (diff) | |
download | gcc-2f0a921fadf4e8bcc2820db0da227366ecd50bf7.zip gcc-2f0a921fadf4e8bcc2820db0da227366ecd50bf7.tar.gz gcc-2f0a921fadf4e8bcc2820db0da227366ecd50bf7.tar.bz2 |
[Ada] Broken privacy on Controlled type extensions
2019-12-12 Justin Squirek <squirek@adacore.com>
gcc/ada/
* sem_ch4.adb (Analyze_One_Call): Add condition to check for
incorrectly resolved hidden controlled primitives.
From-SVN: r279297
Diffstat (limited to 'gcc/ada')
-rw-r--r-- | gcc/ada/ChangeLog | 5 | ||||
-rw-r--r-- | gcc/ada/sem_ch4.adb | 54 |
2 files changed, 57 insertions, 2 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 49fdae7..7c77382 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,8 @@ +2019-12-12 Justin Squirek <squirek@adacore.com> + + * sem_ch4.adb (Analyze_One_Call): Add condition to check for + incorrectly resolved hidden controlled primitives. + 2019-12-12 Ed Schonberg <schonberg@adacore.com> * sem_res.adb: Fix processing of standard predefined operators. diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 58e178e..81c5bfd 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -3249,6 +3249,7 @@ package body Sem_Ch4 is -- is already known to be compatible, and because this may be an -- indexing of a call with default parameters. + First_Form : Entity_Id; Formal : Entity_Id; Actual : Node_Id; Is_Indexed : Boolean := False; @@ -3581,8 +3582,9 @@ package body Sem_Ch4 is -- Normalize_Actuals has chained the named associations in the -- correct order of the formals. - Actual := First_Actual (N); - Formal := First_Formal (Nam); + Actual := First_Actual (N); + Formal := First_Formal (Nam); + First_Form := Formal; -- If we are analyzing a call rewritten from object notation, skip -- first actual, which may be rewritten later as an explicit @@ -3742,6 +3744,54 @@ package body Sem_Ch4 is end if; end loop; + -- Due to our current model of controlled type expansion we may + -- have resolved a user call to a non-visible controlled primitive + -- since these inherited subprograms may be generated in the current + -- scope. This is a side-effect of the need for the expander to be + -- able to resolve internally generated calls. + + -- Specifically, the issue appears when predefined controlled + -- operations get called on a type extension whose parent is a + -- private extension completed with a controlled extension - see + -- below: + + -- package X is + -- type Par_Typ is tagged private; + -- private + -- type Par_Typ is new Controlled with null record; + -- end; + -- ... + -- procedure Main is + -- type Ext_Typ is new Par_Typ with null record; + -- Obj : Ext_Typ; + -- begin + -- Finalize (Obj); -- Will improperly resolve + -- end; + + -- To avoid breaking privacy, Is_Hidden gets set elsewhere on such + -- primitives, but we still need to verify that Nam is indeed a + -- controlled subprogram. So, we do that here and issue the + -- appropriate error. + + if Is_Hidden (Nam) + and then not In_Instance + and then not Comes_From_Source (Nam) + and then Comes_From_Source (N) + + -- Verify Nam is a controlled primitive + + and then Nam_In (Chars (Nam), Name_Adjust, + Name_Finalize, + Name_Initialize) + and then Ekind (Nam) = E_Procedure + and then Is_Controlled (Etype (First_Form)) + and then No (Next_Formal (First_Form)) + then + Error_Msg_Node_2 := Etype (First_Form); + Error_Msg_NE ("call to non-visible controlled primitive & on type" + & " &", N, Nam); + end if; + -- On exit, all actuals match Indicate_Name_And_Type; |