Mercurial > hg > CbC > CbC_gcc
diff gcc/ada/sem_aggr.adb @ 145:1830386684a0
gcc-9.2.0
| author | anatofuz |
|---|---|
| date | Thu, 13 Feb 2020 11:34:05 +0900 |
| parents | 84e7813d76e9 |
| children |
line wrap: on
line diff
--- a/gcc/ada/sem_aggr.adb Thu Oct 25 07:37:49 2018 +0900 +++ b/gcc/ada/sem_aggr.adb Thu Feb 13 11:34:05 2020 +0900 @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2018, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2019, 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- -- @@ -602,6 +602,7 @@ 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); @@ -611,6 +612,23 @@ 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 @@ -876,7 +894,6 @@ procedure Resolve_Aggregate (N : Node_Id; Typ : Entity_Id) is Loc : constant Source_Ptr := Sloc (N); - Pkind : constant Node_Kind := Nkind (Parent (N)); Aggr_Subtyp : Entity_Id; -- The actual aggregate subtype. This is not necessarily the same as Typ @@ -894,7 +911,7 @@ -- 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. @@ -1061,16 +1078,17 @@ -- 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. Ditto if the context is an - -- initialization procedure where a component may have a predicate - -- function that carries the base type. + -- 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 @@ -1084,24 +1102,26 @@ 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)) + and then Nkind_In (Parent (N), + N_Parameter_Association, + N_Function_Call, + N_Procedure_Call_Statement, + N_Generic_Association, + N_Formal_Object_Declaration, + N_Simple_Return_Statement, + N_Object_Declaration, + N_Component_Declaration, + N_Parameter_Specification, + N_Qualified_Expression, + N_Reference, + N_Aggregate, + N_Extension_Aggregate, + N_Component_Association, + N_Case_Expression_Alternative, + N_If_Expression)) then Aggr_Resolved := Resolve_Array_Aggregate @@ -1627,7 +1647,7 @@ -- component assignments. If the expression covers several components -- the analysis and the predicate check take place later. - if Present (Predicate_Function (Component_Typ)) + if Has_Predicates (Component_Typ) and then Analyzed (Expr) then Apply_Predicate_Check (Expr, Component_Typ); @@ -2789,6 +2809,11 @@ 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 -gnatX", N); + end if; + if not Is_Composite_Type (Typ) then Error_Msg_N ("not a composite type", N); end if; @@ -3143,6 +3168,9 @@ 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; @@ -3184,6 +3212,13 @@ 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; @@ -4194,7 +4229,7 @@ -- because the aggegate might not be expanded into individual -- component assignments. - if Present (Predicate_Function (Expr_Type)) + if Has_Predicates (Expr_Type) and then Analyzed (Expr) then Apply_Predicate_Check (Expr, Expr_Type); @@ -4254,8 +4289,15 @@ Expr_Disc : Node_Id) is begin - if Nkind (Bound) = N_Identifier - and then Entity (Bound) = Disc + 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; @@ -4270,9 +4312,7 @@ -- Start of processing for Rewrite_Range begin - if Has_Discriminants (Root_Type) - and then Nkind (Rge) = N_Range - then + if Has_Discriminants (Root_Type) and then Nkind (Rge) = N_Range then Low := Low_Bound (Rge); High := High_Bound (Rge); @@ -4893,7 +4933,9 @@ -- Root record type whose discriminants may be used as -- bounds in range nodes. - Index : Node_Id; + Assoc : Node_Id; + Choice : Node_Id; + Index : Node_Id; begin -- Rewrite the range nodes occurring in the indexes @@ -4909,12 +4951,26 @@ end loop; -- Rewrite the range nodes occurring as aggregate - -- bounds. - - if Nkind (Expr) = N_Aggregate - and then Present (Aggregate_Bounds (Expr)) - then - Rewrite_Range (Rec_Typ, Aggregate_Bounds (Expr)); + -- 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;