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

[multiple changes]

Browse Source 
2009-04-10  Thomas Quinot  <quinot@adacore.com>

	* xsnamest.adb: Use XUtil to have uniform line endings (UNIX style) in
	generated files on all platforms.

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

	* sem_aux.adb: Minor reformatting

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

	* sem_ch3.adb (Access_Definition): Handle properly the case of a
	protected function with formals that returns an anonymous access type.

2009-04-10  Thomas Quinot  <quinot@adacore.com>

	* sem_disp.adb: Minor reformatting

2009-04-10  Vasiliy Fofanov  <fofanov@adacore.com>

	* seh_init.c: Do not use the 32-bit specific implementation of
	__gnat_install_SEH_handler on 64-bit Windows target (64-bit specific
	version TBD).

2009-04-10  Jose Ruiz  <ruiz@adacore.com>

	* mlib-tgt-specific-xi.adb (Get_Target_Prefix): Target_Name may contain
	a '/' at the end so we better use the complete target name to determine
	whether it is a PowerPC 55xx target.

From-SVN: r145898
This commit is contained in:
Arnaud Charlet 2009-04-10 15:20:52 +02:00
parent b8063c9899
commit 550f4135fd
7 changed files with 121 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
gcc/ada/ChangeLog
View File

@ -1,3 +1,33 @@
2009-04-10 Thomas Quinot <quinot@adacore.com>
* xsnamest.adb: Use XUtil to have uniform line endings (UNIX style) in
generated files on all platforms.
2009-04-10 Robert Dewar <dewar@adacore.com>
* sem_aux.adb: Minor reformatting
2009-04-10 Ed Schonberg <schonberg@adacore.com>
* sem_ch3.adb (Access_Definition): Handle properly the case of a
protected function with formals that returns an anonymous access type.
2009-04-10 Thomas Quinot <quinot@adacore.com>
* sem_disp.adb: Minor reformatting
2009-04-10 Vasiliy Fofanov <fofanov@adacore.com>
* seh_init.c: Do not use the 32-bit specific implementation of
__gnat_install_SEH_handler on 64-bit Windows target (64-bit specific
version TBD).
2009-04-10 Jose Ruiz <ruiz@adacore.com>
* mlib-tgt-specific-xi.adb (Get_Target_Prefix): Target_Name may contain
a '/' at the end so we better use the complete target name to determine
whether it is a PowerPC 55xx target.
2009-04-10 Thomas Quinot <quinot@adacore.com>
* sem_eval.adb: Minor reformatting

5
gcc/ada/mlib-tgt-specific-xi.adb
View File

@ -155,8 +155,9 @@ package body MLib.Tgt.Specific is
elsif Target_Name (Target_Name'First .. Index) = "leon" then
return "leon-elf-";
elsif Target_Name (Target_Name'First .. Index) = "powerpc" then
if Target_Name'Last - 6 >= Target_Name'First and then
Target_Name (Target_Name'Last - 6 .. Target_Name'Last) = "eabispe"
if Target_Name'Length >= 23 and then
Target_Name (Target_Name'First .. Target_Name'First + 22) =
"powerpc-unknown-eabispe"
then
return "powerpc-eabispe-";
else

4
gcc/ada/seh_init.c
View File

@ -59,7 +59,7 @@ extern struct Exception_Data _abort_signal;
extern void Raise_From_Signal_Handler (struct Exception_Data *, const char *);
#ifdef _WIN32
#if defined (_WIN32) && !defined (_WIN64)
#include <windows.h>
#include <excpt.h>
@ -224,7 +224,7 @@ __gnat_install_SEH_handler (void *ER)
asm ("mov %ecx,%fs:(0)");
}
#else /* _WIN32 */
#else /* defined (_WIN32) && !defined (_WIN64) */
/* For all non Windows targets we provide a dummy SEH install handler. */
void __gnat_install_SEH_handler (void *eh ATTRIBUTE_UNUSED)
{

28
gcc/ada/sem_aux.adb
View File

@ -107,9 +107,9 @@ package body Sem_Aux is
Full_D : Node_Id;
begin
-- If we have no declaration node, then return no constant value.
-- Not clear how this can happen, but it does sometimes and this is
-- the safest approach.
-- If we have no declaration node, then return no constant value. Not
-- clear how this can happen, but it does sometimes and this is the
-- safest approach.
if No (D) then
return Empty;
@ -119,9 +119,9 @@ package body Sem_Aux is
elsif Nkind (D) = N_Object_Renaming_Declaration then
return Renamed_Object (Ent);
-- If this is a component declaration whose entity is constant, it
-- is a prival within a protected function. It does not have
-- a constant value.
-- If this is a component declaration whose entity is constant, it is
-- a prival within a protected function. It does not have a constant
-- value.
elsif Nkind (D) = N_Component_Declaration then
return Empty;
@ -161,8 +161,8 @@ package body Sem_Aux is
S : Entity_Id;
begin
-- The following test is an error defense against some syntax
-- errors that can leave scopes very messed up.
-- The following test is an error defense against some syntax errors
-- that can leave scopes very messed up.
if Ent = Standard_Standard then
return Ent;
@ -314,12 +314,12 @@ package body Sem_Aux is
begin
-- If the base type has no freeze node, it is a type in standard,
-- and always acts as its own first subtype unless it is one of
-- the predefined integer types. If the type is formal, it is also
-- a first subtype, and its base type has no freeze node. On the other
-- hand, a subtype of a generic formal is not its own first_subtype.
-- Its base type, if anonymous, is attached to the formal type decl.
-- from which the first subtype is obtained.
-- and always acts as its own first subtype unless it is one of the
-- predefined integer types. If the type is formal, it is also a first
-- subtype, and its base type has no freeze node. On the other hand, a
-- subtype of a generic formal is not its own first_subtype. Its base
-- type, if anonymous, is attached to the formal type decl. from which
-- the first subtype is obtained.
if No (F) then

31
gcc/ada/sem_ch3.adb
View File

@ -726,11 +726,12 @@ package body Sem_Ch3 is
(Related_Nod : Node_Id;
N : Node_Id) return Entity_Id
is
Loc : constant Source_Ptr := Sloc (Related_Nod);
Anon_Type : Entity_Id;
Anon_Scope : Entity_Id;
Desig_Type : Entity_Id;
Decl : Entity_Id;
Loc : constant Source_Ptr := Sloc (Related_Nod);
Anon_Type : Entity_Id;
Anon_Scope : Entity_Id;
Desig_Type : Entity_Id;
Decl : Entity_Id;
Enclosing_Prot_Type : Entity_Id := Empty;
begin
if Is_Entry (Current_Scope)
@ -767,9 +768,23 @@ package body Sem_Ch3 is
-- is associated with one of the protected operations, and must
-- be available in the scope that encloses the protected declaration.
-- Otherwise the type is in the scope enclosing the subprogram.
-- If the function has formals, The return type of a subprogram
-- declaration is analyzed in the scope of the subprogram (see
-- Process_Formals) and thus the protected type, if present, is
-- the scope of the current function scope.
if Ekind (Current_Scope) = E_Protected_Type then
Anon_Scope := Scope (Scope (Defining_Entity (Related_Nod)));
Enclosing_Prot_Type := Current_Scope;
elsif Ekind (Current_Scope) = E_Function
and then Ekind (Scope (Current_Scope)) = E_Protected_Type
then
Enclosing_Prot_Type := Scope (Current_Scope);
end if;
if Present (Enclosing_Prot_Type) then
Anon_Scope := Scope (Enclosing_Prot_Type);
else
Anon_Scope := Scope (Defining_Entity (Related_Nod));
end if;
@ -947,8 +962,8 @@ package body Sem_Ch3 is
elsif Nkind (Related_Nod) = N_Function_Specification
and then not From_With_Type (Anon_Type)
then
if Ekind (Current_Scope) = E_Protected_Type then
Build_Itype_Reference (Anon_Type, Parent (Current_Scope));
if Present (Enclosing_Prot_Type) then
Build_Itype_Reference (Anon_Type, Parent (Enclosing_Prot_Type));
elsif Is_List_Member (Parent (Related_Nod))
and then Nkind (Parent (N)) /= N_Parameter_Specification

67
gcc/ada/sem_disp.adb
View File

@ -83,8 +83,8 @@ package body Sem_Disp is
List : constant Elist_Id := Primitive_Operations (Tagged_Type);
begin
-- The dispatching operation may already be on the list, if it the
-- wrapper for an inherited function of a null extension (see exp_ch3
-- The dispatching operation may already be on the list, if it is the
-- wrapper for an inherited function of a null extension (see Exp_Ch3
-- for the construction of function wrappers). The list of primitive
-- operations must not contain duplicates.
@ -185,7 +185,7 @@ package body Sem_Disp is
Set_Has_Controlling_Result (Subp);
-- Check that result subtype statically matches first subtype
-- (Ada 2005) : Subp may have a controlling access result.
-- (Ada 2005): Subp may have a controlling access result.
if Subtypes_Statically_Match (Typ, Etype (Subp))
or else (Ekind (Etype (Subp)) = E_Anonymous_Access_Type
@ -236,8 +236,8 @@ package body Sem_Disp is
Tagged_Type := Base_Type (Designated_Type (T));
end if;
-- Ada 2005 : an incomplete type can be tagged. An operation with
-- an access parameter of the type is dispatching.
-- Ada 2005: an incomplete type can be tagged. An operation with an
-- access parameter of the type is dispatching.
elsif Scope (Designated_Type (T)) = Current_Scope then
Tagged_Type := Designated_Type (T);
@ -256,14 +256,12 @@ package body Sem_Disp is
end if;
end if;
if No (Tagged_Type)
or else Is_Class_Wide_Type (Tagged_Type)
then
if No (Tagged_Type) or else Is_Class_Wide_Type (Tagged_Type) then
return Empty;
-- The dispatching type and the primitive operation must be defined
-- in the same scope, except in the case of internal operations and
-- formal abstract subprograms.
-- The dispatching type and the primitive operation must be defined in
-- the same scope, except in the case of internal operations and formal
-- abstract subprograms.
elsif ((Scope (Subp) = Scope (Tagged_Type) or else Is_Internal (Subp))
and then (not Is_Generic_Type (Tagged_Type)
@ -300,7 +298,7 @@ package body Sem_Disp is
Static_Tag : Node_Id := Empty;
-- If a controlling formal has a statically tagged actual, the tag of
-- this actual is to be used for any tag-indeterminate actual
-- this actual is to be used for any tag-indeterminate actual.
procedure Check_Dispatching_Context;
-- If the call is tag-indeterminate and the entity being called is
@ -323,8 +321,8 @@ package body Sem_Disp is
and then not Is_Abstract_Subprogram (Alias (Subp))
and then No (DTC_Entity (Subp))
then
-- Private overriding of inherited abstract operation,
-- call is legal.
-- Private overriding of inherited abstract operation, call is
-- legal.
Set_Entity (Name (N), Alias (Subp));
return;
@ -399,7 +397,7 @@ package body Sem_Disp is
-- If the formal is controlling but the actual is not, the type
-- of the actual is statically known, and may be used as the
-- controlling tag for some other-indeterminate actual.
-- controlling tag for some other tag-indeterminate actual.
elsif Is_Controlling_Formal (Formal)
and then Is_Entity_Name (Actual)
@ -412,18 +410,19 @@ package body Sem_Disp is
Next_Formal (Formal);
end loop;
-- If the call doesn't have a controlling actual but does have
-- an indeterminate actual that requires dispatching treatment,
-- then an object is needed that will serve as the controlling
-- argument for a dispatching call on the indeterminate actual.
-- This can only occur in the unusual situation of a default
-- actual given by a tag-indeterminate call and where the type
-- of the call is an ancestor of the type associated with a
-- containing call to an inherited operation (see AI-239).
-- Rather than create an object of the tagged type, which would
-- be problematic for various reasons (default initialization,
-- discriminants), the tag of the containing call's associated
-- tagged type is directly used to control the dispatching.
-- If the call doesn't have a controlling actual but does have an
-- indeterminate actual that requires dispatching treatment, then an
-- object is needed that will serve as the controlling argument for a
-- dispatching call on the indeterminate actual. This can only occur
-- in the unusual situation of a default actual given by a
-- tag-indeterminate call and where the type of the call is an
-- ancestor of the type associated with a containing call to an
-- inherited operation (see AI-239).
-- Rather than create an object of the tagged type, which would be
-- problematic for various reasons (default initialization,
-- discriminants), the tag of the containing call's associated tagged
-- type is directly used to control the dispatching.
if No (Control)
and then Indeterm_Ancestor_Call
@ -460,11 +459,11 @@ package body Sem_Disp is
elsif Is_Tag_Indeterminate (Actual) then
-- The tag is inherited from the enclosing call (the
-- node we are currently analyzing). Explicitly expand
-- the actual, since the previous call to Expand
-- (from Resolve_Call) had no way of knowing about
-- the required dispatching.
-- The tag is inherited from the enclosing call (the node
-- we are currently analyzing). Explicitly expand the
-- actual, since the previous call to Expand (from
-- Resolve_Call) had no way of knowing about the required
-- dispatching.
Propagate_Tag (Control, Actual);
@ -885,8 +884,8 @@ package body Sem_Disp is
if Present (Old_Subp) then
-- If the type has interfaces we complete this check after we
-- set attribute Is_Dispatching_Operation
-- If the type has interfaces we complete this check after we set
-- attribute Is_Dispatching_Operation.
Check_Subtype_Conformant (Subp, Old_Subp);

26
gcc/ada/xsnamest.adb
View File

@ -35,18 +35,24 @@ with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
with Ada.Strings.Maps; use Ada.Strings.Maps;
with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO;
with GNAT.Spitbol; use GNAT.Spitbol;
with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns;
with XUtil; use XUtil;
procedure XSnamesT is
InB : File_Type;
InT : File_Type;
OutS : File_Type;
OutB : File_Type;
InH : File_Type;
OutH : File_Type;
subtype VString is GNAT.Spitbol.VString;
InS : Ada.Text_IO.File_Type;
InB : Ada.Text_IO.File_Type;
InH : Ada.Text_IO.File_Type;
OutS : Ada.Streams.Stream_IO.File_Type;
OutB : Ada.Streams.Stream_IO.File_Type;
OutH : Ada.Streams.Stream_IO.File_Type;
A, B : VString := Nul;
Line : VString := Nul;
@ -131,7 +137,7 @@ procedure XSnamesT is
if Header_Current_Symbol /= S then
declare
Name2 : Vstring;
Name2 : VString;
Pat : constant Pattern := "#define "
& Header_Prefix (S).all
& Break (' ') * Name2;
@ -175,7 +181,7 @@ procedure XSnamesT is
-- Start of processing for XSnames
begin
Open (InT, In_File, "snames.ads-tmpl");
Open (InS, In_File, "snames.ads-tmpl");
Open (InB, In_File, "snames.adb-tmpl");
Open (InH, In_File, "snames.h-tmpl");
@ -194,8 +200,8 @@ begin
Put_Line (OutB, Line);
LoopN : while not End_Of_File (InT) loop
Line := Get_Line (InT);
LoopN : while not End_Of_File (InS) loop
Line := Get_Line (InS);
if not Match (Line, Name_Ref) then
Put_Line (OutS, Line);