From: Claire Dross Date: Fri, 17 Apr 2026 15:17:13 +0000 (+0200) Subject: ada: Support Constant_Reference in Iterable aspect X-Git-Url: http://git.ipfire.org/gitweb/index.cgi?a=commitdiff_plain;h=6d73ecc2f312fb4fb0bb4fdffbc0e42ff2d6f342;p=thirdparty%2Fgcc.git ada: Support Constant_Reference in Iterable aspect A Constant_Reference function returning an anonymous access-to-constant type can be supplied instead of the Element primitive to allow iteration over elements of a container. gcc/ada/ChangeLog: * exp_ch5.adb (Expand_Formal_Container_Element_Loop): Use Constant_Reference instead of Element if necessary. * sem_ch13.adb (Resolve_Iterable_Operation): Check Constant_Reference. (Validate_Iterable_Aspect): Handle Constant_Reference if supplied. * sem_ch5.adb (Analyze_Loop_Parameter_Specification): Iteration over elements of a container is allowed if Constant_Reference is supplied. * sem_util.adb (Get_Iterable_Type_Primitive): Fix assertion. * snames.ads-tmpl (Name_Constant_Reference): New name. --- diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index c75cfc174d2..92c1ef0bb79 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -4650,17 +4650,21 @@ package body Exp_Ch5 is Element_Op : constant Entity_Id := Get_Iterable_Type_Primitive (Container_Typ, Name_Element); + Constant_Reference_Op : constant Entity_Id := + Get_Iterable_Type_Primitive + (Container_Typ, Name_Constant_Reference); + Advance : Node_Id; Init : Node_Id; New_Loop : Node_Id; Block : Node_Id; begin - -- For an element iterator, the Element aspect must be present, - -- (this is checked during analysis). + -- For an element iterator, either the Element or the Constant_Reference + -- aspect must be present, (this is checked during analysis). - -- We create a block to hold a variable declaration initialized with - -- a call to Element, and generate: + -- If Element is present, we create a block to hold a variable + -- declaration initialized with a call to Element, and generate: -- Cursor : Cursor_Type := First (Container); -- while Has_Element (Cursor, Container) loop @@ -4672,6 +4676,20 @@ package body Exp_Ch5 is -- end; -- end loop; + -- If Constant_Reference is present, we introduce a constant and a + -- renaming, and generate: + + -- Cursor : Cursor_Type := First (Container); + -- while Has_Element (Cursor, Container) loop + -- declare + -- Elmt : Element_Type renames + -- Constant_Reference (Container, Cursor).all; + -- begin + -- + -- Cursor := Next (Container, Cursor); + -- end; + -- end loop; + Build_Formal_Container_Iteration (N, Container, Cursor, Init, Advance, New_Loop); @@ -4686,17 +4704,36 @@ package body Exp_Ch5 is -- Declaration for Element - Elmt_Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Element, - Object_Definition => New_Occurrence_Of (Etype (Element_Op), Loc)); - - Set_Expression (Elmt_Decl, - Make_Function_Call (Loc, - Name => New_Occurrence_Of (Element_Op, Loc), - Parameter_Associations => New_List ( - Convert_To_Iterable_Type (Container, Loc), - New_Occurrence_Of (Cursor, Loc)))); + if Present (Element_Op) then + Elmt_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Element, + Object_Definition => + New_Occurrence_Of (Etype (Element_Op), Loc)); + + Set_Expression (Elmt_Decl, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Element_Op, Loc), + Parameter_Associations => New_List ( + Convert_To_Iterable_Type (Container, Loc), + New_Occurrence_Of (Cursor, Loc)))); + else + Elmt_Decl := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Element, + Subtype_Mark => + New_Occurrence_Of + (Directly_Designated_Type + (Etype (Constant_Reference_Op)), Loc), + Name => + Make_Explicit_Dereference (Loc, + Prefix => Make_Function_Call (Loc, + Name => + New_Occurrence_Of (Constant_Reference_Op, Loc), + Parameter_Associations => New_List ( + Convert_To_Iterable_Type (Container, Loc), + New_Occurrence_Of (Cursor, Loc))))); + end if; Block := Make_Block_Statement (Loc, diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index e9c6ef6b7d7..d84e8aeb29f 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -18094,6 +18094,26 @@ package body Sem_Ch13 is Error_Msg_N ("no match for Element iterable primitive", N); end if; + elsif Nam = Name_Constant_Reference then + + -- Constant_Reference (Container, Cursor) => + -- not null access constant Element_Type; + + if No (F2) + or else Etype (F2) /= Cursor + or else Present (Next_Formal (F2)) + or else not (Is_Anonymous_Access_Type (Etype (Ent)) + and then Is_Access_Constant (Etype (Ent))) + then + Error_Msg_N + ("no match for Constant_Reference iterable primitive", N); + + elsif not Can_Never_Be_Null (Etype (Ent)) then + Error_Msg_N + ("return type of primitive for Constant_Reference must have " + & "null exclusion", N); + end if; + else raise Program_Error; end if; @@ -18159,6 +18179,26 @@ package body Sem_Ch13 is Set_Entity (N, It.Nam); exit; end if; + + elsif Nam = Name_Constant_Reference then + F2 := Next_Formal (F1); + + if Present (F2) + and then No (Next_Formal (F2)) + and then Etype (F2) = Cursor + and then Is_Anonymous_Access_Type (Etype (It.Nam)) + and then Is_Access_Constant (Etype (It.Nam)) + then + Set_Entity (N, It.Nam); + + if not Can_Never_Be_Null (Etype (It.Nam)) then + Error_Msg_N + ("return type of primitive for " + & "Constant_Reference must have null exclusion", + N); + end if; + exit; + end if; end if; end if; @@ -19364,11 +19404,12 @@ package body Sem_Ch13 is Prim : Node_Id; Cursor : 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; + 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; + Constant_Reference_Id : Entity_Id := Empty; begin if Nkind (Aggr) /= N_Aggregate then @@ -19425,6 +19466,11 @@ package body Sem_Ch13 is Resolve_Iterable_Operation (Expr, Cursor, Typ, Name_Element); Element_Id := Entity (Expr); + elsif Chars (Prim) = Name_Constant_Reference then + Resolve_Iterable_Operation + (Expr, Cursor, Typ, Name_Constant_Reference); + Constant_Reference_Id := Entity (Expr); + else Error_Msg_N ("invalid name for iterable function", Prim); end if; @@ -19441,7 +19487,14 @@ package body Sem_Ch13 is elsif No (Has_Element_Id) then Error_Msg_N ("match for Has_Element primitive not found", ASN); - elsif No (Element_Id) or else No (Last_Id) then + elsif Present (Element_Id) and then Present (Constant_Reference_Id) then + Error_Msg_N ("cannot provide both Element and Constant_Reference " + & "primitives", ASN); + + elsif No (Element_Id) + or else No (Constant_Reference_Id) + or else No (Last_Id) + then null; -- optional end if; end Validate_Iterable_Aspect; diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index a9a288bd45f..6f53a8b01c3 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -2724,15 +2724,25 @@ package body Sem_Ch5 is if Of_Present (N) then if Has_Aspect (Typ, Aspect_Iterable) then declare - Elt : constant Entity_Id := + Elt : constant Entity_Id := Get_Iterable_Type_Primitive (Typ, Name_Element); + Cst_Ref : constant Entity_Id := + Get_Iterable_Type_Primitive + (Typ, Name_Constant_Reference); begin - if No (Elt) then - Error_Msg_N - ("missing Element primitive for iteration", N); - else + if Present (Elt) then Set_Etype (Def_Id, Etype (Elt)); Check_Reverse_Iteration (Typ); + + elsif Present (Cst_Ref) then + Set_Etype + (Def_Id, Directly_Designated_Type (Etype (Cst_Ref))); + Check_Reverse_Iteration (Typ); + + else + Error_Msg_N + ("missing Element or Constant_Reference primitive for " + & "iteration", N); end if; end; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 6f28f1cc4cd..d66dd90c2ff 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -11030,7 +11030,8 @@ package body Sem_Util is pragma Assert (Is_Type (Typ) and then - Nam in Name_Element + Nam in Name_Constant_Reference + | Name_Element | Name_First | Name_Has_Element | Name_Last diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 70c5941e3bb..c9948d926a0 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -1413,6 +1413,7 @@ package Snames is -- Names used to implement iterators over predefined containers + Name_Constant_Reference : constant Name_Id := N + $; Name_Cursor : constant Name_Id := N + $; Name_Element : constant Name_Id := N + $; Name_Has_Element : constant Name_Id := N + $;