sinfo.ads, sinfo.adb: New attribute Generalized_Indexing...

2014-02-24  Ed Schonberg  <schonberg@adacore.com>

	* sinfo.ads, sinfo.adb: New attribute Generalized_Indexing, for
	indexed_components that are instances of Ada 2012 container
	indexing operations. Analysis and resolution of such nodes
	is performed on the attribute, and the original source is
	preserved for ASIS operations. If expansion is enabled, the
	indexed component is replaced by the value of this attribute,
	which is in a call to an Indexing aspect, in most case wrapped
	in a dereference operation.
	* sem_ch4.adb (Analyze_Indexed_Component): Create
	Generalized_Indexing attribute when appropriate.
	(Analyze_Call): If prefix is not overloadable and has an indexing
	aspect, transform into an indexed component so it can be analyzed
	as a potential container indexing.
	(Analyze_Expression): If node is an indexed component with a
	Generalized_ Indexing, do not re-analyze.
	* sem_res.adb (Resolve_Generalized_Indexing): Complete resolution
	of an indexed_component that has been transformed into a container
	indexing operation.
	(Resolve_Indexed_Component): Call the above when required.
	(Resolve): Do not insert an explicit dereference operation on
	an indexed_component whose type has an implicit dereference:
	the operation is inserted when resolving the related
	Generalized_Indexing.

From-SVN: r208074

gcc/ada/ChangeLog

+2014-02-24  Ed Schonberg  <schonberg@adacore.com>
+
+	* sinfo.ads, sinfo.adb: New attribute Generalized_Indexing, for
+	indexed_components that are instances of Ada 2012 container
+	indexing operations. Analysis and resolution of such nodes
+	is performed on the attribute, and the original source is
+	preserved for ASIS operations. If expansion is enabled, the
+	indexed component is replaced by the value of this attribute,
+	which is in a call to an Indexing aspect, in most case wrapped
+	in a dereference operation.
+	* sem_ch4.adb (Analyze_Indexed_Component): Create
+	Generalized_Indexing attribute when appropriate.
+	(Analyze_Call): If prefix is not overloadable and has an indexing
+	aspect, transform into an indexed component so it can be analyzed
+	as a potential container indexing.
+	(Analyze_Expression): If node is an indexed component with a
+	Generalized_ Indexing, do not re-analyze.
+	* sem_res.adb (Resolve_Generalized_Indexing): Complete resolution
+	of an indexed_component that has been transformed into a container
+	indexing operation.
+	(Resolve_Indexed_Component): Call the above when required.
+	(Resolve): Do not insert an explicit dereference operation on
+	an indexed_component whose type has an implicit dereference:
+	the operation is inserted when resolving the related
+	Generalized_Indexing.
+
 2014-02-24  Olivier Ramonat  <ramonat@adacore.com>
 
 	* gnat_rm.texi, gnat_ugn.texi: Replace Ada Compiler by Ada Development

gcc/ada/sem_ch4.adb

@@ -1089,10 +1089,29 @@ package body Sem_Ch4 is
          else
             Nam_Ent := Entity (Nam);
 
-            --  If no interpretations, give error message
+            --  If not overloadable, this may be a generalized indexing
+            --  operation with named associations. Rewrite again as an
+            --  indexed component and analyze as container indexing.
 
             if not Is_Overloadable (Nam_Ent) then
-               No_Interpretation;
+               if Present (
+                 Find_Value_Of_Aspect
+                    (Etype (Nam_Ent), Aspect_Constant_Indexing))
+               then
+                  Replace (N,
+                    Make_Indexed_Component (Sloc (N),
+                      Prefix => Nam,
+                      Expressions => Parameter_Associations (N)));
+
+                  if Try_Container_Indexing (N, Nam, Expressions (N)) then
+                     return;
+                  else
+                     No_Interpretation;
+                  end if;
+
+               else
+                  No_Interpretation;
+               end if;
                return;
             end if;
          end if;
@@ -1991,8 +2010,19 @@ package body Sem_Ch4 is
 
    procedure Analyze_Expression (N : Node_Id) is
    begin
-      Analyze (N);
-      Check_Parameterless_Call (N);
+
+      --  If the expression is an indexed component that will be rewritten
+      --  as a container indexing, it has already been analyzed.
+
+      if Nkind (N) = N_Indexed_Component
+        and then Present (Generalized_Indexing (N))
+      then
+         null;
+
+      else
+         Analyze (N);
+         Check_Parameterless_Call (N);
+      end if;
    end Analyze_Expression;
 
    -------------------------------------
@@ -6993,8 +7023,15 @@ package body Sem_Ch4 is
 
       Assoc := New_List (Relocate_Node (Prefix));
 
-      --  A generalized iterator may have nore than one index expression, so
+      --  A generalized indexing may have nore than one index expression, so
       --  transfer all of them to the argument list to be used in the call.
+      --  Note that there may be named associations, in which case the node
+      --  was rewritten earlier as a call, and has been transformed back into
+      --  an indexed expression to share the following processing.
+      --  The generalized indexing node is the one on which analysis and
+      --  resolution take place. Before expansion the original node is replaced
+      --  with the generalized indexing node, which is a call, possibly with
+      --  a dereference operation.
 
       declare
          Arg : Node_Id;
@@ -7012,21 +7049,31 @@ package body Sem_Ch4 is
            Make_Function_Call (Loc,
              Name                   => New_Occurrence_Of (Func, Loc),
              Parameter_Associations => Assoc);
-         Rewrite (N, Indexing);
-         Analyze (N);
+         Set_Parent (Indexing, Parent (N));
+         Set_Generalized_Indexing (N, Indexing);
+         Analyze (Indexing);
+         Set_Etype (N, Etype (Indexing));
 
          --  If the return type of the indexing function is a reference type,
          --  add the dereference as a possible interpretation. Note that the
          --  indexing aspect may be a function that returns the element type
-         --  with no intervening implicit dereference.
+         --  with no intervening implicit dereference, and that the reference
+         --  discriminant is not the first discriminant.
 
          if Has_Discriminants (Etype (Func)) then
             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;
+               declare
+                  Elmt_Type : Entity_Id;
+
+               begin
+                  if Has_Implicit_Dereference (Disc) then
+                     Elmt_Type := Designated_Type (Etype (Disc));
+                     Add_One_Interp (Indexing, Disc, Elmt_Type);
+                     Add_One_Interp (N, Disc, Elmt_Type);
+                     exit;
+                  end if;
+               end;
 
                Next_Discriminant (Disc);
             end loop;
@@ -7038,7 +7085,8 @@ package body Sem_Ch4 is
              Name => Make_Identifier (Loc, Chars (Func_Name)),
              Parameter_Associations => Assoc);
 
-         Rewrite (N, Indexing);
+         Set_Parent (Indexing, Parent (N));
+         Set_Generalized_Indexing (N, Indexing);
 
          declare
             I       : Interp_Index;
@@ -7047,12 +7095,13 @@ package body Sem_Ch4 is
 
          begin
             Get_First_Interp (Func_Name, I, It);
-            Set_Etype (N, Any_Type);
+            Set_Etype (Indexing, Any_Type);
             while Present (It.Nam) loop
-               Analyze_One_Call (N, It.Nam, False, Success);
+               Analyze_One_Call (Indexing, It.Nam, False, Success);
                if Success then
-                  Set_Etype (Name (N), It.Typ);
-                  Set_Entity (Name (N), It.Nam);
+                  Set_Etype (Name (Indexing), It.Typ);
+                  Set_Entity (Name (Indexing), It.Nam);
+                  Set_Etype (N, Etype (Indexing));
 
                   --  Add implicit dereference interpretation
 
@@ -7061,6 +7110,8 @@ package body Sem_Ch4 is
                      while Present (Disc) loop
                         if Has_Implicit_Dereference (Disc) then
                            Add_One_Interp
+                             (Indexing, Disc, Designated_Type (Etype (Disc)));
+                           Add_One_Interp
                              (N, Disc, Designated_Type (Etype (Disc)));
                            exit;
                         end if;
@@ -7076,12 +7127,10 @@ package body Sem_Ch4 is
          end;
       end if;
 
-      if Etype (N) = Any_Type then
+      if Etype (Indexing) = Any_Type then
          Error_Msg_NE
            ("container cannot be indexed with&", N, Etype (First (Exprs)));
          Rewrite (N, New_Occurrence_Of (Any_Id, Loc));
-      else
-         Analyze (N);
       end if;
 
       return True;

gcc/ada/sem_res.adb

@@ -174,6 +174,7 @@ package body Sem_Res is
    procedure Resolve_Explicit_Dereference      (N : Node_Id; Typ : Entity_Id);
    procedure Resolve_Expression_With_Actions   (N : Node_Id; Typ : Entity_Id);
    procedure Resolve_If_Expression             (N : Node_Id; Typ : Entity_Id);
+   procedure Resolve_Generalized_Indexing      (N : Node_Id; Typ : Entity_Id);
    procedure Resolve_Indexed_Component         (N : Node_Id; Typ : Entity_Id);
    procedure Resolve_Integer_Literal           (N : Node_Id; Typ : Entity_Id);
    procedure Resolve_Logical_Op                (N : Node_Id; Typ : Entity_Id);
@@ -2375,7 +2376,15 @@ package body Sem_Res is
                  and then Ekind (It.Nam) = E_Discriminant
                  and then Has_Implicit_Dereference (It.Nam)
                then
-                  Build_Explicit_Dereference (N, It.Nam);
+                  --  If the node is a general indexing, the dereference is
+                  --  is inserted when resolving the rewritten form, else
+                  --  insert it now.
+
+                  if Nkind (N) /= N_Indexed_Component
+                    or else No (Generalized_Indexing (N))
+                  then
+                     Build_Explicit_Dereference (N, It.Nam);
+                  end if;
 
                --  For an explicit dereference, attribute reference, range,
                --  short-circuit form (which is not an operator node), or call
@@ -7520,6 +7529,47 @@ package body Sem_Res is
       end if;
    end Resolve_Expression_With_Actions;
 
+   ----------------------------------
+   -- Resolve_Generalized_Indexing --
+   ----------------------------------
+
+   procedure Resolve_Generalized_Indexing (N : Node_Id; Typ : Entity_Id) is
+      Indexing : constant Node_Id := Generalized_Indexing (N);
+      Call     : Node_Id;
+      Indices  : List_Id;
+      Pref     : Node_Id;
+
+   begin
+
+      --  In ASIS mode, propagate the information about the indices back to
+      --  to the original indexing node. The generalized indexing is either
+      --  a function call, or a dereference of one. The actuals include the
+      --  prefix of the original node, which is the container expression.
+
+      if ASIS_Mode then
+         Resolve (Indexing, Typ);
+         Set_Etype  (N, Etype (Indexing));
+         Set_Is_Overloaded (N, False);
+         Call := Indexing;
+         while Nkind_In (Call,
+            N_Explicit_Dereference, N_Selected_Component)
+         loop
+            Call := Prefix (Call);
+         end loop;
+
+         if Nkind (Call) = N_Function_Call then
+            Indices := Parameter_Associations (Call);
+            Pref := Remove_Head (Indices);
+            Set_Expressions (N, Indices);
+            Set_Prefix (N, Pref);
+         end if;
+
+      else
+         Rewrite (N, Indexing);
+         Resolve (N, Typ);
+      end if;
+   end Resolve_Generalized_Indexing;
+
    ---------------------------
    -- Resolve_If_Expression --
    ---------------------------
@@ -7591,6 +7641,11 @@ package body Sem_Res is
       Index      : Node_Id;
 
    begin
+      if Present (Generalized_Indexing (N)) then
+         Resolve_Generalized_Indexing (N, Typ);
+         return;
+      end if;
+
       if Is_Overloaded (Name) then
 
          --  Use the context type to select the prefix that yields the correct

gcc/ada/sinfo.adb

@@ -1399,6 +1399,14 @@ package body Sinfo is
       return Flag6 (N);
    end From_Default;
 
+   function Generalized_Indexing
+      (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Indexed_Component);
+      return Node4 (N);
+   end Generalized_Indexing;
+
    function Generic_Associations
       (N : Node_Id) return List_Id is
    begin
@@ -4531,6 +4539,14 @@ package body Sinfo is
       Set_Flag6 (N, Val);
    end Set_From_Default;
 
+   procedure Set_Generalized_Indexing
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Indexed_Component);
+      Set_Node4 (N, Val);
+   end Set_Generalized_Indexing;
+
    procedure Set_Generic_Associations
       (N : Node_Id; Val : List_Id) is
    begin

gcc/ada/sinfo.ads

@@ -1277,6 +1277,15 @@ package Sinfo is
    --    declaration is treated as an implicit reference to the formal in the
    --    ali file.
 
+   --  Generalized_Indexing (Node4-Sem)
+   --  Generalized_Indexing is set in Indexed_Component nodes that are Ada 2012
+   --  container indexing operations. The value of the attribute is a function
+   --  call (possibly dereferenced) that corresponds to the proper expansion
+   --  of the source indexing operation. Before expansion, the source node
+   --  is rewritten as the resolved generalized indexing. In ASIS mode, the
+   --  expansion does not take place, so that the source is preserved and
+   --  properly annotated with types.
+
    --  Generic_Parent (Node5-Sem)
    --    Generic_Parent is defined on declaration nodes that are instances. The
    --    value of Generic_Parent is the generic entity from which the instance
@@ -3470,6 +3479,7 @@ package Sinfo is
       --  Sloc contains a copy of the Sloc value of the Prefix
       --  Prefix (Node3)
       --  Expressions (List1)
+      --  Generalized_Indexing (Node4-Sem)
       --  Atomic_Sync_Required (Flag14-Sem)
       --  plus fields for expression
 
@@ -8912,6 +8922,8 @@ package Sinfo is
    function From_Default
      (N : Node_Id) return Boolean;    -- Flag6
 
+   function Generalized_Indexing
+     (N : Node_Id) return Node_Id;    -- Node4
    function Generic_Associations
      (N : Node_Id) return List_Id;    -- List3
 
@@ -9908,6 +9920,9 @@ package Sinfo is
    procedure Set_From_Default
      (N : Node_Id; Val : Boolean := True);    -- Flag6
 
+   procedure Set_Generalized_Indexing
+     (N : Node_Id; Val : Node_Id);            -- Node4
+
    procedure Set_Generic_Associations
      (N : Node_Id; Val : List_Id);            -- List3
 
@@ -10918,7 +10933,7 @@ package Sinfo is
        (1 => True,    --  Expressions (List1)
         2 => False,   --  unused
         3 => True,    --  Prefix (Node3)
-        4 => False,   --  unused
+        4 => False,    --  Generalized_Indexing (Node4-Sem)
         5 => False),  --  Etype (Node5-Sem)
 
      N_Slice =>
@@ -12372,6 +12387,7 @@ package Sinfo is
    pragma Inline (From_At_End);
    pragma Inline (From_At_Mod);
    pragma Inline (From_Default);
+   pragma Inline (Generalized_Indexing);
    pragma Inline (Generic_Associations);
    pragma Inline (Generic_Formal_Declarations);
    pragma Inline (Generic_Parent);
@@ -12701,6 +12717,7 @@ package Sinfo is
    pragma Inline (Set_From_At_End);
    pragma Inline (Set_From_At_Mod);
    pragma Inline (Set_From_Default);
+   pragma Inline (Set_Generalized_Indexing);
    pragma Inline (Set_Generic_Associations);
    pragma Inline (Set_Generic_Formal_Declarations);
    pragma Inline (Set_Generic_Parent);