[multiple changes]

2011-08-05  Bob Duff  <duff@adacore.com>

	* sinfo.ads, sinfo.adb (Subpool_Handle_Name): New attribute for
	subpools.
	* par-ch4.adb (P_Allocator): Parse new subpool specification syntax.

2011-08-05  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch4.adb (Try_Container_Indexing): New procedure to implement the
	general indexing aspects of Ada2012. Called when analyzing indexed
	components when other interpretations fail.
	* sem_ch8.adb (Find_Direct_Name): check for implicit dereference only
	in an expression context where overloading is meaningful. This excludes
	the occurrence in an aspect specification (efficiency only).
	* sem_attr.adb (Analyze_Attribute): indicate that the attributes
	related to iterators can be set by an attribute specification, but
	cannot be queried.
	* sem_ch13.adb (Analyze_Aspect_Specifications): handle
	Constant_Indexing and Variable_Indexing.
	(Check_Indexing_Functions): New procedure to perform legality checks.
	Additional semantic checks at end of declarations.

From-SVN: r177446

gcc/ada/ChangeLog

+2011-08-05  Bob Duff  <duff@adacore.com>
+
+	* sinfo.ads, sinfo.adb (Subpool_Handle_Name): New attribute for
+	subpools.
+	* par-ch4.adb (P_Allocator): Parse new subpool specification syntax.
+
+2011-08-05  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch4.adb (Try_Container_Indexing): New procedure to implement the
+	general indexing aspects of Ada2012. Called when analyzing indexed
+	components when other interpretations fail.
+	* sem_ch8.adb (Find_Direct_Name): check for implicit dereference only
+	in an expression context where overloading is meaningful. This excludes
+	the occurrence in an aspect specification (efficiency only).
+	* sem_attr.adb (Analyze_Attribute): indicate that the attributes
+	related to iterators can be set by an attribute specification, but
+	cannot be queried.
+	* sem_ch13.adb (Analyze_Aspect_Specifications): handle
+	Constant_Indexing and Variable_Indexing.
+	(Check_Indexing_Functions): New procedure to perform legality checks.
+	Additional semantic checks at end of declarations.
+
 2011-08-05  Sergey Rybin  <rybin@adacore.com>
 
 	* tree_io.ads: Update ASIS_Version_Number because of the change of the

gcc/ada/par-ch4.adb

@@ -2810,7 +2810,10 @@ package body Ch4 is
    --------------------
 
    --  ALLOCATOR ::=
-   --    new [NULL_EXCLUSION] SUBTYPE_INDICATION | new QUALIFIED_EXPRESSION
+   --      new [SUBPOOL_SPECIFICATION] SUBTYPE_INDICATION
+   --    | new [SUBPOOL_SPECIFICATION] QUALIFIED_EXPRESSION
+   --
+   --  SUBPOOL_SPECIFICATION ::= (subpool_handle_NAME)
 
    --  The caller has checked that the initial token is NEW
 
@@ -2825,8 +2828,25 @@ package body Ch4 is
       Alloc_Node := New_Node (N_Allocator, Token_Ptr);
       T_New;
 
+      --  Scan subpool_specification if present (Ada 2012 (AI05-0111-3))
+
       --  Scan Null_Exclusion if present (Ada 2005 (AI-231))
 
+      if Token = Tok_Left_Paren then
+         Scan; -- past (
+         Set_Subpool_Handle_Name (Alloc_Node, P_Name);
+         T_Right_Paren;
+
+         if Ada_Version < Ada_2012 then
+            Error_Msg_N
+              ("|subpool specification is an Ada 2012 feature",
+               Subpool_Handle_Name (Alloc_Node));
+            Error_Msg_N
+              ("\|unit must be compiled with -gnat2012 switch",
+               Subpool_Handle_Name (Alloc_Node));
+         end if;
+      end if;
+
       Null_Exclusion_Present := P_Null_Exclusion;
       Set_Null_Exclusion_Present (Alloc_Node, Null_Exclusion_Present);
       Type_Node := P_Subtype_Mark_Resync;

gcc/ada/sem_attr.adb

@@ -2110,13 +2110,15 @@ package body Sem_Attr is
 
       case Attr_Id is
 
-         --  Attributes related to Ada2012 iterators (placeholder ???)
-
-         when Attribute_Constant_Indexing    => null;
-         when Attribute_Default_Iterator     => null;
-         when Attribute_Implicit_Dereference => null;
-         when Attribute_Iterator_Element     => null;
-         when Attribute_Variable_Indexing    => null;
+         --  Attributes related to Ada2012 iterators. Attribute specifications
+         --  exist for these, but they cannot be queried.
+
+         when Attribute_Constant_Indexing    |
+              Attribute_Default_Iterator     |
+              Attribute_Implicit_Dereference |
+              Attribute_Iterator_Element     |
+              Attribute_Variable_Indexing    =>
+            Error_Msg_N ("illegal attribute", N);
 
       ------------------
       -- Abort_Signal --

gcc/ada/sem_ch13.adb

@@ -946,13 +946,36 @@ package body Sem_Ch13 is
 
                   Delay_Required := False;
 
-               --  Aspects related to container iterators (fill in later???)
+               --  Aspects related to container iterators. These aspects denote
+               --  subprograms, and thus must be delayed.
 
                when Aspect_Constant_Indexing    |
-                    Aspect_Default_Iterator     |
-                    Aspect_Iterator_Element     |
                     Aspect_Variable_Indexing    =>
-                  null;
+
+                  if not Is_Type (E) or else not Is_Tagged_Type (E) then
+                     Error_Msg_N ("indexing applies to a tagged type", N);
+                  end if;
+
+                  Aitem :=
+                    Make_Attribute_Definition_Clause (Loc,
+                      Name       => Ent,
+                      Chars      => Chars (Id),
+                      Expression => Relocate_Node (Expr));
+
+                  Delay_Required := True;
+                  Set_Is_Delayed_Aspect (Aspect);
+
+               when Aspect_Default_Iterator     |
+                    Aspect_Iterator_Element     =>
+
+                  Aitem :=
+                    Make_Attribute_Definition_Clause (Loc,
+                      Name       => Ent,
+                      Chars      => Chars (Id),
+                      Expression => Relocate_Node (Expr));
+
+                  Delay_Required := True;
+                  Set_Is_Delayed_Aspect (Aspect);
 
                when Aspect_Implicit_Dereference =>
                   if not Is_Type (E)
@@ -1511,6 +1534,11 @@ package body Sem_Ch13 is
       --  and if so gives an error message. If there is a duplicate, True is
       --  returned, otherwise if there is no error, False is returned.
 
+      procedure Check_Indexing_Functions;
+      --  Check that the function in Constant_Indexing or Variable_Indexing
+      --  attribute has the proper type structure. If the name is overloaded,
+      --  check that all interpretations are legal.
+
       -----------------------------------
       -- Analyze_Stream_TSS_Definition --
       -----------------------------------
@@ -1648,6 +1676,89 @@ package body Sem_Ch13 is
          end if;
       end Analyze_Stream_TSS_Definition;
 
+      ------------------------------
+      -- Check_Indexing_Functions --
+      ------------------------------
+
+      procedure Check_Indexing_Functions is
+         Ctrl : Entity_Id;
+
+         procedure Check_One_Function (Subp : Entity_Id);
+         --  Check one possible interpretation
+
+         ------------------------
+         -- Check_One_Function --
+         ------------------------
+
+         procedure Check_One_Function (Subp : Entity_Id) is
+         begin
+            if Ekind (Subp) /= E_Function then
+               Error_Msg_N ("indexing requires a function", Subp);
+            end if;
+
+            if No (First_Formal (Subp)) then
+               Error_Msg_N
+                 ("function for indexing must have parameters", Subp);
+            else
+               Ctrl := Etype (First_Formal (Subp));
+            end if;
+
+            if Ctrl = Ent
+              or else Ctrl = Class_Wide_Type (Ent)
+              or else
+                (Ekind (Ctrl) = E_Anonymous_Access_Type
+                  and then
+                    (Designated_Type (Ctrl) = Ent
+                      or else Designated_Type (Ctrl) = Class_Wide_Type (Ent)))
+            then
+               null;
+
+            else
+               Error_Msg_N ("indexing function must apply to type&", Subp);
+            end if;
+
+            if No (Next_Formal (First_Formal (Subp))) then
+               Error_Msg_N
+                 ("function for indexing must have two parameters", Subp);
+            end if;
+
+            if not Has_Implicit_Dereference (Etype (Subp)) then
+               Error_Msg_N
+                 ("function for indexing must return a reference type", Subp);
+            end if;
+         end Check_One_Function;
+
+      --  Start of processing for Check_Indexing_Functions
+
+      begin
+         Analyze (Expr);
+
+         if not Is_Overloaded (Expr) then
+            Check_One_Function (Entity (Expr));
+
+         else
+            declare
+               I : Interp_Index;
+               It : Interp;
+
+            begin
+               Get_First_Interp (Expr, I, It);
+               while Present (It.Nam) loop
+
+                  --  Note that analysis will have added the interpretation
+                  --  that corresponds to the dereference. We only check the
+                  --  subprogram itself.
+
+                  if Is_Overloadable (It.Nam) then
+                     Check_One_Function (It.Nam);
+                  end if;
+
+                  Get_Next_Interp (I, It);
+               end loop;
+            end;
+         end if;
+      end Check_Indexing_Functions;
+
       ----------------------
       -- Duplicate_Clause --
       ----------------------
@@ -2267,6 +2378,13 @@ package body Sem_Ch13 is
             end if;
          end Component_Size_Case;
 
+         -----------------------
+         -- Constant_Indexing --
+         -----------------------
+
+         when Attribute_Constant_Indexing =>
+            Check_Indexing_Functions;
+
          ------------------
          -- External_Tag --
          ------------------
@@ -2845,6 +2963,13 @@ package body Sem_Ch13 is
             end if;
          end Value_Size;
 
+         -----------------------
+         -- Variable_Indexing --
+         -----------------------
+
+         when Attribute_Variable_Indexing =>
+            Check_Indexing_Functions;
+
          -----------
          -- Write --
          -----------
@@ -5381,6 +5506,13 @@ package body Sem_Ch13 is
          Analyze (End_Decl_Expr);
          Err := Entity (End_Decl_Expr) /= Entity (Freeze_Expr);
 
+      elsif A_Id = Aspect_Variable_Indexing or else
+            A_Id = Aspect_Constant_Indexing
+      then
+         Analyze (End_Decl_Expr);
+         Analyze (Aspect_Rep_Item (ASN));
+         Err := Entity (End_Decl_Expr) /= Entity (Freeze_Expr);
+
       --  All other cases
 
       else
@@ -5485,15 +5617,6 @@ package body Sem_Ch13 is
               Aspect_Value_Size     =>
             T := Any_Integer;
 
-         --  Following to be done later ???
-
-         when Aspect_Constant_Indexing    |
-              Aspect_Default_Iterator     |
-              Aspect_Iterator_Element     |
-              Aspect_Implicit_Dereference |
-              Aspect_Variable_Indexing    =>
-            null;
-
          --  Stream attribute. Special case, the expression is just an entity
          --  that does not need any resolution, so just analyze.
 
@@ -5504,6 +5627,17 @@ package body Sem_Ch13 is
             Analyze (Expression (ASN));
             return;
 
+         --  Same for Iterator aspects, where the expression is a function
+         --  name. Legality rules are checked separately.
+
+         when Aspect_Constant_Indexing    |
+              Aspect_Default_Iterator     |
+              Aspect_Iterator_Element     |
+              Aspect_Implicit_Dereference |
+              Aspect_Variable_Indexing    =>
+            Analyze (Expression (ASN));
+            return;
+
          --  Suppress/Unsuppress/Warnings should never be delayed
 
          when Aspect_Suppress   |

gcc/ada/sem_ch4.adb

@@ -23,6 +23,7 @@
 --                                                                          --
 ------------------------------------------------------------------------------
 
+with Aspects;  use Aspects;
 with Atree;    use Atree;
 with Debug;    use Debug;
 with Einfo;    use Einfo;
@@ -248,6 +249,12 @@ package body Sem_Ch4 is
    --  Ada 2005: implementation of AI-310. An abstract non-dispatching
    --  operation is not a candidate interpretation.
 
+   function Try_Container_Indexing
+     (N      : Node_Id;
+      Prefix : Node_Id;
+      Expr   : Node_Id) return Boolean;
+   --  AI05-0139: Generalized indexing to support iterators over containers
+
    function Try_Indexed_Call
      (N          : Node_Id;
       Nam        : Entity_Id;
@@ -2032,6 +2039,9 @@ package body Sem_Ch4 is
             then
                return;
 
+            elsif Try_Container_Indexing (N, P, Exp) then
+               return;
+
             elsif Array_Type = Any_Type then
                Set_Etype (N, Any_Type);
 
@@ -6270,6 +6280,130 @@ package body Sem_Ch4 is
       end if;
    end Remove_Abstract_Operations;
 
+   ----------------------------
+   -- Try_Container_Indexing --
+   ----------------------------
+
+   function Try_Container_Indexing
+     (N      : Node_Id;
+      Prefix : Node_Id;
+      Expr   : Node_Id) return Boolean
+   is
+      Loc       : constant Source_Ptr := Sloc (N);
+      Disc      : Entity_Id;
+      Func      : Entity_Id;
+      Func_Name : Node_Id;
+      Indexing  : Node_Id;
+      Is_Var    : Boolean;
+      Ritem     : Node_Id;
+
+   begin
+
+      --  Check whether type has a specified indexing aspect.
+
+      Func_Name := Empty;
+      Is_Var := False;
+      Ritem := First_Rep_Item (Etype (Prefix));
+
+      while Present (Ritem) loop
+         if Nkind (Ritem) = N_Aspect_Specification then
+
+            --  Prefer Variable_Indexing, but will settle for Constant.
+
+            if Get_Aspect_Id (Chars (Identifier (Ritem))) =
+              Aspect_Constant_Indexing
+            then
+               Func_Name := Expression (Ritem);
+
+            elsif Get_Aspect_Id (Chars (Identifier (Ritem))) =
+              Aspect_Variable_Indexing
+            then
+               Func_Name :=  Expression (Ritem);
+               Is_Var := True;
+               exit;
+            end if;
+         end if;
+         Next_Rep_Item (Ritem);
+      end loop;
+
+      --  If aspect does not exist the expression is illegal. Error is
+      --  diagnosed in caller.
+
+      if No (Func_Name) then
+         return False;
+      end if;
+
+      if Is_Var
+        and then not Is_Variable (Prefix)
+      then
+         Error_Msg_N ("Variable indexing cannot be applied to a constant", N);
+      end if;
+
+      if not Is_Overloaded (Func_Name) then
+         Func := Entity (Func_Name);
+         Indexing := Make_Function_Call (Loc,
+           Name => New_Occurrence_Of (Func, Loc),
+           Parameter_Associations =>
+             New_List (Relocate_Node (Prefix), Relocate_Node (Expr)));
+         Rewrite (N, Indexing);
+         Analyze (N);
+
+         --  The return type of the indexing function is a reference type, so
+         --  add the dereference as a possible interpretation.
+
+         Disc := First_Discriminant (Etype (Func));
+         while Present (Disc) loop
+            if Has_Implicit_Dereference (Disc) then
+               Add_One_Interp (N, Disc, Designated_Type (Etype (Disc)));
+               exit;
+            end if;
+
+            Next_Discriminant (Disc);
+         end loop;
+
+      else
+         Indexing := Make_Function_Call (Loc,
+           Name => Make_Identifier (Loc, Chars (Func_Name)),
+           Parameter_Associations =>
+             New_List (Relocate_Node (Prefix), Relocate_Node (Expr)));
+
+         Rewrite (N, Indexing);
+
+         declare
+            I  : Interp_Index;
+            It : Interp;
+            Success : Boolean;
+
+         begin
+            Get_First_Interp (Func_Name, I, It);
+            Set_Etype (N, Any_Type);
+            while Present (It.Nam) loop
+               Analyze_One_Call (N, It.Nam, False, Success);
+               if Success then
+                  Set_Etype (Name (N), It.Typ);
+
+                  --  Add implicit dereference interpretation.
+
+                  Disc := First_Discriminant (Etype (It.Nam));
+
+                  while Present (Disc) loop
+                     if Has_Implicit_Dereference (Disc) then
+                        Add_One_Interp
+                          (N, Disc, Designated_Type (Etype (Disc)));
+                        exit;
+                     end if;
+
+                     Next_Discriminant (Disc);
+                  end loop;
+               end if;
+               Get_Next_Interp (I, It);
+            end loop;
+         end;
+      end if;
+
+      return True;
+   end Try_Container_Indexing;
+
    -----------------------
    -- Try_Indirect_Call --
    -----------------------

gcc/ada/sem_ch8.adb

@@ -4818,7 +4818,12 @@ package body Sem_Ch8 is
             end if;
 
             Set_Entity_Or_Discriminal (N, E);
-            Check_Implicit_Dereference (N, Etype (E));
+
+            if Ada_Version >= Ada_2012
+              and then Nkind (Parent (N)) in N_Subexpr
+            then
+               Check_Implicit_Dereference (N, Etype (E));
+            end if;
          end if;
       end;
    end Find_Direct_Name;

gcc/ada/sinfo.adb

@@ -2844,6 +2844,14 @@ package body Sinfo is
       return Node1 (N);
    end Storage_Pool;
 
+   function Subpool_Handle_Name
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Allocator);
+      return Node4 (N);
+   end Subpool_Handle_Name;
+
    function Strval
       (N : Node_Id) return String_Id is
    begin
@@ -5886,6 +5894,14 @@ package body Sinfo is
       Set_Node1 (N, Val); -- semantic field, no parent set
    end Set_Storage_Pool;
 
+   procedure Set_Subpool_Handle_Name
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Allocator);
+      Set_Node4_With_Parent (N, Val);
+   end Set_Subpool_Handle_Name;
+
    procedure Set_Strval
       (N : Node_Id; Val : String_Id) is
    begin

gcc/ada/sinfo.ads

@@ -3933,14 +3933,20 @@ package Sinfo is
       --------------------
 
       --  ALLOCATOR ::=
-      --    new [NULL_EXCLUSION] SUBTYPE_INDICATION | new QUALIFIED_EXPRESSION
+      --      new [SUBPOOL_SPECIFICATION] SUBTYPE_INDICATION
+      --    | new [SUBPOOL_SPECIFICATION] QUALIFIED_EXPRESSION
+      --
+      --  SUBPOOL_SPECIFICATION ::= (subpool_handle_NAME)
 
       --  Sprint syntax (when storage pool present)
       --    new xxx (storage_pool = pool)
+      --  or
+      --    new (subpool) xxx (storage_pool = pool)
 
       --  N_Allocator
       --  Sloc points to NEW
       --  Expression (Node3) subtype indication or qualified expression
+      --  Subpool_Handle_Name (Node4) (set to Empty if not present)
       --  Storage_Pool (Node1-Sem)
       --  Procedure_To_Call (Node2-Sem)
       --  Null_Exclusion_Present (Flag11)
@@ -8911,6 +8917,9 @@ package Sinfo is
    function Storage_Pool
      (N : Node_Id) return Node_Id;    -- Node1
 
+   function Subpool_Handle_Name
+     (N : Node_Id) return Node_Id;    -- Node4
+
    function Strval
      (N : Node_Id) return String_Id;  -- Str3
 
@@ -9880,6 +9889,9 @@ package Sinfo is
    procedure Set_Storage_Pool
      (N : Node_Id; Val : Node_Id);            -- Node1
 
+   procedure Set_Subpool_Handle_Name
+     (N : Node_Id; Val : Node_Id);            -- Node4
+
    procedure Set_Strval
      (N : Node_Id; Val : String_Id);          -- Str3
 
@@ -10656,7 +10668,7 @@ package Sinfo is
        (1 => False,   --  Storage_Pool (Node1-Sem)
         2 => False,   --  Procedure_To_Call (Node2-Sem)
         3 => True,    --  Expression (Node3)
-        4 => False,   --  unused
+        4 => True,    --  Subpool_Handle_Name (Node4)
         5 => False),  --  Etype (Node5-Sem)
 
      N_Null_Statement =>
@@ -11997,6 +12009,7 @@ package Sinfo is
    pragma Inline (Statements);
    pragma Inline (Static_Processing_OK);
    pragma Inline (Storage_Pool);
+   pragma Inline (Subpool_Handle_Name);
    pragma Inline (Strval);
    pragma Inline (Subtype_Indication);
    pragma Inline (Subtype_Mark);
@@ -12316,6 +12329,7 @@ package Sinfo is
    pragma Inline (Set_Statements);
    pragma Inline (Set_Static_Processing_OK);
    pragma Inline (Set_Storage_Pool);
+   pragma Inline (Set_Subpool_Handle_Name);
    pragma Inline (Set_Strval);
    pragma Inline (Set_Subtype_Indication);
    pragma Inline (Set_Subtype_Mark);