mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-02-22 22:30:18 +08:00
Code Issues Packages Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2009-04-15  Pascal Obry  <obry@adacore.com>

	* adaint.h (__gnat_unlink): Add spec.
	(__gnat_rename): Likewise.

2009-04-15  Vincent Celier  <celier@adacore.com>

	* prj-nmsc.adb: Minor spelling error corrections in error messages

2009-04-15  Robert Dewar  <dewar@adacore.com>

	* sinfo.ads: Minor comment update

	* opt.ads: Minor comment updates

	* checks.adb (Enable_Overflow_Check): Do not set Do_Overflow_Check for
	modular type.

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

	* exp_disp.ads, exp_disp.adb (Register_Primitive): Is now a function
	that generates the code needed to update a dispatch table when a
	primitive operation is declared with a subprogram body without previous
	spec. Insertion of the generated code is responsibility of the caller.
	(Make_DT): When building static tables, append the code created by
	Register_Primitive to update a secondary table after it has been
	constructed.

	* exp_ch3.adb, exp_ch6.adb: use new version of Register_Primitive.

	* sem_disp.adb (Check_Dispatching_Operation): Call Register_Primitive
	on an overriding operation that implements an interface operation only
	if not building static dispatch tables.

2009-04-15  Hristian Kirtchev  <kirtchev@adacore.com>

	* a-caldel-vms.adb (To_Duration): Declare a "safe" end of time which
	does not cause overflow when converted to Duration. Use the safe value
	as the maximum allowable time delay..

2009-04-15  Jerome Lambourg  <lambourg@adacore.com>

	* g-comlin.adb (Set_Command_Line): When adding a switch with attached
	parameter, specify that the delimiter is NUL, otherwise "-j2" will be
	translated to "-j 2".

2009-04-15  Bob Duff  <duff@adacore.com>

	* rtsfind.adb (Maybe_Add_With): Split out procedure to add implicit
	with_clauses, to avoid code duplication. Change this processing so we
	always add a with_clause on the main unit if needed.

From-SVN: r146102
This commit is contained in:
Arnaud Charlet 2009-04-15 14:09:35 +02:00
parent 55cc1a0524
commit 991395ab4f
14 changed files with 208 additions and 132 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

52
gcc/ada/ChangeLog
View File

@ -1,3 +1,55 @@
2009-04-15 Pascal Obry <obry@adacore.com>
* adaint.h (__gnat_unlink): Add spec.
(__gnat_rename): Likewise.
2009-04-15 Vincent Celier <celier@adacore.com>
* prj-nmsc.adb: Minor spelling error corrections in error messages
2009-04-15 Robert Dewar <dewar@adacore.com>
* sinfo.ads: Minor comment update
* opt.ads: Minor comment updates
* checks.adb (Enable_Overflow_Check): Do not set Do_Overflow_Check for
modular type.
2009-04-15 Ed Schonberg <schonberg@adacore.com>
* exp_disp.ads, exp_disp.adb (Register_Primitive): Is now a function
that generates the code needed to update a dispatch table when a
primitive operation is declared with a subprogram body without previous
spec. Insertion of the generated code is responsibility of the caller.
(Make_DT): When building static tables, append the code created by
Register_Primitive to update a secondary table after it has been
constructed.
* exp_ch3.adb, exp_ch6.adb: use new version of Register_Primitive.
* sem_disp.adb (Check_Dispatching_Operation): Call Register_Primitive
on an overriding operation that implements an interface operation only
if not building static dispatch tables.
2009-04-15 Hristian Kirtchev <kirtchev@adacore.com>
* a-caldel-vms.adb (To_Duration): Declare a "safe" end of time which
does not cause overflow when converted to Duration. Use the safe value
as the maximum allowable time delay..
2009-04-15 Jerome Lambourg <lambourg@adacore.com>
* g-comlin.adb (Set_Command_Line): When adding a switch with attached
parameter, specify that the delimiter is NUL, otherwise "-j2" will be
translated to "-j 2".
2009-04-15 Bob Duff <duff@adacore.com>
* rtsfind.adb (Maybe_Add_With): Split out procedure to add implicit
with_clauses, to avoid code duplication. Change this processing so we
always add a with_clause on the main unit if needed.
2009-04-15 Pascal Obry <obry@adacore.com>
Add support for Win32 native encoding for delete/rename routines.

14
gcc/ada/a-caldel-vms.adb
View File

@ -75,8 +75,20 @@ package body Ada.Calendar.Delays is
-----------------
function To_Duration (T : Time) return Duration is
Safe_Ada_High : constant Time := Time_Of (2250, 1, 1, 0.0);
-- A value distant enough to emulate "end of time" but which does not
-- cause overflow.
Safe_T : Time;
begin
return OSP.To_Duration (OSP.OS_Time (T), OSP.Absolute_Calendar);
if T > Safe_Ada_High then
Safe_T := Safe_Ada_High;
else
Safe_T := T;
end if;
return OSP.To_Duration (OSP.OS_Time (Safe_T), OSP.Absolute_Calendar);
end To_Duration;
--------------------

3
gcc/ada/adaint.h
View File

@ -70,6 +70,9 @@ extern int __gnat_open_new_temp (char *, int);
extern int __gnat_mkdir (char *);
extern int __gnat_stat (char *,
struct stat *);
extern int __gnat_unlink (char *);
extern int __gnat_rename (char *, char *);
extern FILE *__gnat_fopen (char *, char *, int);
extern FILE *__gnat_freopen (char *, char *, FILE *,
int);

5
gcc/ada/checks.adb
View File

@ -3568,6 +3568,11 @@ package body Checks is
then
return;
-- Nothing to do for unsigned integer types, which do not overflow
elsif Is_Modular_Integer_Type (Typ) then
return;
-- Nothing to do if the range of the result is known OK. We skip this
-- for conversions, since the caller already did the check, and in any
-- case the condition for deleting the check for a type conversion is

5
gcc/ada/exp_ch3.adb
View File

@ -2394,9 +2394,8 @@ package body Exp_Ch3 is
and then Convention (Prim) = Convention_CPP
and then not Present (Interface_Alias (Prim))
then
Register_Primitive (Loc,
Prim => Prim,
Ins_Nod => Last (Init_Tags_List));
Append_List_To (Init_Tags_List,
Register_Primitive (Loc, Prim => Prim));
end if;
Next_Elmt (E);

5
gcc/ada/exp_ch6.adb
View File

@ -4911,9 +4911,8 @@ package body Exp_Ch6 is
Register_Predefined_DT_Entry (Subp);
end if;
Register_Primitive (Loc,
Prim => Subp,
Ins_Nod => N);
Insert_Actions_After (N,
Register_Primitive (Loc, Prim => Subp));
end if;
end if;
end;

29
gcc/ada/exp_disp.adb
View File

@ -6273,17 +6273,16 @@ package body Exp_Disp is
-- Register_Primitive --
------------------------
procedure Register_Primitive
function Register_Primitive
(Loc : Source_Ptr;
Prim : Entity_Id;
Ins_Nod : Node_Id)
Prim : Entity_Id) return List_Id
is
DT_Ptr : Entity_Id;
Iface_Prim : Entity_Id;
Iface_Typ : Entity_Id;
Iface_DT_Ptr : Entity_Id;
Iface_DT_Elmt : Elmt_Id;
L : List_Id;
L : constant List_Id := New_List;
Pos : Uint;
Tag : Entity_Id;
Tag_Typ : Entity_Id;
@ -6294,7 +6293,7 @@ package body Exp_Disp is
pragma Assert (not Restriction_Active (No_Dispatching_Calls));
if not RTE_Available (RE_Tag) then
return;
return L;
end if;
if not Present (Interface_Alias (Prim)) then
@ -6308,7 +6307,7 @@ package body Exp_Disp is
DT_Ptr :=
Node (Next_Elmt (First_Elmt (Access_Disp_Table (Tag_Typ))));
Insert_After (Ins_Nod,
Append_To (L,
Build_Set_Predefined_Prim_Op_Address (Loc,
Tag_Node => New_Reference_To (DT_Ptr, Loc),
Position => Pos,
@ -6324,7 +6323,7 @@ package body Exp_Disp is
and then RTE_Record_Component_Available (RE_Size_Func)
then
DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ)));
Insert_After (Ins_Nod,
Append_To (L,
Build_Set_Size_Function (Loc,
Tag_Node => New_Reference_To (DT_Ptr, Loc),
Size_Func => Prim));
@ -6334,7 +6333,7 @@ package body Exp_Disp is
pragma Assert (Pos /= Uint_0 and then Pos <= DT_Entry_Count (Tag));
DT_Ptr := Node (First_Elmt (Access_Disp_Table (Tag_Typ)));
Insert_After (Ins_Nod,
Append_To (L,
Build_Set_Prim_Op_Address (Loc,
Typ => Tag_Typ,
Tag_Node => New_Reference_To (DT_Ptr, Loc),
@ -6363,12 +6362,6 @@ package body Exp_Disp is
if not Is_Ancestor (Iface_Typ, Tag_Typ)
and then Present (Thunk_Code)
then
-- Comment needed on why checks are suppressed. This is not just
-- efficiency, but fundamental functionality (see 1.295 RH, which
-- still does not answer this question) ???
Insert_Action (Ins_Nod, Thunk_Code, Suppress => All_Checks);
-- Generate the code necessary to fill the appropriate entry of
-- the secondary dispatch table of Prim's controlling type with
-- Thunk_Id's address.
@ -6380,7 +6373,8 @@ package body Exp_Disp is
Iface_Prim := Interface_Alias (Prim);
Pos := DT_Position (Iface_Prim);
Tag := First_Tag_Component (Iface_Typ);
L := New_List;
Prepend_To (L, Thunk_Code);
if Is_Predefined_Dispatching_Operation (Prim)
or else Is_Predefined_Dispatching_Alias (Prim)
@ -6412,8 +6406,6 @@ package body Exp_Disp is
Prefix => New_Reference_To (Alias (Prim), Loc),
Attribute_Name => Name_Unrestricted_Access))));
Insert_Actions_After (Ins_Nod, L);
else
pragma Assert (Pos /= Uint_0
and then Pos <= DT_Entry_Count (Tag));
@ -6445,10 +6437,11 @@ package body Exp_Disp is
Prefix => New_Reference_To (Alias (Prim), Loc),
Attribute_Name => Name_Unrestricted_Access))));
Insert_Actions_After (Ins_Nod, L);
end if;
end if;
end if;
return L;
end Register_Primitive;
-------------------------

13
gcc/ada/exp_disp.ads
View File

@ -306,19 +306,22 @@ package Exp_Disp is
-- tagged types this routine imports the forward declaration of the tag
-- entity, that will be declared and exported by Make_DT.
procedure Register_Primitive
function Register_Primitive
(Loc : Source_Ptr;
Prim : Entity_Id;
Ins_Nod : Node_Id);
-- Register Prim in the corresponding primary or secondary dispatch table.
Prim : Entity_Id) return List_Id;
-- Build code to register Prim in the primary or secondary dispatch table.
-- If Prim is associated with a secondary dispatch table then generate also
-- its thunk and register it in the associated secondary dispatch table.
-- In general the dispatch tables are always generated by Make_DT and
-- Make_Secondary_DT; this routine is only used in two corner cases:
--
-- 1) To construct the dispatch table of a tagged type whose parent
-- is a CPP_Class (see Build_Init_Procedure).
-- 2) To handle late overriding of dispatching operations (see
-- Check_Dispatching_Operation).
-- Check_Dispatching_Operation and Make_DT).
--
-- The caller is responsible for inserting the generated code in the
-- proper place.
procedure Set_All_DT_Position (Typ : Entity_Id);
-- Set the DT_Position field for each primitive operation. In the CPP

2
gcc/ada/g-comlin.adb
View File

@ -1277,7 +1277,7 @@ package body GNAT.Command_Line is
if Separator (Parser) = ASCII.NUL then
Add_Switch
(Cmd, Sw & Parameter (Parser), "");
(Cmd, Sw & Parameter (Parser), "", ASCII.NUL);
else
Add_Switch
(Cmd, Sw, Parameter (Parser), Separator (Parser));

6
gcc/ada/opt.ads
View File

@ -1316,14 +1316,14 @@ package Opt is
-- handlers that can never handle a local raise. This warning is only ever
-- generated if pragma Restrictions (No_Exception_Propagation) is set. The
-- default is not to generate the warnings except that if the source has
-- at least one exception, and this restriction is set, and the warning
-- was not explicitly turned off, then it is turned on by default.
-- at least one exception handler, and this restriction is set, and the
-- warning was not explicitly turned off, then it is turned on by default.
No_Warn_On_Non_Local_Exception : Boolean := False;
-- GNAT
-- This is set to True if the above warning is explicitly suppressed. We
-- use this to avoid turning it on by default when No_Exception_Propagation
-- restriction is set.
-- restriction is set and an exception handler is present.
Warn_On_Obsolescent_Feature : Boolean := False;
-- GNAT

6
gcc/ada/prj-nmsc.adb
View File

@ -746,8 +746,8 @@ package body Prj.Nmsc is
if Data.Qualifier = Dry and then Data.Source_Dirs /= Nil_String then
Error_Msg
(Project, In_Tree,
"an abstract project need to have no language, no sources or no " &
"source directories",
"an abstract project needs to have no language, no sources " &
"or no source directories",
Data.Location);
end if;
@ -5347,7 +5347,7 @@ package body Prj.Nmsc is
then
Error_Msg
(Project, In_Tree,
"a reference symbol file need to be defined",
"a reference symbol file needs to be defined",
Lib_Symbol_Policy.Location);
end if;

181
gcc/ada/rtsfind.adb
View File

@ -79,11 +79,16 @@ package body Rtsfind is
-- the latter case it is critical to make a call to Set_RTU_Loaded to
-- ensure that the entry in this table reflects the load.
-- Withed is True if an implicit with_clause has been added from some unit
-- other than the main unit to this unit. Withed_By_Main is the same,
-- except from the main unit.
type RT_Unit_Table_Record is record
Entity : Entity_Id;
Uname : Unit_Name_Type;
Unum : Unit_Number_Type;
Withed : Boolean;
Entity : Entity_Id;
Uname : Unit_Name_Type;
Unum : Unit_Number_Type;
Withed : Boolean;
Withed_By_Main : Boolean;
end record;
RT_Unit_Table : array (RTU_Id) of RT_Unit_Table_Record;
@ -106,22 +111,19 @@ package body Rtsfind is
RE_Table : array (RE_Id) of Entity_Id;
--------------------------
-- Generation of WITH's --
--------------------------
--------------------------------
-- Generation of with_clauses --
--------------------------------
-- When a unit is implicitly loaded as a result of a call to RTE, it is
-- necessary to create an implicit WITH to ensure that the object is
-- correctly loaded by the binder. We originally added such WITH clauses
-- only if the extended main unit required them, and added them only to the
-- extended main unit. They are currently added to whatever unit first
-- needs them, which is not necessarily the main unit. This works because
-- if the main unit requires some runtime unit also required by some other
-- unit, the other unit's implicit WITH will force a correct elaboration
-- order. This method is necessary for SofCheck Inspector.
-- necessary to create one or two implicit with_clauses. We add such
-- with_clauses to the extended main unit if needed, and also to whatever
-- unit first needs them, which is not necessarily the main unit. The
-- former ensures that the object is correctly loaded by the binder. The
-- latter is necessary for SofCheck Inspector.
-- The flag Withed in the unit table record is initially set to False. It
-- is set True if a WITH has been generated for the corresponding unit.
-- The flags Withed and Withed_By_Main in the unit table record are used to
-- avoid duplicates.
-----------------------
-- Local Subprograms --
@ -178,6 +180,10 @@ package body Rtsfind is
-- If the unit is a child unit, build fully qualified name for use in
-- With_Clause.
procedure Maybe_Add_With (E : RE_Id; U : in out RT_Unit_Table_Record);
-- If necessary, add an implicit with_clause from the current unit to the
-- one represented by E and U.
procedure Output_Entity_Name (Id : RE_Id; Msg : String);
-- Output continuation error message giving qualified name of entity
-- corresponding to Id, appending the string given by Msg. This call
@ -661,8 +667,9 @@ package body Rtsfind is
-- Otherwise we need to load the unit, First build unit name
-- from the enumeration literal name in type RTU_Id.
U.Uname := Get_Unit_Name (U_Id);
U.Withed := False;
U.Uname := Get_Unit_Name (U_Id);
U.Withed := False;
U.Withed_By_Main := False;
-- Now do the load call, note that setting Error_Node to Empty is
-- a signal to Load_Unit that we will regard a failure to find the
@ -721,7 +728,7 @@ package body Rtsfind is
if not Analyzed (Cunit (U.Unum)) then
-- If the unit is already loaded through a limited_with clause,
-- If the unit is already loaded through a limited_with_clause,
-- the relevant entities must already be available. We do not
-- want to load and analyze the unit because this would create
-- a real semantic dependence when the purpose of the limited_with
@ -784,7 +791,66 @@ package body Rtsfind is
return Nam;
end Make_Unit_Name;
-----------------------
--------------------
-- Maybe_Add_With --
--------------------
procedure Maybe_Add_With (E : RE_Id; U : in out RT_Unit_Table_Record) is
Is_Main : constant Boolean :=
In_Extended_Main_Code_Unit (Cunit_Entity (Current_Sem_Unit));
begin
-- We do not need to generate a with_clause for a call issued from
-- RTE_Component_Available.
if RTE_Available_Call then
return;
end if;
-- If the current unit is the main one, add the with_clause unless it's
-- already been done.
if Is_Main then
if U.Withed_By_Main then
return;
else
U.Withed_By_Main := True;
end if;
-- If the current unit is not the main one, add the with_clause unless
-- it's already been done for some non-main unit.
else
if U.Withed then
return;
else
U.Withed := True;
end if;
end if;
-- Here if we've decided to add the with_clause
declare
Lib_Unit : constant Node_Id := Unit (Cunit (U.Unum));
Withn : constant Node_Id :=
Make_With_Clause (Standard_Location,
Name =>
Make_Unit_Name
(E, Defining_Unit_Name (Specification (Lib_Unit))));
begin
Set_Library_Unit (Withn, Cunit (U.Unum));
Set_Corresponding_Spec (Withn, U.Entity);
Set_First_Name (Withn, True);
Set_Implicit_With (Withn, True);
Mark_Rewrite_Insertion (Withn);
Append (Withn, Context_Items (Cunit (Current_Sem_Unit)));
Check_Restriction_No_Dependence (Name (Withn), Current_Error_Node);
end;
end Maybe_Add_With;
------------------------
-- Output_Entity_Name --
------------------------
@ -1063,36 +1129,8 @@ package body Rtsfind is
end if;
end if;
-- See if we have to generate a WITH for this entity. We generate a WITH
-- if we have not already added the with. The WITH is added to the
-- appropriate unit (the current one). We do not need to generate a WITH
-- for a call issued from RTE_Available.
<<Found>>
if not U.Withed and then not RTE_Available_Call then
U.Withed := True;
declare
Withn : Node_Id;
Lib_Unit : Node_Id;
begin
Lib_Unit := Unit (Cunit (U.Unum));
Withn :=
Make_With_Clause (Standard_Location,
Name =>
Make_Unit_Name
(E, Defining_Unit_Name (Specification (Lib_Unit))));
Set_Library_Unit (Withn, Cunit (U.Unum));
Set_Corresponding_Spec (Withn, U.Entity);
Set_First_Name (Withn, True);
Set_Implicit_With (Withn, True);
Mark_Rewrite_Insertion (Withn);
Append (Withn, Context_Items (Cunit (Current_Sem_Unit)));
Check_Restriction_No_Dependence (Name (Withn), Current_Error_Node);
end;
end if;
Maybe_Add_With (E, U);
Front_End_Inlining := Save_Front_End_Inlining;
return Check_CRT (E, RE_Table (E));
@ -1197,39 +1235,7 @@ package body Rtsfind is
-- If we didn't find the entity we want, something is wrong. The
-- appropriate action will be taken by Check_CRT when we exit.
-- Generate a with-clause if the current unit is part of the extended
-- main code unit, and if we have not already added the with. The clause
-- is added to the appropriate unit (the current one). We do not need to
-- generate it for a call issued from RTE_Component_Available.
if (not U.Withed)
and then
In_Extended_Main_Code_Unit (Cunit_Entity (Current_Sem_Unit))
and then not RTE_Available_Call
then
U.Withed := True;
declare
Withn : Node_Id;
Lib_Unit : Node_Id;
begin
Lib_Unit := Unit (Cunit (U.Unum));
Withn :=
Make_With_Clause (Standard_Location,
Name =>
Make_Unit_Name
(E, Defining_Unit_Name (Specification (Lib_Unit))));
Set_Library_Unit (Withn, Cunit (U.Unum));
Set_Corresponding_Spec (Withn, U.Entity);
Set_First_Name (Withn, True);
Set_Implicit_With (Withn, True);
Mark_Rewrite_Insertion (Withn);
Append (Withn, Context_Items (Cunit (Current_Sem_Unit)));
Check_Restriction_No_Dependence (Name (Withn), Current_Error_Node);
end;
end if;
Maybe_Add_With (E, U);
Front_End_Inlining := Save_Front_End_Inlining;
return Check_CRT (E, Found_E);
@ -1334,10 +1340,11 @@ package body Rtsfind is
-- If entry is not set, set it now
if No (U.Entity) then
U.Entity := E;
U.Uname := Get_Unit_Name (U_Id);
U.Unum := Unum;
U.Withed := False;
U := (Entity => E,
Uname => Get_Unit_Name (U_Id),
Unum => Unum,
Withed => False,
Withed_By_Main => False);
end if;
return;

17
gcc/ada/sem_disp.adb
View File

@ -28,6 +28,7 @@ with Debug; use Debug;
with Elists; use Elists;
with Einfo; use Einfo;
with Exp_Disp; use Exp_Disp;
with Exp_Util; use Exp_Util;
with Exp_Ch7; use Exp_Ch7;
with Exp_Tss; use Exp_Tss;
with Errout; use Errout;
@ -835,9 +836,9 @@ package body Sem_Disp is
end if;
else
Register_Primitive (Sloc (Subp_Body),
Prim => Subp,
Ins_Nod => Subp_Body);
Insert_Actions_After (Subp_Body,
Register_Primitive (Sloc (Subp_Body),
Prim => Subp));
end if;
Generate_Reference (Tagged_Type, Subp, 'p', False);
@ -909,7 +910,9 @@ package body Sem_Disp is
-- Ada 2005 (AI-251): In case of late overriding of a primitive
-- that covers abstract interface subprograms we must register it
-- in all the secondary dispatch tables associated with abstract
-- interfaces.
-- interfaces. We do this now only if not building static tables.
-- Otherwise the patch code is emitted after those tables are
-- built, to prevent access_before_elaboration in gigi.
if Body_Is_Last_Primitive then
declare
@ -925,10 +928,10 @@ package body Sem_Disp is
if Present (Alias (Prim))
and then Present (Interface_Alias (Prim))
and then Alias (Prim) = Subp
and then not Building_Static_DT (Tagged_Type)
then
Register_Primitive (Sloc (Prim),
Prim => Prim,
Ins_Nod => Subp_Body);
Insert_Actions_After (Subp_Body,
Register_Primitive (Sloc (Subp_Body), Prim => Prim));
end if;
Next_Elmt (Elmt);

2
gcc/ada/sinfo.ads
View File

@ -806,7 +806,7 @@ package Sinfo is
-- See also the description of Do_Range_Check for this case. The only
-- attribute references which use this flag are Pred and Succ, where it
-- means that the result should be checked for going outside the base
-- range.
-- range. Note that this flag is not set for modular types.
-- Do_Range_Check (Flag9-Sem)
-- This flag is set on an expression which appears in a context where a