diff gcc/ada/sem_aggr.adb @ 131:84e7813d76e9

gcc-8.2
author mir3636
date Thu, 25 Oct 2018 07:37:49 +0900
parents 04ced10e8804
children 1830386684a0
line wrap: on
line diff
--- a/gcc/ada/sem_aggr.adb	Fri Oct 27 22:46:09 2017 +0900
+++ b/gcc/ada/sem_aggr.adb	Thu Oct 25 07:37:49 2018 +0900
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2017, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2018, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -115,7 +115,7 @@
    --  expressions allowed for a limited component association (namely, an
    --  aggregate, function call, or <> notation). Report error for violations.
    --  Expression is also OK in an instance or inlining context, because we
-   --  have already pre-analyzed and it is known to be type correct.
+   --  have already preanalyzed and it is known to be type correct.
 
    procedure Check_Qualified_Aggregate (Level : Nat; Expr : Node_Id);
    --  Given aggregate Expr, check that sub-aggregates of Expr that are nested
@@ -418,6 +418,13 @@
    --  array of characters is expected. This procedure simply rewrites the
    --  string as an aggregate, prior to resolution.
 
+   ---------------------------------
+   --  Delta aggregate processing --
+   ---------------------------------
+
+   procedure Resolve_Delta_Array_Aggregate  (N : Node_Id; Typ : Entity_Id);
+   procedure Resolve_Delta_Record_Aggregate (N : Node_Id; Typ : Entity_Id);
+
    ------------------------
    -- Array_Aggr_Subtype --
    ------------------------
@@ -1061,7 +1068,9 @@
             --  object may be its unconstrained nominal type. However, if the
             --  context is an assignment, we assume that OTHERS is allowed,
             --  because the target of the assignment will have a constrained
-            --  subtype when fully compiled.
+            --  subtype when fully compiled. Ditto if the context is an
+            --  initialization procedure where a component may have a predicate
+            --  function that carries the base type.
 
             --  Note that there is no node for Explicit_Actual_Parameter.
             --  To test for this context we therefore have to test for node
@@ -1076,6 +1085,7 @@
             Set_Etype (N, Aggr_Typ);  --  May be overridden later on
 
             if Pkind = N_Assignment_Statement
+              or else Inside_Init_Proc
               or else (Is_Constrained (Typ)
                         and then
                           (Pkind = N_Parameter_Association     or else
@@ -1650,12 +1660,13 @@
         (N         : Node_Id;
          Index_Typ : Entity_Id)
       is
-         Id  : constant Entity_Id  := Defining_Identifier (N);
          Loc : constant Source_Ptr := Sloc (N);
 
          Choice : Node_Id;
          Dummy  : Boolean;
          Ent    : Entity_Id;
+         Expr   : Node_Id;
+         Id     : Entity_Id;
 
       begin
          Choice := First (Discrete_Choices (N));
@@ -1690,25 +1701,42 @@
          Ent := New_Internal_Entity (E_Loop, Current_Scope, Loc, 'L');
          Set_Etype  (Ent, Standard_Void_Type);
          Set_Parent (Ent, Parent (N));
-
-         --  Decorate the index variable in the current scope. The association
-         --  may have several choices, each one leading to a loop, so we create
-         --  this variable only once to prevent homonyms in this scope.
+         Push_Scope (Ent);
+         Id :=
+           Make_Defining_Identifier (Loc,
+             Chars => Chars (Defining_Identifier (N)));
+
+         --  Insert and decorate the index variable in the current scope.
          --  The expression has to be analyzed once the index variable is
          --  directly visible. Mark the variable as referenced to prevent
          --  spurious warnings, given that subsequent uses of its name in the
          --  expression will reference the internal (synonym) loop variable.
 
-         if No (Scope (Id)) then
-            Enter_Name (Id);
-            Set_Etype (Id, Index_Typ);
-            Set_Ekind (Id, E_Variable);
-            Set_Scope (Id, Ent);
-            Set_Referenced (Id);
+         Enter_Name (Id);
+         Set_Etype (Id, Index_Typ);
+         Set_Ekind (Id, E_Variable);
+         Set_Scope (Id, Ent);
+         Set_Referenced (Id);
+
+         --  Analyze a copy of the expression, to verify legality. We use
+         --  a copy because the expression will be analyzed anew when the
+         --  enclosing aggregate is expanded, and the construct is rewritten
+         --  as a loop with a new index variable.
+
+         Expr := New_Copy_Tree (Expression (N));
+         Dummy := Resolve_Aggr_Expr (Expr, False);
+
+         --  An iterated_component_association may appear in a nested
+         --  aggregate for a multidimensional structure: preserve the bounds
+         --  computed for the expression, as well as the anonymous array
+         --  type generated for it; both are needed during array expansion.
+         --  This does not work for more than two levels of nesting. ???
+
+         if Nkind (Expr) = N_Aggregate then
+            Set_Aggregate_Bounds (Expression (N), Aggregate_Bounds (Expr));
+            Set_Etype (Expression (N), Etype (Expr));
          end if;
 
-         Push_Scope (Ent);
-         Dummy := Resolve_Aggr_Expr (Expression (N), False);
          End_Scope;
       end Resolve_Iterated_Component_Association;
 
@@ -2758,10 +2786,196 @@
    -----------------------------
 
    procedure Resolve_Delta_Aggregate (N : Node_Id; Typ : Entity_Id) is
-      Base   : constant Node_Id := Expression (N);
+      Base : constant Node_Id := Expression (N);
+
+   begin
+      if not Is_Composite_Type (Typ) then
+         Error_Msg_N ("not a composite type", N);
+      end if;
+
+      Analyze_And_Resolve (Base, Typ);
+
+      if Is_Array_Type (Typ) then
+         Resolve_Delta_Array_Aggregate (N, Typ);
+      else
+         Resolve_Delta_Record_Aggregate (N, Typ);
+      end if;
+
+      Set_Etype (N, Typ);
+   end Resolve_Delta_Aggregate;
+
+   -----------------------------------
+   -- Resolve_Delta_Array_Aggregate --
+   -----------------------------------
+
+   procedure Resolve_Delta_Array_Aggregate (N : Node_Id; Typ : Entity_Id) is
       Deltas : constant List_Id := Component_Associations (N);
 
+      Assoc      : Node_Id;
+      Choice     : Node_Id;
+      Index_Type : Entity_Id;
+
+   begin
+      Index_Type := Etype (First_Index (Typ));
+
+      Assoc := First (Deltas);
+      while Present (Assoc) loop
+         if Nkind (Assoc) = N_Iterated_Component_Association then
+            Choice := First (Choice_List (Assoc));
+            while Present (Choice) loop
+               if Nkind (Choice) = N_Others_Choice then
+                  Error_Msg_N
+                    ("others not allowed in delta aggregate", Choice);
+
+               else
+                  Analyze_And_Resolve (Choice, Index_Type);
+               end if;
+
+               Next (Choice);
+            end loop;
+
+            declare
+               Id  : constant Entity_Id := Defining_Identifier (Assoc);
+               Ent : constant Entity_Id :=
+                       New_Internal_Entity
+                         (E_Loop, Current_Scope, Sloc (Assoc), 'L');
+
+            begin
+               Set_Etype  (Ent, Standard_Void_Type);
+               Set_Parent (Ent, Assoc);
+
+               if No (Scope (Id)) then
+                  Enter_Name (Id);
+                  Set_Etype (Id, Index_Type);
+                  Set_Ekind (Id, E_Variable);
+                  Set_Scope (Id, Ent);
+               end if;
+
+               Push_Scope (Ent);
+               Analyze_And_Resolve
+                 (New_Copy_Tree (Expression (Assoc)), Component_Type (Typ));
+               End_Scope;
+            end;
+
+         else
+            Choice := First (Choice_List (Assoc));
+            while Present (Choice) loop
+               if Nkind (Choice) = N_Others_Choice then
+                  Error_Msg_N
+                    ("others not allowed in delta aggregate", Choice);
+
+               else
+                  Analyze (Choice);
+
+                  if Is_Entity_Name (Choice)
+                    and then Is_Type (Entity (Choice))
+                  then
+                     --  Choice covers a range of values
+
+                     if Base_Type (Entity (Choice)) /=
+                        Base_Type (Index_Type)
+                     then
+                        Error_Msg_NE
+                          ("choice does mat match index type of",
+                           Choice, Typ);
+                     end if;
+                  else
+                     Resolve (Choice, Index_Type);
+                  end if;
+               end if;
+
+               Next (Choice);
+            end loop;
+
+            Analyze_And_Resolve (Expression (Assoc), Component_Type (Typ));
+         end if;
+
+         Next (Assoc);
+      end loop;
+   end Resolve_Delta_Array_Aggregate;
+
+   ------------------------------------
+   -- Resolve_Delta_Record_Aggregate --
+   ------------------------------------
+
+   procedure Resolve_Delta_Record_Aggregate (N : Node_Id; Typ : Entity_Id) is
+
+      --  Variables used to verify that discriminant-dependent components
+      --  appear in the same variant.
+
+      Comp_Ref : Entity_Id := Empty; -- init to avoid warning
+      Variant  : Node_Id;
+
+      procedure Check_Variant (Id : Entity_Id);
+      --  If a given component of the delta aggregate appears in a variant
+      --  part, verify that it is within the same variant as that of previous
+      --  specified variant components of the delta.
+
       function Get_Component_Type (Nam : Node_Id) return Entity_Id;
+      --  Locate component with a given name and return its type. If none found
+      --  report error.
+
+      function Nested_In (V1 : Node_Id; V2 : Node_Id) return Boolean;
+      --  Determine whether variant V1 is within variant V2
+
+      function Variant_Depth (N : Node_Id) return Integer;
+      --  Determine the distance of a variant to the enclosing type
+      --  declaration.
+
+      --------------------
+      --  Check_Variant --
+      --------------------
+
+      procedure Check_Variant (Id : Entity_Id) is
+         Comp         : Entity_Id;
+         Comp_Variant : Node_Id;
+
+      begin
+         if not Has_Discriminants (Typ) then
+            return;
+         end if;
+
+         Comp := First_Entity (Typ);
+         while Present (Comp) loop
+            exit when Chars (Comp) = Chars (Id);
+            Next_Component (Comp);
+         end loop;
+
+         --  Find the variant, if any, whose component list includes the
+         --  component declaration.
+
+         Comp_Variant := Parent (Parent (List_Containing (Parent (Comp))));
+         if Nkind (Comp_Variant) = N_Variant then
+            if No (Variant) then
+               Variant  := Comp_Variant;
+               Comp_Ref := Comp;
+
+            elsif Variant /= Comp_Variant then
+               declare
+                  D1 : constant Integer := Variant_Depth (Variant);
+                  D2 : constant Integer := Variant_Depth (Comp_Variant);
+
+               begin
+                  if D1 = D2
+                    or else
+                      (D1 > D2 and then not Nested_In (Variant, Comp_Variant))
+                    or else
+                      (D2 > D1 and then not Nested_In (Comp_Variant, Variant))
+                  then
+                     pragma Assert (Present (Comp_Ref));
+                     Error_Msg_Node_2 := Comp_Ref;
+                     Error_Msg_NE
+                       ("& and & appear in different variants", Id, Comp);
+
+                  --  Otherwise retain the deeper variant for subsequent tests
+
+                  elsif D2 > D1 then
+                     Variant := Comp_Variant;
+                  end if;
+               end;
+            end if;
+         end if;
+      end Check_Variant;
 
       ------------------------
       -- Get_Component_Type --
@@ -2772,7 +2986,6 @@
 
       begin
          Comp := First_Entity (Typ);
-
          while Present (Comp) loop
             if Chars (Comp) = Chars (Nam) then
                if Ekind (Comp) = E_Discriminant then
@@ -2789,113 +3002,76 @@
          return Any_Type;
       end Get_Component_Type;
 
+      ---------------
+      -- Nested_In --
+      ---------------
+
+      function Nested_In (V1, V2 : Node_Id) return Boolean is
+         Par : Node_Id;
+
+      begin
+         Par := Parent (V1);
+         while Nkind (Par) /= N_Full_Type_Declaration loop
+            if Par = V2 then
+               return True;
+            end if;
+
+            Par := Parent (Par);
+         end loop;
+
+         return False;
+      end Nested_In;
+
+      -------------------
+      -- Variant_Depth --
+      -------------------
+
+      function Variant_Depth (N : Node_Id) return Integer is
+         Depth : Integer;
+         Par   : Node_Id;
+
+      begin
+         Depth := 0;
+         Par   := Parent (N);
+         while Nkind (Par) /= N_Full_Type_Declaration loop
+            Depth := Depth + 1;
+            Par   := Parent (Par);
+         end loop;
+
+         return Depth;
+      end Variant_Depth;
+
       --  Local variables
 
-      Assoc      : Node_Id;
-      Choice     : Node_Id;
-      Comp_Type  : Entity_Id;
-      Index_Type : Entity_Id;
-
-   --  Start of processing for Resolve_Delta_Aggregate
+      Deltas : constant List_Id := Component_Associations (N);
+
+      Assoc     : Node_Id;
+      Choice    : Node_Id;
+      Comp_Type : Entity_Id := Empty; -- init to avoid warning
+
+   --  Start of processing for Resolve_Delta_Record_Aggregate
 
    begin
-      if not Is_Composite_Type (Typ) then
-         Error_Msg_N ("not a composite type", N);
-      end if;
-
-      Analyze_And_Resolve (Base, Typ);
-
-      if Is_Array_Type (Typ) then
-         Index_Type := Etype (First_Index (Typ));
-         Assoc := First (Deltas);
-         while Present (Assoc) loop
-            if Nkind (Assoc) = N_Iterated_Component_Association then
-               Choice := First (Choice_List (Assoc));
-               while Present (Choice) loop
-                  if Nkind (Choice) = N_Others_Choice then
-                     Error_Msg_N
-                       ("others not allowed in delta aggregate", Choice);
-
-                  else
-                     Analyze_And_Resolve (Choice, Index_Type);
-                  end if;
-
-                  Next (Choice);
-               end loop;
-
-               declare
-                  Id  : constant Entity_Id := Defining_Identifier (Assoc);
-                  Ent : constant Entity_Id :=
-                          New_Internal_Entity
-                            (E_Loop, Current_Scope, Sloc (Assoc), 'L');
-
-               begin
-                  Set_Etype  (Ent, Standard_Void_Type);
-                  Set_Parent (Ent, Assoc);
-
-                  if No (Scope (Id)) then
-                     Enter_Name (Id);
-                     Set_Etype (Id, Index_Type);
-                     Set_Ekind (Id, E_Variable);
-                     Set_Scope (Id, Ent);
-                  end if;
-
-                  Push_Scope (Ent);
-                  Analyze_And_Resolve
-                    (New_Copy_Tree (Expression (Assoc)), Component_Type (Typ));
-                  End_Scope;
-               end;
-
-            else
-               Choice := First (Choice_List (Assoc));
-               while Present (Choice) loop
-                  if Nkind (Choice) = N_Others_Choice then
-                     Error_Msg_N
-                       ("others not allowed in delta aggregate", Choice);
-
-                  else
-                     Analyze (Choice);
-                     if Is_Entity_Name (Choice)
-                       and then Is_Type (Entity (Choice))
-                     then
-                        --  Choice covers a range of values.
-                        if Base_Type (Entity (Choice)) /=
-                           Base_Type (Index_Type)
-                        then
-                           Error_Msg_NE
-                             ("choice does mat match index type of",
-                              Choice, Typ);
-                        end if;
-                     else
-                        Resolve (Choice, Index_Type);
-                     end if;
-                  end if;
-
-                  Next (Choice);
-               end loop;
-
-               Analyze_And_Resolve (Expression (Assoc), Component_Type (Typ));
+      Variant := Empty;
+
+      Assoc := First (Deltas);
+      while Present (Assoc) loop
+         Choice := First (Choice_List (Assoc));
+         while Present (Choice) loop
+            Comp_Type := Get_Component_Type (Choice);
+
+            if Comp_Type /= Any_Type then
+               Check_Variant (Choice);
             end if;
 
-            Next (Assoc);
+            Next (Choice);
          end loop;
 
-      else
-         Assoc := First (Deltas);
-         while Present (Assoc) loop
-            Choice := First (Choice_List (Assoc));
-            while Present (Choice) loop
-               Comp_Type := Get_Component_Type (Choice);
-               Next (Choice);
-            end loop;
-
-            Analyze_And_Resolve (Expression (Assoc), Comp_Type);
-            Next (Assoc);
-         end loop;
-      end if;
-
-      Set_Etype (N, Typ);
-   end Resolve_Delta_Aggregate;
+         pragma Assert (Present (Comp_Type));
+         Analyze_And_Resolve (Expression (Assoc), Comp_Type);
+         Next (Assoc);
+      end loop;
+   end Resolve_Delta_Record_Aggregate;
 
    ---------------------------------
    -- Resolve_Extension_Aggregate --