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 c75cfc174d2107e0b7b8515806b63d1d734a6455..92c1ef0bb79e58a39ed9d6304e62352175c1b0a6 100644 (file)
--- 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
+      --          <original loop statements>
+      --          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 e9c6ef6b7d7be2d7aa2625ceae018561f5c2e0d3..d84e8aeb29f36ae30d782c74f73c3eb32e3677ef 100644 (file)
--- 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 a9a288bd45f3e17b4f779b6bb06e17ac9abe61d8..6f53a8b01c316d2d4f28d0696ba9c30360073511 100644 (file)
--- 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 6f28f1cc4cd425805d208c048d88a68486bbb8b6..d66dd90c2ff340e3a423c9c0297b8d278dc256e7 100644 (file)
--- 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 70c5941e3bb37afdd09989b33c962ddfd52f67cd..c9948d926a07392e9385675cec8d05142e501e5e 100644 (file)
--- 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 + $;