Skip to content

R
riscv-gcc-1
Commit 12b4d338 by Arnaud Charlet
Options

[multiple changes] 

2011-10-24  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch12.adb (Earlier): make available globally. If both
	nodes have the same sloc, the freeze node that does not come
	from source is the later one.
	(True_Parent): Make available globally.
	(Previous_Instance): Subsidiary of
	Insert_Freeze_Node_For_Instance, to check whether the generic
	parent of the current instance is declared within a previous
	instance in the same unit or declarative  part, in which case the
	freeze nodes of both instances must appear in order to prevent
	elaboration problems in gigi.
	* sem_ch12.adb (Insert_Freeze_Node_For_Instance): A stub is a
	freeze point, and the freeze node of a preceding instantiation
	must be inserted before it.

2011-10-24  Robert Dewar  <dewar@adacore.com>

	* checks.ads, checks.adb: Add handling of Synchronization_Check
	* debug.adb: Add doc for -gnatd.d and -gnatd.e (disable/enable
	atomic sync).
	* exp_ch2.adb (Expand_Entity_Reference): Set Atomic_Sync_Required
	flag Minor code reorganization.
	* opt.ads (Warn_On_Atomic_Synchronization): New switch.
	* par-prag.adb: Add dummy entries for pragma
	Disable/Enable_Atomic_Synchronization.
	* sem_prag.adb (Process_Suppress_Unsuppress): Handle
	case of Atomic_Synchronization specially (not suppressed
	by All_Checks, cannot be set from Source).
	(Pragma Disable/Enable_Atomic_Synchronization): Add processing.
	* sinfo.ads, sinfo.adb: Add Atomic_Sync_Required flag
	* snames.ads-tmpl: Add entry for Atomic_Synchronization Add
	entry for pragma Disable/Enable_Atomic_Synchronization
	* switch-c.adb: The -gnatp switch does not disable
	Atomic_Synchronization Add -gnatep switch to disable
	Atomic_Synchronization.
	* types.ads: Add entry for Synchronization_Check
	* usage.adb: Add line for -gnated switch
	* warnsw.adb: Settings for Warn_On_Atomic_Synchronization

From-SVN: r180373
parent 08ce7bb8
Showing with 466 additions and 139 deletions
gcc/ada/ChangeLog
2011-10-24 Ed Schonberg <schonberg@adacore.com>
* sem_ch12.adb (Earlier): make available globally. If both
nodes have the same sloc, the freeze node that does not come
from source is the later one.
(True_Parent): Make available globally.
(Previous_Instance): Subsidiary of
Insert_Freeze_Node_For_Instance, to check whether the generic
parent of the current instance is declared within a previous
instance in the same unit or declarative part, in which case the
freeze nodes of both instances must appear in order to prevent
elaboration problems in gigi.
* sem_ch12.adb (Insert_Freeze_Node_For_Instance): A stub is a
freeze point, and the freeze node of a preceding instantiation
must be inserted before it.
2011-10-24 Robert Dewar <dewar@adacore.com>
* checks.ads, checks.adb: Add handling of Synchronization_Check
* debug.adb: Add doc for -gnatd.d and -gnatd.e (disable/enable
atomic sync).
* exp_ch2.adb (Expand_Entity_Reference): Set Atomic_Sync_Required
flag Minor code reorganization.
* opt.ads (Warn_On_Atomic_Synchronization): New switch.
* par-prag.adb: Add dummy entries for pragma
Disable/Enable_Atomic_Synchronization.
* sem_prag.adb (Process_Suppress_Unsuppress): Handle
case of Atomic_Synchronization specially (not suppressed
by All_Checks, cannot be set from Source).
(Pragma Disable/Enable_Atomic_Synchronization): Add processing.
* sinfo.ads, sinfo.adb: Add Atomic_Sync_Required flag
* snames.ads-tmpl: Add entry for Atomic_Synchronization Add
entry for pragma Disable/Enable_Atomic_Synchronization
* switch-c.adb: The -gnatp switch does not disable
Atomic_Synchronization Add -gnatep switch to disable
Atomic_Synchronization.
* types.ads: Add entry for Synchronization_Check
* usage.adb: Add line for -gnated switch
* warnsw.adb: Settings for Warn_On_Atomic_Synchronization
2011-10-24 Geert Bosch <bosch@adacore.com>
* s-gearop.adb (Back_Substitute): Avoid overflow if matrix
......
gcc/ada/checks.adb
......@@ -2555,6 +2555,23 @@ package body Checks is
end if;
end Apply_Universal_Integer_Attribute_Checks;
-------------------------------------
-- Atomic_Synchronization_Disabled --
-------------------------------------
-- Note: internally Disable/Enable_Atomic_Synchronization is implemented
-- using a bogus check called Atomic_Synchronization. This is to make it
-- more convenient to get exactly the same semantics as [Un]Suppress.
function Atomic_Synchronization_Disabled (E : Entity_Id) return Boolean is
begin
if Present (E) and then Checks_May_Be_Suppressed (E) then
return Is_Check_Suppressed (E, Atomic_Synchronization);
else
return Scope_Suppress (Atomic_Synchronization);
end if;
end Atomic_Synchronization_Disabled;
-------------------------------
-- Build_Discriminant_Checks --
-------------------------------
......
gcc/ada/checks.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
-- Copyright (C) 1992-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- --
......@@ -49,6 +49,7 @@ package Checks is
function Access_Checks_Suppressed (E : Entity_Id) return Boolean;
function Accessibility_Checks_Suppressed (E : Entity_Id) return Boolean;
function Alignment_Checks_Suppressed (E : Entity_Id) return Boolean;
function Atomic_Synchronization_Disabled (E : Entity_Id) return Boolean;
function Discriminant_Checks_Suppressed (E : Entity_Id) return Boolean;
function Division_Checks_Suppressed (E : Entity_Id) return Boolean;
function Elaboration_Checks_Suppressed (E : Entity_Id) return Boolean;
......
gcc/ada/debug.adb
......@@ -94,8 +94,8 @@ package body Debug is
-- d.a Force Target_Strict_Alignment mode to True
-- d.b Dump backend types
-- d.c Generate inline concatenation, do not call procedure
-- d.d
-- d.e
-- d.d Disable atomic synchronization
-- d.e Enable atomic synchronization
-- d.f Inhibit folding of static expressions
-- d.g Enable conversion of raise into goto
-- d.h
......@@ -513,6 +513,13 @@ package body Debug is
-- System.Concat_n.Str_Concat_n routines in cases where the latter
-- routines would normally be called.
-- d.d Disable atomic synchronization for all atomic variable references.
-- Pragma Enable_Atomic_Synchronization is ignored.
-- d.e Enable atomic synchronization for all atomic variable references.
-- Pragma Disable_Atomic_Synchronization is ignored, and also the
-- compiler switch -gnated is ignored.
-- d.f Suppress folding of static expressions. This of course results
-- in seriously non-conforming behavior, but is useful sometimes
-- when tracking down handling of complex expressions.
......
gcc/ada/exp_ch2.adb
......@@ -24,6 +24,7 @@
------------------------------------------------------------------------------
with Atree; use Atree;
with Checks; use Checks;
with Debug; use Debug;
with Einfo; use Einfo;
with Elists; use Elists;
......@@ -354,9 +355,9 @@ package body Exp_Ch2 is
elsif Is_Protected_Component (E) then
if No_Run_Time_Mode then
return;
end if;
else
Expand_Protected_Component (N);
end if;
elsif Ekind (E) = E_Entry_Index_Parameter then
Expand_Entry_Index_Parameter (N);
......@@ -398,6 +399,52 @@ package body Exp_Ch2 is
Write_Eol;
end if;
-- Set Atomic_Sync_Required if necessary for atomic variable
if Is_Atomic (E) then
declare
Set : Boolean;
MLoc : Node_Id;
begin
-- Always set if debug flag d.e is set
if Debug_Flag_Dot_E then
Set := True;
-- Never set if debug flag d.d is set
elsif Debug_Flag_Dot_D then
Set := False;
-- Otherwise setting comes from Atomic_Synchronization state
else
Set := not Atomic_Synchronization_Disabled (E);
end if;
-- Set flag if required
if Set then
-- Generate info message if requested
if Warn_On_Atomic_Synchronization then
if Nkind (N) = N_Identifier then
MLoc := N;
else
MLoc := Selector_Name (N);
end if;
Error_Msg_N
("?info: atomic synchronization set for &", MLoc);
end if;
Set_Atomic_Sync_Required (N);
end if;
end;
end if;
-- Interpret possible Current_Value for variable case
if Is_Assignable (E)
......
gcc/ada/opt.ads
......@@ -1448,6 +1448,11 @@ package Opt is
-- with literals or S'Length, presumably assuming a lower bound of one. Set
-- False by -gnatwW.
Warn_On_Atomic_Synchronization : Boolean := False;
-- GNAT
-- Set to True to generate information messages for atomic synchronization.
-- Set True by use of -gnatw.n.
Warn_On_Bad_Fixed_Value : Boolean := False;
-- GNAT
-- Set to True to generate warnings for static fixed-point expression
......
gcc/ada/par-prag.adb
......@@ -61,8 +61,8 @@ function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is
-- that is the only case in which a non-present argument can be referenced.
procedure Check_Arg_Count (Required : Int);
-- Check argument count for pragma = Required.
-- If not give error and raise Error_Resync.
-- Check argument count for pragma = Required. If not give error and raise
-- Error_Resync.
procedure Check_Arg_Is_String_Literal (Arg : Node_Id);
-- Check the expression of the specified argument to make sure that it
......@@ -1127,6 +1127,7 @@ begin
Pragma_Detect_Blocking |
Pragma_Default_Storage_Pool |
Pragma_Dimension |
Pragma_Disable_Atomic_Synchronization |
Pragma_Discard_Names |
Pragma_Dispatching_Domain |
Pragma_Eliminate |
......@@ -1134,6 +1135,7 @@ begin
Pragma_Elaborate_All |
Pragma_Elaborate_Body |
Pragma_Elaboration_Checks |
Pragma_Enable_Atomic_Synchronization |
Pragma_Export |
Pragma_Export_Exception |
Pragma_Export_Function |
......
gcc/ada/sem_ch12.adb
......@@ -451,6 +451,12 @@ package body Sem_Ch12 is
-- an instantiation in the source, or the internal instantiation that
-- corresponds to the actual for a formal package.
function Earlier (N1, N2 : Node_Id) return Boolean;
-- Yields True if N1 and N2 appear in the same compilation unit,
-- ignoring subunits, and if N1 is to the left of N2 in a left-to-right
-- traversal of the tree for the unit. Used to determine the placement
-- of freeze nodes for instance bodies that may depend on other instances.
function Find_Actual_Type
(Typ : Entity_Id;
Gen_Type : Entity_Id) return Entity_Id;
......@@ -473,9 +479,11 @@ package body Sem_Ch12 is
Inst : Node_Id) return Boolean;
-- True if the instantiation Inst and the given freeze_node F_Node appear
-- within the same declarative part, ignoring subunits, but with no inter-
-- vening subprograms or concurrent units. If true, the freeze node
-- of the instance can be placed after the freeze node of the parent,
-- which it itself an instance.
-- vening subprograms or concurrent units. Used to find the proper plave
-- for the freeze node of an instance, when the generic is declared in a
-- previous instance. If predicate is true, the freeze node of the instance
-- can be placed after the freeze node of the previous instance, Otherwise
-- it has to be placed at the end of the current declarative part.
function In_Main_Context (E : Entity_Id) return Boolean;
-- Check whether an instantiation is in the context of the main unit.
......@@ -729,6 +737,9 @@ package body Sem_Ch12 is
-- before installing parents of generics, that are not visible for the
-- actuals themselves.
function True_Parent (N : Node_Id) return Node_Id;
-- For a subunit, return parent of corresponding stub
procedure Valid_Default_Attribute (Nam : Entity_Id; Def : Node_Id);
-- Verify that an attribute that appears as the default for a formal
-- subprogram is a function or procedure with the correct profile.
......@@ -6762,90 +6773,6 @@ package body Sem_Ch12 is
Expander_Mode_Restore;
end End_Generic;
----------------------
-- Find_Actual_Type --
----------------------
function Find_Actual_Type
(Typ : Entity_Id;
Gen_Type : Entity_Id) return Entity_Id
is
Gen_Scope : constant Entity_Id := Scope (Gen_Type);
T : Entity_Id;
begin
-- Special processing only applies to child units
if not Is_Child_Unit (Gen_Scope) then
return Get_Instance_Of (Typ);
-- If designated or component type is itself a formal of the child unit,
-- its instance is available.
elsif Scope (Typ) = Gen_Scope then
return Get_Instance_Of (Typ);
-- If the array or access type is not declared in the parent unit,
-- no special processing needed.
elsif not Is_Generic_Type (Typ)
and then Scope (Gen_Scope) /= Scope (Typ)
then
return Get_Instance_Of (Typ);
-- Otherwise, retrieve designated or component type by visibility
else
T := Current_Entity (Typ);
while Present (T) loop
if In_Open_Scopes (Scope (T)) then
return T;
elsif Is_Generic_Actual_Type (T) then
return T;
end if;
T := Homonym (T);
end loop;
return Typ;
end if;
end Find_Actual_Type;
----------------------------
-- Freeze_Subprogram_Body --
----------------------------
procedure Freeze_Subprogram_Body
(Inst_Node : Node_Id;
Gen_Body : Node_Id;
Pack_Id : Entity_Id)
is
Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node);
Par : constant Entity_Id := Scope (Gen_Unit);
E_G_Id : Entity_Id;
Enc_G : Entity_Id;
Enc_I : Node_Id;
F_Node : Node_Id;
function Earlier (N1, N2 : Node_Id) return Boolean;
-- Yields True if N1 and N2 appear in the same compilation unit,
-- ignoring subunits, and if N1 is to the left of N2 in a left-to-right
-- traversal of the tree for the unit.
function Enclosing_Body (N : Node_Id) return Node_Id;
-- Find innermost package body that encloses the given node, and which
-- is not a compilation unit. Freeze nodes for the instance, or for its
-- enclosing body, may be inserted after the enclosing_body of the
-- generic unit.
function Package_Freeze_Node (B : Node_Id) return Node_Id;
-- Find entity for given package body, and locate or create a freeze
-- node for it.
function True_Parent (N : Node_Id) return Node_Id;
-- For a subunit, return parent of corresponding stub
-------------
-- Earlier --
-------------
......@@ -6924,10 +6851,101 @@ package body Sem_Ch12 is
end if;
end loop;
return
Top_Level_Location (Sloc (P1)) < Top_Level_Location (Sloc (P2));
-- If the sloc positions are different the result is unambiguous. If
-- the slocs are identical, one of them must not come from source, which
-- is the case for freeze nodes, whose sloc is unrelated to the point
-- point at which they are inserted in the tree. The source node is the
-- earlier one in the tree.
if Top_Level_Location (Sloc (P1)) < Top_Level_Location (Sloc (P2)) then
return True;
elsif
Top_Level_Location (Sloc (P1)) > Top_Level_Location (Sloc (P2))
then
return False;
else
return Comes_From_Source (P1);
end if;
end Earlier;
----------------------
-- Find_Actual_Type --
----------------------
function Find_Actual_Type
(Typ : Entity_Id;
Gen_Type : Entity_Id) return Entity_Id
is
Gen_Scope : constant Entity_Id := Scope (Gen_Type);
T : Entity_Id;
begin
-- Special processing only applies to child units
if not Is_Child_Unit (Gen_Scope) then
return Get_Instance_Of (Typ);
-- If designated or component type is itself a formal of the child unit,
-- its instance is available.
elsif Scope (Typ) = Gen_Scope then
return Get_Instance_Of (Typ);
-- If the array or access type is not declared in the parent unit,
-- no special processing needed.
elsif not Is_Generic_Type (Typ)
and then Scope (Gen_Scope) /= Scope (Typ)
then
return Get_Instance_Of (Typ);
-- Otherwise, retrieve designated or component type by visibility
else
T := Current_Entity (Typ);
while Present (T) loop
if In_Open_Scopes (Scope (T)) then
return T;
elsif Is_Generic_Actual_Type (T) then
return T;
end if;
T := Homonym (T);
end loop;
return Typ;
end if;
end Find_Actual_Type;
----------------------------
-- Freeze_Subprogram_Body --
----------------------------
procedure Freeze_Subprogram_Body
(Inst_Node : Node_Id;
Gen_Body : Node_Id;
Pack_Id : Entity_Id)
is
Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node);
Par : constant Entity_Id := Scope (Gen_Unit);
E_G_Id : Entity_Id;
Enc_G : Entity_Id;
Enc_I : Node_Id;
F_Node : Node_Id;
function Enclosing_Body (N : Node_Id) return Node_Id;
-- Find innermost package body that encloses the given node, and which
-- is not a compilation unit. Freeze nodes for the instance, or for its
-- enclosing body, may be inserted after the enclosing_body of the
-- generic unit.
function Package_Freeze_Node (B : Node_Id) return Node_Id;
-- Find entity for given package body, and locate or create a freeze
-- node for it.
--------------------
-- Enclosing_Body --
--------------------
......@@ -6973,19 +6991,6 @@ package body Sem_Ch12 is
return Freeze_Node (Id);
end Package_Freeze_Node;
-----------------
-- True_Parent --
-----------------
function True_Parent (N : Node_Id) return Node_Id is
begin
if Nkind (Parent (N)) = N_Subunit then
return Parent (Corresponding_Stub (Parent (N)));
else
return Parent (N);
end if;
end True_Parent;
-- Start of processing of Freeze_Subprogram_Body
begin
......@@ -7336,6 +7341,7 @@ package body Sem_Ch12 is
elsif Nkind_In (Nod, N_Subprogram_Body,
N_Package_Body,
N_Package_Declaration,
N_Task_Body,
N_Protected_Body,
N_Block_Statement)
......@@ -7478,12 +7484,58 @@ package body Sem_Ch12 is
Decls : List_Id;
Par_N : Node_Id;
function Previous_Instance (Gen : Entity_Id) return Entity_Id;
-- Find the local instance, if any, that declares the generic that is
-- being instantiated. If present, the freeze node for this instance
-- must follow the freeze node for the previous instance.
-----------------------
-- Previous_Instance --
-----------------------
function Previous_Instance (Gen : Entity_Id) return Entity_Id is
S : Entity_Id;
begin
S := Scope (Gen);
while Present (S)
and then S /= Standard_Standard
loop
if Is_Generic_Instance (S)
and then In_Same_Source_Unit (S, N)
then
return S;
end if;
S := Scope (S);
end loop;
return Empty;
end Previous_Instance;
begin
if not Is_List_Member (F_Node) then
Decls := List_Containing (N);
Par_N := Parent (Decls);
Decl := N;
-- If this is a package instance, check whether the generic is
-- declared in a previous instance.
if Present (Generic_Parent (Parent (Inst)))
and then Is_In_Main_Unit (N)
then
declare
Par_I : constant Entity_Id :=
Previous_Instance (Generic_Parent (Parent (Inst)));
begin
if Present (Par_I)
and then Earlier (N, Freeze_Node (Par_I))
then
Insert_After (Freeze_Node (Par_I), F_Node);
return;
end if;
end;
end if;
-- When the instantiation occurs in a package declaration, append the
-- freeze node to the private declarations (if any).
......@@ -7500,9 +7552,9 @@ package body Sem_Ch12 is
-- adhere to the general rule of a package or subprogram body causing
-- freezing of anything before it in the same declarative region. In
-- this case, the proper freeze point of a package instantiation is
-- before the first source body which follows. This ensures that
-- entities coming from the instance are already frozen and usable
-- in source bodies.
-- before the first source body which follows, or before a stub.
-- This ensures that entities coming from the instance are already
-- frozen and usable in source bodies.
if Nkind (Par_N) /= N_Package_Declaration
and then Ekind (Inst) = E_Package
......@@ -7511,7 +7563,9 @@ package body Sem_Ch12 is
not In_Same_Source_Unit (Generic_Parent (Parent (Inst)), Inst)
then
while Present (Decl) loop
if Nkind_In (Decl, N_Package_Body, N_Subprogram_Body)
if (Nkind (Decl) in N_Unit_Body
or else
Nkind (Decl) in N_Body_Stub)
and then Comes_From_Source (Decl)
then
Insert_Before (Decl, F_Node);
......@@ -7525,6 +7579,7 @@ package body Sem_Ch12 is
-- In a package declaration, or if no previous body, insert at end
-- of list.
Set_Sloc (F_Node, Sloc (Last (Decls)));
Insert_After (Last (Decls), F_Node);
end if;
end Insert_Freeze_Node_For_Instance;
......@@ -13177,6 +13232,19 @@ package body Sem_Ch12 is
end loop;
end Switch_View;
-----------------
-- True_Parent --
-----------------
function True_Parent (N : Node_Id) return Node_Id is
begin
if Nkind (Parent (N)) = N_Subunit then
return Parent (Corresponding_Stub (Parent (N)));
else
return Parent (N);
end if;
end True_Parent;
-----------------------------
-- Valid_Default_Attribute --
-----------------------------
......
gcc/ada/sem_prag.adb
......@@ -750,6 +750,10 @@ package body Sem_Prag is
-- convention value in the specified entity or entities. On return
-- C is the convention, Ent is the referenced entity.
procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id);
-- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
-- Name_Suppress for Disable and Name_Unsuppress for Enable.
procedure Process_Extended_Import_Export_Exception_Pragma
(Arg_Internal : Node_Id;
Arg_External : Node_Id;
......@@ -3566,6 +3570,35 @@ package body Sem_Prag is
end if;
end Process_Convention;
----------------------------------------
-- Process_Disable_Enable_Atomic_Sync --
----------------------------------------
procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id) is
begin
GNAT_Pragma;
Check_No_Identifiers;
Check_At_Most_N_Arguments (1);
-- Modeled internally as
-- pragma Unsuppress (Atomic_Synchronization [,Entity])
Rewrite (N,
Make_Pragma (Loc,
Pragma_Identifier =>
Make_Identifier (Loc, Nam),
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression =>
Make_Identifier (Loc, Name_Atomic_Synchronization)))));
if Present (Arg1) then
Append_To (Pragma_Argument_Associations (N), New_Copy (Arg1));
end if;
Analyze (N);
end Process_Disable_Enable_Atomic_Sync;
-----------------------------------------------------
-- Process_Extended_Import_Export_Exception_Pragma --
-----------------------------------------------------
......@@ -5305,8 +5338,15 @@ package body Sem_Prag is
-- H.4(12). Restriction_Warnings never affects generated code
-- so this is done only in the real restriction case.
-- Atomic_Synchronization is not a real check, so it is not
-- affected by this processing).
if R_Id = No_Exceptions and then not Warn then
Scope_Suppress := (others => True);
for J in Scope_Suppress'Range loop
if J /= Atomic_Synchronization then
Scope_Suppress (J) := True;
end if;
end loop;
end if;
-- Case of No_Dependence => unit-name. Note that the parser
......@@ -5418,6 +5458,17 @@ package body Sem_Prag is
procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is
begin
-- Check for error of trying to set atomic synchronization for
-- a non-atomic variable.
if C = Atomic_Synchronization
and then not Is_Atomic (E)
then
Error_Msg_N
("pragma & requires atomic variable",
Pragma_Identifier (Original_Node (N)));
end if;
Set_Checks_May_Be_Suppressed (E);
if In_Package_Spec then
......@@ -5425,7 +5476,6 @@ package body Sem_Prag is
(Entity => E,
Check => C,
Suppress => Suppress_Case);
else
Push_Local_Suppress_Stack_Entry
(Entity => E,
......@@ -5493,18 +5543,26 @@ package body Sem_Prag is
-- the exception of Elaboration_Check, which is handled
-- specially because of not wanting All_Checks to have the
-- effect of deactivating static elaboration order processing.
-- Atomic_Synchronization is also not affected, since this is
-- not a real check.
for J in Scope_Suppress'Range loop
if J /= Elaboration_Check then
if J /= Elaboration_Check
and then J /= Atomic_Synchronization
then
Scope_Suppress (J) := Suppress_Case;
end if;
end loop;
-- If not All_Checks, and predefined check, then set appropriate
-- scope entry. Note that we will set Elaboration_Check if this
-- is explicitly specified.
-- is explicitly specified. Atomic_Synchronization is allowed
-- only if internally generated and entity is atomic.
elsif C in Predefined_Check_Id then
elsif C in Predefined_Check_Id
and then (not Comes_From_Source (N)
or else C /= Atomic_Synchronization)
then
Scope_Suppress (C) := Suppress_Case;
end if;
......@@ -6918,7 +6976,6 @@ package body Sem_Prag is
Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
end if;
end Atomic_Components;
--------------------
-- Attach_Handler --
--------------------
......@@ -7942,6 +7999,15 @@ package body Sem_Prag is
Check_Arg_Is_Static_Expression (Arg3, Standard_Integer);
Check_Arg_Is_Static_Expression (Arg4, Standard_Integer);
------------------------------------
-- Disable_Atomic_Synchronization --
------------------------------------
-- pragma Disable_Atomic_Synchronization [(Entity)];
when Pragma_Disable_Atomic_Synchronization =>
Process_Disable_Enable_Atomic_Sync (Name_Suppress);
-------------------
-- Discard_Names --
-------------------
......@@ -8364,6 +8430,15 @@ package body Sem_Prag is
Source_Location);
end Eliminate;
-----------------------------------
-- Enable_Atomic_Synchronization --
-----------------------------------
-- pragma Enable_Atomic_Synchronization [(Entity)];
when Pragma_Enable_Atomic_Synchronization =>
Process_Disable_Enable_Atomic_Sync (Name_Unsuppress);
------------
-- Export --
------------
......@@ -14152,16 +14227,12 @@ package body Sem_Prag is
end;
elsif Nkind (A) = N_Identifier then
if Chars (A) = Name_All_Checks then
Set_Validity_Check_Options ("a");
elsif Chars (A) = Name_On then
Validity_Checks_On := True;
elsif Chars (A) = Name_Off then
Validity_Checks_On := False;
end if;
end if;
end Validity_Checks;
......@@ -14721,6 +14792,7 @@ package body Sem_Prag is
Pragma_Detect_Blocking => -1,
Pragma_Default_Storage_Pool => -1,
Pragma_Dimension => -1,
Pragma_Disable_Atomic_Synchronization => -1,
Pragma_Discard_Names => 0,
Pragma_Dispatching_Domain => -1,
Pragma_Elaborate => -1,
......@@ -14728,6 +14800,7 @@ package body Sem_Prag is
Pragma_Elaborate_Body => -1,
Pragma_Elaboration_Checks => -1,
Pragma_Eliminate => -1,
Pragma_Enable_Atomic_Synchronization => -1,
Pragma_Export => -1,
Pragma_Export_Exception => -1,
Pragma_Export_Function => -1,
......
gcc/ada/sinfo.adb
......@@ -249,6 +249,15 @@ package body Sinfo is
return Node3 (N);
end Ancestor_Part;
function Atomic_Sync_Required
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_Expanded_Name
or else NT (N).Nkind = N_Identifier);
return Flag14 (N);
end Atomic_Sync_Required;
function Array_Aggregate
(N : Node_Id) return Node_Id is
begin
......@@ -3309,6 +3318,15 @@ package body Sinfo is
Set_Node3_With_Parent (N, Val);
end Set_Ancestor_Part;
procedure Set_Atomic_Sync_Required
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Expanded_Name
or else NT (N).Nkind = N_Identifier);
Set_Flag14 (N, Val);
end Set_Atomic_Sync_Required;
procedure Set_Array_Aggregate
(N : Node_Id; Val : Node_Id) is
begin
......
gcc/ada/sinfo.ads
......@@ -605,6 +605,12 @@ package Sinfo is
-- Since the back end is expected to ignore generic templates, this is
-- harmless.
-- Atomic_Sync_Required (Flag14-Sem)
-- This flag is set in an identifier or expanded name node if the
-- corresponding reference (or assignment when on the left side of
-- an assignment) requires atomic synchronization, as a result of
-- Atomic_Synchronization being enabled for the corresponding entity.
-- At_End_Proc (Node1)
-- This field is present in an N_Handled_Sequence_Of_Statements node.
-- It contains an identifier reference for the cleanup procedure to be
......@@ -1917,6 +1923,7 @@ package Sinfo is
-- Associated_Node (Node4-Sem)
-- Original_Discriminant (Node2-Sem)
-- Redundant_Use (Flag13-Sem)
-- Atomic_Sync_Required (Flag14-Sem)
-- Has_Private_View (Flag11-Sem) (set in generic units)
-- plus fields for expression
......@@ -6982,8 +6989,9 @@ package Sinfo is
-- Selector_Name (Node2)
-- Entity (Node4-Sem)
-- Associated_Node (Node4-Sem)
-- Redundant_Use (Flag13-Sem)
-- Has_Private_View (Flag11-Sem) set in generic units.
-- Redundant_Use (Flag13-Sem)
-- Atomic_Sync_Required (Flag14-Sem)
-- plus fields for expression
-----------------------------
......@@ -8121,6 +8129,9 @@ package Sinfo is
function Ancestor_Part
(N : Node_Id) return Node_Id; -- Node3
function Atomic_Sync_Required
(N : Node_Id) return Boolean; -- Flag14
function Array_Aggregate
(N : Node_Id) return Node_Id; -- Node3
......@@ -9096,6 +9107,9 @@ package Sinfo is
procedure Set_Ancestor_Part
(N : Node_Id; Val : Node_Id); -- Node3
procedure Set_Atomic_Sync_Required
(N : Node_Id; Val : Boolean := True); -- Flag14
procedure Set_Array_Aggregate
(N : Node_Id; Val : Node_Id); -- Node3
......@@ -11764,6 +11778,7 @@ package Sinfo is
pragma Inline (All_Present);
pragma Inline (Alternatives);
pragma Inline (Ancestor_Part);
pragma Inline (Atomic_Sync_Required);
pragma Inline (Array_Aggregate);
pragma Inline (Aspect_Rep_Item);
pragma Inline (Assignment_OK);
......@@ -12086,6 +12101,7 @@ package Sinfo is
pragma Inline (Set_All_Present);
pragma Inline (Set_Alternatives);
pragma Inline (Set_Ancestor_Part);
pragma Inline (Set_Atomic_Sync_Required);
pragma Inline (Set_Array_Aggregate);
pragma Inline (Set_Aspect_Rep_Item);
pragma Inline (Set_Assignment_OK);
......
gcc/ada/snames.ads-tmpl
......@@ -361,10 +361,12 @@ package Snames is
Name_Debug_Policy : constant Name_Id := N + $; -- GNAT
Name_Detect_Blocking : constant Name_Id := N + $; -- Ada 05
Name_Default_Storage_Pool : constant Name_Id := N + $; -- Ada 12
Name_Disable_Atomic_Synchronization : constant Name_Id := N + $; -- GNAT
Name_Discard_Names : constant Name_Id := N + $;
Name_Dispatching_Domain : constant Name_Id := N + $; -- Ada 12
Name_Elaboration_Checks : constant Name_Id := N + $; -- GNAT
Name_Eliminate : constant Name_Id := N + $; -- GNAT
Name_Enable_Atomic_Synchronization : constant Name_Id := N + $; -- GNAT
Name_Extend_System : constant Name_Id := N + $; -- GNAT
Name_Extensions_Allowed : constant Name_Id := N + $; -- GNAT
Name_External_Name_Casing : constant Name_Id := N + $; -- GNAT
......@@ -941,10 +943,14 @@ package Snames is
-- Names of recognized checks for pragma Suppress
-- Note: the name Atomic_Synchronization can only be specified internally
-- as a result of using pragma Enable/Disable_Atomic_Synchronization.
First_Check_Name : constant Name_Id := N + $;
Name_Access_Check : constant Name_Id := N + $;
Name_Accessibility_Check : constant Name_Id := N + $;
Name_Alignment_Check : constant Name_Id := N + $; -- GNAT
Name_Atomic_Synchronization : constant Name_Id := N + $; -- GNAT
Name_Discriminant_Check : constant Name_Id := N + $;
Name_Division_Check : constant Name_Id := N + $;
Name_Elaboration_Check : constant Name_Id := N + $;
......@@ -1532,10 +1538,12 @@ package Snames is
Pragma_Debug_Policy,
Pragma_Detect_Blocking,
Pragma_Default_Storage_Pool,
Pragma_Disable_Atomic_Synchronization,
Pragma_Discard_Names,
Pragma_Dispatching_Domain,
Pragma_Elaboration_Checks,
Pragma_Eliminate,
Pragma_Enable_Atomic_Synchronization,
Pragma_Extend_System,
Pragma_Extensions_Allowed,
Pragma_External_Name_Casing,
......
gcc/ada/switch-c.adb
......@@ -440,6 +440,11 @@ package body Switch.C is
-- Ptr := Ptr + 1;
-- Generate_SCIL := True;
-- -gnated switch (disable atomic synchronization)
when 'd' =>
Suppress_Options (Atomic_Synchronization) := True;
-- -gnateD switch (preprocessing symbol definition)
when 'D' =>
......@@ -743,10 +748,14 @@ package body Switch.C is
-- Set all specific options as well as All_Checks in the
-- Suppress_Options array, excluding Elaboration_Check,
-- since this is treated specially because we do not want
-- -gnatp to disable static elaboration processing.
-- -gnatp to disable static elaboration processing. Also
-- exclude Atomic_Synchronization, since this is not a real
-- check.
for J in Suppress_Options'Range loop
if J /= Elaboration_Check then
if J /= Elaboration_Check
and then J /= Atomic_Synchronization
then
Suppress_Options (J) := True;
end if;
end loop;
......
gcc/ada/types.ads
......@@ -663,19 +663,22 @@ package Types is
Access_Check : constant := 1;
Accessibility_Check : constant := 2;
Alignment_Check : constant := 3;
Discriminant_Check : constant := 4;
Division_Check : constant := 5;
Elaboration_Check : constant := 6;
Index_Check : constant := 7;
Length_Check : constant := 8;
Overflow_Check : constant := 9;
Range_Check : constant := 10;
Storage_Check : constant := 11;
Tag_Check : constant := 12;
Validity_Check : constant := 13;
-- Values used to represent individual predefined checks
All_Checks : constant := 14;
Atomic_Synchronization : constant := 4;
Discriminant_Check : constant := 5;
Division_Check : constant := 6;
Elaboration_Check : constant := 7;
Index_Check : constant := 8;
Length_Check : constant := 9;
Overflow_Check : constant := 10;
Range_Check : constant := 11;
Storage_Check : constant := 12;
Tag_Check : constant := 13;
Validity_Check : constant := 14;
-- Values used to represent individual predefined checks (including the
-- setting of Atomic_Synchronization, which is implemented internally using
-- a "check" whose name is Atomic_Synchronization.
All_Checks : constant := 15;
-- Value used to represent All_Checks value
subtype Predefined_Check_Id is Check_Id range 1 .. All_Checks;
......
gcc/ada/usage.adb
......@@ -172,6 +172,11 @@ begin
Write_Switch_Char ("ec=?");
Write_Line ("Specify configuration pragmas file, e.g. -gnatec=/x/f.adc");
-- Line for -gnated switch
Write_Switch_Char ("ed");
Write_Line ("Disable synchronization of atomic variables");
-- Line for -gnateD switch
Write_Switch_Char ("eD?");
......
gcc/ada/warnsw.adb
......@@ -67,6 +67,7 @@ package body Warnsw is
Warn_On_All_Unread_Out_Parameters := True;
Warn_On_Assertion_Failure := True;
Warn_On_Assumed_Low_Bound := True;
Warn_On_Atomic_Synchronization := True;
Warn_On_Bad_Fixed_Value := True;
Warn_On_Biased_Representation := True;
Warn_On_Constant := True;
......@@ -120,6 +121,12 @@ package body Warnsw is
when 'M' =>
Warn_On_Suspicious_Modulus_Value := False;
when 'n' =>
Warn_On_Atomic_Synchronization := True;
when 'N' =>
Warn_On_Atomic_Synchronization := False;
when 'o' =>
Warn_On_All_Unread_Out_Parameters := True;
......@@ -202,6 +209,7 @@ package body Warnsw is
Warn_On_All_Unread_Out_Parameters := False;
Warn_On_Assertion_Failure := True;
Warn_On_Assumed_Low_Bound := True;
Warn_On_Atomic_Synchronization := False;
Warn_On_Bad_Fixed_Value := True;
Warn_On_Biased_Representation := True;
Warn_On_Constant := True;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment