Natools

natools-s_expressions-interpreters.adb at [4f0ae7072f]
Login

File src/natools-s_expressions-interpreters.adb artifact 43b0b541fb part of check-in 4f0ae7072f


------------------------------------------------------------------------------
-- Copyright (c) 2013-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.Interpreters is

   -----------------
   -- Interpreter --
   -----------------

   procedure Add_Command
     (Self : in out Interpreter;
      Name : in Atom;
      Cmd : in Command'Class) is
   begin
      Self.Commands.Insert (Name, Cmd);
      Self.Max_Length := Count'Max (Self.Max_Length, Name'Length);
   end Add_Command;


   procedure Add
     (Self : in out Interpreter;
      Name : in String;
      Cmd : in Command'Class) is
   begin
      Self.Add_Command (To_Atom (Name), Cmd);
   end Add;


   function Has_Command (Self : Interpreter; Name : Atom) return Boolean is
   begin
      return Self.Commands.Contains (Name);
   end Has_Command;


   function Is_Empty (Self : Interpreter) return Boolean is
   begin
      return Self.Commands.Is_Empty;
   end Is_Empty;


   procedure Set_Fallback
     (Self : in out Interpreter;
      Name : in Atom)
   is
      function Create return Atom;

      function Create return Atom is
      begin
         return Name;
      end Create;
   begin
      Self.Fallback_Name.Replace (Create'Access);
   end Set_Fallback;


   procedure Reset_Fallback (Self : in out Interpreter) is
   begin
      Self.Fallback_Name.Reset;
   end Reset_Fallback;


   not overriding procedure Execute
     (Self : in Interpreter;
      Expression : in out Lockable.Descriptor'Class;
      State : in out Shared_State;
      Context : in Shared_Context)
   is
      Event : Events.Event := Expression.Current_Event;
      Lock_State : Lockable.Lock_State;
   begin
      loop
         case Event is
            when Events.Add_Atom =>
               Self.Execute (State, Context, Expression.Current_Atom);
            when Events.Open_List =>
               Expression.Lock (Lock_State);
               begin
                  Expression.Next (Event);
                  if Event = Events.Add_Atom then
                     Self.Execute (State, Context, Expression);
                  end if;
               exception
                  when others =>
                     Expression.Unlock (Lock_State, False);
                     raise;
               end;
               Expression.Unlock (Lock_State);
            when Events.Close_List | Events.End_Of_Input | Events.Error =>
               exit;
         end case;

         Expression.Next (Event);
      end loop;
   end Execute;


   not overriding procedure Execute
     (Self : in Interpreter;
      Fallback : in Command'Class;
      Expression : in out Lockable.Descriptor'Class;
      State : in out Shared_State;
      Context : in Shared_Context)
   is
      procedure Dispatch (Process : not null access procedure
                            (Name : in Atom; Cmd : in Command'Class));
      procedure Process_Atom (Name : in Atom; Cmd : in Command'Class);
      procedure Process_Exp (Name : in Atom; Cmd : in Command'Class);

      procedure Dispatch (Process : not null access procedure
                            (Name : in Atom; Cmd : in Command'Class))
      is
         procedure Process_Fallback (Name : in Atom);

         procedure Process_Fallback (Name : in Atom) is
         begin
            Process (Name, Fallback);
         end Process_Fallback;

         Buffer : Atom (1 .. Self.Max_Length);
         Length : Count;
         Cursor : Command_Maps.Cursor;
      begin
         Expression.Read_Atom (Buffer, Length);
         if Length > Self.Max_Length then
            Expression.Query_Atom (Process_Fallback'Access);
         else
            Cursor := Self.Commands.Find (Buffer (1 .. Length));
            if Command_Maps.Has_Element (Cursor) then
               Command_Maps.Query_Element (Cursor, Process);
            else
               Process (Buffer (1 .. Length), Fallback);
            end if;
         end if;
      end Dispatch;

      procedure Process_Atom (Name : in Atom; Cmd : in Command'Class) is
      begin
         Cmd.Execute (State, Context, Name);
      end Process_Atom;

      procedure Process_Exp (Name : in Atom; Cmd : in Command'Class) is
         pragma Unreferenced (Name);
      begin
         Cmd.Execute (State, Context, Expression);
      end Process_Exp;

      Event : Events.Event := Expression.Current_Event;
      Lock_State : Lockable.Lock_State;
   begin
      loop
         case Event is
            when Events.Add_Atom =>
               Dispatch (Process_Atom'Access);

            when Events.Open_List =>
               Expression.Lock (Lock_State);
               begin
                  Expression.Next (Event);
                  if Event = Events.Add_Atom then
                     Dispatch (Process_Exp'Access);
                  end if;
               exception
                  when others =>
                     Expression.Unlock (Lock_State, False);
                     raise;
               end;
               Expression.Unlock (Lock_State);

            when Events.Close_List | Events.End_Of_Input | Events.Error =>
               exit;
         end case;

         Expression.Next (Event);
      end loop;
   end Execute;


   overriding procedure Execute
     (Self : in Interpreter;
      State : in out Shared_State;
      Context : in Shared_Context;
      Name : in Atom)
   is
      procedure Process_Atom (Key : in Atom; Cmd : in Command'Class);

      procedure Process_Atom (Key : in Atom; Cmd : in Command'Class) is
         pragma Unreferenced (Key);
      begin
         Cmd.Execute (State, Context, Name);
      end Process_Atom;

      Cursor : Command_Maps.Cursor;
   begin
      if Name'Length <= Self.Max_Length then
         Cursor := Self.Commands.Find (Name);
         if Command_Maps.Has_Element (Cursor) then
            Command_Maps.Query_Element (Cursor, Process_Atom'Access);
            return;
         end if;
      end if;

      if not Self.Fallback_Name.Is_Empty then
         Cursor := Self.Commands.Find (Self.Fallback_Name.Query.Data.all);
         if Command_Maps.Has_Element (Cursor) then
            Command_Maps.Query_Element (Cursor, Process_Atom'Access);
            return;
         end if;
      end if;

      raise Command_Not_Found
        with "Unknown command """ & To_String (Name) & '"';
   end Execute;


   overriding procedure Execute
     (Self : in Interpreter;
      State : in out Shared_State;
      Context : in Shared_Context;
      Cmd : in out Lockable.Descriptor'Class)
   is
      procedure Process_Exp (Name : in Atom; Actual : in Command'Class);

      procedure Process_Exp (Name : in Atom; Actual : in Command'Class) is
         pragma Unreferenced (Name);
      begin
         Actual.Execute (State, Context, Cmd);
      end Process_Exp;

      Buffer : Atom (1 .. Self.Max_Length);
      Length : Count;
      Cursor : Command_Maps.Cursor;
   begin
      if Cmd.Current_Event /= Events.Add_Atom then
         return;
      end if;

      Cmd.Read_Atom (Buffer, Length);

      if Length <= Self.Max_Length then
         Cursor := Self.Commands.Find (Buffer (1 .. Length));
         if Command_Maps.Has_Element (Cursor) then
            Command_Maps.Query_Element (Cursor, Process_Exp'Access);
            return;
         end if;
      end if;

      if not Self.Fallback_Name.Is_Empty then
         Cursor := Self.Commands.Find (Self.Fallback_Name.Query.Data.all);
         if Command_Maps.Has_Element (Cursor) then
            Command_Maps.Query_Element (Cursor, Process_Exp'Access);
            return;
         end if;
      end if;

      raise Command_Not_Found
        with "Unknown command """ & To_String (Cmd.Current_Atom) & '"';
   end Execute;



   --------------------------------------
   -- Interpreter Building Subprograms --
   --------------------------------------

   function Build (Commands : Command_Array) return Interpreter is
      Result : Interpreter;
   begin
      for I in Commands'Range loop
         Result.Add_Command
           (Commands (I).Name.Query.Data.all,
            Commands (I).Cmd.Query.Data.all);
      end loop;

      return Result;
   end Build;


   function Build (Commands : Command_Array; Fallback : String)
     return Interpreter
   is
      Result : Interpreter := Build (Commands);
   begin
      Result.Set_Fallback (To_Atom (Fallback));
      return Result;
   end Build;


   function Item (Name : String; Cmd : Command'Class)
     return Command_Description
   is
      function Get_Name return Atom;
      function Get_Command return Command'Class;

      function Get_Name return Atom is
      begin
         return To_Atom (Name);
      end Get_Name;

      function Get_Command return Command'Class is
      begin
         return Cmd;
      end Get_Command;
   begin
      return (Name => Atom_Refs.Create (Get_Name'Access),
              Cmd => Command_Refs.Create (Get_Command'Access));
   end Item;

end Natools.S_Expressions.Interpreters;