git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

[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
This commit is contained in:
Arnaud Charlet 2011-10-24 11:51:42 +02:00
parent 08ce7bb81d
commit 12b4d33822
16 changed files with 841 additions and 514 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
gcc/ada/ChangeLog
View File

@ -1,3 +1,43 @@
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

17
gcc/ada/checks.adb
View File

@ -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 --
-------------------------------

29
gcc/ada/checks.ads
View File

@ -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- --
@ -46,19 +46,20 @@ package Checks is
-- Called for each new main source program, to initialize internal
-- variables used in the package body of the Checks unit.
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 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;
function Index_Checks_Suppressed (E : Entity_Id) return Boolean;
function Length_Checks_Suppressed (E : Entity_Id) return Boolean;
function Overflow_Checks_Suppressed (E : Entity_Id) return Boolean;
function Range_Checks_Suppressed (E : Entity_Id) return Boolean;
function Storage_Checks_Suppressed (E : Entity_Id) return Boolean;
function Tag_Checks_Suppressed (E : Entity_Id) return Boolean;
function Validity_Checks_Suppressed (E : Entity_Id) return Boolean;
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;
function Index_Checks_Suppressed (E : Entity_Id) return Boolean;
function Length_Checks_Suppressed (E : Entity_Id) return Boolean;
function Overflow_Checks_Suppressed (E : Entity_Id) return Boolean;
function Range_Checks_Suppressed (E : Entity_Id) return Boolean;
function Storage_Checks_Suppressed (E : Entity_Id) return Boolean;
function Tag_Checks_Suppressed (E : Entity_Id) return Boolean;
function Validity_Checks_Suppressed (E : Entity_Id) return Boolean;
-- These functions check to see if the named check is suppressed, either
-- by an active scope suppress setting, or because the check has been
-- specifically suppressed for the given entity. If no entity is relevant

11
gcc/ada/debug.adb
View File

@ -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.

51
gcc/ada/exp_ch2.adb
View File

@ -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,10 +355,10 @@ package body Exp_Ch2 is
elsif Is_Protected_Component (E) then
if No_Run_Time_Mode then
return;
else
Expand_Protected_Component (N);
end if;
Expand_Protected_Component (N);
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)

5
gcc/ada/opt.ads
View File

@ -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

342
gcc/ada/par-prag.adb
View File

@ -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
@ -1091,174 +1091,176 @@ begin
-- For all other pragmas, checking and processing is handled
-- entirely in Sem_Prag, and no further checking is done by Par.
when Pragma_Abort_Defer |
Pragma_Assertion_Policy |
Pragma_Assume_No_Invalid_Values |
Pragma_AST_Entry |
Pragma_All_Calls_Remote |
Pragma_Annotate |
Pragma_Assert |
Pragma_Asynchronous |
Pragma_Atomic |
Pragma_Atomic_Components |
Pragma_Attach_Handler |
Pragma_Check |
Pragma_Check_Name |
Pragma_Check_Policy |
Pragma_CIL_Constructor |
Pragma_Compile_Time_Error |
Pragma_Compile_Time_Warning |
Pragma_Compiler_Unit |
Pragma_Convention_Identifier |
Pragma_CPP_Class |
Pragma_CPP_Constructor |
Pragma_CPP_Virtual |
Pragma_CPP_Vtable |
Pragma_CPU |
Pragma_C_Pass_By_Copy |
Pragma_Comment |
Pragma_Common_Object |
Pragma_Complete_Representation |
Pragma_Complex_Representation |
Pragma_Component_Alignment |
Pragma_Controlled |
Pragma_Convention |
Pragma_Debug_Policy |
Pragma_Detect_Blocking |
Pragma_Default_Storage_Pool |
Pragma_Dimension |
Pragma_Discard_Names |
Pragma_Dispatching_Domain |
Pragma_Eliminate |
Pragma_Elaborate |
Pragma_Elaborate_All |
Pragma_Elaborate_Body |
Pragma_Elaboration_Checks |
Pragma_Export |
Pragma_Export_Exception |
Pragma_Export_Function |
Pragma_Export_Object |
Pragma_Export_Procedure |
Pragma_Export_Value |
Pragma_Export_Valued_Procedure |
Pragma_Extend_System |
Pragma_External |
Pragma_External_Name_Casing |
Pragma_Favor_Top_Level |
Pragma_Fast_Math |
Pragma_Finalize_Storage_Only |
Pragma_Float_Representation |
Pragma_Ident |
Pragma_Implementation_Defined |
Pragma_Implemented |
Pragma_Implicit_Packing |
Pragma_Import |
Pragma_Import_Exception |
Pragma_Import_Function |
Pragma_Import_Object |
Pragma_Import_Procedure |
Pragma_Import_Valued_Procedure |
Pragma_Independent |
Pragma_Independent_Components |
Pragma_Initialize_Scalars |
Pragma_Inline |
Pragma_Inline_Always |
Pragma_Inline_Generic |
Pragma_Inspection_Point |
Pragma_Interface |
Pragma_Interface_Name |
Pragma_Interrupt_Handler |
Pragma_Interrupt_State |
Pragma_Interrupt_Priority |
Pragma_Invariant |
Pragma_Java_Constructor |
Pragma_Java_Interface |
Pragma_Keep_Names |
Pragma_License |
Pragma_Link_With |
Pragma_Linker_Alias |
Pragma_Linker_Constructor |
Pragma_Linker_Destructor |
Pragma_Linker_Options |
Pragma_Linker_Section |
Pragma_Locking_Policy |
Pragma_Long_Float |
Pragma_Machine_Attribute |
Pragma_Main |
Pragma_Main_Storage |
Pragma_Memory_Size |
Pragma_No_Body |
Pragma_No_Return |
Pragma_No_Run_Time |
Pragma_No_Strict_Aliasing |
Pragma_Normalize_Scalars |
Pragma_Obsolescent |
Pragma_Ordered |
Pragma_Optimize |
Pragma_Optimize_Alignment |
Pragma_Pack |
Pragma_Passive |
Pragma_Preelaborable_Initialization |
Pragma_Polling |
Pragma_Persistent_BSS |
Pragma_Postcondition |
Pragma_Precondition |
Pragma_Predicate |
Pragma_Preelaborate |
Pragma_Preelaborate_05 |
Pragma_Priority |
Pragma_Priority_Specific_Dispatching |
Pragma_Profile |
Pragma_Profile_Warnings |
Pragma_Propagate_Exceptions |
Pragma_Psect_Object |
Pragma_Pure |
Pragma_Pure_05 |
Pragma_Pure_Function |
Pragma_Queuing_Policy |
Pragma_Relative_Deadline |
Pragma_Remote_Call_Interface |
Pragma_Remote_Types |
Pragma_Restricted_Run_Time |
Pragma_Ravenscar |
Pragma_Reviewable |
Pragma_Share_Generic |
Pragma_Shared |
Pragma_Shared_Passive |
Pragma_Short_Circuit_And_Or |
Pragma_Short_Descriptors |
Pragma_Storage_Size |
Pragma_Storage_Unit |
Pragma_Static_Elaboration_Desired |
Pragma_Stream_Convert |
Pragma_Subtitle |
Pragma_Suppress |
Pragma_Suppress_Debug_Info |
Pragma_Suppress_Exception_Locations |
Pragma_Suppress_Initialization |
Pragma_System_Name |
Pragma_Task_Dispatching_Policy |
Pragma_Task_Info |
Pragma_Task_Name |
Pragma_Task_Storage |
Pragma_Test_Case |
Pragma_Thread_Local_Storage |
Pragma_Time_Slice |
Pragma_Title |
Pragma_Unchecked_Union |
Pragma_Unimplemented_Unit |
Pragma_Universal_Aliasing |
Pragma_Universal_Data |
Pragma_Unmodified |
Pragma_Unreferenced |
Pragma_Unreferenced_Objects |
Pragma_Unreserve_All_Interrupts |
Pragma_Unsuppress |
Pragma_Use_VADS_Size |
Pragma_Volatile |
Pragma_Volatile_Components |
Pragma_Weak_External |
Pragma_Validity_Checks =>
when Pragma_Abort_Defer |
Pragma_Assertion_Policy |
Pragma_Assume_No_Invalid_Values |
Pragma_AST_Entry |
Pragma_All_Calls_Remote |
Pragma_Annotate |
Pragma_Assert |
Pragma_Asynchronous |
Pragma_Atomic |
Pragma_Atomic_Components |
Pragma_Attach_Handler |
Pragma_Check |
Pragma_Check_Name |
Pragma_Check_Policy |
Pragma_CIL_Constructor |
Pragma_Compile_Time_Error |
Pragma_Compile_Time_Warning |
Pragma_Compiler_Unit |
Pragma_Convention_Identifier |
Pragma_CPP_Class |
Pragma_CPP_Constructor |
Pragma_CPP_Virtual |
Pragma_CPP_Vtable |
Pragma_CPU |
Pragma_C_Pass_By_Copy |
Pragma_Comment |
Pragma_Common_Object |
Pragma_Complete_Representation |
Pragma_Complex_Representation |
Pragma_Component_Alignment |
Pragma_Controlled |
Pragma_Convention |
Pragma_Debug_Policy |
Pragma_Detect_Blocking |
Pragma_Default_Storage_Pool |
Pragma_Dimension |
Pragma_Disable_Atomic_Synchronization |
Pragma_Discard_Names |
Pragma_Dispatching_Domain |
Pragma_Eliminate |
Pragma_Elaborate |
Pragma_Elaborate_All |
Pragma_Elaborate_Body |
Pragma_Elaboration_Checks |
Pragma_Enable_Atomic_Synchronization |
Pragma_Export |
Pragma_Export_Exception |
Pragma_Export_Function |
Pragma_Export_Object |
Pragma_Export_Procedure |
Pragma_Export_Value |
Pragma_Export_Valued_Procedure |
Pragma_Extend_System |
Pragma_External |
Pragma_External_Name_Casing |
Pragma_Favor_Top_Level |
Pragma_Fast_Math |
Pragma_Finalize_Storage_Only |
Pragma_Float_Representation |
Pragma_Ident |
Pragma_Implementation_Defined |
Pragma_Implemented |
Pragma_Implicit_Packing |
Pragma_Import |
Pragma_Import_Exception |
Pragma_Import_Function |
Pragma_Import_Object |
Pragma_Import_Procedure |
Pragma_Import_Valued_Procedure |
Pragma_Independent |
Pragma_Independent_Components |
Pragma_Initialize_Scalars |
Pragma_Inline |
Pragma_Inline_Always |
Pragma_Inline_Generic |
Pragma_Inspection_Point |
Pragma_Interface |
Pragma_Interface_Name |
Pragma_Interrupt_Handler |
Pragma_Interrupt_State |
Pragma_Interrupt_Priority |
Pragma_Invariant |
Pragma_Java_Constructor |
Pragma_Java_Interface |
Pragma_Keep_Names |
Pragma_License |
Pragma_Link_With |
Pragma_Linker_Alias |
Pragma_Linker_Constructor |
Pragma_Linker_Destructor |
Pragma_Linker_Options |
Pragma_Linker_Section |
Pragma_Locking_Policy |
Pragma_Long_Float |
Pragma_Machine_Attribute |
Pragma_Main |
Pragma_Main_Storage |
Pragma_Memory_Size |
Pragma_No_Body |
Pragma_No_Return |
Pragma_No_Run_Time |
Pragma_No_Strict_Aliasing |
Pragma_Normalize_Scalars |
Pragma_Obsolescent |
Pragma_Ordered |
Pragma_Optimize |
Pragma_Optimize_Alignment |
Pragma_Pack |
Pragma_Passive |
Pragma_Preelaborable_Initialization |
Pragma_Polling |
Pragma_Persistent_BSS |
Pragma_Postcondition |
Pragma_Precondition |
Pragma_Predicate |
Pragma_Preelaborate |
Pragma_Preelaborate_05 |
Pragma_Priority |
Pragma_Priority_Specific_Dispatching |
Pragma_Profile |
Pragma_Profile_Warnings |
Pragma_Propagate_Exceptions |
Pragma_Psect_Object |
Pragma_Pure |
Pragma_Pure_05 |
Pragma_Pure_Function |
Pragma_Queuing_Policy |
Pragma_Relative_Deadline |
Pragma_Remote_Call_Interface |
Pragma_Remote_Types |
Pragma_Restricted_Run_Time |
Pragma_Ravenscar |
Pragma_Reviewable |
Pragma_Share_Generic |
Pragma_Shared |
Pragma_Shared_Passive |
Pragma_Short_Circuit_And_Or |
Pragma_Short_Descriptors |
Pragma_Storage_Size |
Pragma_Storage_Unit |
Pragma_Static_Elaboration_Desired |
Pragma_Stream_Convert |
Pragma_Subtitle |
Pragma_Suppress |
Pragma_Suppress_Debug_Info |
Pragma_Suppress_Exception_Locations |
Pragma_Suppress_Initialization |
Pragma_System_Name |
Pragma_Task_Dispatching_Policy |
Pragma_Task_Info |
Pragma_Task_Name |
Pragma_Task_Storage |
Pragma_Test_Case |
Pragma_Thread_Local_Storage |
Pragma_Time_Slice |
Pragma_Title |
Pragma_Unchecked_Union |
Pragma_Unimplemented_Unit |
Pragma_Universal_Aliasing |
Pragma_Universal_Data |
Pragma_Unmodified |
Pragma_Unreferenced |
Pragma_Unreferenced_Objects |
Pragma_Unreserve_All_Interrupts |
Pragma_Unsuppress |
Pragma_Use_VADS_Size |
Pragma_Volatile |
Pragma_Volatile_Components |
Pragma_Weak_External |
Pragma_Validity_Checks =>
null;
--------------------

288
gcc/ada/sem_ch12.adb
View File

@ -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,6 +6773,103 @@ package body Sem_Ch12 is
Expander_Mode_Restore;
end End_Generic;
-------------
-- Earlier --
-------------
function Earlier (N1, N2 : Node_Id) return Boolean is
D1 : Integer := 0;
D2 : Integer := 0;
P1 : Node_Id := N1;
P2 : Node_Id := N2;
procedure Find_Depth (P : in out Node_Id; D : in out Integer);
-- Find distance from given node to enclosing compilation unit
----------------
-- Find_Depth --
----------------
procedure Find_Depth (P : in out Node_Id; D : in out Integer) is
begin
while Present (P)
and then Nkind (P) /= N_Compilation_Unit
loop
P := True_Parent (P);
D := D + 1;
end loop;
end Find_Depth;
-- Start of processing for Earlier
begin
Find_Depth (P1, D1);
Find_Depth (P2, D2);
if P1 /= P2 then
return False;
else
P1 := N1;
P2 := N2;
end if;
while D1 > D2 loop
P1 := True_Parent (P1);
D1 := D1 - 1;
end loop;
while D2 > D1 loop
P2 := True_Parent (P2);
D2 := D2 - 1;
end loop;
-- At this point P1 and P2 are at the same distance from the root.
-- We examine their parents until we find a common declarative list,
-- at which point we can establish their relative placement by
-- comparing their ultimate slocs. If we reach the root, N1 and N2
-- do not descend from the same declarative list (e.g. one is nested
-- in the declarative part and the other is in a block in the
-- statement part) and the earlier one is already frozen.
while not Is_List_Member (P1)
or else not Is_List_Member (P2)
or else List_Containing (P1) /= List_Containing (P2)
loop
P1 := True_Parent (P1);
P2 := True_Parent (P2);
if Nkind (Parent (P1)) = N_Subunit then
P1 := Corresponding_Stub (Parent (P1));
end if;
if Nkind (Parent (P2)) = N_Subunit then
P2 := Corresponding_Stub (Parent (P2));
end if;
if P1 = P2 then
return False;
end if;
end loop;
-- 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 --
----------------------
@ -6828,11 +6936,6 @@ package body Sem_Ch12 is
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
@ -6843,91 +6946,6 @@ package body Sem_Ch12 is
-- 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 --
-------------
function Earlier (N1, N2 : Node_Id) return Boolean is
D1 : Integer := 0;
D2 : Integer := 0;
P1 : Node_Id := N1;
P2 : Node_Id := N2;
procedure Find_Depth (P : in out Node_Id; D : in out Integer);
-- Find distance from given node to enclosing compilation unit
----------------
-- Find_Depth --
----------------
procedure Find_Depth (P : in out Node_Id; D : in out Integer) is
begin
while Present (P)
and then Nkind (P) /= N_Compilation_Unit
loop
P := True_Parent (P);
D := D + 1;
end loop;
end Find_Depth;
-- Start of processing for Earlier
begin
Find_Depth (P1, D1);
Find_Depth (P2, D2);
if P1 /= P2 then
return False;
else
P1 := N1;
P2 := N2;
end if;
while D1 > D2 loop
P1 := True_Parent (P1);
D1 := D1 - 1;
end loop;
while D2 > D1 loop
P2 := True_Parent (P2);
D2 := D2 - 1;
end loop;
-- At this point P1 and P2 are at the same distance from the root.
-- We examine their parents until we find a common declarative list,
-- at which point we can establish their relative placement by
-- comparing their ultimate slocs. If we reach the root, N1 and N2
-- do not descend from the same declarative list (e.g. one is nested
-- in the declarative part and the other is in a block in the
-- statement part) and the earlier one is already frozen.
while not Is_List_Member (P1)
or else not Is_List_Member (P2)
or else List_Containing (P1) /= List_Containing (P2)
loop
P1 := True_Parent (P1);
P2 := True_Parent (P2);
if Nkind (Parent (P1)) = N_Subunit then
P1 := Corresponding_Stub (Parent (P1));
end if;
if Nkind (Parent (P2)) = N_Subunit then
P2 := Corresponding_Stub (Parent (P2));
end if;
if P1 = P2 then
return False;
end if;
end loop;
return
Top_Level_Location (Sloc (P1)) < Top_Level_Location (Sloc (P2));
end Earlier;
--------------------
-- 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 --
-----------------------------

469
gcc/ada/sem_prag.adb
View File

@ -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;
@ -14678,194 +14749,196 @@ package body Sem_Prag is
-- 99 special processing required (e.g. for pragma Check)
Sig_Flags : constant array (Pragma_Id) of Int :=
(Pragma_AST_Entry => -1,
Pragma_Abort_Defer => -1,
Pragma_Ada_83 => -1,
Pragma_Ada_95 => -1,
Pragma_Ada_05 => -1,
Pragma_Ada_2005 => -1,
Pragma_Ada_12 => -1,
Pragma_Ada_2012 => -1,
Pragma_All_Calls_Remote => -1,
Pragma_Annotate => -1,
Pragma_Assert => -1,
Pragma_Assertion_Policy => 0,
Pragma_Assume_No_Invalid_Values => 0,
Pragma_Asynchronous => -1,
Pragma_Atomic => 0,
Pragma_Atomic_Components => 0,
Pragma_Attach_Handler => -1,
Pragma_Check => 99,
Pragma_Check_Name => 0,
Pragma_Check_Policy => 0,
Pragma_CIL_Constructor => -1,
Pragma_CPP_Class => 0,
Pragma_CPP_Constructor => 0,
Pragma_CPP_Virtual => 0,
Pragma_CPP_Vtable => 0,
Pragma_CPU => -1,
Pragma_C_Pass_By_Copy => 0,
Pragma_Comment => 0,
Pragma_Common_Object => -1,
Pragma_Compile_Time_Error => -1,
Pragma_Compile_Time_Warning => -1,
Pragma_Compiler_Unit => 0,
Pragma_Complete_Representation => 0,
Pragma_Complex_Representation => 0,
Pragma_Component_Alignment => -1,
Pragma_Controlled => 0,
Pragma_Convention => 0,
Pragma_Convention_Identifier => 0,
Pragma_Debug => -1,
Pragma_Debug_Policy => 0,
Pragma_Detect_Blocking => -1,
Pragma_Default_Storage_Pool => -1,
Pragma_Dimension => -1,
Pragma_Discard_Names => 0,
Pragma_Dispatching_Domain => -1,
Pragma_Elaborate => -1,
Pragma_Elaborate_All => -1,
Pragma_Elaborate_Body => -1,
Pragma_Elaboration_Checks => -1,
Pragma_Eliminate => -1,
Pragma_Export => -1,
Pragma_Export_Exception => -1,
Pragma_Export_Function => -1,
Pragma_Export_Object => -1,
Pragma_Export_Procedure => -1,
Pragma_Export_Value => -1,
Pragma_Export_Valued_Procedure => -1,
Pragma_Extend_System => -1,
Pragma_Extensions_Allowed => -1,
Pragma_External => -1,
Pragma_Favor_Top_Level => -1,
Pragma_External_Name_Casing => -1,
Pragma_Fast_Math => -1,
Pragma_Finalize_Storage_Only => 0,
Pragma_Float_Representation => 0,
Pragma_Ident => -1,
Pragma_Implementation_Defined => -1,
Pragma_Implemented => -1,
Pragma_Implicit_Packing => 0,
Pragma_Import => +2,
Pragma_Import_Exception => 0,
Pragma_Import_Function => 0,
Pragma_Import_Object => 0,
Pragma_Import_Procedure => 0,
Pragma_Import_Valued_Procedure => 0,
Pragma_Independent => 0,
Pragma_Independent_Components => 0,
Pragma_Initialize_Scalars => -1,
Pragma_Inline => 0,
Pragma_Inline_Always => 0,
Pragma_Inline_Generic => 0,
Pragma_Inspection_Point => -1,
Pragma_Interface => +2,
Pragma_Interface_Name => +2,
Pragma_Interrupt_Handler => -1,
Pragma_Interrupt_Priority => -1,
Pragma_Interrupt_State => -1,
Pragma_Invariant => -1,
Pragma_Java_Constructor => -1,
Pragma_Java_Interface => -1,
Pragma_Keep_Names => 0,
Pragma_License => -1,
Pragma_Link_With => -1,
Pragma_Linker_Alias => -1,
Pragma_Linker_Constructor => -1,
Pragma_Linker_Destructor => -1,
Pragma_Linker_Options => -1,
Pragma_Linker_Section => -1,
Pragma_List => -1,
Pragma_Locking_Policy => -1,
Pragma_Long_Float => -1,
Pragma_Machine_Attribute => -1,
Pragma_Main => -1,
Pragma_Main_Storage => -1,
Pragma_Memory_Size => -1,
Pragma_No_Return => 0,
Pragma_No_Body => 0,
Pragma_No_Run_Time => -1,
Pragma_No_Strict_Aliasing => -1,
Pragma_Normalize_Scalars => -1,
Pragma_Obsolescent => 0,
Pragma_Optimize => -1,
Pragma_Optimize_Alignment => -1,
Pragma_Ordered => 0,
Pragma_Pack => 0,
Pragma_Page => -1,
Pragma_Passive => -1,
Pragma_Preelaborable_Initialization => -1,
Pragma_Polling => -1,
Pragma_Persistent_BSS => 0,
Pragma_Postcondition => -1,
Pragma_Precondition => -1,
Pragma_Predicate => -1,
Pragma_Preelaborate => -1,
Pragma_Preelaborate_05 => -1,
Pragma_Priority => -1,
Pragma_Priority_Specific_Dispatching => -1,
Pragma_Profile => 0,
Pragma_Profile_Warnings => 0,
Pragma_Propagate_Exceptions => -1,
Pragma_Psect_Object => -1,
Pragma_Pure => -1,
Pragma_Pure_05 => -1,
Pragma_Pure_Function => -1,
Pragma_Queuing_Policy => -1,
Pragma_Ravenscar => -1,
Pragma_Relative_Deadline => -1,
Pragma_Remote_Call_Interface => -1,
Pragma_Remote_Types => -1,
Pragma_Restricted_Run_Time => -1,
Pragma_Restriction_Warnings => -1,
Pragma_Restrictions => -1,
Pragma_Reviewable => -1,
Pragma_Short_Circuit_And_Or => -1,
Pragma_Share_Generic => -1,
Pragma_Shared => -1,
Pragma_Shared_Passive => -1,
Pragma_Short_Descriptors => 0,
Pragma_Source_File_Name => -1,
Pragma_Source_File_Name_Project => -1,
Pragma_Source_Reference => -1,
Pragma_Storage_Size => -1,
Pragma_Storage_Unit => -1,
Pragma_Static_Elaboration_Desired => -1,
Pragma_Stream_Convert => -1,
Pragma_Style_Checks => -1,
Pragma_Subtitle => -1,
Pragma_Suppress => 0,
Pragma_Suppress_Exception_Locations => 0,
Pragma_Suppress_All => -1,
Pragma_Suppress_Debug_Info => 0,
Pragma_Suppress_Initialization => 0,
Pragma_System_Name => -1,
Pragma_Task_Dispatching_Policy => -1,
Pragma_Task_Info => -1,
Pragma_Task_Name => -1,
Pragma_Task_Storage => 0,
Pragma_Test_Case => -1,
Pragma_Thread_Local_Storage => 0,
Pragma_Time_Slice => -1,
Pragma_Title => -1,
Pragma_Unchecked_Union => 0,
Pragma_Unimplemented_Unit => -1,
Pragma_Universal_Aliasing => -1,
Pragma_Universal_Data => -1,
Pragma_Unmodified => -1,
Pragma_Unreferenced => -1,
Pragma_Unreferenced_Objects => -1,
Pragma_Unreserve_All_Interrupts => -1,
Pragma_Unsuppress => 0,
Pragma_Use_VADS_Size => -1,
Pragma_Validity_Checks => -1,
Pragma_Volatile => 0,
Pragma_Volatile_Components => 0,
Pragma_Warnings => -1,
Pragma_Weak_External => -1,
Pragma_Wide_Character_Encoding => 0,
Unknown_Pragma => 0);
(Pragma_AST_Entry => -1,
Pragma_Abort_Defer => -1,
Pragma_Ada_83 => -1,
Pragma_Ada_95 => -1,
Pragma_Ada_05 => -1,
Pragma_Ada_2005 => -1,
Pragma_Ada_12 => -1,
Pragma_Ada_2012 => -1,
Pragma_All_Calls_Remote => -1,
Pragma_Annotate => -1,
Pragma_Assert => -1,
Pragma_Assertion_Policy => 0,
Pragma_Assume_No_Invalid_Values => 0,
Pragma_Asynchronous => -1,
Pragma_Atomic => 0,
Pragma_Atomic_Components => 0,
Pragma_Attach_Handler => -1,
Pragma_Check => 99,
Pragma_Check_Name => 0,
Pragma_Check_Policy => 0,
Pragma_CIL_Constructor => -1,
Pragma_CPP_Class => 0,
Pragma_CPP_Constructor => 0,
Pragma_CPP_Virtual => 0,
Pragma_CPP_Vtable => 0,
Pragma_CPU => -1,
Pragma_C_Pass_By_Copy => 0,
Pragma_Comment => 0,
Pragma_Common_Object => -1,
Pragma_Compile_Time_Error => -1,
Pragma_Compile_Time_Warning => -1,
Pragma_Compiler_Unit => 0,
Pragma_Complete_Representation => 0,
Pragma_Complex_Representation => 0,
Pragma_Component_Alignment => -1,
Pragma_Controlled => 0,
Pragma_Convention => 0,
Pragma_Convention_Identifier => 0,
Pragma_Debug => -1,
Pragma_Debug_Policy => 0,
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,
Pragma_Elaborate_All => -1,
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,
Pragma_Export_Object => -1,
Pragma_Export_Procedure => -1,
Pragma_Export_Value => -1,
Pragma_Export_Valued_Procedure => -1,
Pragma_Extend_System => -1,
Pragma_Extensions_Allowed => -1,
Pragma_External => -1,
Pragma_Favor_Top_Level => -1,
Pragma_External_Name_Casing => -1,
Pragma_Fast_Math => -1,
Pragma_Finalize_Storage_Only => 0,
Pragma_Float_Representation => 0,
Pragma_Ident => -1,
Pragma_Implementation_Defined => -1,
Pragma_Implemented => -1,
Pragma_Implicit_Packing => 0,
Pragma_Import => +2,
Pragma_Import_Exception => 0,
Pragma_Import_Function => 0,
Pragma_Import_Object => 0,
Pragma_Import_Procedure => 0,
Pragma_Import_Valued_Procedure => 0,
Pragma_Independent => 0,
Pragma_Independent_Components => 0,
Pragma_Initialize_Scalars => -1,
Pragma_Inline => 0,
Pragma_Inline_Always => 0,
Pragma_Inline_Generic => 0,
Pragma_Inspection_Point => -1,
Pragma_Interface => +2,
Pragma_Interface_Name => +2,
Pragma_Interrupt_Handler => -1,
Pragma_Interrupt_Priority => -1,
Pragma_Interrupt_State => -1,
Pragma_Invariant => -1,
Pragma_Java_Constructor => -1,
Pragma_Java_Interface => -1,
Pragma_Keep_Names => 0,
Pragma_License => -1,
Pragma_Link_With => -1,
Pragma_Linker_Alias => -1,
Pragma_Linker_Constructor => -1,
Pragma_Linker_Destructor => -1,
Pragma_Linker_Options => -1,
Pragma_Linker_Section => -1,
Pragma_List => -1,
Pragma_Locking_Policy => -1,
Pragma_Long_Float => -1,
Pragma_Machine_Attribute => -1,
Pragma_Main => -1,
Pragma_Main_Storage => -1,
Pragma_Memory_Size => -1,
Pragma_No_Return => 0,
Pragma_No_Body => 0,
Pragma_No_Run_Time => -1,
Pragma_No_Strict_Aliasing => -1,
Pragma_Normalize_Scalars => -1,
Pragma_Obsolescent => 0,
Pragma_Optimize => -1,
Pragma_Optimize_Alignment => -1,
Pragma_Ordered => 0,
Pragma_Pack => 0,
Pragma_Page => -1,
Pragma_Passive => -1,
Pragma_Preelaborable_Initialization => -1,
Pragma_Polling => -1,
Pragma_Persistent_BSS => 0,
Pragma_Postcondition => -1,
Pragma_Precondition => -1,
Pragma_Predicate => -1,
Pragma_Preelaborate => -1,
Pragma_Preelaborate_05 => -1,
Pragma_Priority => -1,
Pragma_Priority_Specific_Dispatching => -1,
Pragma_Profile => 0,
Pragma_Profile_Warnings => 0,
Pragma_Propagate_Exceptions => -1,
Pragma_Psect_Object => -1,
Pragma_Pure => -1,
Pragma_Pure_05 => -1,
Pragma_Pure_Function => -1,
Pragma_Queuing_Policy => -1,
Pragma_Ravenscar => -1,
Pragma_Relative_Deadline => -1,
Pragma_Remote_Call_Interface => -1,
Pragma_Remote_Types => -1,
Pragma_Restricted_Run_Time => -1,
Pragma_Restriction_Warnings => -1,
Pragma_Restrictions => -1,
Pragma_Reviewable => -1,
Pragma_Short_Circuit_And_Or => -1,
Pragma_Share_Generic => -1,
Pragma_Shared => -1,
Pragma_Shared_Passive => -1,
Pragma_Short_Descriptors => 0,
Pragma_Source_File_Name => -1,
Pragma_Source_File_Name_Project => -1,
Pragma_Source_Reference => -1,
Pragma_Storage_Size => -1,
Pragma_Storage_Unit => -1,
Pragma_Static_Elaboration_Desired => -1,
Pragma_Stream_Convert => -1,
Pragma_Style_Checks => -1,
Pragma_Subtitle => -1,
Pragma_Suppress => 0,
Pragma_Suppress_Exception_Locations => 0,
Pragma_Suppress_All => -1,
Pragma_Suppress_Debug_Info => 0,
Pragma_Suppress_Initialization => 0,
Pragma_System_Name => -1,
Pragma_Task_Dispatching_Policy => -1,
Pragma_Task_Info => -1,
Pragma_Task_Name => -1,
Pragma_Task_Storage => 0,
Pragma_Test_Case => -1,
Pragma_Thread_Local_Storage => 0,
Pragma_Time_Slice => -1,
Pragma_Title => -1,
Pragma_Unchecked_Union => 0,
Pragma_Unimplemented_Unit => -1,
Pragma_Universal_Aliasing => -1,
Pragma_Universal_Data => -1,
Pragma_Unmodified => -1,
Pragma_Unreferenced => -1,
Pragma_Unreferenced_Objects => -1,
Pragma_Unreserve_All_Interrupts => -1,
Pragma_Unsuppress => 0,
Pragma_Use_VADS_Size => -1,
Pragma_Validity_Checks => -1,
Pragma_Volatile => 0,
Pragma_Volatile_Components => 0,
Pragma_Warnings => -1,
Pragma_Weak_External => -1,
Pragma_Wide_Character_Encoding => 0,
Unknown_Pragma => 0);
function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is
Id : Pragma_Id;

18
gcc/ada/sinfo.adb
View File

@ -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

18
gcc/ada/sinfo.ads
View File

@ -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);

8
gcc/ada/snames.ads-tmpl
View File

@ -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,

13
gcc/ada/switch-c.adb
View File

@ -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;

33
gcc/ada/types.ads
View File

@ -660,22 +660,25 @@ package Types is
No_Check_Id : constant := 0;
-- Check_Id value used to indicate no check
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
Access_Check : constant := 1;
Accessibility_Check : constant := 2;
Alignment_Check : constant := 3;
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 := 14;
All_Checks : constant := 15;
-- Value used to represent All_Checks value
subtype Predefined_Check_Id is Check_Id range 1 .. All_Checks;

5
gcc/ada/usage.adb
View File

@ -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?");

8
gcc/ada/warnsw.adb
View File

@ -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;