Make Non_Preemptive_FIFO_Within_Priorities a standard dispatching policy name as defined in RM D.2.4(2/2).
Create the language-defined library package Ada.Dispatching.Non_Preemptive, as defined in RM D.2.4(2.2/3). This package is marked as unimplemented because no target environment supports it. Add the procedure Ada.Dispatching.Yield, introduced by Ada 2012 in RM D.2.1(1.3/3). The following test should trigger an error in the use of package Ada.Dispatching.Non_Preemptive (not implemented) as shown: pragma Task_Dispatching_Policy (Non_Preemptive_FIFO_Within_Priorities); with Ada.Dispatching.Non_Preemptive; procedure Non_Preemptive is begin null; end Non_Preemptive; $ gcc -c non_preemptive.adb Non_Preemptive is not supported in this configuration compilation abandoned Tested on x86_64-pc-linux-gnu, committed on trunk 2015-02-20 Jose Ruiz <r...@adacore.com> * a-dinopr.ads: Add spec for this package (Unimplemented_Unit). * a-dispat.ads (Yield): Include procedure added in Ada 2012. * a-dispat.adb (Yield): Implement procedure added in Ada 2012. * impunit.adb (Non_Imp_File_Names_05): Mark unit a-dinopr.ads as defined by Ada 2005. * snames.ads-tmpl (Name_Non_Preemptive_FIFO_Within_Priorities): This is the correct name for the dispatching policy (FIFO was missing).
Index: impunit.adb =================================================================== --- impunit.adb (revision 220835) +++ impunit.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2000-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-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- -- @@ -427,6 +427,7 @@ ("a-coorse", T), -- Ada.Containers.Ordered_Sets ("a-coteio", T), -- Ada.Complex_Text_IO ("a-direct", T), -- Ada.Directories + ("a-dinopr", T), -- Ada.Dispatching.Non_Preemptive ("a-diroro", T), -- Ada.Dispatching.Round_Robin ("a-disedf", T), -- Ada.Dispatching.EDF ("a-dispat", T), -- Ada.Dispatching Index: a-dispat.adb =================================================================== --- a-dispat.adb (revision 0) +++ a-dispat.adb (revision 0) @@ -0,0 +1,57 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . D I S P A T C H I N G -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 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- -- +-- 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/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Exceptions; +with System.Tasking; +with System.Task_Primitives.Operations; + +package body Ada.Dispatching is + + procedure Yield is + Self_Id : constant System.Tasking.Task_Id := + System.Task_Primitives.Operations.Self; + + begin + -- If pragma Detect_Blocking is active, Program_Error must be + -- raised if this potentially blocking operation is called from a + -- protected action. + + if System.Tasking.Detect_Blocking + and then Self_Id.Common.Protected_Action_Nesting > 0 + then + Ada.Exceptions.Raise_Exception + (Program_Error'Identity, "potentially blocking operation"); + else + System.Task_Primitives.Operations.Yield; + end if; + end Yield; + +end Ada.Dispatching; Index: a-dispat.ads =================================================================== --- a-dispat.ads (revision 220835) +++ a-dispat.ads (working copy) @@ -14,7 +14,9 @@ ------------------------------------------------------------------------------ package Ada.Dispatching is - pragma Pure (Dispatching); + pragma Preelaborate (Dispatching); + procedure Yield; + Dispatching_Policy_Error : exception; end Ada.Dispatching; Index: a-dinopr.ads =================================================================== --- a-dinopr.ads (revision 0) +++ a-dinopr.ads (revision 0) @@ -0,0 +1,31 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . D I S P A T C H I N G . N O N _ P R E E M P T I V E -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- This unit is not implemented in typical GNAT implementations that lie on +-- top of operating systems, because it is infeasible to implement in such +-- environments. + +-- If a target environment provides appropriate support for this package, +-- then the Unimplemented_Unit pragma should be removed from this spec and +-- an appropriate body provided. + +package Ada.Dispatching.Non_Preemptive is + pragma Preelaborate (Non_Preemptive); + + pragma Unimplemented_Unit; + + procedure Yield_To_Higher; + procedure Yield_To_Same_Or_Higher renames Yield; +end Ada.Dispatching.Non_Preemptive; Index: snames.ads-tmpl =================================================================== --- snames.ads-tmpl (revision 220835) +++ snames.ads-tmpl (working copy) @@ -1063,12 +1063,12 @@ -- for FIFO_Within_Priorities). If new policy names are added, the first -- character must be distinct. - First_Task_Dispatching_Policy_Name : constant Name_Id := N + $; - Name_EDF_Across_Priorities : constant Name_Id := N + $; - Name_FIFO_Within_Priorities : constant Name_Id := N + $; - Name_Non_Preemptive_Within_Priorities : constant Name_Id := N + $; - Name_Round_Robin_Within_Priorities : constant Name_Id := N + $; - Last_Task_Dispatching_Policy_Name : constant Name_Id := N + $; + First_Task_Dispatching_Policy_Name : constant Name_Id := N + $; + Name_EDF_Across_Priorities : constant Name_Id := N + $; + Name_FIFO_Within_Priorities : constant Name_Id := N + $; + Name_Non_Preemptive_FIFO_Within_Priorities : constant Name_Id := N + $; + Name_Round_Robin_Within_Priorities : constant Name_Id := N + $; + Last_Task_Dispatching_Policy_Name : constant Name_Id := N + $; -- Names of recognized partition elaboration policy identifiers