Index: src/natools-static_hash_maps.adb ================================================================== --- src/natools-static_hash_maps.adb +++ src/natools-static_hash_maps.adb @@ -49,13 +49,20 @@ 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); + Spec_File, Body_File : in Ada.Text_IO.File_Type; + Test : in Boolean := False); -- Output a complete map package + procedure Write_Test + (Map : in Map_Description; + Prefix : in String; + File : in Ada.Text_IO.File_Type); + -- Output test loop for the hash function + ------------------------ -- Package Generators -- ------------------------ @@ -281,14 +288,16 @@ end Write_Map_With; procedure Write_Package (Pkg : in Map_Package; - Spec_File, Body_File : in Ada.Text_IO.File_Type) + Spec_File, Body_File : in Ada.Text_IO.File_Type; + Test : in Boolean := False) is type Stage is - (Hash_Package, Public_Spec, Private_Spec, Body_With, Body_Contents); + (Hash_Package, Public_Spec, Private_Spec, Body_With, Body_Contents, + Test_Body); Current_Stage : Stage; Map_Pos : Natural := 0; procedure Process (Element : in Map_Description); @@ -309,10 +318,13 @@ 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); + when Test_Body => + Write_Test (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 @@ -343,10 +355,39 @@ 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 Test then + declare + Name : constant String + := To_String (Pkg.Name) + & '.' + & To_String (Pkg.Test_Child); + begin + Ada.Text_IO.Put_Line (Spec_File, "function " & Name); + Ada.Text_IO.Put_Line (Spec_File, " return Boolean;"); + + Current_Stage := Body_With; + Map_Pos := 0; + Pkg.Maps.Iterate (Query'Access); + + Ada.Text_IO.Put_Line (Body_File, "function " & Name); + Ada.Text_IO.Put_Line (Body_File, " return Boolean is"); + Ada.Text_IO.Put_Line (Body_File, "begin"); + + Current_Stage := Test_Body; + Map_Pos := 0; + Pkg.Maps.Iterate (Query'Access); + + Ada.Text_IO.Put_Line (Body_File, " return True;"); + Ada.Text_IO.Put_Line (Body_File, "end " & Name & ';'); + end; + + return; + end if; if Pkg.Priv then Ada.Text_IO.Put (Spec_File, "private "); end if; Ada.Text_IO.Put_Line @@ -388,10 +429,31 @@ Map_Pos := 0; Pkg.Maps.Iterate (Query'Access); Ada.Text_IO.Put_Line (Body_File, "end " & To_String (Pkg.Name) & ';'); end Write_Package; + + + procedure Write_Test + (Map : in Map_Description; + Prefix : in String; + File : in Ada.Text_IO.File_Type) + is + Key_Array_Name : constant String := Prefix & "_Keys"; + begin + Ada.Text_IO.Put_Line (File, " for I in " + & Key_Array_Name & "'Range loop"); + Ada.Text_IO.Put_Line (File, " if " + & To_String (Map.Hash_Package_Name) & ".Hash"); + Ada.Text_IO.Put_Line (File, " (" + & Key_Array_Name & " (I).all) /= I"); + Ada.Text_IO.Put_Line (File, " then"); + Ada.Text_IO.Put_Line (File, " return False;"); + Ada.Text_IO.Put_Line (File, " end if;"); + Ada.Text_IO.Put_Line (File, " end loop;"); + end Write_Test; + ------------------------------- -- Key-Name Pair Constructor -- @@ -526,10 +588,18 @@ Private_Child : in Boolean := True) is begin Self.Priv := Private_Child; end Set_Private_Child; + + procedure Set_Test_Child + (Self : in out Map_Package; + Test_Child : in String) is + begin + Self.Test_Child := Hold (Test_Child); + end Set_Test_Child; + procedure Add_Map (Self : in out Map_Package; Map : in Map_Description) is begin if To_String (Self.Name) = "" then raise Constraint_Error @@ -567,10 +637,31 @@ Write_Package (Self, Spec_File, Body_File); Ada.Text_IO.Close (Spec_File); Ada.Text_IO.Close (Body_File); end; + + if To_String (Self.Test_Child) /= "" then + declare + Unit_Name : constant String + := To_String (Self.Name) & '.' & To_String (Self.Test_Child); + Base_Name : constant String := File_Name (Unit_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, Test => True); + + Ada.Text_IO.Close (Spec_File); + Ada.Text_IO.Close (Body_File); + end; + end if; end Commit; ------------------------- Index: src/natools-static_hash_maps.ads ================================================================== --- src/natools-static_hash_maps.ads +++ src/natools-static_hash_maps.ads @@ -95,10 +95,14 @@ procedure Set_Private_Child (Self : in out Map_Package; Private_Child : in Boolean := True); + procedure Set_Test_Child + (Self : in out Map_Package; + Test_Child : in String); + 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 @@ -151,10 +155,11 @@ type Map_Package is record Name : String_Holder; Description : String_Holder; Extra_Declarations : String_Holder; + Test_Child : String_Holder; Priv : Boolean; Maps : Map_Lists.List; end record; end Natools.Static_Hash_Maps;