From: Javier Miranda <miranda@adacore.com>
Date: Thu, 24 May 2018 13:06:28 +0000 (+0000)
Subject: [Ada] Missing error on illegal access to discriminant
X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=24e959661f42da6c5c65de96a7c9d88082c3ffd8;p=gcc.git

[Ada] Missing error on illegal access to discriminant

The compiler does not report an error on the illegal access to a renamed
discriminant when the actual object is a parameter of a subprogram.

2018-05-24  Javier Miranda  <miranda@adacore.com>

gcc/ada/

	* sem_ch3.adb (Is_Visible_Component): For untagged types add missing
	check for renamed discriminants.
	* sem_ch4.adb (Analyze_Overloaded_Selected_Component,
	Analyze_Selected_Component, Check_Misspelled_Selector): For calls to
	Is_Visible_Component pass the associated selector node to allow
	checking renamed discriminants on untagged types.

gcc/testsuite/

	* gnat.dg/discr52.adb: New testcase.

From-SVN: r260664
---

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 8f7e51df49d..ddee2dca188 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,12 @@
+2018-05-24  Javier Miranda  <miranda@adacore.com>
+
+	* sem_ch3.adb (Is_Visible_Component): For untagged types add missing
+	check for renamed discriminants.
+	* sem_ch4.adb (Analyze_Overloaded_Selected_Component,
+	Analyze_Selected_Component, Check_Misspelled_Selector): For calls to
+	Is_Visible_Component pass the associated selector node to allow
+	checking renamed discriminants on untagged types.
+
 2018-05-24  Ed Schonberg  <schonberg@adacore.com>
 
 	* sem_ch8.adb (Analyze_Use_Type): Do not assign the Prev_Use_Clause
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index f3ba0691ce5..00e81ce4856 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -18797,7 +18797,18 @@ package body Sem_Ch3 is
       --  This test only concerns tagged types
 
       if not Is_Tagged_Type (Original_Type) then
-         return True;
+
+         --  Check if this is a renamed discriminant (hidden either by the
+         --  derived type or by some ancestor), unless we are analyzing code
+         --  generated by the expander since it may reference such components
+         --  (for example see the expansion of Deep_Adjust).
+
+         if Ekind (C) = E_Discriminant and then Present (N) then
+            return not Comes_From_Source (N)
+              or else not Is_Completely_Hidden (C);
+         else
+            return True;
+         end if;
 
       --  If it is _Parent or _Tag, there is no visibility issue
 
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index 5d2e81b3056..f17741758dd 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -3905,7 +3905,7 @@ package body Sem_Ch4 is
             Comp := First_Entity (T);
             while Present (Comp) loop
                if Chars (Comp) = Chars (Sel)
-                 and then Is_Visible_Component (Comp)
+                 and then Is_Visible_Component (Comp, Sel)
                then
 
                   --  AI05-105:  if the context is an object renaming with
@@ -5324,7 +5324,7 @@ package body Sem_Ch4 is
                Comp := First_Component (Base_Type (Prefix_Type));
                while Present (Comp) loop
                   if Chars (Comp) = Chars (Sel)
-                    and then Is_Visible_Component (Comp)
+                    and then Is_Visible_Component (Comp, Sel)
                   then
                      Set_Entity_With_Checks (Sel, Comp);
                      Generate_Reference (Comp, Sel);
@@ -6031,7 +6031,7 @@ package body Sem_Ch4 is
 
       Comp  := First_Entity (Prefix);
       while Nr_Of_Suggestions <= Max_Suggestions and then Present (Comp) loop
-         if Is_Visible_Component (Comp) then
+         if Is_Visible_Component (Comp, Sel) then
             if Is_Bad_Spelling_Of (Chars (Comp), Chars (Sel)) then
                Nr_Of_Suggestions := Nr_Of_Suggestions + 1;
 
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 6ab715740b3..d71ee6c4f12 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2018-05-24  Javier Miranda  <miranda@adacore.com>
+
+	* gnat.dg/discr52.adb: New testcase.
+
 2018-05-24  Ed Schonberg  <schonberg@adacore.com>
 
 	* gnat.dg/others1.adb: New testcase.
diff --git a/gcc/testsuite/gnat.dg/discr52.adb b/gcc/testsuite/gnat.dg/discr52.adb
new file mode 100644
index 00000000000..3f91f0aa8d3
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/discr52.adb
@@ -0,0 +1,20 @@
+--  { dg-do compile }
+
+procedure Discr52 is
+   type T_Root (Root_Disc : Natural) is record
+      Data : Natural := 0;
+   end record;
+
+   type T_Derived (deriv_disc : Natural) is
+     new T_Root (root_disc => deriv_disc);
+
+   Derived : T_Derived (Deriv_Disc => 3);
+   Value   : Natural;
+
+   procedure Do_Test (Obj : T_Derived) is
+   begin
+      Value := Obj.root_disc; --  { dg-error "no selector \"root_disc\" for type \"T_Derived\" defined at line \\d+" }
+   end;
+begin
+   Do_Test (Derived);
+end;