X-Git-Url: https://git.libre-soc.org/?a=blobdiff_plain;f=gcc%2Fada%2Fsem_aggr.adb;h=3f96139e3225d2789101f3b73426301309ab8102;hb=02fb12801b18c9d3cfe1c29b5be9f33d2dc77e21;hp=575a1d2ea3ccf8d1ca7aa210694589d885937a2e;hpb=888be6b18a697c7f57f2f74fa8dbab058bb819ef;p=gcc.git diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 575a1d2ea3c..3f96139e322 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2020, 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- -- @@ -30,6 +30,7 @@ with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; with Expander; use Expander; +with Exp_Ch6; use Exp_Ch6; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Freeze; use Freeze; @@ -47,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; @@ -62,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 @@ -84,9 +87,8 @@ package body Sem_Aggr is -- The node of the choice end record; - type Case_Table_Type is array (Nat range <>) of Case_Bounds; - -- Table type used by Check_Case_Choices procedure. Entry zero is not - -- used (reserved for the sort). Real entries start at one. + type Case_Table_Type is array (Pos range <>) of Case_Bounds; + -- Table type used by Check_Case_Choices procedure ----------------------- -- Local Subprograms -- @@ -114,16 +116,7 @@ package body Sem_Aggr is -- 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. - - 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. - - function Is_Top_Level_Aggregate (Expr : Node_Id) return Boolean; - -- Return True of Expr is an aggregate not contained directly in another - -- aggregate. + -- have already preanalyzed and it is known to be type correct. ------------------------------------------------------ -- Subprograms used for RECORD AGGREGATE Processing -- @@ -146,9 +139,10 @@ package body Sem_Aggr is -- -- Once this new Component_Association_List is built and all the semantic -- checks performed, the original aggregate subtree is replaced with the - -- new named record aggregate just built. Note that subtree substitution is - -- performed with Rewrite so as to be able to retrieve the original - -- aggregate. + -- new named record aggregate just built. This new record aggregate has no + -- positional associations, so its Expressions field is set to No_List. + -- Note that subtree substitution is performed with Rewrite so as to be + -- able to retrieve the original aggregate. -- -- The aggregate subtree manipulation performed by Resolve_Record_Aggregate -- yields the aggregate format expected by Gigi. Typically, this kind of @@ -233,12 +227,6 @@ package body Sem_Aggr is -- misspelling of one of the components of the Assoc_List. This is called -- by Resolve_Aggr_Expr after producing an invalid component error message. - procedure Check_Static_Discriminated_Subtype (T : Entity_Id; V : Node_Id); - -- An optimization: determine whether a discriminated subtype has a static - -- constraint, and contains array components whose length is also static, - -- either because they are constrained by the discriminant, or because the - -- original component bounds are static. - ----------------------------------------------------- -- Subprograms used for ARRAY AGGREGATE Processing -- ----------------------------------------------------- @@ -417,6 +405,13 @@ package body Sem_Aggr is -- 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 -- ------------------------ @@ -457,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 @@ -594,6 +589,7 @@ package body Sem_Aggr is Set_Etype (Itype, Base_Type (Typ)); Set_Has_Alignment_Clause (Itype, Has_Alignment_Clause (Typ)); Set_Is_Aliased (Itype, Is_Aliased (Typ)); + Set_Is_Independent (Itype, Is_Independent (Typ)); Set_Depends_On_Private (Itype, Depends_On_Private (Typ)); Copy_Suppress_Status (Index_Check, Typ, Itype); @@ -603,6 +599,23 @@ package body Sem_Aggr is Set_Is_Constrained (Itype, True); Set_Is_Internal (Itype, True); + if Has_Predicates (Typ) then + Set_Has_Predicates (Itype); + + -- If the base type has a predicate, capture the predicated parent + -- or the existing predicate function for SPARK use. + + if Present (Predicate_Function (Typ)) then + Set_Predicate_Function (Itype, Predicate_Function (Typ)); + + elsif Is_Itype (Typ) then + Set_Predicated_Parent (Itype, Predicated_Parent (Typ)); + + else + Set_Predicated_Parent (Itype, Typ); + end if; + end if; + -- A simple optimization: purely positional aggregates of static -- components should be passed to gigi unexpanded whenever possible, and -- regardless of the staticness of the bounds themselves. Subsequent @@ -647,9 +660,9 @@ package body Sem_Aggr is begin -- All the components of List are matched against Component and a count - -- is maintained of possible misspellings. When at the end of the the + -- is maintained of possible misspellings. When at the end of the -- analysis there are one or two (not more) possible misspellings, - -- these misspellings will be suggested as possible correction. + -- these misspellings will be suggested as possible corrections. Component_Elmt := First_Elmt (Elements); while Nr_Of_Suggestions <= Max_Suggestions @@ -664,7 +677,7 @@ package body Sem_Aggr is case Nr_Of_Suggestions is when 1 => Suggestion_1 := Node (Component_Elmt); when 2 => Suggestion_2 := Node (Component_Elmt); - when others => exit; + when others => null; end case; end if; @@ -704,125 +717,30 @@ package body Sem_Aggr is end if; end Check_Expr_OK_In_Limited_Aggregate; - ------------------------------- - -- Check_Qualified_Aggregate -- - ------------------------------- - - procedure Check_Qualified_Aggregate (Level : Nat; Expr : Node_Id) is - Comp_Expr : Node_Id; - Comp_Assn : Node_Id; - - begin - if Level = 0 then - if Nkind (Parent (Expr)) /= N_Qualified_Expression then - Check_SPARK_05_Restriction ("aggregate should be qualified", Expr); - end if; - - else - Comp_Expr := First (Expressions (Expr)); - while Present (Comp_Expr) loop - if Nkind (Comp_Expr) = N_Aggregate then - Check_Qualified_Aggregate (Level - 1, Comp_Expr); - end if; - - Comp_Expr := Next (Comp_Expr); - end loop; - - Comp_Assn := First (Component_Associations (Expr)); - while Present (Comp_Assn) loop - Comp_Expr := Expression (Comp_Assn); - - if Nkind (Comp_Expr) = N_Aggregate then - Check_Qualified_Aggregate (Level - 1, Comp_Expr); - end if; - - Comp_Assn := Next (Comp_Assn); - end loop; - end if; - end Check_Qualified_Aggregate; - - ---------------------------------------- - -- Check_Static_Discriminated_Subtype -- - ---------------------------------------- - - procedure Check_Static_Discriminated_Subtype (T : Entity_Id; V : Node_Id) is - Disc : constant Entity_Id := First_Discriminant (T); - Comp : Entity_Id; - Ind : Entity_Id; - - begin - if Has_Record_Rep_Clause (T) then - return; - - elsif Present (Next_Discriminant (Disc)) then - return; - - elsif Nkind (V) /= N_Integer_Literal then - return; - end if; - - Comp := First_Component (T); - while Present (Comp) loop - if Is_Scalar_Type (Etype (Comp)) then - null; - - elsif Is_Private_Type (Etype (Comp)) - and then Present (Full_View (Etype (Comp))) - and then Is_Scalar_Type (Full_View (Etype (Comp))) - then - null; - - elsif Is_Array_Type (Etype (Comp)) then - if Is_Bit_Packed_Array (Etype (Comp)) then - return; - end if; - - Ind := First_Index (Etype (Comp)); - while Present (Ind) loop - if Nkind (Ind) /= N_Range - or else Nkind (Low_Bound (Ind)) /= N_Integer_Literal - or else Nkind (High_Bound (Ind)) /= N_Integer_Literal - then - return; - end if; - - Next_Index (Ind); - end loop; - - else - return; - end if; - - Next_Component (Comp); - end loop; - - -- On exit, all components have statically known sizes - - Set_Size_Known_At_Compile_Time (T); - end Check_Static_Discriminated_Subtype; - ------------------------- -- Is_Others_Aggregate -- ------------------------- function Is_Others_Aggregate (Aggr : Node_Id) return Boolean is + Assoc : constant List_Id := Component_Associations (Aggr); + begin return No (Expressions (Aggr)) - and then - Nkind (First (Choices (First (Component_Associations (Aggr))))) = - N_Others_Choice; + and then Nkind (First (Choice_List (First (Assoc)))) = N_Others_Choice; end Is_Others_Aggregate; - ---------------------------- - -- Is_Top_Level_Aggregate -- - ---------------------------- + ------------------------- + -- Is_Single_Aggregate -- + ------------------------- + + function Is_Single_Aggregate (Aggr : Node_Id) return Boolean is + Assoc : constant List_Id := Component_Associations (Aggr); - function Is_Top_Level_Aggregate (Expr : Node_Id) return Boolean is begin - return Nkind (Parent (Expr)) /= N_Aggregate - and then (Nkind (Parent (Expr)) /= N_Component_Association - or else Nkind (Parent (Parent (Expr))) /= N_Aggregate); - end Is_Top_Level_Aggregate; + return No (Expressions (Aggr)) + and then No (Next (First (Assoc))) + and then No (Next (First (Choice_List (First (Assoc))))); + end Is_Single_Aggregate; -------------------------------- -- Make_String_Into_Aggregate -- @@ -867,13 +785,39 @@ package body Sem_Aggr is ----------------------- procedure Resolve_Aggregate (N : Node_Id; Typ : Entity_Id) is - Loc : constant Source_Ptr := Sloc (N); - Pkind : constant Node_Kind := Nkind (Parent (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 @@ -886,7 +830,7 @@ package body Sem_Aggr is -- If the aggregate has box-initialized components, its type must be -- frozen so that initialization procedures can properly be called - -- in the resolution that follows. The replacement of boxes with + -- in the resolution that follows. The replacement of boxes with -- initialization calls is properly an expansion activity but it must -- be done during resolution. @@ -894,56 +838,31 @@ 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; end if; - -- An unqualified aggregate is restricted in SPARK to: - - -- An aggregate item inside an aggregate for a multi-dimensional array - - -- An expression being assigned to an unconstrained array, but only if - -- the aggregate specifies a value for OTHERS only. - - if Nkind (Parent (N)) = N_Qualified_Expression then - if Is_Array_Type (Typ) then - Check_Qualified_Aggregate (Number_Dimensions (Typ), N); - else - Check_Qualified_Aggregate (1, N); - end if; - else - if Is_Array_Type (Typ) - and then Nkind (Parent (N)) = N_Assignment_Statement - and then not Is_Constrained (Etype (Name (Parent (N)))) - then - if not Is_Others_Aggregate (N) then - Check_SPARK_05_Restriction - ("array aggregate should have only OTHERS", N); - end if; - - elsif Is_Top_Level_Aggregate (N) then - Check_SPARK_05_Restriction ("aggregate should be qualified", N); - - -- The legality of this unqualified aggregate is checked by calling - -- Check_Qualified_Aggregate from one of its enclosing aggregate, - -- unless one of these already causes an error to be issued. - - else - null; - end if; - end if; - -- Check for aggregates not allowed in configurable run-time mode. -- We allow all cases of aggregates that do not come from source, since -- these are all assumed to be small (e.g. bounds of a string literal). @@ -951,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; @@ -981,18 +901,27 @@ 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); elsif Is_Array_Type (Typ) then - -- First a special test, for the case of a positional aggregate - -- of characters which can be replaced by a string literal. + -- First a special test, for the case of a positional aggregate of + -- characters which can be replaced by a string literal. - -- Do not perform this transformation if this was a string literal to - -- start with, whose components needed constraint checks, or if the - -- component type is non-static, because it will require those checks - -- and be transformed back into an aggregate. + -- Do not perform this transformation if this was a string literal + -- to start with, whose components needed constraint checks, or if + -- the component type is non-static, because it will require those + -- checks and be transformed back into an aggregate. If the index + -- type is not Integer the aggregate may represent a user-defined + -- string type but the context might need the original type so we + -- do not perform the transformation at this point. if Number_Dimensions (Typ) = 1 and then Is_Standard_Character_Type (Component_Type (Typ)) @@ -1002,6 +931,8 @@ package body Sem_Aggr is and then not Is_Bit_Packed_Array (Typ) and then Nkind (Original_Node (Parent (N))) /= N_String_Literal and then Is_OK_Static_Subtype (Component_Type (Typ)) + and then Base_Type (Etype (First_Index (Typ))) = + Base_Type (Standard_Integer) then declare Expr : Node_Id; @@ -1048,14 +979,17 @@ package body Sem_Aggr is -- permit it, or the aggregate type is unconstrained, an OTHERS -- choice is not allowed (except that it is always allowed on the -- right-hand side of an assignment statement; in this case the - -- constrainedness of the type doesn't matter). + -- constrainedness of the type doesn't matter, because an array + -- object is always constrained). -- 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. + -- context is an assignment statement, OTHERS is allowed, because + -- the target of the assignment will have a constrained 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 @@ -1069,34 +1003,27 @@ package body Sem_Aggr is Set_Etype (N, Aggr_Typ); -- May be overridden later on - if Pkind = N_Assignment_Statement + if Nkind (Parent (N)) = 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 - Pkind = N_Generic_Association or else - Pkind = N_Formal_Object_Declaration or else - Pkind = N_Simple_Return_Statement or else - Pkind = N_Object_Declaration or else - Pkind = N_Component_Declaration or else - Pkind = N_Parameter_Specification or else - Pkind = N_Qualified_Expression or else - Pkind = N_Reference or else - Pkind = N_Aggregate or else - Pkind = N_Extension_Aggregate or else - Pkind = N_Component_Association)) - then - Aggr_Resolved := - Resolve_Array_Aggregate - (N, - Index => First_Index (Aggr_Typ), - Index_Constr => First_Index (Typ), - Component_Typ => Component_Type (Typ), - Others_Allowed => True); - - elsif not Expander_Active - and then Pkind = N_Assignment_Statement + 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 @@ -1105,7 +1032,6 @@ package body Sem_Aggr is Index_Constr => First_Index (Typ), Component_Typ => Component_Type (Typ), Others_Allowed => True); - else Aggr_Resolved := Resolve_Array_Aggregate @@ -1162,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; @@ -1192,6 +1125,11 @@ package body Sem_Aggr is Index_Base_High : constant Node_Id := Type_High_Bound (Index_Base); -- Ditto for the base type + Others_Present : Boolean := False; + + Nb_Choices : Nat := 0; + -- Contains the overall number of named choices in this sub-aggregate + function Add (Val : Uint; To : Node_Id) return Node_Id; -- Creates a new expression node where Val is added to expression To. -- Tries to constant fold whenever possible. To must be an already @@ -1233,6 +1171,11 @@ package body Sem_Aggr is -- N_Component_Association node as Expr, since there is no Expression in -- that case, and we need a Sloc for the error message. + procedure Resolve_Iterated_Component_Association + (N : Node_Id; + Index_Typ : Entity_Id); + -- For AI12-061 + --------- -- Add -- --------- @@ -1534,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 @@ -1590,7 +1533,7 @@ package body Sem_Aggr is -- unless the expression covers a single component, or the -- expander is inactive. - -- In SPARK mode, expressions that can perform side-effects will + -- In SPARK mode, expressions that can perform side effects will -- be recognized by the gnat2why back-end, and the whole -- subprogram will be ignored. So semantic analysis can be -- performed safely. @@ -1609,10 +1552,13 @@ 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 - -- component assignments. + -- 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. - if Present (Predicate_Function (Component_Typ)) then + if Has_Predicates (Component_Typ) + and then Analyzed (Expr) + then Apply_Predicate_Check (Expr, Component_Typ); end if; @@ -1635,38 +1581,161 @@ package body Sem_Aggr is return Resolution_OK; end Resolve_Aggr_Expr; - -- Variables local to Resolve_Array_Aggregate + -------------------------------------------- + -- Resolve_Iterated_Component_Association -- + -------------------------------------------- + + procedure Resolve_Iterated_Component_Association + (N : Node_Id; + 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; + + -- 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 + if Nkind (Choice) = N_Others_Choice then + Others_Present := True; + + else + 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 (Index_Typ) + then + null; + + else + Analyze_And_Resolve (Choice, Index_Typ); + end if; + end if; + + Next (Choice); + end loop; + + -- Create a scope in which to introduce an index, which is usually + -- visible in the expression for the component, and needed for its + -- 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); + + -- Insert and decorate the index variable in the current scope. + -- The expression has to be analyzed once the index variable is + -- directly visible. + + Enter_Name (Id); + Set_Etype (Id, Index_Typ); + Set_Ekind (Id, E_Variable); + Set_Scope (Id, Ent); + + -- 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 := 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. + + 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 Assoc : Node_Id; Choice : Node_Id; Expr : Node_Id; Discard : Node_Id; - Delete_Choice : Boolean; - -- Used when replacing a subtype choice with predicate by a list - Aggr_Low : Node_Id := Empty; Aggr_High : Node_Id := Empty; -- The actual low and high bounds of this sub-aggregate + Case_Table_Size : Nat; + -- Contains the size of the case table needed to sort aggregate choices + Choices_Low : Node_Id := Empty; Choices_High : Node_Id := Empty; -- The lowest and highest discrete choices values for a named aggregate + Delete_Choice : Boolean; + -- Used when replacing a subtype choice with predicate by a list + Nb_Elements : Uint := Uint_0; -- The number of elements in a positional aggregate - Others_Present : Boolean := False; - - Nb_Choices : Nat := 0; - -- Contains the overall number of named choices in this sub-aggregate - Nb_Discrete_Choices : Nat := 0; -- The overall number of discrete choices (not counting others choice) - Case_Table_Size : Nat; - -- Contains the size of the case table needed to sort aggregate choices - -- Start of processing for Resolve_Array_Aggregate begin @@ -1684,13 +1753,17 @@ package body Sem_Aggr is if Present (Component_Associations (N)) then Assoc := First (Component_Associations (N)); while Present (Assoc) loop - Choice := First (Choices (Assoc)); + if Nkind (Assoc) = N_Iterated_Component_Association then + Resolve_Iterated_Component_Association (Assoc, Index_Typ); + end if; + + Choice := First (Choice_List (Assoc)); Delete_Choice := False; while Present (Choice) loop if Nkind (Choice) = N_Others_Choice then Others_Present := True; - if Choice /= First (Choices (Assoc)) + if Choice /= First (Choice_List (Assoc)) or else Present (Next (Choice)) then Error_Msg_N @@ -1706,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); @@ -1740,6 +1813,7 @@ package body Sem_Aggr is -- If the subtype has a static predicate, replace the -- original choice with the list of individual values -- covered by the predicate. + -- This should be deferred to expansion time ??? if Present (Static_Discrete_Predicate (E)) then Delete_Choice := True; @@ -1789,7 +1863,7 @@ package body Sem_Aggr is then Error_Msg_N ("named association cannot follow positional association", - First (Choices (First (Component_Associations (N))))); + First (Choice_List (First (Component_Associations (N))))); return Failure; end if; @@ -1798,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; @@ -1818,6 +1892,25 @@ package body Sem_Aggr is end if; Step_2 : declare + function Empty_Range (A : Node_Id) return Boolean; + -- If an association covers an empty range, some warnings on the + -- expression of the association can be disabled. + + ----------------- + -- Empty_Range -- + ----------------- + + function Empty_Range (A : Node_Id) return Boolean is + R : constant Node_Id := First (Choices (A)); + begin + return No (Next (R)) + and then Nkind (R) = N_Range + and then Compile_Time_Compare + (Low_Bound (R), High_Bound (R), False) = GT; + end Empty_Range; + + -- Local variables + Low : Node_Id; High : Node_Id; -- Denote the lowest and highest values in an aggregate choice @@ -1827,9 +1920,8 @@ package body Sem_Aggr is -- if a choice in an aggregate is a subtype indication these -- denote the lowest and highest values of the subtype - Table : Case_Table_Type (0 .. Case_Table_Size); - -- Used to sort all the different choice values. Entry zero is - -- reserved for sorting purposes. + Table : Case_Table_Type (1 .. Case_Table_Size); + -- Used to sort all the different choice values Single_Choice : Boolean; -- Set to true every time there is a single discrete choice in a @@ -1842,23 +1934,6 @@ package body Sem_Aggr is Errors_Posted_On_Choices : Boolean := False; -- Keeps track of whether any choices have semantic errors - function Empty_Range (A : Node_Id) return Boolean; - -- If an association covers an empty range, some warnings on the - -- expression of the association can be disabled. - - ----------------- - -- Empty_Range -- - ----------------- - - function Empty_Range (A : Node_Id) return Boolean is - R : constant Node_Id := First (Choices (A)); - begin - return No (Next (R)) - and then Nkind (R) = N_Range - and then Compile_Time_Compare - (Low_Bound (R), High_Bound (R), False) = GT; - end Empty_Range; - -- Start of processing for Step_2 begin @@ -1867,7 +1942,8 @@ package body Sem_Aggr is Assoc := First (Component_Associations (N)); while Present (Assoc) loop Prev_Nb_Discrete_Choices := Nb_Discrete_Choices; - Choice := First (Choices (Assoc)); + Choice := First (Choice_List (Assoc)); + loop Analyze (Choice); @@ -1927,16 +2003,6 @@ package body Sem_Aggr is -- bounds of the array aggregate are within range. Set_Do_Range_Check (Choice, False); - - -- In SPARK, the choice must be static - - if not (Is_OK_Static_Expression (Choice) - or else (Nkind (Choice) = N_Range - and then Is_OK_Static_Range (Choice))) - then - Check_SPARK_05_Restriction - ("choice should be static", Choice); - end if; end if; -- If we could not resolve the discrete choice stop here @@ -2022,6 +2088,14 @@ 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 + elsif not Resolve_Aggr_Expr (Expression (Assoc), Single_Elmt => Single_Choice) then @@ -2052,8 +2126,8 @@ package body Sem_Aggr is Set_Parent (Expr, Parent (Expression (Assoc))); Analyze (Expr); - -- Compute its dimensions now, rather than at the end - -- of resolution, because in the case of multidimensional + -- Compute its dimensions now, rather than at the end of + -- resolution, because in the case of multidimensional -- aggregates subsequent expansion may lead to spurious -- errors. @@ -2532,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 := @@ -2652,31 +2726,640 @@ package body Sem_Aggr is end Resolve_Array_Aggregate; --------------------------------- - -- Resolve_Extension_Aggregate -- + -- Resolve_Container_Aggregate -- --------------------------------- - -- There are two cases to consider: + 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; - -- a) If the ancestor part is a type mark, the components needed are the - -- difference between the components of the expected type and the - -- components of the given type mark. + 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; - -- b) If the ancestor part is an expression, it must be unambiguous, and - -- once we have its type we can also compute the needed components as in - -- the previous case. In both cases, if the ancestor type is not the - -- immediate ancestor, we have to build this ancestor recursively. + -- 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. - -- In both cases, discriminants of the ancestor type do not play a role in - -- the resolution of the needed components, because inherited discriminants - -- cannot be used in a type extension. As a result we can compute - -- independently the list of components of the ancestor type and of the - -- expected type. + Key_Expr := Key_Expression (Comp); + Analyze_And_Resolve (New_Copy_Tree (Key_Expr), Key_Type); - procedure Resolve_Extension_Aggregate (N : Node_Id; Typ : Entity_Id) is - A : constant Node_Id := Ancestor_Part (N); - A_Type : Entity_Id; - I : Interp_Index; - It : Interp; + 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 -- + ----------------------------- + + procedure Resolve_Delta_Aggregate (N : Node_Id; Typ : Entity_Id) is + Base : constant Node_Id := Expression (N); + + begin + if Ada_Version < Ada_2020 then + Error_Msg_N ("delta_aggregate is an Ada 202x feature", N); + Error_Msg_N ("\compile with -gnat2020", N); + end if; + + 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); + Index_Type : constant Entity_Id := Etype (First_Index (Typ)); + + Assoc : Node_Id; + Choice : Node_Id; + Expr : Node_Id; + + begin + 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); + Push_Scope (Ent); + + if No (Scope (Id)) then + Set_Etype (Id, Index_Type); + Set_Ekind (Id, E_Variable); + Set_Scope (Id, Ent); + end if; + Enter_Name (Id); + + -- 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; + + 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 not 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 (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 + + 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 -- + ------------------- + + function Get_Component (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; + + return Comp; + end if; + + Next_Entity (Comp); + end loop; + + Error_Msg_NE ("type& has no component with this name", Nam, Typ); + return Empty; + end Get_Component; + + --------------- + -- 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 + + Deltas : constant List_Id := Component_Associations (N); + + 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 + + begin + Variant := Empty; + + Assoc := First (Deltas); + while Present (Assoc) loop + Choice := First (Choice_List (Assoc)); + while Present (Choice) loop + Comp := Get_Component (Choice); + + 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); + end loop; + + pragma Assert (Present (Comp_Type)); + Analyze_And_Resolve (Expression (Assoc), Comp_Type); + Next (Assoc); + end loop; + end Resolve_Delta_Record_Aggregate; + + --------------------------------- + -- Resolve_Extension_Aggregate -- + --------------------------------- + + -- There are two cases to consider: + + -- a) If the ancestor part is a type mark, the components needed are the + -- difference between the components of the expected type and the + -- components of the given type mark. + + -- b) If the ancestor part is an expression, it must be unambiguous, and + -- once we have its type we can also compute the needed components as in + -- the previous case. In both cases, if the ancestor type is not the + -- immediate ancestor, we have to build this ancestor recursively. + + -- In both cases, discriminants of the ancestor type do not play a role in + -- the resolution of the needed components, because inherited discriminants + -- cannot be used in a type extension. As a result we can compute + -- independently the list of components of the ancestor type and of the + -- expected type. + + procedure Resolve_Extension_Aggregate (N : Node_Id; Typ : Entity_Id) is + A : constant Node_Id := Ancestor_Part (N); + A_Type : Entity_Id; + I : Interp_Index; + It : Interp; function Valid_Limited_Ancestor (Anc : Node_Id) return Boolean; -- If the type is limited, verify that the ancestor part is a legal @@ -2687,6 +3370,11 @@ package body Sem_Aggr is -- Verify that the type of the ancestor part is a non-private ancestor -- of the expected type, which must be a type extension. + procedure Transform_BIP_Assignment (Typ : Entity_Id); + -- For an extension aggregate whose ancestor part is a build-in-place + -- call returning a nonlimited type, this is used to transform the + -- assignment to the ancestor part to use a temp. + ---------------------------- -- Valid_Limited_Ancestor -- ---------------------------- @@ -2699,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; @@ -2716,6 +3404,9 @@ package body Sem_Aggr is elsif Nkind (Anc) = N_Qualified_Expression then return Valid_Limited_Ancestor (Expression (Anc)); + elsif Nkind (Anc) = N_Raise_Expression then + return True; + else return False; end if; @@ -2757,6 +3448,13 @@ package body Sem_Aggr is then return True; + -- The parent type may be a raise expression (which is legal in + -- any expression context). + + elsif A_Type = Raise_Type then + A_Type := Etype (Imm_Type); + return True; + else Imm_Type := Etype (Base_Type (Imm_Type)); end if; @@ -2768,6 +3466,26 @@ package body Sem_Aggr is return False; end Valid_Ancestor_Type; + ------------------------------ + -- Transform_BIP_Assignment -- + ------------------------------ + + procedure Transform_BIP_Assignment (Typ : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); + Def_Id : constant Entity_Id := Make_Temporary (Loc, 'Y', A); + Obj_Decl : constant Node_Id := + Make_Object_Declaration (Loc, + Defining_Identifier => Def_Id, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Typ, Loc), + Expression => A, + Has_Init_Expression => True); + begin + Set_Etype (Def_Id, Typ); + Set_Ancestor_Part (N, New_Occurrence_Of (Def_Id, Loc)); + Insert_Action (N, Obj_Decl); + end Transform_BIP_Assignment; + -- Start of processing for Resolve_Extension_Aggregate begin @@ -2777,15 +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 - Check_SPARK_05_Restriction ("ancestor part cannot be a type mark", A); - - -- 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); @@ -2836,7 +3564,7 @@ package body Sem_Aggr is Get_First_Interp (A, I, It); while Present (It.Typ) loop - -- Only consider limited interpretations in the Ada 2005 case + -- Consider limited interpretations if Ada 2005 or higher if Is_Tagged_Type (It.Typ) and then (Ada_Version >= Ada_2005 @@ -2932,12 +3660,24 @@ package body Sem_Aggr is Error_Msg_N ("ancestor part must be statically tagged", A); else + -- We are using the build-in-place protocol, but we can't build + -- in place, because we need to call the function before + -- allocating the aggregate. Could do better for null + -- extensions, and maybe for nondiscriminated types. + -- This is wrong for limited, but those were wrong already. + + if not Is_Limited_View (A_Type) + and then Is_Build_In_Place_Function_Call (A) + then + Transform_BIP_Assignment (A_Type); + end if; + Resolve_Record_Aggregate (N, Typ); end if; end if; else - Error_Msg_N ("no unique type for this aggregate", A); + Error_Msg_N ("no unique type for this aggregate", A); end if; Check_Function_Writable_Actuals (N); @@ -2948,25 +3688,9 @@ package body Sem_Aggr is ------------------------------ procedure Resolve_Record_Aggregate (N : Node_Id; Typ : Entity_Id) is - Assoc : Node_Id; - -- N_Component_Association node belonging to the input aggregate N - - Expr : Node_Id; - Positional_Expr : Node_Id; - Component : Entity_Id; - Component_Elmt : Elmt_Id; - - Components : constant Elist_Id := New_Elmt_List; - -- Components is the list of the record components whose value must be - -- provided in the aggregate. This list does include discriminants. - New_Assoc_List : constant List_Id := New_List; - New_Assoc : Node_Id; -- New_Assoc_List is the newly built list of N_Component_Association - -- nodes. New_Assoc is one such N_Component_Association node in it. - -- Note that while Assoc and New_Assoc contain the same kind of nodes, - -- they are used to iterate over two different N_Component_Association - -- lists. + -- nodes. Others_Etype : Entity_Id := Empty; -- This variable is used to save the Etype of the last record component @@ -2979,10 +3703,9 @@ package body Sem_Aggr is -- -- This variable is updated as a side effect of function Get_Value. - Box_Node : Node_Id; + Box_Node : Node_Id := Empty; Is_Box_Present : Boolean := False; - Others_Box : Integer := 0; - + Others_Box : Natural := 0; -- Ada 2005 (AI-287): Variables used in case of default initialization -- to provide a functionality similar to Others_Etype. Box_Present -- indicates that the component takes its default initialization; @@ -2990,9 +3713,9 @@ package body Sem_Aggr is -- (which may be a sub-aggregate of a larger one) that are default- -- initialized. A value of One indicates that an others_box is present. -- Any larger value indicates that the others_box is not redundant. - -- These variables, similar to Others_Etype, are also updated as a - -- side effect of function Get_Value. - -- Box_Node is used to place a warning on a redundant others_box. + -- These variables, similar to Others_Etype, are also updated as a side + -- effect of function Get_Value. Box_Node is used to place a warning on + -- a redundant others_box. procedure Add_Association (Component : Entity_Id; @@ -3004,14 +3727,23 @@ package body Sem_Aggr is -- either New_Assoc_List, or the association being built for an inner -- aggregate. - function Discr_Present (Discr : Entity_Id) return Boolean; + procedure Add_Discriminant_Values + (New_Aggr : Node_Id; + Assoc_List : List_Id); + -- The constraint to a component may be given by a discriminant of the + -- enclosing type, in which case we have to retrieve its value, which is + -- part of the enclosing aggregate. Assoc_List provides the discriminant + -- associations of the current type or of some enclosing record. + + function Discriminant_Present (Input_Discr : Entity_Id) return Boolean; -- If aggregate N is a regular aggregate this routine will return True. - -- Otherwise, if N is an extension aggregate, Discr is a discriminant - -- whose value may already have been specified by N's ancestor part. - -- This routine checks whether this is indeed the case and if so returns - -- False, signaling that no value for Discr should appear in N's - -- aggregate part. Also, in this case, the routine appends to - -- New_Assoc_List the discriminant value specified in the ancestor part. + -- Otherwise, if N is an extension aggregate, then Input_Discr denotes + -- a discriminant whose value may already have been specified by N's + -- ancestor part. This routine checks whether this is indeed the case + -- and if so returns False, signaling that no value for Input_Discr + -- should appear in N's aggregate part. Also, in this case, the routine + -- appends to New_Assoc_List the discriminant value specified in the + -- ancestor part. -- -- If the aggregate is in a context with expansion delayed, it will be -- reanalyzed. The inherited discriminant values must not be reinserted @@ -3019,11 +3751,16 @@ package body Sem_Aggr is -- present on first analysis to build the proper subtype indications. -- The flag Inherited_Discriminant is used to prevent the re-insertion. + function Find_Private_Ancestor (Typ : Entity_Id) return Entity_Id; + -- AI05-0115: Find earlier ancestor in the derivation chain that is + -- derived from private view Typ. Whether the aggregate is legal depends + -- on the current visibility of the type as well as that of the parent + -- of the ancestor. + function Get_Value - (Compon : Node_Id; + (Compon : Entity_Id; From : List_Id; - Consider_Others_Choice : Boolean := False) - return Node_Id; + Consider_Others_Choice : Boolean := False) return Node_Id; -- Given a record component stored in parameter Compon, this function -- returns its value as it appears in the list From, which is a list -- of N_Component_Association nodes. @@ -3040,15 +3777,14 @@ package body Sem_Aggr is -- An error message is emitted if the components taking their value from -- the others choice do not have same type. - function New_Copy_Tree_And_Copy_Dimensions - (Source : Node_Id; - Map : Elist_Id := No_Elist; - New_Sloc : Source_Ptr := No_Location; - New_Scope : Entity_Id := Empty) return Node_Id; - -- Same as New_Copy_Tree (defined in Sem_Util), except that this routine - -- also copies the dimensions of Source to the returned node. + procedure Propagate_Discriminants + (Aggr : Node_Id; + Assoc_List : List_Id); + -- Nested components may themselves be discriminated types constrained + -- by outer discriminants, whose values must be captured before the + -- aggregate is expanded into assignments. - procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Node_Id); + procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Entity_Id); -- Analyzes and resolves expression Expr against the Etype of the -- Component. This routine also applies all appropriate checks to Expr. -- It finally saves a Expr in the newly created association list that @@ -3056,6 +3792,12 @@ package body Sem_Aggr is -- Parent pointer of Expr is not set then Expr was produced with a -- New_Copy_Tree or some such. + procedure Rewrite_Range (Root_Type : Entity_Id; Rge : Node_Id); + -- Rewrite a range node Rge when its bounds refer to non-stored + -- discriminants from Root_Type, to replace them with the stored + -- discriminant values. This is required in GNATprove mode, and is + -- adopted in all modes to avoid special-casing GNATprove mode. + --------------------- -- Add_Association -- --------------------- @@ -3066,48 +3808,112 @@ package body Sem_Aggr is Assoc_List : List_Id; Is_Box_Present : Boolean := False) is - Loc : Source_Ptr; Choice_List : constant List_Id := New_List; - New_Assoc : Node_Id; + Loc : Source_Ptr; + + begin + -- If this is a box association the expression is missing, so use the + -- Sloc of the aggregate itself for the new association. + + pragma Assert (Present (Expr) xor Is_Box_Present); + + if Present (Expr) then + Loc := Sloc (Expr); + else + Loc := Sloc (N); + end if; + + Append_To (Choice_List, New_Occurrence_Of (Component, Loc)); + + Append_To (Assoc_List, + Make_Component_Association (Loc, + Choices => Choice_List, + Expression => Expr, + Box_Present => Is_Box_Present)); + end Add_Association; + + ----------------------------- + -- Add_Discriminant_Values -- + ----------------------------- + + procedure Add_Discriminant_Values + (New_Aggr : Node_Id; + Assoc_List : List_Id) + is + Assoc : Node_Id; + Discr : Entity_Id; + Discr_Elmt : Elmt_Id; + Discr_Val : Node_Id; + Val : Entity_Id; + + begin + Discr := First_Discriminant (Etype (New_Aggr)); + Discr_Elmt := First_Elmt (Discriminant_Constraint (Etype (New_Aggr))); + while Present (Discr_Elmt) loop + Discr_Val := Node (Discr_Elmt); + + -- If the constraint is given by a discriminant then it is a + -- discriminant of an enclosing record, and its value has already + -- been placed in the association list. + + if Is_Entity_Name (Discr_Val) + and then Ekind (Entity (Discr_Val)) = E_Discriminant + then + Val := Entity (Discr_Val); + + Assoc := First (Assoc_List); + while Present (Assoc) loop + if Present (Entity (First (Choices (Assoc)))) + and then Entity (First (Choices (Assoc))) = Val + then + Discr_Val := Expression (Assoc); + exit; + end if; + + Next (Assoc); + end loop; + end if; - begin - -- If this is a box association the expression is missing, so - -- use the Sloc of the aggregate itself for the new association. + Add_Association + (Discr, New_Copy_Tree (Discr_Val), + Component_Associations (New_Aggr)); - if Present (Expr) then - Loc := Sloc (Expr); - else - Loc := Sloc (N); - end if; + -- If the discriminant constraint is a current instance, mark the + -- current aggregate so that the self-reference can be expanded + -- later. The constraint may refer to the subtype of aggregate, so + -- use base type for comparison. - Append (New_Occurrence_Of (Component, Loc), Choice_List); - New_Assoc := - Make_Component_Association (Loc, - Choices => Choice_List, - Expression => Expr, - Box_Present => Is_Box_Present); - Append (New_Assoc, Assoc_List); - end Add_Association; + if Nkind (Discr_Val) = N_Attribute_Reference + and then Is_Entity_Name (Prefix (Discr_Val)) + and then Is_Type (Entity (Prefix (Discr_Val))) + and then Base_Type (Etype (N)) = Entity (Prefix (Discr_Val)) + then + Set_Has_Self_Reference (N); + end if; - ------------------- - -- Discr_Present -- - ------------------- + Next_Elmt (Discr_Elmt); + Next_Discriminant (Discr); + end loop; + end Add_Discriminant_Values; + + -------------------------- + -- Discriminant_Present -- + -------------------------- - function Discr_Present (Discr : Entity_Id) return Boolean is + function Discriminant_Present (Input_Discr : Entity_Id) return Boolean is Regular_Aggr : constant Boolean := Nkind (N) /= N_Extension_Aggregate; + Ancestor_Is_Subtyp : Boolean; + Loc : Source_Ptr; Ancestor : Node_Id; + Ancestor_Typ : Entity_Id; Comp_Assoc : Node_Id; + Discr : Entity_Id; Discr_Expr : Node_Id; - - Ancestor_Typ : Entity_Id; + Discr_Val : Elmt_Id := No_Elmt; Orig_Discr : Entity_Id; - D : Entity_Id; - D_Val : Elmt_Id := No_Elmt; -- stop junk warning - - Ancestor_Is_Subtyp : Boolean; begin if Regular_Aggr then @@ -3164,51 +3970,75 @@ package body Sem_Aggr is -- Now look to see if Discr was specified in the ancestor part if Ancestor_Is_Subtyp then - D_Val := First_Elmt (Discriminant_Constraint (Entity (Ancestor))); + Discr_Val := + First_Elmt (Discriminant_Constraint (Entity (Ancestor))); end if; - Orig_Discr := Original_Record_Component (Discr); + Orig_Discr := Original_Record_Component (Input_Discr); - D := First_Discriminant (Ancestor_Typ); - while Present (D) loop + Discr := First_Discriminant (Ancestor_Typ); + while Present (Discr) loop -- If Ancestor has already specified Disc value then insert its -- value in the final aggregate. - if Original_Record_Component (D) = Orig_Discr then + if Original_Record_Component (Discr) = Orig_Discr then if Ancestor_Is_Subtyp then - Discr_Expr := New_Copy_Tree (Node (D_Val)); + Discr_Expr := New_Copy_Tree (Node (Discr_Val)); else Discr_Expr := Make_Selected_Component (Loc, Prefix => Duplicate_Subexpr (Ancestor), - Selector_Name => New_Occurrence_Of (Discr, Loc)); + Selector_Name => New_Occurrence_Of (Input_Discr, Loc)); end if; - Resolve_Aggr_Expr (Discr_Expr, Discr); + Resolve_Aggr_Expr (Discr_Expr, Input_Discr); Set_Inherited_Discriminant (Last (New_Assoc_List)); return False; end if; - Next_Discriminant (D); + Next_Discriminant (Discr); if Ancestor_Is_Subtyp then - Next_Elmt (D_Val); + Next_Elmt (Discr_Val); end if; end loop; return True; - end Discr_Present; + end Discriminant_Present; + + --------------------------- + -- Find_Private_Ancestor -- + --------------------------- + + function Find_Private_Ancestor (Typ : Entity_Id) return Entity_Id is + Par : Entity_Id; + + begin + Par := Typ; + loop + if Has_Private_Ancestor (Par) + and then not Has_Private_Ancestor (Etype (Base_Type (Par))) + then + return Par; + + elsif not Is_Derived_Type (Par) then + return Empty; + + else + Par := Etype (Base_Type (Par)); + end if; + end loop; + end Find_Private_Ancestor; --------------- -- Get_Value -- --------------- function Get_Value - (Compon : Node_Id; + (Compon : Entity_Id; From : List_Id; - Consider_Others_Choice : Boolean := False) - return Node_Id + Consider_Others_Choice : Boolean := False) return Node_Id is Typ : constant Entity_Id := Etype (Compon); Assoc : Node_Id; @@ -3234,7 +4064,7 @@ package body Sem_Aggr is -- This is redundant if the others_choice covers only -- one component (small optimization possible???), but -- indispensable otherwise, because each one must be - -- expanded individually to preserve side-effects. + -- expanded individually to preserve side effects. -- Ada 2005 (AI-287): In case of default initialization -- of components, we duplicate the corresponding default @@ -3273,35 +4103,22 @@ package body Sem_Aggr is null; else Error_Msg_N - ("components in OTHERS choice must " - & "have same type", Selector_Name); + ("components in OTHERS choice must have same " + & "type", Selector_Name); end if; end if; Others_Etype := Typ; - -- Copy expression so that it is resolved + -- 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 - - -- In ASIS mode, preanalyze the expression in an - -- others association before making copies for - -- separate resolution and accessibility checks. - -- This ensures that the type of the expression is - -- available to ASIS in all cases, in particular if - -- the expression is itself an aggregate. - - if ASIS_Mode then - Preanalyze_And_Resolve (Expression (Assoc), Typ); - end if; - return New_Copy_Tree_And_Copy_Dimensions (Expression (Assoc)); - else return Expression (Assoc); end if; @@ -3401,44 +4218,135 @@ package body Sem_Aggr is return Expr; end Get_Value; - --------------------------------------- - -- New_Copy_Tree_And_Copy_Dimensions -- - --------------------------------------- + ----------------------------- + -- Propagate_Discriminants -- + ----------------------------- - function New_Copy_Tree_And_Copy_Dimensions - (Source : Node_Id; - Map : Elist_Id := No_Elist; - New_Sloc : Source_Ptr := No_Location; - New_Scope : Entity_Id := Empty) return Node_Id + procedure Propagate_Discriminants + (Aggr : Node_Id; + Assoc_List : List_Id) is - New_Copy : constant Node_Id := - New_Copy_Tree (Source, Map, New_Sloc, New_Scope); + Loc : constant Source_Ptr := Sloc (N); + + procedure Process_Component (Comp : Entity_Id); + -- Add one component with a box association to the inner aggregate, + -- and recurse if component is itself composite. + + ----------------------- + -- Process_Component -- + ----------------------- + + procedure Process_Component (Comp : Entity_Id) is + T : constant Entity_Id := Etype (Comp); + New_Aggr : Node_Id; + + begin + if Is_Record_Type (T) and then Has_Discriminants (T) then + New_Aggr := Make_Aggregate (Loc, No_List, New_List); + Set_Etype (New_Aggr, T); + + Add_Association + (Comp, New_Aggr, Component_Associations (Aggr)); + + -- Collect discriminant values and recurse + + Add_Discriminant_Values (New_Aggr, Assoc_List); + Propagate_Discriminants (New_Aggr, Assoc_List); + + Build_Constrained_Itype + (New_Aggr, T, Component_Associations (New_Aggr)); + else + Add_Association + (Comp, Empty, Component_Associations (Aggr), + Is_Box_Present => True); + end if; + end Process_Component; + + -- Local variables + + Aggr_Type : constant Entity_Id := Base_Type (Etype (Aggr)); + Components : constant Elist_Id := New_Elmt_List; + Def_Node : constant Node_Id := + Type_Definition (Declaration_Node (Aggr_Type)); + + Comp : Node_Id; + Comp_Elmt : Elmt_Id; + Errors : Boolean; + + -- Start of processing for Propagate_Discriminants begin - -- Move the dimensions of Source to New_Copy + -- The component type may be a variant type. Collect the components + -- that are ruled by the known values of the discriminants. Their + -- values have already been inserted into the component list of the + -- current aggregate. + + if Nkind (Def_Node) = N_Record_Definition + and then Present (Component_List (Def_Node)) + and then Present (Variant_Part (Component_List (Def_Node))) + then + Gather_Components (Aggr_Type, + Component_List (Def_Node), + Governed_By => Component_Associations (Aggr), + Into => Components, + Report_Errors => Errors); + + Comp_Elmt := First_Elmt (Components); + while Present (Comp_Elmt) loop + if Ekind (Node (Comp_Elmt)) /= E_Discriminant then + Process_Component (Node (Comp_Elmt)); + end if; - Copy_Dimensions (Source, New_Copy); - return New_Copy; - end New_Copy_Tree_And_Copy_Dimensions; + Next_Elmt (Comp_Elmt); + end loop; + + -- No variant part, iterate over all components + + else + Comp := First_Component (Etype (Aggr)); + while Present (Comp) loop + Process_Component (Comp); + Next_Component (Comp); + end loop; + end if; + end Propagate_Discriminants; ----------------------- -- Resolve_Aggr_Expr -- ----------------------- - procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Node_Id) is - Expr_Type : Entity_Id := Empty; - New_C : Entity_Id := Component; - New_Expr : Node_Id; - + procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Entity_Id) is function Has_Expansion_Delayed (Expr : Node_Id) return Boolean; -- If the expression is an aggregate (possibly qualified) then its -- expansion is delayed until the enclosing aggregate is expanded -- into assignments. In that case, do not generate checks on the -- expression, because they will be generated later, and will other- - -- wise force a copy (to remove side-effects) that would leave a + -- wise force a copy (to remove side effects) that would leave a -- dynamic-sized aggregate in the code, something that gigi cannot -- handle. + --------------------------- + -- Has_Expansion_Delayed -- + --------------------------- + + function Has_Expansion_Delayed (Expr : Node_Id) return Boolean is + begin + return + (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)) + or else + (Nkind (Expr) = N_Qualified_Expression + and then Has_Expansion_Delayed (Expression (Expr))); + end Has_Expansion_Delayed; + + -- Local variables + + Expr_Type : Entity_Id := Empty; + New_C : Entity_Id := Component; + New_Expr : Node_Id; + Relocate : Boolean; -- Set to True if the resolved Expr node needs to be relocated when -- attached to the newly created association list. This node need not @@ -3448,21 +4356,6 @@ package body Sem_Aggr is -- aggregate and hence it needs to be relocated when moved over to -- the new association list. - --------------------------- - -- Has_Expansion_Delayed -- - --------------------------- - - function Has_Expansion_Delayed (Expr : Node_Id) return Boolean is - Kind : constant Node_Kind := Nkind (Expr); - begin - return (Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate) - and then Present (Etype (Expr)) - and then Is_Record_Type (Etype (Expr)) - and then Expansion_Delayed (Expr)) - or else (Kind = N_Qualified_Expression - and then Has_Expansion_Delayed (Expression (Expr))); - end Has_Expansion_Delayed; - -- Start of processing for Resolve_Aggr_Expr begin @@ -3562,10 +4455,12 @@ 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 Present (Predicate_Function (Expr_Type)) then + if Has_Predicates (Expr_Type) + and then Analyzed (Expr) + then Apply_Predicate_Check (Expr, Expr_Type); end if; @@ -3583,6 +4478,8 @@ package body Sem_Aggr is Generate_Range_Check (Expr, Expr_Type, CE_Range_Check_Failed); end if; + -- Add association Component => Expr if the caller requests it + if Relocate then New_Expr := Relocate_Node (Expr); @@ -3598,6 +4495,78 @@ package body Sem_Aggr is Add_Association (New_C, New_Expr, New_Assoc_List); end Resolve_Aggr_Expr; + ------------------- + -- Rewrite_Range -- + ------------------- + + procedure Rewrite_Range (Root_Type : Entity_Id; Rge : Node_Id) is + procedure Rewrite_Bound + (Bound : Node_Id; + Disc : Entity_Id; + Expr_Disc : Node_Id); + -- Rewrite a bound of the range Bound, when it is equal to the + -- non-stored discriminant Disc, into the stored discriminant + -- value Expr_Disc. + + ------------------- + -- Rewrite_Bound -- + ------------------- + + procedure Rewrite_Bound + (Bound : Node_Id; + Disc : Entity_Id; + Expr_Disc : Node_Id) + is + begin + if Nkind (Bound) /= N_Identifier then + return; + end if; + + -- We expect either the discriminant or the discriminal + + if Entity (Bound) = Disc + or else (Ekind (Entity (Bound)) = E_In_Parameter + and then Discriminal_Link (Entity (Bound)) = Disc) + then + Rewrite (Bound, New_Copy_Tree (Expr_Disc)); + end if; + end Rewrite_Bound; + + -- Local variables + + Low, High : Node_Id; + Disc : Entity_Id; + Expr_Disc : Elmt_Id; + + -- Start of processing for Rewrite_Range + + begin + if Has_Discriminants (Root_Type) and then Nkind (Rge) = N_Range then + Low := Low_Bound (Rge); + High := High_Bound (Rge); + + Disc := First_Discriminant (Root_Type); + Expr_Disc := First_Elmt (Stored_Constraint (Etype (N))); + while Present (Disc) loop + Rewrite_Bound (Low, Disc, Node (Expr_Disc)); + Rewrite_Bound (High, Disc, Node (Expr_Disc)); + Next_Discriminant (Disc); + Next_Elmt (Expr_Disc); + end loop; + end if; + end Rewrite_Range; + + -- Local variables + + Components : constant Elist_Id := New_Elmt_List; + -- Components is the list of the record components whose value must be + -- provided in the aggregate. This list does include discriminants. + + Component : Entity_Id; + Component_Elmt : Elmt_Id; + Expr : Node_Id; + Positional_Expr : Node_Id; + -- Start of processing for Resolve_Record_Aggregate begin @@ -3610,31 +4579,20 @@ package body Sem_Aggr is if Present (Component_Associations (N)) and then Present (First (Component_Associations (N))) then - - if Present (Expressions (N)) then - Check_SPARK_05_Restriction - ("named association cannot follow positional one", - First (Choices (First (Component_Associations (N))))); - end if; - declare Assoc : Node_Id; begin Assoc := First (Component_Associations (N)); while Present (Assoc) loop - if List_Length (Choices (Assoc)) > 1 then - Check_SPARK_05_Restriction - ("component association in record aggregate must " - & "contain a single choice", Assoc); - end if; - - if Nkind (First (Choices (Assoc))) = N_Others_Choice then - Check_SPARK_05_Restriction - ("record aggregate cannot contain OTHERS", Assoc); + if Nkind (Assoc) = N_Iterated_Component_Association then + Error_Msg_N + ("iterated component association can only appear in an " + & "array aggregate", N); + raise Unrecoverable_Error; end if; - Assoc := Next (Assoc); + Next (Assoc); end loop; end; end if; @@ -3681,8 +4639,9 @@ package body Sem_Aggr is -- STEP 2: Verify aggregate structure Step_2 : declare - Selector_Name : Node_Id; + Assoc : Node_Id; Bad_Aggregate : Boolean := False; + Selector_Name : Node_Id; begin if Present (Component_Associations (N)) then @@ -3754,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)) @@ -3777,7 +4740,7 @@ package body Sem_Aggr is -- First find the discriminant values in the positional components while Present (Discrim) and then Present (Positional_Expr) loop - if Discr_Present (Discrim) then + if Discriminant_Present (Discrim) then Resolve_Aggr_Expr (Positional_Expr, Discrim); -- Ada 2005 (AI-231) @@ -3805,7 +4768,7 @@ package body Sem_Aggr is while Present (Discrim) loop Expr := Get_Value (Discrim, Component_Associations (N), True); - if not Discr_Present (Discrim) then + if not Discriminant_Present (Discrim) then if Present (Expr) then Error_Msg_NE ("more than one value supplied for discriminant &", @@ -3835,73 +4798,11 @@ package body Sem_Aggr is -- STEP 4: Set the Etype of the record aggregate - -- ??? This code is pretty much a copy of Sem_Ch3.Build_Subtype. That - -- routine should really be exported in sem_util or some such and used - -- in sem_ch3 and here rather than have a copy of the code which is a - -- maintenance nightmare. - - -- ??? Performance WARNING. The current implementation creates a new - -- itype for all aggregates whose base type is discriminated. This means - -- that for record aggregates nested inside an array aggregate we will - -- create a new itype for each record aggregate if the array component - -- type has discriminants. For large aggregates this may be a problem. - -- What should be done in this case is to reuse itypes as much as - -- possible. - if Has_Discriminants (Typ) or else (Has_Unknown_Discriminants (Typ) and then Present (Underlying_Record_View (Typ))) then - Build_Constrained_Itype : declare - Loc : constant Source_Ptr := Sloc (N); - Indic : Node_Id; - Subtyp_Decl : Node_Id; - Def_Id : Entity_Id; - - C : constant List_Id := New_List; - - begin - New_Assoc := First (New_Assoc_List); - while Present (New_Assoc) loop - Append (Duplicate_Subexpr (Expression (New_Assoc)), To => C); - Next (New_Assoc); - end loop; - - if Has_Unknown_Discriminants (Typ) - and then Present (Underlying_Record_View (Typ)) - then - Indic := - Make_Subtype_Indication (Loc, - Subtype_Mark => - New_Occurrence_Of (Underlying_Record_View (Typ), Loc), - Constraint => - Make_Index_Or_Discriminant_Constraint (Loc, C)); - else - Indic := - Make_Subtype_Indication (Loc, - Subtype_Mark => - New_Occurrence_Of (Base_Type (Typ), Loc), - Constraint => - Make_Index_Or_Discriminant_Constraint (Loc, C)); - end if; - - Def_Id := Create_Itype (Ekind (Typ), N); - - Subtyp_Decl := - Make_Subtype_Declaration (Loc, - Defining_Identifier => Def_Id, - Subtype_Indication => Indic); - Set_Parent (Subtyp_Decl, Parent (N)); - - -- Itypes must be analyzed with checks off (see itypes.ads) - - Analyze (Subtyp_Decl, Suppress => All_Checks); - - Set_Etype (N, Def_Id); - Check_Static_Discriminated_Subtype - (Def_Id, Expression (First (New_Assoc_List))); - end Build_Constrained_Itype; - + Build_Constrained_Itype (N, Typ, New_Assoc_List); else Set_Etype (N, Typ); end if; @@ -3909,45 +4810,13 @@ package body Sem_Aggr is -- STEP 5: Get remaining components according to discriminant values Step_5 : declare + Dnode : Node_Id; + Errors_Found : Boolean := False; Record_Def : Node_Id; Parent_Typ : Entity_Id; - Root_Typ : Entity_Id; Parent_Typ_List : Elist_Id; Parent_Elmt : Elmt_Id; - Errors_Found : Boolean := False; - Dnode : Node_Id; - - function Find_Private_Ancestor return Entity_Id; - -- AI05-0115: Find earlier ancestor in the derivation chain that is - -- derived from a private view. Whether the aggregate is legal - -- depends on the current visibility of the type as well as that - -- of the parent of the ancestor. - - --------------------------- - -- Find_Private_Ancestor -- - --------------------------- - - function Find_Private_Ancestor return Entity_Id is - Par : Entity_Id; - - begin - Par := Typ; - loop - if Has_Private_Ancestor (Par) - and then not Has_Private_Ancestor (Etype (Base_Type (Par))) - then - return Par; - - elsif not Is_Derived_Type (Par) then - return Empty; - - else - Par := Etype (Base_Type (Par)); - end if; - end loop; - end Find_Private_Ancestor; - - -- Start of processing for Step_5 + Root_Typ : Entity_Id; begin if Is_Derived_Type (Typ) and then Is_Tagged_Type (Typ) then @@ -3962,19 +4831,20 @@ package body Sem_Aggr is Root_Typ := Base_Type (Etype (Ancestor_Part (N))); else - -- AI05-0115: check legality of aggregate for type with - -- aa private ancestor. + -- AI05-0115: check legality of aggregate for type with a + -- private ancestor. Root_Typ := Root_Type (Typ); if Has_Private_Ancestor (Typ) then declare Ancestor : constant Entity_Id := - Find_Private_Ancestor; + Find_Private_Ancestor (Typ); Ancestor_Unit : constant Entity_Id := - Cunit_Entity (Get_Source_Unit (Ancestor)); + Cunit_Entity + (Get_Source_Unit (Ancestor)); Parent_Unit : constant Entity_Id := - Cunit_Entity - (Get_Source_Unit (Base_Type (Etype (Ancestor)))); + Cunit_Entity (Get_Source_Unit + (Base_Type (Etype (Ancestor)))); begin -- Check whether we are in a scope that has full view -- over the private ancestor and its parent. This can @@ -4192,8 +5062,7 @@ package body Sem_Aggr is -- object of the aggregate. if Present (Parent (Component)) - and then - Nkind (Parent (Component)) = N_Component_Declaration + and then Nkind (Parent (Component)) = N_Component_Declaration and then Present (Expression (Parent (Component))) then Expr := @@ -4202,6 +5071,61 @@ package body Sem_Aggr is New_Scope => Current_Scope, New_Sloc => Sloc (N)); + -- As the type of the copied default expression may refer + -- to discriminants of the record type declaration, these + -- non-stored discriminants need to be rewritten into stored + -- discriminant values for the aggregate. This is required + -- in GNATprove mode, and is adopted in all modes to avoid + -- special-casing GNATprove mode. + + if Is_Array_Type (Etype (Expr)) then + declare + Rec_Typ : constant Entity_Id := Scope (Component); + -- Root record type whose discriminants may be used as + -- bounds in range nodes. + + Assoc : Node_Id; + Choice : Node_Id; + Index : Node_Id; + + begin + -- Rewrite the range nodes occurring in the indexes + -- and their types. + + Index := First_Index (Etype (Expr)); + while Present (Index) loop + Rewrite_Range (Rec_Typ, Index); + Rewrite_Range + (Rec_Typ, Scalar_Range (Etype (Index))); + + Next_Index (Index); + end loop; + + -- Rewrite the range nodes occurring as aggregate + -- bounds and component associations. + + if Nkind (Expr) = N_Aggregate then + if Present (Aggregate_Bounds (Expr)) then + Rewrite_Range (Rec_Typ, Aggregate_Bounds (Expr)); + end if; + + if Present (Component_Associations (Expr)) then + Assoc := First (Component_Associations (Expr)); + while Present (Assoc) loop + Choice := First (Choices (Assoc)); + while Present (Choice) loop + Rewrite_Range (Rec_Typ, Choice); + + Next (Choice); + end loop; + + Next (Assoc); + end loop; + end if; + end if; + end; + end if; + Add_Association (Component => Component, Expr => Expr, @@ -4216,26 +5140,18 @@ package body Sem_Aggr is elsif Present (Underlying_Type (Ctyp)) and then Is_Access_Type (Underlying_Type (Ctyp)) then - if not Is_Private_Type (Ctyp) then - Expr := Make_Null (Sloc (N)); - Set_Etype (Expr, Ctyp); - Add_Association - (Component => Component, - Expr => Expr, - Assoc_List => New_Assoc_List); - -- If the component's type is private with an access type as -- its underlying type then we have to create an unchecked -- conversion to satisfy type checking. - else + if Is_Private_Type (Ctyp) then declare Qual_Null : constant Node_Id := Make_Qualified_Expression (Sloc (N), Subtype_Mark => New_Occurrence_Of (Underlying_Type (Ctyp), Sloc (N)), - Expression => Make_Null (Sloc (N))); + Expression => Make_Null (Sloc (N))); Convert_Null : constant Node_Id := Unchecked_Convert_To @@ -4248,18 +5164,42 @@ package body Sem_Aggr is Expr => Convert_Null, Assoc_List => New_Assoc_List); end; + + -- Otherwise the component type is non-private + + else + Expr := Make_Null (Sloc (N)); + Set_Etype (Expr, Ctyp); + + Add_Association + (Component => Component, + Expr => Expr, + Assoc_List => New_Assoc_List); 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 @@ -4273,8 +5213,8 @@ package body Sem_Aggr is -- for the rest, if other components are present. -- The type of the aggregate is the known subtype of - -- the component. The capture of discriminants must - -- be recursive because subcomponents may be constrained + -- the component. The capture of discriminants must be + -- recursive because subcomponents may be constrained -- (transitively) by discriminants of enclosing types. -- For a private type with discriminants, a call to the -- initialization procedure will be generated, and no @@ -4284,208 +5224,8 @@ package body Sem_Aggr is Loc : constant Source_Ptr := Sloc (N); Expr : Node_Id; - procedure Add_Discriminant_Values - (New_Aggr : Node_Id; - Assoc_List : List_Id); - -- The constraint to a component may be given by a - -- discriminant of the enclosing type, in which case - -- we have to retrieve its value, which is part of the - -- enclosing aggregate. Assoc_List provides the - -- discriminant associations of the current type or - -- of some enclosing record. - - procedure Propagate_Discriminants - (Aggr : Node_Id; - Assoc_List : List_Id); - -- Nested components may themselves be discriminated - -- types constrained by outer discriminants, whose - -- values must be captured before the aggregate is - -- expanded into assignments. - - ----------------------------- - -- Add_Discriminant_Values -- - ----------------------------- - - procedure Add_Discriminant_Values - (New_Aggr : Node_Id; - Assoc_List : List_Id) - is - Assoc : Node_Id; - Discr : Entity_Id; - Discr_Elmt : Elmt_Id; - Discr_Val : Node_Id; - Val : Entity_Id; - - begin - Discr := First_Discriminant (Etype (New_Aggr)); - Discr_Elmt := - First_Elmt - (Discriminant_Constraint (Etype (New_Aggr))); - while Present (Discr_Elmt) loop - Discr_Val := Node (Discr_Elmt); - - -- If the constraint is given by a discriminant - -- it is a discriminant of an enclosing record, - -- and its value has already been placed in the - -- association list. - - if Is_Entity_Name (Discr_Val) - and then - Ekind (Entity (Discr_Val)) = E_Discriminant - then - Val := Entity (Discr_Val); - - Assoc := First (Assoc_List); - while Present (Assoc) loop - if Present - (Entity (First (Choices (Assoc)))) - and then - Entity (First (Choices (Assoc))) = Val - then - Discr_Val := Expression (Assoc); - exit; - end if; - - Next (Assoc); - end loop; - end if; - - Add_Association - (Discr, New_Copy_Tree (Discr_Val), - Component_Associations (New_Aggr)); - - -- If the discriminant constraint is a current - -- instance, mark the current aggregate so that - -- the self-reference can be expanded later. - -- The constraint may refer to the subtype of - -- aggregate, so use base type for comparison. - - if Nkind (Discr_Val) = N_Attribute_Reference - and then Is_Entity_Name (Prefix (Discr_Val)) - and then Is_Type (Entity (Prefix (Discr_Val))) - and then Base_Type (Etype (N)) = - Entity (Prefix (Discr_Val)) - then - Set_Has_Self_Reference (N); - end if; - - Next_Elmt (Discr_Elmt); - Next_Discriminant (Discr); - end loop; - end Add_Discriminant_Values; - - ----------------------------- - -- Propagate_Discriminants -- - ----------------------------- - - procedure Propagate_Discriminants - (Aggr : Node_Id; - Assoc_List : List_Id) - is - Aggr_Type : constant Entity_Id := - Base_Type (Etype (Aggr)); - Def_Node : constant Node_Id := - Type_Definition - (Declaration_Node (Aggr_Type)); - - Comp : Node_Id; - Comp_Elmt : Elmt_Id; - Components : constant Elist_Id := New_Elmt_List; - Needs_Box : Boolean := False; - Errors : Boolean; - - procedure Process_Component (Comp : Entity_Id); - -- Add one component with a box association to the - -- inner aggregate, and recurse if component is - -- itself composite. - - ----------------------- - -- Process_Component -- - ----------------------- - - procedure Process_Component (Comp : Entity_Id) is - T : constant Entity_Id := Etype (Comp); - New_Aggr : Node_Id; - - begin - if Is_Record_Type (T) - and then Has_Discriminants (T) - then - New_Aggr := - Make_Aggregate (Loc, New_List, New_List); - Set_Etype (New_Aggr, T); - Add_Association - (Comp, New_Aggr, - Component_Associations (Aggr)); - - -- Collect discriminant values and recurse - - Add_Discriminant_Values - (New_Aggr, Assoc_List); - Propagate_Discriminants - (New_Aggr, Assoc_List); - - else - Needs_Box := True; - end if; - end Process_Component; - - -- Start of processing for Propagate_Discriminants - - begin - -- The component type may be a variant type, so - -- collect the components that are ruled by the - -- known values of the discriminants. Their values - -- have already been inserted into the component - -- list of the current aggregate. - - if Nkind (Def_Node) = N_Record_Definition - and then Present (Component_List (Def_Node)) - and then - Present - (Variant_Part (Component_List (Def_Node))) - then - Gather_Components (Aggr_Type, - Component_List (Def_Node), - Governed_By => Component_Associations (Aggr), - Into => Components, - Report_Errors => Errors); - - Comp_Elmt := First_Elmt (Components); - while Present (Comp_Elmt) loop - if Ekind (Node (Comp_Elmt)) /= - E_Discriminant - then - Process_Component (Node (Comp_Elmt)); - end if; - - Next_Elmt (Comp_Elmt); - end loop; - - -- No variant part, iterate over all components - - else - Comp := First_Component (Etype (Aggr)); - while Present (Comp) loop - Process_Component (Comp); - Next_Component (Comp); - end loop; - end if; - - if Needs_Box then - Append_To (Component_Associations (Aggr), - Make_Component_Association (Loc, - Choices => - New_List (Make_Others_Choice (Loc)), - Expression => Empty, - Box_Present => True)); - end if; - end Propagate_Discriminants; - - -- Start of processing for Capture_Discriminants - begin - Expr := Make_Aggregate (Loc, New_List, New_List); + Expr := Make_Aggregate (Loc, No_List, New_List); Set_Etype (Expr, Ctyp); -- If the enclosing type has discriminants, they have @@ -4501,9 +5241,12 @@ package body Sem_Aggr is elsif Has_Discriminants (Ctyp) then Add_Discriminant_Values - (Expr, Component_Associations (Expr)); + (Expr, Component_Associations (Expr)); Propagate_Discriminants - (Expr, Component_Associations (Expr)); + (Expr, Component_Associations (Expr)); + + Build_Constrained_Itype + (Expr, Ctyp, Component_Associations (Expr)); else declare @@ -4526,6 +5269,7 @@ package body Sem_Aggr is Expression => Empty, Box_Present => True)); end if; + exit; end if; @@ -4540,6 +5284,9 @@ package body Sem_Aggr is Assoc_List => New_Assoc_List); end Capture_Discriminants; + -- Otherwise the component type is not a record, or it has + -- not discriminants, or it is private. + else Add_Association (Component => Component, @@ -4579,6 +5326,9 @@ package body Sem_Aggr is -- STEP 7: check for invalid components + check type in choice list Step_7 : declare + Assoc : Node_Id; + New_Assoc : Node_Id; + Selectr : Node_Id; -- Selector name @@ -4654,7 +5404,7 @@ package body Sem_Aggr is if Nkind (N) /= N_Extension_Aggregate or else Scope (Original_Record_Component (C)) /= - Etype (Ancestor_Part (N)) + Etype (Ancestor_Part (N)) then exit; end if; @@ -4753,8 +5503,9 @@ package body Sem_Aggr is when E_Array_Type => Comp_Typ := Component_Type (Typ); - when E_Component | - E_Discriminant => + when E_Component + | E_Discriminant + => Comp_Typ := Etype (Typ); when others =>