diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/sem_aggr.adb | 274 |
1 files changed, 4 insertions, 270 deletions
diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index bc03a07..e1e7b8b 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -4623,14 +4623,6 @@ package body Sem_Aggr is -- either New_Assoc_List, or the association being built for an inner -- aggregate. - 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, then Input_Discr denotes @@ -4673,13 +4665,6 @@ 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. - 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 : Entity_Id); -- Analyzes and resolves expression Expr against the Etype of the -- Component. This routine also applies all appropriate checks to Expr. @@ -4736,73 +4721,6 @@ package body Sem_Aggr is end if; 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; - - 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 by - -- Build_Record_Aggr_Code.Replace_Type later. - - 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 - Is_Ancestor - (Entity (Prefix (Discr_Val)), - Etype (N), - Use_Full_View => True) - then - Set_Has_Self_Reference (N); - end if; - - Next_Elmt (Discr_Elmt); - Next_Discriminant (Discr); - end loop; - end Add_Discriminant_Values; - -------------------------- -- Discriminant_Present -- -------------------------- @@ -5126,99 +5044,6 @@ package body Sem_Aggr is return Expr; end Get_Value; - ----------------------------- - -- Propagate_Discriminants -- - ----------------------------- - - procedure Propagate_Discriminants - (Aggr : Node_Id; - Assoc_List : List_Id) - is - 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 - -- 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; - - 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 -- ----------------------- @@ -6074,107 +5899,16 @@ package body Sem_Aggr is Assoc_List => New_Assoc_List); Set_Has_Self_Reference (N); - elsif Needs_Simple_Initialization (Ctyp) then + elsif Needs_Simple_Initialization (Ctyp) + or else Has_Non_Null_Base_Init_Proc (Ctyp) + or else not Expander_Active + then Add_Association (Component => Component, Expr => Empty, Assoc_List => New_Assoc_List, Is_Box_Present => True); - elsif Has_Non_Null_Base_Init_Proc (Ctyp) - or else not Expander_Active - then - if Is_Record_Type (Ctyp) - and then Has_Discriminants (Ctyp) - and then not Is_Private_Type (Ctyp) - then - -- We build a partially initialized aggregate with the - -- values of the discriminants and box initialization - -- 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 - -- (transitively) by discriminants of enclosing types. - -- For a private type with discriminants, a call to the - -- initialization procedure will be generated, and no - -- subaggregate is needed. - - Capture_Discriminants : declare - Loc : constant Source_Ptr := Sloc (N); - Expr : Node_Id; - - begin - Expr := Make_Aggregate (Loc, No_List, New_List); - Set_Etype (Expr, Ctyp); - - -- If the enclosing type has discriminants, they have - -- been collected in the aggregate earlier, and they - -- may appear as constraints of subcomponents. - - -- Similarly if this component has discriminants, they - -- might in turn be propagated to their components. - - if Has_Discriminants (Typ) then - Add_Discriminant_Values (Expr, New_Assoc_List); - Propagate_Discriminants (Expr, New_Assoc_List); - - elsif Has_Discriminants (Ctyp) then - Add_Discriminant_Values - (Expr, Component_Associations (Expr)); - Propagate_Discriminants - (Expr, Component_Associations (Expr)); - - Build_Constrained_Itype - (Expr, Ctyp, Component_Associations (Expr)); - - else - declare - Comp : Entity_Id; - - begin - -- If the type has additional components, create - -- an OTHERS box association for them. - - Comp := First_Component (Ctyp); - while Present (Comp) loop - if Ekind (Comp) = E_Component then - if not Is_Record_Type (Etype (Comp)) then - Append_To - (Component_Associations (Expr), - Make_Component_Association (Loc, - Choices => - New_List ( - Make_Others_Choice (Loc)), - Expression => Empty, - Box_Present => True)); - end if; - - exit; - end if; - - Next_Component (Comp); - end loop; - end; - end if; - - Add_Association - (Component => Component, - Expr => Expr, - 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, - Expr => Empty, - Assoc_List => New_Assoc_List, - Is_Box_Present => True); - end if; - -- Otherwise we only need to resolve the expression if the -- component has partially initialized values (required to -- expand the corresponding assignments and run-time checks). |