diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 28 | ||||
| -rw-r--r-- | gcc/ada/par-ch4.adb | 14 | ||||
| -rw-r--r-- | gcc/ada/s-osinte-linux.ads | 14 | ||||
| -rw-r--r-- | gcc/ada/s-taprop-linux.adb | 162 | ||||
| -rw-r--r-- | gcc/ada/s-taprop-posix.adb | 19 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 9 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 8 |
7 files changed, 214 insertions, 40 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index a9ded59..e06d758 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,31 @@ +2017-04-25 Bob Duff <duff@adacore.com> + + * s-osinte-linux.ads (pthread_mutexattr_setprotocol, + pthread_mutexattr_setprioceiling): Add new interfaces for these + pthread operations. + * s-taprop-linux.adb (Initialize_Lock, Initialize_TCB): Set + protocols as appropriate for Locking_Policy 'C' and 'I'. + * s-taprop-posix.adb: Minor reformatting to make it more similar + to s-taprop-linux.adb. + +2017-04-25 Ed Schonberg <schonberg@adacore.com> + + * sem_ch3.adb (Get_Discriminant_Value, Search_Derivation_Levels): + Handle properly a multi- level derivation involving both renamed + and constrained parent discriminants, when the type to be + constrained has fewer discriminants that the ultimate ancestor. + +2017-04-25 Bob Duff <duff@adacore.com> + + * sem_util.adb (Is_Object_Reference): In the + case of N_Explicit_Dereference, return False if it came from a + conditional expression. + +2017-04-25 Bob Duff <duff@adacore.com> + + * par-ch4.adb (P_Case_Expression): If a semicolon + is followed by "when", assume that ";" was meant to be ",". + 2017-04-25 Gary Dismukes <dismukes@adacore.com> * sem_ch9.adb, sem_ch10.adb, sem_util.adb: Minor reformatting and typo diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index e9a3a23..4e6c8a7 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -3199,6 +3199,20 @@ package body Ch4 is if Token = Tok_When then T_Comma; + -- A semicolon followed by "when" is probably meant to be a comma + + elsif Token = Tok_Semicolon then + Save_Scan_State (Save_State); + Scan; -- past the semicolon + + if Token /= Tok_When then + Restore_Scan_State (Save_State); + exit; + end if; + + Error_Msg_SP -- CODEFIX + ("|"";"" should be "","""); + -- If comma/WHEN, skip comma and we have another alternative elsif Token = Tok_Comma then diff --git a/gcc/ada/s-osinte-linux.ads b/gcc/ada/s-osinte-linux.ads index b0ba229..fa1e060 100644 --- a/gcc/ada/s-osinte-linux.ads +++ b/gcc/ada/s-osinte-linux.ads @@ -452,6 +452,20 @@ package System.OS_Interface is -- POSIX.1c Section 13 -- -------------------------- + PTHREAD_PRIO_NONE : constant := 0; + PTHREAD_PRIO_INHERIT : constant := 1; + PTHREAD_PRIO_PROTECT : constant := 2; + + function pthread_mutexattr_setprotocol + (attr : access pthread_mutexattr_t; + protocol : int) return int; + pragma Import (C, pthread_mutexattr_setprotocol); + + function pthread_mutexattr_setprioceiling + (attr : access pthread_mutexattr_t; + prioceiling : int) return int; + pragma Import (C, pthread_mutexattr_setprioceiling); + type struct_sched_param is record sched_priority : int; -- scheduling priority end record; diff --git a/gcc/ada/s-taprop-linux.adb b/gcc/ada/s-taprop-linux.adb index ad603d8..00cf9ce 100644 --- a/gcc/ada/s-taprop-linux.adb +++ b/gcc/ada/s-taprop-linux.adb @@ -111,6 +111,14 @@ package body System.Task_Primitives.Operations is -- Constant to indicate that the thread identifier has not yet been -- initialized. + function geteuid return Integer; + pragma Import (C, geteuid, "geteuid"); + pragma Warnings (Off, "non-static call not allowed in preelaborated unit"); + Superuser : constant Boolean := geteuid = 0; + pragma Warnings (On, "non-static call not allowed in preelaborated unit"); + -- True if we are running as 'root'. On Linux, ceiling priorities work only + -- in that case, so if this is False, we ignore Locking_Policy = 'C'. + -------------------- -- Local Packages -- -------------------- @@ -161,6 +169,11 @@ package body System.Task_Primitives.Operations is procedure Abort_Handler (signo : Signal); + function GNAT_pthread_condattr_setup + (attr : access pthread_condattr_t) return int; + pragma Import (C, + GNAT_pthread_condattr_setup, "__gnat_pthread_condattr_setup"); + ------------------- -- Abort_Handler -- ------------------- @@ -261,8 +274,6 @@ package body System.Task_Primitives.Operations is (Prio : System.Any_Priority; L : not null access Lock) is - pragma Unreferenced (Prio); - begin if Locking_Policy = 'R' then declare @@ -291,36 +302,91 @@ package body System.Task_Primitives.Operations is else declare + Attributes : aliased pthread_mutexattr_t; Result : Interfaces.C.int; begin - Result := pthread_mutex_init (L.WO'Access, null); + Result := pthread_mutexattr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + if Result = ENOMEM then + raise Storage_Error; + end if; + + if Locking_Policy = 'C' then + if Superuser then + Result := pthread_mutexattr_setprotocol + (Attributes'Access, PTHREAD_PRIO_PROTECT); + pragma Assert (Result = 0); + + Result := pthread_mutexattr_setprioceiling + (Attributes'Access, Interfaces.C.int (Prio)); + pragma Assert (Result = 0); + end if; + + elsif Locking_Policy = 'I' then + Result := pthread_mutexattr_setprotocol + (Attributes'Access, PTHREAD_PRIO_INHERIT); + pragma Assert (Result = 0); + end if; + + Result := pthread_mutex_init (L.WO'Access, Attributes'Access); pragma Assert (Result = 0 or else Result = ENOMEM); if Result = ENOMEM then + Result := pthread_mutexattr_destroy (Attributes'Access); raise Storage_Error with "Failed to allocate a lock"; end if; + + Result := pthread_mutexattr_destroy (Attributes'Access); + pragma Assert (Result = 0); end; end if; end Initialize_Lock; procedure Initialize_Lock - (L : not null access RTS_Lock; - Level : Lock_Level) + (L : not null access RTS_Lock; Level : Lock_Level) is pragma Unreferenced (Level); - Result : Interfaces.C.int; + Attributes : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; begin - Result := pthread_mutex_init (L, null); + Result := pthread_mutexattr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + if Locking_Policy = 'C' then + if Superuser then + Result := pthread_mutexattr_setprotocol + (Attributes'Access, PTHREAD_PRIO_PROTECT); + pragma Assert (Result = 0); + + Result := pthread_mutexattr_setprioceiling + (Attributes'Access, Interfaces.C.int (System.Any_Priority'Last)); + pragma Assert (Result = 0); + end if; + + elsif Locking_Policy = 'I' then + Result := pthread_mutexattr_setprotocol + (Attributes'Access, PTHREAD_PRIO_INHERIT); + pragma Assert (Result = 0); + end if; + Result := pthread_mutex_init (L, Attributes'Access); pragma Assert (Result = 0 or else Result = ENOMEM); if Result = ENOMEM then + Result := pthread_mutexattr_destroy (Attributes'Access); raise Storage_Error; end if; + + Result := pthread_mutexattr_destroy (Attributes'Access); + pragma Assert (Result = 0); end Initialize_Lock; ------------------- @@ -361,11 +427,10 @@ package body System.Task_Primitives.Operations is Result := pthread_mutex_lock (L.WO'Access); end if; - Ceiling_Violation := Result = EINVAL; - - -- Assume the cause of EINVAL is a priority ceiling violation + -- The cause of EINVAL is a priority ceiling violation - pragma Assert (Result = 0 or else Result = EINVAL); + Ceiling_Violation := Result = EINVAL; + pragma Assert (Result = 0 or else Ceiling_Violation); end Write_Lock; procedure Write_Lock @@ -405,11 +470,10 @@ package body System.Task_Primitives.Operations is Result := pthread_mutex_lock (L.WO'Access); end if; - Ceiling_Violation := Result = EINVAL; + -- The cause of EINVAL is a priority ceiling violation - -- Assume the cause of EINVAL is a priority ceiling violation - - pragma Assert (Result = 0 or else Result = EINVAL); + Ceiling_Violation := Result = EINVAL; + pragma Assert (Result = 0 or else Ceiling_Violation); end Read_Lock; ------------ @@ -855,8 +919,9 @@ package body System.Task_Primitives.Operations is -------------------- procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is - Cond_Attr : aliased pthread_condattr_t; + Mutex_Attr : aliased pthread_mutexattr_t; Result : Interfaces.C.int; + Cond_Attr : aliased pthread_condattr_t; begin -- Give the task a unique serial number @@ -868,24 +933,63 @@ package body System.Task_Primitives.Operations is Self_ID.Common.LL.Thread := Null_Thread_Id; if not Single_Lock then - Result := - pthread_mutex_init (Self_ID.Common.LL.L'Access, null); + Result := pthread_mutexattr_init (Mutex_Attr'Access); pragma Assert (Result = 0 or else Result = ENOMEM); + if Result = 0 then + if Locking_Policy = 'C' then + if Superuser then + Result := + pthread_mutexattr_setprotocol + (Mutex_Attr'Access, + PTHREAD_PRIO_PROTECT); + pragma Assert (Result = 0); + + Result := + pthread_mutexattr_setprioceiling + (Mutex_Attr'Access, + Interfaces.C.int (System.Any_Priority'Last)); + pragma Assert (Result = 0); + end if; + + elsif Locking_Policy = 'I' then + Result := + pthread_mutexattr_setprotocol + (Mutex_Attr'Access, + PTHREAD_PRIO_INHERIT); + pragma Assert (Result = 0); + end if; + + Result := + pthread_mutex_init + (Self_ID.Common.LL.L'Access, + Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + end if; + if Result /= 0 then Succeeded := False; return; end if; + + Result := pthread_mutexattr_destroy (Mutex_Attr'Access); + pragma Assert (Result = 0); end if; Result := pthread_condattr_init (Cond_Attr'Access); - pragma Assert (Result = 0); - - Result := - pthread_cond_init (Self_ID.Common.LL.CV'Access, Cond_Attr'Access); pragma Assert (Result = 0 or else Result = ENOMEM); if Result = 0 then + Result := GNAT_pthread_condattr_setup (Cond_Attr'Access); + pragma Assert (Result = 0); + + Result := + pthread_cond_init + (Self_ID.Common.LL.CV'Access, Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + end if; + + if Result = 0 then Succeeded := True; else if not Single_Lock then @@ -895,6 +999,9 @@ package body System.Task_Primitives.Operations is Succeeded := False; end if; + + Result := pthread_condattr_destroy (Cond_Attr'Access); + pragma Assert (Result = 0); end Initialize_TCB; ----------------- @@ -1042,12 +1149,11 @@ package body System.Task_Primitives.Operations is -- safe to do this, since we know we have no problems with aliasing and -- Unrestricted_Access bypasses this check. - Result := - pthread_create - (T.Common.LL.Thread'Unrestricted_Access, - Attributes'Access, - Thread_Body_Access (Wrapper), - To_Address (T)); + Result := pthread_create + (T.Common.LL.Thread'Unrestricted_Access, + Attributes'Access, + Thread_Body_Access (Wrapper), + To_Address (T)); pragma Assert (Result = 0 or else Result = EAGAIN or else Result = ENOMEM); diff --git a/gcc/ada/s-taprop-posix.adb b/gcc/ada/s-taprop-posix.adb index 5ed7bad..fc647aa 100644 --- a/gcc/ada/s-taprop-posix.adb +++ b/gcc/ada/s-taprop-posix.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, 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- -- @@ -352,12 +352,11 @@ package body System.Task_Primitives.Operations is -- Initialize_Lock -- --------------------- - -- Note: mutexes and cond_variables needed per-task basis are - -- initialized in Initialize_TCB and the Storage_Error is - -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...) - -- used in RTS is initialized before any status change of RTS. - -- Therefore raising Storage_Error in the following routines - -- should be able to be handled safely. + -- Note: mutexes and cond_variables needed per-task basis are initialized + -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such + -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any + -- status change of RTS. Therefore raising Storage_Error in the following + -- routines should be able to be handled safely. procedure Initialize_Lock (Prio : System.Any_Priority; @@ -474,10 +473,10 @@ package body System.Task_Primitives.Operations is begin Result := pthread_mutex_lock (L.WO'Access); - -- Assume that the cause of EINVAL is a priority ceiling violation + -- The cause of EINVAL is a priority ceiling violation - Ceiling_Violation := (Result = EINVAL); - pragma Assert (Result = 0 or else Result = EINVAL); + Ceiling_Violation := Result = EINVAL; + pragma Assert (Result = 0 or else Ceiling_Violation); end Write_Lock; procedure Write_Lock diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 7c3f7e6..0c3b08e 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -17660,7 +17660,12 @@ package body Sem_Ch3 is end if; while Present (Disc) loop - pragma Assert (Present (Assoc)); + -- If no further associations return the discriminant, value + -- will be found on the second pass. + + if No (Assoc) then + return Result; + end if; if Original_Record_Component (Disc) = Result_Entity then return Node (Assoc); @@ -17690,6 +17695,8 @@ package body Sem_Ch3 is -- ??? This routine is a gigantic mess and will be deleted. For the -- time being just test for the trivial case before calling recurse. + -- We are now celebrating the 20th anniversary of this comment! + if Base_Type (Scope (Discriminant)) = Base_Type (Typ_For_Constraint) then declare D : Entity_Id; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 0a09b16..f069055 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -13548,8 +13548,14 @@ package body Sem_Util is (Is_Object_Reference (Prefix (N)) or else Is_Access_Type (Etype (Prefix (N)))); + -- An explicit dereference denotes an object, except that a + -- conditional expression gets turned into an explicit dereference + -- in some cases, and conditional expressions are not object + -- names. + when N_Explicit_Dereference => - return True; + return not Nkind_In + (Original_Node (N), N_If_Expression, N_Case_Expression); -- A view conversion of a tagged object is an object reference |