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);