Natools

------------------------------------------------------------------------------
-- Copyright (c) 2014, Natacha Porté                                        --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

package body Natools.S_Expressions.Lockable is

   ----------------
   -- Lock Stack --
   ----------------

   procedure Push_Level
     (Stack : in out Lock_Stack;
      Level : in Natural;
      State : out Lock_State) is
   begin
      State := (Depth => Stack.Depth, Level => Stack.Level);
      Stack := (Depth => Stack.Depth + 1, Level => Level);
   end Push_Level;


   procedure Pop_Level
     (Stack : in out Lock_Stack;
      State : in Lock_State;
      Allow_Gap : in Boolean := False) is
   begin
      if State.Depth = 0 then
         raise Constraint_Error with "Invalid stack state";
      elsif State.Depth >= Stack.Depth then
         raise Constraint_Error with "Trying to Pop a state outside of Stack";
      elsif not Allow_Gap and then State.Depth < Stack.Depth - 1 then
         raise Constraint_Error
           with "Trying to Pop several items without Allow_Gap";
      end if;

      Stack := (Depth => State.Depth, Level => State.Level);
   end Pop_Level;


   function Current_Level (Stack : Lock_Stack) return Natural is
   begin
      return Stack.Level;
   end Current_Level;



   -------------------------------------
   -- Lockable Wrapper Implementation --
   -------------------------------------

   function Current_Event (Object : in Wrapper) return Events.Event is
   begin
      if Object.Finished then
         return Events.End_Of_Input;
      else
         return Object.Backend.Current_Event;
      end if;
   end Current_Event;


   function Current_Atom (Object : in Wrapper) return Atom is
   begin
      if Object.Finished then
         raise Program_Error with "Current_Atom on finished wrapper";
      else
         return Object.Backend.Current_Atom;
      end if;
   end Current_Atom;


   function Current_Level (Object : in Wrapper) return Natural is
   begin
      if Object.Finished then
         return 0;
      else
         return Object.Backend.Current_Level - Current_Level (Object.Stack);
      end if;
   end Current_Level;


   procedure Query_Atom
     (Object : in Wrapper;
      Process : not null access procedure (Data : in Atom)) is
   begin
      if Object.Finished then
         raise Program_Error with "Query_Atom on finished wrapper";
      else
         Object.Backend.Query_Atom (Process);
      end if;
   end Query_Atom;


   procedure Read_Atom
     (Object : in Wrapper;
      Data : out Atom;
      Length : out Count) is
   begin
      if Object.Finished then
         raise Program_Error with "Read_Atom on finished wrapper";
      else
         Object.Backend.Read_Atom (Data, Length);
      end if;
   end Read_Atom;


   procedure Next
     (Object : in out Wrapper;
      Event : out Events.Event) is
   begin
      if Object.Finished then
         Event := Events.Error;
         return;
      end if;

      Object.Backend.Next (Event);

      if Event = Events.Close_List
        and then Object.Backend.Current_Level < Current_Level (Object.Stack)
      then
         Object.Finished := True;
         Event := Events.End_Of_Input;
      end if;
   end Next;


   procedure Lock
     (Object : in out Wrapper;
      State : out Lock_State) is
   begin
      Push_Level (Object.Stack, Object.Backend.Current_Level, State);
   end Lock;


   procedure Unlock
     (Object : in out Wrapper;
      State : in out Lock_State;
      Finish : in Boolean := True)
   is
      Previous_Level : constant Natural := Current_Level (Object.Stack);
   begin
      Pop_Level (Object.Stack, State);
      State := (0, 0);

      if Finish then
         declare
            Event : Events.Event;
         begin
            Event := Object.Backend.Current_Event;
            loop
               case Event is
                  when Events.Open_List | Events.Add_Atom =>
                     null;
                  when Events.Close_List =>
                     exit when Object.Backend.Current_Level < Previous_Level;
                  when Events.Error | Events.End_Of_Input =>
                     exit;
               end case;
               Object.Backend.Next (Event);
            end loop;
         end;
      end if;

      Object.Finished := Object.Backend.Current_Level
        < Current_Level (Object.Stack);
   end Unlock;

end Natools.S_Expressions.Lockable;

------------------------------------------------------------------------------
-- Copyright (c) 2014, Natacha Porté                                        --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

------------------------------------------------------------------------------
-- Natools.S_Expressions.Lockable provides an interface for Descriptor that --
-- can be locked in the current nesting level, returning End_Of_Input       --
-- instead of Close_List of that level. That way the descriptor can         --
-- be safely handed to other code fragments without risking scope change.   --
--                                                                          --
-- A Wrapper type is also provided to add a lockable layer on top of a      --
-- basic Descriptor interface, however with the extra overhead of one more  --
-- call.                                                                    --
------------------------------------------------------------------------------

package Natools.S_Expressions.Lockable is
   pragma Pure (Lockable);

   type Lock_Stack is private;
   type Lock_State is private;

   procedure Push_Level
     (Stack : in out Lock_Stack;
      Level : in Natural;
      State : out Lock_State);
      --  Insert Level on top of Stack and return current State

   procedure Pop_Level
     (Stack : in out Lock_Stack;
      State : in Lock_State;
      Allow_Gap : in Boolean := False);
      --  Remove upper part of Stack, up to and including the entry pointed
      --  by State. Constraint_Error is raised if State does not point to a
      --  valid level in the stack, and if Allow_Gap is True and more than
      --  one item would be removed.

   function Current_Level (Stack : Lock_Stack) return Natural;
      --  Return the value on top of the stack


   type Descriptor is limited interface and S_Expressions.Descriptor;

   procedure Lock
     (Object : in out Descriptor;
      State : out Lock_State)
     is abstract;
      --  Turn Object into a state where it cannot reach below or beyond
      --  current nesting level at Lock call.

   procedure Unlock
     (Object : in out Descriptor;
      State : in out Lock_State;
      Finish : in Boolean := True)
     is abstract;
      --  Undo the effects of previous Lock call, and unwind Object until the
      --  end of locked level (unless Finish is False).


   type Wrapper (Backend : access S_Expressions.Descriptor'Class)
     is new Descriptor with private;
      --  Wrapper layer on top of a non-lockable object, albeit with the
      --  performance penalty of an extra layer.

   function Current_Event (Object : in Wrapper) return Events.Event;
   function Current_Atom (Object : in Wrapper) return Atom;
   function Current_Level (Object : in Wrapper) return Natural;
   procedure Query_Atom
     (Object : in Wrapper;
      Process : not null access procedure (Data : in Atom));
   procedure Read_Atom
     (Object : in Wrapper;
      Data : out Atom;
      Length : out Count);
   procedure Next
     (Object : in out Wrapper;
      Event : out Events.Event);

   procedure Lock
     (Object : in out Wrapper;
      State : out Lock_State);
   procedure Unlock
     (Object : in out Wrapper;
      State : in out Lock_State;
      Finish : in Boolean := True);

private

   type Lock_State is record
      Level, Depth : Natural := 0;
   end record;

   type Lock_Stack is record
      Level : Natural := 0;
      Depth : Positive := 1;
   end record;

   type Wrapper (Backend : access S_Expressions.Descriptor'Class)
     is new Descriptor with record
      Stack : Lock_Stack;
      Finished : Boolean := False;
   end record;

end Natools.S_Expressions.Lockable;