-----------------------------------------------------------------------
--  mat-expressions -- Expressions for memory slot selection
--  Copyright (C) 2014, 2015 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Unchecked_Deallocation;

with MAT.Expressions.Parser;
package body MAT.Expressions is

   procedure Free is
     new Ada.Unchecked_Deallocation (Object => Node_Type,
                                     Name   => Node_Type_Access);

   --  Destroy recursively the node, releasing the storage.
   procedure Destroy (Node : in out Node_Type_Access);

   --  ------------------------------
   --  Create a NOT expression node.
   --  ------------------------------
   function Create_Not (Expr : in Expression_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_NOT,
                                    Expr        => Expr.Node);
      Util.Concurrent.Counters.Increment (Expr.Node.Ref_Counter);
      return Result;
   end Create_Not;

   --  ------------------------------
   --  Create a AND expression node.
   --  ------------------------------
   function Create_And (Left  : in Expression_Type;
                        Right : in Expression_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_AND,
                                    Left        => Left.Node,
                                    Right       => Right.Node);
      Util.Concurrent.Counters.Increment (Left.Node.Ref_Counter);
      Util.Concurrent.Counters.Increment (Right.Node.Ref_Counter);
      return Result;
   end Create_And;

   --  ------------------------------
   --  Create a OR expression node.
   --  ------------------------------
   function Create_Or (Left  : in Expression_Type;
                       Right : in Expression_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_OR,
                                    Left        => Left.Node,
                                    Right       => Right.Node);
      Util.Concurrent.Counters.Increment (Left.Node.Ref_Counter);
      Util.Concurrent.Counters.Increment (Right.Node.Ref_Counter);
      return Result;
   end Create_Or;

   --  ------------------------------
   --  Create an INSIDE expression node.
   --  ------------------------------
   function Create_Inside (Name : in Ada.Strings.Unbounded.Unbounded_String;
                           Kind : in Inside_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_INSIDE,
                                    Name        => Name,
                                    Inside      => Kind);
      return Result;
   end Create_Inside;

   --  ------------------------------
   --  Create an size range expression node.
   --  ------------------------------
   function Create_Size (Min : in MAT.Types.Target_Size;
                         Max : in MAT.Types.Target_Size) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_RANGE_SIZE,
                                    Min_Size    => Min,
                                    Max_Size    => Max);
      return Result;
   end Create_Size;

   --  ------------------------------
   --  Create an addr range expression node.
   --  ------------------------------
   function Create_Addr (Min : in MAT.Types.Target_Addr;
                         Max : in MAT.Types.Target_Addr) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_RANGE_ADDR,
                                    Min_Addr    => Min,
                                    Max_Addr    => Max);
      return Result;
   end Create_Addr;

   --  ------------------------------
   --  Create an time range expression node.
   --  ------------------------------
   function Create_Time (Min : in MAT.Types.Target_Tick_Ref;
                         Max : in MAT.Types.Target_Tick_Ref) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_RANGE_TIME,
                                    Min_Time    => Min,
                                    Max_Time    => Max);
      return Result;
   end Create_Time;

   --  ------------------------------
   --  Create a thread ID range expression node.
   --  ------------------------------
   function Create_Thread (Min : in MAT.Types.Target_Thread_Ref;
                           Max : in MAT.Types.Target_Thread_Ref) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_THREAD,
                                    Min_Thread  => Min,
                                    Max_Thread  => Max);
      return Result;
   end Create_Thread;

   --  ------------------------------
   --  Create a event type expression check.
   --  ------------------------------
   function Create_Event_Type (Event_Kind : in MAT.Events.Targets.Probe_Index_Type)
                               return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_TYPE,
                                    Event_Kind  => Event_Kind);
      return Result;
   end Create_Event_Type;

   --  ------------------------------
   --  Create an event ID range expression node.
   --  ------------------------------
   function Create_Event (Min : in MAT.Events.Targets.Event_Id_Type;
                          Max : in MAT.Events.Targets.Event_Id_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_EVENT,
                                    Min_Event   => Min,
                                    Max_Event   => Max);
      return Result;
   end Create_Event;

   --  ------------------------------
   --  Evaluate the expression to check if the memory slot described by the
   --  context is selected.  Returns True if the memory slot is selected.
   --  ------------------------------
   function Is_Selected (Node       : in Expression_Type;
                         Addr       : in MAT.Types.Target_Addr;
                         Allocation : in MAT.Memory.Allocation) return Boolean is
   begin
      if Node.Node = null then
         return True;
      else
         return Is_Selected (Node.Node.all, Addr, Allocation);
      end if;
   end Is_Selected;

   --  ------------------------------
   --  Evaluate the expression to check if the event described by the
   --  context is selected.  Returns True if the event is selected.
   --  ------------------------------
   function Is_Selected (Node       : in Expression_Type;
                         Event      : in MAT.Events.Targets.Probe_Event_Type) return Boolean is
   begin
      return Is_Selected (Node.Node.all, Event);
   end Is_Selected;

   --  ------------------------------
   --  Evaluate the node against the context.  Returns True if the node expression
   --  selects the memory slot defined by the context.
   --  ------------------------------
   function Is_Selected (Node       : in Node_Type;
                         Addr       : in MAT.Types.Target_Addr;
                         Allocation : in MAT.Memory.Allocation) return Boolean is
      use type MAT.Types.Target_Size;
      use type MAT.Types.Target_Tick_Ref;
   begin
      case Node.Kind is
         when N_NOT =>
            return not Is_Selected (Node.Expr.all, Addr, Allocation);

         when N_AND =>
            return Is_Selected (Node.Left.all, Addr, Allocation)
              and then Is_Selected (Node.Right.all, Addr, Allocation);

         when N_OR =>
            return Is_Selected (Node.Left.all, Addr, Allocation)
              or else Is_Selected (Node.Right.all, Addr, Allocation);

         when N_RANGE_SIZE =>
            return Allocation.Size >= Node.Min_Size
              and Allocation.Size <= Node.Max_Size;

         when N_RANGE_ADDR =>
            return Addr >= Node.Min_Addr
              and Addr <= Node.Max_Addr;

         when N_RANGE_TIME =>
            return Allocation.Time >= Node.Min_Time
              and Allocation.Time <= Node.Max_Time;

         when others =>
            return False;

      end case;
   end Is_Selected;

   --  ------------------------------
   --  Evaluate the expression to check if the event described by the
   --  context is selected.  Returns True if the event is selected.
   --  ------------------------------
   function Is_Selected (Node       : in Node_Type;
                         Event      : in MAT.Events.Targets.Probe_Event_Type) return Boolean is
      use type MAT.Types.Target_Size;
      use type MAT.Types.Target_Tick_Ref;
      use type MAT.Types.Target_Thread_Ref;
      use type MAT.Events.Targets.Event_Id_Type;
      use type MAT.Events.Targets.Probe_Index_Type;
   begin
      case Node.Kind is
         when N_NOT =>
            return not Is_Selected (Node.Expr.all, Event);

         when N_AND =>
            return Is_Selected (Node.Left.all, Event)
              and then Is_Selected (Node.Right.all, Event);

         when N_OR =>
            return Is_Selected (Node.Left.all, Event)
              or else Is_Selected (Node.Right.all, Event);

         when N_RANGE_SIZE =>
            return Event.Size >= Node.Min_Size
              and Event.Size <= Node.Max_Size;

         when N_RANGE_ADDR =>
            return Event.Addr >= Node.Min_Addr
              and Event.Addr <= Node.Max_Addr;

         when N_RANGE_TIME =>
            return Event.Time >= Node.Min_Time
              and Event.Time <= Node.Max_Time;

         when N_EVENT =>
            return Event.Id >= Node.Min_Event
              and Event.Id <= Node.Max_Event;

         when N_THREAD =>
            return Event.Thread >= Node.Min_Thread
              and Event.Thread <= Node.Max_Thread;

         when N_TYPE =>
            return Event.Index = Node.Event_Kind;

         when others =>
            return False;

      end case;
   end Is_Selected;

   --  ------------------------------
   --  Parse the string and return the expression tree.
   --  ------------------------------
   function Parse (Expr : in String) return Expression_Type is
   begin
      return MAT.Expressions.Parser.Parse (Expr);
   end Parse;

   --  ------------------------------
   --  Destroy recursively the node, releasing the storage.
   --  ------------------------------
   procedure Destroy (Node : in out Node_Type_Access) is
      Release : Boolean;
   begin
      if Node /= null then
         Util.Concurrent.Counters.Decrement (Node.Ref_Counter, Release);
         if Release then
            case Node.Kind is
            when N_NOT =>
               Destroy (Node.Expr);

            when N_AND | N_OR =>
               Destroy (Node.Left);
               Destroy (Node.Right);

            when others =>
               null;
            end case;
            Free (Node);
         else
            Node := null;
         end if;
      end if;
   end Destroy;

   --  ------------------------------
   --  Release the reference and destroy the expression tree if it was the last reference.
   --  ------------------------------
   overriding
   procedure Finalize (Obj : in out Expression_Type) is
   begin
      if Obj.Node /= null then
         Destroy (Obj.Node);
      end if;
   end Finalize;

   --  ------------------------------
   --  Update the reference after an assignment.
   --  ------------------------------
   overriding
   procedure Adjust (Obj : in out Expression_Type) is
   begin
      if Obj.Node /= null then
         Util.Concurrent.Counters.Increment (Obj.Node.Ref_Counter);
      end if;
   end Adjust;

end MAT.Expressions;

-----------------------------------------------------------------------
--  mat-expressions -- Expressions for event and memory slot selection
--  Copyright (C) 2014, 2015 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Unchecked_Deallocation;

with MAT.Expressions.Parser;
package body MAT.Expressions is

   procedure Free is
     new Ada.Unchecked_Deallocation (Object => Node_Type,
                                     Name   => Node_Type_Access);

   --  Destroy recursively the node, releasing the storage.
   procedure Destroy (Node : in out Node_Type_Access);

   --  ------------------------------
   --  Create a NOT expression node.
   --  ------------------------------
   function Create_Not (Expr : in Expression_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_NOT,
                                    Expr        => Expr.Node);
      Util.Concurrent.Counters.Increment (Expr.Node.Ref_Counter);
      return Result;
   end Create_Not;

   --  ------------------------------
   --  Create a AND expression node.
   --  ------------------------------
   function Create_And (Left  : in Expression_Type;
                        Right : in Expression_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_AND,
                                    Left        => Left.Node,
                                    Right       => Right.Node);
      Util.Concurrent.Counters.Increment (Left.Node.Ref_Counter);
      Util.Concurrent.Counters.Increment (Right.Node.Ref_Counter);
      return Result;
   end Create_And;

   --  ------------------------------
   --  Create a OR expression node.
   --  ------------------------------
   function Create_Or (Left  : in Expression_Type;
                       Right : in Expression_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_OR,
                                    Left        => Left.Node,
                                    Right       => Right.Node);
      Util.Concurrent.Counters.Increment (Left.Node.Ref_Counter);
      Util.Concurrent.Counters.Increment (Right.Node.Ref_Counter);
      return Result;
   end Create_Or;

   --  ------------------------------
   --  Create an INSIDE expression node.
   --  ------------------------------
   function Create_Inside (Name : in Ada.Strings.Unbounded.Unbounded_String;
                           Kind : in Inside_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_INSIDE,
                                    Name        => Name,
                                    Inside      => Kind);
      return Result;
   end Create_Inside;

   --  ------------------------------
   --  Create an size range expression node.
   --  ------------------------------
   function Create_Size (Min : in MAT.Types.Target_Size;
                         Max : in MAT.Types.Target_Size) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_RANGE_SIZE,
                                    Min_Size    => Min,
                                    Max_Size    => Max);
      return Result;
   end Create_Size;

   --  ------------------------------
   --  Create an addr range expression node.
   --  ------------------------------
   function Create_Addr (Min : in MAT.Types.Target_Addr;
                         Max : in MAT.Types.Target_Addr) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_RANGE_ADDR,
                                    Min_Addr    => Min,
                                    Max_Addr    => Max);
      return Result;
   end Create_Addr;

   --  ------------------------------
   --  Create an time range expression node.
   --  ------------------------------
   function Create_Time (Min : in MAT.Types.Target_Tick_Ref;
                         Max : in MAT.Types.Target_Tick_Ref) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_RANGE_TIME,
                                    Min_Time    => Min,
                                    Max_Time    => Max);
      return Result;
   end Create_Time;

   --  ------------------------------
   --  Create a thread ID range expression node.
   --  ------------------------------
   function Create_Thread (Min : in MAT.Types.Target_Thread_Ref;
                           Max : in MAT.Types.Target_Thread_Ref) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_THREAD,
                                    Min_Thread  => Min,
                                    Max_Thread  => Max);
      return Result;
   end Create_Thread;

   --  ------------------------------
   --  Create a event type expression check.
   --  ------------------------------
   function Create_Event_Type (Event_Kind : in MAT.Events.Targets.Probe_Index_Type)
                               return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_TYPE,
                                    Event_Kind  => Event_Kind);
      return Result;
   end Create_Event_Type;

   --  ------------------------------
   --  Create an event ID range expression node.
   --  ------------------------------
   function Create_Event (Min : in MAT.Events.Targets.Event_Id_Type;
                          Max : in MAT.Events.Targets.Event_Id_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_EVENT,
                                    Min_Event   => Min,
                                    Max_Event   => Max);
      return Result;
   end Create_Event;

   --  ------------------------------
   --  Evaluate the expression to check if the memory slot described by the
   --  context is selected.  Returns True if the memory slot is selected.
   --  ------------------------------
   function Is_Selected (Node       : in Expression_Type;
                         Addr       : in MAT.Types.Target_Addr;
                         Allocation : in MAT.Memory.Allocation) return Boolean is
   begin
      if Node.Node = null then
         return True;
      else
         return Is_Selected (Node.Node.all, Addr, Allocation);
      end if;
   end Is_Selected;

   --  ------------------------------
   --  Evaluate the expression to check if the event described by the
   --  context is selected.  Returns True if the event is selected.
   --  ------------------------------
   function Is_Selected (Node       : in Expression_Type;
                         Event      : in MAT.Events.Targets.Probe_Event_Type) return Boolean is
   begin
      return Is_Selected (Node.Node.all, Event);
   end Is_Selected;

   --  ------------------------------
   --  Evaluate the node against the context.  Returns True if the node expression
   --  selects the memory slot defined by the context.
   --  ------------------------------
   function Is_Selected (Node       : in Node_Type;
                         Addr       : in MAT.Types.Target_Addr;
                         Allocation : in MAT.Memory.Allocation) return Boolean is
      use type MAT.Types.Target_Size;
      use type MAT.Types.Target_Tick_Ref;
   begin
      case Node.Kind is
         when N_NOT =>
            return not Is_Selected (Node.Expr.all, Addr, Allocation);

         when N_AND =>
            return Is_Selected (Node.Left.all, Addr, Allocation)
              and then Is_Selected (Node.Right.all, Addr, Allocation);

         when N_OR =>
            return Is_Selected (Node.Left.all, Addr, Allocation)
              or else Is_Selected (Node.Right.all, Addr, Allocation);

         when N_RANGE_SIZE =>
            return Allocation.Size >= Node.Min_Size
              and Allocation.Size <= Node.Max_Size;

         when N_RANGE_ADDR =>
            return Addr >= Node.Min_Addr
              and Addr <= Node.Max_Addr;

         when N_RANGE_TIME =>
            return Allocation.Time >= Node.Min_Time
              and Allocation.Time <= Node.Max_Time;

         when others =>
            return False;

      end case;
   end Is_Selected;

   --  ------------------------------
   --  Evaluate the expression to check if the event described by the
   --  context is selected.  Returns True if the event is selected.
   --  ------------------------------
   function Is_Selected (Node       : in Node_Type;
                         Event      : in MAT.Events.Targets.Probe_Event_Type) return Boolean is
      use type MAT.Types.Target_Size;
      use type MAT.Types.Target_Tick_Ref;
      use type MAT.Types.Target_Thread_Ref;
      use type MAT.Events.Targets.Event_Id_Type;
      use type MAT.Events.Targets.Probe_Index_Type;
   begin
      case Node.Kind is
         when N_NOT =>
            return not Is_Selected (Node.Expr.all, Event);

         when N_AND =>
            return Is_Selected (Node.Left.all, Event)
              and then Is_Selected (Node.Right.all, Event);

         when N_OR =>
            return Is_Selected (Node.Left.all, Event)
              or else Is_Selected (Node.Right.all, Event);

         when N_RANGE_SIZE =>
            return Event.Size >= Node.Min_Size
              and Event.Size <= Node.Max_Size;

         when N_RANGE_ADDR =>
            return Event.Addr >= Node.Min_Addr
              and Event.Addr <= Node.Max_Addr;

         when N_RANGE_TIME =>
            return Event.Time >= Node.Min_Time
              and Event.Time <= Node.Max_Time;

         when N_EVENT =>
            return Event.Id >= Node.Min_Event
              and Event.Id <= Node.Max_Event;

         when N_THREAD =>
            return Event.Thread >= Node.Min_Thread
              and Event.Thread <= Node.Max_Thread;

         when N_TYPE =>
            return Event.Index = Node.Event_Kind;

         when others =>
            return False;

      end case;
   end Is_Selected;

   --  ------------------------------
   --  Parse the string and return the expression tree.
   --  ------------------------------
   function Parse (Expr : in String) return Expression_Type is
   begin
      return MAT.Expressions.Parser.Parse (Expr);
   end Parse;

   --  ------------------------------
   --  Destroy recursively the node, releasing the storage.
   --  ------------------------------
   procedure Destroy (Node : in out Node_Type_Access) is
      Release : Boolean;
   begin
      if Node /= null then
         Util.Concurrent.Counters.Decrement (Node.Ref_Counter, Release);
         if Release then
            case Node.Kind is
            when N_NOT =>
               Destroy (Node.Expr);

            when N_AND | N_OR =>
               Destroy (Node.Left);
               Destroy (Node.Right);

            when others =>
               null;
            end case;
            Free (Node);
         else
            Node := null;
         end if;
      end if;
   end Destroy;

   --  ------------------------------
   --  Release the reference and destroy the expression tree if it was the last reference.
   --  ------------------------------
   overriding
   procedure Finalize (Obj : in out Expression_Type) is
   begin
      if Obj.Node /= null then
         Destroy (Obj.Node);
      end if;
   end Finalize;

   --  ------------------------------
   --  Update the reference after an assignment.
   --  ------------------------------
   overriding
   procedure Adjust (Obj : in out Expression_Type) is
   begin
      if Obj.Node /= null then
         Util.Concurrent.Counters.Increment (Obj.Node.Ref_Counter);
      end if;
   end Adjust;

end MAT.Expressions;

Update the title comment

Update the title comment


--  SPDX-License-Identifier: Apache-2.0
--
--  Copyright (c) 2017 onox <denkpadje@gmail.com>
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.

with System.Multiprocessors.Dispatching_Domains;

with Ada.Unchecked_Conversion;
with Ada.Unchecked_Deallocation;
with Ada.Exceptions;

with Orka.Futures;
with Orka.Loggers;
with Orka.Logging;
with Orka.Simulation;
with Orka.Simulation_Jobs;

package body Orka.Loops is

   use all type Orka.Logging.Source;
   use all type Orka.Logging.Severity;
   use Orka.Logging;

   package Messages is new Orka.Logging.Messages (Game_Loop);

   function "+" (Value : Ada.Real_Time.Time_Span) return Duration
     renames Ada.Real_Time.To_Duration;

   procedure Free is new Ada.Unchecked_Deallocation
     (Behaviors.Behavior_Array, Behaviors.Behavior_Array_Access);

   function "<" (Left, Right : Behaviors.Behavior_Ptr) return Boolean is
      function Convert is new Ada.Unchecked_Conversion
        (Source => System.Address, Target => Long_Integer);
   begin
      return Convert (Left.all'Address) < Convert (Right.all'Address);
   end "<";

   protected body Handler is
      procedure Stop is
      begin
         Stop_Flag := True;
      end Stop;

      procedure Set_Frame_Limit (Value : Time_Span) is
      begin
         Limit := Value;
      end Set_Frame_Limit;

      function Frame_Limit return Time_Span is (Limit);

      procedure Enable_Limit (Enable : Boolean) is
      begin
         Limit_Flag := Enable;
      end Enable_Limit;

      function Limit_Enabled return Boolean is (Limit_Flag);

      function Should_Stop return Boolean is (Stop_Flag);
   end Handler;

   protected body Scene is
      procedure Add (Object : Behaviors.Behavior_Ptr) is
      begin
         Behaviors_Set.Insert (Object);
         Modified_Flag := True;
      end Add;

      procedure Remove (Object : Behaviors.Behavior_Ptr) is
      begin
         Behaviors_Set.Delete (Object);
         Modified_Flag := True;
      end Remove;

      procedure Replace_Array (Target : in out Behaviors.Behavior_Array_Access) is
         pragma Assert (Modified);

         Index : Positive := 1;
         Count : constant Positive := Positive (Behaviors_Set.Length);
      begin
         Free (Target);
         Target := new Behaviors.Behavior_Array'(1 .. Count => Behaviors.Null_Behavior);

         --  Copy the elements from the set to the array
         --  for faster iteration by the game loop
         for Element of Behaviors_Set loop
            Target (Index) := Element;
            Index := Index + 1;
         end loop;

         Modified_Flag := False;
      end Replace_Array;

      function Modified return Boolean is
        (Modified_Flag);

      procedure Set_Camera (Camera : Cameras.Camera_Ptr) is
      begin
         Scene_Camera := Camera;
      end Set_Camera;

      function Camera return Cameras.Camera_Ptr is
        (Scene_Camera);
   end Scene;

   package SJ renames Simulation_Jobs;

   procedure Stop_Loop is
   begin
      Handler.Stop;
   end Stop_Loop;

   procedure Run_Game_Loop
     (Fence  : not null access SJ.Fences.Buffer_Fence;
      Render : Simulation.Render_Ptr)
   is
      Previous_Time : Time := Clock;
      Next_Time     : Time := Previous_Time;

      Lag : Time_Span := Time_Span_Zero;

      Scene_Array : not null Behaviors.Behavior_Array_Access := Behaviors.Empty_Behavior_Array;
      Batch_Length : constant := 10;

      One_Second  : constant Time_Span := Seconds (1);

      Frame_Counter          : Natural := 0;
      Exceeded_Frame_Counter : Natural := 0;
      Clock_FPS_Start : Time := Clock;

      Stat_Sum : Time_Span := Time_Span_Zero;
      Stat_Min : Duration  := To_Duration (One_Second);
      Stat_Max : Duration  := To_Duration (-One_Second);
   begin
      Scene.Replace_Array (Scene_Array);

      Messages.Log (Debug, "Simulation tick resolution: " & Trim (Image (+Tick)));

      --  Based on http://gameprogrammingpatterns.com/game-loop.html
      loop
         declare
            Current_Time : constant Time := Clock;
            Elapsed : constant Time_Span := Current_Time - Previous_Time;
         begin
            Previous_Time := Current_Time;
            Lag := Lag + Elapsed;

            exit when Handler.Should_Stop;

            declare
               Iterations : constant Natural := Lag / Time_Step;
            begin
               Lag := Lag - Iterations * Time_Step;
               Scene.Camera.Update (To_Duration (Lag));

               declare
                  Fixed_Update_Job : constant Jobs.Job_Ptr
                    := Jobs.Parallelize (SJ.Create_Fixed_Update_Job
                         (Scene_Array, Time_Step, Iterations),
                         SJ.Clone_Fixed_Update_Job'Access,
                         Scene_Array'Length, Batch_Length);

                  Finished_Job : constant Jobs.Job_Ptr := SJ.Create_Finished_Job
                    (Scene_Array, Time_Step, Scene.Camera.View_Position, Batch_Length);

                  Render_Scene_Job : constant Jobs.Job_Ptr
                    := SJ.Create_Scene_Render_Job (Render, Scene_Array, Scene.Camera);

                  Render_Start_Job  : constant Jobs.Job_Ptr
                    := SJ.Create_Start_Render_Job (Fence);
                  Render_Finish_Job : constant Jobs.Job_Ptr
                    := SJ.Create_Finish_Render_Job (Fence);

                  Handle : Futures.Pointers.Mutable_Pointer;
                  Status : Futures.Status;
               begin
                  Orka.Jobs.Chain
                    ((Render_Start_Job, Fixed_Update_Job, Finished_Job,
                      Render_Scene_Job, Render_Finish_Job));

                  Job_Manager.Queue.Enqueue (Render_Start_Job, Handle);

                  declare
                     Frame_Future : constant Orka.Futures.Future_Access := Handle.Get.Value;
                  begin
                     select
                        Frame_Future.Wait_Until_Done (Status);
                     or
                        delay until Current_Time + Maximum_Frame_Time;
                        raise Program_Error with
                          "Maximum frame time of " & Trim (Image (+Maximum_Frame_Time)) &
                          " exceeded";
                     end select;
                  end;
               end;
            end;

            if Scene.Modified then
               Scene.Replace_Array (Scene_Array);
            end if;

            declare
               Total_Elapsed  : constant Time_Span := Clock - Clock_FPS_Start;
               Limit_Exceeded : constant Time_Span := Elapsed - Handler.Frame_Limit;
            begin
               Frame_Counter := Frame_Counter + 1;

               if Limit_Exceeded > Time_Span_Zero then
                  Stat_Sum := Stat_Sum + Limit_Exceeded;
                  Stat_Min := Duration'Min (Stat_Min, To_Duration (Limit_Exceeded));
                  Stat_Max := Duration'Max (Stat_Max, To_Duration (Limit_Exceeded));
                  Exceeded_Frame_Counter := Exceeded_Frame_Counter + 1;
               end if;

               if Total_Elapsed > One_Second then
                  declare
                     Frame_Time : constant Time_Span := Total_Elapsed / Frame_Counter;
                     FPS        : constant Integer   := Integer (1.0 / To_Duration (Frame_Time));
                  begin
                     Messages.Log (Debug, Trim (FPS'Image) & " FPS, frame time: " &
                       Trim (Image (+Frame_Time)));
                  end;

                  if Exceeded_Frame_Counter > 0 then
                     declare
                        Stat_Avg : constant Duration := +(Stat_Sum / Exceeded_Frame_Counter);
                     begin
                        Messages.Log (Debug, "  deadline missed: " &
                          Trim (Exceeded_Frame_Counter'Image) & " (limit is " &
                          Trim (Image (+Handler.Frame_Limit)) & ")");
                        Messages.Log (Debug, "    avg/min/max: " &
                          Image (Stat_Avg) &
                          Image (Stat_Min) &
                          Image (Stat_Max));
                     end;
                  end if;

                  Clock_FPS_Start := Clock;
                  Frame_Counter          := 0;
                  Exceeded_Frame_Counter := 0;

                  Stat_Sum := Time_Span_Zero;
                  Stat_Min := To_Duration (One_Second);
                  Stat_Max := To_Duration (Time_Span_Zero);
               end if;
            end;

            if Handler.Limit_Enabled then
               --  Do not sleep if Next_Time fell behind more than one frame
               --  due to high workload (FPS dropping below limit), otherwise
               --  the FPS will be exceeded during a subsequent low workload
               --  until Next_Time has catched up
               if Next_Time < Current_Time - Handler.Frame_Limit then
                  Next_Time := Current_Time;
               else
                  Next_Time := Next_Time + Handler.Frame_Limit;
                  delay until Next_Time;
               end if;
            end if;
         end;
      end loop;

      Job_Manager.Shutdown;
   exception
      when others =>
         Job_Manager.Shutdown;
         raise;
   end Run_Game_Loop;

   procedure Run_Loop
     (Render : not null access procedure
        (Scene  : not null Behaviors.Behavior_Array_Access;
         Camera : Cameras.Camera_Ptr))
   is
      Fence : aliased SJ.Fences.Buffer_Fence := SJ.Fences.Create_Buffer_Fence;
   begin
      declare
         --  Create a separate task for the game loop. The current task
         --  will be used to dequeue and execute GPU jobs.
         task Simulation;

         task body Simulation is
         begin
            System.Multiprocessors.Dispatching_Domains.Set_CPU (1);
            Run_Game_Loop (Fence'Unchecked_Access, Render);
         exception
            when Error : others =>
               Messages.Log (Loggers.Error, Ada.Exceptions.Exception_Information (Error));
         end Simulation;
      begin
         System.Multiprocessors.Dispatching_Domains.Set_CPU (1);

         --  Execute GPU jobs in the current task
         Job_Manager.Execute_GPU_Jobs;
      end;
   end Run_Loop;

end Orka.Loops;

--  SPDX-License-Identifier: Apache-2.0
--
--  Copyright (c) 2017 onox <denkpadje@gmail.com>
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.

with System.Multiprocessors.Dispatching_Domains;

with Ada.Unchecked_Conversion;
with Ada.Unchecked_Deallocation;
with Ada.Exceptions;

with Orka.Futures;
with Orka.Loggers;
with Orka.Logging;
with Orka.Simulation;
with Orka.Simulation_Jobs;

package body Orka.Loops is

   use all type Orka.Logging.Source;
   use all type Orka.Logging.Severity;
   use Orka.Logging;

   package Messages is new Orka.Logging.Messages (Game_Loop);

   function "+" (Value : Ada.Real_Time.Time_Span) return Duration
     renames Ada.Real_Time.To_Duration;

   procedure Free is new Ada.Unchecked_Deallocation
     (Behaviors.Behavior_Array, Behaviors.Behavior_Array_Access);

   function "<" (Left, Right : Behaviors.Behavior_Ptr) return Boolean is
      function Convert is new Ada.Unchecked_Conversion
        (Source => System.Address, Target => Long_Integer);
   begin
      return Convert (Left.all'Address) < Convert (Right.all'Address);
   end "<";

   protected body Handler is
      procedure Stop is
      begin
         Stop_Flag := True;
      end Stop;

      procedure Set_Frame_Limit (Value : Time_Span) is
      begin
         Limit := Value;
      end Set_Frame_Limit;

      function Frame_Limit return Time_Span is (Limit);

      procedure Enable_Limit (Enable : Boolean) is
      begin
         Limit_Flag := Enable;
      end Enable_Limit;

      function Limit_Enabled return Boolean is (Limit_Flag);

      function Should_Stop return Boolean is (Stop_Flag);
   end Handler;

   protected body Scene is
      procedure Add (Object : Behaviors.Behavior_Ptr) is
      begin
         Behaviors_Set.Insert (Object);
         Modified_Flag := True;
      end Add;

      procedure Remove (Object : Behaviors.Behavior_Ptr) is
      begin
         Behaviors_Set.Delete (Object);
         Modified_Flag := True;
      end Remove;

      procedure Replace_Array (Target : in out Behaviors.Behavior_Array_Access) is
         pragma Assert (Modified);

         Index : Positive := 1;
         Count : constant Positive := Positive (Behaviors_Set.Length);
      begin
         Free (Target);
         Target := new Behaviors.Behavior_Array'(1 .. Count => Behaviors.Null_Behavior);

         --  Copy the elements from the set to the array
         --  for faster iteration by the game loop
         for Element of Behaviors_Set loop
            Target (Index) := Element;
            Index := Index + 1;
         end loop;

         Modified_Flag := False;
      end Replace_Array;

      function Modified return Boolean is
        (Modified_Flag);

      procedure Set_Camera (Camera : Cameras.Camera_Ptr) is
      begin
         Scene_Camera := Camera;
      end Set_Camera;

      function Camera return Cameras.Camera_Ptr is
        (Scene_Camera);
   end Scene;

   package SJ renames Simulation_Jobs;

   procedure Stop_Loop is
   begin
      Handler.Stop;
   end Stop_Loop;

   procedure Run_Game_Loop
     (Fence  : not null access SJ.Fences.Buffer_Fence;
      Render : Simulation.Render_Ptr)
   is
      subtype Time is Ada.Real_Time.Time;

      Previous_Time : Time := Clock;
      Next_Time     : Time := Previous_Time;

      Lag : Time_Span := Time_Span_Zero;

      Scene_Array : not null Behaviors.Behavior_Array_Access := Behaviors.Empty_Behavior_Array;
      Batch_Length : constant := 10;

      One_Second  : constant Time_Span := Seconds (1);

      Frame_Counter          : Natural := 0;
      Exceeded_Frame_Counter : Natural := 0;
      Clock_FPS_Start : Time := Clock;

      Stat_Sum : Time_Span := Time_Span_Zero;
      Stat_Min : Duration  := To_Duration (One_Second);
      Stat_Max : Duration  := To_Duration (-One_Second);
   begin
      Scene.Replace_Array (Scene_Array);

      Messages.Log (Debug, "Simulation tick resolution: " & Trim (Image (+Tick)));

      --  Based on http://gameprogrammingpatterns.com/game-loop.html
      loop
         declare
            Current_Time : constant Time := Clock;
            Elapsed : constant Time_Span := Current_Time - Previous_Time;
         begin
            Previous_Time := Current_Time;
            Lag := Lag + Elapsed;

            exit when Handler.Should_Stop;

            declare
               Iterations : constant Natural := Lag / Time_Step;
            begin
               Lag := Lag - Iterations * Time_Step;
               Scene.Camera.Update (To_Duration (Lag));

               declare
                  Fixed_Update_Job : constant Jobs.Job_Ptr
                    := Jobs.Parallelize (SJ.Create_Fixed_Update_Job
                         (Scene_Array, Time_Step, Iterations),
                         SJ.Clone_Fixed_Update_Job'Access,
                         Scene_Array'Length, Batch_Length);

                  Finished_Job : constant Jobs.Job_Ptr := SJ.Create_Finished_Job
                    (Scene_Array, Time_Step, Scene.Camera.View_Position, Batch_Length);

                  Render_Scene_Job : constant Jobs.Job_Ptr
                    := SJ.Create_Scene_Render_Job (Render, Scene_Array, Scene.Camera);

                  Render_Start_Job  : constant Jobs.Job_Ptr
                    := SJ.Create_Start_Render_Job (Fence);
                  Render_Finish_Job : constant Jobs.Job_Ptr
                    := SJ.Create_Finish_Render_Job (Fence);

                  Handle : Futures.Pointers.Mutable_Pointer;
                  Status : Futures.Status;
               begin
                  Orka.Jobs.Chain
                    ((Render_Start_Job, Fixed_Update_Job, Finished_Job,
                      Render_Scene_Job, Render_Finish_Job));

                  Job_Manager.Queue.Enqueue (Render_Start_Job, Handle);

                  declare
                     Frame_Future : constant Orka.Futures.Future_Access := Handle.Get.Value;
                  begin
                     select
                        Frame_Future.Wait_Until_Done (Status);
                     or
                        delay until Current_Time + Maximum_Frame_Time;
                        raise Program_Error with
                          "Maximum frame time of " & Trim (Image (+Maximum_Frame_Time)) &
                          " exceeded";
                     end select;
                  end;
               end;
            end;

            if Scene.Modified then
               Scene.Replace_Array (Scene_Array);
            end if;

            declare
               Total_Elapsed  : constant Time_Span := Clock - Clock_FPS_Start;
               Limit_Exceeded : constant Time_Span := Elapsed - Handler.Frame_Limit;
            begin
               Frame_Counter := Frame_Counter + 1;

               if Limit_Exceeded > Time_Span_Zero then
                  Stat_Sum := Stat_Sum + Limit_Exceeded;
                  Stat_Min := Duration'Min (Stat_Min, To_Duration (Limit_Exceeded));
                  Stat_Max := Duration'Max (Stat_Max, To_Duration (Limit_Exceeded));
                  Exceeded_Frame_Counter := Exceeded_Frame_Counter + 1;
               end if;

               if Total_Elapsed > One_Second then
                  declare
                     Frame_Time : constant Time_Span := Total_Elapsed / Frame_Counter;
                     FPS        : constant Integer   := Integer (1.0 / To_Duration (Frame_Time));
                  begin
                     Messages.Log (Debug, Trim (FPS'Image) & " FPS, frame time: " &
                       Trim (Image (+Frame_Time)));
                  end;

                  if Exceeded_Frame_Counter > 0 then
                     declare
                        Stat_Avg : constant Duration := +(Stat_Sum / Exceeded_Frame_Counter);
                     begin
                        Messages.Log (Debug, "  deadline missed: " &
                          Trim (Exceeded_Frame_Counter'Image) & " (limit is " &
                          Trim (Image (+Handler.Frame_Limit)) & ")");
                        Messages.Log (Debug, "    avg/min/max: " &
                          Image (Stat_Avg) &
                          Image (Stat_Min) &
                          Image (Stat_Max));
                     end;
                  end if;

                  Clock_FPS_Start := Clock;
                  Frame_Counter          := 0;
                  Exceeded_Frame_Counter := 0;

                  Stat_Sum := Time_Span_Zero;
                  Stat_Min := To_Duration (One_Second);
                  Stat_Max := To_Duration (Time_Span_Zero);
               end if;
            end;

            if Handler.Limit_Enabled then
               --  Do not sleep if Next_Time fell behind more than one frame
               --  due to high workload (FPS dropping below limit), otherwise
               --  the FPS will be exceeded during a subsequent low workload
               --  until Next_Time has catched up
               if Next_Time < Current_Time - Handler.Frame_Limit then
                  Next_Time := Current_Time;
               else
                  Next_Time := Next_Time + Handler.Frame_Limit;
                  delay until Next_Time;
               end if;
            end if;
         end;
      end loop;

      Job_Manager.Shutdown;
   exception
      when others =>
         Job_Manager.Shutdown;
         raise;
   end Run_Game_Loop;

   procedure Run_Loop
     (Render : not null access procedure
        (Scene  : not null Behaviors.Behavior_Array_Access;
         Camera : Cameras.Camera_Ptr))
   is
      Fence : aliased SJ.Fences.Buffer_Fence := SJ.Fences.Create_Buffer_Fence;
   begin
      declare
         --  Create a separate task for the game loop. The current task
         --  will be used to dequeue and execute GPU jobs.
         task Simulation;

         task body Simulation is
         begin
            System.Multiprocessors.Dispatching_Domains.Set_CPU (1);
            Run_Game_Loop (Fence'Unchecked_Access, Render);
         exception
            when Error : others =>
               Messages.Log (Loggers.Error, Ada.Exceptions.Exception_Information (Error));
         end Simulation;
      begin
         System.Multiprocessors.Dispatching_Domains.Set_CPU (1);

         --  Execute GPU jobs in the current task
         Job_Manager.Execute_GPU_Jobs;
      end;
   end Run_Loop;

end Orka.Loops;

Fix compilation of package Orka.Loops

orka: Fix compilation of package Orka.Loops

Signed-off-by: onox <34c1d3d2d1347bea60a26f46574de21a7a79b6d5@gmail.com>


-----------------------------------------------------------------------
--  security-contexts -- Context to provide security information and verify permissions
--  Copyright (C) 2011, 2012 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Ada.Task_Attributes;
with Ada.Unchecked_Deallocation;

package body Security.Contexts is

   use type Security.Policies.Policy_Context_Array_Access;
   use type Security.Policies.Policy_Access;
   use type Security.Policies.Policy_Context_Access;

   package Task_Context is new Ada.Task_Attributes
     (Security_Context_Access, null);

   procedure Free is
      new Ada.Unchecked_Deallocation (Object => Security.Policies.Policy_Context'Class,
                                      Name   => Security.Policies.Policy_Context_Access);

   --  ------------------------------
   --  Get the application associated with the current service operation.
   --  ------------------------------
   function Get_User_Principal (Context : in Security_Context'Class)
                                return Security.Principal_Access is
   begin
      return Context.Principal;
   end Get_User_Principal;

   --  ------------------------------
   --  Get the permission manager.
   --  ------------------------------
   function Get_Permission_Manager (Context : in Security_Context'Class)
                                    return Security.Policies.Policy_Manager_Access is
   begin
      return Context.Manager;
   end Get_Permission_Manager;

   --  ------------------------------
   --  Get the policy with the name Name registered in the policy manager.
   --  Returns null if there is no such policy.
   --  ------------------------------
   function Get_Policy (Context : in Security_Context'Class;
                        Name    : in String) return Security.Policies.Policy_Access is
      use type Security.Policies.Policy_Manager_Access;
   begin
      if Context.Manager = null then
         return null;
      else
         return Context.Manager.Get_Policy (Name);
      end if;
   end Get_Policy;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   procedure Has_Permission (Context    : in out Security_Context;
                             Permission : in Security.Permissions.Permission_Index;
                             Result     : out Boolean) is
      use type Security.Policies.Policy_Manager_Access;
   begin
      if Context.Manager = null then
         Result := False;
         return;
      end if;
      declare
         Perm : Security.Permissions.Permission (Permission);
      begin
         Result := Context.Manager.Has_Permission (Context, Perm);
      end;
   end Has_Permission;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   procedure Has_Permission (Context    : in out Security_Context;
                             Permission : in String;
                             Result     : out Boolean) is
      Index : constant Permissions.Permission_Index
        := Permissions.Get_Permission_Index (Permission);
   begin
      Security_Context'Class (Context).Has_Permission (Index, Result);
   end Has_Permission;

   --  ------------------------------
   --  Initializes the service context.  By creating the Security_Context variable,
   --  the instance will be associated with the current task attribute.  If the current task
   --  already has a security context, the new security context is installed, the old one
   --  being kept.
   --  ------------------------------
   overriding
   procedure Initialize (Context : in out Security_Context) is
   begin
      Context.Previous := Task_Context.Value;
      Task_Context.Set_Value (Context'Unchecked_Access);
   end Initialize;

   --  ------------------------------
   --  Finalize the security context releases any object.  The previous security context is
   --  restored to the current task attribute.
   --  ------------------------------
   overriding
   procedure Finalize (Context : in out Security_Context) is

      procedure Free is
        new Ada.Unchecked_Deallocation (Object => Security.Policies.Policy_Context_Array,
                                        Name   => Security.Policies.Policy_Context_Array_Access);
   begin
      Task_Context.Set_Value (Context.Previous);
      if Context.Contexts /= null then
         for I in Context.Contexts'Range loop
            Free (Context.Contexts (I));
         end loop;
         Free (Context.Contexts);
      end if;
   end Finalize;

   --  ------------------------------
   --  Set a policy context information represented by Value and associated with
   --  the policy index Policy.
   --  ------------------------------
   procedure Set_Policy_Context (Context   : in out Security_Context;
                                 Policy    : in Security.Policies.Policy_Access;
                                 Value     : in Security.Policies.Policy_Context_Access) is
   begin
      if Context.Contexts = null then
         Context.Contexts := Context.Manager.Create_Policy_Contexts;
      end if;
      Free (Context.Contexts (Policy.Get_Policy_Index));
      Context.Contexts (Policy.Get_Policy_Index) := Value;
   end Set_Policy_Context;

   --  ------------------------------
   --  Get the policy context information registered for the given security policy in the security
   --  context Context.
   --  Raises Invalid_Context if there is no such information.
   --  Raises Invalid_Policy if the policy was not set.
   --  ------------------------------
   function Get_Policy_Context (Context  : in Security_Context;
                                Policy   : in Security.Policies.Policy_Access)
                                return Security.Policies.Policy_Context_Access is
      Result : Security.Policies.Policy_Context_Access;
   begin
      if Policy = null then
         raise Invalid_Policy;
      end if;
      if Context.Contexts = null then
         raise Invalid_Context;
      end if;
      Result := Context.Contexts (Policy.Get_Policy_Index);
      return Result;
   end Get_Policy_Context;

   --  ------------------------------
   --  Returns True if a context information was registered for the security policy.
   --  ------------------------------
   function Has_Policy_Context (Context : in Security_Context;
                                Policy  : in Security.Policies.Policy_Access) return Boolean is
   begin
      return Policy /= null and then Context.Contexts /= null
        and then Context.Contexts (Policy.Get_Policy_Index) /= null;
   end Has_Policy_Context;

   --  ------------------------------
   --  Set the current application and user context.
   --  ------------------------------
   procedure Set_Context (Context   : in out Security_Context;
                          Manager   : in Security.Policies.Policy_Manager_Access;
                          Principal : in Security.Principal_Access) is
   begin
      Context.Manager   := Manager;
      Context.Principal := Principal;
   end Set_Context;

   --  ------------------------------
   --  Get the current security context.
   --  Returns null if the current thread is not associated with any security context.
   --  ------------------------------
   function Current return Security_Context_Access is
   begin
      return Task_Context.Value;
   end Current;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   function Has_Permission (Permission : in Permissions.Permission_Index) return Boolean is
      Result  : Boolean;
      Context : constant Security_Context_Access := Current;
   begin
      if Context = null then
         return False;
      else
         Context.Has_Permission (Permission, Result);
         return Result;
      end if;
   end Has_Permission;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   function Has_Permission (Permission : in String) return Boolean is
      Result  : Boolean;
      Context : constant Security_Context_Access := Current;
   begin
      if Context = null then
         return False;
      else
         Context.Has_Permission (Permission, Result);
         return Result;
      end if;
   end Has_Permission;

end Security.Contexts;

-----------------------------------------------------------------------
--  security-contexts -- Context to provide security information and verify permissions
--  Copyright (C) 2011, 2012 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Ada.Task_Attributes;
with Ada.Unchecked_Deallocation;

package body Security.Contexts is

   use type Security.Policies.Policy_Context_Array_Access;
   use type Security.Policies.Policy_Access;
   use type Security.Policies.Policy_Context_Access;

   package Task_Context is new Ada.Task_Attributes
     (Security_Context_Access, null);

   procedure Free is
      new Ada.Unchecked_Deallocation (Object => Security.Policies.Policy_Context'Class,
                                      Name   => Security.Policies.Policy_Context_Access);

   --  ------------------------------
   --  Get the application associated with the current service operation.
   --  ------------------------------
   function Get_User_Principal (Context : in Security_Context'Class)
                                return Security.Principal_Access is
   begin
      return Context.Principal;
   end Get_User_Principal;

   --  ------------------------------
   --  Get the permission manager.
   --  ------------------------------
   function Get_Permission_Manager (Context : in Security_Context'Class)
                                    return Security.Policies.Policy_Manager_Access is
   begin
      return Context.Manager;
   end Get_Permission_Manager;

   --  ------------------------------
   --  Get the policy with the name Name registered in the policy manager.
   --  Returns null if there is no such policy.
   --  ------------------------------
   function Get_Policy (Context : in Security_Context'Class;
                        Name    : in String) return Security.Policies.Policy_Access is
      use type Security.Policies.Policy_Manager_Access;
   begin
      if Context.Manager = null then
         return null;
      else
         return Context.Manager.Get_Policy (Name);
      end if;
   end Get_Policy;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   procedure Has_Permission (Context    : in out Security_Context;
                             Permission : in Security.Permissions.Permission_Index;
                             Result     : out Boolean) is
      use type Security.Policies.Policy_Manager_Access;
   begin
      if Context.Manager = null then
         Result := False;
         return;
      end if;
      declare
         Perm : Security.Permissions.Permission (Permission);
      begin
         Result := Context.Manager.Has_Permission (Context, Perm);
      end;
   end Has_Permission;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   procedure Has_Permission (Context    : in out Security_Context;
                             Permission : in String;
                             Result     : out Boolean) is
      Index : constant Permissions.Permission_Index
        := Permissions.Get_Permission_Index (Permission);
   begin
      Security_Context'Class (Context).Has_Permission (Index, Result);
   end Has_Permission;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   procedure Has_Permission (Context    : in out Security_Context;
                             Permission : in Security.Permissions.Permission'Class;
                             Result     : out Boolean) is
      use type Security.Policies.Policy_Manager_Access;
   begin
      if Context.Manager = null then
         Result := False;
         return;
      end if;
      Result := Context.Manager.Has_Permission (Context, Permission);
   end Has_Permission;

   --  ------------------------------
   --  Initializes the service context.  By creating the Security_Context variable,
   --  the instance will be associated with the current task attribute.  If the current task
   --  already has a security context, the new security context is installed, the old one
   --  being kept.
   --  ------------------------------
   overriding
   procedure Initialize (Context : in out Security_Context) is
   begin
      Context.Previous := Task_Context.Value;
      Task_Context.Set_Value (Context'Unchecked_Access);
   end Initialize;

   --  ------------------------------
   --  Finalize the security context releases any object.  The previous security context is
   --  restored to the current task attribute.
   --  ------------------------------
   overriding
   procedure Finalize (Context : in out Security_Context) is

      procedure Free is
        new Ada.Unchecked_Deallocation (Object => Security.Policies.Policy_Context_Array,
                                        Name   => Security.Policies.Policy_Context_Array_Access);
   begin
      Task_Context.Set_Value (Context.Previous);
      if Context.Contexts /= null then
         for I in Context.Contexts'Range loop
            Free (Context.Contexts (I));
         end loop;
         Free (Context.Contexts);
      end if;
   end Finalize;

   --  ------------------------------
   --  Set a policy context information represented by Value and associated with
   --  the policy index Policy.
   --  ------------------------------
   procedure Set_Policy_Context (Context   : in out Security_Context;
                                 Policy    : in Security.Policies.Policy_Access;
                                 Value     : in Security.Policies.Policy_Context_Access) is
   begin
      if Context.Contexts = null then
         Context.Contexts := Context.Manager.Create_Policy_Contexts;
      end if;
      Free (Context.Contexts (Policy.Get_Policy_Index));
      Context.Contexts (Policy.Get_Policy_Index) := Value;
   end Set_Policy_Context;

   --  ------------------------------
   --  Get the policy context information registered for the given security policy in the security
   --  context Context.
   --  Raises Invalid_Context if there is no such information.
   --  Raises Invalid_Policy if the policy was not set.
   --  ------------------------------
   function Get_Policy_Context (Context  : in Security_Context;
                                Policy   : in Security.Policies.Policy_Access)
                                return Security.Policies.Policy_Context_Access is
      Result : Security.Policies.Policy_Context_Access;
   begin
      if Policy = null then
         raise Invalid_Policy;
      end if;
      if Context.Contexts = null then
         raise Invalid_Context;
      end if;
      Result := Context.Contexts (Policy.Get_Policy_Index);
      return Result;
   end Get_Policy_Context;

   --  ------------------------------
   --  Returns True if a context information was registered for the security policy.
   --  ------------------------------
   function Has_Policy_Context (Context : in Security_Context;
                                Policy  : in Security.Policies.Policy_Access) return Boolean is
   begin
      return Policy /= null and then Context.Contexts /= null
        and then Context.Contexts (Policy.Get_Policy_Index) /= null;
   end Has_Policy_Context;

   --  ------------------------------
   --  Set the current application and user context.
   --  ------------------------------
   procedure Set_Context (Context   : in out Security_Context;
                          Manager   : in Security.Policies.Policy_Manager_Access;
                          Principal : in Security.Principal_Access) is
   begin
      Context.Manager   := Manager;
      Context.Principal := Principal;
   end Set_Context;

   --  ------------------------------
   --  Get the current security context.
   --  Returns null if the current thread is not associated with any security context.
   --  ------------------------------
   function Current return Security_Context_Access is
   begin
      return Task_Context.Value;
   end Current;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   function Has_Permission (Permission : in Permissions.Permission_Index) return Boolean is
      Result  : Boolean;
      Context : constant Security_Context_Access := Current;
   begin
      if Context = null then
         return False;
      else
         Context.Has_Permission (Permission, Result);
         return Result;
      end if;
   end Has_Permission;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   function Has_Permission (Permission : in String) return Boolean is
      Result  : Boolean;
      Context : constant Security_Context_Access := Current;
   begin
      if Context = null then
         return False;
      else
         Context.Has_Permission (Permission, Result);
         return Result;
      end if;
   end Has_Permission;

end Security.Contexts;

Implement the new Has_Permission procedure


-----------------------------------------------------------------------
--  security-policies -- Security Policies
--  Copyright (C) 2010, 2011, 2012 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Ada.Finalization;

with Util.Beans.Objects;
with Util.Beans.Objects.Vectors;
with Util.Serialize.IO.XML;

with Security.Permissions;
limited with Security.Controllers;
limited with Security.Contexts;

--  == Security Policies ==
--
--  @include security-policies-roles.ads
--  @include security-policies-urls.ads
package Security.Policies is

   type Security_Context_Access is access all Contexts.Security_Context'Class;

   type Controller_Access is access all Security.Controllers.Controller'Class;

   type Controller_Access_Array is
     array (Permissions.Permission_Index range <>) of Controller_Access;

   type Policy_Index is new Positive;

   type Policy_Context is limited interface;
   type Policy_Context_Access is access all Policy_Context'Class;

   type Policy_Context_Array is
     array (Policy_Index range <>) of Policy_Context_Access;
   type Policy_Context_Array_Access is access Policy_Context_Array;

   --  ------------------------------
   --  Security policy
   --  ------------------------------
   type Policy is abstract new Ada.Finalization.Limited_Controlled with private;
   type Policy_Access is access all Policy'Class;

   --  Get the policy name.
   function Get_Name (From : in Policy) return String is abstract;

   --  Get the policy index.
   function Get_Policy_Index (From : in Policy'Class) return Policy_Index;
   pragma Inline (Get_Policy_Index);

   --  Prepare the XML parser to read the policy configuration.
   procedure Prepare_Config (Pol     : in out Policy;
                             Reader  : in out Util.Serialize.IO.XML.Parser) is null;

   --  Finish reading the XML policy configuration.  The security policy implementation can use
   --  this procedure to perform any configuration setup after the configuration is parsed.
   procedure Finish_Config (Into    : in out Policy;
                            Reader  : in out Util.Serialize.IO.XML.Parser) is null;

   --  Add a permission under the given permission name and associated with the controller.
   --  To verify the permission, the controller will be called.
   procedure Add_Permission (Manager    : in out Policy;
                             Name       : in String;
                             Permission : in Controller_Access);

   Invalid_Name : exception;

   Policy_Error : exception;

   --  ------------------------------
   --  Permission Manager
   --  ------------------------------
   --  The Permission_Manager verifies through some policy that a permission
   --  is granted to a user.
   type Policy_Manager (Max_Policies : Policy_Index) is
     new Ada.Finalization.Limited_Controlled with private;
   type Policy_Manager_Access is access all Policy_Manager'Class;

   --  Get the policy with the name Name registered in the policy manager.
   --  Returns null if there is no such policy.
   function Get_Policy (Manager : in Policy_Manager;
                        Name    : in String) return Policy_Access;

   --  Add the policy to the policy manager.  After a policy is added in the manager,
   --  it can participate in the security policy.
   --  Raises Policy_Error if the policy table is full.
   procedure Add_Policy (Manager : in out Policy_Manager;
                         Policy  : in Policy_Access);

   --  Add a permission under the given permission name and associated with the controller.
   --  To verify the permission, the controller will be called.
   procedure Add_Permission (Manager    : in out Policy_Manager;
                             Name       : in String;
                             Permission : in Controller_Access);

   --  Checks whether the permission defined by the Permission controller data is granted
   --  by the security context passed in Context.
   --  Returns true if such permission is granted.
   function Has_Permission (Manager    : in Policy_Manager;
                            Context    : in Security.Contexts.Security_Context'Class;
                            Permission : in Security.Permissions.Permission'Class)
                            return Boolean;

   --  Create the policy contexts to be associated with the security context.
   function Create_Policy_Contexts (Manager : in Policy_Manager)
                                    return Policy_Context_Array_Access;

   --  Read the policy file
   procedure Read_Policy (Manager : in out Policy_Manager;
                          File    : in String);

   --  Initialize the permission manager.
   overriding
   procedure Initialize (Manager : in out Policy_Manager);

   --  Finalize the permission manager.
   overriding
   procedure Finalize (Manager : in out Policy_Manager);

   --  ------------------------------
   --  Policy Configuration
   --  ------------------------------
   type Policy_Config is record
      Id          : Natural := 0;
      Permissions : Util.Beans.Objects.Vectors.Vector;
      Patterns    : Util.Beans.Objects.Vectors.Vector;
      Manager     : Policy_Manager_Access;
   end record;
   type Policy_Config_Access is access all Policy_Config;

   --  Setup the XML parser to read the policy description.  For example:
   --
   --  <policy id='1'>
   --     <permission>create-workspace</permission>
   --     <permission>admin</permission>
   --     <url-pattern>/workspace/create</url-pattern>
   --     <url-pattern>/workspace/setup/*</url-pattern>
   --  </policy>
   --
   --  This policy gives access to the URL that match one of the URL pattern if the
   --  security context has the permission create-workspace or admin.
   generic
      Reader  : in out Util.Serialize.IO.XML.Parser;
      Manager : in Policy_Manager_Access;
   package Reader_Config is
      Config : aliased Policy_Config;
   end Reader_Config;

private

   subtype Permission_Index is Permissions.Permission_Index;

   type Permission_Index_Array is array (Positive range <>) of Permissions.Permission_Index;

   type Controller_Access_Array_Access is access all Controller_Access_Array;

   type Policy_Access_Array is array (Policy_Index range <>) of Policy_Access;

   type Policy is abstract new Ada.Finalization.Limited_Controlled with record
      Manager : Policy_Manager_Access;
      Index   : Policy_Index;
   end record;

   type Policy_Manager (Max_Policies : Policy_Index) is
     new Ada.Finalization.Limited_Controlled with record
      Permissions  : Controller_Access_Array_Access;
      Last_Index   : Permission_Index := Permission_Index'First;

      --  The security policies.
      Policies     : Policy_Access_Array (1 .. Max_Policies);
   end record;

end Security.Policies;

-----------------------------------------------------------------------
--  security-policies -- Security Policies
--  Copyright (C) 2010, 2011, 2012 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Ada.Finalization;

with Util.Beans.Objects;
with Util.Beans.Objects.Vectors;
with Util.Serialize.IO.XML;

with Security.Permissions;
limited with Security.Controllers;
limited with Security.Contexts;

--  == Security Policies ==
--  The Security Policy defines and implements the set of security rules that specify
--  how to protect the system or resources. The <tt>Policy_Manager</tt> maintains
--  the security policies.  These policies are registered when an application starts
--  and before reading the policy configuration files.
--
--  [http://ada-security.googlecode.com/svn/wiki/PolicyModel.png]
--
--  While the policy configuration files are processed, the policy instances that have been
--  registered will create a security controller and bind it to a given permission.  After
--  successful initialization, the <tt>Policy_Manager</tt> contains a list of securiy
--  controllers which are associated with each permission defined by the application.
--
--  @include security-policies-roles.ads
--  @include security-policies-urls.ads
--  @include security-controllers.ads
package Security.Policies is

   type Security_Context_Access is access all Contexts.Security_Context'Class;

   type Controller_Access is access all Security.Controllers.Controller'Class;

   type Controller_Access_Array is
     array (Permissions.Permission_Index range <>) of Controller_Access;

   type Policy_Index is new Positive;

   type Policy_Context is limited interface;
   type Policy_Context_Access is access all Policy_Context'Class;

   type Policy_Context_Array is
     array (Policy_Index range <>) of Policy_Context_Access;
   type Policy_Context_Array_Access is access Policy_Context_Array;

   --  ------------------------------
   --  Security policy
   --  ------------------------------
   type Policy is abstract new Ada.Finalization.Limited_Controlled with private;
   type Policy_Access is access all Policy'Class;

   --  Get the policy name.
   function Get_Name (From : in Policy) return String is abstract;

   --  Get the policy index.
   function Get_Policy_Index (From : in Policy'Class) return Policy_Index;
   pragma Inline (Get_Policy_Index);

   --  Prepare the XML parser to read the policy configuration.
   procedure Prepare_Config (Pol     : in out Policy;
                             Reader  : in out Util.Serialize.IO.XML.Parser) is null;

   --  Finish reading the XML policy configuration.  The security policy implementation can use
   --  this procedure to perform any configuration setup after the configuration is parsed.
   procedure Finish_Config (Into    : in out Policy;
                            Reader  : in out Util.Serialize.IO.XML.Parser) is null;

   --  Add a permission under the given permission name and associated with the controller.
   --  To verify the permission, the controller will be called.
   procedure Add_Permission (Manager    : in out Policy;
                             Name       : in String;
                             Permission : in Controller_Access);

   Invalid_Name : exception;

   Policy_Error : exception;

   --  ------------------------------
   --  Permission Manager
   --  ------------------------------
   --  The Permission_Manager verifies through some policy that a permission
   --  is granted to a user.
   type Policy_Manager (Max_Policies : Policy_Index) is
     new Ada.Finalization.Limited_Controlled with private;
   type Policy_Manager_Access is access all Policy_Manager'Class;

   --  Get the policy with the name Name registered in the policy manager.
   --  Returns null if there is no such policy.
   function Get_Policy (Manager : in Policy_Manager;
                        Name    : in String) return Policy_Access;

   --  Add the policy to the policy manager.  After a policy is added in the manager,
   --  it can participate in the security policy.
   --  Raises Policy_Error if the policy table is full.
   procedure Add_Policy (Manager : in out Policy_Manager;
                         Policy  : in Policy_Access);

   --  Add a permission under the given permission name and associated with the controller.
   --  To verify the permission, the controller will be called.
   procedure Add_Permission (Manager    : in out Policy_Manager;
                             Name       : in String;
                             Permission : in Controller_Access);

   --  Checks whether the permission defined by the Permission controller data is granted
   --  by the security context passed in Context.
   --  Returns true if such permission is granted.
   function Has_Permission (Manager    : in Policy_Manager;
                            Context    : in Security.Contexts.Security_Context'Class;
                            Permission : in Security.Permissions.Permission'Class)
                            return Boolean;

   --  Create the policy contexts to be associated with the security context.
   function Create_Policy_Contexts (Manager : in Policy_Manager)
                                    return Policy_Context_Array_Access;

   --  Read the policy file
   procedure Read_Policy (Manager : in out Policy_Manager;
                          File    : in String);

   --  Initialize the permission manager.
   overriding
   procedure Initialize (Manager : in out Policy_Manager);

   --  Finalize the permission manager.
   overriding
   procedure Finalize (Manager : in out Policy_Manager);

   --  ------------------------------
   --  Policy Configuration
   --  ------------------------------
   type Policy_Config is record
      Id          : Natural := 0;
      Permissions : Util.Beans.Objects.Vectors.Vector;
      Patterns    : Util.Beans.Objects.Vectors.Vector;
      Manager     : Policy_Manager_Access;
   end record;
   type Policy_Config_Access is access all Policy_Config;

   --  Setup the XML parser to read the policy description.  For example:
   --
   --  <policy id='1'>
   --     <permission>create-workspace</permission>
   --     <permission>admin</permission>
   --     <url-pattern>/workspace/create</url-pattern>
   --     <url-pattern>/workspace/setup/*</url-pattern>
   --  </policy>
   --
   --  This policy gives access to the URL that match one of the URL pattern if the
   --  security context has the permission create-workspace or admin.
   generic
      Reader  : in out Util.Serialize.IO.XML.Parser;
      Manager : in Policy_Manager_Access;
   package Reader_Config is
      Config : aliased Policy_Config;
   end Reader_Config;

private

   subtype Permission_Index is Permissions.Permission_Index;

   type Permission_Index_Array is array (Positive range <>) of Permissions.Permission_Index;

   type Controller_Access_Array_Access is access all Controller_Access_Array;

   type Policy_Access_Array is array (Policy_Index range <>) of Policy_Access;

   type Policy is abstract new Ada.Finalization.Limited_Controlled with record
      Manager : Policy_Manager_Access;
      Index   : Policy_Index;
   end record;

   type Policy_Manager (Max_Policies : Policy_Index) is
     new Ada.Finalization.Limited_Controlled with record
      Permissions  : Controller_Access_Array_Access;
      Last_Index   : Permission_Index := Permission_Index'First;

      --  The security policies.
      Policies     : Policy_Access_Array (1 .. Max_Policies);
   end record;

end Security.Policies;

Document the security policy

Document the security policy