OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2011-08-29  Yannick Moy  <moy@adacore.com>

	* gnat1drv.adb (Adjust_Global_Switches): Restore expansion of tagged
	types and dispatching calls in Alfa mode.
	* lib-xref-alfa.adb (Collect_ALFA): Rewrite computation of
	correspondance between body and spec scopes, to reuse utility functions
	(Traverse_Declarations_Or_Statements): Protect access to body for stub
	by testing the presence of the library unit for the body
	* sem_ch6.adb (Set_Actual_Subtypes): take into account that in Alfa
	mode the expansion of accept statements is skipped
	* sem_util.adb, sem_util.ads (Unique_Entity): New function returning
	the unique entity corresponding to the one returned by
	Unique_Defining_Entity applied to the enclosing declaration of the
	argument.

2011-08-29  Bob Duff  <duff@adacore.com>

	* treepr.ads: Improve debugging facilities. pn(x) no longer crashes in
	gdb when x is not a node (it can be a node list, name_id, etc). pp is
	an alias for pn. ppp is an alias for pt.

2011-08-29  Javier Miranda  <miranda@adacore.com>

	* exp_aggr.adb (Expand_Record_Aggregate): Use the top-level enclosing
	aggregate to take a consistent decision on the need to convert into
	assignments aggregates that initialize constant objects.

2011-08-29  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch4.adb (Expand_Allocator_Expression): Add a call to
	Build_Allocate_Deallocate_Proc in order to handle allocation of
	non-controlled objects on subpools.
	* impunit.adb: Remove s-finmas and s-spsufi since they were never meant
	to be end-user visible.
	* s-finmas.adb: Add with and use clause for System.HTable.
	Add an instantiation of Simple_HTable which provides a mapping between
	the address of a controlled object and the corresponding
	Finalize_Address used to clean up the object. The table is used when a
	master is operating in heterogeneous mode.
	(Attach): Explain why the input node is not verified on being already
	attached.
	(Delete_Finalize_Address): New routine.
	(Detach): Add pragma Assert which ensures that a node is already
	attached.
	(Finalize): Add local variable Cleanup. Rewrite the iteration scheme
	since nodes are no longer removed on traversal. Explain why node
	detachment is undesirable in this case.
	(Get_Finalize_Address): New routine.
	(Hash): New routine.
	(Is_Empty_List): Removed.
	(pm): Renamed to Print_Master. Add output for discriminant
	Is_Homogeneous.
	Comment reformatting.
	(Set_Finalize_Address (Address, Finalize_Address_Ptr)): New routine.
	* s-finmas.ads: Various comments additions / improvements.
	Type Finalization_Master has a discriminant which determines the mode of
	operation.
	(Delete_Finalize_Address): New routine.
	(Get_Finalize_Address): New routine.
	(pm): Renamed to Print_Master.
	(Set_Finalize_Address (Address, Finalize_Address_Ptr)): New routine.
	* s-stposu.adb: Add with clause for System.Address_Image; Add with and
	use clause for System.IO.
	(Allocate_Any_Controlled): Add machinery to set TSS primitive
	Finalize_Address depending on the mode of allocation and the mode of
	the master.
	(Deallocate_Any_Controlled): Remove the relation pair object -
	Finalize_Address regardless of the master mode. Add comment explaining
	the reason.
	(Detach): Ensure that fields Prev and Next are null after detachment.
	(Finalize_Pool): Remove local variable Next_Ptr. Rewrite the iteration
	scheme to check whether the list of subpools is empty. There is no
	longer need to store the next subpool or advance the current pointer.
	(Is_Empty_List): New routine.
	(Print_Pool): New routine.
	(Print_Subpool): New routine.
	* s-stposu.ads: Various comments additions / improvements.
	Field Master of type Root_Subpool is now a heterogeneous collection.
	(Print_Pool): New routine.
	(Print_Subpool): New routine.

2011-08-29  Ed Schonberg  <schonberg@adacore.com>

	* exp_ch5.adb (Expand_N_Iterator_Loop): Implement Ada2012 loop iterator
	forms, using aspects of container types.
	* sem_ch3.adb (Find_Type_Name): Preserve Has_Delayed_Aspects and
	Has_Implicit_Dereference flags, that may be set on the partial view.
	* sem_ch4.adb (Process_Overloaded_Indexed_Component): Prefix may be a
	container type with an indexing aspect.
	(Analyze_Quantified_Expression): Analyze construct with expansion
	disabled, because it will be rewritten as a loop during expansion.
	(Try_Container_Indexing): The prefix itself may be a container type
	with an indexing aspect, as with a vector of vectors.
	* sem_ch5.adb (Analyze_Iteration_Scheme): In a generic context, analyze
	the original doamin of iteration, for name capture.
	(Analyze_Iterator_Specification): If the domain is an expression that
	needs finalization, create a separate declaration for it.
	For an iterator with "of" retrieve default iterator info from aspect of
	container type. For "in" iterator, retrieve type of Iterate function.
	* sem_ch13.adb (Check_Iterator_Function): Fix typo.
	(Check_Aspect_At_End_Of_Declaration): Make type unfrozen before
	analysis, to prevent spurious errors about late attributes.
	* sprint.adb: Handle quantified expression with either loop or iterator
	specification.
	* a-convec.ads, a-convec.adb: Iterate function returns a reversible
	iterator.

From-SVN: r178235
This commit is contained in:
Arnaud Charlet 2011-08-29 15:54:30 +02:00
parent 9fdf1422c7
commit 57a8057af4
23 changed files with 935 additions and 271 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

107
gcc/ada/ChangeLog
View File

@ -1,3 +1,110 @@
2011-08-29 Yannick Moy <moy@adacore.com>
* gnat1drv.adb (Adjust_Global_Switches): Restore expansion of tagged
types and dispatching calls in Alfa mode.
* lib-xref-alfa.adb (Collect_ALFA): Rewrite computation of
correspondance between body and spec scopes, to reuse utility functions
(Traverse_Declarations_Or_Statements): Protect access to body for stub
by testing the presence of the library unit for the body
* sem_ch6.adb (Set_Actual_Subtypes): take into account that in Alfa
mode the expansion of accept statements is skipped
* sem_util.adb, sem_util.ads (Unique_Entity): New function returning
the unique entity corresponding to the one returned by
Unique_Defining_Entity applied to the enclosing declaration of the
argument.
2011-08-29 Bob Duff <duff@adacore.com>
* treepr.ads: Improve debugging facilities. pn(x) no longer crashes in
gdb when x is not a node (it can be a node list, name_id, etc). pp is
an alias for pn. ppp is an alias for pt.
2011-08-29 Javier Miranda <miranda@adacore.com>
* exp_aggr.adb (Expand_Record_Aggregate): Use the top-level enclosing
aggregate to take a consistent decision on the need to convert into
assignments aggregates that initialize constant objects.
2011-08-29 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch4.adb (Expand_Allocator_Expression): Add a call to
Build_Allocate_Deallocate_Proc in order to handle allocation of
non-controlled objects on subpools.
* impunit.adb: Remove s-finmas and s-spsufi since they were never meant
to be end-user visible.
* s-finmas.adb: Add with and use clause for System.HTable.
Add an instantiation of Simple_HTable which provides a mapping between
the address of a controlled object and the corresponding
Finalize_Address used to clean up the object. The table is used when a
master is operating in heterogeneous mode.
(Attach): Explain why the input node is not verified on being already
attached.
(Delete_Finalize_Address): New routine.
(Detach): Add pragma Assert which ensures that a node is already
attached.
(Finalize): Add local variable Cleanup. Rewrite the iteration scheme
since nodes are no longer removed on traversal. Explain why node
detachment is undesirable in this case.
(Get_Finalize_Address): New routine.
(Hash): New routine.
(Is_Empty_List): Removed.
(pm): Renamed to Print_Master. Add output for discriminant
Is_Homogeneous.
Comment reformatting.
(Set_Finalize_Address (Address, Finalize_Address_Ptr)): New routine.
* s-finmas.ads: Various comments additions / improvements.
Type Finalization_Master has a discriminant which determines the mode of
operation.
(Delete_Finalize_Address): New routine.
(Get_Finalize_Address): New routine.
(pm): Renamed to Print_Master.
(Set_Finalize_Address (Address, Finalize_Address_Ptr)): New routine.
* s-stposu.adb: Add with clause for System.Address_Image; Add with and
use clause for System.IO.
(Allocate_Any_Controlled): Add machinery to set TSS primitive
Finalize_Address depending on the mode of allocation and the mode of
the master.
(Deallocate_Any_Controlled): Remove the relation pair object -
Finalize_Address regardless of the master mode. Add comment explaining
the reason.
(Detach): Ensure that fields Prev and Next are null after detachment.
(Finalize_Pool): Remove local variable Next_Ptr. Rewrite the iteration
scheme to check whether the list of subpools is empty. There is no
longer need to store the next subpool or advance the current pointer.
(Is_Empty_List): New routine.
(Print_Pool): New routine.
(Print_Subpool): New routine.
* s-stposu.ads: Various comments additions / improvements.
Field Master of type Root_Subpool is now a heterogeneous collection.
(Print_Pool): New routine.
(Print_Subpool): New routine.
2011-08-29 Ed Schonberg <schonberg@adacore.com>
* exp_ch5.adb (Expand_N_Iterator_Loop): Implement Ada2012 loop iterator
forms, using aspects of container types.
* sem_ch3.adb (Find_Type_Name): Preserve Has_Delayed_Aspects and
Has_Implicit_Dereference flags, that may be set on the partial view.
* sem_ch4.adb (Process_Overloaded_Indexed_Component): Prefix may be a
container type with an indexing aspect.
(Analyze_Quantified_Expression): Analyze construct with expansion
disabled, because it will be rewritten as a loop during expansion.
(Try_Container_Indexing): The prefix itself may be a container type
with an indexing aspect, as with a vector of vectors.
* sem_ch5.adb (Analyze_Iteration_Scheme): In a generic context, analyze
the original doamin of iteration, for name capture.
(Analyze_Iterator_Specification): If the domain is an expression that
needs finalization, create a separate declaration for it.
For an iterator with "of" retrieve default iterator info from aspect of
container type. For "in" iterator, retrieve type of Iterate function.
* sem_ch13.adb (Check_Iterator_Function): Fix typo.
(Check_Aspect_At_End_Of_Declaration): Make type unfrozen before
analysis, to prevent spurious errors about late attributes.
* sprint.adb: Handle quantified expression with either loop or iterator
specification.
* a-convec.ads, a-convec.adb: Iterate function returns a reversible
iterator.
2011-08-29 Vincent Celier <celier@adacore.com>
* make.adb (Scan_Make_Arg): Take any option as is in packages Compiler,

2
gcc/ada/a-convec.adb
View File

@ -2042,7 +2042,7 @@ package body Ada.Containers.Vectors is
end Iterate;
function Iterate (Container : Vector; Start : Cursor)
return Vector_Iterator_Interfaces.Forward_Iterator'Class
return Vector_Iterator_Interfaces.Reversible_Iterator'class
is
It : constant Iterator :=
(Container'Unchecked_Access, Start.Index);

2
gcc/ada/a-convec.ads
View File

@ -358,7 +358,7 @@ package Ada.Containers.Vectors is
return Vector_Iterator_Interfaces.Reversible_Iterator'Class;
function Iterate (Container : Vector; Start : Cursor)
return Vector_Iterator_Interfaces.Forward_Iterator'Class;
return Vector_Iterator_Interfaces.Reversible_Iterator'class;
generic
with function "<" (Left, Right : Element_Type) return Boolean is <>;

52
gcc/ada/exp_aggr.adb
View File

@ -5099,6 +5099,16 @@ package body Exp_Aggr is
-- semantics of Ada complicate the analysis and lead to anomalies in
-- the gcc back-end if the aggregate is not expanded into assignments.
function Has_Visible_Private_Ancestor (Id : E) return Boolean;
-- If any ancestor of the current type is private, the aggregate
-- cannot be built in place. We canot rely on Has_Private_Ancestor,
-- because it will not be set when type and its parent are in the
-- same scope, and the parent component needs expansion.
function Top_Level_Aggregate (N : Node_Id) return Node_Id;
-- For nested aggregates return the ultimate enclosing aggregate; for
-- non-nested aggregates return N.
----------------------------------
-- Component_Not_OK_For_Backend --
----------------------------------
@ -5178,18 +5188,6 @@ package body Exp_Aggr is
return False;
end Component_Not_OK_For_Backend;
-- Remaining Expand_Record_Aggregate variables
Tag_Value : Node_Id;
Comp : Entity_Id;
New_Comp : Node_Id;
function Has_Visible_Private_Ancestor (Id : E) return Boolean;
-- If any ancestor of the current type is private, the aggregate
-- cannot be built in place. We canot rely on Has_Private_Ancestor,
-- because it will not be set when type and its parent are in the
-- same scope, and the parent component needs expansion.
-----------------------------------
-- Has_Visible_Private_Ancestor --
-----------------------------------
@ -5197,6 +5195,7 @@ package body Exp_Aggr is
function Has_Visible_Private_Ancestor (Id : E) return Boolean is
R : constant Entity_Id := Root_Type (Id);
T1 : Entity_Id := Id;
begin
loop
if Is_Private_Type (T1) then
@ -5211,6 +5210,31 @@ package body Exp_Aggr is
end loop;
end Has_Visible_Private_Ancestor;
-------------------------
-- Top_Level_Aggregate --
-------------------------
function Top_Level_Aggregate (N : Node_Id) return Node_Id is
Aggr : Node_Id := N;
begin
while Present (Parent (Aggr))
and then Nkind_In (Parent (Aggr), N_Component_Association,
N_Aggregate)
loop
Aggr := Parent (Aggr);
end loop;
return Aggr;
end Top_Level_Aggregate;
-- Local variables
Top_Level_Aggr : constant Node_Id := Top_Level_Aggregate (N);
Tag_Value : Node_Id;
Comp : Entity_Id;
New_Comp : Node_Id;
-- Start of processing for Expand_Record_Aggregate
begin
@ -5317,8 +5341,8 @@ package body Exp_Aggr is
elsif Has_Mutable_Components (Typ)
and then
(Nkind (Parent (N)) /= N_Object_Declaration
or else not Constant_Present (Parent (N)))
(Nkind (Parent (Top_Level_Aggr)) /= N_Object_Declaration
or else not Constant_Present (Parent (Top_Level_Aggr)))
then
Convert_To_Assignments (N, Typ);

2
gcc/ada/exp_ch4.adb
View File

@ -1137,6 +1137,8 @@ package body Exp_Ch4 is
Rewrite (Exp, New_Copy (Expression (Exp)));
end if;
else
Build_Allocate_Deallocate_Proc (N, True);
-- If we have:
-- type A is access T1;
-- X : A := new T2'(...);

192
gcc/ada/exp_ch5.adb
View File

@ -2825,6 +2825,7 @@ package body Exp_Ch5 is
Container : constant Node_Id := Name (I_Spec);
Container_Typ : constant Entity_Id := Etype (Container);
Cursor : Entity_Id;
Iterator : Entity_Id;
New_Loop : Node_Id;
Stats : List_Id := Statements (N);
@ -2839,10 +2840,10 @@ package body Exp_Ch5 is
-- the array.
if Of_Present (I_Spec) then
Cursor := Make_Temporary (Loc, 'C');
Iterator := Make_Temporary (Loc, 'C');
-- Generate:
-- Element : Component_Type renames Container (Cursor);
-- Element : Component_Type renames Container (Iterator);
Prepend_To (Stats,
Make_Object_Renaming_Declaration (Loc,
@ -2853,19 +2854,19 @@ package body Exp_Ch5 is
Make_Indexed_Component (Loc,
Prefix => Relocate_Node (Container),
Expressions => New_List (
New_Reference_To (Cursor, Loc)))));
New_Reference_To (Iterator, Loc)))));
-- for Index in Array loop
--
-- This case utilizes the already given cursor name
-- This case utilizes the already given iterator name
else
Cursor := Id;
Iterator := Id;
end if;
-- Generate:
-- for Cursor in [reverse] Container'Range loop
-- Element : Component_Type renames Container (Cursor);
-- for Iterator in [reverse] Container'Range loop
-- Element : Component_Type renames Container (Iterator);
-- -- for the "of" form
--
-- <original loop statements>
@ -2877,7 +2878,7 @@ package body Exp_Ch5 is
Make_Iteration_Scheme (Loc,
Loop_Parameter_Specification =>
Make_Loop_Parameter_Specification (Loc,
Defining_Identifier => Cursor,
Defining_Identifier => Iterator,
Discrete_Subtype_Definition =>
Make_Attribute_Reference (Loc,
Prefix => Relocate_Node (Container),
@ -2889,21 +2890,28 @@ package body Exp_Ch5 is
-- Processing for containers
else
-- For an iterator of the form "Of" then name is some expression,
-- which is transformed into a call to the default iterator.
-- For an iterator of the form "in" then name is a function call
-- that delivers an iterator.
-- The for loop is expanded into a while loop which uses a container
-- specific cursor to examine each element.
-- Cursor : Pack.Cursor := Container.First;
-- while Cursor /= Pack.No_Element loop
-- Iter : Iterator_Type := Container.Iterate;
-- Cursor : Cursor_type := First (Iter);
-- while Has_Element (Iter) loop
-- declare
-- -- the block is added when Element_Type is controlled
-- Obj : Pack.Element_Type := Element (Cursor);
-- Obj : Pack.Element_Type := Element (Iterator);
-- -- for the "of" loop form
-- begin
-- <original loop statements>
-- end;
-- Pack.Next (Cursor);
-- Cursor := Iter.Next (Cursor);
-- end loop;
-- If "reverse" is present, then the initialization of the cursor
@ -2912,30 +2920,48 @@ package body Exp_Ch5 is
declare
Element_Type : constant Entity_Id := Etype (Id);
Pack : constant Entity_Id :=
Scope (Base_Type (Container_Typ));
Pack : Entity_Id;
Decl : Node_Id;
Cntr : Node_Id;
Name_Init : Name_Id;
Name_Step : Name_Id;
begin
-- The "of" case uses an internally generated cursor
if Is_Entity_Name (Container) then
Pack := Scope (Etype (Container));
else
Pack := Scope (Entity (Name (Container)));
end if;
-- The "of" case uses an internally generated cursor whose type
-- is found in the container package.
if Of_Present (I_Spec) then
Cursor := Make_Temporary (Loc, 'C');
Cursor := Make_Temporary (Loc, 'I');
declare
Ent : Entity_Id;
begin
Ent := First_Entity (Pack);
while Present (Ent) loop
if Chars (Ent) = Name_Cursor then
Set_Etype (Cursor, Etype (Ent));
exit;
end if;
Next_Entity (Ent);
end loop;
end;
else
Cursor := Id;
end if;
-- The code below only handles containers where Element is not a
-- primitive operation of the container. This excludes for now the
-- Hi-Lite formal containers.
Iterator := Make_Temporary (Loc, 'I');
if Of_Present (I_Spec) then
-- Generate:
-- Id : Element_Type := Pack.Element (Cursor);
-- Id : Element_Type renames Pack.Element (Cursor);
Decl :=
Make_Object_Renaming_Declaration (Loc,
@ -2951,18 +2977,18 @@ package body Exp_Ch5 is
Selector_Name =>
Make_Identifier (Loc, Chars => Name_Element)),
Expressions => New_List (
New_Reference_To (Cursor, Loc))));
New_Occurrence_Of (Cursor, Loc))));
-- When the container holds controlled objects, wrap the loop
-- statements and element renaming declaration with a block.
-- This ensures that the transient result of Element (Cursor)
-- This ensures that the transient result of Element (Iterator)
-- is cleaned up after each iteration of the loop.
if Needs_Finalization (Element_Type) then
-- Generate:
-- declare
-- Id : Element_Type := Pack.Element (Cursor);
-- Id : Element_Type := Pack.Element (Iterator);
-- begin
-- <original loop statements>
-- end;
@ -2994,22 +3020,38 @@ package body Exp_Ch5 is
-- For both iterator forms, add a call to the step operation to
-- advance the cursor. Generate:
--
-- Pack.[Next | Prev] (Cursor);
-- Cursor := Iterator.Next (Cursor);
-- or else
-- Cursor := Next (Cursor);
Append_To (Stats,
Make_Procedure_Call_Statement (Loc,
declare
Rhs : Node_Id;
begin
if Of_Present (I_Spec) then
Rhs :=
Make_Function_Call (Loc,
Name => Make_Identifier (Loc, Name_Step),
Parameter_Associations =>
New_List (New_Reference_To (Cursor, Loc)));
else
Rhs :=
Make_Function_Call (Loc,
Name =>
Make_Selected_Component (Loc,
Prefix =>
New_Reference_To (Pack, Loc),
Selector_Name =>
Make_Identifier (Loc, Name_Step)),
Prefix => New_Reference_To (Iterator, Loc),
Selector_Name => Make_Identifier (Loc, Name_Step)),
Parameter_Associations => New_List (
New_Reference_To (Cursor, Loc))));
New_Reference_To (Cursor, Loc)));
end if;
Append_To (Stats,
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Cursor, Loc),
Expression => Rhs));
end;
-- Generate:
-- while Cursor /= Pack.No_Element loop
-- while Iterator.Has_Element loop
-- <Stats>
-- end loop;
@ -3018,71 +3060,61 @@ package body Exp_Ch5 is
Iteration_Scheme =>
Make_Iteration_Scheme (Loc,
Condition =>
Make_Op_Ne (Loc,
Left_Opnd =>
New_Reference_To (Cursor, Loc),
Right_Opnd =>
Make_Function_Call (Loc,
Name =>
Make_Selected_Component (Loc,
Prefix =>
New_Reference_To (Pack, Loc),
Prefix => New_Occurrence_Of (Pack, Loc),
Selector_Name =>
Make_Identifier (Loc, Name_No_Element)))),
Make_Identifier (Loc, Name_Has_Element)),
Parameter_Associations =>
New_List (
New_Reference_To (Cursor, Loc)))),
Statements => Stats,
End_Label => Empty);
Cntr := Relocate_Node (Container);
-- When the container is provided by a function call, create an
-- explicit renaming of the function result. Generate:
--
-- Cnn : Container_Typ renames Func_Call (...);
--
-- The renaming avoids the generation of a transient scope when
-- initializing the cursor and the premature finalization of the
-- container.
if Nkind (Cntr) = N_Function_Call then
declare
Ren_Id : constant Entity_Id := Make_Temporary (Loc, 'C');
begin
Insert_Action (N,
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Ren_Id,
Subtype_Mark =>
New_Reference_To (Container_Typ, Loc),
Name => Cntr));
Cntr := New_Reference_To (Ren_Id, Loc);
end;
end if;
-- Create the declaration of the cursor and insert it before the
-- source loop. Generate:
-- Create the declarations for Iterator and cursor and insert then
-- before the source loop. Generate:
--
-- I : Iterator_Type := Iterate (Container);
-- C : Pack.Cursor_Type := Container.[First | Last];
Insert_Action (N,
declare
Decl1 : Node_Id;
Decl2 : Node_Id;
begin
Decl1 :=
Make_Object_Declaration (Loc,
Defining_Identifier => Iterator,
Object_Definition =>
New_Occurrence_Of (Etype (Name (I_Spec)), Loc),
Expression => Relocate_Node (Name (I_Spec)));
Set_Assignment_OK (Decl1);
Decl2 :=
Make_Object_Declaration (Loc,
Defining_Identifier => Cursor,
Object_Definition =>
Make_Selected_Component (Loc,
Prefix =>
New_Reference_To (Pack, Loc),
Selector_Name =>
Make_Identifier (Loc, Name_Cursor)),
New_Occurrence_Of (Etype (Cursor), Loc),
Expression =>
Make_Selected_Component (Loc,
Prefix => Cntr,
Prefix => New_Reference_To (Iterator, Loc),
Selector_Name =>
Make_Identifier (Loc, Name_Init))));
Make_Identifier (Loc, Name_Init)));
-- The cursor is not modified in the source, but of course will
Set_Assignment_OK (Decl2);
Insert_Actions (N,
New_List (Decl1, Decl2));
end;
-- The Iterator is not modified in the source, but of course will
-- be updated in the generated code. Indicate that it is actually
-- set to prevent spurious warnings.
Set_Never_Set_In_Source (Cursor, False);
Set_Never_Set_In_Source (Iterator, False);
-- If the range of iteration is given by a function call that
-- returns a container, the finalization actions have been saved

7
gcc/ada/gnat1drv.adb
View File

@ -476,9 +476,12 @@ procedure Gnat1drv is
Global_Discard_Names := True;
-- Suppress the expansion of tagged types and dispatching calls
-- We would prefer to suppress the expansion of tagged types and
-- dispatching calls, so that one day GNATprove can handle them
-- directly. Unfortunately, this is causing problems on H513-015, so
-- keep this expansion for the time being.
Tagged_Type_Expansion := False;
Tagged_Type_Expansion := True;
end if;
end Adjust_Global_Switches;

2
gcc/ada/impunit.adb
View File

@ -346,7 +346,6 @@ package body Impunit is
"s-addima", -- System.Address_Image
"s-assert", -- System.Assertions
"s-finmas", -- System.Finalization_Masters
"s-memory", -- System.Memory
"s-parint", -- System.Partition_Interface
"s-pooglo", -- System.Pool_Global
@ -529,7 +528,6 @@ package body Impunit is
-- GNAT Defined Additions to Ada 20012 --
-----------------------------------------
"s-spsufi", -- System.Storage_Pools.Subpools.Finalization
"a-cofove", -- Ada.Containers.Formal_Vectors
"a-cfdlli", -- Ada.Containers.Formal_Doubly_Linked_Lists
"a-cforse", -- Ada.Containers.Formal_Ordered_Sets

41
gcc/ada/lib-xref-alfa.adb
View File

@ -835,39 +835,23 @@ package body ALFA is
declare
Srec : ALFA_Scope_Record renames ALFA_Scope_Table.Table (S);
Body_Entity : Entity_Id;
Spec_Entity : Entity_Id;
Spec_Scope : Scope_Index;
Spec_Entity : constant Entity_Id :=
Unique_Entity (Srec.Scope_Entity);
Spec_Scope : constant Scope_Index :=
Entity_Hash_Table.Get (Spec_Entity);
begin
if Ekind (Srec.Scope_Entity) = E_Subprogram_Body then
Body_Entity := Parent (Parent (Srec.Scope_Entity));
elsif Ekind (Srec.Scope_Entity) = E_Package_Body then
Body_Entity := Parent (Srec.Scope_Entity);
else
Body_Entity := Empty;
end if;
-- Spec of generic may be missing, in which case Spec_Scope is
-- zero.
if Present (Body_Entity) then
if Nkind (Body_Entity) = N_Defining_Program_Unit_Name then
Body_Entity := Parent (Body_Entity);
elsif Nkind (Body_Entity) = N_Subprogram_Body_Stub then
Body_Entity :=
Proper_Body (Unit (Library_Unit (Body_Entity)));
end if;
Spec_Entity := Corresponding_Spec (Body_Entity);
Spec_Scope := Entity_Hash_Table.Get (Spec_Entity);
-- Spec of generic may be missing
if Spec_Scope /= 0 then
if Spec_Entity /= Srec.Scope_Entity
and then Spec_Scope /= 0
then
Srec.Spec_File_Num :=
ALFA_Scope_Table.Table (Spec_Scope).File_Num;
Srec.Spec_Scope_Num :=
ALFA_Scope_Table.Table (Spec_Scope).Scope_Num;
end if;
end if;
end;
end loop;
end;
@ -1019,6 +1003,7 @@ package body ALFA is
end if;
when N_Package_Body_Stub =>
if Present (Library_Unit (N)) then
declare
Body_N : constant Node_Id := Get_Body_From_Stub (N);
begin
@ -1029,6 +1014,7 @@ package body ALFA is
Traverse_Package_Body (Body_N, Process, Inside_Stubs);
end if;
end;
end if;
-- Subprogram declaration
@ -1048,6 +1034,7 @@ package body ALFA is
end if;
when N_Subprogram_Body_Stub =>
if Present (Library_Unit (N)) then
declare
Body_N : constant Node_Id := Get_Body_From_Stub (N);
begin
@ -1055,9 +1042,11 @@ package body ALFA is
and then
not Is_Generic_Subprogram (Defining_Entity (Body_N))
then
Traverse_Subprogram_Body (Body_N, Process, Inside_Stubs);
Traverse_Subprogram_Body
(Body_N, Process, Inside_Stubs);
end if;
end;
end if;
-- Block statement

126
gcc/ada/s-finmas.adb
View File

@ -31,12 +31,32 @@
with Ada.Exceptions; use Ada.Exceptions;
with System.Address_Image;
with System.HTable; use System.HTable;
with System.IO; use System.IO;
with System.Soft_Links; use System.Soft_Links;
with System.Storage_Elements; use System.Storage_Elements;
package body System.Finalization_Masters is
-- Finalize_Address hash table types. In general, masters are homogeneous
-- collections of controlled objects. Rare cases such as allocations on a
-- subpool require heterogeneous masters. The following table provides a
-- relation between object address and its Finalize_Address routine.
type Header_Num is range 0 .. 127;
function Hash (Key : System.Address) return Header_Num;
-- Address --> Finalize_Address_Ptr
package Finalize_Address_Table is new Simple_HTable
(Header_Num => Header_Num,
Element => Finalize_Address_Ptr,
No_Element => null,
Key => System.Address,
Hash => Hash,
Equal => "=");
---------------------------
-- Add_Offset_To_Address --
---------------------------
@ -79,6 +99,17 @@ package body System.Finalization_Masters is
return Master.Base_Pool;
end Base_Pool;
-----------------------------
-- Delete_Finalize_Address --
-----------------------------
procedure Delete_Finalize_Address (Obj : System.Address) is
begin
Lock_Task.all;
Finalize_Address_Table.Remove (Obj);
Unlock_Task.all;
end Delete_Finalize_Address;
------------
-- Detach --
------------
@ -94,10 +125,10 @@ package body System.Finalization_Masters is
N.Next := null;
Unlock_Task.all;
end if;
-- Note: No need to unlock in case of an exception because the above
-- code can never raise one.
end if;
end Detach;
--------------
@ -105,6 +136,7 @@ package body System.Finalization_Masters is
--------------
overriding procedure Finalize (Master : in out Finalization_Master) is
Cleanup : Finalize_Address_Ptr;
Curr_Ptr : FM_Node_Ptr;
Ex_Occur : Exception_Occurrence;
Obj_Addr : Address;
@ -144,15 +176,27 @@ package body System.Finalization_Masters is
Detach (Curr_Ptr);
if Master.Finalize_Address /= null then
-- Skip the list header in order to offer proper object layout for
-- finalization and call Finalize_Address.
-- finalization.
Obj_Addr := Curr_Ptr.all'Address + Header_Offset;
-- Retrieve TSS primitive Finalize_Address depending on the master's
-- mode of operation.
if Master.Is_Homogeneous then
Cleanup := Master.Finalize_Address;
else
Cleanup := Get_Finalize_Address (Obj_Addr);
end if;
-- If Finalize_Address is not available, then this is most likely an
-- error in the expansion of the designated type or the allocator.
pragma Assert (Cleanup /= null);
begin
Master.Finalize_Address (Obj_Addr);
Cleanup (Obj_Addr);
exception
when Fin_Occur : others =>
@ -161,6 +205,12 @@ package body System.Finalization_Masters is
Save_Occurrence (Ex_Occur, Fin_Occur);
end if;
end;
-- When the master is a heterogeneous collection, destroy the object
-- - Finalize_Address pair since it is no longer needed.
if not Master.Is_Homogeneous then
Delete_Finalize_Address (Obj_Addr);
end if;
end loop;
@ -172,6 +222,23 @@ package body System.Finalization_Masters is
end if;
end Finalize;
--------------------------
-- Get_Finalize_Address --
--------------------------
function Get_Finalize_Address
(Obj : System.Address) return Finalize_Address_Ptr
is
Result : Finalize_Address_Ptr;
begin
Lock_Task.all;
Result := Finalize_Address_Table.Get (Obj);
Unlock_Task.all;
return Result;
end Get_Finalize_Address;
-----------------
-- Header_Size --
-----------------
@ -181,6 +248,17 @@ package body System.Finalization_Masters is
return FM_Node'Size / Storage_Unit;
end Header_Size;
----------
-- Hash --
----------
function Hash (Key : System.Address) return Header_Num is
begin
return
Header_Num
(To_Integer (Key) mod Integer_Address (Header_Num'Range_Length));
end Hash;
-------------------
-- Header_Offset --
-------------------
@ -202,11 +280,11 @@ package body System.Finalization_Masters is
Master.Objects.Prev := Master.Objects'Unchecked_Access;
end Initialize;
--------
-- pm --
--------
------------------
-- Print_Master --
------------------
procedure pm (Master : Finalization_Master) is
procedure Print_Master (Master : Finalization_Master) is
Head : constant FM_Node_Ptr := Master.Objects'Unrestricted_Access;
Head_Seen : Boolean := False;
N_Ptr : FM_Node_Ptr;
@ -215,6 +293,7 @@ package body System.Finalization_Masters is
-- Output the basic contents of a master
-- Master : 0x123456789
-- Is_Hmgen : TURE <or> FALSE
-- Base_Pool: null <or> 0x123456789
-- Fin_Addr : null <or> 0x123456789
-- Fin_Start: TRUE <or> FALSE
@ -222,8 +301,10 @@ package body System.Finalization_Masters is
Put ("Master : ");
Put_Line (Address_Image (Master'Address));
Put ("Base_Pool: ");
Put ("Is_Hmgen : ");
Put_Line (Master.Is_Homogeneous'Img);
Put ("Base_Pool: ");
if Master.Base_Pool = null then
Put_Line ("null");
else
@ -231,7 +312,6 @@ package body System.Finalization_Masters is
end if;
Put ("Fin_Addr : ");
if Master.Finalize_Address = null then
Put_Line ("null");
else
@ -255,17 +335,17 @@ package body System.Finalization_Masters is
-- Header - the address of the list header
-- Prev - the address of the list header which the current element
-- - points back to
-- points back to
-- Next - the address of the list header which the current element
-- - points to
-- points to
-- (dummy head) - present if dummy head
N_Ptr := Head;
while N_Ptr /= null loop -- Should never be null; we being defensive
while N_Ptr /= null loop -- Should never be null
Put_Line ("V");
-- We see the head initially; we want to exit when we see the head a
-- SECOND time.
-- second time.
if N_Ptr = Head then
exit when Head_Seen;
@ -321,7 +401,7 @@ package body System.Finalization_Masters is
N_Ptr := N_Ptr.Next;
end loop;
end pm;
end Print_Master;
-------------------
-- Set_Base_Pool --
@ -347,4 +427,18 @@ package body System.Finalization_Masters is
Master.Finalize_Address := Fin_Addr_Ptr;
end Set_Finalize_Address;
--------------------------
-- Set_Finalize_Address --
--------------------------
procedure Set_Finalize_Address
(Obj : System.Address;
Fin_Addr_Ptr : Finalize_Address_Ptr)
is
begin
Lock_Task.all;
Finalize_Address_Table.Set (Obj, Fin_Addr_Ptr);
Unlock_Task.all;
end Set_Finalize_Address;
end System.Finalization_Masters;

25
gcc/ada/s-finmas.ads
View File

@ -31,7 +31,6 @@
with Ada.Finalization;
with Ada.Unchecked_Conversion;
with System.Storage_Elements;
with System.Storage_Pools;
@ -69,9 +68,10 @@ package System.Finalization_Masters is
-- Finalization master type structure. A unique master is associated with
-- each access-to-controlled or access-to-class-wide type. Masters also act
-- as components of subpools.
-- as components of subpools. By default, a master contains objects of the
-- same designated type but it may also accomodate heterogeneous objects.
type Finalization_Master is
type Finalization_Master (Is_Homogeneous : Boolean := True) is
new Ada.Finalization.Limited_Controlled with
record
Base_Pool : Any_Storage_Pool_Ptr := null;
@ -83,7 +83,8 @@ package System.Finalization_Masters is
-- objects allocated in a [sub]pool.
Finalize_Address : Finalize_Address_Ptr := null;
-- A reference to the routine reponsible for object finalization
-- A reference to the routine reponsible for object finalization. This
-- is used only when the master is in homogeneous mode.
Finalization_Started : Boolean := False;
pragma Atomic (Finalization_Started);
@ -114,6 +115,10 @@ package System.Finalization_Masters is
-- Return a reference to the underlying storage pool on which the master
-- operates.
procedure Delete_Finalize_Address (Obj : System.Address);
-- Destroy the relation pair object - Finalize_Address from the internal
-- hash table.
procedure Detach (N : not null FM_Node_Ptr);
-- Remove a node from an arbitrary finalization master
@ -122,6 +127,11 @@ package System.Finalization_Masters is
-- the list of allocated controlled objects, finalizing each one by calling
-- its specific Finalize_Address. In the end, deallocate the dummy head.
function Get_Finalize_Address
(Obj : System.Address) return Finalize_Address_Ptr;
-- Retrieve the Finalize_Address primitive associated with a particular
-- object.
function Header_Offset return System.Storage_Elements.Storage_Offset;
-- Return the size of type FM_Node as Storage_Offset
@ -131,7 +141,7 @@ package System.Finalization_Masters is
overriding procedure Initialize (Master : in out Finalization_Master);
-- Initialize the dummy head of a finalization master
procedure pm (Master : Finalization_Master);
procedure Print_Master (Master : Finalization_Master);
-- Debug routine, outputs the contents of a master
procedure Set_Base_Pool
@ -144,4 +154,9 @@ package System.Finalization_Masters is
Fin_Addr_Ptr : Finalize_Address_Ptr);
-- Set the clean up routine of a finalization master
procedure Set_Finalize_Address
(Obj : System.Address;
Fin_Addr_Ptr : Finalize_Address_Ptr);
-- Add a relation pair object - Finalize_Address to the internal hash table
end System.Finalization_Masters;

205
gcc/ada/s-stposu.adb
View File

@ -31,8 +31,9 @@
with Ada.Exceptions; use Ada.Exceptions;
with Ada.Unchecked_Deallocation;
with System.Address_Image;
with System.Finalization_Masters; use System.Finalization_Masters;
with System.IO; use System.IO;
with System.Soft_Links; use System.Soft_Links;
with System.Storage_Elements; use System.Storage_Elements;
@ -254,15 +255,33 @@ package body System.Storage_Pools.Subpools is
Attach (N_Ptr, Master.Objects'Unchecked_Access);
if Master.Finalize_Address = null then
Master.Finalize_Address := Fin_Address;
end if;
-- Move the address from the hidden list header to the start of the
-- object. This operation effectively hides the list header.
Addr := N_Addr + Header_And_Padding;
-- Subpool allocations use heterogeneous masters to manage various
-- controlled objects. Associate a Finalize_Address with the object.
-- This relation pair is deleted when the object is deallocated or
-- when the associated master is finalized.
if Is_Subpool_Allocation then
pragma Assert (not Master.Is_Homogeneous);
Set_Finalize_Address (Addr, Fin_Address);
-- Normal allocations chain objects on homogeneous collections
else
pragma Assert (Master.Is_Homogeneous);
if Master.Finalize_Address = null then
Master.Finalize_Address := Fin_Address;
end if;
end if;
-- Non-controlled allocation
else
Addr := N_Addr;
end if;
@ -315,6 +334,14 @@ package body System.Storage_Pools.Subpools is
if Is_Controlled then
-- Destroy the relation pair object - Finalize_Address since it is no
-- longer needed. If the object was chained on a homogeneous master,
-- this call does nothing. This is unconditional destruction since we
-- do not want to drag in additional data to determine the master
-- kind.
Delete_Finalize_Address (Addr);
-- Account for possible padding space before the header due to a
-- larger alignment.
@ -382,6 +409,8 @@ package body System.Storage_Pools.Subpools is
N.Prev.Next := N.Next;
N.Next.Prev := N.Prev;
N.Prev := null;
N.Next := null;
Unlock_Task.all;
@ -405,9 +434,22 @@ package body System.Storage_Pools.Subpools is
procedure Finalize_Pool (Pool : in out Root_Storage_Pool_With_Subpools) is
Curr_Ptr : SP_Node_Ptr;
Ex_Occur : Exception_Occurrence;
Next_Ptr : SP_Node_Ptr;
Raised : Boolean := False;
function Is_Empty_List (L : not null SP_Node_Ptr) return Boolean;
-- Determine whether a list contains only one element, the dummy head
-------------------
-- Is_Empty_List --
-------------------
function Is_Empty_List (L : not null SP_Node_Ptr) return Boolean is
begin
return L.Next = L and then L.Prev = L;
end Is_Empty_List;
-- Start of processing for Finalize_Pool
begin
-- It is possible for multiple tasks to cause the finalization of a
-- common pool. Allow only one task to finalize the contents.
@ -423,11 +465,8 @@ package body System.Storage_Pools.Subpools is
Pool.Finalization_Started := True;
-- Skip the dummy head
while not Is_Empty_List (Pool.Subpools'Unchecked_Access) loop
Curr_Ptr := Pool.Subpools.Next;
while Curr_Ptr /= Pool.Subpools'Unchecked_Access loop
Next_Ptr := Curr_Ptr.Next;
-- Perform the following actions:
@ -446,8 +485,6 @@ package body System.Storage_Pools.Subpools is
Save_Occurrence (Ex_Occur, Fin_Occur);
end if;
end;
Curr_Ptr := Next_Ptr;
end loop;
-- If the finalization of a particular master failed, reraise the
@ -537,6 +574,150 @@ package body System.Storage_Pools.Subpools is
return Subpool.Owner;
end Pool_Of_Subpool;
----------------
-- Print_Pool --
----------------
procedure Print_Pool (Pool : Root_Storage_Pool_With_Subpools) is
Head : constant SP_Node_Ptr := Pool.Subpools'Unrestricted_Access;
Head_Seen : Boolean := False;
SP_Ptr : SP_Node_Ptr;
begin
-- Output the contents of the pool
-- Pool : 0x123456789
-- Subpools : 0x123456789
-- Fin_Start : TRUE <or> FALSE
-- Controller: OK <or> NOK
Put ("Pool : ");
Put_Line (Address_Image (Pool'Address));
Put ("Subpools : ");
Put_Line (Address_Image (Pool.Subpools'Address));
Put ("Fin_Start : ");
Put_Line (Pool.Finalization_Started'Img);
Put ("Controlled: ");
if Pool.Controller.Enclosing_Pool = Pool'Unrestricted_Access then
Put_Line ("OK");
else
Put_Line ("NOK (ERROR)");
end if;
SP_Ptr := Head;
while SP_Ptr /= null loop -- Should never be null
Put_Line ("V");
-- We see the head initially; we want to exit when we see the head a
-- second time.
if SP_Ptr = Head then
exit when Head_Seen;
Head_Seen := True;
end if;
-- The current element is null. This should never happend since the
-- list is circular.
if SP_Ptr.Prev = null then
Put_Line ("null (ERROR)");
-- The current element points back to the correct element
elsif SP_Ptr.Prev.Next = SP_Ptr then
Put_Line ("^");
-- The current element points to an erroneous element
else
Put_Line ("? (ERROR)");
end if;
-- Output the contents of the node
Put ("|Header: ");
Put (Address_Image (SP_Ptr.all'Address));
if SP_Ptr = Head then
Put_Line (" (dummy head)");
else
Put_Line ("");
end if;
Put ("| Prev: ");
if SP_Ptr.Prev = null then
Put_Line ("null");
else
Put_Line (Address_Image (SP_Ptr.Prev.all'Address));
end if;
Put ("| Next: ");
if SP_Ptr.Next = null then
Put_Line ("null");
else
Put_Line (Address_Image (SP_Ptr.Next.all'Address));
end if;
Put ("| Subp: ");
if SP_Ptr.Subpool = null then
Put_Line ("null");
else
Put_Line (Address_Image (SP_Ptr.Subpool.all'Address));
end if;
SP_Ptr := SP_Ptr.Next;
end loop;
end Print_Pool;
-------------------
-- Print_Subpool --
-------------------
procedure Print_Subpool (Subpool : Subpool_Handle) is
begin
if Subpool = null then
Put_Line ("null");
return;
end if;
-- Output the contents of a subpool
-- Owner : 0x123456789
-- Master: 0x123456789
-- Node : 0x123456789
Put ("Owner : ");
if Subpool.Owner = null then
Put_Line ("null");
else
Put_Line (Address_Image (Subpool.Owner'Address));
end if;
Put ("Master: ");
Put_Line (Address_Image (Subpool.Master'Address));
Put ("Node : ");
if Subpool.Node = null then
Put ("null");
if Subpool.Owner = null then
Put_Line (" OK");
else
Put_Line (" (ERROR)");
end if;
else
Put_Line (Address_Image (Subpool.Node'Address));
end if;
Print_Master (Subpool.Master);
end Print_Subpool;
-------------------------
-- Set_Pool_Of_Subpool --
-------------------------

11
gcc/ada/s-stposu.ads
View File

@ -34,7 +34,6 @@
------------------------------------------------------------------------------
with Ada.Finalization;
with System.Finalization_Masters;
with System.Storage_Elements;
@ -241,8 +240,8 @@ private
Owner : Any_Storage_Pool_With_Subpools_Ptr := null;
-- A reference to the master pool_with_subpools
Master : aliased System.Finalization_Masters.Finalization_Master;
-- A collection of controlled objects
Master : aliased System.Finalization_Masters.Finalization_Master (False);
-- A heterogeneous collection of controlled objects
Node : SP_Node_Ptr := null;
-- A link to the doubly linked list node which contains the subpool.
@ -336,4 +335,10 @@ private
procedure Initialize_Pool (Pool : in out Root_Storage_Pool_With_Subpools);
-- Setup the doubly linked list of subpools
procedure Print_Pool (Pool : Root_Storage_Pool_With_Subpools);
-- Debug routine, output the contents of a pool_with_subpools
procedure Print_Subpool (Subpool : Subpool_Handle);
-- Debug routine, output the contents of a subpool
end System.Storage_Pools.Subpools;

7
gcc/ada/sem_ch13.adb
View File

@ -1904,7 +1904,7 @@ package body Sem_Ch13 is
Get_First_Interp (Expr, I, It);
while Present (It.Nam) loop
if not Check_Primitive_Function (It.Nam)
or else Valid_Default_Iterator (It.Nam)
or else not Valid_Default_Iterator (It.Nam)
then
Remove_Interp (I);
@ -5767,8 +5767,13 @@ package body Sem_Ch13 is
A_Id = Aspect_Default_Iterator or else
A_Id = Aspect_Iterator_Element
then
-- Make type unfrozen before analysis, to prevent spurious
-- errors about late attributes.
Set_Is_Frozen (Ent, False);
Analyze (End_Decl_Expr);
Analyze (Aspect_Rep_Item (ASN));
Set_Is_Frozen (Ent, True);
-- If the end of declarations comes before any other freeze
-- point, the Freeze_Expr is not analyzed: no check needed.

6
gcc/ada/sem_ch3.adb
View File

@ -15003,6 +15003,12 @@ package body Sem_Ch3 is
Set_Has_Private_Declaration (Prev);
Set_Has_Private_Declaration (Id);
-- Preserve aspect and iterator flags, that may have been
-- set on the partial view.
Set_Has_Delayed_Aspects (Prev, Has_Delayed_Aspects (Id));
Set_Has_Implicit_Dereference (Prev, Has_Implicit_Dereference (Id));
-- If no error, propagate freeze_node from private to full view.
-- It may have been generated for an early operational item.

19
gcc/ada/sem_ch4.adb
View File

@ -30,6 +30,7 @@ with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
with Exp_Util; use Exp_Util;
with Expander; use Expander;
with Fname; use Fname;
with Itypes; use Itypes;
with Lib; use Lib;
@ -2235,6 +2236,10 @@ package body Sem_Ch4 is
Check_Implicit_Dereference (N, CT);
end;
end if;
elsif Try_Container_Indexing (N, P, First (Exprs)) then
return;
end if;
Get_Next_Interp (I, It);
@ -3340,6 +3345,7 @@ package body Sem_Ch4 is
Iterator : Node_Id;
begin
Expander_Mode_Save_And_Set (False);
Check_SPARK_Restriction ("quantified expression is not allowed", N);
Set_Etype (Ent, Standard_Void_Type);
@ -3373,8 +3379,8 @@ package body Sem_Ch4 is
Analyze (Condition (N));
End_Scope;
Set_Etype (N, Standard_Boolean);
Expander_Mode_Restore;
end Analyze_Quantified_Expression;
-------------------
@ -6366,8 +6372,19 @@ package body Sem_Ch4 is
-- diagnosed in caller.
if No (Func_Name) then
-- The prefix itself may be an indexing of a container
-- rewrite as such and re-analyze.
if Has_Implicit_Dereference (Etype (Prefix)) then
Build_Explicit_Dereference
(Prefix, First_Discriminant (Etype (Prefix)));
return Try_Container_Indexing (N, Prefix, Expr);
else
return False;
end if;
end if;
if Is_Var
and then not Is_Variable (Prefix)

149
gcc/ada/sem_ch5.adb
View File

@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
with Einfo; use Einfo;
@ -2005,7 +2006,22 @@ package body Sem_Ch5 is
Set_Parent (D_Copy, Parent (DS));
Pre_Analyze_Range (D_Copy);
-- Ada2012 : if the domain of iteration is a function call,
-- it is the new iterator form.
-- We have also implemented the shorter form : for X in S
-- for Alfa use. In this case the attributes Old and Result
-- must be treated as entity names over which iterators are
-- legal.
if Nkind (D_Copy) = N_Function_Call
or else
(ALFA_Mode
and then (Nkind (D_Copy) = N_Attribute_Reference
and then
(Attribute_Name (D_Copy) = Name_Result
or else Attribute_Name (D_Copy) = Name_Old)))
or else
(Is_Entity_Name (D_Copy)
and then not Is_Type (Entity (D_Copy)))
@ -2027,6 +2043,14 @@ package body Sem_Ch5 is
Set_Iterator_Specification (N, I_Spec);
Set_Loop_Parameter_Specification (N, Empty);
Analyze_Iterator_Specification (I_Spec);
-- In a generic context, analyze the original
-- domain of iteration, for name capture.
if not Expander_Active then
Analyze (DS);
end if;
return;
end;
@ -2207,7 +2231,7 @@ package body Sem_Ch5 is
Loc : constant Source_Ptr := Sloc (N);
Def_Id : constant Node_Id := Defining_Identifier (N);
Subt : constant Node_Id := Subtype_Indication (N);
Container : constant Node_Id := Name (N);
Iter_Name : constant Node_Id := Name (N);
Ent : Entity_Id;
Typ : Entity_Id;
@ -2220,45 +2244,83 @@ package body Sem_Ch5 is
Analyze (Subt);
end if;
-- If it is an expression, the container is pre-analyzed in the caller.
-- If it is an expression, the name is pre-analyzed in the caller.
-- If it it of a controlled type we need a block for the finalization
-- actions. As for loop bounds that need finalization, we create a
-- declaration and an assignment to trigger these actions.
if Present (Etype (Container))
and then Is_Controlled (Etype (Container))
and then not Is_Entity_Name (Container)
if Present (Etype (Iter_Name))
and then Is_Controlled (Etype (Iter_Name))
and then not Is_Entity_Name (Iter_Name)
then
declare
Id : constant Entity_Id := Make_Temporary (Loc, 'R', Container);
Id : constant Entity_Id := Make_Temporary (Loc, 'R', Iter_Name);
Decl : Node_Id;
Assign : Node_Id;
begin
Typ := Etype (Container);
Typ := Etype (Iter_Name);
Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Id,
Object_Definition => New_Occurrence_Of (Typ, Loc));
Object_Definition => New_Occurrence_Of (Typ, Loc),
Expression => Relocate_Node (Iter_Name));
Assign :=
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Id, Loc),
Expression => Relocate_Node (Container));
Insert_Actions (Parent (N), New_List (Decl, Assign));
Insert_Actions
(Parent (Parent (N)), New_List (Decl));
Rewrite (Name (N), New_Occurrence_Of (Id, Loc));
Set_Etype (Id, Typ);
Set_Etype (Name (N), Typ);
end;
else
-- Container is an entity or an array with uncontrolled components
-- Container is an entity or an array with uncontrolled components,
-- or else it is a container iterator given by a function call,
-- typically called Iterate in the case of predefined containers,
-- even though Iterate is not a reserved name. What matter is that
-- the return type of the function is an iterator type.
Analyze_And_Resolve (Container);
Analyze (Iter_Name);
if Nkind (Iter_Name) = N_Function_Call then
declare
C : constant Node_Id := Name (Iter_Name);
I : Interp_Index;
It : Interp;
begin
if not Is_Overloaded (Iter_Name) then
Resolve (Iter_Name, Etype (C));
else
Get_First_Interp (C, I, It);
while It.Typ /= Empty loop
if Reverse_Present (N) then
if Is_Reversible_Iterator (It.Typ) then
Resolve (Iter_Name, It.Typ);
exit;
end if;
Typ := Etype (Container);
elsif Is_Iterator (It.Typ) then
Resolve (Iter_Name, It.Typ);
exit;
end if;
Get_Next_Interp (I, It);
end loop;
end if;
end;
else
-- domain of iteration is not overloaded.
Resolve (Iter_Name, Etype (Iter_Name));
end if;
end if;
Typ := Etype (Iter_Name);
if Is_Array_Type (Typ) then
if Of_Present (N) then
@ -2269,33 +2331,58 @@ package body Sem_Ch5 is
Set_Etype (Def_Id, Etype (First_Index (Typ)));
end if;
-- Check for type error in iterator.
elsif Typ = Any_Type then
return;
-- Iteration over a container
else
Set_Ekind (Def_Id, E_Loop_Parameter);
if Of_Present (N) then
-- If the container has already been rewritten as a
-- call to the default iterator, nothing to do. This
-- is the case with the expansion of a quantified
-- expression.
-- Find the Element_Type in the package instance that defines the
-- container type.
if Nkind (Name (N)) = N_Function_Call
and then not Comes_From_Source (Name (N))
then
null;
Ent := First_Entity (Scope (Base_Type (Typ)));
while Present (Ent) loop
if Chars (Ent) = Name_Element_Type then
Set_Etype (Def_Id, Ent);
exit;
elsif Expander_Active then
-- Find the Iterator_Element and the default_iterator
-- of the container type.
Set_Etype (Def_Id,
Entity (
Find_Aspect (Typ, Aspect_Iterator_Element)));
declare
Default_Iter : constant Entity_Id :=
Find_Aspect (Typ, Aspect_Default_Iterator);
begin
Rewrite (Name (N),
Make_Function_Call (Loc,
Name => Default_Iter,
Parameter_Associations =>
New_List (Relocate_Node (Iter_Name))));
Analyze_And_Resolve (Name (N));
end;
end if;
Next_Entity (Ent);
end loop;
else
-- Find the Cursor type in similar fashion
-- result type of Iterate function is the classwide
-- type of the interface parent. We need the specific
-- Cursor type defined in the package.
Ent := First_Entity (Scope (Base_Type (Typ)));
Ent := First_Entity (Scope (Typ));
while Present (Ent) loop
if Chars (Ent) = Name_Cursor then
Set_Etype (Def_Id, Ent);
Set_Etype (Def_Id, Etype (Ent));
exit;
end if;

8
gcc/ada/sem_ch6.adb
View File

@ -9749,12 +9749,13 @@ package body Sem_Ch6 is
if AS_Needed then
if Nkind (N) = N_Accept_Statement then
-- If expansion is active, The formal is replaced by a local
-- If expansion is active, the formal is replaced by a local
-- variable that renames the corresponding entry of the
-- parameter block, and it is this local variable that may
-- require an actual subtype.
-- require an actual subtype. In ALFA mode, expansion of accept
-- statements is skipped.
if Expander_Active then
if Expander_Active and not ALFA_Mode then
Decl := Build_Actual_Subtype (T, Renamed_Object (Formal));
else
Decl := Build_Actual_Subtype (T, Formal);
@ -9794,6 +9795,7 @@ package body Sem_Ch6 is
if Nkind (N) = N_Accept_Statement
and then Expander_Active
and then not ALFA_Mode
then
Set_Actual_Subtype (Renamed_Object (Formal),
Defining_Identifier (Decl));

53
gcc/ada/sem_util.adb
View File

@ -12472,21 +12472,56 @@ package body Sem_Util is
function Unique_Defining_Entity (N : Node_Id) return Entity_Id is
begin
case Nkind (N) is
when N_Package_Body =>
return Corresponding_Spec (N);
return Unique_Entity (Defining_Entity (N));
end Unique_Defining_Entity;
when N_Subprogram_Body =>
if Acts_As_Spec (N) then
return Defining_Entity (N);
-------------------
-- Unique_Entity --
-------------------
function Unique_Entity (E : Entity_Id) return Entity_Id is
U : Entity_Id := E;
P : Node_Id;
begin
case Ekind (E) is
when Type_Kind =>
if Present (Full_View (E)) then
U := Full_View (E);
end if;
when E_Package_Body =>
P := Parent (E);
if Nkind (P) = N_Defining_Program_Unit_Name then
P := Parent (P);
end if;
U := Corresponding_Spec (P);
when E_Subprogram_Body =>
P := Parent (E);
if Nkind (P) = N_Defining_Program_Unit_Name then
P := Parent (P);
end if;
P := Parent (P);
if Nkind (P) = N_Subprogram_Body_Stub then
if Present (Library_Unit (P)) then
U := Get_Body_From_Stub (P);
end if;
else
return Corresponding_Spec (N);
U := Corresponding_Spec (P);
end if;
when others =>
return Defining_Entity (N);
null;
end case;
end Unique_Defining_Entity;
return U;
end Unique_Entity;
-----------------
-- Unique_Name --

12
gcc/ada/sem_util.ads
View File

@ -1421,8 +1421,16 @@ package Sem_Util is
-- specified we check only for the given stream operation.
function Unique_Defining_Entity (N : Node_Id) return Entity_Id;
-- Return the entity which represents declaration N, so that matching
-- declaration and body have the same entity.
-- Return the entity which represents declaration N, so that different
-- views of the same entity have the same unique defining entity:
-- * package spec and body;
-- * subprogram declaration, subprogram stub and subprogram body;
-- * private view and full view of a type.
-- In other cases, return the defining entity for N.
function Unique_Entity (E : Entity_Id) return Entity_Id;
-- Return the unique entity for entity E, which would be returned by
-- Unique_Defining_Entity if applied to the enclosing declaration of E.
function Unique_Name (E : Entity_Id) return String;
-- Return a unique name for entity E, which could be used to identify E

5
gcc/ada/sprint.adb
View File

@ -2709,7 +2709,12 @@ package body Sprint is
Write_Str (" some ");
end if;
if Present (Iterator_Specification (Node)) then
Sprint_Node (Iterator_Specification (Node));
else
Sprint_Node (Loop_Parameter_Specification (Node));
end if;
Write_Str (" => ");
Sprint_Node (Condition (Node));

44
gcc/ada/treepr.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2011, 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- --
@ -263,11 +263,40 @@ package body Treepr is
-- pn --
--------
procedure pn (N : Node_Id) is
procedure pn (N : Union_Id) is
begin
Print_Tree_Node (N);
case N is
when List_Low_Bound .. List_High_Bound - 1 =>
pl (Int (N));
when Node_Range =>
Print_Tree_Node (Node_Id (N));
when Elist_Range =>
Print_Tree_Elist (Elist_Id (N));
when Elmt_Range =>
raise Program_Error;
when Names_Range =>
Namet.wn (Name_Id (N));
when Strings_Range =>
Write_String_Table_Entry (String_Id (N));
when Uint_Range =>
Uintp.pid (From_Union (N));
when Ureal_Range =>
Urealp.pr (From_Union (N));
when others =>
Write_Str ("Invalid Union_Id: ");
Write_Int (Int (N));
end case;
end pn;
--------
-- pp --
--------
procedure pp (N : Union_Id) is
begin
pn (N);
end pp;
----------------
-- Print_Char --
----------------
@ -1471,6 +1500,15 @@ package body Treepr is
Print_Node_Subtree (N);
end pt;
---------
-- ppp --
---------
procedure ppp (N : Node_Id) is
begin
pt (N);
end ppp;
-------------------
-- Serial_Number --
-------------------

33
gcc/ada/treepr.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2011, 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- --
@ -57,25 +57,36 @@ package Treepr is
-- Prints the subtree consisting of the given element list and all its
-- referenced descendants.
-- The following debugging procedures are intended to be called from gdb
procedure pp (N : Union_Id);
pragma Export (Ada, pp);
-- Prints a node, node list, uint, or anything else that falls under
-- Union_Id.
procedure ppp (N : Node_Id);
pragma Export (Ada, ppp);
-- Same as Print_Node_Subtree
-- The following are no longer needed; you can use pp or ppp instead
procedure pe (E : Elist_Id);
pragma Export (Ada, pe);
-- Debugging procedure (to be called within gdb), same as Print_Tree_Elist
-- Same as Print_Tree_Elist
procedure pl (L : Int);
pragma Export (Ada, pl);
-- Debugging procedure (to be called within gdb), same as Print_Tree_List,
-- except that you can use e.g. 66 instead of -99999966. In other words
-- for the positive case we fill out to 8 digits on the left and add a
-- minus sign. This just saves some typing in the debugger.
-- Same as Print_Tree_List, except that you can use e.g. 66 instead of
-- -99999966. In other words for the positive case we fill out to 8 digits
-- on the left and add a minus sign. This just saves some typing in the
-- debugger.
procedure pn (N : Node_Id);
procedure pn (N : Union_Id);
pragma Export (Ada, pn);
-- Debugging procedure (to be called within gdb)
-- same as Print_Tree_Node with Label = ""
-- Same as pp
procedure pt (N : Node_Id);
pragma Export (Ada, pt);
-- Debugging procedure (to be called within gdb)
-- same as Print_Node_Subtree
-- Same as ppp
end Treepr;