Mercurial > hg > CbC > CbC_gcc
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 --