/usr/share/ada/adainclude/gnatcoll/gnatcoll-ravenscar-multiple_queue_sporadic_server.adb is in libgnatcoll1.6-dev 1.6gpl2014-9.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 | ------------------------------------------------------------------------------
-- --
-- G N A T C O L L --
-- --
-- Copyright (C) 2008-2014, AdaCore --
-- --
-- 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 2, 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. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
-- Boston, MA 02110-1301, USA. --
-- --
-- --
-- --
-- --
-- --
-- --
-- --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with GNATCOLL.Ravenscar.Utils;
package body GNATCOLL.Ravenscar.Multiple_Queue_Sporadic_Server is
use GNATCOLL.Ravenscar.Utils;
procedure Put_Request
(Req : Request;
Kind : Request_Kind)
is
begin
-- Simply delegates to Protocol.Put
Protocol.Put (Req, Kind);
end Put_Request;
protected body Protocol is
procedure Update_Barrier is
begin
Barrier := Pending > 0;
end Update_Barrier;
pragma Inline (Update_Barrier);
procedure Put
(Req : Request;
Kind : Request_Kind)
is
Ref : constant Request_Type_Ref :=
Queues (Kind) (Insert_Index (Kind))'Access;
begin
-- put the Req in the appropriate queue
Queues (Kind) (Insert_Index (Kind)) := Req;
-- increase insert index
Increase_Counter (Insert_Index (Kind), QS);
if Pending < Pointer_Queue_Range_Max then
Pending := Pending + 1;
end if;
-- save pointer to last Req on a queue
Ptr_Queue (Pointer_Queue_Insert_Index) := (Kind, Ref);
Increase_Counter
(Pointer_Queue_Insert_Index,
Pointer_Queue_Range_Max);
-- if there has been an overflow, increase also the Extract index.
-- This is because the insert index has surpassed the extract index,
-- overwriting older request. It is thus necessary to increase the
-- extract index to avoid to fetch a newly posted request instead
-- of older ones.
if Pointer_Queue_Overflow then
Increase_Counter
(Pointer_Queue_Extract_Index,
Pointer_Queue_Range_Max);
end if;
-- Check if the Insert_Index is going to surpass the extract index
if Pointer_Queue_Insert_Index = Pointer_Queue_Extract_Index then
Pointer_Queue_Overflow := True;
end if;
-- update the barrier
Update_Barrier;
end Put;
procedure Get_Next_Request (Req : out Request) is
Ref : Pointer_Queue_Item_Ref := null;
begin
if Pointer_Queue_Insert_Index = Pointer_Queue_Extract_Index then
Pointer_Queue_Overflow := False;
end if;
-- get the oldest Req
Ref := Ptr_Queue (Pointer_Queue_Extract_Index)'Access;
Increase_Counter
(Pointer_Queue_Extract_Index,
Pointer_Queue_Range_Max);
Req := Ref.Req.all;
Pending := Pending - 1;
end Get_Next_Request;
pragma Inline (Get_Next_Request);
entry Get
(Req : out Request;
Release_Time : out Ada.Real_Time.Time) when Barrier
is
begin
Release_Time := Ada.Real_Time.Clock;
Get_Next_Request (Req);
Update_Barrier;
end Get;
end Protocol;
task body Sporadic_Task is
Req : Request;
Release_Time : Ada.Real_Time.Time;
Next_Time : Ada.Real_Time.Time := System_Start_Time;
use Ada.Real_Time;
begin
loop
-- report.Print(natural'Image(Pointer_Queue_Range_Max));
delay until Next_Time;
Protocol.Get (Req, Release_Time);
Dispatch (Req);
Next_Time := Release_Time + Milliseconds (Minimum_Interelease_Time);
end loop;
end Sporadic_Task;
end GNATCOLL.Ravenscar.Multiple_Queue_Sporadic_Server;
|