diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 40 | ||||
| -rw-r--r-- | gcc/ada/checks.adb | 17 | ||||
| -rw-r--r-- | gcc/ada/checks.ads | 29 | ||||
| -rw-r--r-- | gcc/ada/debug.adb | 11 | ||||
| -rw-r--r-- | gcc/ada/exp_ch2.adb | 51 | ||||
| -rw-r--r-- | gcc/ada/opt.ads | 5 | ||||
| -rw-r--r-- | gcc/ada/par-prag.adb | 342 | ||||
| -rw-r--r-- | gcc/ada/sem_ch12.adb | 288 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 469 | ||||
| -rw-r--r-- | gcc/ada/sinfo.adb | 18 | ||||
| -rw-r--r-- | gcc/ada/sinfo.ads | 18 | ||||
| -rw-r--r-- | gcc/ada/snames.ads-tmpl | 8 | ||||
| -rw-r--r-- | gcc/ada/switch-c.adb | 13 | ||||
| -rw-r--r-- | gcc/ada/types.ads | 35 | ||||
| -rw-r--r-- | gcc/ada/usage.adb | 5 | ||||
| -rw-r--r-- | gcc/ada/warnsw.adb | 8 |
16 files changed, 842 insertions, 515 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index a226bb8..93e4e3e 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -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 diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index e07d70e..f323486 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -2555,6 +2555,23 @@ package body Checks is end if; end Apply_Universal_Integer_Attribute_Checks; + ------------------------------------- + -- Atomic_Synchronization_Disabled -- + ------------------------------------- + + -- Note: internally Disable/Enable_Atomic_Synchronization is implemented + -- using a bogus check called Atomic_Synchronization. This is to make it + -- more convenient to get exactly the same semantics as [Un]Suppress. + + function Atomic_Synchronization_Disabled (E : Entity_Id) return Boolean is + begin + if Present (E) and then Checks_May_Be_Suppressed (E) then + return Is_Check_Suppressed (E, Atomic_Synchronization); + else + return Scope_Suppress (Atomic_Synchronization); + end if; + end Atomic_Synchronization_Disabled; + ------------------------------- -- Build_Discriminant_Checks -- ------------------------------- diff --git a/gcc/ada/checks.ads b/gcc/ada/checks.ads index 509a55c..83a67dc 100644 --- a/gcc/ada/checks.ads +++ b/gcc/ada/checks.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -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 diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index b3eb5cf..99ba3d5 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -94,8 +94,8 @@ package body Debug is -- d.a Force Target_Strict_Alignment mode to True -- d.b Dump backend types -- d.c Generate inline concatenation, do not call procedure - -- d.d - -- d.e + -- d.d Disable atomic synchronization + -- d.e Enable atomic synchronization -- d.f Inhibit folding of static expressions -- d.g Enable conversion of raise into goto -- d.h @@ -513,6 +513,13 @@ package body Debug is -- System.Concat_n.Str_Concat_n routines in cases where the latter -- routines would normally be called. + -- d.d Disable atomic synchronization for all atomic variable references. + -- Pragma Enable_Atomic_Synchronization is ignored. + + -- d.e Enable atomic synchronization for all atomic variable references. + -- Pragma Disable_Atomic_Synchronization is ignored, and also the + -- compiler switch -gnated is ignored. + -- d.f Suppress folding of static expressions. This of course results -- in seriously non-conforming behavior, but is useful sometimes -- when tracking down handling of complex expressions. diff --git a/gcc/ada/exp_ch2.adb b/gcc/ada/exp_ch2.adb index 68483ff..a71ce69 100644 --- a/gcc/ada/exp_ch2.adb +++ b/gcc/ada/exp_ch2.adb @@ -24,6 +24,7 @@ ------------------------------------------------------------------------------ with Atree; use Atree; +with Checks; use Checks; with Debug; use Debug; with Einfo; use Einfo; with Elists; use Elists; @@ -354,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) diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index ed940d4..e6a4281 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -1448,6 +1448,11 @@ package Opt is -- with literals or S'Length, presumably assuming a lower bound of one. Set -- False by -gnatwW. + Warn_On_Atomic_Synchronization : Boolean := False; + -- GNAT + -- Set to True to generate information messages for atomic synchronization. + -- Set True by use of -gnatw.n. + Warn_On_Bad_Fixed_Value : Boolean := False; -- GNAT -- Set to True to generate warnings for static fixed-point expression diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index 5ed6553..224b992 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -61,8 +61,8 @@ function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is -- that is the only case in which a non-present argument can be referenced. procedure Check_Arg_Count (Required : Int); - -- Check argument count for pragma = Required. - -- If not give error and raise Error_Resync. + -- Check argument count for pragma = Required. If not give error and raise + -- Error_Resync. procedure Check_Arg_Is_String_Literal (Arg : Node_Id); -- Check the expression of the specified argument to make sure that it @@ -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; -------------------- diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 489f724..f88c900 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -451,6 +451,12 @@ package body Sem_Ch12 is -- an instantiation in the source, or the internal instantiation that -- corresponds to the actual for a formal package. + function Earlier (N1, N2 : Node_Id) return Boolean; + -- Yields True if N1 and N2 appear in the same compilation unit, + -- ignoring subunits, and if N1 is to the left of N2 in a left-to-right + -- traversal of the tree for the unit. Used to determine the placement + -- of freeze nodes for instance bodies that may depend on other instances. + function Find_Actual_Type (Typ : Entity_Id; Gen_Type : Entity_Id) return Entity_Id; @@ -473,9 +479,11 @@ package body Sem_Ch12 is Inst : Node_Id) return Boolean; -- True if the instantiation Inst and the given freeze_node F_Node appear -- within the same declarative part, ignoring subunits, but with no inter- - -- vening subprograms or concurrent units. If true, the freeze node - -- of the instance can be placed after the freeze node of the parent, - -- which it itself an instance. + -- vening subprograms or concurrent units. Used to find the proper plave + -- for the freeze node of an instance, when the generic is declared in a + -- previous instance. If predicate is true, the freeze node of the instance + -- can be placed after the freeze node of the previous instance, Otherwise + -- it has to be placed at the end of the current declarative part. function In_Main_Context (E : Entity_Id) return Boolean; -- Check whether an instantiation is in the context of the main unit. @@ -729,6 +737,9 @@ package body Sem_Ch12 is -- before installing parents of generics, that are not visible for the -- actuals themselves. + function True_Parent (N : Node_Id) return Node_Id; + -- For a subunit, return parent of corresponding stub + procedure Valid_Default_Attribute (Nam : Entity_Id; Def : Node_Id); -- Verify that an attribute that appears as the default for a formal -- subprogram is a function or procedure with the correct profile. @@ -6762,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 -- ----------------------------- diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 40afb8b..a143dea 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -750,6 +750,10 @@ package body Sem_Prag is -- convention value in the specified entity or entities. On return -- C is the convention, Ent is the referenced entity. + procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id); + -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is + -- Name_Suppress for Disable and Name_Unsuppress for Enable. + procedure Process_Extended_Import_Export_Exception_Pragma (Arg_Internal : Node_Id; Arg_External : Node_Id; @@ -3566,6 +3570,35 @@ package body Sem_Prag is end if; end Process_Convention; + ---------------------------------------- + -- Process_Disable_Enable_Atomic_Sync -- + ---------------------------------------- + + procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id) is + begin + GNAT_Pragma; + Check_No_Identifiers; + Check_At_Most_N_Arguments (1); + + -- Modeled internally as + -- pragma Unsuppress (Atomic_Synchronization [,Entity]) + + Rewrite (N, + Make_Pragma (Loc, + Pragma_Identifier => + Make_Identifier (Loc, Nam), + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => + Make_Identifier (Loc, Name_Atomic_Synchronization))))); + + if Present (Arg1) then + Append_To (Pragma_Argument_Associations (N), New_Copy (Arg1)); + end if; + + Analyze (N); + end Process_Disable_Enable_Atomic_Sync; + ----------------------------------------------------- -- Process_Extended_Import_Export_Exception_Pragma -- ----------------------------------------------------- @@ -5305,8 +5338,15 @@ package body Sem_Prag is -- H.4(12). Restriction_Warnings never affects generated code -- so this is done only in the real restriction case. + -- Atomic_Synchronization is not a real check, so it is not + -- affected by this processing). + if R_Id = No_Exceptions and then not Warn then - Scope_Suppress := (others => True); + for J in Scope_Suppress'Range loop + if J /= Atomic_Synchronization then + Scope_Suppress (J) := True; + end if; + end loop; end if; -- Case of No_Dependence => unit-name. Note that the parser @@ -5418,6 +5458,17 @@ package body Sem_Prag is procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is begin + -- Check for error of trying to set atomic synchronization for + -- a non-atomic variable. + + if C = Atomic_Synchronization + and then not Is_Atomic (E) + then + Error_Msg_N + ("pragma & requires atomic variable", + Pragma_Identifier (Original_Node (N))); + end if; + Set_Checks_May_Be_Suppressed (E); if In_Package_Spec then @@ -5425,7 +5476,6 @@ package body Sem_Prag is (Entity => E, Check => C, Suppress => Suppress_Case); - else Push_Local_Suppress_Stack_Entry (Entity => E, @@ -5493,18 +5543,26 @@ package body Sem_Prag is -- the exception of Elaboration_Check, which is handled -- specially because of not wanting All_Checks to have the -- effect of deactivating static elaboration order processing. + -- Atomic_Synchronization is also not affected, since this is + -- not a real check. for J in Scope_Suppress'Range loop - if J /= Elaboration_Check then + if J /= Elaboration_Check + and then J /= Atomic_Synchronization + then Scope_Suppress (J) := Suppress_Case; end if; end loop; -- If not All_Checks, and predefined check, then set appropriate -- scope entry. Note that we will set Elaboration_Check if this - -- is explicitly specified. + -- is explicitly specified. Atomic_Synchronization is allowed + -- only if internally generated and entity is atomic. - elsif C in Predefined_Check_Id then + elsif C in Predefined_Check_Id + and then (not Comes_From_Source (N) + or else C /= Atomic_Synchronization) + then Scope_Suppress (C) := Suppress_Case; end if; @@ -6918,7 +6976,6 @@ package body Sem_Prag is Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1); end if; end Atomic_Components; - -------------------- -- Attach_Handler -- -------------------- @@ -7942,6 +7999,15 @@ package body Sem_Prag is Check_Arg_Is_Static_Expression (Arg3, Standard_Integer); Check_Arg_Is_Static_Expression (Arg4, Standard_Integer); + ------------------------------------ + -- Disable_Atomic_Synchronization -- + ------------------------------------ + + -- pragma Disable_Atomic_Synchronization [(Entity)]; + + when Pragma_Disable_Atomic_Synchronization => + Process_Disable_Enable_Atomic_Sync (Name_Suppress); + ------------------- -- Discard_Names -- ------------------- @@ -8364,6 +8430,15 @@ package body Sem_Prag is Source_Location); end Eliminate; + ----------------------------------- + -- Enable_Atomic_Synchronization -- + ----------------------------------- + + -- pragma Enable_Atomic_Synchronization [(Entity)]; + + when Pragma_Enable_Atomic_Synchronization => + Process_Disable_Enable_Atomic_Sync (Name_Unsuppress); + ------------ -- Export -- ------------ @@ -14152,16 +14227,12 @@ package body Sem_Prag is end; elsif Nkind (A) = N_Identifier then - if Chars (A) = Name_All_Checks then Set_Validity_Check_Options ("a"); - elsif Chars (A) = Name_On then Validity_Checks_On := True; - elsif Chars (A) = Name_Off then Validity_Checks_On := False; - end if; end if; end Validity_Checks; @@ -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; diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index 7543347..916e0ae 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -249,6 +249,15 @@ package body Sinfo is return Node3 (N); end Ancestor_Part; + function Atomic_Sync_Required + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Expanded_Name + or else NT (N).Nkind = N_Identifier); + return Flag14 (N); + end Atomic_Sync_Required; + function Array_Aggregate (N : Node_Id) return Node_Id is begin @@ -3309,6 +3318,15 @@ package body Sinfo is Set_Node3_With_Parent (N, Val); end Set_Ancestor_Part; + procedure Set_Atomic_Sync_Required + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Expanded_Name + or else NT (N).Nkind = N_Identifier); + Set_Flag14 (N, Val); + end Set_Atomic_Sync_Required; + procedure Set_Array_Aggregate (N : Node_Id; Val : Node_Id) is begin diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 3a03c04..0b5a52f 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -605,6 +605,12 @@ package Sinfo is -- Since the back end is expected to ignore generic templates, this is -- harmless. + -- Atomic_Sync_Required (Flag14-Sem) + -- This flag is set in an identifier or expanded name node if the + -- corresponding reference (or assignment when on the left side of + -- an assignment) requires atomic synchronization, as a result of + -- Atomic_Synchronization being enabled for the corresponding entity. + -- At_End_Proc (Node1) -- This field is present in an N_Handled_Sequence_Of_Statements node. -- It contains an identifier reference for the cleanup procedure to be @@ -1917,6 +1923,7 @@ package Sinfo is -- Associated_Node (Node4-Sem) -- Original_Discriminant (Node2-Sem) -- Redundant_Use (Flag13-Sem) + -- Atomic_Sync_Required (Flag14-Sem) -- Has_Private_View (Flag11-Sem) (set in generic units) -- plus fields for expression @@ -6982,8 +6989,9 @@ package Sinfo is -- Selector_Name (Node2) -- Entity (Node4-Sem) -- Associated_Node (Node4-Sem) - -- Redundant_Use (Flag13-Sem) -- Has_Private_View (Flag11-Sem) set in generic units. + -- Redundant_Use (Flag13-Sem) + -- Atomic_Sync_Required (Flag14-Sem) -- plus fields for expression ----------------------------- @@ -8121,6 +8129,9 @@ package Sinfo is function Ancestor_Part (N : Node_Id) return Node_Id; -- Node3 + function Atomic_Sync_Required + (N : Node_Id) return Boolean; -- Flag14 + function Array_Aggregate (N : Node_Id) return Node_Id; -- Node3 @@ -9096,6 +9107,9 @@ package Sinfo is procedure Set_Ancestor_Part (N : Node_Id; Val : Node_Id); -- Node3 + procedure Set_Atomic_Sync_Required + (N : Node_Id; Val : Boolean := True); -- Flag14 + procedure Set_Array_Aggregate (N : Node_Id; Val : Node_Id); -- Node3 @@ -11764,6 +11778,7 @@ package Sinfo is pragma Inline (All_Present); pragma Inline (Alternatives); pragma Inline (Ancestor_Part); + pragma Inline (Atomic_Sync_Required); pragma Inline (Array_Aggregate); pragma Inline (Aspect_Rep_Item); pragma Inline (Assignment_OK); @@ -12086,6 +12101,7 @@ package Sinfo is pragma Inline (Set_All_Present); pragma Inline (Set_Alternatives); pragma Inline (Set_Ancestor_Part); + pragma Inline (Set_Atomic_Sync_Required); pragma Inline (Set_Array_Aggregate); pragma Inline (Set_Aspect_Rep_Item); pragma Inline (Set_Assignment_OK); diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index f7c441e..3ed2a66 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -361,10 +361,12 @@ package Snames is Name_Debug_Policy : constant Name_Id := N + $; -- GNAT Name_Detect_Blocking : constant Name_Id := N + $; -- Ada 05 Name_Default_Storage_Pool : constant Name_Id := N + $; -- Ada 12 + Name_Disable_Atomic_Synchronization : constant Name_Id := N + $; -- GNAT Name_Discard_Names : constant Name_Id := N + $; Name_Dispatching_Domain : constant Name_Id := N + $; -- Ada 12 Name_Elaboration_Checks : constant Name_Id := N + $; -- GNAT Name_Eliminate : constant Name_Id := N + $; -- GNAT + Name_Enable_Atomic_Synchronization : constant Name_Id := N + $; -- GNAT Name_Extend_System : constant Name_Id := N + $; -- GNAT Name_Extensions_Allowed : constant Name_Id := N + $; -- GNAT Name_External_Name_Casing : constant Name_Id := N + $; -- GNAT @@ -941,10 +943,14 @@ package Snames is -- Names of recognized checks for pragma Suppress + -- Note: the name Atomic_Synchronization can only be specified internally + -- as a result of using pragma Enable/Disable_Atomic_Synchronization. + First_Check_Name : constant Name_Id := N + $; Name_Access_Check : constant Name_Id := N + $; Name_Accessibility_Check : constant Name_Id := N + $; Name_Alignment_Check : constant Name_Id := N + $; -- GNAT + Name_Atomic_Synchronization : constant Name_Id := N + $; -- GNAT Name_Discriminant_Check : constant Name_Id := N + $; Name_Division_Check : constant Name_Id := N + $; Name_Elaboration_Check : constant Name_Id := N + $; @@ -1532,10 +1538,12 @@ package Snames is Pragma_Debug_Policy, Pragma_Detect_Blocking, Pragma_Default_Storage_Pool, + Pragma_Disable_Atomic_Synchronization, Pragma_Discard_Names, Pragma_Dispatching_Domain, Pragma_Elaboration_Checks, Pragma_Eliminate, + Pragma_Enable_Atomic_Synchronization, Pragma_Extend_System, Pragma_Extensions_Allowed, Pragma_External_Name_Casing, diff --git a/gcc/ada/switch-c.adb b/gcc/ada/switch-c.adb index 58d4e13..e900faa 100644 --- a/gcc/ada/switch-c.adb +++ b/gcc/ada/switch-c.adb @@ -440,6 +440,11 @@ package body Switch.C is -- Ptr := Ptr + 1; -- Generate_SCIL := True; + -- -gnated switch (disable atomic synchronization) + + when 'd' => + Suppress_Options (Atomic_Synchronization) := True; + -- -gnateD switch (preprocessing symbol definition) when 'D' => @@ -743,10 +748,14 @@ package body Switch.C is -- Set all specific options as well as All_Checks in the -- Suppress_Options array, excluding Elaboration_Check, -- since this is treated specially because we do not want - -- -gnatp to disable static elaboration processing. + -- -gnatp to disable static elaboration processing. Also + -- exclude Atomic_Synchronization, since this is not a real + -- check. for J in Suppress_Options'Range loop - if J /= Elaboration_Check then + if J /= Elaboration_Check + and then J /= Atomic_Synchronization + then Suppress_Options (J) := True; end if; end loop; diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads index 0422d82..05d3dbe 100644 --- a/gcc/ada/types.ads +++ b/gcc/ada/types.ads @@ -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 - - 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; diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index 146b0c0..2c20136 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -172,6 +172,11 @@ begin Write_Switch_Char ("ec=?"); Write_Line ("Specify configuration pragmas file, e.g. -gnatec=/x/f.adc"); + -- Line for -gnated switch + + Write_Switch_Char ("ed"); + Write_Line ("Disable synchronization of atomic variables"); + -- Line for -gnateD switch Write_Switch_Char ("eD?"); diff --git a/gcc/ada/warnsw.adb b/gcc/ada/warnsw.adb index 78b36eb..703ce0c 100644 --- a/gcc/ada/warnsw.adb +++ b/gcc/ada/warnsw.adb @@ -67,6 +67,7 @@ package body Warnsw is Warn_On_All_Unread_Out_Parameters := True; Warn_On_Assertion_Failure := True; Warn_On_Assumed_Low_Bound := True; + Warn_On_Atomic_Synchronization := True; Warn_On_Bad_Fixed_Value := True; Warn_On_Biased_Representation := True; Warn_On_Constant := True; @@ -120,6 +121,12 @@ package body Warnsw is when 'M' => Warn_On_Suspicious_Modulus_Value := False; + when 'n' => + Warn_On_Atomic_Synchronization := True; + + when 'N' => + Warn_On_Atomic_Synchronization := False; + when 'o' => Warn_On_All_Unread_Out_Parameters := True; @@ -202,6 +209,7 @@ package body Warnsw is Warn_On_All_Unread_Out_Parameters := False; Warn_On_Assertion_Failure := True; Warn_On_Assumed_Low_Bound := True; + Warn_On_Atomic_Synchronization := False; Warn_On_Bad_Fixed_Value := True; Warn_On_Biased_Representation := True; Warn_On_Constant := True; |