+2015-10-23 Arnaud Charlet <charlet@adacore.com>
+
+ * s-taskin.ads: Minor code clean up.
+ (Ada_Task_Control_Block): Move fixed size field before variable sized
+ ones.
+ * einfo.ads: Minor editing.
+
+2015-10-23 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch6.adb (Check_Aggregate_Accessibility): Apply rule in RM
+ 6.5 (8.3) to verify that access discriminants in an aggregate
+ in a return statement have the proper accessibility, i.e. do
+ not lead to dangling references.
+
+2015-10-23 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_ch13.adb (Analyze_Attribute_Definition_Clause): Add missing
+ test on Address_Clause_Overlay_Warnings to the "constant overlays
+ variable" warning. For the reverse case, also issue a warning if
+ the modification is potentially made through the initialization
+ of the variable.
+
+2015-10-23 Jose Ruiz <ruiz@adacore.com>
+
+ * a-exetim-posix.adb (Clock): Use the pthread_getcpuclockid
+ function to have access to CPU clocks for tasks other than the
+ calling task.
+
2015-10-23 Hristian Kirtchev <kirtchev@adacore.com>
* debug.adb: Switch -gnatd.5 is no longer in use, remove the
-- --
-- B o d y --
-- --
--- Copyright (C) 2007-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 2007-2015, 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- --
with Ada.Task_Identification; use Ada.Task_Identification;
with Ada.Unchecked_Conversion;
-with System.OS_Constants; use System.OS_Constants;
+with System.Tasking;
with System.OS_Interface; use System.OS_Interface;
+with System.Task_Primitives.Operations; use System.Task_Primitives.Operations;
with Interfaces.C; use Interfaces.C;
(T : Ada.Task_Identification.Task_Id :=
Ada.Task_Identification.Current_Task) return CPU_Time
is
- TS : aliased timespec;
- Result : Interfaces.C.int;
+ TS : aliased timespec;
+ Clock_Id : aliased Interfaces.C.int;
+ Result : Interfaces.C.int;
function To_CPU_Time is
new Ada.Unchecked_Conversion (Duration, CPU_Time);
-- Time is equal to Duration (although it is a private type) and
-- CPU_Time is equal to Time.
+ function Convert_Ids is new
+ Ada.Unchecked_Conversion (Task_Id, System.Tasking.Task_Id);
+
function clock_gettime
(clock_id : Interfaces.C.int;
tp : access timespec)
pragma Import (C, clock_gettime, "clock_gettime");
-- Function from the POSIX.1b Realtime Extensions library
+ function pthread_getcpuclockid
+ (tid : Thread_Id;
+ clock_id : access Interfaces.C.int)
+ return int;
+ pragma Import (C, pthread_getcpuclockid, "pthread_getcpuclockid");
+ -- Function from the Thread CPU-Time Clocks option
+
begin
if T = Ada.Task_Identification.Null_Task_Id then
raise Program_Error;
+ else
+ -- Get the CPU clock for the task passed as parameter
+
+ Result := pthread_getcpuclockid
+ (Get_Thread_Id (Convert_Ids (T)), Clock_Id'Access);
+ pragma Assert (Result = 0);
end if;
Result := clock_gettime
- (clock_id => CLOCK_THREAD_CPUTIME_ID, tp => TS'Unchecked_Access);
+ (clock_id => Clock_Id, tp => TS'Unchecked_Access);
pragma Assert (Result = 0);
return To_CPU_Time (To_Duration (TS));
-- Rewritten_For_C (Flag287)
-- Defined on functions that return a constrained array type, when
--- Modify_Tree_For_C is set. indicates that a procedure with an extra
+-- Modify_Tree_For_C is set. Indicates that a procedure with an extra
-- out parameter has been created for it, and calls must be rewritten as
-- calls to the new procedure.
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, 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- --
-- User-writeable location, for use in debugging tasks; also provides a
-- simple task specific data.
+ 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.
+
Attributes : Attribute_Array := (others => 0);
-- Task attributes
+ -- IMPORTANT Note: the Entry_Queues field is last for efficiency of
+ -- access to other fields, do not put new fields after this one.
+
Entry_Queues : Task_Entry_Queue_Array (1 .. Entry_Num);
-- An array of task entry queues
--
-- 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;
--------------------
Make_Raise_Program_Error (Loc,
Reason => PE_Overlaid_Controlled_Object));
- elsif Present (O_Ent)
+ -- Issue an unconditional warning for a constant overlaying
+ -- a variable. For the reverse case, we will issue it only
+ -- if the variable is modified, see below.
+
+ elsif Address_Clause_Overlay_Warnings
+ and then Present (O_Ent)
and then Ekind (U_Ent) = E_Constant
and then not Is_Constant_Object (O_Ent)
then
-- If variable overlays a constant view, and we are
-- warning on overlays, then mark the variable as
- -- overlaying a constant (we will give warnings later
- -- if this variable is assigned).
+ -- overlaying a constant and warn immediately if it
+ -- is initialized. We will give other warnings later
+ -- if the variable is assigned.
if Is_Constant_Object (O_Ent)
and then Ekind (U_Ent) = E_Variable
then
- Set_Overlays_Constant (U_Ent);
+ declare
+ Init : constant Node_Id :=
+ Expression (Declaration_Node (U_Ent));
+ begin
+ Set_Overlays_Constant (U_Ent);
+ if Present (Init)
+ and then Comes_From_Source (Init)
+ then
+ Error_Msg_Sloc := Sloc (N);
+ Error_Msg_NE
+ ("??constant& may be modified via address "
+ & "clause#", Declaration_Node (U_Ent), O_Ent);
+ end if;
+ end;
end if;
end if;
end;
R_Type : constant Entity_Id := Etype (Scope_Id);
-- Function result subtype
+ procedure Check_Aggregate_Accessibility (Aggr : Node_Id);
+ -- Apply legality rule of 6.5 (8.2) to the access discriminants of
+ -- an aggregate in a return statement.
+
procedure Check_Limited_Return (Expr : Node_Id);
-- Check the appropriate (Ada 95 or Ada 2005) rules for returning
-- limited types. Used only for simple return statements.
-- Check that the return_subtype_indication properly matches the result
-- subtype of the function, as required by RM-6.5(5.1/2-5.3/2).
+ -----------------------------------
+ -- Check_Aggregate_Accessibility --
+ -----------------------------------
+
+ procedure Check_Aggregate_Accessibility (Aggr : Node_Id) is
+ Typ : constant Entity_Id := Etype (Aggr);
+ Assoc : Node_Id;
+ Discr : Entity_Id;
+ Expr : Node_Id;
+ Obj : Node_Id;
+
+ begin
+ if Is_Record_Type (Typ)
+ and then Has_Discriminants (Typ)
+ then
+ Discr := First_Discriminant (Typ);
+ Assoc := First (Component_Associations (Aggr));
+ while Present (Discr) loop
+ if Ekind (Etype (Discr)) = E_Anonymous_Access_Type then
+ Expr := Expression (Assoc);
+ if Nkind (Expr) = N_Attribute_Reference
+ and then Attribute_Name (Expr) /= Name_Unrestricted_Access
+ then
+ Obj := Prefix (Expr);
+ while Nkind_In (Obj,
+ N_Selected_Component, N_Indexed_Component)
+ loop
+ Obj := Prefix (Obj);
+ end loop;
+
+ if Is_Entity_Name (Obj)
+ and then Is_Formal (Entity (Obj))
+ then
+ -- A run-time check may be needed ???
+ null;
+
+ elsif Object_Access_Level (Obj) >
+ Scope_Depth (Scope (Scope_Id))
+ then
+ Error_Msg_N
+ ("access discriminant in return aggregate " &
+ "will be a dangling reference", Obj);
+ end if;
+ end if;
+ end if;
+
+ Next_Discriminant (Discr);
+ end loop;
+ end if;
+ end Check_Aggregate_Accessibility;
+
--------------------------
-- Check_Limited_Return --
--------------------------
Resolve (Expr, R_Type);
Check_Limited_Return (Expr);
+
+ if Present (Expr) and then Nkind (Expr) = N_Aggregate then
+ Check_Aggregate_Accessibility (Expr);
+ end if;
end if;
-- RETURN only allowed in SPARK as the last statement in function
projects / gcc.git / commitdiff