* [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).