Skip to content

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

[multiple changes] 

2011-08-04  Eric Botcazou  <ebotcazou@adacore.com>

	* bindgen.adb (Gen_Finalize_Library_Ada): Factor out code to generate
	the header of the finalization routine.
	If the unit has no finalizer but is a body whose spec has one, then
	generate the decrement of the elaboration entity only.
	If the unit has a finalizer and is a spec, then do not generate the
	decrement of the elaboration entity.
	(Gen_Finalize_Library_C): Likewise.

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

	* exp_ch7.adb (Alignment_Of): New subsidiary routine.
	(Bounds_Size_Expression): Removed.
	(Double_Alignment_Of): New subsidiary routine.
	(Make_Finalize_Address_Stmts): New local variable Index_Typ. Account
	for a hole in the dope vector of unconstrained arrays due to different
	index and element alignments.

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

	* sem_res.adb (Resolve_Allocator): diagnose task allocator that will
	raise program_error because body has not been seen yet.

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

	* sem_ch10.adb (Analyze_With_Clause): Protect against child unit with
	an unresolved name.

2011-08-04  Vincent Celier  <celier@adacore.com>

	* makeutl.adb (Do_Complete): Check absolute paths in canonical forms

2011-08-04  Yannick Moy  <moy@adacore.com>

	* alfa.adb, alfa.ads (Unique_Defining_Entity): move function from here
	* sem_util.adb, sem_util.ads (Unique_Defining_Entity): ...to here

2011-08-04  Thomas Quinot  <quinot@adacore.com>

	* sem_ch12.adb (Analyze_Package_Instantiation): Do not omit body for
	instantiation in RCI.

2011-08-04  Emmanuel Briot  <briot@adacore.com>

	* make.adb: Share more code with gprbuild

From-SVN: r177361
parent f5fc5b9d
Showing with 318 additions and 139 deletions
gcc/ada/ChangeLog
2011-08-04 Eric Botcazou <ebotcazou@adacore.com>
* bindgen.adb (Gen_Finalize_Library_Ada): Factor out code to generate
the header of the finalization routine.
If the unit has no finalizer but is a body whose spec has one, then
generate the decrement of the elaboration entity only.
If the unit has a finalizer and is a spec, then do not generate the
decrement of the elaboration entity.
(Gen_Finalize_Library_C): Likewise.
2011-08-04 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch7.adb (Alignment_Of): New subsidiary routine.
(Bounds_Size_Expression): Removed.
(Double_Alignment_Of): New subsidiary routine.
(Make_Finalize_Address_Stmts): New local variable Index_Typ. Account
for a hole in the dope vector of unconstrained arrays due to different
index and element alignments.
2011-08-04 Ed Schonberg <schonberg@adacore.com>
* sem_res.adb (Resolve_Allocator): diagnose task allocator that will
raise program_error because body has not been seen yet.
2011-08-04 Ed Schonberg <schonberg@adacore.com>
* sem_ch10.adb (Analyze_With_Clause): Protect against child unit with
an unresolved name.
2011-08-04 Vincent Celier <celier@adacore.com>
* makeutl.adb (Do_Complete): Check absolute paths in canonical forms
2011-08-04 Yannick Moy <moy@adacore.com>
* alfa.adb, alfa.ads (Unique_Defining_Entity): move function from here
* sem_util.adb, sem_util.ads (Unique_Defining_Entity): ...to here
2011-08-04 Thomas Quinot <quinot@adacore.com>
* sem_ch12.adb (Analyze_Package_Instantiation): Do not omit body for
instantiation in RCI.
2011-08-04 Emmanuel Briot <briot@adacore.com>
* make.adb: Share more code with gprbuild
2011-08-04 Emmanuel Briot <briot@adacore.com>
* projects.texi: Added documentation for the IDE'Gnat project file
......
gcc/ada/alfa.adb
......@@ -23,11 +23,8 @@
-- --
------------------------------------------------------------------------------
with Atree; use Atree;
with Output; use Output;
with Put_ALFA;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
package body ALFA is
......@@ -203,26 +200,4 @@ package body ALFA is
Debug_Put_ALFA;
end palfa;
----------------------------
-- Unique_Defining_Entity --
----------------------------
function Unique_Defining_Entity (N : Node_Id) return Entity_Id is
begin
case Nkind (N) is
when N_Package_Body =>
return Corresponding_Spec (N);
when N_Subprogram_Body =>
if Acts_As_Spec (N) then
return Defining_Entity (N);
else
return Corresponding_Spec (N);
end if;
when others =>
return Defining_Entity (N);
end case;
end Unique_Defining_Entity;
end ALFA;
gcc/ada/alfa.ads
......@@ -319,10 +319,6 @@ package ALFA is
procedure Initialize_ALFA_Tables;
-- Reset tables for a new compilation
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.
procedure dalfa;
-- Debug routine to dump internal ALFA tables. This is a raw format dump
-- showing exactly what the tables contain.
......
gcc/ada/bindgen.adb
......@@ -1662,38 +1662,84 @@ package body Bindgen is
Uspec : Unit_Record;
Unum : Unit_Id;
procedure Gen_Header;
-- Generate the header of the finalization routine
procedure Gen_Header is
begin
WBI (" procedure finalize_library is");
-- The following flag is used to check for library-level
-- exceptions raised during finalization. The symbol comes
-- from System.Soft_Links. VM targets use regular Ada to
-- reference the entity.
if VM_Target = No_VM then
WBI (" LE_Set : Boolean;");
Set_String (" pragma Import (Ada, LE_Set, ");
Set_String ("""__gnat_library_exception_set"");");
Write_Statement_Buffer;
end if;
WBI (" begin");
end Gen_Header;
begin
for E in reverse Elab_Order.First .. Elab_Order.Last loop
Unum := Elab_Order.Table (E);
U := Units.Table (Unum);
-- Dealing with package bodies is a little complicated. In such
-- cases we must retrieve the package spec since it contains the
-- spec of the body finalizer.
if U.Utype = Is_Body then
Unum := Unum + 1;
Uspec := Units.Table (Unum);
else
Uspec := U;
end if;
Get_Name_String (Uspec.Uname);
-- We are only interested in non-generic packages
if U.Unit_Kind = 'p'
and then U.Has_Finalizer
and then not U.Is_Generic
and then not U.SAL_Interface
and then not U.No_Elab
then
if not Lib_Final_Built then
Lib_Final_Built := True;
if U.Unit_Kind /= 'p' or else U.Is_Generic then
null;
WBI (" procedure finalize_library is");
-- That aren't an interface to a stand alone library
-- The following flag is used to check for library-level
-- exceptions raised during finalization. The symbol comes
-- from System.Soft_Links. VM targets use regular Ada to
-- reference the entity.
elsif U.SAL_Interface then
null;
if VM_Target = No_VM then
WBI (" LE_Set : Boolean;");
-- Case of no finalization
Set_String (" pragma Import (Ada, LE_Set, ");
Set_String ("""__gnat_library_exception_set"");");
Write_Statement_Buffer;
elsif not U.Has_Finalizer then
-- The only case in which we have to do something is if this
-- is a body, with a separate spec, where the separate spec
-- has a finalizer. In that case, this is where we decrement
-- the elaboration entity.
if U.Utype = Is_Body and then Uspec.Has_Finalizer then
if not Lib_Final_Built then
Gen_Header;
Lib_Final_Built := True;
end if;
WBI (" begin");
Set_String (" E");
Set_Unit_Number (Unum);
Set_String (" := E");
Set_Unit_Number (Unum);
Set_String (" - 1;");
Write_Statement_Buffer;
end if;
else
if not Lib_Final_Built then
Gen_Header;
Lib_Final_Built := True;
end if;
-- Generate:
......@@ -1732,19 +1778,6 @@ package body Bindgen is
Set_Int (Count);
Set_String (", """);
-- Dealing with package bodies is a little complicated. In such
-- cases we must retrieve the package spec since it contains the
-- spec of the body finalizer.
if U.Utype = Is_Body then
Unum := Unum + 1;
Uspec := Units.Table (Unum);
else
Uspec := U;
end if;
Get_Name_String (Uspec.Uname);
-- Perform name construction
-- .NET xx.yy_pkg.xx__yy__finalize
......@@ -1798,13 +1831,19 @@ package body Bindgen is
-- F<Count>;
-- end;
-- The uname_E decrement is skipped if this is a separate spec,
-- since it will be done when we process the body.
WBI (" begin");
Set_String (" E");
Set_Unit_Number (Unum);
Set_String (" := E");
Set_Unit_Number (Unum);
Set_String (" - 1;");
Write_Statement_Buffer;
if U.Utype /= Is_Spec then
Set_String (" E");
Set_Unit_Number (Unum);
Set_String (" := E");
Set_Unit_Number (Unum);
Set_String (" - 1;");
Write_Statement_Buffer;
end if;
if Interface_Library_Unit or not Bind_Main_Program then
Set_String (" if E");
......@@ -1884,37 +1923,68 @@ package body Bindgen is
Uspec : Unit_Record;
Unum : Unit_Id;
procedure Gen_Header;
-- Generate the header of the finalization routine
procedure Gen_Header is
begin
WBI ("static void finalize_library(void) {");
end Gen_Header;
begin
for E in reverse Elab_Order.First .. Elab_Order.Last loop
Unum := Elab_Order.Table (E);
U := Units.Table (Unum);
-- Dealing with package bodies is a little complicated. In such
-- cases we must retrieve the package spec since it contains the
-- spec of the body finalizer.
if U.Utype = Is_Body then
Unum := Unum + 1;
Uspec := Units.Table (Unum);
else
Uspec := U;
end if;
Get_Name_String (Uspec.Uname);
-- We are only interested in non-generic packages
if U.Unit_Kind = 'p'
and then U.Has_Finalizer
and then not U.Is_Generic
and then not U.SAL_Interface
and then not U.No_Elab
then
if not Lib_Final_Built then
Lib_Final_Built := True;
if U.Unit_Kind /= 'p' or else U.Is_Generic then
null;
WBI ("static void finalize_library(void) {");
end if;
-- That aren't an interface to a stand alone library
-- Dealing with package bodies is a little complicated. In such
-- cases we must retrieve the package spec since it contains the
-- spec of the body finalizer.
elsif U.SAL_Interface then
null;
if U.Utype = Is_Body then
Unum := Unum + 1;
Uspec := Units.Table (Unum);
else
Uspec := U;
-- Case of no finalization
elsif not U.Has_Finalizer then
-- The only case in which we have to do something is if this
-- is a body, with a separate spec, where the separate spec
-- has a finalizer. In that case, this is where we decrement
-- the elaboration entity.
if U.Utype = Is_Body and then Uspec.Has_Finalizer then
if not Lib_Final_Built then
Gen_Header;
Lib_Final_Built := True;
end if;
Set_String (" ");
Set_Unit_Name;
Set_String ("_E--;");
Write_Statement_Buffer;
end if;
Get_Name_String (Uspec.Uname);
else
if not Lib_Final_Built then
Gen_Header;
Lib_Final_Built := True;
end if;
-- If binding a library or if there is a non-Ada main subprogram
-- then we generate:
......@@ -1928,10 +1998,15 @@ package body Bindgen is
-- uname_E--;
-- uname__finalize_[spec|body] ();
Set_String (" ");
Set_Unit_Name;
Set_String ("_E--;");
Write_Statement_Buffer;
-- The uname_E decrement is skipped if this is a separate spec,
-- since it will be done when we process the body.
if U.Utype /= Is_Spec then
Set_String (" ");
Set_Unit_Name;
Set_String ("_E--;");
Write_Statement_Buffer;
end if;
if Interface_Library_Unit or not Bind_Main_Program then
Set_String (" if (");
......
gcc/ada/exp_ch7.adb
......@@ -6865,6 +6865,42 @@ package body Exp_Ch7 is
Desg_Typ : Entity_Id;
Obj_Expr : Node_Id;
function Alignment_Of (Some_Typ : Entity_Id) return Node_Id;
-- Subsidiary routine, generate the following attribute reference:
--
-- Some_Typ'Alignment
function Double_Alignment_Of (Some_Typ : Entity_Id) return Node_Id;
-- Subsidiary routine, generate the following expression:
--
-- 2 * Some_Typ'Alignment
------------------
-- Alignment_Of --
------------------
function Alignment_Of (Some_Typ : Entity_Id) return Node_Id is
begin
return
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Some_Typ, Loc),
Attribute_Name => Name_Alignment);
end Alignment_Of;
-------------------------
-- Double_Alignment_Of --
-------------------------
function Double_Alignment_Of (Some_Typ : Entity_Id) return Node_Id is
begin
return
Make_Op_Multiply (Loc,
Left_Opnd => Make_Integer_Literal (Loc, 2),
Right_Opnd => Alignment_Of (Some_Typ));
end Double_Alignment_Of;
-- Start of processing for Make_Finalize_Address_Stmts
begin
if Is_Array_Type (Typ) then
if Is_Constrained (First_Subtype (Typ)) then
......@@ -6931,7 +6967,7 @@ package body Exp_Ch7 is
-- Unconstrained arrays require special processing in order to retrieve
-- the elements. To achieve this, we have to skip the dope vector which
-- lays infront of the elements and then use a thin pointer to perform
-- lays in front of the elements and then use a thin pointer to perform
-- the address-to-access conversion.
if Is_Array_Type (Typ)
......@@ -6942,30 +6978,7 @@ package body Exp_Ch7 is
Dope_Id : Entity_Id;
For_First : Boolean := True;
Index : Node_Id;
function Bounds_Size_Expression (Typ : Entity_Id) return Node_Id;
-- Given the type of an array index, create the following
-- expression:
--
-- 2 * Esize (Typ) / Storage_Unit
----------------------------
-- Bounds_Size_Expression --
----------------------------
function Bounds_Size_Expression (Typ : Entity_Id) return Node_Id is
begin
return
Make_Op_Multiply (Loc,
Left_Opnd => Make_Integer_Literal (Loc, 2),
Right_Opnd =>
Make_Op_Divide (Loc,
Left_Opnd => Make_Integer_Literal (Loc, Esize (Typ)),
Right_Opnd =>
Make_Integer_Literal (Loc, System_Storage_Unit)));
end Bounds_Size_Expression;
-- Start of processing for arrays
Index_Typ : Entity_Id;
begin
-- Ensure that Ptr_Typ a thin pointer, generate:
......@@ -6980,32 +6993,56 @@ package body Exp_Ch7 is
Make_Integer_Literal (Loc, System_Address_Size)));
-- For unconstrained arrays, create the expression which computes
-- the size of the dope vector. Note that in the end, all values
-- will be constant folded.
-- the size of the dope vector.
Index := First_Index (Typ);
while Present (Index) loop
Index_Typ := Etype (Index);
-- Generate:
-- 2 * Esize (Index_Typ) / Storage_Unit
-- Each bound has two values and a potential hole added to
-- compensate for alignment differences.
if For_First then
For_First := False;
Dope_Expr := Bounds_Size_Expression (Etype (Index));
-- Generate:
-- Dope_Expr + 2 * Esize (Index_Typ) / Storage_Unit
-- Generate:
-- 2 * Index_Typ'Alignment
Dope_Expr := Double_Alignment_Of (Index_Typ);
else
-- Generate:
-- Dope_Expr + 2 * Index_Typ'Alignment
Dope_Expr :=
Make_Op_Add (Loc,
Left_Opnd => Dope_Expr,
Right_Opnd => Bounds_Size_Expression (Etype (Index)));
Right_Opnd => Double_Alignment_Of (Index_Typ));
end if;
Next_Index (Index);
end loop;
-- Round the cumulative alignment to the next higher multiple of
-- the array alignment. Generate:
-- ((Dope_Expr + Typ'Alignment - 1) / Typ'Alignment)
-- * Typ'Alignment
Dope_Expr :=
Make_Op_Multiply (Loc,
Left_Opnd =>
Make_Op_Divide (Loc,
Left_Opnd =>
Make_Op_Add (Loc,
Left_Opnd => Dope_Expr,
Right_Opnd =>
Make_Op_Subtract (Loc,
Left_Opnd => Alignment_Of (Typ),
Right_Opnd => Make_Integer_Literal (Loc, 1))),
Right_Opnd => Alignment_Of (Typ)),
Right_Opnd => Alignment_Of (Typ));
-- Generate:
-- Dnn : Storage_Offset := Dope_Expr;
......
gcc/ada/makeutl.adb
......@@ -1347,7 +1347,7 @@ package body Makeutl is
then
-- Traverse in reverse order, since in the case of multi-unit
-- files we will be adding extra files at the end, and there's
-- no need to process them in tun.
-- no need to process them in turn.
for J in reverse Names.First .. Names.Last loop
declare
......@@ -1457,7 +1457,7 @@ package body Makeutl is
else
if Is_Absolute then
if File_Name_Type (Source.Path.Display_Name) /=
if File_Name_Type (Source.Path.Name) /=
File.File
then
Debug_Output
......
gcc/ada/sem_ch10.adb
......@@ -2602,8 +2602,16 @@ package body Sem_Ch10 is
Par_Name := Entity (Pref);
end if;
Set_Entity_With_Style_Check (Pref, Par_Name);
Generate_Reference (Par_Name, Pref);
-- Guard against missing or misspelled child units.
if Present (Par_Name) then
Set_Entity_With_Style_Check (Pref, Par_Name);
Generate_Reference (Par_Name, Pref);
else
Set_Name (N, Make_Null (Sloc (N)));
return;
end if;
end if;
-- If the withed unit is System, and a system extension pragma is
......
gcc/ada/sem_ch12.adb
......@@ -3379,18 +3379,18 @@ package body Sem_Ch12 is
end if;
end;
-- If we are generating calling stubs, we never need a body for an
-- instantiation from source in the visible part, because in that
-- case we'll be generating stubs for any subprogram in the instance.
-- However normal processing occurs for instantiations in generated
-- code or in the private part, since in those cases we do not
-- generate stubs.
if Distribution_Stub_Mode = Generate_Caller_Stub_Body
and then Comes_From_Source (N)
then
Needs_Body := False;
end if;
-- Note that we generate the instance body even when generating
-- calling stubs for an RCI unit: it may be required e.g. if it
-- provides stream attributes for some type used in the profile of a
-- remote subprogram. If the instantiation is within the visible part
-- of the RCI, then calling stubs for any relevant subprogram will
-- be inserted immediately after the subprogram declaration, and
-- will take precedence over the subsequent (original) body. (The
-- stub and original body will be complete homographs, but this is
-- permitted in an instance).
-- Could we do better and remove the original subprogram body in that
-- case???
if Needs_Body then
......
gcc/ada/sem_res.adb
......@@ -4342,6 +4342,21 @@ package body Sem_Res is
Set_Is_Static_Coextension (N, False);
end if;
end if;
-- Report a simple error: if the designated object is a local task,
-- its body has not been seen yet, and its activation will fail
-- an elaboration check.
if Is_Task_Type (Designated_Type (Typ))
and then Scope (Base_Type (Designated_Type (Typ))) = Current_Scope
and then Is_Compilation_Unit (Current_Scope)
and then Ekind (Current_Scope) = E_Package
and then not In_Package_Body (Current_Scope)
then
Error_Msg_N
("cannot activate task before body seen?", N);
Error_Msg_N ("\Program_Error will be raised at run time", N);
end if;
end Resolve_Allocator;
---------------------------
......
gcc/ada/sem_util.adb
......@@ -12179,6 +12179,28 @@ package body Sem_Util is
return Scope_Depth (Enclosing_Dynamic_Scope (Btyp));
end Type_Access_Level;
----------------------------
-- Unique_Defining_Entity --
----------------------------
function Unique_Defining_Entity (N : Node_Id) return Entity_Id is
begin
case Nkind (N) is
when N_Package_Body =>
return Corresponding_Spec (N);
when N_Subprogram_Body =>
if Acts_As_Spec (N) then
return Defining_Entity (N);
else
return Corresponding_Spec (N);
end if;
when others =>
return Defining_Entity (N);
end case;
end Unique_Defining_Entity;
--------------------------
-- Unit_Declaration_Node --
--------------------------
......
gcc/ada/sem_util.ads
......@@ -1368,6 +1368,10 @@ package Sem_Util is
function Type_Access_Level (Typ : Entity_Id) return Uint;
-- Return the accessibility level of Typ
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.
function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id;
-- Unit_Id is the simple name of a program unit, this function returns the
-- corresponding xxx_Declaration node for the entity. Also applies to the
......
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