public inbox for gcc-patches@gcc.gnu.org
 help / color / mirror / Atom feed
* [Ada] Improve detection of illegal Iterable aspects
@ 2022-09-06  7:15 Marc Poulhiès
  0 siblings, 0 replies; only message in thread
From: Marc Poulhiès @ 2022-09-06  7:15 UTC (permalink / raw)
  To: gcc-patches; +Cc: Piotr Trojanek

[-- Attachment #1: Type: text/plain, Size: 995 bytes --]

Handling of aspect Iterable was lacking guards against illegal code, so
the compiler either crashed or emitted cryptic errors while expanding
loops that rely on this aspect.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

	* doc/gnat_rm/implementation_defined_aspects.rst
	(Aspect Iterable): Include Last and Previous primitives in
	syntactic and semantic description.
	* exp_attr.adb
	(Expand_N_Attribute_Reference): Don't expect attributes like
	Iterable that can only appear in attribute definition clauses.
	* sem_ch13.adb
	(Analyze_Attribute_Definition_Clause): Prevent crash on
	non-aggregate Iterable attribute; improve basic diagnosis of
	attribute values.
	(Resolve_Iterable_Operation): Improve checks for illegal
	primitives in aspect Iterable, e.g. with wrong number of formal
	parameters.
	(Validate_Iterable_Aspect): Prevent crashes on syntactically
	illegal aspect expression.
	* sem_util.adb
	(Get_Cursor_Type): Fix style.
	* gnat_ugn.texi, gnat_rm.texi: Regenerate.

[-- Attachment #2: patch.diff --]
[-- Type: text/x-diff, Size: 10192 bytes --]

diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst b/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst
--- a/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst
+++ b/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst
@@ -317,23 +317,27 @@ The following is a typical example of use:
   type List is private with
       Iterable => (First       => First_Cursor,
                    Next        => Advance,
-                   Has_Element => Cursor_Has_Element,
-                  [Element     => Get_Element]);
+                   Has_Element => Cursor_Has_Element
+                 [,Element     => Get_Element]
+                 [,Last        => Last_Cursor]
+                 [,Previous    => Retreat]);
 
-* The value denoted by ``First`` must denote a primitive operation of the
-  container type that returns a ``Cursor``, which must a be a type declared in
+* The values of ``First`` and ``Last`` are primitive operations of the
+  container type that return a ``Cursor``, which must be a type declared in
   the container package or visible from it. For example:
 
 .. code-block:: ada
 
   function First_Cursor (Cont : Container) return Cursor;
+  function Last_Cursor  (Cont : Container) return Cursor;
 
-* The value of ``Next`` is a primitive operation of the container type that takes
-  both a container and a cursor and yields a cursor. For example:
+* The values of ``Next`` and ``Previous`` are primitive operations of the container type that take
+  both a container and a cursor and yield a cursor. For example:
 
 .. code-block:: ada
 
   function Advance (Cont : Container; Position : Cursor) return Cursor;
+  function Retreat (Cont : Container; Position : Cursor) return Cursor;
 
 * The value of ``Has_Element`` is a primitive operation of the container type
   that takes both a container and a cursor and yields a boolean. For example:


diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -2079,7 +2079,8 @@ package body Exp_Attr is
 
       case Id is
 
-      --  Attributes related to Ada 2012 iterators
+      --  Attributes related to Ada 2012 iterators. They are only allowed in
+      --  attribute definition clauses and should never be expanded.
 
       when Attribute_Constant_Indexing
          | Attribute_Default_Iterator
@@ -2088,7 +2089,7 @@ package body Exp_Attr is
          | Attribute_Iterator_Element
          | Attribute_Variable_Indexing
       =>
-         null;
+         raise Program_Error;
 
       --  Internal attributes used to deal with Ada 2012 delayed aspects. These
       --  were already rejected by the parser. Thus they shouldn't appear here.


diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi
--- a/gcc/ada/gnat_rm.texi
+++ b/gcc/ada/gnat_rm.texi
@@ -9774,33 +9774,37 @@ The following is a typical example of use:
 type List is private with
     Iterable => (First       => First_Cursor,
                  Next        => Advance,
-                 Has_Element => Cursor_Has_Element,
-                [Element     => Get_Element]);
+                 Has_Element => Cursor_Has_Element
+               [,Element     => Get_Element]
+               [,Last        => Last_Cursor]
+               [,Previous    => Retreat]);
 @end example
 
 
 @itemize *
 
 @item 
-The value denoted by @code{First} must denote a primitive operation of the
-container type that returns a @code{Cursor}, which must a be a type declared in
+The values of @code{First} and @code{Last} are primitive operations of the
+container type that return a @code{Cursor}, which must be a type declared in
 the container package or visible from it. For example:
 @end itemize
 
 @example
 function First_Cursor (Cont : Container) return Cursor;
+function Last_Cursor  (Cont : Container) return Cursor;
 @end example
 
 
 @itemize *
 
 @item 
-The value of @code{Next} is a primitive operation of the container type that takes
-both a container and a cursor and yields a cursor. For example:
+The values of @code{Next} and @code{Previous} are primitive operations of the container type that take
+both a container and a cursor and yield a cursor. For example:
 @end itemize
 
 @example
 function Advance (Cont : Container; Position : Cursor) return Cursor;
+function Retreat (Cont : Container; Position : Cursor) return Cursor;
 @end example
 
 


diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi
--- a/gcc/ada/gnat_ugn.texi
+++ b/gcc/ada/gnat_ugn.texi
@@ -29308,8 +29308,8 @@ to permit their use in free software.
 
 @printindex ge
 
-@anchor{gnat_ugn/gnat_utility_programs switches-related-to-project-files}@w{                              }
 @anchor{cf}@w{                              }
+@anchor{gnat_ugn/gnat_utility_programs switches-related-to-project-files}@w{                              }
 
 @c %**end of body
 @bye


diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -6959,6 +6959,7 @@ package body Sem_Ch13 is
 
             if Nkind (Expr) /= N_Aggregate then
                Error_Msg_N ("aspect Iterable must be an aggregate", Expr);
+               return;
             end if;
 
             declare
@@ -6969,7 +6970,9 @@ package body Sem_Ch13 is
                while Present (Assoc) loop
                   Analyze (Expression (Assoc));
 
-                  if not Is_Entity_Name (Expression (Assoc)) then
+                  if not Is_Entity_Name (Expression (Assoc))
+                    or else Ekind (Entity (Expression (Assoc))) /= E_Function
+                  then
                      Error_Msg_N ("value must be a function", Assoc);
                   end if;
 
@@ -15875,22 +15878,34 @@ package body Sem_Ch13 is
 
          Ent := Entity (N);
          F1  := First_Formal (Ent);
+         F2  := Next_Formal (F1);
 
-         if Nam in Name_First | Name_Last then
+         if Nam = Name_First then
 
-            --  First or Last (Container) => Cursor
+            --  First (Container) => Cursor
 
             if Etype (Ent) /= Cursor then
                Error_Msg_N ("primitive for First must yield a cursor", N);
+            elsif Present (F2) then
+               Error_Msg_N ("no match for First iterable primitive", N);
+            end if;
+
+         elsif Nam = Name_Last then
+
+            --  Last (Container) => Cursor
+
+            if Etype (Ent) /= Cursor then
+               Error_Msg_N ("primitive for Last must yield a cursor", N);
+            elsif Present (F2) then
+               Error_Msg_N ("no match for Last iterable primitive", N);
             end if;
 
          elsif Nam = Name_Next then
 
             --  Next (Container, Cursor) => Cursor
 
-            F2 := Next_Formal (F1);
-
-            if Etype (F2) /= Cursor
+            if No (F2)
+              or else Etype (F2) /= Cursor
               or else Etype (Ent) /= Cursor
               or else Present (Next_Formal (F2))
             then
@@ -15901,9 +15916,8 @@ package body Sem_Ch13 is
 
             --  Previous (Container, Cursor) => Cursor
 
-            F2 := Next_Formal (F1);
-
-            if Etype (F2) /= Cursor
+            if No (F2)
+              or else Etype (F2) /= Cursor
               or else Etype (Ent) /= Cursor
               or else Present (Next_Formal (F2))
             then
@@ -15914,9 +15928,8 @@ package body Sem_Ch13 is
 
             --  Has_Element (Container, Cursor) => Boolean
 
-            F2 := Next_Formal (F1);
-
-            if Etype (F2) /= Cursor
+            if No (F2)
+              or else Etype (F2) /= Cursor
               or else Etype (Ent) /= Standard_Boolean
               or else Present (Next_Formal (F2))
             then
@@ -15924,7 +15937,8 @@ package body Sem_Ch13 is
             end if;
 
          elsif Nam = Name_Element then
-            F2 := Next_Formal (F1);
+
+            --  Element (Container, Cursor) => Element_Type;
 
             if No (F2)
               or else Etype (F2) /= Cursor
@@ -17084,34 +17098,41 @@ package body Sem_Ch13 is
    ------------------------------
 
    procedure Validate_Iterable_Aspect (Typ : Entity_Id; ASN : Node_Id) is
+      Aggr  : constant Node_Id := Expression (ASN);
       Assoc : Node_Id;
       Expr  : Node_Id;
 
       Prim   : Node_Id;
-      Cursor : constant Entity_Id := Get_Cursor_Type (ASN, Typ);
+      Cursor : Entity_Id;
 
-      First_Id       : Entity_Id;
-      Last_Id        : Entity_Id;
-      Next_Id        : Entity_Id;
-      Has_Element_Id : Entity_Id;
-      Element_Id     : Entity_Id;
+      First_Id       : Entity_Id := Empty;
+      Last_Id        : Entity_Id := Empty;
+      Next_Id        : Entity_Id := Empty;
+      Has_Element_Id : Entity_Id := Empty;
+      Element_Id     : Entity_Id := Empty;
 
    begin
+      if Nkind (Aggr) /= N_Aggregate then
+         Error_Msg_N ("aspect Iterable must be an aggregate", Aggr);
+         return;
+      end if;
+
+      Cursor := Get_Cursor_Type (ASN, Typ);
+
       --  If previous error aspect is unusable
 
       if Cursor = Any_Type then
          return;
       end if;
 
-      First_Id       := Empty;
-      Last_Id        := Empty;
-      Next_Id        := Empty;
-      Has_Element_Id := Empty;
-      Element_Id     := Empty;
+      if not Is_Empty_List (Expressions (Aggr)) then
+         Error_Msg_N
+           ("illegal positional association", First (Expressions (Aggr)));
+      end if;
 
       --  Each expression must resolve to a function with the proper signature
 
-      Assoc := First (Component_Associations (Expression (ASN)));
+      Assoc := First (Component_Associations (Aggr));
       while Present (Assoc) loop
          Expr := Expression (Assoc);
          Analyze (Expr);


diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -10894,7 +10894,7 @@ package body Sem_Util is
       --  First.
 
       Assoc := First (Component_Associations (Expression (Aspect)));
-      First_Op  := Any_Id;
+      First_Op := Any_Id;
       while Present (Assoc) loop
          if Chars (First (Choices (Assoc))) = Name_First then
             First_Op := Expression (Assoc);



^ permalink raw reply	[flat|nested] only message in thread

only message in thread, other threads:[~2022-09-06  7:15 UTC | newest]

Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2022-09-06  7:15 [Ada] Improve detection of illegal Iterable aspects Marc Poulhiès

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).