+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.
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.
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;
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;
-- --
-- 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- --
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;
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;
-- 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;
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:
-- 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 --
---------------
-- 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.
* *
* 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- *
#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
-- --
------------------------------------------------------------------------------
+with Aspects; use Aspects;
with Atree; use Atree;
with Casing; use Casing;
with Einfo; use Einfo;
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 --
-- 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));
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 --
--------------------------------------
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;
-- 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 --
----------------------------------
-- 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 --
-- 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
-- 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
-- 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
-- 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
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));
-- 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;
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
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 + $;
projects / gcc.git / commitdiff