From a3a76ccc41dd9d4d6e05bdcc53a81cc9c98d6ccc Mon Sep 17 00:00:00 2001 From: charlet Date: Tue, 6 Sep 2011 10:35:25 +0000 Subject: [PATCH] 2011-09-06 Ed Schonberg * exp_ch6.adb (Expand_Inlined_Call): Fix use of uninitialized variable for type of return value when return type is unconstrained and context is an assignment. 2011-09-06 Ed Schonberg * sem_ch8.adb (Check_Class_Wide_Actual): Do not generate body of class-wide operation if expansion is not enabled. 2011-09-06 Eric Botcazou * checks.adb (Apply_Scalar_Range_Check): Deal with access type prefix. 2011-09-06 Yannick Moy * sem_ch13.adb (Analyze_Aspect_Specifications, case Aspect_Invariant): Do not issue error at this point on illegal pragma placement, as this is checked later on when analyzing the corresponding pragma. * sem_prag.adb (Error_Pragma_Arg_Alternate_Name): New procedure similar to Error_Pragma_Arg, except the source name of the aspect/pragma to use in warnings may be equal to parameter Alt_Name (Analyze_Pragma, case Pragma_Invariant): refine error message to distinguish source name of pragma/aspect, and whether the illegality resides in the type being public, or being private without a public declaration 2011-09-06 Thomas Quinot * g-socket.adb (Check_For_Fd_Set): On Windows, no need for bitmap size check (fd_set is implemented differently on that platform). 2011-09-06 Thomas Quinot * s-taprop-vxworks.adb, s-taprop-tru64.adb, s-taprop-vms.adb, s-tpoaal.adb, s-taprop-mingw.adb, s-taprop-linux.adb, s-taprop-solaris.adb, s-taprop-irix.adb, s-taprop.ads, s-taprop-hpux-dce.adb, s-taprop-dummy.adb, s-taprop-posix.adb (ATCB_Allocation): New subpackage of System.Tasking.Primitive_Operations, shared across all targets with full tasking runtime. (ATCB_Allocation.New_ATCB): Moved there (from target specific s-taprop bodies). (ATCB_Allocation.Free_ATCB): New subprogram. Deallocate an ATCB, taking care of establishing a local temporary ATCB if the one being deallocated is Self, to avoid a reference to the freed ATCB in Abort_Undefer. 2011-09-06 Thomas Quinot * s-tassta.adb, s-taskin.ads (Free_Task): If the task is not terminated, mark it for deallocation upon termination. (Terminate_Task): Call Free_Task again if the task is marked for automatic deallocation upon termination. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@178582 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/ChangeLog | 58 +++++++++++++++ gcc/ada/checks.adb | 3 + gcc/ada/exp_ch6.adb | 72 ++++++++++--------- gcc/ada/g-socket.adb | 40 +++++++---- gcc/ada/s-taprop-dummy.adb | 16 ++--- gcc/ada/s-taprop-hpux-dce.adb | 30 +++----- gcc/ada/s-taprop-irix.adb | 30 +++----- gcc/ada/s-taprop-linux.adb | 30 +++----- gcc/ada/s-taprop-mingw.adb | 29 +++----- gcc/ada/s-taprop-posix.adb | 30 +++----- gcc/ada/s-taprop-solaris.adb | 35 +++------ gcc/ada/s-taprop-tru64.adb | 31 +++----- gcc/ada/s-taprop-vms.adb | 30 +++----- gcc/ada/s-taprop-vxworks.adb | 30 +++----- gcc/ada/s-taprop.ads | 21 +++++- gcc/ada/s-taskin.ads | 6 ++ gcc/ada/s-tassta.adb | 18 +++-- gcc/ada/s-tpoaal.adb | 79 ++++++++++++++++++++ gcc/ada/sem_ch13.adb | 22 +----- gcc/ada/sem_ch8.adb | 7 +- gcc/ada/sem_prag.adb | 162 +++++++++++++++++++++++++++--------------- 21 files changed, 442 insertions(+), 337 deletions(-) create mode 100644 gcc/ada/s-tpoaal.adb diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 270e0bf..0b5216f 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,61 @@ +2011-09-06 Ed Schonberg + + * exp_ch6.adb (Expand_Inlined_Call): Fix use of uninitialized + variable for type of return value when return type is + unconstrained and context is an assignment. + +2011-09-06 Ed Schonberg + + * sem_ch8.adb (Check_Class_Wide_Actual): Do not generate body of + class-wide operation if expansion is not enabled. + +2011-09-06 Eric Botcazou + + * checks.adb (Apply_Scalar_Range_Check): Deal with access + type prefix. + +2011-09-06 Yannick Moy + + * sem_ch13.adb (Analyze_Aspect_Specifications, case + Aspect_Invariant): Do not issue error at this point on illegal + pragma placement, as this is checked later on when analyzing + the corresponding pragma. + * sem_prag.adb (Error_Pragma_Arg_Alternate_Name): New procedure + similar to Error_Pragma_Arg, except the source name of the + aspect/pragma to use in warnings may be equal to parameter + Alt_Name (Analyze_Pragma, case Pragma_Invariant): refine error + message to distinguish source name of pragma/aspect, and whether + the illegality resides in the type being public, or being private + without a public declaration + +2011-09-06 Thomas Quinot + + * g-socket.adb (Check_For_Fd_Set): On Windows, no need for bitmap + size check (fd_set is implemented differently on that platform). + +2011-09-06 Thomas Quinot + + * s-taprop-vxworks.adb, s-taprop-tru64.adb, s-taprop-vms.adb, + s-tpoaal.adb, s-taprop-mingw.adb, s-taprop-linux.adb, + s-taprop-solaris.adb, s-taprop-irix.adb, s-taprop.ads, + s-taprop-hpux-dce.adb, s-taprop-dummy.adb, s-taprop-posix.adb + (ATCB_Allocation): New subpackage of + System.Tasking.Primitive_Operations, shared across all targets + with full tasking runtime. + (ATCB_Allocation.New_ATCB): Moved there (from target specific + s-taprop bodies). + (ATCB_Allocation.Free_ATCB): New subprogram. Deallocate an ATCB, + taking care of establishing a local temporary ATCB if the one + being deallocated is Self, to avoid a reference to the freed + ATCB in Abort_Undefer. + +2011-09-06 Thomas Quinot + + * s-tassta.adb, s-taskin.ads (Free_Task): If the task is not + terminated, mark it for deallocation upon termination. + (Terminate_Task): Call Free_Task again if the task is marked + for automatic deallocation upon termination. + 2011-09-06 Robert Dewar * a-cbprqu.ads, a-cbsyqu.ads, a-cuprqu.ads, a-cusyqu.ads, diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index cb07771..336b144 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -1877,6 +1877,9 @@ package body Checks is if Is_Subscr_Ref then Arr := Prefix (Parnt); Arr_Typ := Get_Actual_Subtype_If_Available (Arr); + if Is_Access_Type (Arr_Typ) then + Arr_Typ := Directly_Designated_Type (Arr_Typ); + end if; end if; if not Do_Range_Check (Expr) then diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index f5765a3..b300389 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -3740,8 +3740,15 @@ package body Exp_Ch6 is New_A : Node_Id; Num_Ret : Int := 0; Ret_Type : Entity_Id; - Targ : Node_Id; - Targ1 : Node_Id; + + Targ : Node_Id; + -- The target of the call. If context is an assignment statement then + -- this is the left-hand side of the assignment. else it is a temporary + -- to which the return value is assigned prior to rewriting the call. + + Targ1 : Node_Id; + -- A separate target used when the return type is unconstrained + Temp : Entity_Id; Temp_Typ : Entity_Id; @@ -3749,8 +3756,8 @@ package body Exp_Ch6 is -- Entity in declaration in an extended_return_statement Is_Unc : constant Boolean := - Is_Array_Type (Etype (Subp)) - and then not Is_Constrained (Etype (Subp)); + Is_Array_Type (Etype (Subp)) + and then not Is_Constrained (Etype (Subp)); -- If the type returned by the function is unconstrained and the call -- can be inlined, special processing is required. @@ -3841,6 +3848,7 @@ package body Exp_Ch6 is Rewrite (N, New_Copy (A)); end if; end if; + return Skip; elsif Is_Entity_Name (N) @@ -3891,8 +3899,8 @@ package body Exp_Ch6 is if Nkind_In (Expression (N), N_Aggregate, N_Null) then Ret := Make_Qualified_Expression (Sloc (N), - Subtype_Mark => New_Occurrence_Of (Ret_Type, Sloc (N)), - Expression => Relocate_Node (Expression (N))); + Subtype_Mark => New_Occurrence_Of (Ret_Type, Sloc (N)), + Expression => Relocate_Node (Expression (N))); else Ret := Unchecked_Convert_To @@ -3902,12 +3910,12 @@ package body Exp_Ch6 is if Nkind (Targ) = N_Defining_Identifier then Rewrite (N, Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Targ, Loc), + Name => New_Occurrence_Of (Targ, Loc), Expression => Ret)); else Rewrite (N, Make_Assignment_Statement (Loc, - Name => New_Copy (Targ), + Name => New_Copy (Targ), Expression => Ret)); end if; @@ -3915,19 +3923,17 @@ package body Exp_Ch6 is if Present (Exit_Lab) then Insert_After (N, - Make_Goto_Statement (Loc, - Name => New_Copy (Lab_Id))); + Make_Goto_Statement (Loc, Name => New_Copy (Lab_Id))); end if; end if; return OK; - elsif Nkind (N) = N_Extended_Return_Statement then - - -- An extended return becomes a block whose first statement is - -- the assignment of the initial expression of the return object - -- to the target of the call itself. + -- An extended return becomes a block whose first statement is the + -- assignment of the initial expression of the return object to the + -- target of the call itself. + elsif Nkind (N) = N_Extended_Return_Statement then declare Return_Decl : constant Entity_Id := First (Return_Object_Declarations (N)); @@ -3940,12 +3946,12 @@ package body Exp_Ch6 is if Nkind (Targ) = N_Defining_Identifier then Assign := Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Targ, Loc), + Name => New_Occurrence_Of (Targ, Loc), Expression => Expression (Return_Decl)); else Assign := Make_Assignment_Statement (Loc, - Name => New_Copy (Targ), + Name => New_Copy (Targ), Expression => Expression (Return_Decl)); end if; @@ -4011,7 +4017,6 @@ package body Exp_Ch6 is and then Nkind (Fst) = N_Assignment_Statement and then No (Next (Fst)) then - -- The function call may have been rewritten as the temporary -- that holds the result of the call, in which case remove the -- now useless declaration. @@ -4080,6 +4085,7 @@ package body Exp_Ch6 is procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id) is HSS : constant Node_Id := Handled_Statement_Sequence (Blk); + begin -- If there is a transient scope for N, this will be the scope of the -- actions for N, and the statements in Blk need to be within this @@ -4161,7 +4167,6 @@ package body Exp_Ch6 is -- Start of processing for Expand_Inlined_Call begin - -- Check for an illegal attempt to inline a recursive procedure. If the -- subprogram has parameters this is detected when trying to supply a -- binding for parameters that already have one. For parameterless @@ -4219,8 +4224,12 @@ package body Exp_Ch6 is -- expansion of an extended return, the left-hand side provides bounds -- even if the return type is unconstrained. - if Is_Unc and then Nkind (Parent (N)) /= N_Assignment_Statement then - Targ1 := Defining_Identifier (First (Declarations (Blk))); + if Is_Unc then + if Nkind (Parent (N)) /= N_Assignment_Statement then + Targ1 := Defining_Identifier (First (Declarations (Blk))); + else + Targ1 := Name (Parent (N)); + end if; end if; -- If this is a derived function, establish the proper return type @@ -4250,8 +4259,7 @@ package body Exp_Ch6 is if Is_Class_Wide_Type (Etype (F)) or else (Is_Access_Type (Etype (F)) - and then - Is_Class_Wide_Type (Designated_Type (Etype (F)))) + and then Is_Class_Wide_Type (Designated_Type (Etype (F)))) then Temp_Typ := Etype (F); @@ -4259,7 +4267,6 @@ package body Exp_Ch6 is and then Etype (F) /= Base_Type (Etype (F)) then Temp_Typ := Etype (F); - else Temp_Typ := Etype (A); end if; @@ -4285,13 +4292,13 @@ package body Exp_Ch6 is or else (Nkind_In (A, N_Real_Literal, - N_Integer_Literal, - N_Character_Literal) - and then not Address_Taken (F)) + N_Integer_Literal, + N_Character_Literal) + and then not Address_Taken (F)) then if Etype (F) /= Etype (A) then Set_Renamed_Object - (F, Unchecked_Convert_To (Etype (F), Relocate_Node (A))); + (F, Unchecked_Convert_To (Etype (F), Relocate_Node (A))); else Set_Renamed_Object (F, A); end if; @@ -4337,9 +4344,9 @@ package body Exp_Ch6 is if Ekind (F) = E_In_Parameter and then not Is_By_Reference_Type (Etype (A)) and then - (not Is_Array_Type (Etype (A)) - or else not Is_Object_Reference (A) - or else Is_Bit_Packed_Array (Etype (A))) + (not Is_Array_Type (Etype (A)) + or else not Is_Object_Reference (A) + or else Is_Bit_Packed_Array (Etype (A))) then Decl := Make_Object_Declaration (Loc, @@ -4698,7 +4705,6 @@ package body Exp_Ch6 is Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id); -- Create the temporary, generate: - -- -- Local_Id : Ptr_Typ; Local_Id := Make_Temporary (Loc, 'T'); @@ -4710,7 +4716,6 @@ package body Exp_Ch6 is New_Reference_To (Ptr_Typ, Loc))); -- Allocate the object, generate: - -- -- Local_Id := ; Append_To (Stmts, @@ -4758,7 +4763,6 @@ package body Exp_Ch6 is end; -- For all other cases, generate: - -- -- Temp_Id := ; else diff --git a/gcc/ada/g-socket.adb b/gcc/ada/g-socket.adb index 7fc3e5e..59e63bd 100644 --- a/gcc/ada/g-socket.adb +++ b/gcc/ada/g-socket.adb @@ -198,7 +198,7 @@ package body GNAT.Sockets is procedure Check_For_Fd_Set (Fd : Socket_Type); pragma Inline (Check_For_Fd_Set); -- Raise Constraint_Error if Fd is less than 0 or greater than or equal to - -- FD_SETSIZE. + -- FD_SETSIZE, on platforms where fd_set is a bitmap. -- Types needed for Datagram_Socket_Stream_Type @@ -468,6 +468,32 @@ package body GNAT.Sockets is end if; end Bind_Socket; + ---------------------- + -- Check_For_Fd_Set -- + ---------------------- + + procedure Check_For_Fd_Set (Fd : Socket_Type) is + use SOSC; + begin + -- On Windows, fd_set is a FD_SETSIZE array of socket ids: + -- no check required. Warnings suppressed because condition + -- is known at compile time. + + pragma Warnings (Off); + if Target_OS = Windows then + pragma Warnings (On); + + return; + + -- On other platforms, fd_set is an FD_SETSIZE bitmap: check + -- that Fd is within range (otherwise behaviour is undefined). + + elsif Fd < 0 or else Fd >= SOSC.FD_SETSIZE then + raise Constraint_Error with "invalid value for socket set: " + & Image (Fd); + end if; + end Check_For_Fd_Set; + -------------------- -- Check_Selector -- -------------------- @@ -573,18 +599,6 @@ package body GNAT.Sockets is Narrow (E_Socket_Set); end Check_Selector; - ---------------------- - -- Check_For_Fd_Set -- - ---------------------- - - procedure Check_For_Fd_Set (Fd : Socket_Type) is - begin - if Fd < 0 or else Fd >= SOSC.FD_SETSIZE then - raise Constraint_Error with "invalid value for socket set: " - & Image (Fd); - end if; - end Check_For_Fd_Set; - ----------- -- Clear -- ----------- diff --git a/gcc/ada/s-taprop-dummy.adb b/gcc/ada/s-taprop-dummy.adb index 88f4571..f6e9a64 100644 --- a/gcc/ada/s-taprop-dummy.adb +++ b/gcc/ada/s-taprop-dummy.adb @@ -46,6 +46,13 @@ package body System.Task_Primitives.Operations is pragma Warnings (Off); -- Turn off warnings since so many unreferenced parameters + ---------------------------------- + -- ATCB allocation/deallocation -- + ---------------------------------- + + package body ATCB_Allocation is separate; + -- The body of this package is shared across several targets + ---------------- -- Abort_Task -- ---------------- @@ -252,15 +259,6 @@ package body System.Task_Primitives.Operations is return 0.0; end Monotonic_Clock; - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - --------------- -- Read_Lock -- --------------- diff --git a/gcc/ada/s-taprop-hpux-dce.adb b/gcc/ada/s-taprop-hpux-dce.adb index 6bc89fc..346de43 100644 --- a/gcc/ada/s-taprop-hpux-dce.adb +++ b/gcc/ada/s-taprop-hpux-dce.adb @@ -39,7 +39,6 @@ pragma Polling (Off); -- operations. It causes infinite loops and other problems. with Ada.Unchecked_Conversion; -with Ada.Unchecked_Deallocation; with Interfaces.C; @@ -130,6 +129,13 @@ package body System.Task_Primitives.Operations is package body Specific is separate; -- The body of this package is target specific + ---------------------------------- + -- ATCB allocation/deallocation -- + ---------------------------------- + + package body ATCB_Allocation is separate; + -- The body of this package is shared across several targets + --------------------------------- -- Support for foreign threads -- --------------------------------- @@ -696,15 +702,6 @@ package body System.Task_Primitives.Operations is Specific.Set (Self_ID); end Enter_Task; - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - ------------------- -- Is_Valid_Task -- ------------------- @@ -839,12 +836,7 @@ package body System.Task_Primitives.Operations is ------------------ procedure Finalize_TCB (T : Task_Id) is - Result : Interfaces.C.int; - Tmp : Task_Id := T; - Is_Self : constant Boolean := T = Self; - - procedure Free is new - Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + Result : Interfaces.C.int; begin if not Single_Lock then @@ -859,11 +851,7 @@ package body System.Task_Primitives.Operations is Known_Tasks (T.Known_Tasks_Index) := null; end if; - Free (Tmp); - - if Is_Self then - Specific.Set (null); - end if; + ATCB_Allocation.Free_ATCB (T); end Finalize_TCB; --------------- diff --git a/gcc/ada/s-taprop-irix.adb b/gcc/ada/s-taprop-irix.adb index bfa425e..2646904 100644 --- a/gcc/ada/s-taprop-irix.adb +++ b/gcc/ada/s-taprop-irix.adb @@ -39,7 +39,6 @@ pragma Polling (Off); -- operations. It causes infinite loops and other problems. with Ada.Unchecked_Conversion; -with Ada.Unchecked_Deallocation; with Interfaces.C; @@ -127,6 +126,13 @@ package body System.Task_Primitives.Operations is package body Specific is separate; -- The body of this package is target specific + ---------------------------------- + -- ATCB allocation/deallocation -- + ---------------------------------- + + package body ATCB_Allocation is separate; + -- The body of this package is shared across several targets + --------------------------------- -- Support for foreign threads -- --------------------------------- @@ -699,15 +705,6 @@ package body System.Task_Primitives.Operations is end if; end Enter_Task; - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - ------------------- -- Is_Valid_Task -- ------------------- @@ -901,12 +898,7 @@ package body System.Task_Primitives.Operations is ------------------ procedure Finalize_TCB (T : Task_Id) is - Result : Interfaces.C.int; - Tmp : Task_Id := T; - Is_Self : constant Boolean := T = Self; - - procedure Free is new - Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + Result : Interfaces.C.int; begin if not Single_Lock then @@ -921,11 +913,7 @@ package body System.Task_Primitives.Operations is Known_Tasks (T.Known_Tasks_Index) := null; end if; - Free (Tmp); - - if Is_Self then - Specific.Set (null); - end if; + ATCB_Allocation.Free_ATCB (T); end Finalize_TCB; --------------- diff --git a/gcc/ada/s-taprop-linux.adb b/gcc/ada/s-taprop-linux.adb index 8d381ab..84c663a 100644 --- a/gcc/ada/s-taprop-linux.adb +++ b/gcc/ada/s-taprop-linux.adb @@ -38,8 +38,6 @@ pragma Polling (Off); -- Turn off polling, we do not want ATC polling to take place during tasking -- operations. It causes infinite loops and other problems. -with Ada.Unchecked_Deallocation; - with Interfaces.C; with System.Task_Info; @@ -137,6 +135,13 @@ package body System.Task_Primitives.Operations is package body Specific is separate; -- The body of this package is target specific + ---------------------------------- + -- ATCB allocation/deallocation -- + ---------------------------------- + + package body ATCB_Allocation is separate; + -- The body of this package is shared across several targets + --------------------------------- -- Support for foreign threads -- --------------------------------- @@ -731,15 +736,6 @@ package body System.Task_Primitives.Operations is end if; end Enter_Task; - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - ------------------- -- Is_Valid_Task -- ------------------- @@ -978,12 +974,7 @@ package body System.Task_Primitives.Operations is ------------------ procedure Finalize_TCB (T : Task_Id) is - Result : Interfaces.C.int; - Tmp : Task_Id := T; - Is_Self : constant Boolean := T = Self; - - procedure Free is new - Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + Result : Interfaces.C.int; begin if not Single_Lock then @@ -999,11 +990,8 @@ package body System.Task_Primitives.Operations is end if; SC.Invalidate_Stack_Cache (T.Common.Compiler_Data.Pri_Stack_Info'Access); - Free (Tmp); - if Is_Self then - Specific.Set (null); - end if; + ATCB_Allocation.Free_ATCB (T); end Finalize_TCB; --------------- diff --git a/gcc/ada/s-taprop-mingw.adb b/gcc/ada/s-taprop-mingw.adb index ab66a88..d26568f 100644 --- a/gcc/ada/s-taprop-mingw.adb +++ b/gcc/ada/s-taprop-mingw.adb @@ -38,8 +38,6 @@ pragma Polling (Off); -- Turn off polling, we do not want ATC polling to take place during tasking -- operations. It causes infinite loops and other problems. -with Ada.Unchecked_Deallocation; - with Interfaces.C; with Interfaces.C.Strings; @@ -176,6 +174,13 @@ package body System.Task_Primitives.Operations is end Specific; + ---------------------------------- + -- ATCB allocation/deallocation -- + ---------------------------------- + + package body ATCB_Allocation is separate; + -- The body of this package is shared across several targets + --------------------------------- -- Support for foreign threads -- --------------------------------- @@ -820,15 +825,6 @@ package body System.Task_Primitives.Operations is Self_ID.Common.Compiler_Data.Pri_Stack_Info.Limit'Address); end Enter_Task; - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - ------------------- -- Is_Valid_Task -- ------------------- @@ -987,13 +983,8 @@ package body System.Task_Primitives.Operations is ------------------ procedure Finalize_TCB (T : Task_Id) is - Self_ID : Task_Id := T; Result : DWORD; Succeeded : BOOL; - Is_Self : constant Boolean := T = Self; - - procedure Free is new - Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); begin if not Single_Lock then @@ -1017,11 +1008,7 @@ package body System.Task_Primitives.Operations is pragma Assert (Succeeded = Win32.TRUE); end if; - Free (Self_ID); - - if Is_Self then - Specific.Set (null); - end if; + ATCB_Allocation.Free_ATCB (T); end Finalize_TCB; --------------- diff --git a/gcc/ada/s-taprop-posix.adb b/gcc/ada/s-taprop-posix.adb index 440d941..eb1b771 100644 --- a/gcc/ada/s-taprop-posix.adb +++ b/gcc/ada/s-taprop-posix.adb @@ -45,7 +45,6 @@ pragma Polling (Off); -- operations. It causes infinite loops and other problems. with Ada.Unchecked_Conversion; -with Ada.Unchecked_Deallocation; with Interfaces.C; @@ -144,6 +143,13 @@ package body System.Task_Primitives.Operations is package body Specific is separate; -- The body of this package is target specific + ---------------------------------- + -- ATCB allocation/deallocation -- + ---------------------------------- + + package body ATCB_Allocation is separate; + -- The body of this package is shared across several targets + --------------------------------- -- Support for foreign threads -- --------------------------------- @@ -782,15 +788,6 @@ package body System.Task_Primitives.Operations is end if; end Enter_Task; - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - ------------------- -- Is_Valid_Task -- ------------------- @@ -1000,12 +997,7 @@ package body System.Task_Primitives.Operations is ------------------ procedure Finalize_TCB (T : Task_Id) is - Result : Interfaces.C.int; - Tmp : Task_Id := T; - Is_Self : constant Boolean := T = Self; - - procedure Free is new - Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + Result : Interfaces.C.int; begin if not Single_Lock then @@ -1020,11 +1012,7 @@ package body System.Task_Primitives.Operations is Known_Tasks (T.Known_Tasks_Index) := null; end if; - Free (Tmp); - - if Is_Self then - Specific.Set (null); - end if; + ATCB_Allocation.Free_ATCB (T); end Finalize_TCB; --------------- diff --git a/gcc/ada/s-taprop-solaris.adb b/gcc/ada/s-taprop-solaris.adb index 421c60e..b5fe1ee 100644 --- a/gcc/ada/s-taprop-solaris.adb +++ b/gcc/ada/s-taprop-solaris.adb @@ -38,8 +38,6 @@ pragma Polling (Off); -- Turn off polling, we do not want ATC polling to take place during tasking -- operations. It causes infinite loops and other problems. -with Ada.Unchecked_Deallocation; - with Interfaces.C; with System.Multiprocessors; @@ -226,6 +224,13 @@ package body System.Task_Primitives.Operations is package body Specific is separate; -- The body of this package is target specific + ---------------------------------- + -- ATCB allocation/deallocation -- + ---------------------------------- + + package body ATCB_Allocation is separate; + -- The body of this package is shared across several targets + --------------------------------- -- Support for foreign threads -- --------------------------------- @@ -868,26 +873,15 @@ package body System.Task_Primitives.Operations is procedure Enter_Task (Self_ID : Task_Id) is begin Self_ID.Common.LL.Thread := thr_self; - - Self_ID.Common.LL.LWP := lwp_self; + Self_ID.Common.LL.LWP := lwp_self; Set_Task_Affinity (Self_ID); - Specific.Set (Self_ID); -- We need the above code even if we do direct fetch of Task_Id in Self -- for the main task on Sun, x86 Solaris and for gcc 2.7.2. end Enter_Task; - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - ------------------- -- Is_Valid_Task -- ------------------- @@ -1032,12 +1026,7 @@ package body System.Task_Primitives.Operations is ------------------ procedure Finalize_TCB (T : Task_Id) is - Result : Interfaces.C.int; - Tmp : Task_Id := T; - Is_Self : constant Boolean := T = Self; - - procedure Free is new - Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + Result : Interfaces.C.int; begin T.Common.LL.Thread := Null_Thread_Id; @@ -1054,11 +1043,7 @@ package body System.Task_Primitives.Operations is Known_Tasks (T.Known_Tasks_Index) := null; end if; - Free (Tmp); - - if Is_Self then - Specific.Set (null); - end if; + ATCB_Allocation.Free_ATCB (T); end Finalize_TCB; --------------- diff --git a/gcc/ada/s-taprop-tru64.adb b/gcc/ada/s-taprop-tru64.adb index 2fe2441..b0b727d 100644 --- a/gcc/ada/s-taprop-tru64.adb +++ b/gcc/ada/s-taprop-tru64.adb @@ -38,8 +38,6 @@ pragma Polling (Off); -- Turn off polling, we do not want ATC polling to take place during tasking -- operations. It causes infinite loops and other problems. -with Ada.Unchecked_Deallocation; - with Interfaces; with Interfaces.C; @@ -127,6 +125,13 @@ package body System.Task_Primitives.Operations is package body Specific is separate; -- The body of this package is target specific + ---------------------------------- + -- ATCB allocation/deallocation -- + ---------------------------------- + + package body ATCB_Allocation is separate; + -- The body of this package is shared across several targets + --------------------------------- -- Support for foreign threads -- --------------------------------- @@ -695,15 +700,6 @@ package body System.Task_Primitives.Operations is Specific.Set (Self_ID); end Enter_Task; - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - ------------------- -- Is_Valid_Task -- ------------------- @@ -930,12 +926,7 @@ package body System.Task_Primitives.Operations is ------------------ procedure Finalize_TCB (T : Task_Id) is - Result : Interfaces.C.int; - Tmp : Task_Id := T; - Is_Self : constant Boolean := T = Self; - - procedure Free is new - Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + Result : Interfaces.C.int; begin if not Single_Lock then @@ -950,11 +941,7 @@ package body System.Task_Primitives.Operations is Known_Tasks (T.Known_Tasks_Index) := null; end if; - Free (Tmp); - - if Is_Self then - Specific.Set (null); - end if; + ATCB_Allocation.Free_ATCB (T); end Finalize_TCB; --------------- diff --git a/gcc/ada/s-taprop-vms.adb b/gcc/ada/s-taprop-vms.adb index 1cfafbb..92b6023 100644 --- a/gcc/ada/s-taprop-vms.adb +++ b/gcc/ada/s-taprop-vms.adb @@ -39,7 +39,6 @@ pragma Polling (Off); -- operations. It causes infinite loops and other problems. with Ada.Unchecked_Conversion; -with Ada.Unchecked_Deallocation; with Interfaces.C; @@ -114,6 +113,13 @@ package body System.Task_Primitives.Operations is package body Specific is separate; -- The body of this package is target specific + ---------------------------------- + -- ATCB allocation/deallocation -- + ---------------------------------- + + package body ATCB_Allocation is separate; + -- The body of this package is shared across several targets + --------------------------------- -- Support for foreign threads -- --------------------------------- @@ -680,15 +686,6 @@ package body System.Task_Primitives.Operations is Specific.Set (Self_ID); end Enter_Task; - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - ------------------- -- Is_Valid_Task -- ------------------- @@ -839,12 +836,7 @@ package body System.Task_Primitives.Operations is ------------------ procedure Finalize_TCB (T : Task_Id) is - Result : Interfaces.C.int; - Tmp : Task_Id := T; - Is_Self : constant Boolean := T = Self; - - procedure Free is new - Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + Result : Interfaces.C.int; begin if not Single_Lock then @@ -859,11 +851,7 @@ package body System.Task_Primitives.Operations is Known_Tasks (T.Known_Tasks_Index) := null; end if; - Free (Tmp); - - if Is_Self then - Specific.Set (null); - end if; + ATCB_Allocation.Free_ATCB (T); end Finalize_TCB; --------------- diff --git a/gcc/ada/s-taprop-vxworks.adb b/gcc/ada/s-taprop-vxworks.adb index ae28649..6b3c35e 100644 --- a/gcc/ada/s-taprop-vxworks.adb +++ b/gcc/ada/s-taprop-vxworks.adb @@ -39,7 +39,6 @@ pragma Polling (Off); -- operations. It causes infinite loops and other problems. with Ada.Unchecked_Conversion; -with Ada.Unchecked_Deallocation; with Interfaces.C; @@ -140,6 +139,13 @@ package body System.Task_Primitives.Operations is package body Specific is separate; -- The body of this package is target specific + ---------------------------------- + -- ATCB allocation/deallocation -- + ---------------------------------- + + package body ATCB_Allocation is separate; + -- The body of this package is shared across several targets + --------------------------------- -- Support for foreign threads -- --------------------------------- @@ -828,15 +834,6 @@ package body System.Task_Primitives.Operations is end if; end Enter_Task; - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - ------------------- -- Is_Valid_Task -- ------------------- @@ -986,12 +983,7 @@ package body System.Task_Primitives.Operations is ------------------ procedure Finalize_TCB (T : Task_Id) is - Result : int; - Tmp : Task_Id := T; - Is_Self : constant Boolean := (T = Self); - - procedure Free is new - Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + Result : int; begin if not Single_Lock then @@ -1008,11 +1000,7 @@ package body System.Task_Primitives.Operations is Known_Tasks (T.Known_Tasks_Index) := null; end if; - Free (Tmp); - - if Is_Self then - Specific.Delete; - end if; + ATCB_Allocation.Free_ATCB (T); end Finalize_TCB; --------------- diff --git a/gcc/ada/s-taprop.ads b/gcc/ada/s-taprop.ads index feb6f55..12fbd71 100644 --- a/gcc/ada/s-taprop.ads +++ b/gcc/ada/s-taprop.ads @@ -87,9 +87,24 @@ package System.Task_Primitives.Operations is -- The effects of further calls to operations defined below on the task -- are undefined thereafter. - function New_ATCB (Entry_Num : ST.Task_Entry_Index) return ST.Task_Id; - pragma Inline (New_ATCB); - -- Allocate a new ATCB with the specified number of entries + ---------------------------------- + -- ATCB allocation/deallocation -- + ---------------------------------- + + package ATCB_Allocation is + + function New_ATCB (Entry_Num : ST.Task_Entry_Index) return ST.Task_Id; + pragma Inline (New_ATCB); + -- Allocate a new ATCB with the specified number of entries + + procedure Free_ATCB (T : ST.Task_Id); + pragma Inline (Free_ATCB); + -- Deallocate an ATCB previously allocated by New_ATCB + + end ATCB_Allocation; + + function New_ATCB (Entry_Num : ST.Task_Entry_Index) return ST.Task_Id + renames ATCB_Allocation.New_ATCB; procedure Initialize_TCB (Self_ID : ST.Task_Id; Succeeded : out Boolean); pragma Inline (Initialize_TCB); diff --git a/gcc/ada/s-taskin.ads b/gcc/ada/s-taskin.ads index 8b4e61a..d313137 100644 --- a/gcc/ada/s-taskin.ads +++ b/gcc/ada/s-taskin.ads @@ -1150,6 +1150,12 @@ package System.Tasking is -- -- Protection: Self.L. Once a task has set Self.Stage to Completing, it -- has exclusive access to this field. + + Free_On_Termination : Boolean := False; + -- Deallocate the ATCB when the task terminates. This flag is normally + -- False, and is set True when Unchecked_Deallocation is called on a + -- non-terminated task so that the associated storage is automatically + -- reclaimed when the task terminates. end record; -------------------- diff --git a/gcc/ada/s-tassta.adb b/gcc/ada/s-tassta.adb index bf1cc35..6449bf6 100644 --- a/gcc/ada/s-tassta.adb +++ b/gcc/ada/s-tassta.adb @@ -969,12 +969,11 @@ package body System.Tasking.Stages is Free_Entry_Names (T); System.Task_Primitives.Operations.Finalize_TCB (T); - -- If the task is not terminated, then we simply ignore the call. This - -- happens when a user program attempts an unchecked deallocation on - -- a non-terminated task. - else - null; + -- If the task is not terminated, then mark the task as to be freed + -- upon termination. + + T.Free_On_Termination := True; end if; end Free_Task; @@ -1429,6 +1428,7 @@ package body System.Tasking.Stages is procedure Terminate_Task (Self_ID : Task_Id) is Environment_Task : constant Task_Id := STPO.Environment_Task; Master_of_Task : Integer; + Deallocate : Boolean; begin Debug.Task_Termination_Hook; @@ -1474,6 +1474,7 @@ package body System.Tasking.Stages is Stack_Guard (Self_ID, False); Utilities.Make_Passive (Self_ID, Task_Completed => True); + Deallocate := Self_ID.Free_On_Termination; if Single_Lock then Unlock_RTS; @@ -1485,7 +1486,12 @@ package body System.Tasking.Stages is Initialization.Final_Task_Unlock (Self_ID); -- WARNING: past this point, this thread must assume that the ATCB has - -- been deallocated. It should not be accessed again. + -- been deallocated, and can't access it anymore (which is why we have + -- saved the Free_On_Termination flag in a temporary variable). + + if Deallocate then + Free_Task (Self_ID); + end if; if Master_of_Task > 0 then STPO.Exit_Task; diff --git a/gcc/ada/s-tpoaal.adb b/gcc/ada/s-tpoaal.adb new file mode 100644 index 0000000..0e79f45 --- /dev/null +++ b/gcc/ada/s-tpoaal.adb @@ -0,0 +1,79 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.ATCB_ALLOCATION -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2011, Free Software Foundation, Inc. -- +-- -- +-- GNARL 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Deallocation; + +separate (System.Task_Primitives.Operations) +package body ATCB_Allocation is + + --------------- + -- Free_ATCB -- + --------------- + + procedure Free_ATCB (T : Task_Id) is + Tmp : Task_Id := T; + Is_Self : constant Boolean := T = Self; + + procedure Free is new + Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + + begin + if Is_Self then + declare + Local_ATCB : aliased Ada_Task_Control_Block (0); + -- Create a dummy ATCB and initialize it minimally so that "Free" + -- can still call Self and Defer/Undefer_Abort after Tmp is freed + -- by the underlying memory management library. + + begin + Local_ATCB.Common.LL.Thread := T.Common.LL.Thread; + Local_ATCB.Common.Current_Priority := T.Common.Current_Priority; + + Specific.Set (Local_ATCB'Unchecked_Access); + Free (Tmp); + Specific.Set (null); + end; + + else + Free (Tmp); + end if; + end Free_ATCB; + + -------------- + -- New_ATCB -- + -------------- + + function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is + begin + return new Ada_Task_Control_Block (Entry_Num); + end New_ATCB; + +end ATCB_Allocation; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index fe2b82b..2655b25 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -1289,25 +1289,9 @@ package body Sem_Ch13 is when Aspect_Invariant | Aspect_Type_Invariant => - -- Check placement legality: An invariant must apply to a - -- private type, or appear in the private part of a spec. - -- Analysis of the pragma will verify that in the private - -- part it applies to a completion. - - if Nkind_In (N, N_Private_Type_Declaration, - N_Private_Extension_Declaration) - then - null; - - elsif Nkind (N) = N_Full_Type_Declaration - and then In_Private_Part (Current_Scope) - then - null; - - else - Error_Msg_N - ("invariant aspect must apply to a private type", N); - end if; + -- Analysis of the pragma will verify placement legality: + -- an invariant must apply to a private type, or appear in + -- the private part of a spec and apply to a completion. -- Construct the pragma diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 796f9b0..6c561da 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -1859,9 +1859,12 @@ package body Sem_Ch8 is Statements (Handled_Statement_Sequence (New_Body))); -- The generated body does not freeze. It is analyzed when the - -- generated operation is frozen. + -- generated operation is frozen. This body is only needed if + -- expansion is enabled. - Append_Freeze_Action (Defining_Entity (New_Decl), New_Body); + if Expander_Active then + Append_Freeze_Action (Defining_Entity (New_Decl), New_Body); + end if; Result := Defining_Entity (New_Decl); end if; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 0c204cd..2ca9417 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -29,63 +29,65 @@ -- to complete the syntax checks. Certain pragmas are handled partially or -- completely by the parser (see Par.Prag for further details). -with Atree; use Atree; -with Casing; use Casing; -with Checks; use Checks; -with Csets; use Csets; -with Debug; use Debug; -with Einfo; use Einfo; -with Elists; use Elists; -with Errout; use Errout; -with Exp_Dist; use Exp_Dist; -with Exp_Util; use Exp_Util; -with Freeze; use Freeze; -with Lib; use Lib; -with Lib.Writ; use Lib.Writ; -with Lib.Xref; use Lib.Xref; -with Namet.Sp; use Namet.Sp; -with Nlists; use Nlists; -with Nmake; use Nmake; -with Opt; use Opt; -with Output; use Output; -with Par_SCO; use Par_SCO; -with Restrict; use Restrict; -with Rident; use Rident; -with Rtsfind; use Rtsfind; -with Sem; use Sem; -with Sem_Aux; use Sem_Aux; -with Sem_Ch3; use Sem_Ch3; -with Sem_Ch6; use Sem_Ch6; -with Sem_Ch8; use Sem_Ch8; -with Sem_Ch12; use Sem_Ch12; -with Sem_Ch13; use Sem_Ch13; -with Sem_Disp; use Sem_Disp; -with Sem_Dist; use Sem_Dist; -with Sem_Elim; use Sem_Elim; -with Sem_Eval; use Sem_Eval; -with Sem_Intr; use Sem_Intr; -with Sem_Mech; use Sem_Mech; -with Sem_Res; use Sem_Res; -with Sem_Type; use Sem_Type; -with Sem_Util; use Sem_Util; -with Sem_VFpt; use Sem_VFpt; -with Sem_Warn; use Sem_Warn; -with Stand; use Stand; -with Sinfo; use Sinfo; -with Sinfo.CN; use Sinfo.CN; -with Sinput; use Sinput; -with Snames; use Snames; -with Stringt; use Stringt; -with Stylesw; use Stylesw; +with System.Case_Util; + +with Atree; use Atree; +with Casing; use Casing; +with Checks; use Checks; +with Csets; use Csets; +with Debug; use Debug; +with Einfo; use Einfo; +with Elists; use Elists; +with Errout; use Errout; +with Exp_Dist; use Exp_Dist; +with Exp_Util; use Exp_Util; +with Freeze; use Freeze; +with Lib; use Lib; +with Lib.Writ; use Lib.Writ; +with Lib.Xref; use Lib.Xref; +with Namet.Sp; use Namet.Sp; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Output; use Output; +with Par_SCO; use Par_SCO; +with Restrict; use Restrict; +with Rident; use Rident; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Ch3; use Sem_Ch3; +with Sem_Ch6; use Sem_Ch6; +with Sem_Ch8; use Sem_Ch8; +with Sem_Ch12; use Sem_Ch12; +with Sem_Ch13; use Sem_Ch13; +with Sem_Disp; use Sem_Disp; +with Sem_Dist; use Sem_Dist; +with Sem_Elim; use Sem_Elim; +with Sem_Eval; use Sem_Eval; +with Sem_Intr; use Sem_Intr; +with Sem_Mech; use Sem_Mech; +with Sem_Res; use Sem_Res; +with Sem_Type; use Sem_Type; +with Sem_Util; use Sem_Util; +with Sem_VFpt; use Sem_VFpt; +with Sem_Warn; use Sem_Warn; +with Stand; use Stand; +with Sinfo; use Sinfo; +with Sinfo.CN; use Sinfo.CN; +with Sinput; use Sinput; +with Snames; use Snames; +with Stringt; use Stringt; +with Stylesw; use Stylesw; with Table; -with Targparm; use Targparm; -with Tbuild; use Tbuild; +with Targparm; use Targparm; +with Tbuild; use Tbuild; with Ttypes; -with Uintp; use Uintp; -with Uname; use Uname; -with Urealp; use Urealp; -with Validsw; use Validsw; -with Warnsw; use Warnsw; +with Uintp; use Uintp; +with Uname; use Uname; +with Urealp; use Urealp; +with Validsw; use Validsw; +with Warnsw; use Warnsw; package body Sem_Prag is @@ -646,6 +648,17 @@ package body Sem_Prag is -- Similar to above form of Error_Pragma_Arg except that two messages -- are provided, the second is a continuation comment starting with \. + procedure Error_Pragma_Arg_Alternate_Name + (Msg : String; + Arg : Node_Id; + Alt_Name : Name_Id); + pragma No_Return (Error_Pragma_Arg_Alternate_Name); + -- Outputs error message for current pragma, similar to + -- Error_Pragma_Arg, except the source name of the aspect/pragma to use + -- in warnings may be equal to Alt_Name (which should be equivalent to + -- the name used in pragma). The location for the source name should be + -- pointed to by Arg. + procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id); pragma No_Return (Error_Pragma_Arg_Ident); -- Outputs error message for current pragma. The message may contain @@ -2427,6 +2440,34 @@ package body Sem_Prag is Error_Pragma_Arg (Msg2, Arg); end Error_Pragma_Arg; + ------------------------------------- + -- Error_Pragma_Arg_Alternate_Name -- + ------------------------------------- + + procedure Error_Pragma_Arg_Alternate_Name + (Msg : String; + Arg : Node_Id; + Alt_Name : Name_Id) + is + MsgF : String := Msg; + Source_Name : String := Exact_Source_Name (Sloc (Arg)); + Alter_Name : String := Get_Name_String (Alt_Name); + + begin + System.Case_Util.To_Lower (Source_Name); + System.Case_Util.To_Lower (Alter_Name); + + if Source_Name = Alter_Name then + Error_Msg_Name_1 := Alt_Name; + else + Error_Msg_Name_1 := Pname; + end if; + + Fix_Error (MsgF); + Error_Msg_N (MsgF, Get_Pragma_Arg (Arg)); + raise Pragma_Exit; + end Error_Pragma_Arg_Alternate_Name; + ---------------------------- -- Error_Pragma_Arg_Ident -- ---------------------------- @@ -10140,9 +10181,16 @@ package body Sem_Prag is then null; + elsif In_Private_Part (Current_Scope) then + Error_Pragma_Arg_Alternate_Name + ("pragma% only allowed for private type " & + "declared in visible part", Arg1, + Alt_Name => Name_Type_Invariant); + else - Error_Pragma_Arg - ("pragma% only allowed for private type", Arg1); + Error_Pragma_Arg_Alternate_Name + ("pragma% only allowed for private type", Arg1, + Alt_Name => Name_Type_Invariant); end if; -- Note that the type has at least one invariant, and also that -- 2.7.4