From e7fceebce65739f184ad8e090d0fac712336df34 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 19 Sep 2011 10:31:55 +0200 Subject: [PATCH] [multiple changes] 2011-09-19 Robert Dewar * err_vars.ads, errout.ads: Minor reformatting. 2011-09-19 Robert Dewar * 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 * lib-xref.adb (Generate_Reference): Take into account multiple renamings for Alfa refs. 2011-09-19 Thomas Quinot * g-socthi-mingw.adb: Minor reformatting. 2011-09-19 Yannick Moy * gnat1drv.adb (Adjust_Global_Switches): Set tagged type expansion to False in mode Alfa 2011-09-19 Pascal Obry * mingw32.h: Remove obsolete code needed for old versions of MingW. From-SVN: r178959 --- gcc/ada/ChangeLog | 48 ++++++++++++++++++ gcc/ada/aspects.ads | 25 ++++++++++ gcc/ada/err_vars.ads | 4 +- gcc/ada/errout.ads | 4 +- gcc/ada/g-socthi-mingw.adb | 6 +-- gcc/ada/gnat1drv.adb | 7 +-- gcc/ada/lib-writ.adb | 8 +-- gcc/ada/lib-xref.adb | 27 ++++++++-- gcc/ada/mingw32.h | 24 +-------- gcc/ada/restrict.adb | 100 ++++++++++++++++++++++++++++++++----- gcc/ada/restrict.ads | 18 ++++++- gcc/ada/s-rident.ads | 12 +++-- gcc/ada/sem_ch13.adb | 13 +++++ gcc/ada/sem_prag.adb | 21 ++++++++ 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,3 +1,51 @@ +2011-09-19 Robert Dewar + + * err_vars.ads, errout.ads: Minor reformatting. + +2011-09-19 Robert Dewar + + * 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 + + * lib-xref.adb (Generate_Reference): Take into account multiple + renamings for Alfa refs. + +2011-09-19 Thomas Quinot + + * g-socthi-mingw.adb: Minor reformatting. + +2011-09-19 Yannick Moy + + * gnat1drv.adb (Adjust_Global_Switches): Set tagged type + expansion to False in mode Alfa + +2011-09-19 Pascal Obry + + * mingw32.h: Remove obsolete code needed for old versions + of MingW. + 2011-09-19 Robert Dewar * errout.ads: Minor reformatting. 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 + ("