[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 3dc73b3588462f9a5fae5d8d3209a485aa2b8928..59d0a3f76aaabbf15f36b11958a8cefabf93b696 100644 (file)
--- 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 4f8bec38aaf306f39ebf4ff625df8479df785b87..afb0b71341f62d25df64be55824dc47da530f2d6 100644 (file)
--- 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 02337b805d7386387809b80350c1b6c85979951a..61f1e31f9a10554a3540867a2bbeb86678c91f69 100644 (file)
--- 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 (file)
index 0000000..27293eb
--- /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;