Skip to content

R
riscv-gcc-1
Commit 107b023c by Arnaud Charlet
Options

[multiple changes] 

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
parent e50e3081
Showing with 230 additions and 89 deletions
gcc/ada/ChangeLog
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> 2009-04-29 Gary Dismukes <dismukes@adacore.com>
* sem_aggr.adb (Valid_Limited_Ancestor): Add test for the name of a * sem_aggr.adb (Valid_Limited_Ancestor): Add test for the name of a
......
gcc/ada/g-socket.adb
...@@ -1904,7 +1904,8 @@ package body GNAT.Sockets is ...@@ -1904,7 +1904,8 @@ package body GNAT.Sockets is
Count : out Ada.Streams.Stream_Element_Count; Count : out Ada.Streams.Stream_Element_Count;
Flags : Request_Flag_Type := No_Request_Flag) Flags : Request_Flag_Type := No_Request_Flag)
is is
use type SOSC.Msg_Iovlen_T; use SOSC;
use Interfaces.C;
Res : ssize_t; Res : ssize_t;
Iov_Count : SOSC.Msg_Iovlen_T; Iov_Count : SOSC.Msg_Iovlen_T;
......
gcc/ada/prj-part.adb
...@@ -1101,10 +1101,10 @@ package body Prj.Part is ...@@ -1101,10 +1101,10 @@ package body Prj.Part is
begin begin
-- Loop through extending projects to find the ultimate -- Loop through extending projects to find the ultimate
-- extending project, that is the one that is not -- extending project, that is the one that is not
-- extended. But don't attempt to find an extending -- extended. For an abstract project, as it can be
-- project if the initial project is an abstract project, -- extended several times, there is no extending project
-- as it may have been extended several time, so it -- registered, so the loop does not execute and the
-- cannot have a single extending project. -- resulting project is the abstract project.
while while
Extending_Project_Of (Decl, In_Tree) /= Empty_Node Extending_Project_Of (Decl, In_Tree) /= Empty_Node
......
gcc/ada/sem_aggr.adb
...@@ -2356,10 +2356,12 @@ package body Sem_Aggr is ...@@ -2356,10 +2356,12 @@ package body Sem_Aggr is
procedure Add_Association procedure Add_Association
(Component : Entity_Id; (Component : Entity_Id;
Expr : Node_Id; Expr : Node_Id;
Assoc_List : List_Id;
Is_Box_Present : Boolean := False); Is_Box_Present : Boolean := False);
-- Builds a new N_Component_Association node which associates -- Builds a new N_Component_Association node which associates
-- Component to expression Expr and adds it to the new association -- Component to expression Expr and adds it to the association
-- list New_Assoc_List being built. -- list being built, either New_Assoc_List, or the association
-- being build for an inner aggregate.
function Discr_Present (Discr : Entity_Id) return Boolean; function Discr_Present (Discr : Entity_Id) return Boolean;
-- If aggregate N is a regular aggregate this routine will return True. -- If aggregate N is a regular aggregate this routine will return True.
...@@ -2406,6 +2408,7 @@ package body Sem_Aggr is ...@@ -2406,6 +2408,7 @@ package body Sem_Aggr is
procedure Add_Association procedure Add_Association
(Component : Entity_Id; (Component : Entity_Id;
Expr : Node_Id; Expr : Node_Id;
Assoc_List : List_Id;
Is_Box_Present : Boolean := False) Is_Box_Present : Boolean := False)
is is
Choice_List : constant List_Id := New_List; Choice_List : constant List_Id := New_List;
...@@ -2418,7 +2421,7 @@ package body Sem_Aggr is ...@@ -2418,7 +2421,7 @@ package body Sem_Aggr is
Choices => Choice_List, Choices => Choice_List,
Expression => Expr, Expression => Expr,
Box_Present => Is_Box_Present); Box_Present => Is_Box_Present);
Append (New_Assoc, New_Assoc_List); Append (New_Assoc, Assoc_List);
end Add_Association; end Add_Association;
------------------- -------------------
...@@ -2781,9 +2784,9 @@ package body Sem_Aggr is ...@@ -2781,9 +2784,9 @@ package body Sem_Aggr is
end if; end if;
if Relocate then if Relocate then
Add_Association (New_C, Relocate_Node (Expr)); Add_Association (New_C, Relocate_Node (Expr), New_Assoc_List);
else else
Add_Association (New_C, Expr); Add_Association (New_C, Expr, New_Assoc_List);
end if; end if;
end Resolve_Aggr_Expr; end Resolve_Aggr_Expr;
...@@ -3254,8 +3257,9 @@ package body Sem_Aggr is ...@@ -3254,8 +3257,9 @@ package body Sem_Aggr is
New_Sloc => Sloc (N)); New_Sloc => Sloc (N));
Add_Association Add_Association
(Component => Component, (Component => Component,
Expr => Expr); Expr => Expr,
Assoc_List => New_Assoc_List);
Set_Has_Self_Reference (N); Set_Has_Self_Reference (N);
-- A box-defaulted access component gets the value null. Also -- A box-defaulted access component gets the value null. Also
...@@ -3270,8 +3274,9 @@ package body Sem_Aggr is ...@@ -3270,8 +3274,9 @@ package body Sem_Aggr is
Expr := Make_Null (Sloc (N)); Expr := Make_Null (Sloc (N));
Set_Etype (Expr, Ctyp); Set_Etype (Expr, Ctyp);
Add_Association Add_Association
(Component => Component, (Component => Component,
Expr => Expr); Expr => Expr,
Assoc_List => New_Assoc_List);
-- If the component's type is private with an access type as -- If the component's type is private with an access type as
-- its underlying type then we have to create an unchecked -- its underlying type then we have to create an unchecked
...@@ -3293,7 +3298,9 @@ package body Sem_Aggr is ...@@ -3293,7 +3298,9 @@ package body Sem_Aggr is
begin begin
Analyze_And_Resolve (Convert_Null, Ctyp); Analyze_And_Resolve (Convert_Null, Ctyp);
Add_Association Add_Association
(Component => Component, Expr => Convert_Null); (Component => Component,
Expr => Convert_Null,
Assoc_List => New_Assoc_List);
end; end;
end if; end if;
...@@ -3307,101 +3314,219 @@ package body Sem_Aggr is ...@@ -3307,101 +3314,219 @@ package body Sem_Aggr is
-- values of the discriminants and box initialization -- values of the discriminants and box initialization
-- for the rest, if other components are present. -- for the rest, if other components are present.
-- The type of the aggregate is the known subtype of -- 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); Loc : constant Source_Ptr := Sloc (N);
Assoc : Node_Id;
Discr : Entity_Id;
Discr_Elmt : Elmt_Id;
Discr_Val : Node_Id;
Expr : Node_Id; Expr : Node_Id;
begin procedure Add_Discriminant_Values
Expr := Make_Aggregate (Loc, New_List, New_List); (New_Aggr : Node_Id;
Set_Etype (Expr, Ctyp); 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 := begin
First_Elmt (Discriminant_Constraint (Ctyp)); Discr := First_Discriminant (Etype (New_Aggr));
while Present (Discr_Elmt) loop Discr_Elmt :=
Discr_Val := Node (Discr_Elmt); First_Elmt
(Discriminant_Constraint (Etype (New_Aggr)));
-- The constraint may be given by a discriminant while Present (Discr_Elmt) loop
-- of the enclosing type, in which case we have Discr_Val := Node (Discr_Elmt);
-- to retrieve its value, which is part of the
-- current aggregate. -- If the constraint is given by a discriminant
-- it is a discriminant of an enclosing record,
if Is_Entity_Name (Discr_Val) -- and its value has already been placed in the
and then -- association list.
Ekind (Entity (Discr_Val)) = E_Discriminant
then if Is_Entity_Name (Discr_Val)
Discr := Entity (Discr_Val); and then
Ekind (Entity (Discr_Val)) = E_Discriminant
Assoc := First (New_Assoc_List); then
while Present (Assoc) loop Val := Entity (Discr_Val);
if Present
(Entity (First (Choices (Assoc)))) Assoc := First (Assoc_List);
and then while Present (Assoc) loop
Entity (First (Choices (Assoc))) = Discr if Present
then (Entity (First (Choices (Assoc))))
Discr_Val := Expression (Assoc); and then
exit; Entity (First (Choices (Assoc)))
end if; = Val
Next (Assoc); then
end loop; Discr_Val := Expression (Assoc);
end if; exit;
end if;
Append Next (Assoc);
(New_Copy_Tree (Discr_Val), Expressions (Expr)); end loop;
end if;
-- If the discriminant constraint is a current Add_Association
-- instance, mark the current aggregate so that (Discr, New_Copy_Tree (Discr_Val),
-- the self-reference can be expanded later. Component_Associations (New_Aggr));
if Nkind (Discr_Val) = N_Attribute_Reference -- If the discriminant constraint is a current
and then Is_Entity_Name (Prefix (Discr_Val)) -- instance, mark the current aggregate so that
and then Is_Type (Entity (Prefix (Discr_Val))) -- the self-reference can be expanded later.
and then Etype (N) = Entity (Prefix (Discr_Val))
then
Set_Has_Self_Reference (N);
end if;
Next_Elmt (Discr_Elmt); if Nkind (Discr_Val) = N_Attribute_Reference
end loop; 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 Next_Elmt (Discr_Elmt);
Comp : Entity_Id; 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 begin
-- Look for a component that is not a discriminant
-- before creating an others box association. Inner_Comp := First_Component (Etype (Comp));
while Present (Inner_Comp) loop
Comp := First_Component (Ctyp); Comp_Type := Etype (Inner_Comp);
while Present (Comp) loop
if Ekind (Comp) = E_Component then if Is_Record_Type (Comp_Type)
Append and then Has_Discriminants (Comp_Type)
(Make_Component_Association (Loc, then
Choices => New_Aggr :=
New_List (Make_Others_Choice (Loc)), Make_Aggregate (Loc, New_List, New_List);
Expression => Empty, Set_Etype (New_Aggr, Comp_Type);
Box_Present => True), Add_Association
Component_Associations (Expr)); (Inner_Comp, New_Aggr,
exit; 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; end if;
Next_Component (Comp); Next_Component (Inner_Comp);
end loop; 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 Add_Association
(Component => Component, (Component => Component,
Expr => Expr); Expr => Expr,
end; Assoc_List => New_Assoc_List);
end Capture_Discriminants;
else else
Add_Association Add_Association
(Component => Component, (Component => Component,
Expr => Empty, Expr => Empty,
Assoc_List => New_Assoc_List,
Is_Box_Present => True); Is_Box_Present => True);
end if; end if;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment