FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

[multiple changes]

Browse source 
2009-04-29  Vincent Celier  <celier@adacore.com>

	* prj-part.adb: Minor comment update

2009-04-29  Ed Schonberg  <schonberg@adacore.com>

	* 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  <charlet@adacore.com>

	* g-socket.adb: Code clean up.

From-SVN: r146976
This commit is contained in:
Arnaud Charlet 2009-04-29 17:25:01 +02:00
parent e50e30817e
commit 107b023cee
4 changed files with 230 additions and 89 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

15
gcc/ada/ChangeLog
View file

@ -1,3 +1,18 @@
2009-04-29 Vincent Celier <celier@adacore.com>
* prj-part.adb: Minor comment update
2009-04-29 Ed Schonberg <schonberg@adacore.com>
* 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 <charlet@adacore.com>
* g-socket.adb: Code clean up.
2009-04-29 Gary Dismukes <dismukes@adacore.com>
* sem_aggr.adb (Valid_Limited_Ancestor): Add test for the name of a

3
gcc/ada/g-socket.adb
View file

@ -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;

8
gcc/ada/prj-part.adb
View file

@ -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

293
gcc/ada/sem_aggr.adb
View file

@ -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;
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;
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.
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;
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
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 (Inner_Comp);
end loop;
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);
Discr_Elmt :=
First_Elmt (Discriminant_Constraint (Ctyp));
while Present (Discr_Elmt) loop
Discr_Val := Node (Discr_Elmt);
-- 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.
-- 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 Has_Discriminants (Typ) then
Add_Discriminant_Values (Expr, New_Assoc_List);
Propagate_Discriminants
(Expr, New_Assoc_List, Component);
if Is_Entity_Name (Discr_Val)
and then
Ekind (Entity (Discr_Val)) = E_Discriminant
then
Discr := Entity (Discr_Val);
elsif Has_Discriminants (Ctyp) then
Add_Discriminant_Values
(Expr, Component_Associations (Expr));
Propagate_Discriminants
(Expr, Component_Associations (Expr), Component);
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);
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 (Assoc);
Next_Component (Comp);
end loop;
end if;
Append
(New_Copy_Tree (Discr_Val), Expressions (Expr));
-- If the discriminant constraint is a current
-- instance, mark the current aggregate so that
-- the self-reference can be expanded 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 Etype (N) = Entity (Prefix (Discr_Val))
then
Set_Has_Self_Reference (N);
end if;
Next_Elmt (Discr_Elmt);
end loop;
declare
Comp : Entity_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;
end if;
Next_Component (Comp);
end loop;
end;
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;