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

comparison 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

comparison

equal deleted inserted replaced

-:84e7813d76e9
+:1830386684a0
 --                                                                          --
 --                             S E M _ A G G R                              --
 --                                                                          --
 --                                 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- --
 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
 Set_Convention             (Itype, Convention            (Typ));
 Set_Depends_On_Private     (Itype, Has_Private_Component (Typ));
 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);
 Copy_Suppress_Status (Length_Check, Typ, Itype);
 Set_First_Index    (Itype, First (Index_Constraints));
 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
 --  checks in exp_aggr verify that type is not packed, etc.
 -- Resolve_Aggregate --
 -----------------------
 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
 --  which is the subtype of the context in which the aggregate was found.
 return;
 end if;
 --  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.
 if Expander_Active
 and then Present (Component_Associations (N))
 --  allowed inside the array aggregate. The test checks the context
 --  in which the array aggregate occurs. If the context does not
 --  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,
+--  context is an assignment statement, OTHERS is allowed, because
---  because the target of the assignment will have a constrained
+--  the target of the assignment will have a constrained subtype
---  subtype when fully compiled. Ditto if the context is an
+--  when fully compiled. Ditto if the context is an initialization
---  initialization procedure where a component may have a predicate
+--  procedure where a component may have a predicate function that
---  function that carries the base type.
+--  carries the base type.
 --  Note that there is no node for Explicit_Actual_Parameter.
 --  To test for this context we therefore have to test for node
 --  N_Parameter_Association which itself appears only if there is a
 --  formal parameter. Consequently we also need to test for
 --  Legality of the others clause was established in the source,
 --  so the context is legal.
 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
+and then Nkind_In (Parent (N),
-(Pkind = N_Parameter_Association     or else
+N_Parameter_Association,
-Pkind = N_Function_Call             or else
+N_Function_Call,
-Pkind = N_Procedure_Call_Statement  or else
+N_Procedure_Call_Statement,
-Pkind = N_Generic_Association       or else
+N_Generic_Association,
-Pkind = N_Formal_Object_Declaration or else
+N_Formal_Object_Declaration,
-Pkind = N_Simple_Return_Statement   or else
+N_Simple_Return_Statement,
-Pkind = N_Object_Declaration        or else
+N_Object_Declaration,
-Pkind = N_Component_Declaration     or else
+N_Component_Declaration,
-Pkind = N_Parameter_Specification   or else
+N_Parameter_Specification,
-Pkind = N_Qualified_Expression      or else
+N_Qualified_Expression,
-Pkind = N_Reference                 or else
+N_Reference,
-Pkind = N_Aggregate                 or else
+N_Aggregate,
-Pkind = N_Extension_Aggregate       or else
+N_Extension_Aggregate,
-Pkind = N_Component_Association))
+N_Component_Association,
+N_Case_Expression_Alternative,
+N_If_Expression))
 then
 Aggr_Resolved :=
 Resolve_Array_Aggregate
 (N,
 Index          => First_Index (Aggr_Typ),
 --  predicate check must be applied, as for an assignment statement,
 --  because the aggegate 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))
+if Has_Predicates (Component_Typ)
 and then Analyzed (Expr)
 then
 Apply_Predicate_Check (Expr, Component_Typ);
 end if;
 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 -gnatX", 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);
 return True;
 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;
 end Valid_Limited_Ancestor;
 elsif Is_Private_Type (A_Type)
 and then not Is_Private_Type (Imm_Type)
 and then Present (Full_View (A_Type))
 and then Base_Type (Full_View (A_Type)) = Etype (Imm_Type)
 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;
 --  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.
-if Present (Predicate_Function (Expr_Type))
+if Has_Predicates (Expr_Type)
 and then Analyzed (Expr)
 then
 Apply_Predicate_Check (Expr, Expr_Type);
 end if;
 (Bound     : Node_Id;
 Disc      : Entity_Id;
 Expr_Disc : Node_Id)
 is
 begin
-if Nkind (Bound) = N_Identifier
+if Nkind (Bound) /= N_Identifier then
-and then Entity (Bound) = Disc
+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;
 Expr_Disc : Elmt_Id;
 --  Start of processing for Rewrite_Range
 begin
-if Has_Discriminants (Root_Type)
+if Has_Discriminants (Root_Type) and then Nkind (Rge) = N_Range then
-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)));
 declare
 Rec_Typ : constant Entity_Id := Scope (Component);
 --  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
 --  and their types.
 Next_Index (Index);
 end loop;
 --  Rewrite the range nodes occurring as aggregate
---  bounds.
+--  bounds and component associations.
-if Nkind (Expr) = N_Aggregate
+if Nkind (Expr) = N_Aggregate then
-and then Present (Aggregate_Bounds (Expr))
+if Present (Aggregate_Bounds (Expr)) then
-then
+Rewrite_Range (Rec_Typ, Aggregate_Bounds (Expr));
-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

Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/sem_aggr.adb @ 145:1830386684a0