From: Ed Schonberg <schonberg@adacore.com>
Date: Tue, 11 Dec 2018 11:12:16 +0000 (+0000)
Subject: [Ada] Crash on misplaced First operation for GNAT iterable type
X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=2f42b6ead47da2c5d863042de6689aee64d342b3;p=gcc.git

[Ada] Crash on misplaced First operation for GNAT iterable type

This patch improves the handling of an improper declaaration of aspect
First for a GNAT-defined iterable type,

2018-12-11  Ed Schonberg  <schonberg@adacore.com>

gcc/ada/

	* sem_util.adb (Get_Actual_Subtype): Function can return type
	mark.
	(Get_Cursor_Type): Improve recovery and error message on a
	misplaced First aspect for an iterable type.

gcc/testsuite/

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

From-SVN: r267013
---

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 3dc73b35884..59d0a3f76aa 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,10 @@
+2018-12-11  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_util.adb (Get_Actual_Subtype): Function can return type
+	mark.
+	(Get_Cursor_Type): Improve recovery and error message on a
+	misplaced First aspect for an iterable type.
+
 2018-12-11  Hristian Kirtchev  <kirtchev@adacore.com>
 
 	* checks.adb: Add with and use clauses for Sem_Mech.
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 4f8bec38aaf..afb0b71341f 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -9049,6 +9049,13 @@ package body Sem_Util is
 
          else
             Decl := Build_Actual_Subtype (Typ, N);
+
+            --  The call may yield a declaration, or just return the entity
+
+            if Decl = Typ then
+               return Typ;
+            end if;
+
             Atyp := Defining_Identifier (Decl);
 
             --  If Build_Actual_Subtype generated a new declaration then use it
@@ -9162,6 +9169,9 @@ package body Sem_Util is
       if First_Op = Any_Id then
          Error_Msg_N ("aspect Iterable must specify First operation", Aspect);
          return Any_Type;
+
+      elsif not Analyzed (First_Op) then
+         Analyze (First_Op);
       end if;
 
       Cursor := Any_Type;
@@ -9195,7 +9205,8 @@ package body Sem_Util is
 
       if Cursor = Any_Type then
          Error_Msg_N
-           ("No legal primitive operation First for Iterable type", Aspect);
+           ("primitive operation for Iterable type must appear "
+             & "in the same list of declarations as the type", Aspect);
       end if;
 
       return Cursor;
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 02337b805d7..61f1e31f9a1 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2018-12-11  Ed Schonberg  <schonberg@adacore.com>
+
+	* gnat.dg/iter4.adb: New testcase.
+
 2018-12-11  Hristian Kirtchev  <kirtchev@adacore.com>
 
 	* gnat.dg/valid4.adb, gnat.dg/valid4_pkg.adb,
diff --git a/gcc/testsuite/gnat.dg/iter4.adb b/gcc/testsuite/gnat.dg/iter4.adb
new file mode 100644
index 00000000000..27293ebd8c9
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/iter4.adb
@@ -0,0 +1,36 @@
+--  { dg-do compile }
+
+procedure Iter4 is
+   package Root is
+      type Result is tagged record
+         B : Boolean;
+      end record;
+
+      type T is tagged record
+         I : Integer;
+      end record
+      with Iterable => (First       => Pkg.First, --  { dg-error "primitive operation for Iterable type must appear in the same list of declarations as the type" }
+                        Next        => Pkg.Next,
+                        Has_Element => Pkg.Has_Element,
+                        Element     => Pkg.Element);
+
+      package Pkg is
+         function First (Dummy : T) return Natural is (0);
+         function Next (Dummy : T; Cursor : Natural) return Natural is
+           (Cursor + 1);
+         function Has_Element (Value : T; Cursor : Natural) return Boolean is
+           (Cursor <= Value.I);
+         function Element (Dummy : T; Cursor : Natural) return Result is
+           ((B => Cursor mod 2 = 0));
+      end Pkg;
+   end Root;
+
+   package Derived is
+      type T is new Root.T with record
+         C : Character;
+      end record;
+   end Derived;
+
+begin
+   null;
+end;