From 2f0a921fadf4e8bcc2820db0da227366ecd50bf7 Mon Sep 17 00:00:00 2001 From: Justin Squirek Date: Thu, 12 Dec 2019 10:03:16 +0000 Subject: [PATCH] [Ada] Broken privacy on Controlled type extensions 2019-12-12 Justin Squirek gcc/ada/ * sem_ch4.adb (Analyze_One_Call): Add condition to check for incorrectly resolved hidden controlled primitives. From-SVN: r279297 --- gcc/ada/ChangeLog | 5 +++++ gcc/ada/sem_ch4.adb | 54 +++++++++++++++++++++++++++++++++++++++++++-- 2 files changed, 57 insertions(+), 2 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 49fdae76d96..7c7738229ef 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,8 @@ +2019-12-12 Justin Squirek + + * sem_ch4.adb (Analyze_One_Call): Add condition to check for + incorrectly resolved hidden controlled primitives. + 2019-12-12 Ed Schonberg * sem_res.adb: Fix processing of standard predefined operators. diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 58e178e967f..81c5bfd3a46 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; -- 2.30.2