===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- 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
===================================================================
@@ -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;
===================================================================
@@ -14,7 +14,9 @@
------------------------------------------------------------------------------
package Ada.Dispatching is
- pragma Pure (Dispatching);
+ pragma Preelaborate (Dispatching);
+ procedure Yield;
+
Dispatching_Policy_Error : exception;
end Ada.Dispatching;
===================================================================
@@ -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;
===================================================================
@@ -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