+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
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 --
-------------------------------
-- --
-- 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- --
-- 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
-- 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
-- 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.
------------------------------------------------------------------------------
with Atree; use Atree;
+with Checks; use Checks;
with Debug; use Debug;
with Einfo; use Einfo;
with Elists; use Elists;
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);
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)
-- 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
-- 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
-- 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;
--------------------
-- 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;
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.
-- 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.
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 --
----------------------
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
-- 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 --
--------------------
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
elsif Nkind_In (Nod, N_Subprogram_Body,
N_Package_Body,
+ N_Package_Declaration,
N_Task_Body,
N_Protected_Body,
N_Block_Statement)
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).
-- 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
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);
-- 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;
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 --
-----------------------------
-- 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;
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 --
-----------------------------------------------------
-- 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
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
(Entity => E,
Check => C,
Suppress => Suppress_Case);
-
else
Push_Local_Suppress_Stack_Entry
(Entity => E,
-- 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;
Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
end if;
end Atomic_Components;
-
--------------------
-- Attach_Handler --
--------------------
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 --
-------------------
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 --
------------
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;
-- 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;
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
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
-- 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
-- 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
-- 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
-----------------------------
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
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
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);
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);
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
-- 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 + $;
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,
-- 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' =>
-- 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;
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
-
- All_Checks : constant := 14;
+ 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 := 15;
-- Value used to represent All_Checks value
subtype Predefined_Check_Id is Check_Id range 1 .. All_Checks;
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?");
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;
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;
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;
projects / platform / upstream / gcc.git / commitdiff