[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 8f7e51d..ddee2dc 100644 (file)
--- 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 f3ba069..00e81ce 100644 (file)
--- 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 5d2e81b..f177417 100644 (file)
--- 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 6ab7157..d71ee6c 100644 (file)
--- 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 (file)
index 0000000..3f91f0a
--- /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;