CbC/CbC_gcc: gcc/ada/sem_aggr.adb comparison

comparison 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

comparison

equal deleted inserted replaced

-:04ced10e8804
+:84e7813d76e9
 --                                                                          --
 --                             S E M _ A G G R                              --
 --                                                                          --
 --                                 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- --
 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
 procedure Check_Expr_OK_In_Limited_Aggregate (Expr : Node_Id);
 --  Check that Expr is either not limited or else is one of the cases of
 --  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
 --  at Level are qualified. If Level = 0, this applies to Expr directly.
 --  Only issue errors in formal verification mode.
 procedure Make_String_Into_Aggregate (N : Node_Id);
 --  A string literal can appear in a context in which a one dimensional
 --  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 --
 ------------------------
 function Array_Aggr_Subtype
 --  If expansion is disabled (generic context, or semantics-only
 --  mode) actual subtypes cannot be constructed, and the type of an
 --  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
 --  N_Parameter_Association which itself appears only if there is a
 --  formal parameter. Consequently we also need to test for
 --  so the context is legal.
 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
 Pkind = N_Function_Call             or else
 Pkind = N_Procedure_Call_Statement  or else
 procedure Resolve_Iterated_Component_Association
 (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));
 while Present (Choice) loop
 --  analysis.
 Ent := New_Internal_Entity (E_Loop, Current_Scope, Loc, 'L');
 Set_Etype  (Ent, Standard_Void_Type);
 Set_Parent (Ent, Parent (N));
+Push_Scope (Ent);
---  Decorate the index variable in the current scope. The association
+Id :=
---  may have several choices, each one leading to a loop, so we create
+Make_Defining_Identifier (Loc,
---  this variable only once to prevent homonyms in this scope.
+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);
-Enter_Name (Id);
+Set_Etype (Id, Index_Typ);
-Set_Etype (Id, Index_Typ);
+Set_Ekind (Id, E_Variable);
-Set_Ekind (Id, E_Variable);
+Set_Scope (Id, Ent);
-Set_Scope (Id, Ent);
+Set_Referenced (Id);
-Set_Referenced (Id);
-end if;
+--  Analyze a copy of the expression, to verify legality. We use
+--  a copy because the expression will be analyzed anew when the
-Push_Scope (Ent);
+--  enclosing aggregate is expanded, and the construct is rewritten
-Dummy := Resolve_Aggr_Expr (Expression (N), False);
+--  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;
 End_Scope;
 end Resolve_Iterated_Component_Association;
 --  Local variables
 -----------------------------
 -- Resolve_Delta_Aggregate --
 -----------------------------
 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 --
 ------------------------
 function Get_Component_Type (Nam : Node_Id) return Entity_Id is
 Comp : Entity_Id;
 begin
 Comp := First_Entity (Typ);
 while Present (Comp) loop
 if Chars (Comp) = Chars (Nam) then
 if Ekind (Comp) = E_Discriminant then
 Error_Msg_N ("delta cannot apply to discriminant", Nam);
 end if;
 Error_Msg_NE ("type& has no component with this name", Nam, Typ);
 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;
+Deltas : constant List_Id := Component_Associations (N);
-Choice     : Node_Id;
-Comp_Type  : Entity_Id;
+Assoc     : Node_Id;
-Index_Type : Entity_Id;
+Choice    : Node_Id;
+Comp_Type : Entity_Id := Empty; -- init to avoid warning
---  Start of processing for Resolve_Delta_Aggregate
+--  Start of processing for Resolve_Delta_Record_Aggregate
 begin
-if not Is_Composite_Type (Typ) then
+Variant := Empty;
-Error_Msg_N ("not a composite type", N);
-end if;
+Assoc := First (Deltas);
+while Present (Assoc) loop
-Analyze_And_Resolve (Base, Typ);
+Choice := First (Choice_List (Assoc));
+while Present (Choice) loop
-if Is_Array_Type (Typ) then
+Comp_Type := Get_Component_Type (Choice);
-Index_Type := Etype (First_Index (Typ));
-Assoc := First (Deltas);
+if Comp_Type /= Any_Type then
-while Present (Assoc) loop
+Check_Variant (Choice);
-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);
+Next (Choice);
 end loop;
-else
+pragma Assert (Present (Comp_Type));
-Assoc := First (Deltas);
+Analyze_And_Resolve (Expression (Assoc), Comp_Type);
-while Present (Assoc) loop
+Next (Assoc);
-Choice := First (Choice_List (Assoc));
+end loop;
-while Present (Choice) loop
+end Resolve_Delta_Record_Aggregate;
-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;
 ---------------------------------
 -- Resolve_Extension_Aggregate --
 ---------------------------------

Mercurial > hg > CbC > CbC_gcc

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