===================================================================
@@ -160,6 +160,53 @@
-- or body. Flag Nested_Constructs should be set when any nested packages
-- declared in L must be processed.
+ -------------------------------------
+ -- Activate_Atomic_Synchronization --
+ -------------------------------------
+
+ procedure Activate_Atomic_Synchronization (N : Node_Id) is
+ Msg_Node : Node_Id;
+
+ begin
+ -- Nothing to do if we are the prefix of an attribute, since we do not
+ -- want an atomic sync operation for things like A'Adress or A'Size).
+
+ if Nkind (Parent (N)) = N_Attribute_Reference
+ and then Prefix (Parent (N)) = N
+ then
+ return;
+ end if;
+
+ -- Go ahead and set the flag
+
+ Set_Atomic_Sync_Required (N);
+
+ -- Generate info message if requested
+
+ if Warn_On_Atomic_Synchronization then
+ case Nkind (N) is
+ when N_Identifier =>
+ Msg_Node := N;
+
+ when N_Selected_Component | N_Expanded_Name =>
+ Msg_Node := Selector_Name (N);
+
+ when N_Explicit_Dereference | N_Indexed_Component =>
+ Msg_Node := Empty;
+
+ when others =>
+ pragma Assert (False);
+ return;
+ end case;
+
+ if Present (Msg_Node) then
+ Error_Msg_N ("?info: atomic synchronization set for &", Msg_Node);
+ else
+ Error_Msg_N ("?info: atomic synchronization set", N);
+ end if;
+ end if;
+ end Activate_Atomic_Synchronization;
+
----------------------
-- Adjust_Condition --
----------------------
===================================================================
@@ -149,6 +149,14 @@
-- Other Subprograms --
-----------------------
+ procedure Activate_Atomic_Synchronization (N : Node_Id);
+ -- N is a node for which atomic synchronization may be required (it is
+ -- either an identifier, expanded name, or selected/indexed component or
+ -- an explicit dereference). The caller has checked the basic conditions
+ -- (atomic variable appearing and Atomic_Sync not disabled). This function
+ -- checks if atomic synchronization is required and if so sets the flag
+ -- and if appropriate generates a warning (in -gnatw.n mode).
+
procedure Adjust_Condition (N : Node_Id);
-- The node N is an expression whose root-type is Boolean, and which
-- represents a boolean value used as a condition (i.e. a True/False
===================================================================
@@ -256,7 +256,8 @@
or else NT (N).Nkind = N_Expanded_Name
or else NT (N).Nkind = N_Explicit_Dereference
or else NT (N).Nkind = N_Identifier
- or else NT (N).Nkind = N_Indexed_Component);
+ or else NT (N).Nkind = N_Indexed_Component
+ or else NT (N).Nkind = N_Selected_Component);
return Flag14 (N);
end Atomic_Sync_Required;
@@ -3327,7 +3328,8 @@
or else NT (N).Nkind = N_Expanded_Name
or else NT (N).Nkind = N_Explicit_Dereference
or else NT (N).Nkind = N_Identifier
- or else NT (N).Nkind = N_Indexed_Component);
+ or else NT (N).Nkind = N_Indexed_Component
+ or else NT (N).Nkind = N_Selected_Component);
Set_Flag14 (N, Val);
end Set_Atomic_Sync_Required;
===================================================================
@@ -606,16 +606,8 @@
-- 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
- -- or its type. Also set for Selector_Name of an N_Selected Component
- -- node if the type is atomic and requires atomic synchronization.
- -- Also set on an N_Explicit Dereference node if the resulting type
- -- is atomic and requires atomic synchronization. Finally it is set
- -- on an N_Indexed_Component node if the resulting type is Atomic, or
- -- if the array type or the array has pragma Atomic_Components set.
+ -- This flag is set on a node for which atomic synchronization is
+ -- required for the corresponding reference or modification.
-- At_End_Proc (Node1)
-- This field is present in an N_Handled_Sequence_Of_Statements node.
@@ -3248,6 +3240,7 @@
-- Associated_Node (Node4-Sem)
-- Do_Discriminant_Check (Flag13-Sem)
-- Is_In_Discriminant_Check (Flag11-Sem)
+ -- Atomic_Sync_Required (Flag14-Sem)
-- plus fields for expression
--------------------------
===================================================================
@@ -2565,8 +2565,25 @@
function Atomic_Synchronization_Disabled (E : Entity_Id) return Boolean is
begin
- if Present (E) and then Checks_May_Be_Suppressed (E) then
+ -- If debug flag d.e is set, always return False, i.e. all atomic sync
+ -- looks enabled, since it is never disabled.
+
+ if Debug_Flag_Dot_E then
+ return False;
+
+ -- If debug flag d.d is set then always return True, i.e. all atomic
+ -- sync looks disabled, since it always tests True.
+
+ elsif Debug_Flag_Dot_D then
+ return True;
+
+ -- If entity present, then check result for that entity
+
+ elsif Present (E) and then Checks_May_Be_Suppressed (E) then
return Is_Check_Suppressed (E, Atomic_Synchronization);
+
+ -- Otherwise result depends on current scope setting
+
else
return Scope_Suppress (Atomic_Synchronization);
end if;
===================================================================
@@ -404,35 +404,15 @@
if Nkind_In (N, N_Identifier, N_Expanded_Name)
and then Ekind (E) = E_Variable
and then (Is_Atomic (E) or else Is_Atomic (Etype (E)))
-
- -- Don't go setting the flag for the prefix of an attribute because
- -- we don't want atomic sync for X'Size, X'Access etc.
-
- -- Is this right in all cases of attributes???
- -- Are there other exemptions required ???
-
- and then (Nkind (Parent (N)) /= N_Attribute_Reference
- or else Prefix (Parent (N)) /= N)
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;
-
-- If variable is atomic, but type is not, setting depends on
-- disable/enable state for the variable.
- elsif Is_Atomic (E) and then not Is_Atomic (Etype (E)) then
+ if Is_Atomic (E) and then not Is_Atomic (Etype (E)) then
Set := not Atomic_Synchronization_Disabled (E);
-- If variable is not atomic, but its type is atomic, setting
@@ -453,20 +433,7 @@
-- Set flag if required
if Set then
- Set_Atomic_Sync_Required (N);
-
- -- 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;
+ Activate_Atomic_Synchronization (N);
end if;
end;
end if;
===================================================================
@@ -4478,13 +4478,7 @@
if Is_Atomic (Etype (N))
and then not Atomic_Synchronization_Disabled (Etype (N))
then
- Set_Atomic_Sync_Required (N);
-
- -- Generate info message if requested
-
- if Warn_On_Atomic_Synchronization then
- Error_Msg_N ("?info: atomic synchronization set", N);
- end if;
+ Activate_Atomic_Synchronization (N);
end if;
end Expand_N_Explicit_Dereference;
@@ -5326,13 +5320,7 @@
or else (Is_Atomic (Typ)
and then not Atomic_Synchronization_Disabled (Typ))
then
- Set_Atomic_Sync_Required (N);
-
- -- Generate info message if requested
-
- if Warn_On_Atomic_Synchronization then
- Error_Msg_N ("?info: atomic synchronization set", N);
- end if;
+ Activate_Atomic_Synchronization (N);
end if;
-- All done for the non-packed case
@@ -8216,14 +8204,7 @@
and then Is_Atomic (Etype (N))
and then not Atomic_Synchronization_Disabled (Etype (N))
then
- Set_Atomic_Sync_Required (Selector_Name (N));
-
- -- Generate info message if requested
-
- if Warn_On_Atomic_Synchronization then
- Error_Msg_N
- ("?info: atomic synchronization set for &", Selector_Name (N));
- end if;
+ Activate_Atomic_Synchronization (N);
end if;
end Expand_N_Selected_Component;