diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/ChangeLog | 30 | ||||
| -rw-r--r-- | gcc/ada/mlib-tgt-specific-xi.adb | 5 | ||||
| -rw-r--r-- | gcc/ada/seh_init.c | 4 | ||||
| -rwxr-xr-x | gcc/ada/sem_aux.adb | 28 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 31 | ||||
| -rw-r--r-- | gcc/ada/sem_disp.adb | 67 | ||||
| -rw-r--r-- | gcc/ada/xsnamest.adb | 26 |
7 files changed, 121 insertions, 70 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 0e93d6d..0c842dd 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,35 @@ 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 2009-04-10 Thomas Quinot <quinot@adacore.com> diff --git a/gcc/ada/mlib-tgt-specific-xi.adb b/gcc/ada/mlib-tgt-specific-xi.adb index 3a56d83..97e6e53 100644 --- a/gcc/ada/mlib-tgt-specific-xi.adb +++ b/gcc/ada/mlib-tgt-specific-xi.adb @@ -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 diff --git a/gcc/ada/seh_init.c b/gcc/ada/seh_init.c index def5af9..2bc3d23 100644 --- a/gcc/ada/seh_init.c +++ b/gcc/ada/seh_init.c @@ -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) { diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index 94db312..884c2bd 100755 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -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 diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 12abf17..bc6635f 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -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 diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index e7419a8..40778dd 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -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); diff --git a/gcc/ada/xsnamest.adb b/gcc/ada/xsnamest.adb index 77cb965..2d6e8e9 100644 --- a/gcc/ada/xsnamest.adb +++ b/gcc/ada/xsnamest.adb @@ -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); |