From: Justin Squirek <squirek@adacore.com>
Date: Thu, 12 Dec 2019 10:03:16 +0000 (+0000)
Subject: [Ada] Broken privacy on Controlled type extensions
X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=2f0a921fadf4e8bcc2820db0da227366ecd50bf7;p=gcc.git

[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
---

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  <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 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;