From 107b023cee9d3ce4928b2767fe69a1e316c20d1c Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 29 Apr 2009 17:25:01 +0200 Subject: [PATCH] [multiple changes] 2009-04-29 Vincent Celier * prj-part.adb: Minor comment update 2009-04-29 Ed Schonberg * sem_aggr.adb (Resolve_Record_Aggregate): handle properly box-initialized records with discriminated subcomponents that are constrained by discriminants of enclosing components. New subsidiary procedures Add_Discriminant_Values, Propagate_Discriminants. 2009-04-29 Arnaud Charlet * g-socket.adb: Code clean up. From-SVN: r146976 --- gcc/ada/ChangeLog | 15 +++ gcc/ada/g-socket.adb | 3 +- gcc/ada/prj-part.adb | 8 +- gcc/ada/sem_aggr.adb | 293 ++++++++++++++++++++++++++++++++++++--------------- 4 files changed, 230 insertions(+), 89 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 38819f6..3db1b05 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,18 @@ +2009-04-29 Vincent Celier + + * prj-part.adb: Minor comment update + +2009-04-29 Ed Schonberg + + * sem_aggr.adb (Resolve_Record_Aggregate): handle properly + box-initialized records with discriminated subcomponents that are + constrained by discriminants of enclosing components. New subsidiary + procedures Add_Discriminant_Values, Propagate_Discriminants. + +2009-04-29 Arnaud Charlet + + * g-socket.adb: Code clean up. + 2009-04-29 Gary Dismukes * sem_aggr.adb (Valid_Limited_Ancestor): Add test for the name of a diff --git a/gcc/ada/g-socket.adb b/gcc/ada/g-socket.adb index 63f6d74..4caa5f4 100644 --- a/gcc/ada/g-socket.adb +++ b/gcc/ada/g-socket.adb @@ -1904,7 +1904,8 @@ package body GNAT.Sockets is Count : out Ada.Streams.Stream_Element_Count; Flags : Request_Flag_Type := No_Request_Flag) is - use type SOSC.Msg_Iovlen_T; + use SOSC; + use Interfaces.C; Res : ssize_t; Iov_Count : SOSC.Msg_Iovlen_T; diff --git a/gcc/ada/prj-part.adb b/gcc/ada/prj-part.adb index 0608e02..871517c 100644 --- a/gcc/ada/prj-part.adb +++ b/gcc/ada/prj-part.adb @@ -1101,10 +1101,10 @@ package body Prj.Part is begin -- Loop through extending projects to find the ultimate -- extending project, that is the one that is not - -- extended. But don't attempt to find an extending - -- project if the initial project is an abstract project, - -- as it may have been extended several time, so it - -- cannot have a single extending project. + -- extended. For an abstract project, as it can be + -- extended several times, there is no extending project + -- registered, so the loop does not execute and the + -- resulting project is the abstract project. while Extending_Project_Of (Decl, In_Tree) /= Empty_Node diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index e5d8cdc..3760e79 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -2356,10 +2356,12 @@ package body Sem_Aggr is procedure Add_Association (Component : Entity_Id; Expr : Node_Id; + Assoc_List : List_Id; Is_Box_Present : Boolean := False); -- Builds a new N_Component_Association node which associates - -- Component to expression Expr and adds it to the new association - -- list New_Assoc_List being built. + -- Component to expression Expr and adds it to the association + -- list being built, either New_Assoc_List, or the association + -- being build for an inner aggregate. function Discr_Present (Discr : Entity_Id) return Boolean; -- If aggregate N is a regular aggregate this routine will return True. @@ -2406,6 +2408,7 @@ package body Sem_Aggr is procedure Add_Association (Component : Entity_Id; Expr : Node_Id; + Assoc_List : List_Id; Is_Box_Present : Boolean := False) is Choice_List : constant List_Id := New_List; @@ -2418,7 +2421,7 @@ package body Sem_Aggr is Choices => Choice_List, Expression => Expr, Box_Present => Is_Box_Present); - Append (New_Assoc, New_Assoc_List); + Append (New_Assoc, Assoc_List); end Add_Association; ------------------- @@ -2781,9 +2784,9 @@ package body Sem_Aggr is end if; if Relocate then - Add_Association (New_C, Relocate_Node (Expr)); + Add_Association (New_C, Relocate_Node (Expr), New_Assoc_List); else - Add_Association (New_C, Expr); + Add_Association (New_C, Expr, New_Assoc_List); end if; end Resolve_Aggr_Expr; @@ -3254,8 +3257,9 @@ package body Sem_Aggr is New_Sloc => Sloc (N)); Add_Association - (Component => Component, - Expr => Expr); + (Component => Component, + Expr => Expr, + Assoc_List => New_Assoc_List); Set_Has_Self_Reference (N); -- A box-defaulted access component gets the value null. Also @@ -3270,8 +3274,9 @@ package body Sem_Aggr is Expr := Make_Null (Sloc (N)); Set_Etype (Expr, Ctyp); Add_Association - (Component => Component, - Expr => Expr); + (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 @@ -3293,7 +3298,9 @@ package body Sem_Aggr is begin Analyze_And_Resolve (Convert_Null, Ctyp); Add_Association - (Component => Component, Expr => Convert_Null); + (Component => Component, + Expr => Convert_Null, + Assoc_List => New_Assoc_List); end; end if; @@ -3307,101 +3314,219 @@ package body Sem_Aggr is -- 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 component. The capture of discriminants must + -- be recursive because subcomponents may be contrained + -- (transitively) by discriminants of enclosing types. - declare + Capture_Discriminants : declare Loc : constant Source_Ptr := Sloc (N); - Assoc : Node_Id; - Discr : Entity_Id; - Discr_Elmt : Elmt_Id; - Discr_Val : Node_Id; Expr : Node_Id; - begin - Expr := Make_Aggregate (Loc, New_List, New_List); - Set_Etype (Expr, Ctyp); + 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; + Comp : Entity_Id); + -- Nested components may themselves be discriminated + -- types constrained by outer discriminants. Their + -- 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; - Discr_Elmt := - First_Elmt (Discriminant_Constraint (Ctyp)); - while Present (Discr_Elmt) loop - Discr_Val := Node (Discr_Elmt); - - -- The constraint may be given by a discriminant - -- of the enclosing type, in which case we have - -- to retrieve its value, which is part of the - -- current aggregate. - - if Is_Entity_Name (Discr_Val) - and then - Ekind (Entity (Discr_Val)) = E_Discriminant - then - Discr := Entity (Discr_Val); - - Assoc := First (New_Assoc_List); - while Present (Assoc) loop - if Present - (Entity (First (Choices (Assoc)))) - and then - Entity (First (Choices (Assoc))) = Discr - then - Discr_Val := Expression (Assoc); - exit; - end if; - Next (Assoc); - end loop; - end if; - - Append - (New_Copy_Tree (Discr_Val), Expressions (Expr)); + 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; - -- If the discriminant constraint is a current - -- instance, mark the current aggregate so that - -- the self-reference can be expanded later. + Add_Association + (Discr, New_Copy_Tree (Discr_Val), + Component_Associations (New_Aggr)); - 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 Etype (N) = Entity (Prefix (Discr_Val)) - then - Set_Has_Self_Reference (N); - end if; + -- If the discriminant constraint is a current + -- instance, mark the current aggregate so that + -- the self-reference can be expanded later. - Next_Elmt (Discr_Elmt); - end loop; + 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 Etype (N) = + Entity (Prefix (Discr_Val)) + then + Set_Has_Self_Reference (N); + end if; - declare - Comp : Entity_Id; + 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; + Comp : Entity_Id) + is + Inner_Comp : Entity_Id; + Comp_Type : Entity_Id; + Needs_Box : Boolean := False; + New_Aggr : Node_Id; begin - -- Look for a component that is not a discriminant - -- before creating an others box association. - - Comp := First_Component (Ctyp); - while Present (Comp) loop - if Ekind (Comp) = E_Component then - Append - (Make_Component_Association (Loc, - Choices => - New_List (Make_Others_Choice (Loc)), - Expression => Empty, - Box_Present => True), - Component_Associations (Expr)); - exit; + + Inner_Comp := First_Component (Etype (Comp)); + while Present (Inner_Comp) loop + Comp_Type := Etype (Inner_Comp); + + if Is_Record_Type (Comp_Type) + and then Has_Discriminants (Comp_Type) + then + New_Aggr := + Make_Aggregate (Loc, New_List, New_List); + Set_Etype (New_Aggr, Comp_Type); + Add_Association + (Inner_Comp, New_Aggr, + Component_Associations (Aggr)); + + -- Collect disciminant values, and recurse. + + Add_Discriminant_Values + (New_Aggr, Assoc_List); + Propagate_Discriminants + (New_Aggr, Assoc_List, Inner_Comp); + + else + Needs_Box := True; end if; - Next_Component (Comp); + Next_Component (Inner_Comp); end loop; - end; + + if Needs_Box then + Append + (Make_Component_Association (Loc, + Choices => + New_List (Make_Others_Choice (Loc)), + Expression => Empty, + Box_Present => True), + Component_Associations (Aggr)); + end if; + end Propagate_Discriminants; + + begin + Expr := Make_Aggregate (Loc, New_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 it turn be propagated to their components. + + if Has_Discriminants (Typ) then + Add_Discriminant_Values (Expr, New_Assoc_List); + Propagate_Discriminants + (Expr, New_Assoc_List, Component); + + elsif Has_Discriminants (Ctyp) then + Add_Discriminant_Values + (Expr, Component_Associations (Expr)); + Propagate_Discriminants + (Expr, Component_Associations (Expr), Component); + + 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 + (Make_Component_Association (Loc, + Choices => + New_List + (Make_Others_Choice (Loc)), + Expression => Empty, + Box_Present => True), + Component_Associations (Expr)); + end if; + exit; + end if; + + Next_Component (Comp); + end loop; + end; + end if; Add_Association - (Component => Component, - Expr => Expr); - end; + (Component => Component, + Expr => Expr, + Assoc_List => New_Assoc_List); + end Capture_Discriminants; else Add_Association (Component => Component, Expr => Empty, + Assoc_List => New_Assoc_List, Is_Box_Present => True); end if; -- 2.7.4