From: Arnaud Charlet Date: Fri, 23 Oct 2015 12:48:46 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=ed11bbfe441b0d223566174af18e04e4753f3fbb;p=gcc.git [multiple changes] 2015-10-23 Arnaud Charlet * 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 * 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 * 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 * a-exetim-posix.adb (Clock): Use the pthread_getcpuclockid function to have access to CPU clocks for tasks other than the calling task. From-SVN: r229247 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index bf8ad25c85b..94904273a64 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,31 @@ +2015-10-23 Arnaud Charlet + + * 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 + + * 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 + + * 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 + + * 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 * debug.adb: Switch -gnatd.5 is no longer in use, remove the diff --git a/gcc/ada/a-exetim-posix.adb b/gcc/ada/a-exetim-posix.adb index 9dc709ac61f..9c7ad57166e 100644 --- a/gcc/ada/a-exetim-posix.adb +++ b/gcc/ada/a-exetim-posix.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -34,8 +34,9 @@ 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; @@ -97,14 +98,18 @@ package body Ada.Execution_Time is (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) @@ -112,13 +117,26 @@ package body Ada.Execution_Time is 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)); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index b27405f2477..201da87738a 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -3945,7 +3945,7 @@ package Einfo is -- 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. diff --git a/gcc/ada/s-taskin.ads b/gcc/ada/s-taskin.ads index f48d98d0634..539d08854fb 100644 --- a/gcc/ada/s-taskin.ads +++ b/gcc/ada/s-taskin.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -1135,20 +1135,23 @@ package System.Tasking is -- 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; -------------------- diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 02e5ed33ab6..d54ef0ffd99 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -4728,7 +4728,12 @@ package body Sem_Ch13 is 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 @@ -4859,13 +4864,27 @@ package body Sem_Ch13 is -- 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; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 6a3e5e7644f..af31c9f1a85 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -619,6 +619,10 @@ package body Sem_Ch6 is 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. @@ -628,6 +632,57 @@ package body Sem_Ch6 is -- 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 -- -------------------------- @@ -931,6 +986,10 @@ package body Sem_Ch6 is 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