Skip to content

R
riscv-gcc-1
Commit cfae2bed by Arnaud Charlet
Options

[multiple changes] 

2011-08-04  Robert Dewar  <dewar@adacore.com>

	* sem_util.adb: Minor reformatting.

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

	* bindgen.adb (Gen_Finalize_Library_Ada): Update the import string for
	library-level finalizers.
	(Gen_Finalize_Library_C): Update the import string for library-level
	finalizers.
	(Gen_Finalize_Library_Defs_C): Update the definition name of a
	library-level finalizer.
	* exp_ch7.adb: Remove with and use clauses for Stringt.
	(Create_Finalizer): Remove local variables Conv_Name, Prag_Decl,
	Spec_Decl. Add local variable Body_Id. The names of library-level
	finalizers are now manually fully qualified and are no longer external.
	A single name is now capable of servicing .NET, JVM and non-VM targets.
	Pragma Export is no longer required to provide visibility for the name.
	(Create_Finalizer_String): Removed.
	(New_Finalizer_Name): New routine which mimics New_..._Name.

From-SVN: r177322
parent 01f0729a
Showing with 221 additions and 343 deletions
gcc/ada/ChangeLog
2011-08-04 Robert Dewar <dewar@adacore.com>
* sem_util.adb: Minor reformatting.
2011-08-04 Hristian Kirtchev <kirtchev@adacore.com>
* bindgen.adb (Gen_Finalize_Library_Ada): Update the import string for
library-level finalizers.
(Gen_Finalize_Library_C): Update the import string for library-level
finalizers.
(Gen_Finalize_Library_Defs_C): Update the definition name of a
library-level finalizer.
* exp_ch7.adb: Remove with and use clauses for Stringt.
(Create_Finalizer): Remove local variables Conv_Name, Prag_Decl,
Spec_Decl. Add local variable Body_Id. The names of library-level
finalizers are now manually fully qualified and are no longer external.
A single name is now capable of servicing .NET, JVM and non-VM targets.
Pragma Export is no longer required to provide visibility for the name.
(Create_Finalizer_String): Removed.
(New_Finalizer_Name): New routine which mimics New_..._Name.
2011-08-04 Eric Botcazou <ebotcazou@adacore.com> 2011-08-04 Eric Botcazou <ebotcazou@adacore.com>
* sem_elab.adb (Check_Internal_Call_Continue): Change the type of the * sem_elab.adb (Check_Internal_Call_Continue): Change the type of the
......
gcc/ada/bindgen.adb
...@@ -1688,13 +1688,16 @@ package body Bindgen is ...@@ -1688,13 +1688,16 @@ package body Bindgen is
Write_Statement_Buffer; Write_Statement_Buffer;
-- Generate: -- Generate:
-- pragma Import (CIL, F<Count>, "xx.yy_pkg.Finalize[B/S]"); -- pragma Import (CIL, F<Count>,
-- "xx.yy_pkg.xx__yy__finalize_[body|spec]");
-- -- for .NET targets -- -- for .NET targets
-- pragma Import (Java, F<Count>, "xx$yy.Finalize[B/S]"); -- pragma Import (Java, F<Count>,
-- "xx$yy.xx__yy__finalize_[body|spec]");
-- -- for JVM targets -- -- for JVM targets
-- pragma Import (Ada, F<Count>, "xx__yy__Finalize[B/S]"); -- pragma Import (Ada, F<Count>,
-- "xx__yy__finalize_[body|spec]");
-- -- for default targets -- -- for default targets
if VM_Target = CLI_Target then if VM_Target = CLI_Target then
...@@ -1723,36 +1726,35 @@ package body Bindgen is ...@@ -1723,36 +1726,35 @@ package body Bindgen is
-- Perform name construction -- Perform name construction
-- .NET xx.yy_pkg.finalize -- .NET xx.yy_pkg.xx__yy__finalize
if VM_Target = CLI_Target then if VM_Target = CLI_Target then
Set_Unit_Name (Mode => Dot); Set_Unit_Name (Mode => Dot);
Set_String ("_pkg.finalize"); Set_String ("_pkg.");
-- JVM xx$yy.finalize -- JVM xx$yy.xx__yy__finalize
elsif VM_Target = JVM_Target then elsif VM_Target = JVM_Target then
Set_Unit_Name (Mode => Dollar_Sign); Set_Unit_Name (Mode => Dollar_Sign);
Set_String (".finalize"); Set_Char ('.');
end if;
-- Default xx__yy__finalize -- Default xx__yy__finalize
else
Set_Unit_Name; Set_Unit_Name;
Set_String ("__finalize"); Set_String ("__finalize_");
end if;
-- Package spec processing -- Package spec processing
if U.Utype = Is_Spec if U.Utype = Is_Spec
or else U.Utype = Is_Spec_Only or else U.Utype = Is_Spec_Only
then then
Set_Char ('S'); Set_String ("spec");
-- Package body processing -- Package body processing
else else
Set_Char ('B'); Set_String ("body");
end if; end if;
Set_String (""");"); Set_String (""");");
...@@ -1895,12 +1897,12 @@ package body Bindgen is ...@@ -1895,12 +1897,12 @@ package body Bindgen is
-- uname_E--; -- uname_E--;
-- if (uname_E == 0) -- if (uname_E == 0)
-- uname__finalize[S|B] (); -- uname__finalize_[spec|body] ();
-- Otherwise, finalization routines are called unconditionally: -- Otherwise, finalization routines are called unconditionally:
-- uname_E--; -- uname_E--;
-- uname__finalize[S|B] (); -- uname__finalize_[spec|body] ();
Set_String (" "); Set_String (" ");
Set_Unit_Name; Set_Unit_Name;
...@@ -1918,19 +1920,19 @@ package body Bindgen is ...@@ -1918,19 +1920,19 @@ package body Bindgen is
Set_String (" "); Set_String (" ");
Get_Name_String (Uspec.Uname); Get_Name_String (Uspec.Uname);
Set_Unit_Name; Set_Unit_Name;
Set_String ("__finalize"); Set_String ("__finalize_");
-- Package spec processing -- Package spec processing
if U.Utype = Is_Spec if U.Utype = Is_Spec
or else U.Utype = Is_Spec_Only or else U.Utype = Is_Spec_Only
then then
Set_Char ('S'); Set_String ("spec");
-- Package body processing -- Package body processing
else else
Set_Char ('B'); Set_String ("body");
end if; end if;
Set_String (" ();"); Set_String (" ();");
...@@ -1982,14 +1984,14 @@ package body Bindgen is ...@@ -1982,14 +1984,14 @@ package body Bindgen is
Set_String ("extern void "); Set_String ("extern void ");
Get_Name_String (Uspec.Uname); Get_Name_String (Uspec.Uname);
Set_Unit_Name; Set_Unit_Name;
Set_String ("__finalize"); Set_String ("__finalize_");
if U.Utype = Is_Spec if U.Utype = Is_Spec
or else U.Utype = Is_Spec_Only or else U.Utype = Is_Spec_Only
then then
Set_Char ('S'); Set_String ("spec");
else else
Set_Char ('B'); Set_String ("body");
end if; end if;
Set_String (" (void);"); Set_String (" (void);");
......
gcc/ada/exp_ch7.adb
...@@ -59,7 +59,6 @@ with Sem_Res; use Sem_Res; ...@@ -59,7 +59,6 @@ with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util; with Sem_Util; use Sem_Util;
with Snames; use Snames; with Snames; use Snames;
with Stand; use Stand; with Stand; use Stand;
with Stringt; use Stringt;
with Targparm; use Targparm; with Targparm; use Targparm;
with Tbuild; use Tbuild; with Tbuild; use Tbuild;
with Ttypes; use Ttypes; with Ttypes; use Ttypes;
...@@ -448,22 +447,22 @@ package body Exp_Ch7 is ...@@ -448,22 +447,22 @@ package body Exp_Ch7 is
procedure Build_Array_Deep_Procs (Typ : Entity_Id) is procedure Build_Array_Deep_Procs (Typ : Entity_Id) is
begin begin
Set_TSS (Typ, Set_TSS (Typ,
Make_Deep_Proc ( Make_Deep_Proc
Prim => Initialize_Case, (Prim => Initialize_Case,
Typ => Typ, Typ => Typ,
Stmts => Make_Deep_Array_Body (Initialize_Case, Typ))); Stmts => Make_Deep_Array_Body (Initialize_Case, Typ)));
if not Is_Immutably_Limited_Type (Typ) then if not Is_Immutably_Limited_Type (Typ) then
Set_TSS (Typ, Set_TSS (Typ,
Make_Deep_Proc ( Make_Deep_Proc
Prim => Adjust_Case, (Prim => Adjust_Case,
Typ => Typ, Typ => Typ,
Stmts => Make_Deep_Array_Body (Adjust_Case, Typ))); Stmts => Make_Deep_Array_Body (Adjust_Case, Typ)));
end if; end if;
Set_TSS (Typ, Set_TSS (Typ,
Make_Deep_Proc ( Make_Deep_Proc
Prim => Finalize_Case, (Prim => Finalize_Case,
Typ => Typ, Typ => Typ,
Stmts => Make_Deep_Array_Body (Finalize_Case, Typ))); Stmts => Make_Deep_Array_Body (Finalize_Case, Typ)));
...@@ -784,15 +783,12 @@ package body Exp_Ch7 is ...@@ -784,15 +783,12 @@ package body Exp_Ch7 is
Make_If_Statement (Loc, Make_If_Statement (Loc,
Condition => Condition =>
Make_Op_Not (Loc, Make_Op_Not (Loc,
Right_Opnd => Right_Opnd => New_Reference_To (Raised_Id, Loc)),
New_Reference_To (Raised_Id, Loc)),
Then_Statements => New_List ( Then_Statements => New_List (
Make_Assignment_Statement (Loc, Make_Assignment_Statement (Loc,
Name => Name => New_Reference_To (Raised_Id, Loc),
New_Reference_To (Raised_Id, Loc), Expression => New_Reference_To (Standard_True, Loc)),
Expression =>
New_Reference_To (Standard_True, Loc)),
Make_Procedure_Call_Statement (Loc, Make_Procedure_Call_Statement (Loc,
Name => Name =>
...@@ -922,8 +918,7 @@ package body Exp_Ch7 is ...@@ -922,8 +918,7 @@ package body Exp_Ch7 is
if Comes_From_Source (Typ) then if Comes_From_Source (Typ) then
Coll_Id := Coll_Id :=
Make_Defining_Identifier (Loc, Make_Defining_Identifier (Loc,
Chars => Chars => New_External_Name (Chars (Typ), "FC"));
New_External_Name (Chars (Typ), "FC"));
else else
Coll_Id := Make_Temporary (Loc, 'F'); Coll_Id := Make_Temporary (Loc, 'F');
end if; end if;
...@@ -978,8 +973,7 @@ package body Exp_Ch7 is ...@@ -978,8 +973,7 @@ package body Exp_Ch7 is
Parameter_Associations => New_List ( Parameter_Associations => New_List (
New_Reference_To (Coll_Id, Loc), New_Reference_To (Coll_Id, Loc),
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Prefix => Prefix => New_Reference_To (Pool_Id, Loc),
New_Reference_To (Pool_Id, Loc),
Attribute_Name => Name_Unrestricted_Access)))); Attribute_Name => Name_Unrestricted_Access))));
end if; end if;
...@@ -1246,8 +1240,7 @@ package body Exp_Ch7 is ...@@ -1246,8 +1240,7 @@ package body Exp_Ch7 is
Defining_Identifier => Counter_Typ, Defining_Identifier => Counter_Typ,
Subtype_Indication => Subtype_Indication =>
Make_Subtype_Indication (Loc, Make_Subtype_Indication (Loc,
Subtype_Mark => Subtype_Mark => New_Reference_To (Standard_Natural, Loc),
New_Reference_To (Standard_Natural, Loc),
Constraint => Constraint =>
Make_Range_Constraint (Loc, Make_Range_Constraint (Loc,
Range_Expression => Range_Expression =>
...@@ -1264,10 +1257,8 @@ package body Exp_Ch7 is ...@@ -1264,10 +1257,8 @@ package body Exp_Ch7 is
Counter_Decl := Counter_Decl :=
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
Defining_Identifier => Counter_Id, Defining_Identifier => Counter_Id,
Object_Definition => Object_Definition => New_Reference_To (Counter_Typ, Loc),
New_Reference_To (Counter_Typ, Loc), Expression => Make_Integer_Literal (Loc, 0));
Expression =>
Make_Integer_Literal (Loc, 0));
-- Set the type of the counter explicitly to prevent errors when -- Set the type of the counter explicitly to prevent errors when
-- examining object declarations later on. -- examining object declarations later on.
...@@ -1315,71 +1306,62 @@ package body Exp_Ch7 is ...@@ -1315,71 +1306,62 @@ package body Exp_Ch7 is
---------------------- ----------------------
procedure Create_Finalizer is procedure Create_Finalizer is
Conv_Name : Name_Id; Body_Id : Entity_Id;
Fin_Body : Node_Id; Fin_Body : Node_Id;
Fin_Spec : Node_Id; Fin_Spec : Node_Id;
Jump_Block : Node_Id; Jump_Block : Node_Id;
Label : Node_Id; Label : Node_Id;
Label_Id : Entity_Id; Label_Id : Entity_Id;
Prag_Decl : Node_Id;
Spec_Decl : Node_Id;
function Create_Finalizer_String return String_Id; function New_Finalizer_Name return Name_Id;
-- Generate a string of the form <Name>_finalize where <Name> denotes -- Create a fully qualified name of a package spec or body finalizer.
-- the fully qualified name of the spec. The string is in lower case. -- The generated name is of the form: xx__yy__finalize_[spec|body].
----------------------------- ------------------------
-- Create_Finalizer_String -- -- New_Finalizer_Name --
----------------------------- ------------------------
function Create_Finalizer_String return String_Id is
procedure Create_Finalizer_String (Id : Entity_Id);
-- Generate a string of the form "Id__". If the identifier has a
-- non-standard scope, process the scope first. The generated
-- string is in lower case.
----------------------------- function New_Finalizer_Name return Name_Id is
-- Create_Finalizer_String -- procedure New_Finalizer_Name (Id : Entity_Id);
----------------------------- -- Place "__<name-of-Id>" in the name buffer. If the identifier
-- has a non-standard scope, process the scope first.
procedure Create_Finalizer_String (Id : Entity_Id) is ------------------------
S : constant Entity_Id := Scope (Id); -- New_Finalizer_Name --
------------------------
procedure New_Finalizer_Name (Id : Entity_Id) is
begin begin
-- Climb the scope stack in order to start from the topmost if Scope (Id) = Standard_Standard then
-- name. Get_Name_String (Chars (Id));
if Present (S) else
and then S /= Standard_Standard New_Finalizer_Name (Scope (Id));
then Add_Str_To_Name_Buffer ("__");
Create_Finalizer_String (S); Add_Str_To_Name_Buffer (Get_Name_String (Chars (Id)));
end if; end if;
end New_Finalizer_Name;
Get_Name_String (Chars (Id)); -- Start of processing for New_Finalizer_Name
Store_String_Chars (Name_Buffer (1 .. Name_Len));
Store_String_Char ('_');
Store_String_Char ('_');
end Create_Finalizer_String;
-- Start of processing for Create_Finalizer_String
begin begin
Start_String; -- Create the fully qualified name of the enclosing scope
-- Build a fully qualified name. Compilations for .NET/JVM use the New_Finalizer_Name (Spec_Id);
-- finalizer name directly.
if VM_Target = No_VM then -- Generate:
Create_Finalizer_String (Spec_Id); -- __finalize_[spec|body]
end if;
-- Add the name of the finalizer Add_Str_To_Name_Buffer ("__finalize_");
Get_Name_String (Chars (Fin_Id)); if For_Package_Spec then
Store_String_Chars (Name_Buffer (1 .. Name_Len)); Add_Str_To_Name_Buffer ("spec");
else
Add_Str_To_Name_Buffer ("body");
end if;
return End_String; return Name_Find;
end Create_Finalizer_String; end New_Finalizer_Name;
-- Start of processing for Create_Finalizer -- Start of processing for Create_Finalizer
...@@ -1387,24 +1369,15 @@ package body Exp_Ch7 is ...@@ -1387,24 +1369,15 @@ package body Exp_Ch7 is
-- Step 1: Creation of the finalizer name -- Step 1: Creation of the finalizer name
-- Packages must use a distinct name for their finalizers since the -- Packages must use a distinct name for their finalizers since the
-- binder will have to generate calls to them by name. -- binder will have to generate calls to them by name. The name is
-- of the following form:
if For_Package then
-- finalizeS for specs
if For_Package_Spec then
Fin_Id :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Name_Finalize, 'S'));
-- finalizeB for bodies -- xx__yy__finalize_[spec|body]
else if For_Package then
Fin_Id := Fin_Id := Make_Defining_Identifier (Loc, New_Finalizer_Name);
Make_Defining_Identifier (Loc, Set_Has_Qualified_Name (Fin_Id);
Chars => New_External_Name (Name_Finalize, 'B')); Set_Has_Fully_Qualified_Name (Fin_Id);
end if;
-- The default name is _finalizer -- The default name is _finalizer
...@@ -1414,65 +1387,24 @@ package body Exp_Ch7 is ...@@ -1414,65 +1387,24 @@ package body Exp_Ch7 is
Chars => New_External_Name (Name_uFinalizer)); Chars => New_External_Name (Name_uFinalizer));
end if; end if;
-- Step 2: Creation of the finalizer specification and export for -- Step 2: Creation of the finalizer specification
-- packages.
-- Generate: -- Generate:
-- procedure Fin_Id; -- procedure Fin_Id;
-- pragma Export (CIL, Fin_Id, "Finalize[S/B]"); Fin_Spec :=
-- -- for .NET targets
-- pragma Export (Java, Fin_Id, "Finalize[S/B]");
-- -- for JVM targets
-- pragma Export (Ada, Fin_Id, "Spec_Id_Finalize[S/B]");
-- -- for default targets
if For_Package then
Spec_Decl :=
Make_Subprogram_Declaration (Loc, Make_Subprogram_Declaration (Loc,
Specification => Specification =>
Make_Procedure_Specification (Loc, Make_Procedure_Specification (Loc,
Defining_Unit_Name => Fin_Id)); Defining_Unit_Name => Fin_Id));
-- Determine the proper convention depending on the target
if VM_Target = CLI_Target then
Conv_Name := Name_CIL;
elsif VM_Target = JVM_Target then
Conv_Name := Name_Java;
else
Conv_Name := Name_Ada;
end if;
Prag_Decl :=
Make_Pragma (Loc,
Chars => Name_Export,
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression =>
Make_Identifier (Loc, Conv_Name)),
Make_Pragma_Argument_Association (Loc,
Expression =>
New_Reference_To (Fin_Id, Loc)),
Make_Pragma_Argument_Association (Loc,
Expression =>
Make_String_Literal (Loc, Create_Finalizer_String))));
end if;
-- Step 3: Creation of the finalizer body -- Step 3: Creation of the finalizer body
if Has_Ctrl_Objs then if Has_Ctrl_Objs then
-- Add L0, the default destination to the jump block -- Add L0, the default destination to the jump block
Label_Id := Label_Id := Make_Identifier (Loc, New_External_Name ('L', 0));
Make_Identifier (Loc, New_External_Name ('L', 0));
Set_Entity (Label_Id, Set_Entity (Label_Id,
Make_Defining_Identifier (Loc, Chars (Label_Id))); Make_Defining_Identifier (Loc, Chars (Label_Id)));
Label := Make_Label (Loc, Label_Id); Label := Make_Label (Loc, Label_Id);
...@@ -1491,12 +1423,10 @@ package body Exp_Ch7 is ...@@ -1491,12 +1423,10 @@ package body Exp_Ch7 is
Append_To (Jump_Alts, Append_To (Jump_Alts,
Make_Case_Statement_Alternative (Loc, Make_Case_Statement_Alternative (Loc,
Discrete_Choices => New_List ( Discrete_Choices => New_List (Make_Others_Choice (Loc)),
Make_Others_Choice (Loc)),
Statements => New_List ( Statements => New_List (
Make_Goto_Statement (Loc, Make_Goto_Statement (Loc,
Name => Name => New_Reference_To (Entity (Label_Id), Loc)))));
New_Reference_To (Entity (Label_Id), Loc)))));
-- Generate: -- Generate:
-- <<L0>> -- <<L0>>
...@@ -1522,8 +1452,7 @@ package body Exp_Ch7 is ...@@ -1522,8 +1452,7 @@ package body Exp_Ch7 is
Jump_Block := Jump_Block :=
Make_Case_Statement (Loc, Make_Case_Statement (Loc,
Expression => Expression => Make_Identifier (Loc, Chars (Counter_Id)),
Make_Identifier (Loc, Chars (Counter_Id)),
Alternatives => Jump_Alts); Alternatives => Jump_Alts);
if Acts_As_Clean if Acts_As_Clean
...@@ -1569,13 +1498,11 @@ package body Exp_Ch7 is ...@@ -1569,13 +1498,11 @@ package body Exp_Ch7 is
then then
Prepend_To (Finalizer_Stmts, Prepend_To (Finalizer_Stmts,
Make_Procedure_Call_Statement (Loc, Make_Procedure_Call_Statement (Loc,
Name => Name => New_Reference_To (RTE (RE_Abort_Defer), Loc)));
New_Reference_To (RTE (RE_Abort_Defer), Loc)));
Append_To (Finalizer_Stmts, Append_To (Finalizer_Stmts,
Make_Procedure_Call_Statement (Loc, Make_Procedure_Call_Statement (Loc,
Name => Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc)));
New_Reference_To (RTE (RE_Abort_Undefer), Loc)));
end if; end if;
-- Generate: -- Generate:
...@@ -1611,18 +1538,23 @@ package body Exp_Ch7 is ...@@ -1611,18 +1538,23 @@ package body Exp_Ch7 is
-- Create the body of the finalizer -- Create the body of the finalizer
Body_Id := Make_Defining_Identifier (Loc, Chars (Fin_Id));
if For_Package then
Set_Has_Qualified_Name (Body_Id);
Set_Has_Fully_Qualified_Name (Body_Id);
end if;
Fin_Body := Fin_Body :=
Make_Subprogram_Body (Loc, Make_Subprogram_Body (Loc,
Specification => Specification =>
Make_Procedure_Specification (Loc, Make_Procedure_Specification (Loc,
Defining_Unit_Name => Defining_Unit_Name => Body_Id),
Make_Defining_Identifier (Loc, Chars (Fin_Id))),
Declarations => Finalizer_Decls, Declarations => Finalizer_Decls,
Handled_Statement_Sequence => Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Make_Handled_Sequence_Of_Statements (Loc, Finalizer_Stmts));
Statements => Finalizer_Stmts));
-- Step 4: Spec and body insertion, analysis -- Step 4: Spec and body insertion, analysis
...@@ -1634,8 +1566,7 @@ package body Exp_Ch7 is ...@@ -1634,8 +1566,7 @@ package body Exp_Ch7 is
-- inserted at the top of the visible declarations. -- inserted at the top of the visible declarations.
if For_Package_Spec then if For_Package_Spec then
Prepend_To (Decls, Prag_Decl); Prepend_To (Decls, Fin_Spec);
Prepend_To (Decls, Spec_Decl);
if Present (Priv_Decls) then if Present (Priv_Decls) then
Append_To (Priv_Decls, Fin_Body); Append_To (Priv_Decls, Fin_Body);
...@@ -1649,18 +1580,18 @@ package body Exp_Ch7 is ...@@ -1649,18 +1580,18 @@ package body Exp_Ch7 is
else else
declare declare
Spec_Nod : Node_Id := Spec_Id; Spec_Nod : Node_Id;
Vis_Decls : List_Id; Vis_Decls : List_Id;
begin begin
Spec_Nod := Spec_Id;
while Nkind (Spec_Nod) /= N_Package_Specification loop while Nkind (Spec_Nod) /= N_Package_Specification loop
Spec_Nod := Parent (Spec_Nod); Spec_Nod := Parent (Spec_Nod);
end loop; end loop;
Vis_Decls := Visible_Declarations (Spec_Nod); Vis_Decls := Visible_Declarations (Spec_Nod);
Prepend_To (Vis_Decls, Prag_Decl); Prepend_To (Vis_Decls, Fin_Spec);
Prepend_To (Vis_Decls, Spec_Decl);
Append_To (Decls, Fin_Body); Append_To (Decls, Fin_Body);
end; end;
end if; end if;
...@@ -1668,8 +1599,7 @@ package body Exp_Ch7 is ...@@ -1668,8 +1599,7 @@ package body Exp_Ch7 is
-- Push the name of the package -- Push the name of the package
Push_Scope (Spec_Id); Push_Scope (Spec_Id);
Analyze (Spec_Decl); Analyze (Fin_Spec);
Analyze (Prag_Decl);
Analyze (Fin_Body); Analyze (Fin_Body);
Pop_Scope; Pop_Scope;
...@@ -1690,12 +1620,6 @@ package body Exp_Ch7 is ...@@ -1690,12 +1620,6 @@ package body Exp_Ch7 is
-- Fin_Id; -- At_End handler -- Fin_Id; -- At_End handler
-- end; -- end;
Fin_Spec :=
Make_Subprogram_Declaration (Loc,
Specification =>
Make_Procedure_Specification (Loc,
Defining_Unit_Name => Fin_Id));
pragma Assert (Present (Spec_Decls)); pragma Assert (Present (Spec_Decls));
Append_To (Spec_Decls, Fin_Spec); Append_To (Spec_Decls, Fin_Spec);
...@@ -1870,9 +1794,9 @@ package body Exp_Ch7 is ...@@ -1870,9 +1794,9 @@ package body Exp_Ch7 is
and then Present (Expr) and then Present (Expr)
and then and then
(Is_Null_Access_BIP_Func_Call (Expr) (Is_Null_Access_BIP_Func_Call (Expr)
or else or else (Is_Non_BIP_Func_Call (Expr)
(Is_Non_BIP_Func_Call (Expr) and then not
and then not Is_Related_To_Func_Return (Obj_Id))) Is_Related_To_Func_Return (Obj_Id)))
then then
Processing_Actions (Has_No_Init => True); Processing_Actions (Has_No_Init => True);
...@@ -1966,9 +1890,7 @@ package body Exp_Ch7 is ...@@ -1966,9 +1890,7 @@ package body Exp_Ch7 is
and then not Is_Access_Subprogram_Type (Typ) and then not Is_Access_Subprogram_Type (Typ)
and then Needs_Finalization and then Needs_Finalization
(Available_View (Designated_Type (Typ)))) (Available_View (Designated_Type (Typ))))
or else or else (Is_Type (Typ) and then Needs_Finalization (Typ))
(Is_Type (Typ)
and then Needs_Finalization (Typ))
then then
Old_Counter_Val := Counter_Val; Old_Counter_Val := Counter_Val;
...@@ -2164,11 +2086,9 @@ package body Exp_Ch7 is ...@@ -2164,11 +2086,9 @@ package body Exp_Ch7 is
Make_Function_Call (Loc, Make_Function_Call (Loc,
Name => Name =>
New_Reference_To (RTE (RE_Base_Pool), Loc), New_Reference_To (RTE (RE_Base_Pool), Loc),
Parameter_Associations => New_List ( Parameter_Associations => New_List (
Make_Explicit_Dereference (Loc, Make_Explicit_Dereference (Loc,
Prefix => Prefix => New_Reference_To (Collect, Loc)))))));
New_Reference_To (Collect, Loc)))))));
-- Create an access type which uses the storage pool of the -- Create an access type which uses the storage pool of the
-- caller's collection. -- caller's collection.
...@@ -2183,8 +2103,7 @@ package body Exp_Ch7 is ...@@ -2183,8 +2103,7 @@ package body Exp_Ch7 is
Defining_Identifier => Ptr_Typ, Defining_Identifier => Ptr_Typ,
Type_Definition => Type_Definition =>
Make_Access_To_Object_Definition (Loc, Make_Access_To_Object_Definition (Loc,
Subtype_Indication => Subtype_Indication => New_Reference_To (Obj_Typ, Loc))));
New_Reference_To (Obj_Typ, Loc))));
-- Perform minor decoration in order to set the collection and the -- Perform minor decoration in order to set the collection and the
-- storage pool attributes. -- storage pool attributes.
...@@ -2226,10 +2145,8 @@ package body Exp_Ch7 is ...@@ -2226,10 +2145,8 @@ package body Exp_Ch7 is
Cond := Cond :=
Make_Op_Ne (Loc, Make_Op_Ne (Loc,
Left_Opnd => Left_Opnd => New_Reference_To (Collect, Loc),
New_Reference_To (Collect, Loc), Right_Opnd => Make_Null (Loc));
Right_Opnd =>
Make_Null (Loc));
-- For constrained or tagged results escalate the condition to -- For constrained or tagged results escalate the condition to
-- include the allocation format. Generate: -- include the allocation format. Generate:
...@@ -2249,8 +2166,7 @@ package body Exp_Ch7 is ...@@ -2249,8 +2166,7 @@ package body Exp_Ch7 is
Make_And_Then (Loc, Make_And_Then (Loc,
Left_Opnd => Left_Opnd =>
Make_Op_Gt (Loc, Make_Op_Gt (Loc,
Left_Opnd => Left_Opnd => New_Reference_To (Alloc, Loc),
New_Reference_To (Alloc, Loc),
Right_Opnd => Right_Opnd =>
Make_Integer_Literal (Loc, Make_Integer_Literal (Loc,
UI_From_Int UI_From_Int
...@@ -2433,10 +2349,8 @@ package body Exp_Ch7 is ...@@ -2433,10 +2349,8 @@ package body Exp_Ch7 is
Inc_Decl := Inc_Decl :=
Make_Assignment_Statement (Loc, Make_Assignment_Statement (Loc,
Name => Name => New_Reference_To (Counter_Id, Loc),
New_Reference_To (Counter_Id, Loc), Expression => Make_Integer_Literal (Loc, Counter_Val));
Expression =>
Make_Integer_Literal (Loc, Counter_Val));
-- Insert the counter after all initialization has been done. The -- Insert the counter after all initialization has been done. The
-- place of insertion depends on the context. When dealing with a -- place of insertion depends on the context. When dealing with a
...@@ -2470,8 +2384,7 @@ package body Exp_Ch7 is ...@@ -2470,8 +2384,7 @@ package body Exp_Ch7 is
-- L<counter> : label; -- L<counter> : label;
Label_Id := Label_Id :=
Make_Identifier (Loc, Make_Identifier (Loc, New_External_Name ('L', Counter_Val));
Chars => New_External_Name ('L', Counter_Val));
Set_Entity (Label_Id, Set_Entity (Label_Id,
Make_Defining_Identifier (Loc, Chars (Label_Id))); Make_Defining_Identifier (Loc, Chars (Label_Id)));
Label := Make_Label (Loc, Label_Id); Label := Make_Label (Loc, Label_Id);
...@@ -2492,8 +2405,7 @@ package body Exp_Ch7 is ...@@ -2492,8 +2405,7 @@ package body Exp_Ch7 is
Make_Integer_Literal (Loc, Counter_Val)), Make_Integer_Literal (Loc, Counter_Val)),
Statements => New_List ( Statements => New_List (
Make_Goto_Statement (Loc, Make_Goto_Statement (Loc,
Name => Name => New_Reference_To (Entity (Label_Id), Loc)))));
New_Reference_To (Entity (Label_Id), Loc)))));
-- Insert the jump destination, generate: -- Insert the jump destination, generate:
-- --
...@@ -2608,12 +2520,9 @@ package body Exp_Ch7 is ...@@ -2608,12 +2520,9 @@ package body Exp_Ch7 is
-- H505-021 This needs to be revisited on .NET/JVM -- H505-021 This needs to be revisited on .NET/JVM
if VM_Target = No_VM if VM_Target = No_VM and then Is_Return_Object (Obj_Id) then
and then Is_Return_Object (Obj_Id)
then
declare declare
Func_Id : constant Entity_Id := Enclosing_Function (Obj_Id); Func_Id : constant Entity_Id := Enclosing_Function (Obj_Id);
begin begin
if Is_Build_In_Place_Function (Func_Id) if Is_Build_In_Place_Function (Func_Id)
and then Needs_BIP_Collection (Func_Id) and then Needs_BIP_Collection (Func_Id)
...@@ -2648,7 +2557,7 @@ package body Exp_Ch7 is ...@@ -2648,7 +2557,7 @@ package body Exp_Ch7 is
Append_List_To (Finalizer_Stmts, Fin_Stmts); Append_List_To (Finalizer_Stmts, Fin_Stmts);
-- Since the declarations are examined in reverse, the state counter -- Since the declarations are examined in reverse, the state counter
-- must be dectemented in order to keep with the true position of -- must be decremented in order to keep with the true position of
-- objects. -- objects.
Counter_Val := Counter_Val - 1; Counter_Val := Counter_Val - 1;
...@@ -2763,9 +2672,7 @@ package body Exp_Ch7 is ...@@ -2763,9 +2672,7 @@ package body Exp_Ch7 is
-- that N has a declarative list since the finalizer spec will be -- that N has a declarative list since the finalizer spec will be
-- attached to it. -- attached to it.
if Has_Ctrl_Objs if Has_Ctrl_Objs and then No (Decls) then
and then No (Decls)
then
Set_Declarations (N, New_List); Set_Declarations (N, New_List);
Decls := Declarations (N); Decls := Declarations (N);
Spec_Decls := Decls; Spec_Decls := Decls;
...@@ -2776,9 +2683,7 @@ package body Exp_Ch7 is ...@@ -2776,9 +2683,7 @@ package body Exp_Ch7 is
-- cases, the finalizer must be created and carry the additional -- cases, the finalizer must be created and carry the additional
-- statements. -- statements.
if Acts_As_Clean if Acts_As_Clean or else Has_Ctrl_Objs then
or else Has_Ctrl_Objs
then
Build_Components; Build_Components;
end if; end if;
...@@ -2790,9 +2695,7 @@ package body Exp_Ch7 is ...@@ -2790,9 +2695,7 @@ package body Exp_Ch7 is
-- Step 3: Finalizer creation -- Step 3: Finalizer creation
if Acts_As_Clean if Acts_As_Clean or else Has_Ctrl_Objs then
or else Has_Ctrl_Objs
then
Create_Finalizer; Create_Finalizer;
end if; end if;
end Build_Finalizer; end Build_Finalizer;
...@@ -2850,8 +2753,7 @@ package body Exp_Ch7 is ...@@ -2850,8 +2753,7 @@ package body Exp_Ch7 is
begin begin
Block := Block :=
Make_Block_Statement (Loc, Make_Block_Statement (Loc, Handled_Statement_Sequence => HSS);
Handled_Statement_Sequence => HSS);
Set_Handled_Statement_Sequence (N, Set_Handled_Statement_Sequence (N,
Make_Handled_Sequence_Of_Statements (Loc, New_List (Block))); Make_Handled_Sequence_Of_Statements (Loc, New_List (Block)));
...@@ -2876,8 +2778,8 @@ package body Exp_Ch7 is ...@@ -2876,8 +2778,8 @@ package body Exp_Ch7 is
for Final_Prim in Name_Of'Range loop for Final_Prim in Name_Of'Range loop
if Name_Of (Final_Prim) = Nam then if Name_Of (Final_Prim) = Nam then
Set_TSS (Typ, Set_TSS (Typ,
Make_Deep_Proc ( Make_Deep_Proc
Prim => Final_Prim, (Prim => Final_Prim,
Typ => Typ, Typ => Typ,
Stmts => Make_Deep_Record_Body (Final_Prim, Typ))); Stmts => Make_Deep_Record_Body (Final_Prim, Typ)));
end if; end if;
...@@ -2947,10 +2849,8 @@ package body Exp_Ch7 is ...@@ -2947,10 +2849,8 @@ package body Exp_Ch7 is
Make_And_Then (Loc, Make_And_Then (Loc,
Left_Opnd => Left_Opnd =>
Make_Op_Ne (Loc, Make_Op_Ne (Loc,
Left_Opnd => Left_Opnd => New_Reference_To (Temp_Id, Loc),
New_Reference_To (Temp_Id, Loc), Right_Opnd => Make_Null (Loc)),
Right_Opnd =>
Make_Null (Loc)),
Right_Opnd => Right_Opnd =>
Make_Op_Eq (Loc, Make_Op_Eq (Loc,
...@@ -2960,8 +2860,7 @@ package body Exp_Ch7 is ...@@ -2960,8 +2860,7 @@ package body Exp_Ch7 is
New_Reference_To (RTE (RE_Exception_Identity), Loc), New_Reference_To (RTE (RE_Exception_Identity), Loc),
Parameter_Associations => New_List ( Parameter_Associations => New_List (
Make_Explicit_Dereference (Loc, Make_Explicit_Dereference (Loc,
Prefix => Prefix => New_Reference_To (Temp_Id, Loc)))),
New_Reference_To (Temp_Id, Loc)))),
Right_Opnd => Right_Opnd =>
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
...@@ -2983,8 +2882,7 @@ package body Exp_Ch7 is ...@@ -2983,8 +2882,7 @@ package body Exp_Ch7 is
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
Defining_Identifier => Abort_Id, Defining_Identifier => Abort_Id,
Constant_Present => True, Constant_Present => True,
Object_Definition => Object_Definition => New_Reference_To (Standard_Boolean, Loc),
New_Reference_To (Standard_Boolean, Loc),
Expression => A_Expr)); Expression => A_Expr));
-- Generate: -- Generate:
...@@ -3005,10 +2903,8 @@ package body Exp_Ch7 is ...@@ -3005,10 +2903,8 @@ package body Exp_Ch7 is
Append_To (Result, Append_To (Result,
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
Defining_Identifier => Raised_Id, Defining_Identifier => Raised_Id,
Object_Definition => Object_Definition => New_Reference_To (Standard_Boolean, Loc),
New_Reference_To (Standard_Boolean, Loc), Expression => New_Reference_To (Standard_False, Loc)));
Expression =>
New_Reference_To (Standard_False, Loc)));
return Result; return Result;
end Build_Object_Declarations; end Build_Object_Declarations;
...@@ -3057,13 +2953,10 @@ package body Exp_Ch7 is ...@@ -3057,13 +2953,10 @@ package body Exp_Ch7 is
return return
Make_If_Statement (Loc, Make_If_Statement (Loc,
Condition => Condition => New_Reference_To (Raised_Id, Loc),
New_Reference_To (Raised_Id, Loc),
Then_Statements => New_List ( Then_Statements => New_List (
Make_Procedure_Call_Statement (Loc, Make_Procedure_Call_Statement (Loc,
Name => Name => New_Reference_To (Proc_Id, Loc),
New_Reference_To (Proc_Id, Loc),
Parameter_Associations => Params))); Parameter_Associations => Params)));
end Build_Raise_Statement; end Build_Raise_Statement;
...@@ -3074,22 +2967,22 @@ package body Exp_Ch7 is ...@@ -3074,22 +2967,22 @@ package body Exp_Ch7 is
procedure Build_Record_Deep_Procs (Typ : Entity_Id) is procedure Build_Record_Deep_Procs (Typ : Entity_Id) is
begin begin
Set_TSS (Typ, Set_TSS (Typ,
Make_Deep_Proc ( Make_Deep_Proc
Prim => Initialize_Case, (Prim => Initialize_Case,
Typ => Typ, Typ => Typ,
Stmts => Make_Deep_Record_Body (Initialize_Case, Typ))); Stmts => Make_Deep_Record_Body (Initialize_Case, Typ)));
if not Is_Immutably_Limited_Type (Typ) then if not Is_Immutably_Limited_Type (Typ) then
Set_TSS (Typ, Set_TSS (Typ,
Make_Deep_Proc ( Make_Deep_Proc
Prim => Adjust_Case, (Prim => Adjust_Case,
Typ => Typ, Typ => Typ,
Stmts => Make_Deep_Record_Body (Adjust_Case, Typ))); Stmts => Make_Deep_Record_Body (Adjust_Case, Typ)));
end if; end if;
Set_TSS (Typ, Set_TSS (Typ,
Make_Deep_Proc ( Make_Deep_Proc
Prim => Finalize_Case, (Prim => Finalize_Case,
Typ => Typ, Typ => Typ,
Stmts => Make_Deep_Record_Body (Finalize_Case, Typ))); Stmts => Make_Deep_Record_Body (Finalize_Case, Typ)));
...@@ -3098,8 +2991,8 @@ package body Exp_Ch7 is ...@@ -3098,8 +2991,8 @@ package body Exp_Ch7 is
if VM_Target = No_VM then if VM_Target = No_VM then
Set_TSS (Typ, Set_TSS (Typ,
Make_Deep_Proc ( Make_Deep_Proc
Prim => Address_Case, (Prim => Address_Case,
Typ => Typ, Typ => Typ,
Stmts => Make_Deep_Record_Body (Address_Case, Typ))); Stmts => Make_Deep_Record_Body (Address_Case, Typ)));
end if; end if;
...@@ -3222,16 +3115,14 @@ package body Exp_Ch7 is ...@@ -3222,16 +3115,14 @@ package body Exp_Ch7 is
Nkind (Type_Definition (Parent (U_Typ))) = N_Record_Definition Nkind (Type_Definition (Parent (U_Typ))) = N_Record_Definition
and then and then
Present Present
(Variant_Part (Variant_Part (Component_List (Type_Definition (Parent (U_Typ)))))
(Component_List (Type_Definition (Parent (U_Typ)))))
then then
-- For now, do not attempt to free a component that may appear in -- For now, do not attempt to free a component that may appear in a
-- a variant, and instead issue a warning. Doing this "properly" -- variant, and instead issue a warning. Doing this "properly" would
-- would require building a case statement and would be quite a -- require building a case statement and would be quite a mess. Note
-- mess. Note that the RM only requires that free "work" for the -- that the RM only requires that free "work" for the case of a task
-- case of a task access value, so already we go way beyond this -- access value, so already we go way beyond this in that we deal
-- in that we deal with the array case and non-discriminated -- with the array case and non-discriminated record cases.
-- record cases.
Error_Msg_N Error_Msg_N
("task/protected object in variant record will not be freed?", N); ("task/protected object in variant record will not be freed?", N);
...@@ -3239,7 +3130,6 @@ package body Exp_Ch7 is ...@@ -3239,7 +3130,6 @@ package body Exp_Ch7 is
end if; end if;
Comp := First_Component (Typ); Comp := First_Component (Typ);
while Present (Comp) loop while Present (Comp) loop
if Has_Task (Etype (Comp)) if Has_Task (Etype (Comp))
or else Has_Simple_Protected_Object (Etype (Comp)) or else Has_Simple_Protected_Object (Etype (Comp))
...@@ -3261,12 +3151,10 @@ package body Exp_Ch7 is ...@@ -3261,12 +3151,10 @@ package body Exp_Ch7 is
-- Recurse, by generating the prefix of the argument to -- Recurse, by generating the prefix of the argument to
-- the eventual cleanup call. -- the eventual cleanup call.
Append_List_To Append_List_To (Stmts, Cleanup_Record (N, Tsk, Etype (Comp)));
(Stmts, Cleanup_Record (N, Tsk, Etype (Comp)));
elsif Is_Array_Type (Etype (Comp)) then elsif Is_Array_Type (Etype (Comp)) then
Append_List_To Append_List_To (Stmts, Cleanup_Array (N, Tsk, Etype (Comp)));
(Stmts, Cleanup_Array (N, Tsk, Etype (Comp)));
end if; end if;
end if; end if;
...@@ -3411,10 +3299,8 @@ package body Exp_Ch7 is ...@@ -3411,10 +3299,8 @@ package body Exp_Ch7 is
elsif Ftyp /= Atyp elsif Ftyp /= Atyp
and then Present (Atyp) and then Present (Atyp)
and then and then (Is_Private_Type (Ftyp) or else Is_Private_Type (Atyp))
(Is_Private_Type (Ftyp) or else Is_Private_Type (Atyp)) and then Base_Type (Underlying_Type (Atyp)) =
and then
Base_Type (Underlying_Type (Atyp)) =
Base_Type (Underlying_Type (Ftyp)) Base_Type (Underlying_Type (Ftyp))
then then
return Unchecked_Convert_To (Ftyp, Arg); return Unchecked_Convert_To (Ftyp, Arg);
...@@ -3680,8 +3566,7 @@ package body Exp_Ch7 is ...@@ -3680,8 +3566,7 @@ package body Exp_Ch7 is
New_Reference_To (RTE (RE_Mark_Id), Loc), New_Reference_To (RTE (RE_Mark_Id), Loc),
Expression => Expression =>
Make_Function_Call (Loc, Make_Function_Call (Loc,
Name => Name => New_Reference_To (RTE (RE_SS_Mark), Loc))));
New_Reference_To (RTE (RE_SS_Mark), Loc))));
Set_Uses_Sec_Stack (Scop, False); Set_Uses_Sec_Stack (Scop, False);
end if; end if;
...@@ -4159,7 +4044,6 @@ package body Exp_Ch7 is ...@@ -4159,7 +4044,6 @@ package body Exp_Ch7 is
Comp := First_Component (E); Comp := First_Component (E);
while Present (Comp) loop while Present (Comp) loop
if Chars (Comp) = Name_uParent then if Chars (Comp) = Name_uParent then
null; null;
...@@ -4196,7 +4080,6 @@ package body Exp_Ch7 is ...@@ -4196,7 +4080,6 @@ package body Exp_Ch7 is
begin begin
Comp := First_Component (T); Comp := First_Component (T);
while Present (Comp) loop while Present (Comp) loop
if Has_Simple_Protected_Object (Etype (Comp)) then if Has_Simple_Protected_Object (Etype (Comp)) then
return True; return True;
...@@ -4636,7 +4519,7 @@ package body Exp_Ch7 is ...@@ -4636,7 +4519,7 @@ package body Exp_Ch7 is
(Typ : Entity_Id) return List_Id; (Typ : Entity_Id) return List_Id;
-- Create the statements necessary to adjust or finalize an array of -- Create the statements necessary to adjust or finalize an array of
-- controlled elements. Generate: -- controlled elements. Generate:
--
-- declare -- declare
-- Temp : constant Exception_Occurrence_Access := -- Temp : constant Exception_Occurrence_Access :=
-- Get_Current_Excep.all; -- Get_Current_Excep.all;
...@@ -4646,10 +4529,10 @@ package body Exp_Ch7 is ...@@ -4646,10 +4529,10 @@ package body Exp_Ch7 is
-- Standard'Abort_Signal'Identity; -- Standard'Abort_Signal'Identity;
-- <or> -- <or>
-- Abort : constant Boolean := False; -- no abort -- Abort : constant Boolean := False; -- no abort
--
-- E : Exception_Occurrence; -- E : Exception_Occurrence;
-- Raised : Boolean := False; -- Raised : Boolean := False;
--
-- begin -- begin
-- for J1 in [reverse] Typ'First (1) .. Typ'Last (1) loop -- for J1 in [reverse] Typ'First (1) .. Typ'Last (1) loop
-- ^-- in the finalization case -- ^-- in the finalization case
...@@ -4657,7 +4540,7 @@ package body Exp_Ch7 is ...@@ -4657,7 +4540,7 @@ package body Exp_Ch7 is
-- for Jn in [reverse] Typ'First (n) .. Typ'Last (n) loop -- for Jn in [reverse] Typ'First (n) .. Typ'Last (n) loop
-- begin -- begin
-- [Deep_]Adjust / Finalize (V (J1, ..., Jn)); -- [Deep_]Adjust / Finalize (V (J1, ..., Jn));
--
-- exception -- exception
-- when others => -- when others =>
-- if not Raised then -- if not Raised then
...@@ -4668,7 +4551,7 @@ package body Exp_Ch7 is ...@@ -4668,7 +4551,7 @@ package body Exp_Ch7 is
-- end loop; -- end loop;
-- ... -- ...
-- end loop; -- end loop;
--
-- if Raised then -- if Raised then
-- Raise_From_Controlled_Operation (E, Abort); -- Raise_From_Controlled_Operation (E, Abort);
-- end if; -- end if;
...@@ -4678,19 +4561,19 @@ package body Exp_Ch7 is ...@@ -4678,19 +4561,19 @@ package body Exp_Ch7 is
-- Create the statements necessary to initialize an array of controlled -- Create the statements necessary to initialize an array of controlled
-- elements. Include a mechanism to carry out partial finalization if an -- elements. Include a mechanism to carry out partial finalization if an
-- exception occurs. Generate: -- exception occurs. Generate:
--
-- declare -- declare
-- Counter : Integer := 0; -- Counter : Integer := 0;
--
-- begin -- begin
-- for J1 in V'Range (1) loop -- for J1 in V'Range (1) loop
-- ... -- ...
-- for JN in V'Range (N) loop -- for JN in V'Range (N) loop
-- begin -- begin
-- [Deep_]Initialize (V (J1, ..., JN)); -- [Deep_]Initialize (V (J1, ..., JN));
--
-- Counter := Counter + 1; -- Counter := Counter + 1;
--
-- exception -- exception
-- when others => -- when others =>
-- declare -- declare
...@@ -4859,9 +4742,7 @@ package body Exp_Ch7 is ...@@ -4859,9 +4742,7 @@ package body Exp_Ch7 is
J := Last (Index_List); J := Last (Index_List);
Dim := Num_Dims; Dim := Num_Dims;
while Present (J) while Present (J) and then Dim > 0 loop
and then Dim > 0
loop
Loop_Id := J; Loop_Id := J;
Prev (J); Prev (J);
Remove (Loop_Id); Remove (Loop_Id);
...@@ -4984,12 +4865,9 @@ package body Exp_Ch7 is ...@@ -4984,12 +4865,9 @@ package body Exp_Ch7 is
Dim := 1; Dim := 1;
Expr := Expr :=
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Prefix => Prefix => Make_Identifier (Loc, Name_V),
Make_Identifier (Loc, Name_V), Attribute_Name => Name_Length,
Attribute_Name => Expressions => New_List (Make_Integer_Literal (Loc, Dim)));
Name_Length,
Expressions => New_List (
Make_Integer_Literal (Loc, Dim)));
-- Process the rest of the dimensions, generate: -- Process the rest of the dimensions, generate:
-- Expr * V'Length (N) -- Expr * V'Length (N)
...@@ -5066,10 +4944,8 @@ package body Exp_Ch7 is ...@@ -5066,10 +4944,8 @@ package body Exp_Ch7 is
function Build_Initialization_Call return Node_Id is function Build_Initialization_Call return Node_Id is
Comp_Ref : constant Node_Id := Comp_Ref : constant Node_Id :=
Make_Indexed_Component (Loc, Make_Indexed_Component (Loc,
Prefix => Prefix => Make_Identifier (Loc, Name_V),
Make_Identifier (Loc, Name_V), Expressions => New_References_To (Index_List, Loc));
Expressions =>
New_References_To (Index_List, Loc));
begin begin
Set_Etype (Comp_Ref, Comp_Typ); Set_Etype (Comp_Ref, Comp_Typ);
...@@ -5153,9 +5029,7 @@ package body Exp_Ch7 is ...@@ -5153,9 +5029,7 @@ package body Exp_Ch7 is
F := Last (Final_List); F := Last (Final_List);
Dim := Num_Dims; Dim := Num_Dims;
while Present (F) while Present (F) and then Dim > 0 loop
and then Dim > 0
loop
Loop_Id := F; Loop_Id := F;
Prev (F); Prev (F);
Remove (Loop_Id); Remove (Loop_Id);
...@@ -5223,7 +5097,6 @@ package body Exp_Ch7 is ...@@ -5223,7 +5097,6 @@ package body Exp_Ch7 is
Make_Block_Statement (Loc, Make_Block_Statement (Loc,
Declarations => Declarations =>
Build_Object_Declarations (Loc, Abort_Id, E_Id, Raised_Id), Build_Object_Declarations (Loc, Abort_Id, E_Id, Raised_Id),
Handled_Statement_Sequence => Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)); Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts));
...@@ -5244,13 +5117,10 @@ package body Exp_Ch7 is ...@@ -5244,13 +5117,10 @@ package body Exp_Ch7 is
Make_Block_Statement (Loc, Make_Block_Statement (Loc,
Handled_Statement_Sequence => Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List ( Statements => New_List (Build_Initialization_Call),
Build_Initialization_Call),
Exception_Handlers => New_List ( Exception_Handlers => New_List (
Make_Exception_Handler (Loc, Make_Exception_Handler (Loc,
Exception_Choices => New_List ( Exception_Choices => New_List (Make_Others_Choice (Loc)),
Make_Others_Choice (Loc)),
Statements => New_List (Final_Block))))); Statements => New_List (Final_Block)))));
Append_To (Statements (Handled_Statement_Sequence (Init_Loop)), Append_To (Statements (Handled_Statement_Sequence (Init_Loop)),
...@@ -5270,9 +5140,7 @@ package body Exp_Ch7 is ...@@ -5270,9 +5140,7 @@ package body Exp_Ch7 is
J := Last (Index_List); J := Last (Index_List);
Dim := Num_Dims; Dim := Num_Dims;
while Present (J) while Present (J) and then Dim > 0 loop
and then Dim > 0
loop
Loop_Id := J; Loop_Id := J;
Prev (J); Prev (J);
Remove (Loop_Id); Remove (Loop_Id);
...@@ -5286,8 +5154,7 @@ package body Exp_Ch7 is ...@@ -5286,8 +5154,7 @@ package body Exp_Ch7 is
Defining_Identifier => Loop_Id, Defining_Identifier => Loop_Id,
Discrete_Subtype_Definition => Discrete_Subtype_Definition =>
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Prefix => Prefix => Make_Identifier (Loc, Name_V),
Make_Identifier (Loc, Name_V),
Attribute_Name => Name_Range, Attribute_Name => Name_Range,
Expressions => New_List ( Expressions => New_List (
Make_Integer_Literal (Loc, Dim))))), Make_Integer_Literal (Loc, Dim))))),
...@@ -5455,10 +5322,10 @@ package body Exp_Ch7 is ...@@ -5455,10 +5322,10 @@ package body Exp_Ch7 is
function Build_Adjust_Statements (Typ : Entity_Id) return List_Id; function Build_Adjust_Statements (Typ : Entity_Id) return List_Id;
-- Build the statements necessary to adjust a record type. The type may -- Build the statements necessary to adjust a record type. The type may
-- have discriminants and contain variant parts. Generate: -- have discriminants and contain variant parts. Generate:
--
-- begin -- begin
-- Root_Controlled (V).Finalized := False; -- Root_Controlled (V).Finalized := False;
--
-- begin -- begin
-- [Deep_]Adjust (V.Comp_1); -- [Deep_]Adjust (V.Comp_1);
-- exception -- exception
...@@ -5478,7 +5345,7 @@ package body Exp_Ch7 is ...@@ -5478,7 +5345,7 @@ package body Exp_Ch7 is
-- Save_Occurrence (E, Get_Current_Excep.all.all); -- Save_Occurrence (E, Get_Current_Excep.all.all);
-- end if; -- end if;
-- end; -- end;
--
-- begin -- begin
-- Deep_Adjust (V._parent, False); -- If applicable -- Deep_Adjust (V._parent, False); -- If applicable
-- exception -- exception
...@@ -5488,7 +5355,7 @@ package body Exp_Ch7 is ...@@ -5488,7 +5355,7 @@ package body Exp_Ch7 is
-- Save_Occurrence (E, Get_Current_Excep.all.all); -- Save_Occurrence (E, Get_Current_Excep.all.all);
-- end if; -- end if;
-- end; -- end;
--
-- if F then -- if F then
-- begin -- begin
-- Adjust (V); -- If applicable -- Adjust (V); -- If applicable
...@@ -5500,7 +5367,7 @@ package body Exp_Ch7 is ...@@ -5500,7 +5367,7 @@ package body Exp_Ch7 is
-- end if; -- end if;
-- end; -- end;
-- end if; -- end if;
--
-- if Raised then -- if Raised then
-- Raise_From_Controlled_Object (E, Abort); -- Raise_From_Controlled_Object (E, Abort);
-- end if; -- end if;
...@@ -5509,7 +5376,7 @@ package body Exp_Ch7 is ...@@ -5509,7 +5376,7 @@ package body Exp_Ch7 is
function Build_Finalize_Statements (Typ : Entity_Id) return List_Id; function Build_Finalize_Statements (Typ : Entity_Id) return List_Id;
-- Build the statements necessary to finalize a record type. The type -- Build the statements necessary to finalize a record type. The type
-- may have discriminants and contain variant parts. Generate: -- may have discriminants and contain variant parts. Generate:
--
-- declare -- declare
-- Temp : constant Exception_Occurrence_Access := -- Temp : constant Exception_Occurrence_Access :=
-- Get_Current_Excep.all; -- Get_Current_Excep.all;
...@@ -5521,12 +5388,12 @@ package body Exp_Ch7 is ...@@ -5521,12 +5388,12 @@ package body Exp_Ch7 is
-- Abort : constant Boolean := False; -- no abort -- Abort : constant Boolean := False; -- no abort
-- E : Exception_Occurence; -- E : Exception_Occurence;
-- Raised : Boolean := False; -- Raised : Boolean := False;
--
-- begin -- begin
-- if Root_Controlled (V).Finalized then -- if Root_Controlled (V).Finalized then
-- return; -- return;
-- end if; -- end if;
--
-- if F then -- if F then
-- begin -- begin
-- Finalize (V); -- If applicable -- Finalize (V); -- If applicable
...@@ -5538,7 +5405,7 @@ package body Exp_Ch7 is ...@@ -5538,7 +5405,7 @@ package body Exp_Ch7 is
-- end if; -- end if;
-- end; -- end;
-- end if; -- end if;
--
-- case Variant_1 is -- case Variant_1 is
-- when Value_1 => -- when Value_1 =>
-- case State_Counter_N => -- If Is_Local is enabled -- case State_Counter_N => -- If Is_Local is enabled
...@@ -5550,7 +5417,7 @@ package body Exp_Ch7 is ...@@ -5550,7 +5417,7 @@ package body Exp_Ch7 is
-- when others => . -- when others => .
-- goto L0; . -- goto L0; .
-- end case; . -- end case; .
--
-- <<LN>> -- If Is_Local is enabled -- <<LN>> -- If Is_Local is enabled
-- begin -- begin
-- [Deep_]Finalize (V.Comp_N); -- [Deep_]Finalize (V.Comp_N);
...@@ -5574,12 +5441,12 @@ package body Exp_Ch7 is ...@@ -5574,12 +5441,12 @@ package body Exp_Ch7 is
-- end; -- end;
-- <<L0>> -- <<L0>>
-- end case; -- end case;
--
-- case State_Counter_1 => -- If Is_Local is enabled -- case State_Counter_1 => -- If Is_Local is enabled
-- when M => . -- when M => .
-- goto LM; . -- goto LM; .
-- ... -- ...
--
-- begin -- begin
-- Deep_Finalize (V._parent, False); -- If applicable -- Deep_Finalize (V._parent, False); -- If applicable
-- exception -- exception
...@@ -5589,9 +5456,9 @@ package body Exp_Ch7 is ...@@ -5589,9 +5456,9 @@ package body Exp_Ch7 is
-- Save_Occurrence (E, Get_Current_Excep.all.all); -- Save_Occurrence (E, Get_Current_Excep.all.all);
-- end if; -- end if;
-- end; -- end;
--
-- Root_Controlled (V).Finalized := True; -- Root_Controlled (V).Finalized := True;
--
-- if Raised then -- if Raised then
-- Raise_From_Controlled_Object (E, Abort); -- Raise_From_Controlled_Object (E, Abort);
-- end if; -- end if;
...@@ -5674,10 +5541,8 @@ package body Exp_Ch7 is ...@@ -5674,10 +5541,8 @@ package body Exp_Ch7 is
Make_Adjust_Call ( Make_Adjust_Call (
Obj_Ref => Obj_Ref =>
Make_Selected_Component (Loc, Make_Selected_Component (Loc,
Prefix => Prefix => Make_Identifier (Loc, Name_V),
Make_Identifier (Loc, Name_V), Selector_Name => Make_Identifier (Loc, Chars (Id))),
Selector_Name =>
Make_Identifier (Loc, Chars (Id))),
Typ => Typ); Typ => Typ);
if Exceptions_OK then if Exceptions_OK then
...@@ -5686,7 +5551,6 @@ package body Exp_Ch7 is ...@@ -5686,7 +5551,6 @@ package body Exp_Ch7 is
Handled_Statement_Sequence => Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Adj_Stmt), Statements => New_List (Adj_Stmt),
Exception_Handlers => New_List ( Exception_Handlers => New_List (
Build_Exception_Handler (Loc, E_Id, Raised_Id)))); Build_Exception_Handler (Loc, E_Id, Raised_Id))));
end if; end if;
...@@ -5882,9 +5746,7 @@ package body Exp_Ch7 is ...@@ -5882,9 +5746,7 @@ package body Exp_Ch7 is
-- --
-- Deep_Adjust (Obj._parent, False); -- Deep_Adjust (Obj._parent, False);
if Is_Tagged_Type (Typ) if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then
and then Is_Derived_Type (Typ)
then
declare declare
Par_Typ : constant Entity_Id := Parent_Field_Type (Typ); Par_Typ : constant Entity_Id := Parent_Field_Type (Typ);
Adj_Stmt : Node_Id; Adj_Stmt : Node_Id;
...@@ -6254,11 +6116,10 @@ package body Exp_Ch7 is ...@@ -6254,11 +6116,10 @@ package body Exp_Ch7 is
Make_Case_Statement (Loc, Make_Case_Statement (Loc,
Expression => Expression =>
Make_Selected_Component (Loc, Make_Selected_Component (Loc,
Prefix => Prefix => Make_Identifier (Loc, Name_V),
Make_Identifier (Loc, Name_V),
Selector_Name => Selector_Name =>
Make_Identifier (Loc, Make_Identifier (Loc,
Chars (Name (Variant_Part (Comps))))), Chars => Chars (Name (Variant_Part (Comps))))),
Alternatives => Var_Alts); Alternatives => Var_Alts);
end; end;
end if; end if;
...@@ -6367,8 +6228,7 @@ package body Exp_Ch7 is ...@@ -6367,8 +6228,7 @@ package body Exp_Ch7 is
-- Add the declaration of default jump location L0, its -- Add the declaration of default jump location L0, its
-- corresponding alternative and its place in the statements. -- corresponding alternative and its place in the statements.
Label_Id := Label_Id := Make_Identifier (Loc, New_External_Name ('L', 0));
Make_Identifier (Loc, New_External_Name ('L', 0));
Set_Entity (Label_Id, Set_Entity (Label_Id,
Make_Defining_Identifier (Loc, Chars (Label_Id))); Make_Defining_Identifier (Loc, Chars (Label_Id)));
Label := Make_Label (Loc, Label_Id); Label := Make_Label (Loc, Label_Id);
...@@ -6385,8 +6245,7 @@ package body Exp_Ch7 is ...@@ -6385,8 +6245,7 @@ package body Exp_Ch7 is
Statements => New_List ( Statements => New_List (
Make_Goto_Statement (Loc, Make_Goto_Statement (Loc,
Name => Name => New_Reference_To (Entity (Label_Id), Loc)))));
New_Reference_To (Entity (Label_Id), Loc)))));
Append_To (Stmts, Label); -- statement Append_To (Stmts, Label); -- statement
...@@ -6394,8 +6253,7 @@ package body Exp_Ch7 is ...@@ -6394,8 +6253,7 @@ package body Exp_Ch7 is
Prepend_To (Stmts, Prepend_To (Stmts,
Make_Case_Statement (Loc, Make_Case_Statement (Loc,
Expression => Expression => Make_Identifier (Loc, Chars (Counter_Id)),
Make_Identifier (Loc, Chars (Counter_Id)),
Alternatives => Alts)); Alternatives => Alts));
end if; end if;
...@@ -7018,8 +6876,7 @@ package body Exp_Ch7 is ...@@ -7018,8 +6876,7 @@ package body Exp_Ch7 is
Type_Definition => Type_Definition =>
Make_Access_To_Object_Definition (Loc, Make_Access_To_Object_Definition (Loc,
All_Present => True, All_Present => True,
Subtype_Indication => Subtype_Indication => New_Reference_To (Desg_Typ, Loc))),
New_Reference_To (Desg_Typ, Loc))),
Make_Attribute_Definition_Clause (Loc, Make_Attribute_Definition_Clause (Loc,
Name => New_Reference_To (Ptr_Typ, Loc), Name => New_Reference_To (Ptr_Typ, Loc),
...@@ -7059,8 +6916,7 @@ package body Exp_Ch7 is ...@@ -7059,8 +6916,7 @@ package body Exp_Ch7 is
Left_Opnd => Make_Integer_Literal (Loc, 2), Left_Opnd => Make_Integer_Literal (Loc, 2),
Right_Opnd => Right_Opnd =>
Make_Op_Divide (Loc, Make_Op_Divide (Loc,
Left_Opnd => Left_Opnd => Make_Integer_Literal (Loc, Esize (Typ)),
Make_Integer_Literal (Loc, Esize (Typ)),
Right_Opnd => Right_Opnd =>
Make_Integer_Literal (Loc, System_Storage_Unit))); Make_Integer_Literal (Loc, System_Storage_Unit)));
end Bounds_Size_Expression; end Bounds_Size_Expression;
...@@ -7270,6 +7126,7 @@ package body Exp_Ch7 is ...@@ -7270,6 +7126,7 @@ package body Exp_Ch7 is
then then
Utyp := Underlying_Type (Root_Type (Base_Type (Typ))); Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
Ref := Unchecked_Convert_To (Utyp, Ref); Ref := Unchecked_Convert_To (Utyp, Ref);
Set_Assignment_OK (Ref); Set_Assignment_OK (Ref);
-- To prevent problems with UC see 1.156 RH ??? -- To prevent problems with UC see 1.156 RH ???
end if; end if;
...@@ -7377,9 +7234,7 @@ package body Exp_Ch7 is ...@@ -7377,9 +7234,7 @@ package body Exp_Ch7 is
else else
Utyp := Typ; Utyp := Typ;
if Is_Private_Type (Utyp) if Is_Private_Type (Utyp) and then Present (Full_View (Utyp)) then
and then Present (Full_View (Utyp))
then
Utyp := Full_View (Utyp); Utyp := Full_View (Utyp);
end if; end if;
...@@ -7620,8 +7475,8 @@ package body Exp_Ch7 is ...@@ -7620,8 +7475,8 @@ package body Exp_Ch7 is
-- scope, furthermore, if they are controlled variables they are finalized -- scope, furthermore, if they are controlled variables they are finalized
-- right after the declaration. The finalization list of the transient -- right after the declaration. The finalization list of the transient
-- scope is defined as a renaming of the enclosing one so during their -- scope is defined as a renaming of the enclosing one so during their
-- initialization they will be attached to the proper finalization -- initialization they will be attached to the proper finalization list.
-- list. For instance, the following declaration : -- For instance, the following declaration :
-- X : Typ := F (G (A), G (B)); -- X : Typ := F (G (A), G (B));
...@@ -7686,11 +7541,12 @@ package body Exp_Ch7 is ...@@ -7686,11 +7541,12 @@ package body Exp_Ch7 is
begin begin
-- Generate: -- Generate:
-- Temp : Typ; -- Temp : Typ;
-- declare -- declare
-- M : constant Mark_Id := SS_Mark; -- M : constant Mark_Id := SS_Mark;
-- procedure Finalizer is ... (See Build_Finalizer) -- procedure Finalizer is ... (See Build_Finalizer)
--
-- begin -- begin
-- Temp := <Expr>; -- Temp := <Expr>;
-- --
......
gcc/ada/sem_util.adb
...@@ -964,8 +964,7 @@ package body Sem_Util is ...@@ -964,8 +964,7 @@ package body Sem_Util is
Defining_Identifier => Elab_Ent, Defining_Identifier => Elab_Ent,
Object_Definition => Object_Definition =>
New_Occurrence_Of (Standard_Short_Integer, Loc), New_Occurrence_Of (Standard_Short_Integer, Loc),
Expression => Expression => Make_Integer_Literal (Loc, Uint_0));
Make_Integer_Literal (Loc, Uint_0));
Push_Scope (Standard_Standard); Push_Scope (Standard_Standard);
Add_Global_Declaration (Decl); Add_Global_Declaration (Decl);
......
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