[Ada] Crash on use of Loop_Entry, Result, and Old as actuals

2019-12-12  Justin Squirek  <squirek@adacore.com>

gcc/ada/

	* exp_ch6.adb (Expand_Call_Helper): Added null case for
	'Loop_Entry, 'Old, and 'Result when calculating whether to
	create extra accessibility parameters.
	* sem_util.adb (Dynamic_Accessibility_Level): Added null case
	for 'Loop_Entry, 'Old, and 'Result when  calculating
	accessibility level based on access-valued attributes.  Also
	added special handling for uses of 'Loop_Entry when used in its
	indexed component form.

From-SVN: r279280

3 files changed, 43 insertions, 1 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index c57674e..7343430 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,14 @@
+2019-12-12  Justin Squirek  <squirek@adacore.com>
+
+	* exp_ch6.adb (Expand_Call_Helper): Added null case for
+	'Loop_Entry, 'Old, and 'Result when calculating whether to
+	create extra accessibility parameters.
+	* sem_util.adb (Dynamic_Accessibility_Level): Added null case
+	for 'Loop_Entry, 'Old, and 'Result when  calculating
+	accessibility level based on access-valued attributes.  Also
+	added special handling for uses of 'Loop_Entry when used in its
+	indexed component form.
+
 2019-12-12  Arnaud Charlet  <charlet@adacore.com>
 
 	* raise-gcc.c: Remove references to VMS
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index b311322..3d6ef48 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -3389,6 +3389,15 @@ package body Exp_Ch6 is
                case Nkind (Prev_Orig) is
                   when N_Attribute_Reference =>
                      case Get_Attribute_Id (Attribute_Name (Prev_Orig)) is
+                        --  Ignore 'Result, 'Loop_Entry, and 'Old as they can
+                        --  be used to identify access objects and do not have
+                        --  an effect on accessibility level.
+
+                        when Attribute_Loop_Entry
+                           | Attribute_Old
+                           | Attribute_Result
+                        =>
+                           null;
 
                         --  For X'Access, pass on the level of the prefix X
 
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 4de41d3e..c7dabdd 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -6488,7 +6488,7 @@ package body Sem_Util is
 
       --  Local variables
 
-      Expr : constant Node_Id := Original_Node (N);
+      Expr : Node_Id := Original_Node (N);
       --  Expr references the original node because at this stage N may be the
       --  reference to a variable internally created by the frontend to remove
       --  side effects of an expression.
@@ -6516,6 +6516,21 @@ package body Sem_Util is
       --  Unimplemented: Ptr.all'Access, where Ptr has Extra_Accessibility ???
 
       case Nkind (Expr) is
+         --  It may be possible that we have an access object denoted by an
+         --  attribute reference for 'Loop_Entry which may, in turn, have an
+         --  indexed component representing a loop identifier.
+
+         --  In this case we must climb up the indexed component and set expr
+         --  to the attribute reference so the rest of the machinery can
+         --  operate as expected.
+
+         when N_Indexed_Component =>
+            if Nkind (Prefix (Expr)) = N_Attribute_Reference
+              and then Get_Attribute_Id (Attribute_Name (Prefix (Expr)))
+                         = Attribute_Loop_Entry
+            then
+               Expr := Prefix (Expr);
+            end if;
 
          --  For access discriminant, the level of the enclosing object
 
@@ -6530,6 +6545,13 @@ package body Sem_Util is
          when N_Attribute_Reference =>
             case Get_Attribute_Id (Attribute_Name (Expr)) is
 
+               --  Ignore 'Loop_Entry, 'Result, and 'Old as they can be used to
+               --  identify access objects and do not have an effect on
+               --  accessibility level.
+
+               when Attribute_Loop_Entry | Attribute_Old | Attribute_Result =>
+                  null;
+
                --  For X'Access, the level of the prefix X
 
                when Attribute_Access =>