Natools

Check-in [0d8d6300c9]
Login

Check-in [0d8d6300c9]

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:static_hash_maps-s_expressions: add S-expression bindings for the test child function generation
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 0d8d6300c9cc1131bb9a88c08898713b3d8d4e0d
User & Date: nat 2014-05-28 17:28:09.195
Context
2014-05-29
18:36
static_hash_maps-s_expressions-tests: new test around generated function for S-expression interpreter check-in: e3eb7b3d2d user: nat tags: trunk
2014-05-28
17:28
static_hash_maps-s_expressions: add S-expression bindings for the test child function generation check-in: 0d8d6300c9 user: nat tags: trunk
2014-05-27
20:22
static_hash_maps: add support for generation of hash function test check-in: 65c085f000 user: nat tags: trunk
Changes
Unified Diff Ignore Whitespace Patch
Changes to src/natools-static_hash_maps-s_expressions-command_maps.adb. 
1
2
3
4
5
6
7
8

--  Generated at 2014-05-26 20:24:08 +0000 by Natools.Static_Hash_Maps
--  from natools-static_hash_maps-s_expressions-hash_maps.sx

with Natools.Static_Hash_Maps.S_Expressions.Command_Pkg;
with Natools.Static_Hash_Maps.S_Expressions.Command_Map;

package body Natools.Static_Hash_Maps.S_Expressions.Command_Maps is


|








1
2
3
4
5
6
7
8

--  Generated at 2014-05-28 17:27:24 +0000 by Natools.Static_Hash_Maps
--  from natools-static_hash_maps-s_expressions-hash_maps.sx

with Natools.Static_Hash_Maps.S_Expressions.Command_Pkg;
with Natools.Static_Hash_Maps.S_Expressions.Command_Map;

package body Natools.Static_Hash_Maps.S_Expressions.Command_Maps is
︙︙
Changes to src/natools-static_hash_maps-s_expressions-command_maps.ads. 
1
2
3
4
5
6
7
8
9
10
11
12



13
14
15



16


17
18

19
20
21
22
23
24
25

--  Generated at 2014-05-26 20:24:08 +0000 by Natools.Static_Hash_Maps
--  from natools-static_hash_maps-s_expressions-hash_maps.sx

private package Natools.Static_Hash_Maps.S_Expressions.Command_Maps is

   function To_Package_Command (Key : String) return Package_Command;
   function To_Map_Command (Key : String) return Map_Command;

private

   Map_1_Key_0 : aliased constant String := "private";
   Map_1_Key_1 : aliased constant String := "public";



   Map_1_Keys : constant array (0 .. 1) of access constant String
     := (Map_1_Key_0'Access,
         Map_1_Key_1'Access);



   Map_1_Elements : constant array (0 .. 1) of Package_Command


     := (Private_Child,
         Public_Child);


   Map_2_Key_0 : aliased constant String := "hash-package";
   Map_2_Key_1 : aliased constant String := "nodes";
   Map_2_Key_2 : aliased constant String := "function";
   Map_2_Key_3 : aliased constant String := "not-found";
   Map_2_Keys : constant array (0 .. 3) of access constant String
     := (Map_2_Key_0'Access,

|









|
|
>
>
>
|

|
>
>
>
|
>
>
|
|
>








1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34

--  Generated at 2014-05-28 17:27:24 +0000 by Natools.Static_Hash_Maps
--  from natools-static_hash_maps-s_expressions-hash_maps.sx

private package Natools.Static_Hash_Maps.S_Expressions.Command_Maps is

   function To_Package_Command (Key : String) return Package_Command;
   function To_Map_Command (Key : String) return Map_Command;

private

   Map_1_Key_0 : aliased constant String := "extra-declarations";
   Map_1_Key_1 : aliased constant String := "extra-decl";
   Map_1_Key_2 : aliased constant String := "private";
   Map_1_Key_3 : aliased constant String := "public";
   Map_1_Key_4 : aliased constant String := "test-function";
   Map_1_Keys : constant array (0 .. 4) of access constant String
     := (Map_1_Key_0'Access,
         Map_1_Key_1'Access,
         Map_1_Key_2'Access,
         Map_1_Key_3'Access,
         Map_1_Key_4'Access);
   Map_1_Elements : constant array (0 .. 4) of Package_Command
     := (Extra_Declarations,
         Extra_Declarations,
         Private_Child,
         Public_Child,
         Test_Function);

   Map_2_Key_0 : aliased constant String := "hash-package";
   Map_2_Key_1 : aliased constant String := "nodes";
   Map_2_Key_2 : aliased constant String := "function";
   Map_2_Key_3 : aliased constant String := "not-found";
   Map_2_Keys : constant array (0 .. 3) of access constant String
     := (Map_2_Key_0'Access,
︙︙
Changes to src/natools-static_hash_maps-s_expressions-command_pkg.adb. 
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32

with Interfaces; use Interfaces;

package body Natools.Static_Hash_Maps.S_Expressions.Command_Pkg is

   P : constant array (0 .. 0) of Natural :=
     (0 .. 0 => 2);

   T1 : constant array (0 .. 0) of Unsigned_8 :=
     (0 .. 0 => 4);

   T2 : constant array (0 .. 0) of Unsigned_8 :=
     (0 .. 0 => 3);

   G : constant array (0 .. 4) of Unsigned_8 :=
     (0, 0, 0, 1, 0);

   function Hash (S : String) return Natural is
      F : constant Natural := S'First - 1;
      L : constant Natural := S'Length;
      F1, F2 : Natural := 0;
      J : Natural;
   begin
      for K in P'Range loop
         exit when L < P (K);
         J  := Character'Pos (S (P (K) + F));
         F1 := (F1 + Natural (T1 (K)) * J) mod 5;
         F2 := (F2 + Natural (T2 (K)) * J) mod 5;
      end loop;
      return (Natural (G (F1)) + Natural (G (F2))) mod 2;
   end Hash;

end Natools.Static_Hash_Maps.S_Expressions.Command_Pkg;





|
|

|
|

|
|

|
|










|
|

|




1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32

with Interfaces; use Interfaces;

package body Natools.Static_Hash_Maps.S_Expressions.Command_Pkg is

   P : constant array (0 .. 1) of Natural :=
     (2, 11);

   T1 : constant array (0 .. 1) of Unsigned_8 :=
     (8, 10);

   T2 : constant array (0 .. 1) of Unsigned_8 :=
     (5, 2);

   G : constant array (0 .. 10) of Unsigned_8 :=
     (2, 3, 0, 0, 0, 0, 1, 0, 0, 0, 2);

   function Hash (S : String) return Natural is
      F : constant Natural := S'First - 1;
      L : constant Natural := S'Length;
      F1, F2 : Natural := 0;
      J : Natural;
   begin
      for K in P'Range loop
         exit when L < P (K);
         J  := Character'Pos (S (P (K) + F));
         F1 := (F1 + Natural (T1 (K)) * J) mod 11;
         F2 := (F2 + Natural (T2 (K)) * J) mod 11;
      end loop;
      return (Natural (G (F1)) + Natural (G (F2))) mod 5;
   end Hash;

end Natools.Static_Hash_Maps.S_Expressions.Command_Pkg;
Changes to src/natools-static_hash_maps-s_expressions-hash_maps.sx. 
1
2
3
4
5
6
7

8
9

10
11
12
13
14
15
16

(Natools.Static_Hash_Maps.S_Expressions.Command_Maps
   private
   (Package_Command
      (hash-package Natools.Static_Hash_Maps.S_Expressions.Command_Pkg)
      (function To_Package_Command)
      (not-found Extra_Declarations)
      (nodes

         (Private_Child private)
         (Public_Child public)))

   (Map_Command
      (hash-package Natools.Static_Hash_Maps.S_Expressions.Command_Map)
      (function To_Map_Command)
      (nodes
         (Hash_Package hash-package)
         (Nodes nodes)
         (Function_Name function)








>

|
>








1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18

(Natools.Static_Hash_Maps.S_Expressions.Command_Maps
   private
   (Package_Command
      (hash-package Natools.Static_Hash_Maps.S_Expressions.Command_Pkg)
      (function To_Package_Command)
      (not-found Extra_Declarations)
      (nodes
         (Extra_Declarations extra-declarations extra-decl)
         (Private_Child private)
         (Public_Child public)
         (Test_Function test-function)))
   (Map_Command
      (hash-package Natools.Static_Hash_Maps.S_Expressions.Command_Map)
      (function To_Map_Command)
      (nodes
         (Hash_Package hash-package)
         (Nodes nodes)
         (Function_Name function)
︙︙
Changes to src/natools-static_hash_maps-s_expressions.adb.
︙︙
47
48
49
50
51
52
53






54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75

      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, Add_Map, Update_Package);

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



   -------------------------








>
>
>
>
>
>














|








47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81

      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);



   -------------------------
︙︙
164
165
166
167
168
169
170



























































171
172
173
174
175
176
177
178
179
180
181


182
183
184
185
186
187
188

      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)
   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 Extra_Declarations =>
            Set_Extra_Declarations (Pkg, Sx.To_String (Name));


      end case;
   end Update_Package;



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








>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>











>
>








170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255

      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 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 Extra_Declarations =>
            Set_Extra_Declarations (Pkg, Sx.To_String (Name));
         when Test_Function =>
            null;
      end case;
   end Update_Package;



   -----------------------
   -- Public Generators --
︙︙
Changes to src/natools-static_hash_maps-s_expressions.ads.
︙︙
37
38
39
40
41
42
43

44
45
46
47
48
49
50

      --  Generate the package described by Input

private

   type Package_Command is
     (Private_Child,
      Public_Child,

      Extra_Declarations);

   type Map_Command is
     (Hash_Package,
      Nodes,
      Function_Name,
      Not_Found);








>








37
38
39
40
41
42
43
44
45
46
47
48
49
50
51

      --  Generate the package described by Input

private

   type Package_Command is
     (Private_Child,
      Public_Child,
      Test_Function,
      Extra_Declarations);

   type Map_Command is
     (Hash_Package,
      Nodes,
      Function_Name,
      Not_Found);
︙︙