+2011-09-06 Ed Schonberg <schonberg@adacore.com>
+
+ * 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 <schonberg@adacore.com>
+
+ * 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 <ebotcazou@adacore.com>
+
+ * checks.adb (Apply_Scalar_Range_Check): Deal with access
+ type prefix.
+
+2011-09-06 Yannick Moy <moy@adacore.com>
+
+ * 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 <quinot@adacore.com>
+
+ * 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 <quinot@adacore.com>
+
+ * 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 <quinot@adacore.com>
+
+ * 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 <dewar@adacore.com>
* a-cbprqu.ads, a-cbsyqu.ads, a-cuprqu.ads, a-cusyqu.ads,
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
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;
-- 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.
Rewrite (N, New_Copy (A));
end if;
end if;
+
return Skip;
elsif Is_Entity_Name (N)
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
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;
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));
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;
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.
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
-- 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
-- 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
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);
and then Etype (F) /= Base_Type (Etype (F))
then
Temp_Typ := Etype (F);
-
else
Temp_Typ := Etype (A);
end if;
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;
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,
Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
-- Create the temporary, generate:
- --
-- Local_Id : Ptr_Typ;
Local_Id := Make_Temporary (Loc, 'T');
New_Reference_To (Ptr_Typ, Loc)));
-- Allocate the object, generate:
- --
-- Local_Id := <Alloc_Expr>;
Append_To (Stmts,
end;
-- For all other cases, generate:
- --
-- Temp_Id := <Alloc_Expr>;
else
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
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 --
--------------------
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 --
-----------
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 --
----------------
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 --
---------------
-- operations. It causes infinite loops and other problems.
with Ada.Unchecked_Conversion;
-with Ada.Unchecked_Deallocation;
with Interfaces.C;
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 --
---------------------------------
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 --
-------------------
------------------
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
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;
---------------
-- operations. It causes infinite loops and other problems.
with Ada.Unchecked_Conversion;
-with Ada.Unchecked_Deallocation;
with Interfaces.C;
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 --
---------------------------------
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 --
-------------------
------------------
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
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;
---------------
-- 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;
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 --
---------------------------------
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 --
-------------------
------------------
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
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;
---------------
-- 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;
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 --
---------------------------------
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 --
-------------------
------------------
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
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;
---------------
-- operations. It causes infinite loops and other problems.
with Ada.Unchecked_Conversion;
-with Ada.Unchecked_Deallocation;
with Interfaces.C;
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 --
---------------------------------
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 --
-------------------
------------------
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
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;
---------------
-- 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;
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 --
---------------------------------
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 --
-------------------
------------------
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;
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;
---------------
-- 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;
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 --
---------------------------------
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 --
-------------------
------------------
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
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;
---------------
-- operations. It causes infinite loops and other problems.
with Ada.Unchecked_Conversion;
-with Ada.Unchecked_Deallocation;
with Interfaces.C;
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 --
---------------------------------
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 --
-------------------
------------------
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
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;
---------------
-- operations. It causes infinite loops and other problems.
with Ada.Unchecked_Conversion;
-with Ada.Unchecked_Deallocation;
with Interfaces.C;
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 --
---------------------------------
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 --
-------------------
------------------
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
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;
---------------
-- 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);
--
-- 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;
--------------------
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;
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;
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;
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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- 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;
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
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;
-- 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
-- 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
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 --
----------------------------
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
OSDN Git Service
