diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 48 | ||||
| -rwxr-xr-x | gcc/ada/aspects.ads | 25 | ||||
| -rw-r--r-- | gcc/ada/err_vars.ads | 4 | ||||
| -rw-r--r-- | gcc/ada/errout.ads | 4 | ||||
| -rw-r--r-- | gcc/ada/g-socthi-mingw.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/gnat1drv.adb | 7 | ||||
| -rw-r--r-- | gcc/ada/lib-writ.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/lib-xref.adb | 27 | ||||
| -rw-r--r-- | gcc/ada/mingw32.h | 24 | ||||
| -rw-r--r-- | gcc/ada/restrict.adb | 100 | ||||
| -rw-r--r-- | gcc/ada/restrict.ads | 18 | ||||
| -rw-r--r-- | gcc/ada/s-rident.ads | 12 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 13 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 21 | ||||
| -rw-r--r-- | gcc/ada/snames.ads-tmpl | 1 |
15 files changed, 257 insertions, 61 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 55e38dd851f..f57c46dc9e9 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,53 @@ 2011-09-19 Robert Dewar <dewar@adacore.com> + * err_vars.ads, errout.ads: Minor reformatting. + +2011-09-19 Robert Dewar <dewar@adacore.com> + + * aspects.ads (Impl_Defined_Aspects): New array + * lib-writ.adb (No_Dependences): New name for No_Dependence + * restrict.adb (No_Dependences): New name for No_Dependence + (Check_Restriction_No_Specification_Of_Aspect): New + procedure. + (Set_Restriction_No_Specification_Of_Aspect): New procedure + (Restricted_Profile_Result): New variable + (No_Specification_Of_Aspects): New variable + (No_Specification_Of_Aspect_Warning): New variable + * restrict.ads (No_Dependences): New name for No_Dependence + (Check_Restriction_No_Specification_Of_Aspect): New procedure + (Set_Restriction_No_Specification_Of_Aspect): New procedure + * s-rident.ads: Add restriction + No_Implementation_Aspect_Specifications, this is also added to + the No_Implementation_Extensions profile. + * sem_ch13.adb (Analyze_Aspect_Specifications): Check + No_Implementation_Defined_Aspects + (Analyze_Aspect_Specifications): Check No_Specification_Of_Aspect + * sem_prag.adb (Analyze_Aspect_Specifications): Check + No_Implementation_Aspects + (Analyze_Aspect_Specifications): Check No_Specification_Of_Aspect + * snames.ads-tmpl (Name_No_Specification_Of_Aspect): New name + +2011-09-19 Yannick Moy <moy@adacore.com> + + * lib-xref.adb (Generate_Reference): Take into account multiple + renamings for Alfa refs. + +2011-09-19 Thomas Quinot <quinot@adacore.com> + + * g-socthi-mingw.adb: Minor reformatting. + +2011-09-19 Yannick Moy <moy@adacore.com> + + * gnat1drv.adb (Adjust_Global_Switches): Set tagged type + expansion to False in mode Alfa + +2011-09-19 Pascal Obry <obry@adacore.com> + + * mingw32.h: Remove obsolete code needed for old versions + of MingW. + +2011-09-19 Robert Dewar <dewar@adacore.com> + * errout.ads: Minor reformatting. 2011-09-19 Ed Schonberg <schonberg@adacore.com> diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index fc110d6ba95..dfca9b12af1 100755 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -144,6 +144,31 @@ package Aspects is Aspect_Post => True, others => False); + -- The following array identifies all implementation defined aspects + + Impl_Defined_Aspects : constant array (Aspect_Id) of Boolean := + (Aspect_Object_Size => True, + Aspect_Predicate => True, + Aspect_Test_Case => True, + Aspect_Value_Size => True, + Aspect_Compiler_Unit => True, + Aspect_Preelaborate_05 => True, + Aspect_Pure_05 => True, + Aspect_Universal_Data => True, + Aspect_Ada_2005 => True, + Aspect_Ada_2012 => True, + Aspect_Favor_Top_Level => True, + Aspect_Inline_Always => True, + Aspect_Persistent_BSS => True, + Aspect_Pure_Function => True, + Aspect_Shared => True, + Aspect_Suppress_Debug_Info => True, + Aspect_Universal_Aliasing => True, + Aspect_Unmodified => True, + Aspect_Unreferenced => True, + Aspect_Unreferenced_Objects => True, + others => False); + -- The following array indicates aspects for which multiple occurrences of -- the same aspect attached to the same declaration are allowed. diff --git a/gcc/ada/err_vars.ads b/gcc/ada/err_vars.ads index 10a0262bb62..90f14915761 100644 --- a/gcc/ada/err_vars.ads +++ b/gcc/ada/err_vars.ads @@ -143,7 +143,9 @@ package Err_Vars is Error_Msg_Warn : Boolean; -- Used if current message contains a < insertion character to indicate - -- if the current message is a warning message. + -- if the current message is a warning message. Must be set appropriately + -- before any call to Error_Msg_xxx with a < insertion character present. + -- Setting is irrelevant if no < insertion character is present. Error_Msg_String : String (1 .. 4096); Error_Msg_Strlen : Natural; diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index fd2d616f21d..5c1c92ce6b5 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -451,7 +451,9 @@ package Errout is Error_Msg_Warn : Boolean renames Err_Vars.Error_Msg_Warn; -- Used if current message contains a < insertion character to indicate - -- if the current message is a warning message. ??? who turns this off??? + -- if the current message is a warning message. Must be set appropriately + -- before any call to Error_Msg_xxx with a < insertion character present. + -- Setting is irrelevant if no < insertion character is present. Error_Msg_String : String renames Err_Vars.Error_Msg_String; Error_Msg_Strlen : Natural renames Err_Vars.Error_Msg_Strlen; diff --git a/gcc/ada/g-socthi-mingw.adb b/gcc/ada/g-socthi-mingw.adb index cb72713e9dd..972940221ff 100644 --- a/gcc/ada/g-socthi-mingw.adb +++ b/gcc/ada/g-socthi-mingw.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2010, AdaCore -- +-- Copyright (C) 2001-2011, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -275,8 +275,8 @@ package body GNAT.Sockets.Thin is use type C.size_t; Fill : constant Boolean := - SOSC.MSG_WAITALL /= -1 - and then (C.unsigned (Flags) and SOSC.MSG_WAITALL) /= 0; + SOSC.MSG_WAITALL /= -1 + and then (C.unsigned (Flags) and SOSC.MSG_WAITALL) /= 0; -- Is the MSG_WAITALL flag set? If so we need to fully fill all vectors Res : C.int; diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index b0b90242209..8a8c8050cd5 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -477,12 +477,9 @@ procedure Gnat1drv is Global_Discard_Names := True; - -- We would prefer to suppress the expansion of tagged types and - -- dispatching calls, so that one day GNATprove can handle them - -- directly. Unfortunately, this is causing problems in some cases, - -- so keep this expansion for the time being. To be investigated ??? + -- Suppress the expansion of tagged types and dispatching calls - Tagged_Type_Expansion := True; + Tagged_Type_Expansion := False; end if; end Adjust_Global_Switches; diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index c8129e9ecbd..25c2559e559 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.adb @@ -1161,13 +1161,13 @@ package body Lib.Writ is -- Output R lines for No_Dependence entries - for J in No_Dependence.First .. No_Dependence.Last loop - if In_Extended_Main_Source_Unit (No_Dependence.Table (J).Unit) - and then not No_Dependence.Table (J).Warn + for J in No_Dependences.First .. No_Dependences.Last loop + if In_Extended_Main_Source_Unit (No_Dependences.Table (J).Unit) + and then not No_Dependences.Table (J).Warn then Write_Info_Initiate ('R'); Write_Info_Char (' '); - Write_Unit_Name (No_Dependence.Table (J).Unit); + Write_Unit_Name (No_Dependences.Table (J).Unit); Write_Info_EOL; end if; end loop; diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb index e9de179f0c0..f50406f3d76 100644 --- a/gcc/ada/lib-xref.adb +++ b/gcc/ada/lib-xref.adb @@ -391,6 +391,10 @@ package body Lib.Xref is Kind : Entity_Kind; -- If Formal is non-Empty, then its Ekind, otherwise E_Void + function Get_Through_Renamings (E : Entity_Id) return Entity_Id; + -- Get the enclosing entity through renamings, which may come from + -- source or from the translation of generic instantiations. + function Is_On_LHS (Node : Node_Id) return Boolean; -- Used to check if a node is on the left hand side of an assignment. -- The following cases are handled: @@ -412,6 +416,22 @@ package body Lib.Xref is -- exceptions where we do not want to set this flag, see body for -- details of these exceptional cases. + --------------------------- + -- Get_Through_Renamings -- + --------------------------- + + function Get_Through_Renamings (E : Entity_Id) return Entity_Id is + Result : Entity_Id := E; + begin + while Present (Result) + and then Is_Object (Result) + and then Present (Renamed_Object (Result)) + loop + Result := Get_Enclosing_Object (Renamed_Object (Result)); + end loop; + return Result; + end Get_Through_Renamings; + --------------- -- Is_On_LHS -- --------------- @@ -955,11 +975,8 @@ package body Lib.Xref is -- the renaming, which is needed to compute a valid set of effects -- (reads, writes) for the enclosing subprogram. - if Alfa_Mode - and then Is_Object (Ent) - and then Present (Renamed_Object (Ent)) - then - Ent := Get_Enclosing_Object (Renamed_Object (Ent)); + if Alfa_Mode then + Ent := Get_Through_Renamings (Ent); -- If no enclosing object, then it could be a reference to any -- location not tracked individually, like heap-allocated data. diff --git a/gcc/ada/mingw32.h b/gcc/ada/mingw32.h index bee45852e11..67bfd2cccfe 100644 --- a/gcc/ada/mingw32.h +++ b/gcc/ada/mingw32.h @@ -6,7 +6,7 @@ * * * C Header File * * * - * Copyright (C) 2002-2009, Free Software Foundation, Inc. * + * Copyright (C) 2002-2011, Free Software Foundation, Inc. * * * * GNAT is free software; you can redistribute it and/or modify it under * * terms of the GNU General Public License as published by the Free Soft- * @@ -38,28 +38,8 @@ #include <_mingw.h> -/* The unicode support is activated by default starting with the 3.9 MingW - version. It is not possible to use it with previous version due to a bug - in the MingW runtime. */ - -#if (((__MINGW32_MAJOR_VERSION == 3 \ - && __MINGW32_MINOR_VERSION >= 9) \ - || (__MINGW32_MAJOR_VERSION >= 4) \ - || defined (__MINGW64)) \ - && !defined (RTX)) +#ifndef RTX #define GNAT_UNICODE_SUPPORT - -#else - -/* Older MingW versions have no definition for _tfreopen, add it here to have a - proper build without unicode support. */ -#ifndef _tfreopen -#define _tfreopen freopen -#endif - -#endif - -#ifdef GNAT_UNICODE_SUPPORT #define _UNICODE /* For C runtime */ #define UNICODE /* For Win32 API */ #endif diff --git a/gcc/ada/restrict.adb b/gcc/ada/restrict.adb index 1bfe1568d71..813568deea6 100644 --- a/gcc/ada/restrict.adb +++ b/gcc/ada/restrict.adb @@ -23,6 +23,7 @@ -- -- ------------------------------------------------------------------------------ +with Aspects; use Aspects; with Atree; use Atree; with Casing; use Casing; with Einfo; use Einfo; @@ -41,14 +42,28 @@ with Uname; use Uname; package body Restrict is Restricted_Profile_Result : Boolean := False; - -- This switch memoizes the result of Restricted_Profile function - -- calls for improved efficiency. Its setting is valid only if - -- Restricted_Profile_Cached is True. Note that if this switch - -- is ever set True, it need never be turned off again. + -- This switch memoizes the result of Restricted_Profile function calls for + -- improved efficiency. Valid only if Restricted_Profile_Cached is True. + -- Note: if this switch is ever set True, it is never turned off again. Restricted_Profile_Cached : Boolean := False; - -- This flag is set to True if the Restricted_Profile_Result - -- contains the correct cached result of Restricted_Profile calls. + -- This flag is set to True if the Restricted_Profile_Result contains the + -- correct cached result of Restricted_Profile calls. + + No_Specification_Of_Aspects : array (Aspect_Id) of Source_Ptr := + (others => No_Location); + -- Entries in this array are set to point to a previously occuring pragma + -- that activates a No_Specification_Of_Aspect check. + + No_Specification_Of_Aspect_Warning : array (Aspect_Id) of Boolean := + (others => True); + -- An entry in this array is set False in reponse to a previous call to + -- Set_No_Speficiation_Of_Aspect for pragmas in the main unit that + -- specify Warning as False. Once set False, an entry is never reset. + + No_Specification_Of_Aspect_Set : Boolean := False; + -- Set True if any entry of No_Specifcation_Of_Aspects has been set True. + -- Once set True, this is never turned off again. ----------------------- -- Local Subprograms -- @@ -461,14 +476,14 @@ package body Restrict is -- Loop through entries in No_Dependence table to check each one in turn - for J in No_Dependence.First .. No_Dependence.Last loop - DU := No_Dependence.Table (J).Unit; + for J in No_Dependences.First .. No_Dependences.Last loop + DU := No_Dependences.Table (J).Unit; if Same_Unit (U, DU) then Error_Msg_Sloc := Sloc (DU); Error_Msg_Node_1 := DU; - if No_Dependence.Table (J).Warn then + if No_Dependences.Table (J).Warn then Error_Msg ("?violation of restriction `No_Dependence '='> &`#", Sloc (Err)); @@ -483,6 +498,44 @@ package body Restrict is end loop; end Check_Restriction_No_Dependence; + -------------------------------------------------- + -- Check_Restriction_No_Specification_Of_Aspect -- + -------------------------------------------------- + + procedure Check_Restriction_No_Specification_Of_Aspect (N : Node_Id) is + A_Id : Aspect_Id; + Id : Node_Id; + + begin + -- Ignore call if no instances of this restriction set + + if not No_Specification_Of_Aspect_Set then + return; + end if; + + -- Ignore call if node N is not in the main source unit, since we only + -- give messages for . This avoids giving messages for aspects that are + -- specified in withed units. + + if not In_Extended_Main_Source_Unit (N) then + return; + end if; + + Id := Identifier (N); + A_Id := Get_Aspect_Id (Chars (Id)); + pragma Assert (A_Id /= No_Aspect); + + Error_Msg_Sloc := No_Specification_Of_Aspects (A_Id); + + if Error_Msg_Sloc /= No_Location then + Error_Msg_Node_1 := Id; + Error_Msg_Warn := No_Specification_Of_Aspect_Warning (A_Id); + Error_Msg_N + ("<violation of restriction `No_Specification_Of_Aspect '='> &`#", + Id); + end if; + end Check_Restriction_No_Specification_Of_Aspect; + -------------------------------------- -- Check_Wide_Character_Restriction -- -------------------------------------- @@ -1059,16 +1112,16 @@ package body Restrict is begin -- Loop to check for duplicate entry - for J in No_Dependence.First .. No_Dependence.Last loop + for J in No_Dependences.First .. No_Dependences.Last loop -- Case of entry already in table - if Same_Unit (Unit, No_Dependence.Table (J).Unit) then + if Same_Unit (Unit, No_Dependences.Table (J).Unit) then -- Error has precedence over warning if not Warn then - No_Dependence.Table (J).Warn := False; + No_Dependences.Table (J).Warn := False; end if; return; @@ -1077,9 +1130,30 @@ package body Restrict is -- Entry is not currently in table - No_Dependence.Append ((Unit, Warn, Profile)); + No_Dependences.Append ((Unit, Warn, Profile)); end Set_Restriction_No_Dependence; + ------------------------------------------------ + -- Set_Restriction_No_Specification_Of_Aspect -- + ------------------------------------------------ + + procedure Set_Restriction_No_Specification_Of_Aspect + (N : Node_Id; + Warning : Boolean) + is + A_Id : constant Aspect_Id := Get_Aspect_Id (Chars (N)); + pragma Assert (A_Id /= No_Aspect); + + begin + No_Specification_Of_Aspects (A_Id) := Sloc (N); + + if Warning = False then + No_Specification_Of_Aspect_Warning (A_Id) := False; + end if; + + No_Specification_Of_Aspect_Set := True; + end Set_Restriction_No_Specification_Of_Aspect; + ---------------------------------- -- Suppress_Restriction_Message -- ---------------------------------- diff --git a/gcc/ada/restrict.ads b/gcc/ada/restrict.ads index a9b0c068e3b..10875025e2b 100644 --- a/gcc/ada/restrict.ads +++ b/gcc/ada/restrict.ads @@ -166,13 +166,13 @@ package Restrict is -- No_Profile if a pragma Restriction set the No_Dependence entry. end record; - package No_Dependence is new Table.Table ( + package No_Dependences is new Table.Table ( Table_Component_Type => ND_Entry, Table_Index_Type => Int, Table_Low_Bound => 0, Table_Initial => 200, Table_Increment => 200, - Table_Name => "Name_No_Dependence"); + Table_Name => "Name_No_Dependences"); ------------------------------- -- SPARK Restriction Control -- @@ -255,6 +255,11 @@ package Restrict is -- an explicit WITH clause). U is a node for the unit involved, and Err is -- the node to which an error will be attached if necessary. + procedure Check_Restriction_No_Specification_Of_Aspect (N : Node_Id); + -- N is the node id for an N_Aspect_Specification. An error message + -- (warning) will be issued if a restriction (warning) was previous set + -- for this aspect using Set_No_Specification_Of_Aspect. + procedure Check_Elaboration_Code_Allowed (N : Node_Id); -- Tests to see if elaboration code is allowed by the current restrictions -- settings. This function is called by Gigi when it needs to define an @@ -409,6 +414,15 @@ package Restrict is -- this flag is not set. Profile is set to a non-default value if the -- No_Dependence restriction comes from a Profile pragma. + procedure Set_Restriction_No_Specification_Of_Aspect + (N : Node_Id; + Warning : Boolean); + -- N is the node id for an identifier from a pragma Restrictions for the + -- No_Specification_Of_Aspect pragma. An error message will be issued if + -- the identifier is not a valid aspect name. Warning is set True for the + -- case of a Restriction_Warnings pragma specifying this restriction and + -- False for a Restrictions pragma specifying this restriction. + function Tasking_Allowed return Boolean; pragma Inline (Tasking_Allowed); -- Tests if tasking operations are allowed by the current restrictions diff --git a/gcc/ada/s-rident.ads b/gcc/ada/s-rident.ads index dca27fe9c61..dd9ef16b22c 100644 --- a/gcc/ada/s-rident.ads +++ b/gcc/ada/s-rident.ads @@ -125,6 +125,7 @@ package System.Rident is -- The following cases do not require consistency checking Immediate_Reclamation, -- (RM H.4(10)) + No_Implementation_Aspect_Specifications, -- Ada 2012 AI-241 No_Implementation_Attributes, -- Ada 2005 AI-257 No_Implementation_Identifiers, -- Ada 2012 AI-246 No_Implementation_Pragmas, -- Ada 2005 AI-257 @@ -349,11 +350,12 @@ package System.Rident is -- Restrictions for Restricted profile (Set => - (No_Implementation_Attributes => True, - No_Implementation_Identifiers => True, - No_Implementation_Pragmas => True, - No_Implementation_Units => True, - others => False), + (No_Implementation_Aspect_Specifications => True, + No_Implementation_Attributes => True, + No_Implementation_Identifiers => True, + No_Implementation_Pragmas => True, + No_Implementation_Units => True, + others => False), -- Value settings for Restricted profile (none diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index f5b52d04e0d..0895eb68652 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -804,6 +804,19 @@ package body Sem_Ch13 is goto Continue; end if; + -- Check restriction No_Implementation_Aspect_Specifications + + if Impl_Defined_Aspects (A_Id) then + Check_Restriction + (No_Implementation_Aspect_Specifications, Aspect); + end if; + + -- Check restriction No_Specification_Of_Aspect + + Check_Restriction_No_Specification_Of_Aspect (Aspect); + + -- Analyze this aspect + Set_Analyzed (Aspect); Set_Entity (Aspect, E); Ent := New_Occurrence_Of (E, Sloc (Id)); diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index e3db8077f68..74d889e283a 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -29,6 +29,7 @@ -- to complete the syntax checks. Certain pragmas are handled partially or -- completely by the parser (see Par.Prag for further details). +with Aspects; use Aspects; with Atree; use Atree; with Casing; use Casing; with Checks; use Checks; @@ -5314,6 +5315,26 @@ package body Sem_Prag is elsif Id = Name_No_Dependence then Check_Unit_Name (Expr); + -- Case of No_Specification_Of_Aspect => Identifier. + + elsif Id = Name_No_Specification_Of_Aspect then + declare + A_Id : Aspect_Id; + + begin + if Nkind (Expr) /= N_Identifier then + A_Id := No_Aspect; + else + A_Id := Get_Aspect_Id (Chars (Expr)); + end if; + + if A_Id = No_Aspect then + Error_Pragma_Arg ("invalid restriction name", Arg); + else + Set_Restriction_No_Specification_Of_Aspect (Expr, Warn); + end if; + end; + -- All other cases of restriction identifier present else diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 332a7902ff2..a68e5e85112 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -663,6 +663,7 @@ package Snames is Name_No_Implementation_Extensions : constant Name_Id := N + $; Name_No_Requeue : constant Name_Id := N + $; Name_No_Requeue_Statements : constant Name_Id := N + $; + Name_No_Specification_Of_Aspect : constant Name_Id := N + $; Name_No_Task_Attributes : constant Name_Id := N + $; Name_No_Task_Attributes_Package : constant Name_Id := N + $; Name_Nominal : constant Name_Id := N + $; |