X-Git-Url: https://git.libre-soc.org/?a=blobdiff_plain;f=gcc%2Fada%2Fsem_aggr.adb;h=3f96139e3225d2789101f3b73426301309ab8102;hb=02fb12801b18c9d3cfe1c29b5be9f33d2dc77e21;hp=19c44c274a26c86afe80cb96867efdff2cd8769c;hpb=5c4adf10c5637284e63fffce8a7ac4ee6afbce29;p=gcc.git diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 19c44c274a2..3f96139e322 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -48,6 +48,7 @@ with Sem; use Sem; with Sem_Aux; use Sem_Aux; with Sem_Cat; use Sem_Cat; with Sem_Ch3; use Sem_Ch3; +with Sem_Ch5; use Sem_Ch5; with Sem_Ch8; use Sem_Ch8; with Sem_Ch13; use Sem_Ch13; with Sem_Dim; use Sem_Dim; @@ -63,6 +64,7 @@ with Stand; use Stand; with Style; use Style; with Targparm; use Targparm; with Tbuild; use Tbuild; +with Ttypes; use Ttypes; with Uintp; use Uintp; package body Sem_Aggr is @@ -450,7 +452,7 @@ package body Sem_Aggr is This_Range : constant Node_Id := Aggregate_Bounds (N); -- The aggregate range node of this specific sub-aggregate - This_Low : constant Node_Id := Low_Bound (Aggregate_Bounds (N)); + This_Low : constant Node_Id := Low_Bound (Aggregate_Bounds (N)); This_High : constant Node_Id := High_Bound (Aggregate_Bounds (N)); -- The aggregate bounds of this specific sub-aggregate @@ -783,12 +785,39 @@ package body Sem_Aggr is ----------------------- procedure Resolve_Aggregate (N : Node_Id; Typ : Entity_Id) is - Loc : constant Source_Ptr := Sloc (N); + Loc : constant Source_Ptr := Sloc (N); Aggr_Subtyp : Entity_Id; -- The actual aggregate subtype. This is not necessarily the same as Typ -- which is the subtype of the context in which the aggregate was found. + Others_Box : Boolean := False; + -- Set to True if N represents a simple aggregate with only + -- (others => <>), not nested as part of another aggregate. + + function Within_Aggregate (N : Node_Id) return Boolean; + -- Return True if N is part of an N_Aggregate + + ---------------------- + -- Within_Aggregate -- + ---------------------- + + function Within_Aggregate (N : Node_Id) return Boolean is + P : Node_Id := Parent (N); + begin + while Present (P) loop + if Nkind (P) = N_Aggregate then + return True; + end if; + + P := Parent (P); + end loop; + + return False; + end Within_Aggregate; + + -- Start of processing for Resolve_Aggregate + begin -- Ignore junk empty aggregate resulting from parser error @@ -809,16 +838,26 @@ package body Sem_Aggr is and then Present (Component_Associations (N)) then declare - Comp : Node_Id; + Comp : Node_Id; + First_Comp : Boolean := True; begin Comp := First (Component_Associations (N)); while Present (Comp) loop if Box_Present (Comp) then + if First_Comp + and then No (Expressions (N)) + and then Nkind (First (Choices (Comp))) = N_Others_Choice + and then not Within_Aggregate (N) + then + Others_Box := True; + end if; + Insert_Actions (N, Freeze_Entity (Typ, N)); exit; end if; + First_Comp := False; Next (Comp); end loop; end; @@ -831,7 +870,8 @@ package body Sem_Aggr is if not Support_Aggregates_On_Target and then Comes_From_Source (N) - and then (not Known_Static_Esize (Typ) or else Esize (Typ) > 64) + and then (not Known_Static_Esize (Typ) + or else Esize (Typ) > System_Max_Integer_Size) then Error_Msg_CRT ("aggregate", N); end if; @@ -861,6 +901,12 @@ package body Sem_Aggr is elsif Is_Array_Type (Typ) and then Null_Record_Present (N) then Error_Msg_N ("null record forbidden in array aggregate", N); + elsif Present (Find_Aspect (Typ, Aspect_Aggregate)) + and then Ekind (Typ) /= E_Record_Type + and then Ada_Version >= Ada_2020 + then + Resolve_Container_Aggregate (N, Typ); + elsif Is_Record_Type (Typ) then Resolve_Record_Aggregate (N, Typ); @@ -960,23 +1006,24 @@ package body Sem_Aggr is if Nkind (Parent (N)) = N_Assignment_Statement or else Inside_Init_Proc or else (Is_Constrained (Typ) - and then Nkind_In (Parent (N), - N_Parameter_Association, - N_Function_Call, - N_Procedure_Call_Statement, - N_Generic_Association, - N_Formal_Object_Declaration, - N_Simple_Return_Statement, - N_Object_Declaration, - N_Component_Declaration, - N_Parameter_Specification, - N_Qualified_Expression, - N_Reference, - N_Aggregate, - N_Extension_Aggregate, - N_Component_Association, - N_Case_Expression_Alternative, - N_If_Expression)) + and then Nkind (Parent (N)) in + N_Parameter_Association + | N_Function_Call + | N_Procedure_Call_Statement + | N_Generic_Association + | N_Formal_Object_Declaration + | N_Simple_Return_Statement + | N_Object_Declaration + | N_Component_Declaration + | N_Parameter_Specification + | N_Qualified_Expression + | N_Reference + | N_Aggregate + | N_Extension_Aggregate + | N_Component_Association + | N_Case_Expression_Alternative + | N_If_Expression + | N_Expression_With_Actions) then Aggr_Resolved := Resolve_Array_Aggregate @@ -1041,6 +1088,13 @@ package body Sem_Aggr is Set_Analyzed (N); end if; + if Warn_On_No_Value_Assigned + and then Others_Box + and then not Is_Fully_Initialized_Type (Etype (N)) + then + Error_Msg_N ("?v?aggregate not fully initialized", N); + end if; + Check_Function_Writable_Actuals (N); end Resolve_Aggregate; @@ -1423,7 +1477,7 @@ package body Sem_Aggr is if Is_Character_Type (Component_Typ) and then No (Next_Index (Nxt_Ind)) - and then Nkind_In (Expr, N_String_Literal, N_Operator_Symbol) + and then Nkind (Expr) in N_String_Literal | N_Operator_Symbol then -- A string literal used in a multidimensional array -- aggregate in place of the final one-dimensional @@ -1498,7 +1552,7 @@ package body Sem_Aggr is -- If an aggregate component has a type with predicates, an explicit -- predicate check must be applied, as for an assignment statement, - -- because the aggegate might not be expanded into individual + -- because the aggregate might not be expanded into individual -- component assignments. If the expression covers several components -- the analysis and the predicate check take place later. @@ -1536,14 +1590,53 @@ package body Sem_Aggr is Index_Typ : Entity_Id) is Loc : constant Source_Ptr := Sloc (N); + Id : constant Entity_Id := Defining_Identifier (N); + + ----------------------- + -- Remove_References -- + ----------------------- + + function Remove_Ref (N : Node_Id) return Traverse_Result; + -- Remove references to the entity Id after analysis, so it can be + -- properly reanalyzed after construct is expanded into a loop. + + function Remove_Ref (N : Node_Id) return Traverse_Result is + begin + if Nkind (N) = N_Identifier + and then Present (Entity (N)) + and then Entity (N) = Id + then + Set_Entity (N, Empty); + Set_Etype (N, Empty); + end if; + Set_Analyzed (N, False); + return OK; + end Remove_Ref; + + procedure Remove_References is new Traverse_Proc (Remove_Ref); + + -- Local variables Choice : Node_Id; Dummy : Boolean; Ent : Entity_Id; Expr : Node_Id; - Id : Entity_Id; + + -- Start of processing for Resolve_Iterated_Component_Association begin + -- An element iterator specification cannot appear in + -- an array aggregate because it does not provide index + -- values for the association. This must be a semantic + -- check because the parser cannot tell whether this is + -- an array aggregate or a container aggregate. + + if Present (Iterator_Specification (N)) then + Error_Msg_N ("container element Iterator cannot appear " + & "in an array aggregate", N); + return; + end if; + Choice := First (Discrete_Choices (N)); while Present (Choice) loop @@ -1577,35 +1670,36 @@ package body Sem_Aggr is Set_Etype (Ent, Standard_Void_Type); Set_Parent (Ent, Parent (N)); 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. + -- directly visible. 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. + -- Analyze expression without expansion, to verify legality. + -- When generating code, we then remove references to the index + -- variable, because the expression will be analyzed anew after + -- rewritting as a loop with a new index variable; when not + -- generating code we leave the analyzed expression as it is. - Expr := New_Copy_Tree (Expression (N)); - Dummy := Resolve_Aggr_Expr (Expr, False); + Expr := Expression (N); + + Expander_Mode_Save_And_Set (False); + Dummy := Resolve_Aggr_Expr (Expr, Single_Elmt => False); + Expander_Mode_Restore; + + if Operating_Mode /= Check_Semantics then + Remove_References (Expr); + end if; -- 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)); @@ -1685,8 +1779,8 @@ package body Sem_Aggr is if Ada_Version = Ada_83 and then Assoc /= First (Component_Associations (N)) - and then Nkind_In (Parent (N), N_Assignment_Statement, - N_Object_Declaration) + and then Nkind (Parent (N)) in + N_Assignment_Statement | N_Object_Declaration then Error_Msg_N ("(Ada 83) illegal context for OTHERS choice", N); @@ -1778,7 +1872,7 @@ package body Sem_Aggr is if Others_Present and then not Others_Allowed then Error_Msg_N ("OTHERS choice not allowed here", - First (Choices (First (Component_Associations (N))))); + First (Choice_List (First (Component_Associations (N))))); return Failure; end if; @@ -1994,8 +2088,13 @@ package body Sem_Aggr is return Failure; end if; + -- ??? Checks for dynamically tagged expressions below will + -- be only applied to iterated_component_association after + -- expansion; in particular, errors might not be reported when + -- -gnatc switch is used. + elsif Nkind (Assoc) = N_Iterated_Component_Association then - null; -- handled above, in a loop context. + null; -- handled above, in a loop context elsif not Resolve_Aggr_Expr (Expression (Assoc), Single_Elmt => Single_Choice) @@ -2507,7 +2606,7 @@ package body Sem_Aggr is -- In order to diagnose the semantic error we create a duplicate -- tree to analyze it and perform the check. - else + elsif Nkind (Assoc) /= N_Iterated_Component_Association then declare Save_Analysis : constant Boolean := Full_Analysis; Expr : constant Node_Id := @@ -2626,6 +2725,303 @@ package body Sem_Aggr is return Success; end Resolve_Array_Aggregate; + --------------------------------- + -- Resolve_Container_Aggregate -- + --------------------------------- + + procedure Resolve_Container_Aggregate (N : Node_Id; Typ : Entity_Id) is + procedure Resolve_Iterated_Association + (Comp : Node_Id; + Key_Type : Entity_Id; + Elmt_Type : Entity_Id); + -- Resolve choices and expression in an iterated component association + -- or an iterated element association, which has a key_expression. + -- This is similar but not identical to the handling of this construct + -- in an array aggregate. + -- For a named container, the type of each choice must be compatible + -- with the key type. For a positional container, the choice must be + -- a subtype indication or an iterator specification that determines + -- an element type. + + Asp : constant Node_Id := Find_Value_Of_Aspect (Typ, Aspect_Aggregate); + + Empty_Subp : Node_Id := Empty; + Add_Named_Subp : Node_Id := Empty; + Add_Unnamed_Subp : Node_Id := Empty; + New_Indexed_Subp : Node_Id := Empty; + Assign_Indexed_Subp : Node_Id := Empty; + + ---------------------------------- + -- Resolve_Iterated_Association -- + ---------------------------------- + + procedure Resolve_Iterated_Association + (Comp : Node_Id; + Key_Type : Entity_Id; + Elmt_Type : Entity_Id) + is + Choice : Node_Id; + Ent : Entity_Id; + Expr : Node_Id; + Key_Expr : Node_Id; + Id : Entity_Id; + Id_Name : Name_Id; + Iter : Node_Id; + Typ : Entity_Id := Empty; + + begin + -- If this is an Iterated_Element_Association then either a + -- an Iterator_Specification or a Loop_Parameter specification + -- is present. In both cases a Key_Expression is present. + + if Nkind (Comp) = N_Iterated_Element_Association then + if Present (Loop_Parameter_Specification (Comp)) then + Analyze_Loop_Parameter_Specification + (Loop_Parameter_Specification (Comp)); + Id_Name := Chars (Defining_Identifier + (Loop_Parameter_Specification (Comp))); + else + Iter := Copy_Separate_Tree (Iterator_Specification (Comp)); + Analyze (Iter); + Typ := Etype (Defining_Identifier (Iter)); + Id_Name := Chars (Defining_Identifier + (Iterator_Specification (Comp))); + end if; + + -- Key expression must have the type of the key. We analyze + -- a copy of the original expression, because it will be + -- reanalyzed and copied as needed during expansion of the + -- corresponding loop. + + Key_Expr := Key_Expression (Comp); + Analyze_And_Resolve (New_Copy_Tree (Key_Expr), Key_Type); + + elsif Present (Iterator_Specification (Comp)) then + Iter := Copy_Separate_Tree (Iterator_Specification (Comp)); + Id_Name := Chars (Defining_Identifier (Comp)); + Analyze (Iter); + Typ := Etype (Defining_Identifier (Iter)); + + else + Choice := First (Discrete_Choices (Comp)); + + while Present (Choice) loop + Analyze (Choice); + + -- Choice can be a subtype name, a range, or an expression + + if Is_Entity_Name (Choice) + and then Is_Type (Entity (Choice)) + and then Base_Type (Entity (Choice)) = Base_Type (Key_Type) + then + null; + + elsif Present (Key_Type) then + Analyze_And_Resolve (Choice, Key_Type); + + else + Typ := Etype (Choice); -- assume unique for now + end if; + + Next (Choice); + end loop; + + Id_Name := Chars (Defining_Identifier (Comp)); + end if; + + -- Create a scope in which to introduce an index, which is usually + -- visible in the expression for the component, and needed for its + -- analysis. + + Id := Make_Defining_Identifier (Sloc (Comp), Id_Name); + Ent := New_Internal_Entity (E_Loop, Current_Scope, Sloc (Comp), 'L'); + Set_Etype (Ent, Standard_Void_Type); + Set_Parent (Ent, Parent (Comp)); + Push_Scope (Ent); + + -- Insert and decorate the loop variable in the current scope. + -- The expression has to be analyzed once the loop 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. + + Enter_Name (Id); + + if No (Key_Type) then + pragma Assert (Present (Typ)); + Set_Etype (Id, Typ); + else + Set_Etype (Id, Key_Type); + end if; + + 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 (Comp)); + Preanalyze_And_Resolve (Expr, Elmt_Type); + End_Scope; + + end Resolve_Iterated_Association; + + begin + pragma Assert (Nkind (Asp) = N_Aggregate); + + Set_Etype (N, Typ); + Parse_Aspect_Aggregate (Asp, + Empty_Subp, Add_Named_Subp, Add_Unnamed_Subp, + New_Indexed_Subp, Assign_Indexed_Subp); + + if Present (Add_Unnamed_Subp) + and then No (New_Indexed_Subp) + then + declare + Elmt_Type : constant Entity_Id := + Etype (Next_Formal + (First_Formal (Entity (Add_Unnamed_Subp)))); + Comp : Node_Id; + + begin + if Present (Expressions (N)) then + -- positional aggregate + + Comp := First (Expressions (N)); + while Present (Comp) loop + Analyze_And_Resolve (Comp, Elmt_Type); + Next (Comp); + end loop; + end if; + + -- Empty aggregate, to be replaced by Empty during + -- expansion, or iterated component association. + + if Present (Component_Associations (N)) then + declare + Comp : Node_Id := First (Component_Associations (N)); + begin + while Present (Comp) loop + if Nkind (Comp) /= + N_Iterated_Component_Association + then + Error_Msg_N ("illegal component association " + & "for unnamed container aggregate", Comp); + return; + else + Resolve_Iterated_Association + (Comp, Empty, Elmt_Type); + end if; + + Next (Comp); + end loop; + end; + end if; + end; + + elsif Present (Add_Named_Subp) then + declare + -- Retrieves types of container, key, and element from the + -- specified insertion procedure. + + Container : constant Entity_Id := + First_Formal (Entity (Add_Named_Subp)); + Key_Type : constant Entity_Id := Etype (Next_Formal (Container)); + Elmt_Type : constant Entity_Id := + Etype (Next_Formal (Next_Formal (Container))); + Comp : Node_Id; + Choice : Node_Id; + + begin + Comp := First (Component_Associations (N)); + while Present (Comp) loop + if Nkind (Comp) = N_Component_Association then + Choice := First (Choices (Comp)); + + while Present (Choice) loop + Analyze_And_Resolve (Choice, Key_Type); + if not Is_Static_Expression (Choice) then + Error_Msg_N ("Choice must be static", Choice); + end if; + + Next (Choice); + end loop; + + Analyze_And_Resolve (Expression (Comp), Elmt_Type); + + elsif Nkind (Comp) in + N_Iterated_Component_Association | + N_Iterated_Element_Association + then + Resolve_Iterated_Association + (Comp, Key_Type, Elmt_Type); + end if; + + Next (Comp); + end loop; + end; + + else + -- Indexed Aggregate. Positional or indexed component + -- can be present, but not both. Choices must be static + -- values or ranges with static bounds. + + declare + Container : constant Entity_Id := + First_Formal (Entity (Assign_Indexed_Subp)); + Index_Type : constant Entity_Id := Etype (Next_Formal (Container)); + Comp_Type : constant Entity_Id := + Etype (Next_Formal (Next_Formal (Container))); + Comp : Node_Id; + Choice : Node_Id; + + begin + if Present (Expressions (N)) then + Comp := First (Expressions (N)); + while Present (Comp) loop + Analyze_And_Resolve (Comp, Comp_Type); + Next (Comp); + end loop; + end if; + + if Present (Component_Associations (N)) then + if Present (Expressions (N)) then + Error_Msg_N ("Container aggregate cannot be " + & "both positional and named", N); + return; + end if; + + Comp := First (Expressions (N)); + + while Present (Comp) loop + if Nkind (Comp) = N_Component_Association then + Choice := First (Choices (Comp)); + + while Present (Choice) loop + Analyze_And_Resolve (Choice, Index_Type); + Next (Choice); + end loop; + + Analyze_And_Resolve (Expression (Comp), Comp_Type); + + elsif Nkind (Comp) in + N_Iterated_Component_Association | + N_Iterated_Element_Association + then + Resolve_Iterated_Association + (Comp, Index_Type, Comp_Type); + end if; + + Next (Comp); + end loop; + end if; + end; + end if; + end Resolve_Container_Aggregate; + ----------------------------- -- Resolve_Delta_Aggregate -- ----------------------------- @@ -2659,15 +3055,14 @@ package body Sem_Aggr is ----------------------------------- procedure Resolve_Delta_Array_Aggregate (N : Node_Id; Typ : Entity_Id) is - Deltas : constant List_Id := Component_Associations (N); + Deltas : constant List_Id := Component_Associations (N); + Index_Type : constant Entity_Id := Etype (First_Index (Typ)); - Assoc : Node_Id; - Choice : Node_Id; - Index_Type : Entity_Id; + Assoc : Node_Id; + Choice : Node_Id; + Expr : Node_Id; begin - Index_Type := Etype (First_Index (Typ)); - Assoc := First (Deltas); while Present (Assoc) loop if Nkind (Assoc) = N_Iterated_Component_Association then @@ -2693,17 +3088,21 @@ package body Sem_Aggr is begin Set_Etype (Ent, Standard_Void_Type); Set_Parent (Ent, Assoc); + Push_Scope (Ent); if No (Scope (Id)) then - Enter_Name (Id); Set_Etype (Id, Index_Type); Set_Ekind (Id, E_Variable); Set_Scope (Id, Ent); end if; + Enter_Name (Id); - Push_Scope (Ent); - Analyze_And_Resolve - (New_Copy_Tree (Expression (Assoc)), Component_Type (Typ)); + -- Resolve a copy of the expression, after setting + -- its parent properly to preserve its context. + + Expr := New_Copy_Tree (Expression (Assoc)); + Set_Parent (Expr, Assoc); + Analyze_And_Resolve (Expr, Component_Type (Typ)); End_Scope; end; @@ -2726,7 +3125,7 @@ package body Sem_Aggr is Base_Type (Index_Type) then Error_Msg_NE - ("choice does mat match index type of", + ("choice does not match index type of &", Choice, Typ); end if; else @@ -2761,9 +3160,9 @@ package body Sem_Aggr is -- 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 Get_Component (Nam : Node_Id) return Entity_Id; + -- Locate component with a given name and return it. If none found then + -- report error and return Empty. function Nested_In (V1 : Node_Id; V2 : Node_Id) return Boolean; -- Determine whether variant V1 is within variant V2 @@ -2827,11 +3226,11 @@ package body Sem_Aggr is end if; end Check_Variant; - ------------------------ - -- Get_Component_Type -- - ------------------------ + ------------------- + -- Get_Component -- + ------------------- - function Get_Component_Type (Nam : Node_Id) return Entity_Id is + function Get_Component (Nam : Node_Id) return Entity_Id is Comp : Entity_Id; begin @@ -2842,15 +3241,15 @@ package body Sem_Aggr is Error_Msg_N ("delta cannot apply to discriminant", Nam); end if; - return Etype (Comp); + return Comp; end if; Next_Entity (Comp); end loop; Error_Msg_NE ("type& has no component with this name", Nam, Typ); - return Any_Type; - end Get_Component_Type; + return Empty; + end Get_Component; --------------- -- Nested_In -- @@ -2897,6 +3296,7 @@ package body Sem_Aggr is Assoc : Node_Id; Choice : Node_Id; + Comp : Entity_Id; Comp_Type : Entity_Id := Empty; -- init to avoid warning -- Start of processing for Resolve_Delta_Record_Aggregate @@ -2908,10 +3308,21 @@ package body Sem_Aggr is while Present (Assoc) loop Choice := First (Choice_List (Assoc)); while Present (Choice) loop - Comp_Type := Get_Component_Type (Choice); + Comp := Get_Component (Choice); - if Comp_Type /= Any_Type then + if Present (Comp) then Check_Variant (Choice); + + Comp_Type := Etype (Comp); + + -- Decorate the component reference by setting its entity and + -- type, as otherwise backends like GNATprove would have to + -- rediscover this information by themselves. + + Set_Entity (Choice, Comp); + Set_Etype (Choice, Comp_Type); + else + Comp_Type := Any_Type; end if; Next (Choice); @@ -2976,9 +3387,9 @@ package body Sem_Aggr is -- The ancestor must be a call or an aggregate, but a call may -- have been expanded into a temporary, so check original node. - elsif Nkind_In (Anc, N_Aggregate, - N_Extension_Aggregate, - N_Function_Call) + elsif Nkind (Anc) in N_Aggregate + | N_Extension_Aggregate + | N_Function_Call then return True; @@ -3084,14 +3495,25 @@ package body Sem_Aggr is Analyze (A); Check_Parameterless_Call (A); - -- In SPARK, the ancestor part cannot be a type mark - if Is_Entity_Name (A) and then Is_Type (Entity (A)) then - -- AI05-0115: if the ancestor part is a subtype mark, the ancestor - -- must not have unknown discriminants. - - if Has_Unknown_Discriminants (Root_Type (Typ)) then + -- AI05-0115: If the ancestor part is a subtype mark, the ancestor + -- must not have unknown discriminants. To catch cases where the + -- aggregate occurs at a place where the full view of the ancestor + -- type is visible and doesn't have unknown discriminants, but the + -- aggregate type was derived from a partial view that has unknown + -- discriminants, we check whether the aggregate type has unknown + -- discriminants (unknown discriminants were inherited), along + -- with checking that the partial view of the ancestor has unknown + -- discriminants. (It might be sufficient to replace the entire + -- condition with Has_Unknown_Discriminants (Typ), but that might + -- miss some cases, not clear, and causes error changes in some tests + -- such as class-wide cases, that aren't clearly improvements. ???) + + if Has_Unknown_Discriminants (Entity (A)) + or else (Has_Unknown_Discriminants (Typ) + and then Partial_View_Has_Unknown_Discr (Entity (A))) + then Error_Msg_NE ("aggregate not available for type& whose ancestor " & "has unknown discriminants", N, Typ); @@ -3336,7 +3758,7 @@ package body Sem_Aggr is -- of the ancestor. function Get_Value - (Compon : Node_Id; + (Compon : Entity_Id; From : List_Id; Consider_Others_Choice : Boolean := False) return Node_Id; -- Given a record component stored in parameter Compon, this function @@ -3614,7 +4036,7 @@ package body Sem_Aggr is --------------- function Get_Value - (Compon : Node_Id; + (Compon : Entity_Id; From : List_Id; Consider_Others_Choice : Boolean := False) return Node_Id is @@ -3690,7 +4112,7 @@ package body Sem_Aggr is -- Copy the expression so that it is resolved -- independently for each component, This is needed - -- for accessibility checks on compoents of anonymous + -- for accessibility checks on components of anonymous -- access types, even in compile_only mode. if not Inside_A_Generic then @@ -3910,7 +4332,7 @@ package body Sem_Aggr is function Has_Expansion_Delayed (Expr : Node_Id) return Boolean is begin return - (Nkind_In (Expr, N_Aggregate, N_Extension_Aggregate) + (Nkind (Expr) in N_Aggregate | N_Extension_Aggregate and then Present (Etype (Expr)) and then Is_Record_Type (Etype (Expr)) and then Expansion_Delayed (Expr)) @@ -4033,7 +4455,7 @@ package body Sem_Aggr is -- If an aggregate component has a type with predicates, an explicit -- predicate check must be applied, as for an assignment statement, - -- because the aggegate might not be expanded into individual + -- because the aggregate might not be expanded into individual -- component assignments. if Has_Predicates (Expr_Type) @@ -4291,6 +4713,10 @@ package body Sem_Aggr is -- AI05-0115: if the ancestor part is a subtype mark, the ancestor -- must not have unknown discriminants. + -- ??? We are not checking any subtype mark here and this code is not + -- exercised by any test, so it's likely wrong (in particular + -- we should not use Root_Type here but the subtype mark, if any), + -- and possibly not needed. if Is_Derived_Type (Typ) and then Has_Unknown_Discriminants (Root_Type (Typ)) @@ -4752,16 +5178,28 @@ package body Sem_Aggr is end if; -- Ada 2012: If component is scalar with default value, use it + -- by converting it to Ctyp, so that subtype constraints are + -- checked. elsif Is_Scalar_Type (Ctyp) and then Has_Default_Aspect (Ctyp) then - Add_Association - (Component => Component, - Expr => - Default_Aspect_Value - (First_Subtype (Underlying_Type (Ctyp))), - Assoc_List => New_Assoc_List); + declare + Conv : constant Node_Id := + Convert_To + (Typ => Ctyp, + Expr => + New_Copy_Tree + (Default_Aspect_Value + (First_Subtype (Underlying_Type (Ctyp))))); + + begin + Analyze_And_Resolve (Conv, Ctyp); + Add_Association + (Component => Component, + Expr => Conv, + Assoc_List => New_Assoc_List); + end; elsif Has_Non_Null_Base_Init_Proc (Ctyp) or else not Expander_Active