Natools

natools-static_hash_maps-s_expressions.adb at [579aa9f314]
Login

File src/natools-static_hash_maps-s_expressions.adb artifact c67c4fb249 part of check-in 579aa9f314


------------------------------------------------------------------------------
-- 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.           --
------------------------------------------------------------------------------

with Natools.S_Expressions.Interpreter_Loop;
with Natools.Static_Hash_Maps.S_Expressions.Command_Maps;

package body Natools.Static_Hash_Maps.S_Expressions is

   procedure Add_Map
     (Pkg : in out Map_Package;
      Context : in Meaningless_Type;
      Name : in Sx.Atom;
      Arguments : in out Sx.Lockable.Descriptor'Class);

   procedure Add_Value
     (Map : in out Map_Description;
      Element_Name : in String;
      Key : in Sx.Atom);

   procedure Generate_Package
     (Pkg : in out Map_Package;
      Description : in String;
      Name : in Sx.Atom;
      Arguments : in out Sx.Lockable.Descriptor'Class);

   procedure Update_Map
     (Map : in out Map_Description;
      Context : in Meaningless_Type;
      Name : in Sx.Atom;
      Arguments : in out Sx.Lockable.Descriptor'Class);

   procedure Update_Nodes
     (Map : in out Map_Description;
      Context : in Meaningless_Type;
      Name : in Sx.Atom;
      Arguments : in out Sx.Lockable.Descriptor'Class);

   procedure Update_Package
     (Pkg : in out Map_Package;
      Context : in Meaningless_Type;
      Name : in Sx.Atom;
      Arguments : in out Sx.Lockable.Descriptor'Class);

   procedure Update_Package
     (Pkg : in out Map_Package;
      Context : in Meaningless_Type;
      Name : in Sx.Atom);



   procedure Map_Interpreter is new Sx.Interpreter_Loop
     (Map_Description, Meaningless_Type, Update_Map);

   procedure Node_Interpreter is new Sx.Interpreter_Loop
     (Map_Description, Meaningless_Type, Update_Nodes);

   procedure Package_Generator is new Sx.Interpreter_Loop
     (Map_Package, String, Generate_Package);

   procedure Package_Interpreter is new Sx.Interpreter_Loop
     (Map_Package, Meaningless_Type, Update_Package, Update_Package);

   procedure Value_Interpreter is new Sx.Interpreter_Loop
     (Map_Description, String, Dispatch_Without_Argument => Add_Value);



   -------------------------
   -- Command Dispatchers --
   -------------------------

   procedure Add_Map
     (Pkg : in out Map_Package;
      Context : in Meaningless_Type;
      Name : in Sx.Atom;
      Arguments : in out Sx.Lockable.Descriptor'Class)
   is
      pragma Unreferenced (Context);
      Map : Map_Description;
   begin
      Set_Element_Type (Map, Sx.To_String (Name));
      Map_Interpreter (Arguments, Map, Meaningless_Value);
      Add_Map (Pkg, Map);
   end Add_Map;


   procedure Add_Value
     (Map : in out Map_Description;
      Element_Name : in String;
      Key : in Sx.Atom) is
   begin
      Insert (Map, Sx.To_String (Key), Element_Name);
   end Add_Value;


   procedure Generate_Package
     (Pkg : in out Map_Package;
      Description : in String;
      Name : in Sx.Atom;
      Arguments : in out Sx.Lockable.Descriptor'Class) is
   begin
      Open (Pkg, Sx.To_String (Name));
      Set_Description (Pkg, Description);
      Package_Interpreter (Arguments, Pkg, Meaningless_Value);
      Commit (Pkg);
   end Generate_Package;



   procedure Update_Map
     (Map : in out Map_Description;
      Context : in Meaningless_Type;
      Name : in Sx.Atom;
      Arguments : in out Sx.Lockable.Descriptor'Class)
   is
      pragma Unreferenced (Context);
      use type Sx.Events.Event;
      Event : constant Sx.Events.Event := Arguments.Current_Event;
   begin
      case Command_Maps.To_Map_Command (Sx.To_String (Name)) is
         when Hash_Package =>
            if Event = Sx.Events.Add_Atom then
               Set_Hash_Package_Name
                 (Map, Sx.To_String (Arguments.Current_Atom));
            else
               Set_Hash_Package_Name (Map, "");
            end if;

         when Definite_Elements =>
            Set_Definite (Map);

         when Indefinite_Elements =>
            Set_Indefinite (Map);

         when Function_Name =>
            if Event = Sx.Events.Add_Atom then
               Set_Function_Name (Map, Sx.To_String (Arguments.Current_Atom));
            else
               Set_Function_Name (Map, "");
            end if;

         when Not_Found =>
            if Event = Sx.Events.Add_Atom then
               Set_Not_Found (Map, Sx.To_String (Arguments.Current_Atom));
            else
               Set_Not_Found (Map, "");
            end if;

         when Nodes =>
            Node_Interpreter (Arguments, Map, Meaningless_Value);
      end case;
   end Update_Map;


   procedure Update_Nodes
     (Map : in out Map_Description;
      Context : in Meaningless_Type;
      Name : in Sx.Atom;
      Arguments : in out Sx.Lockable.Descriptor'Class)
   is
      pragma Unreferenced (Context);
   begin
      Value_Interpreter (Arguments, Map, Sx.To_String (Name));
   end Update_Nodes;


   procedure Update_Package
     (Pkg : in out Map_Package;
      Context : in Meaningless_Type;
      Name : in Sx.Atom;
      Arguments : in out Sx.Lockable.Descriptor'Class)
   is
      pragma Unreferenced (Context);
      use type Sx.Events.Event;
      use type Sx.Octet;
      Is_Command : Boolean := False;
   begin
      for I in Name'Range loop
         if Name (I) = Character'Pos ('-') then
            Is_Command := True;
            exit;
         end if;
      end loop;

      if not Is_Command then
         Add_Map (Pkg, Meaningless_Value, Name, Arguments);
         return;
      end if;

      case Command_Maps.To_Package_Command (Sx.To_String (Name)) is
         when Private_Child =>
            Set_Private_Child (Pkg, True);
         when Public_Child =>
            Set_Private_Child (Pkg, False);
         when Pure_Package =>
            Set_Categorization (Pkg, Pure);
         when Preelaborate_Package =>
            Set_Categorization (Pkg, Preelaborate);
         when Extra_Declarations =>
            if Arguments.Current_Event = Sx.Events.Add_Atom then
               Set_Extra_Declarations
                 (Pkg, Sx.To_String (Arguments.Current_Atom));
            end if;
         when Test_Function =>
            if Arguments.Current_Event = Sx.Events.Add_Atom then
               declare
                  Child_Name : constant String
                    := Sx.To_String (Arguments.Current_Atom);
                  Parent_Name : constant String := To_String (Pkg.Name);
               begin
                  if Child_Name'Length > Parent_Name'Length
                    and then Child_Name (Child_Name'First
                              .. Child_Name'First + Parent_Name'Length - 1)
                       = Parent_Name
                  then
                     Set_Test_Child (Pkg, Child_Name
                       (Child_Name'First + Parent_Name'Length
                        .. Child_Name'Last));
                  else
                     Set_Test_Child (Pkg, Child_Name);
                  end if;
               end;
            else
               Set_Test_Child (Pkg, "");
            end if;
      end case;
   end Update_Package;


   procedure Update_Package
     (Pkg : in out Map_Package;
      Context : in Meaningless_Type;
      Name : in Sx.Atom)
   is
      pragma Unreferenced (Context);
   begin
      case Command_Maps.To_Package_Command (Sx.To_String (Name)) is
         when Private_Child =>
            Set_Private_Child (Pkg, True);
         when Public_Child =>
            Set_Private_Child (Pkg, False);
         when Pure_Package =>
            Set_Categorization (Pkg, Pure);
         when Preelaborate_Package =>
            Set_Categorization (Pkg, Preelaborate);
         when Extra_Declarations =>
            Set_Extra_Declarations (Pkg, Sx.To_String (Name));
         when Test_Function =>
            null;
      end case;
   end Update_Package;



   -----------------------
   -- Public Generators --
   -----------------------

   procedure Generate_Packages
     (Input : in out Sx.Lockable.Descriptor'Class;
      Description : in String := "")
   is
      Pkg : Map_Package;
   begin
      Package_Generator (Input, Pkg, Description);
   end Generate_Packages;


   procedure Generate_Package
     (Input : in out Sx.Lockable.Descriptor'Class;
      Description : in String := "")
   is
      use type Sx.Events.Event;
      Pkg : Map_Package;
   begin
      if Input.Current_Event /= Sx.Events.Add_Atom then
         return;
      end if;

      declare
         Name : constant Sx.Atom := Input.Current_Atom;
         Event : Sx.Events.Event;
      begin
         Input.Next (Event);
         if Event = Sx.Events.Add_Atom or Event = Sx.Events.Open_List then
            Generate_Package (Pkg, Description, Name, Input);
         end if;
      end;
   end Generate_Package;

end Natools.Static_Hash_Maps.S_Expressions;