From 8b9bbdc362efe420633e43850092d01f467aa6d8 Mon Sep 17 00:00:00 2001 From: Piotr Trojanek Date: Fri, 5 Aug 2022 16:31:19 +0200 Subject: [PATCH] [Ada] Improve detection of illegal Iterable aspects 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. 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. --- .../implementation_defined_aspects.rst | 16 +++-- gcc/ada/exp_attr.adb | 5 +- gcc/ada/gnat_rm.texi | 16 +++-- gcc/ada/gnat_ugn.texi | 2 +- gcc/ada/sem_ch13.adb | 71 ++++++++++++------- gcc/ada/sem_util.adb | 2 +- 6 files changed, 71 insertions(+), 41 deletions(-) diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst b/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst index 6ef00c25ab61..4541f2bc70b2 100644 --- 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 index 52d47d98ae66..d28bb0864150 100644 --- 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 index fe2f434ca4df..e63c757ac0ff 100644 --- 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 index e1a4192a9589..9865ef64fc1c 100644 --- 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 index 4d1644be0492..940379812306 100644 --- 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 index ecfb49a06a85..d0a4a0720da6 100644 --- 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); -- 2.47.2