ADDED src/natools-static_hash_maps.adb Index: src/natools-static_hash_maps.adb ================================================================== --- src/natools-static_hash_maps.adb +++ src/natools-static_hash_maps.adb @@ -0,0 +1,566 @@ +------------------------------------------------------------------------------ +-- 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 Ada.Calendar.Formatting; +with Ada.Calendar.Time_Zones; +with Ada.Characters.Handling; +with Ada.Directories; +with Ada.Text_IO; + +with GNAT.Perfect_Hash_Generators; + +package body Natools.Static_Hash_Maps is + + function File_Name (Package_Name : in String) return String; + -- Convert a package name into a file name, the GNAT way + + function Image (Pos : Natural) return String; + -- Trimmed image, for suffix construction + + function Image (Offset : Ada.Calendar.Time_Zones.Time_Offset) return String; + + procedure Write_Map_Body + (Map : in Map_Description; + Prefix : in String; + File : in Ada.Text_IO.File_Type); + procedure Write_Map_Hash_Package (Map : in Map_Description); + procedure Write_Map_Private_Spec + (Map : in Map_Description; + Prefix : in String; + File : in Ada.Text_IO.File_Type); + procedure Write_Map_Public_Spec + (Map : in Map_Description; + File : in Ada.Text_IO.File_Type); + procedure Write_Map_With + (Map : in Map_Description; + File : in Ada.Text_IO.File_Type); + -- Output fragments relevant for the given map + + procedure Write_Package + (Pkg : in Map_Package; + Spec_File, Body_File : in Ada.Text_IO.File_Type); + -- Output a complete map package + + + ------------------------ + -- Package Generators -- + ------------------------ + + function File_Name (Package_Name : in String) return String is + Result : String := Ada.Characters.Handling.To_Lower (Package_Name); + begin + for I in Result'Range loop + if Result (I) = '.' then + Result (I) := '-'; + end if; + end loop; + + return Result; + end File_Name; + + + function Image (Pos : Natural) return String is + Result : constant String := Natural'Image (Pos); + begin + pragma Assert (Result (Result'First) = ' '); + return Result (Result'First + 1 .. Result'Last); + end Image; + + + function Image (Offset : Ada.Calendar.Time_Zones.Time_Offset) + return String + is + use type Ada.Calendar.Time_Zones.Time_Offset; + H : constant Natural := Natural (abs Offset) / 60; + M : constant Natural := Natural (abs Offset) mod 60; + Sign : Character := '+'; + begin + if Offset < 0 then + Sign := '-'; + end if; + + return String'(1 => Sign, + 2 => Character'Val (48 + H / 10), + 3 => Character'Val (48 + H mod 10), + 4 => Character'Val (48 + M / 10), + 5 => Character'Val (48 + M mod 10)); + end Image; + + + procedure Write_Map_Body + (Map : in Map_Description; + Prefix : in String; + File : in Ada.Text_IO.File_Type) is + begin + Ada.Text_IO.Put_Line + (File, + " function " + & To_String (Map.Function_Name) + & " (Key : String) return " + & To_String (Map.Element_Type) + & " is"); + Ada.Text_IO.Put_Line (File, " N : constant Natural"); + Ada.Text_IO.Put_Line + (File, + " := " & To_String (Map.Hash_Package_Name) & ".Hash (Key);"); + Ada.Text_IO.Put_Line (File, " begin"); + Ada.Text_IO.Put_Line + (File, " if " & Prefix & "_Keys (N).all = Key then"); + Ada.Text_IO.Put_Line + (File, " return " & Prefix & "_Elements (N);"); + Ada.Text_IO.Put_Line (File, " else"); + if To_String (Map.Not_Found) /= "" then + Ada.Text_IO.Put_Line + (File, " return " & To_String (Map.Not_Found) & ';'); + else + Ada.Text_IO.Put_Line + (File, + " raise Constraint_Error " + & "with ""Key """""" & Key & """""" not in map"";"); + end if; + Ada.Text_IO.Put_Line (File, " end if;"); + Ada.Text_IO.Put_Line + (File, " end " & To_String (Map.Function_Name) & ';'); + end Write_Map_Body; + + + procedure Write_Map_Hash_Package (Map : in Map_Description) is + Seed : constant Natural := 2; + Cursor : Node_Lists.Cursor := Map.Nodes.First; + begin + while Node_Lists.Has_Element (Cursor) loop + GNAT.Perfect_Hash_Generators.Insert + (To_String (Node_Lists.Element (Cursor).Key)); + Node_Lists.Next (Cursor); + end loop; + + GNAT.Perfect_Hash_Generators.Initialize (Seed); + GNAT.Perfect_Hash_Generators.Compute; + GNAT.Perfect_Hash_Generators.Produce (To_String (Map.Hash_Package_Name)); + GNAT.Perfect_Hash_Generators.Finalize; + exception + when others => + GNAT.Perfect_Hash_Generators.Finalize; + raise; + end Write_Map_Hash_Package; + + + procedure Write_Map_Private_Spec + (Map : in Map_Description; + Prefix : in String; + File : in Ada.Text_IO.File_Type) + is + Last : constant Natural := Positive (Map.Nodes.Length) - 1; + Pos : Natural; + Cursor : Node_Lists.Cursor; + begin + Pos := 0; + Cursor := Map.Nodes.First; + while Node_Lists.Has_Element (Cursor) loop + Ada.Text_IO.Put_Line + (File, + " " & Prefix & "_Key_" & Image (Pos) + & " : aliased constant String := """ + & To_String (Node_Lists.Element (Cursor).Key) + & """;"); + Pos := Pos + 1; + Node_Lists.Next (Cursor); + end loop; + + Ada.Text_IO.Put_Line + (File, + " " & Prefix & "_Keys : constant array (0 .. " & Image (Last) + & ") of access constant String"); + Pos := 0; + Cursor := Map.Nodes.First; + while Node_Lists.Has_Element (Cursor) loop + if Pos = 0 then + Ada.Text_IO.Put (File, " := ("); + else + Ada.Text_IO.Put (File, " "); + end if; + + Ada.Text_IO.Put (File, Prefix & "_Key_" & Image (Pos) & "'Access"); + + if Pos = Last then + Ada.Text_IO.Put_Line (File, ");"); + else + Ada.Text_IO.Put_Line (File, ","); + end if; + + Pos := Pos + 1; + Node_Lists.Next (Cursor); + end loop; + + Ada.Text_IO.Put_Line + (File, + " " & Prefix & "_Elements : constant array (0 .. " & Image (Last) + & ") of " & To_String (Map.Element_Type)); + Pos := 0; + Cursor := Map.Nodes.First; + while Node_Lists.Has_Element (Cursor) loop + if Pos = 0 then + Ada.Text_IO.Put (File, " := ("); + else + Ada.Text_IO.Put (File, " "); + end if; + + Ada.Text_IO.Put + (File, To_String (Node_Lists.Element (Cursor).Name)); + + if Pos = Last then + Ada.Text_IO.Put_Line (File, ");"); + else + Ada.Text_IO.Put_Line (File, ","); + end if; + + Pos := Pos + 1; + Node_Lists.Next (Cursor); + end loop; + end Write_Map_Private_Spec; + + + procedure Write_Map_Public_Spec + (Map : in Map_Description; + File : in Ada.Text_IO.File_Type) is + begin + Ada.Text_IO.Put_Line + (File, + " function " + & To_String (Map.Function_Name) + & " (Key : String) return " + & To_String (Map.Element_Type) + & ';'); + end Write_Map_Public_Spec; + + + procedure Write_Map_With + (Map : in Map_Description; + File : in Ada.Text_IO.File_Type) is + begin + Ada.Text_IO.Put_Line + (File, "with " & To_String (Map.Hash_Package_Name) & ';'); + end Write_Map_With; + + + procedure Write_Package + (Pkg : in Map_Package; + Spec_File, Body_File : in Ada.Text_IO.File_Type) + is + type Stage is + (Hash_Package, Public_Spec, Private_Spec, Body_With, Body_Contents); + + Current_Stage : Stage; + Map_Pos : Natural := 0; + + procedure Process (Element : in Map_Description); + procedure Query (Cursor : in Map_Lists.Cursor); + + procedure Process (Element : in Map_Description) is + Prefix : constant String := "Map_" & Image (Map_Pos + 1); + begin + case Current_Stage is + when Hash_Package => + Write_Map_Hash_Package (Element); + when Public_Spec => + Write_Map_Public_Spec (Element, Spec_File); + when Private_Spec => + Ada.Text_IO.New_Line (Spec_File); + Write_Map_Private_Spec (Element, Prefix, Spec_File); + when Body_With => + Write_Map_With (Element, Body_File); + when Body_Contents => + Ada.Text_IO.New_Line (Body_File); + Write_Map_Body (Element, Prefix, Body_File); + Ada.Text_IO.New_Line (Body_File); + end case; + Map_Pos := Map_Pos + 1; + end Process; + + procedure Query (Cursor : in Map_Lists.Cursor) is + begin + Map_Lists.Query_Element (Cursor, Process'Access); + end Query; + begin + Current_Stage := Hash_Package; + Map_Pos := 0; + Pkg.Maps.Iterate (Query'Access); + + Write_Headers : + declare + Now : constant Ada.Calendar.Time := Ada.Calendar.Clock; + Offset : constant Ada.Calendar.Time_Zones.Time_Offset + := Ada.Calendar.Time_Zones.UTC_Time_Offset (Now); + Header : constant String + := "-- Generated at " + & Ada.Calendar.Formatting.Image (Now, False, Offset) + & ' ' & Image (Offset) + & " by Natools.Static_Hash_Maps"; + Description : constant String := To_String (Pkg.Description); + begin + Ada.Text_IO.Put_Line (Spec_File, Header); + Ada.Text_IO.Put_Line (Body_File, Header); + if Description'Length > 0 then + Ada.Text_IO.Put_Line (Spec_File, "-- " & Description); + Ada.Text_IO.Put_Line (Body_File, "-- " & Description); + end if; + Ada.Text_IO.New_Line (Spec_File); + Ada.Text_IO.New_Line (Body_File); + end Write_Headers; + + if Pkg.Priv then + Ada.Text_IO.Put (Spec_File, "private "); + end if; + Ada.Text_IO.Put_Line + (Spec_File, "package " & To_String (Pkg.Name) & " is"); + Ada.Text_IO.New_Line (Spec_File); + + Current_Stage := Public_Spec; + Map_Pos := 0; + Pkg.Maps.Iterate (Query'Access); + + Ada.Text_IO.New_Line (Spec_File); + Ada.Text_IO.Put_Line (Spec_File, "private"); + + Current_Stage := Private_Spec; + Map_Pos := 0; + Pkg.Maps.Iterate (Query'Access); + + Ada.Text_IO.New_Line (Spec_File); + Ada.Text_IO.Put_Line (Spec_File, "end " & To_String (Pkg.Name) & ';'); + + Current_Stage := Body_With; + Map_Pos := 0; + Pkg.Maps.Iterate (Query'Access); + + Ada.Text_IO.New_Line (Body_File); + Ada.Text_IO.Put_Line + (Body_File, "package body " & To_String (Pkg.Name) & " is"); + + Current_Stage := Body_Contents; + Map_Pos := 0; + Pkg.Maps.Iterate (Query'Access); + + Ada.Text_IO.Put_Line (Body_File, "end " & To_String (Pkg.Name) & ';'); + end Write_Package; + + + + ------------------------------- + -- Key-Name Pair Constructor -- + ------------------------------- + + function Node (Key, Name : String) return Map_Node is + begin + return (Key => Hold (Key), Name => Hold (Name)); + end Node; + + + + --------------------------------- + -- Map Description Subprograms -- + --------------------------------- + + procedure Reset (Self : out Map_Description) is + begin + Self := (Element_Type => Hold (""), + Hash_Package_Name => Hold (""), + Function_Name => Hold (""), + Not_Found => Hold (""), + Nodes => Node_Lists.Empty_List); + end Reset; + + + procedure Insert + (Self : in out Map_Description; + Key : in String; + Element_Name : in String) is + begin + Self.Nodes.Append (Node (Key, Element_Name)); + end Insert; + + + procedure Set_Element_Type + (Self : in out Map_Description; + Name : in String) is + begin + Self.Element_Type := Hold (Name); + end Set_Element_Type; + + + procedure Set_Function_Name + (Self : in out Map_Description; + Name : in String) is + begin + Self.Function_Name := Hold (Name); + end Set_Function_Name; + + + procedure Set_Hash_Package_Name + (Self : in out Map_Description; + Name : in String) is + begin + Self.Hash_Package_Name := Hold (Name); + end Set_Hash_Package_Name; + + + procedure Set_Not_Found + (Self : in out Map_Description; + Name : in String) is + begin + Self.Not_Found := Hold (Name); + end Set_Not_Found; + + + function Map + (Element_Type : String; + Nodes : Node_Array; + Hash_Package_Name : String := ""; + Function_Name : String := "Element"; + Not_Found : String := "") + return Map_Description + is + Result : Map_Description + := (Element_Type => Hold (Element_Type), + Hash_Package_Name => Hold (Hash_Package_Name), + Function_Name => Hold (Function_Name), + Not_Found => Hold (Not_Found), + Nodes => Node_Lists.Empty_List); + begin + for I in Nodes'Range loop + Result.Nodes.Append (Nodes (I)); + end loop; + + return Result; + end Map; + + + ---------------------------- + -- Map Package Primitives -- + ---------------------------- + + procedure Open + (Self : in out Map_Package; + Name : in String; + Private_Child : in Boolean := False) is + begin + Self.Name := Hold (Name); + Self.Description := Hold (""); + Self.Priv := Private_Child; + Self.Maps.Clear; + end Open; + + + procedure Close (Self : in out Map_Package) is + begin + Self.Name := Hold (""); + Self.Maps.Clear; + end Close; + + + procedure Set_Description + (Self : in out Map_Package; + Description : in String) is + begin + Self.Description := Hold (Description); + end Set_Description; + + + procedure Set_Private_Child + (Self : in out Map_Package; + Private_Child : in Boolean := True) is + begin + Self.Priv := Private_Child; + end Set_Private_Child; + + + procedure Add_Map (Self : in out Map_Package; Map : in Map_Description) is + begin + if To_String (Self.Name) = "" then + raise Constraint_Error + with "Add_Map on non-opened static hash map package"; + end if; + + Self.Maps.Append (Map); + end Add_Map; + + + procedure Commit (Self : in out Map_Package) is + begin + if To_String (Self.Name) = "" then + raise Constraint_Error + with "Commit on static hash map package without a name"; + end if; + + if Self.Maps.Is_Empty then + raise Constraint_Error + with "Commit on static hash map package without any map"; + end if; + + declare + Package_Name : constant String := To_String (Self.Name); + Base_Name : constant String := File_Name (Package_Name); + Spec_File, Body_File : Ada.Text_IO.File_Type; + begin + Ada.Text_IO.Create + (File => Spec_File, + Name => Ada.Directories.Compose ("", Base_Name, "ads")); + Ada.Text_IO.Create + (File => Body_File, + Name => Ada.Directories.Compose ("", Base_Name, "adb")); + + Write_Package (Self, Spec_File, Body_File); + + Ada.Text_IO.Close (Spec_File); + Ada.Text_IO.Close (Body_File); + end; + end Commit; + + + + ------------------------- + -- Combined Procedures -- + ------------------------- + + procedure Generate_Package + (Name : in String; + Single_Map : in Map_Description; + Private_Child : in Boolean := False) + is + Object : Map_Package; + begin + Open (Object, Name, Private_Child); + Add_Map (Object, Single_Map); + Commit (Object); + end Generate_Package; + + + procedure Generate_Package + (Name : in String; + Maps : in Map_Array; + Private_Child : in Boolean := False) + is + Object : Map_Package; + begin + Open (Object, Name, Private_Child); + for I in Maps'Range loop + Add_Map (Object, Maps (I)); + end loop; + Commit (Object); + end Generate_Package; + +end Natools.Static_Hash_Maps; + ADDED src/natools-static_hash_maps.ads Index: src/natools-static_hash_maps.ads ================================================================== --- src/natools-static_hash_maps.ads +++ src/natools-static_hash_maps.ads @@ -0,0 +1,155 @@ +------------------------------------------------------------------------------ +-- 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.Static_Hash_Maps is a code generator that outputs hash map -- +-- packages based on GNAT.Perfect_Hash_Generator. -- +-- This is mostly a text manipulation package, and no sanity checks are -- +-- performed on input strings, they are inserted as-is in the output files. -- +------------------------------------------------------------------------------ + +private with Ada.Strings.Unbounded; +private with Ada.Containers.Doubly_Linked_Lists; + +package Natools.Static_Hash_Maps is + + type Map_Node is private; + + function Node (Key, Name : String) return Map_Node; + + type Node_Array is array (Positive range <>) of Map_Node; + + type Map_Description is private; + + type Map_Array is array (Positive range <>) of Map_Description; + + procedure Reset (Self : out Map_Description); + + procedure Insert + (Self : in out Map_Description; + Key : in String; + Element_Name : in String); + -- Add the pair Key and element designated by Name. + + procedure Set_Element_Type + (Self : in out Map_Description; + Name : in String); + -- String used to desginate the returning type of the element function. + -- This must be set. + + procedure Set_Function_Name + (Self : in out Map_Description; + Name : in String); + -- Element function name, defaulting to "Element" + + procedure Set_Hash_Package_Name + (Self : in out Map_Description; + Name : in String); + -- Set the package name where the perfect hash function will be write. + -- Defaults to "._Hash". + + procedure Set_Not_Found + (Self : in out Map_Description; + Name : in String); + -- If non-empty, when element function is called with an unknown key, + -- return the elemnet named Name instead of raising Constraint_Error. + + function Map + (Element_Type : String; + Nodes : Node_Array; + Hash_Package_Name : String := ""; + Function_Name : String := "Element"; + Not_Found : String := "") + return Map_Description; + -- Create a map in a single call + + + type Map_Package is private; + + procedure Open + (Self : in out Map_Package; + Name : in String; + Private_Child : in Boolean := False); + -- Reset Self and initialize it with the givan package Name + + procedure Set_Description + (Self : in out Map_Package; + Description : in String); + + procedure Set_Private_Child + (Self : in out Map_Package; + Private_Child : in Boolean := True); + + procedure Add_Map (Self : in out Map_Package; Map : in Map_Description); + -- Append a new Map to Self + + procedure Commit (Self : in out Map_Package); + -- Write accumulated package description to disk + + procedure Close (Self : in out Map_Package); + -- Drop all internal state + + + procedure Generate_Package + (Name : in String; + Single_Map : in Map_Description; + Private_Child : in Boolean := False); + procedure Generate_Package + (Name : in String; + Maps : in Map_Array; + Private_Child : in Boolean := False); + -- Build an internal Map_Package and commit it to disk + -- in a single operation. + +private + + subtype String_Holder is Ada.Strings.Unbounded.Unbounded_String; + + function Hold (S : String) return String_Holder + renames Ada.Strings.Unbounded.To_Unbounded_String; + + function To_String (H : String_Holder) return String + renames Ada.Strings.Unbounded.To_String; + + + type Map_Node is record + Key, Name : String_Holder; + end record; + + + + package Node_Lists is new Ada.Containers.Doubly_Linked_Lists (Map_Node); + + type Map_Description is record + Element_Type : String_Holder; + Hash_Package_Name : String_Holder; + Function_Name : String_Holder; + Not_Found : String_Holder; + Nodes : Node_Lists.List; + end record; + + + package Map_Lists is new Ada.Containers.Doubly_Linked_Lists + (Map_Description); + + type Map_Package is record + Name : String_Holder; + Description : String_Holder; + Priv : Boolean; + Maps : Map_Lists.List; + end record; + +end Natools.Static_Hash_Maps;