File : g-pehage.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- G N A T . P E R F E C T _ H A S H _ G E N E R A T O R S --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2002-2015, AdaCore --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
17 -- --
18 -- --
19 -- --
20 -- --
21 -- --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
26 -- --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
29 -- --
30 ------------------------------------------------------------------------------
31
32 with Ada.IO_Exceptions; use Ada.IO_Exceptions;
33 with Ada.Characters.Handling; use Ada.Characters.Handling;
34 with Ada.Directories;
35
36 with GNAT.Heap_Sort_G;
37 with GNAT.OS_Lib; use GNAT.OS_Lib;
38 with GNAT.Table;
39
40 package body GNAT.Perfect_Hash_Generators is
41
42 -- We are using the algorithm of J. Czech as described in Zbigniew J.
43 -- Czech, George Havas, and Bohdan S. Majewski ``An Optimal Algorithm for
44 -- Generating Minimal Perfect Hash Functions'', Information Processing
45 -- Letters, 43(1992) pp.257-264, Oct.1992
46
47 -- This minimal perfect hash function generator is based on random graphs
48 -- and produces a hash function of the form:
49
50 -- h (w) = (g (f1 (w)) + g (f2 (w))) mod m
51
52 -- where f1 and f2 are functions that map strings into integers, and g is
53 -- a function that maps integers into [0, m-1]. h can be order preserving.
54 -- For instance, let W = {w_0, ..., w_i, ..., w_m-1}, h can be defined
55 -- such that h (w_i) = i.
56
57 -- This algorithm defines two possible constructions of f1 and f2. Method
58 -- b) stores the hash function in less memory space at the expense of
59 -- greater CPU time.
60
61 -- a) fk (w) = sum (for i in 1 .. length (w)) (Tk (i, w (i))) mod n
62
63 -- size (Tk) = max (for w in W) (length (w)) * size (used char set)
64
65 -- b) fk (w) = sum (for i in 1 .. length (w)) (Tk (i) * w (i)) mod n
66
67 -- size (Tk) = max (for w in W) (length (w)) but the table lookups are
68 -- replaced by multiplications.
69
70 -- where Tk values are randomly generated. n is defined later on but the
71 -- algorithm recommends to use a value a little bit greater than 2m. Note
72 -- that for large values of m, the main memory space requirements comes
73 -- from the memory space for storing function g (>= 2m entries).
74
75 -- Random graphs are frequently used to solve difficult problems that do
76 -- not have polynomial solutions. This algorithm is based on a weighted
77 -- undirected graph. It comprises two steps: mapping and assignment.
78
79 -- In the mapping step, a graph G = (V, E) is constructed, where = {0, 1,
80 -- ..., n-1} and E = {(for w in W) (f1 (w), f2 (w))}. In order for the
81 -- assignment step to be successful, G has to be acyclic. To have a high
82 -- probability of generating an acyclic graph, n >= 2m. If it is not
83 -- acyclic, Tk have to be regenerated.
84
85 -- In the assignment step, the algorithm builds function g. As G is
86 -- acyclic, there is a vertex v1 with only one neighbor v2. Let w_i be
87 -- the word such that v1 = f1 (w_i) and v2 = f2 (w_i). Let g (v1) = 0 by
88 -- construction and g (v2) = (i - g (v1)) mod n (or h (i) - g (v1) mod n).
89 -- If word w_j is such that v2 = f1 (w_j) and v3 = f2 (w_j), g (v3) = (j -
90 -- g (v2)) mod (or to be general, (h (j) - g (v2)) mod n). If w_i has no
91 -- neighbor, then another vertex is selected. The algorithm traverses G to
92 -- assign values to all the vertices. It cannot assign a value to an
93 -- already assigned vertex as G is acyclic.
94
95 subtype Word_Id is Integer;
96 subtype Key_Id is Integer;
97 subtype Vertex_Id is Integer;
98 subtype Edge_Id is Integer;
99 subtype Table_Id is Integer;
100
101 No_Vertex : constant Vertex_Id := -1;
102 No_Edge : constant Edge_Id := -1;
103 No_Table : constant Table_Id := -1;
104
105 type Word_Type is new String_Access;
106 procedure Free_Word (W : in out Word_Type) renames Free;
107 function New_Word (S : String) return Word_Type;
108
109 procedure Resize_Word (W : in out Word_Type; Len : Natural);
110 -- Resize string W to have a length Len
111
112 type Key_Type is record
113 Edge : Edge_Id;
114 end record;
115 -- A key corresponds to an edge in the algorithm graph
116
117 type Vertex_Type is record
118 First : Edge_Id;
119 Last : Edge_Id;
120 end record;
121 -- A vertex can be involved in several edges. First and Last are the bounds
122 -- of an array of edges stored in a global edge table.
123
124 type Edge_Type is record
125 X : Vertex_Id;
126 Y : Vertex_Id;
127 Key : Key_Id;
128 end record;
129 -- An edge is a peer of vertices. In the algorithm, a key is associated to
130 -- an edge.
131
132 package WT is new GNAT.Table (Word_Type, Word_Id, 0, 32, 32);
133 package IT is new GNAT.Table (Integer, Integer, 0, 32, 32);
134 -- The two main tables. WT is used to store the words in their initial
135 -- version and in their reduced version (that is words reduced to their
136 -- significant characters). As an instance of GNAT.Table, WT does not
137 -- initialize string pointers to null. This initialization has to be done
138 -- manually when the table is allocated. IT is used to store several
139 -- tables of components containing only integers.
140
141 function Image (Int : Integer; W : Natural := 0) return String;
142 function Image (Str : String; W : Natural := 0) return String;
143 -- Return a string which includes string Str or integer Int preceded by
144 -- leading spaces if required by width W.
145
146 function Trim_Trailing_Nuls (Str : String) return String;
147 -- Return Str with trailing NUL characters removed
148
149 Output : File_Descriptor renames GNAT.OS_Lib.Standout;
150 -- Shortcuts
151
152 EOL : constant Character := ASCII.LF;
153
154 Max : constant := 78;
155 Last : Natural := 0;
156 Line : String (1 .. Max);
157 -- Use this line to provide buffered IO
158
159 procedure Add (C : Character);
160 procedure Add (S : String);
161 -- Add a character or a string in Line and update Last
162
163 procedure Put
164 (F : File_Descriptor;
165 S : String;
166 F1 : Natural;
167 L1 : Natural;
168 C1 : Natural;
169 F2 : Natural;
170 L2 : Natural;
171 C2 : Natural);
172 -- Write string S into file F as a element of an array of one or two
173 -- dimensions. Fk (resp. Lk and Ck) indicates the first (resp last and
174 -- current) index in the k-th dimension. If F1 = L1 the array is considered
175 -- as a one dimension array. This dimension is described by F2 and L2. This
176 -- routine takes care of all the parenthesis, spaces and commas needed to
177 -- format correctly the array. Moreover, the array is well indented and is
178 -- wrapped to fit in a 80 col line. When the line is full, the routine
179 -- writes it into file F. When the array is completed, the routine adds
180 -- semi-colon and writes the line into file F.
181
182 procedure New_Line (File : File_Descriptor);
183 -- Simulate Ada.Text_IO.New_Line with GNAT.OS_Lib
184
185 procedure Put (File : File_Descriptor; Str : String);
186 -- Simulate Ada.Text_IO.Put with GNAT.OS_Lib
187
188 procedure Put_Used_Char_Set (File : File_Descriptor; Title : String);
189 -- Output a title and a used character set
190
191 procedure Put_Int_Vector
192 (File : File_Descriptor;
193 Title : String;
194 Vector : Integer;
195 Length : Natural);
196 -- Output a title and a vector
197
198 procedure Put_Int_Matrix
199 (File : File_Descriptor;
200 Title : String;
201 Table : Table_Id;
202 Len_1 : Natural;
203 Len_2 : Natural);
204 -- Output a title and a matrix. When the matrix has only one non-empty
205 -- dimension (Len_2 = 0), output a vector.
206
207 procedure Put_Edges (File : File_Descriptor; Title : String);
208 -- Output a title and an edge table
209
210 procedure Put_Initial_Keys (File : File_Descriptor; Title : String);
211 -- Output a title and a key table
212
213 procedure Put_Reduced_Keys (File : File_Descriptor; Title : String);
214 -- Output a title and a key table
215
216 procedure Put_Vertex_Table (File : File_Descriptor; Title : String);
217 -- Output a title and a vertex table
218
219 function Ada_File_Base_Name (Pkg_Name : String) return String;
220 -- Return the base file name (i.e. without .ads/.adb extension) for an
221 -- Ada source file containing the named package, using the standard GNAT
222 -- file-naming convention. For example, if Pkg_Name is "Parent.Child", we
223 -- return "parent-child".
224
225 ----------------------------------
226 -- Character Position Selection --
227 ----------------------------------
228
229 -- We reduce the maximum key size by selecting representative positions
230 -- in these keys. We build a matrix with one word per line. We fill the
231 -- remaining space of a line with ASCII.NUL. The heuristic selects the
232 -- position that induces the minimum number of collisions. If there are
233 -- collisions, select another position on the reduced key set responsible
234 -- of the collisions. Apply the heuristic until there is no more collision.
235
236 procedure Apply_Position_Selection;
237 -- Apply Position selection and build the reduced key table
238
239 procedure Parse_Position_Selection (Argument : String);
240 -- Parse Argument and compute the position set. Argument is list of
241 -- substrings separated by commas. Each substring represents a position
242 -- or a range of positions (like x-y).
243
244 procedure Select_Character_Set;
245 -- Define an optimized used character set like Character'Pos in order not
246 -- to allocate tables of 256 entries.
247
248 procedure Select_Char_Position;
249 -- Find a min char position set in order to reduce the max key length. The
250 -- heuristic selects the position that induces the minimum number of
251 -- collisions. If there are collisions, select another position on the
252 -- reduced key set responsible of the collisions. Apply the heuristic until
253 -- there is no collision.
254
255 -----------------------------
256 -- Random Graph Generation --
257 -----------------------------
258
259 procedure Random (Seed : in out Natural);
260 -- Simulate Ada.Discrete_Numerics.Random
261
262 procedure Generate_Mapping_Table
263 (Tab : Table_Id;
264 L1 : Natural;
265 L2 : Natural;
266 Seed : in out Natural);
267 -- Random generation of the tables below. T is already allocated
268
269 procedure Generate_Mapping_Tables
270 (Opt : Optimization;
271 Seed : in out Natural);
272 -- Generate the mapping tables T1 and T2. They are used to define fk (w) =
273 -- sum (for i in 1 .. length (w)) (Tk (i, w (i))) mod n. Keys, NK and Chars
274 -- are used to compute the matrix size.
275
276 ---------------------------
277 -- Algorithm Computation --
278 ---------------------------
279
280 procedure Compute_Edges_And_Vertices (Opt : Optimization);
281 -- Compute the edge and vertex tables. These are empty when a self loop is
282 -- detected (f1 (w) = f2 (w)). The edge table is sorted by X value and then
283 -- Y value. Keys is the key table and NK the number of keys. Chars is the
284 -- set of characters really used in Keys. NV is the number of vertices
285 -- recommended by the algorithm. T1 and T2 are the mapping tables needed to
286 -- compute f1 (w) and f2 (w).
287
288 function Acyclic return Boolean;
289 -- Return True when the graph is acyclic. Vertices is the current vertex
290 -- table and Edges the current edge table.
291
292 procedure Assign_Values_To_Vertices;
293 -- Execute the assignment step of the algorithm. Keys is the current key
294 -- table. Vertices and Edges represent the random graph. G is the result of
295 -- the assignment step such that:
296 -- h (w) = (g (f1 (w)) + g (f2 (w))) mod m
297
298 function Sum
299 (Word : Word_Type;
300 Table : Table_Id;
301 Opt : Optimization) return Natural;
302 -- For an optimization of CPU_Time return
303 -- fk (w) = sum (for i in 1 .. length (w)) (Tk (i, w (i))) mod n
304 -- For an optimization of Memory_Space return
305 -- fk (w) = sum (for i in 1 .. length (w)) (Tk (i) * w (i)) mod n
306 -- Here NV = n
307
308 -------------------------------
309 -- Internal Table Management --
310 -------------------------------
311
312 function Allocate (N : Natural; S : Natural := 1) return Table_Id;
313 -- Allocate N * S ints from IT table
314
315 ----------
316 -- Keys --
317 ----------
318
319 Keys : Table_Id := No_Table;
320 NK : Natural := 0;
321 -- NK : Number of Keys
322
323 function Initial (K : Key_Id) return Word_Id;
324 pragma Inline (Initial);
325
326 function Reduced (K : Key_Id) return Word_Id;
327 pragma Inline (Reduced);
328
329 function Get_Key (N : Key_Id) return Key_Type;
330 procedure Set_Key (N : Key_Id; Item : Key_Type);
331 -- Get or Set Nth element of Keys table
332
333 ------------------
334 -- Char_Pos_Set --
335 ------------------
336
337 Char_Pos_Set : Table_Id := No_Table;
338 Char_Pos_Set_Len : Natural;
339 -- Character Selected Position Set
340
341 function Get_Char_Pos (P : Natural) return Natural;
342 procedure Set_Char_Pos (P : Natural; Item : Natural);
343 -- Get or Set the string position of the Pth selected character
344
345 -------------------
346 -- Used_Char_Set --
347 -------------------
348
349 Used_Char_Set : Table_Id := No_Table;
350 Used_Char_Set_Len : Natural;
351 -- Used Character Set : Define a new character mapping. When all the
352 -- characters are not present in the keys, in order to reduce the size
353 -- of some tables, we redefine the character mapping.
354
355 function Get_Used_Char (C : Character) return Natural;
356 procedure Set_Used_Char (C : Character; Item : Natural);
357
358 ------------
359 -- Tables --
360 ------------
361
362 T1 : Table_Id := No_Table;
363 T2 : Table_Id := No_Table;
364 T1_Len : Natural;
365 T2_Len : Natural;
366 -- T1 : Values table to compute F1
367 -- T2 : Values table to compute F2
368
369 function Get_Table (T : Integer; X, Y : Natural) return Natural;
370 procedure Set_Table (T : Integer; X, Y : Natural; Item : Natural);
371
372 -----------
373 -- Graph --
374 -----------
375
376 G : Table_Id := No_Table;
377 G_Len : Natural;
378 -- Values table to compute G
379
380 NT : Natural := Default_Tries;
381 -- Number of tries running the algorithm before raising an error
382
383 function Get_Graph (N : Natural) return Integer;
384 procedure Set_Graph (N : Natural; Item : Integer);
385 -- Get or Set Nth element of graph
386
387 -----------
388 -- Edges --
389 -----------
390
391 Edge_Size : constant := 3;
392 Edges : Table_Id := No_Table;
393 Edges_Len : Natural;
394 -- Edges : Edge table of the random graph G
395
396 function Get_Edges (F : Natural) return Edge_Type;
397 procedure Set_Edges (F : Natural; Item : Edge_Type);
398
399 --------------
400 -- Vertices --
401 --------------
402
403 Vertex_Size : constant := 2;
404
405 Vertices : Table_Id := No_Table;
406 -- Vertex table of the random graph G
407
408 NV : Natural;
409 -- Number of Vertices
410
411 function Get_Vertices (F : Natural) return Vertex_Type;
412 procedure Set_Vertices (F : Natural; Item : Vertex_Type);
413 -- Comments needed ???
414
415 K2V : Float;
416 -- Ratio between Keys and Vertices (parameter of Czech's algorithm)
417
418 Opt : Optimization;
419 -- Optimization mode (memory vs CPU)
420
421 Max_Key_Len : Natural := 0;
422 Min_Key_Len : Natural := 0;
423 -- Maximum and minimum of all the word length
424
425 S : Natural;
426 -- Seed
427
428 function Type_Size (L : Natural) return Natural;
429 -- Given the last L of an unsigned integer type T, return its size
430
431 -------------
432 -- Acyclic --
433 -------------
434
435 function Acyclic return Boolean is
436 Marks : array (0 .. NV - 1) of Vertex_Id := (others => No_Vertex);
437
438 function Traverse (Edge : Edge_Id; Mark : Vertex_Id) return Boolean;
439 -- Propagate Mark from X to Y. X is already marked. Mark Y and propagate
440 -- it to the edges of Y except the one representing the same key. Return
441 -- False when Y is marked with Mark.
442
443 --------------
444 -- Traverse --
445 --------------
446
447 function Traverse (Edge : Edge_Id; Mark : Vertex_Id) return Boolean is
448 E : constant Edge_Type := Get_Edges (Edge);
449 K : constant Key_Id := E.Key;
450 Y : constant Vertex_Id := E.Y;
451 M : constant Vertex_Id := Marks (E.Y);
452 V : Vertex_Type;
453
454 begin
455 if M = Mark then
456 return False;
457
458 elsif M = No_Vertex then
459 Marks (Y) := Mark;
460 V := Get_Vertices (Y);
461
462 for J in V.First .. V.Last loop
463
464 -- Do not propagate to the edge representing the same key
465
466 if Get_Edges (J).Key /= K
467 and then not Traverse (J, Mark)
468 then
469 return False;
470 end if;
471 end loop;
472 end if;
473
474 return True;
475 end Traverse;
476
477 Edge : Edge_Type;
478
479 -- Start of processing for Acyclic
480
481 begin
482 -- Edges valid range is
483
484 for J in 1 .. Edges_Len - 1 loop
485
486 Edge := Get_Edges (J);
487
488 -- Mark X of E when it has not been already done
489
490 if Marks (Edge.X) = No_Vertex then
491 Marks (Edge.X) := Edge.X;
492 end if;
493
494 -- Traverse E when this has not already been done
495
496 if Marks (Edge.Y) = No_Vertex
497 and then not Traverse (J, Edge.X)
498 then
499 return False;
500 end if;
501 end loop;
502
503 return True;
504 end Acyclic;
505
506 ------------------------
507 -- Ada_File_Base_Name --
508 ------------------------
509
510 function Ada_File_Base_Name (Pkg_Name : String) return String is
511 begin
512 -- Convert to lower case, then replace '.' with '-'
513
514 return Result : String := To_Lower (Pkg_Name) do
515 for J in Result'Range loop
516 if Result (J) = '.' then
517 Result (J) := '-';
518 end if;
519 end loop;
520 end return;
521 end Ada_File_Base_Name;
522
523 ---------
524 -- Add --
525 ---------
526
527 procedure Add (C : Character) is
528 pragma Assert (C /= ASCII.NUL);
529 begin
530 Line (Last + 1) := C;
531 Last := Last + 1;
532 end Add;
533
534 ---------
535 -- Add --
536 ---------
537
538 procedure Add (S : String) is
539 Len : constant Natural := S'Length;
540 begin
541 for J in S'Range loop
542 pragma Assert (S (J) /= ASCII.NUL);
543 null;
544 end loop;
545
546 Line (Last + 1 .. Last + Len) := S;
547 Last := Last + Len;
548 end Add;
549
550 --------------
551 -- Allocate --
552 --------------
553
554 function Allocate (N : Natural; S : Natural := 1) return Table_Id is
555 L : constant Integer := IT.Last;
556 begin
557 IT.Set_Last (L + N * S);
558
559 -- Initialize, so debugging printouts don't trip over uninitialized
560 -- components.
561
562 for J in L + 1 .. IT.Last loop
563 IT.Table (J) := -1;
564 end loop;
565
566 return L + 1;
567 end Allocate;
568
569 ------------------------------
570 -- Apply_Position_Selection --
571 ------------------------------
572
573 procedure Apply_Position_Selection is
574 begin
575 for J in 0 .. NK - 1 loop
576 declare
577 IW : constant String := WT.Table (Initial (J)).all;
578 RW : String (1 .. IW'Length) := (others => ASCII.NUL);
579 N : Natural := IW'First - 1;
580
581 begin
582 -- Select the characters of Word included in the position
583 -- selection.
584
585 for C in 0 .. Char_Pos_Set_Len - 1 loop
586 exit when IW (Get_Char_Pos (C)) = ASCII.NUL;
587 N := N + 1;
588 RW (N) := IW (Get_Char_Pos (C));
589 end loop;
590
591 -- Build the new table with the reduced word. Be careful
592 -- to deallocate the old version to avoid memory leaks.
593
594 Free_Word (WT.Table (Reduced (J)));
595 WT.Table (Reduced (J)) := New_Word (RW);
596 Set_Key (J, (Edge => No_Edge));
597 end;
598 end loop;
599 end Apply_Position_Selection;
600
601 -------------------------------
602 -- Assign_Values_To_Vertices --
603 -------------------------------
604
605 procedure Assign_Values_To_Vertices is
606 X : Vertex_Id;
607
608 procedure Assign (X : Vertex_Id);
609 -- Execute assignment on X's neighbors except the vertex that we are
610 -- coming from which is already assigned.
611
612 ------------
613 -- Assign --
614 ------------
615
616 procedure Assign (X : Vertex_Id) is
617 E : Edge_Type;
618 V : constant Vertex_Type := Get_Vertices (X);
619
620 begin
621 for J in V.First .. V.Last loop
622 E := Get_Edges (J);
623
624 if Get_Graph (E.Y) = -1 then
625 Set_Graph (E.Y, (E.Key - Get_Graph (X)) mod NK);
626 Assign (E.Y);
627 end if;
628 end loop;
629 end Assign;
630
631 -- Start of processing for Assign_Values_To_Vertices
632
633 begin
634 -- Value -1 denotes an uninitialized value as it is supposed to
635 -- be in the range 0 .. NK.
636
637 if G = No_Table then
638 G_Len := NV;
639 G := Allocate (G_Len, 1);
640 end if;
641
642 for J in 0 .. G_Len - 1 loop
643 Set_Graph (J, -1);
644 end loop;
645
646 for K in 0 .. NK - 1 loop
647 X := Get_Edges (Get_Key (K).Edge).X;
648
649 if Get_Graph (X) = -1 then
650 Set_Graph (X, 0);
651 Assign (X);
652 end if;
653 end loop;
654
655 for J in 0 .. G_Len - 1 loop
656 if Get_Graph (J) = -1 then
657 Set_Graph (J, 0);
658 end if;
659 end loop;
660
661 if Verbose then
662 Put_Int_Vector (Output, "Assign Values To Vertices", G, G_Len);
663 end if;
664 end Assign_Values_To_Vertices;
665
666 -------------
667 -- Compute --
668 -------------
669
670 procedure Compute (Position : String := Default_Position) is
671 Success : Boolean := False;
672
673 begin
674 if NK = 0 then
675 raise Program_Error with "keywords set cannot be empty";
676 end if;
677
678 if Verbose then
679 Put_Initial_Keys (Output, "Initial Key Table");
680 end if;
681
682 if Position'Length /= 0 then
683 Parse_Position_Selection (Position);
684 else
685 Select_Char_Position;
686 end if;
687
688 if Verbose then
689 Put_Int_Vector
690 (Output, "Char Position Set", Char_Pos_Set, Char_Pos_Set_Len);
691 end if;
692
693 Apply_Position_Selection;
694
695 if Verbose then
696 Put_Reduced_Keys (Output, "Reduced Keys Table");
697 end if;
698
699 Select_Character_Set;
700
701 if Verbose then
702 Put_Used_Char_Set (Output, "Character Position Table");
703 end if;
704
705 -- Perform Czech's algorithm
706
707 for J in 1 .. NT loop
708 Generate_Mapping_Tables (Opt, S);
709 Compute_Edges_And_Vertices (Opt);
710
711 -- When graph is not empty (no self-loop from previous operation) and
712 -- not acyclic.
713
714 if 0 < Edges_Len and then Acyclic then
715 Success := True;
716 exit;
717 end if;
718 end loop;
719
720 if not Success then
721 raise Too_Many_Tries;
722 end if;
723
724 Assign_Values_To_Vertices;
725 end Compute;
726
727 --------------------------------
728 -- Compute_Edges_And_Vertices --
729 --------------------------------
730
731 procedure Compute_Edges_And_Vertices (Opt : Optimization) is
732 X : Natural;
733 Y : Natural;
734 Key : Key_Type;
735 Edge : Edge_Type;
736 Vertex : Vertex_Type;
737 Not_Acyclic : Boolean := False;
738
739 procedure Move (From : Natural; To : Natural);
740 function Lt (L, R : Natural) return Boolean;
741 -- Subprograms needed for GNAT.Heap_Sort_G
742
743 --------
744 -- Lt --
745 --------
746
747 function Lt (L, R : Natural) return Boolean is
748 EL : constant Edge_Type := Get_Edges (L);
749 ER : constant Edge_Type := Get_Edges (R);
750 begin
751 return EL.X < ER.X or else (EL.X = ER.X and then EL.Y < ER.Y);
752 end Lt;
753
754 ----------
755 -- Move --
756 ----------
757
758 procedure Move (From : Natural; To : Natural) is
759 begin
760 Set_Edges (To, Get_Edges (From));
761 end Move;
762
763 package Sorting is new GNAT.Heap_Sort_G (Move, Lt);
764
765 -- Start of processing for Compute_Edges_And_Vertices
766
767 begin
768 -- We store edges from 1 to 2 * NK and leave zero alone in order to use
769 -- GNAT.Heap_Sort_G.
770
771 Edges_Len := 2 * NK + 1;
772
773 if Edges = No_Table then
774 Edges := Allocate (Edges_Len, Edge_Size);
775 end if;
776
777 if Vertices = No_Table then
778 Vertices := Allocate (NV, Vertex_Size);
779 end if;
780
781 for J in 0 .. NV - 1 loop
782 Set_Vertices (J, (No_Vertex, No_Vertex - 1));
783 end loop;
784
785 -- For each w, X = f1 (w) and Y = f2 (w)
786
787 for J in 0 .. NK - 1 loop
788 Key := Get_Key (J);
789 Key.Edge := No_Edge;
790 Set_Key (J, Key);
791
792 X := Sum (WT.Table (Reduced (J)), T1, Opt);
793 Y := Sum (WT.Table (Reduced (J)), T2, Opt);
794
795 -- Discard T1 and T2 as soon as we discover a self loop
796
797 if X = Y then
798 Not_Acyclic := True;
799 exit;
800 end if;
801
802 -- We store (X, Y) and (Y, X) to ease assignment step
803
804 Set_Edges (2 * J + 1, (X, Y, J));
805 Set_Edges (2 * J + 2, (Y, X, J));
806 end loop;
807
808 -- Return an empty graph when self loop detected
809
810 if Not_Acyclic then
811 Edges_Len := 0;
812
813 else
814 if Verbose then
815 Put_Edges (Output, "Unsorted Edge Table");
816 Put_Int_Matrix (Output, "Function Table 1", T1,
817 T1_Len, T2_Len);
818 Put_Int_Matrix (Output, "Function Table 2", T2,
819 T1_Len, T2_Len);
820 end if;
821
822 -- Enforce consistency between edges and keys. Construct Vertices and
823 -- compute the list of neighbors of a vertex First .. Last as Edges
824 -- is sorted by X and then Y. To compute the neighbor list, sort the
825 -- edges.
826
827 Sorting.Sort (Edges_Len - 1);
828
829 if Verbose then
830 Put_Edges (Output, "Sorted Edge Table");
831 Put_Int_Matrix (Output, "Function Table 1", T1,
832 T1_Len, T2_Len);
833 Put_Int_Matrix (Output, "Function Table 2", T2,
834 T1_Len, T2_Len);
835 end if;
836
837 -- Edges valid range is 1 .. 2 * NK
838
839 for E in 1 .. Edges_Len - 1 loop
840 Edge := Get_Edges (E);
841 Key := Get_Key (Edge.Key);
842
843 if Key.Edge = No_Edge then
844 Key.Edge := E;
845 Set_Key (Edge.Key, Key);
846 end if;
847
848 Vertex := Get_Vertices (Edge.X);
849
850 if Vertex.First = No_Edge then
851 Vertex.First := E;
852 end if;
853
854 Vertex.Last := E;
855 Set_Vertices (Edge.X, Vertex);
856 end loop;
857
858 if Verbose then
859 Put_Reduced_Keys (Output, "Key Table");
860 Put_Edges (Output, "Edge Table");
861 Put_Vertex_Table (Output, "Vertex Table");
862 end if;
863 end if;
864 end Compute_Edges_And_Vertices;
865
866 ------------
867 -- Define --
868 ------------
869
870 procedure Define
871 (Name : Table_Name;
872 Item_Size : out Natural;
873 Length_1 : out Natural;
874 Length_2 : out Natural)
875 is
876 begin
877 case Name is
878 when Character_Position =>
879 Item_Size := 8;
880 Length_1 := Char_Pos_Set_Len;
881 Length_2 := 0;
882
883 when Used_Character_Set =>
884 Item_Size := 8;
885 Length_1 := 256;
886 Length_2 := 0;
887
888 when Function_Table_1
889 | Function_Table_2 =>
890 Item_Size := Type_Size (NV);
891 Length_1 := T1_Len;
892 Length_2 := T2_Len;
893
894 when Graph_Table =>
895 Item_Size := Type_Size (NK);
896 Length_1 := NV;
897 Length_2 := 0;
898 end case;
899 end Define;
900
901 --------------
902 -- Finalize --
903 --------------
904
905 procedure Finalize is
906 begin
907 if Verbose then
908 Put (Output, "Finalize");
909 New_Line (Output);
910 end if;
911
912 -- Deallocate all the WT components (both initial and reduced ones) to
913 -- avoid memory leaks.
914
915 for W in 0 .. WT.Last loop
916
917 -- Note: WT.Table (NK) is a temporary variable, do not free it since
918 -- this would cause a double free.
919
920 if W /= NK then
921 Free_Word (WT.Table (W));
922 end if;
923 end loop;
924
925 WT.Release;
926 IT.Release;
927
928 -- Reset all variables for next usage
929
930 Keys := No_Table;
931
932 Char_Pos_Set := No_Table;
933 Char_Pos_Set_Len := 0;
934
935 Used_Char_Set := No_Table;
936 Used_Char_Set_Len := 0;
937
938 T1 := No_Table;
939 T2 := No_Table;
940
941 T1_Len := 0;
942 T2_Len := 0;
943
944 G := No_Table;
945 G_Len := 0;
946
947 Edges := No_Table;
948 Edges_Len := 0;
949
950 Vertices := No_Table;
951 NV := 0;
952
953 NK := 0;
954 Max_Key_Len := 0;
955 Min_Key_Len := 0;
956 end Finalize;
957
958 ----------------------------
959 -- Generate_Mapping_Table --
960 ----------------------------
961
962 procedure Generate_Mapping_Table
963 (Tab : Integer;
964 L1 : Natural;
965 L2 : Natural;
966 Seed : in out Natural)
967 is
968 begin
969 for J in 0 .. L1 - 1 loop
970 for K in 0 .. L2 - 1 loop
971 Random (Seed);
972 Set_Table (Tab, J, K, Seed mod NV);
973 end loop;
974 end loop;
975 end Generate_Mapping_Table;
976
977 -----------------------------
978 -- Generate_Mapping_Tables --
979 -----------------------------
980
981 procedure Generate_Mapping_Tables
982 (Opt : Optimization;
983 Seed : in out Natural)
984 is
985 begin
986 -- If T1 and T2 are already allocated no need to do it twice. Reuse them
987 -- as their size has not changed.
988
989 if T1 = No_Table and then T2 = No_Table then
990 declare
991 Used_Char_Last : Natural := 0;
992 Used_Char : Natural;
993
994 begin
995 if Opt = CPU_Time then
996 for P in reverse Character'Range loop
997 Used_Char := Get_Used_Char (P);
998 if Used_Char /= 0 then
999 Used_Char_Last := Used_Char;
1000 exit;
1001 end if;
1002 end loop;
1003 end if;
1004
1005 T1_Len := Char_Pos_Set_Len;
1006 T2_Len := Used_Char_Last + 1;
1007 T1 := Allocate (T1_Len * T2_Len);
1008 T2 := Allocate (T1_Len * T2_Len);
1009 end;
1010 end if;
1011
1012 Generate_Mapping_Table (T1, T1_Len, T2_Len, Seed);
1013 Generate_Mapping_Table (T2, T1_Len, T2_Len, Seed);
1014
1015 if Verbose then
1016 Put_Used_Char_Set (Output, "Used Character Set");
1017 Put_Int_Matrix (Output, "Function Table 1", T1,
1018 T1_Len, T2_Len);
1019 Put_Int_Matrix (Output, "Function Table 2", T2,
1020 T1_Len, T2_Len);
1021 end if;
1022 end Generate_Mapping_Tables;
1023
1024 ------------------
1025 -- Get_Char_Pos --
1026 ------------------
1027
1028 function Get_Char_Pos (P : Natural) return Natural is
1029 N : constant Natural := Char_Pos_Set + P;
1030 begin
1031 return IT.Table (N);
1032 end Get_Char_Pos;
1033
1034 ---------------
1035 -- Get_Edges --
1036 ---------------
1037
1038 function Get_Edges (F : Natural) return Edge_Type is
1039 N : constant Natural := Edges + (F * Edge_Size);
1040 E : Edge_Type;
1041 begin
1042 E.X := IT.Table (N);
1043 E.Y := IT.Table (N + 1);
1044 E.Key := IT.Table (N + 2);
1045 return E;
1046 end Get_Edges;
1047
1048 ---------------
1049 -- Get_Graph --
1050 ---------------
1051
1052 function Get_Graph (N : Natural) return Integer is
1053 begin
1054 return IT.Table (G + N);
1055 end Get_Graph;
1056
1057 -------------
1058 -- Get_Key --
1059 -------------
1060
1061 function Get_Key (N : Key_Id) return Key_Type is
1062 K : Key_Type;
1063 begin
1064 K.Edge := IT.Table (Keys + N);
1065 return K;
1066 end Get_Key;
1067
1068 ---------------
1069 -- Get_Table --
1070 ---------------
1071
1072 function Get_Table (T : Integer; X, Y : Natural) return Natural is
1073 N : constant Natural := T + (Y * T1_Len) + X;
1074 begin
1075 return IT.Table (N);
1076 end Get_Table;
1077
1078 -------------------
1079 -- Get_Used_Char --
1080 -------------------
1081
1082 function Get_Used_Char (C : Character) return Natural is
1083 N : constant Natural := Used_Char_Set + Character'Pos (C);
1084 begin
1085 return IT.Table (N);
1086 end Get_Used_Char;
1087
1088 ------------------
1089 -- Get_Vertices --
1090 ------------------
1091
1092 function Get_Vertices (F : Natural) return Vertex_Type is
1093 N : constant Natural := Vertices + (F * Vertex_Size);
1094 V : Vertex_Type;
1095 begin
1096 V.First := IT.Table (N);
1097 V.Last := IT.Table (N + 1);
1098 return V;
1099 end Get_Vertices;
1100
1101 -----------
1102 -- Image --
1103 -----------
1104
1105 function Image (Int : Integer; W : Natural := 0) return String is
1106 B : String (1 .. 32);
1107 L : Natural := 0;
1108
1109 procedure Img (V : Natural);
1110 -- Compute image of V into B, starting at B (L), incrementing L
1111
1112 ---------
1113 -- Img --
1114 ---------
1115
1116 procedure Img (V : Natural) is
1117 begin
1118 if V > 9 then
1119 Img (V / 10);
1120 end if;
1121
1122 L := L + 1;
1123 B (L) := Character'Val ((V mod 10) + Character'Pos ('0'));
1124 end Img;
1125
1126 -- Start of processing for Image
1127
1128 begin
1129 if Int < 0 then
1130 L := L + 1;
1131 B (L) := '-';
1132 Img (-Int);
1133 else
1134 Img (Int);
1135 end if;
1136
1137 return Image (B (1 .. L), W);
1138 end Image;
1139
1140 -----------
1141 -- Image --
1142 -----------
1143
1144 function Image (Str : String; W : Natural := 0) return String is
1145 Len : constant Natural := Str'Length;
1146 Max : Natural := Len;
1147
1148 begin
1149 if Max < W then
1150 Max := W;
1151 end if;
1152
1153 declare
1154 Buf : String (1 .. Max) := (1 .. Max => ' ');
1155
1156 begin
1157 for J in 0 .. Len - 1 loop
1158 Buf (Max - Len + 1 + J) := Str (Str'First + J);
1159 end loop;
1160
1161 return Buf;
1162 end;
1163 end Image;
1164
1165 -------------
1166 -- Initial --
1167 -------------
1168
1169 function Initial (K : Key_Id) return Word_Id is
1170 begin
1171 return K;
1172 end Initial;
1173
1174 ----------------
1175 -- Initialize --
1176 ----------------
1177
1178 procedure Initialize
1179 (Seed : Natural;
1180 K_To_V : Float := Default_K_To_V;
1181 Optim : Optimization := Memory_Space;
1182 Tries : Positive := Default_Tries)
1183 is
1184 begin
1185 if Verbose then
1186 Put (Output, "Initialize");
1187 New_Line (Output);
1188 end if;
1189
1190 -- Deallocate the part of the table concerning the reduced words.
1191 -- Initial words are already present in the table. We may have reduced
1192 -- words already there because a previous computation failed. We are
1193 -- currently retrying and the reduced words have to be deallocated.
1194
1195 for W in Reduced (0) .. WT.Last loop
1196 Free_Word (WT.Table (W));
1197 end loop;
1198
1199 IT.Init;
1200
1201 -- Initialize of computation variables
1202
1203 Keys := No_Table;
1204
1205 Char_Pos_Set := No_Table;
1206 Char_Pos_Set_Len := 0;
1207
1208 Used_Char_Set := No_Table;
1209 Used_Char_Set_Len := 0;
1210
1211 T1 := No_Table;
1212 T2 := No_Table;
1213
1214 T1_Len := 0;
1215 T2_Len := 0;
1216
1217 G := No_Table;
1218 G_Len := 0;
1219
1220 Edges := No_Table;
1221 Edges_Len := 0;
1222
1223 Vertices := No_Table;
1224 NV := 0;
1225
1226 S := Seed;
1227 K2V := K_To_V;
1228 Opt := Optim;
1229 NT := Tries;
1230
1231 if K2V <= 2.0 then
1232 raise Program_Error with "K to V ratio cannot be lower than 2.0";
1233 end if;
1234
1235 -- Do not accept a value of K2V too close to 2.0 such that once
1236 -- rounded up, NV = 2 * NK because the algorithm would not converge.
1237
1238 NV := Natural (Float (NK) * K2V);
1239 if NV <= 2 * NK then
1240 NV := 2 * NK + 1;
1241 end if;
1242
1243 Keys := Allocate (NK);
1244
1245 -- Resize initial words to have all of them at the same size
1246 -- (so the size of the largest one).
1247
1248 for K in 0 .. NK - 1 loop
1249 Resize_Word (WT.Table (Initial (K)), Max_Key_Len);
1250 end loop;
1251
1252 -- Allocated the table to store the reduced words. As WT is a
1253 -- GNAT.Table (using C memory management), pointers have to be
1254 -- explicitly initialized to null.
1255
1256 WT.Set_Last (Reduced (NK - 1));
1257
1258 -- Note: Reduced (0) = NK + 1
1259
1260 WT.Table (NK) := null;
1261
1262 for W in 0 .. NK - 1 loop
1263 WT.Table (Reduced (W)) := null;
1264 end loop;
1265 end Initialize;
1266
1267 ------------
1268 -- Insert --
1269 ------------
1270
1271 procedure Insert (Value : String) is
1272 Len : constant Natural := Value'Length;
1273
1274 begin
1275 if Verbose then
1276 Put (Output, "Inserting """ & Value & """");
1277 New_Line (Output);
1278 end if;
1279
1280 for J in Value'Range loop
1281 pragma Assert (Value (J) /= ASCII.NUL);
1282 null;
1283 end loop;
1284
1285 WT.Set_Last (NK);
1286 WT.Table (NK) := New_Word (Value);
1287 NK := NK + 1;
1288
1289 if Max_Key_Len < Len then
1290 Max_Key_Len := Len;
1291 end if;
1292
1293 if Min_Key_Len = 0 or else Len < Min_Key_Len then
1294 Min_Key_Len := Len;
1295 end if;
1296 end Insert;
1297
1298 --------------
1299 -- New_Line --
1300 --------------
1301
1302 procedure New_Line (File : File_Descriptor) is
1303 begin
1304 if Write (File, EOL'Address, 1) /= 1 then
1305 raise Program_Error;
1306 end if;
1307 end New_Line;
1308
1309 --------------
1310 -- New_Word --
1311 --------------
1312
1313 function New_Word (S : String) return Word_Type is
1314 begin
1315 return new String'(S);
1316 end New_Word;
1317
1318 ------------------------------
1319 -- Parse_Position_Selection --
1320 ------------------------------
1321
1322 procedure Parse_Position_Selection (Argument : String) is
1323 N : Natural := Argument'First;
1324 L : constant Natural := Argument'Last;
1325 M : constant Natural := Max_Key_Len;
1326
1327 T : array (1 .. M) of Boolean := (others => False);
1328
1329 function Parse_Index return Natural;
1330 -- Parse argument starting at index N to find an index
1331
1332 -----------------
1333 -- Parse_Index --
1334 -----------------
1335
1336 function Parse_Index return Natural is
1337 C : Character := Argument (N);
1338 V : Natural := 0;
1339
1340 begin
1341 if C = '$' then
1342 N := N + 1;
1343 return M;
1344 end if;
1345
1346 if C not in '0' .. '9' then
1347 raise Program_Error with "cannot read position argument";
1348 end if;
1349
1350 while C in '0' .. '9' loop
1351 V := V * 10 + (Character'Pos (C) - Character'Pos ('0'));
1352 N := N + 1;
1353 exit when L < N;
1354 C := Argument (N);
1355 end loop;
1356
1357 return V;
1358 end Parse_Index;
1359
1360 -- Start of processing for Parse_Position_Selection
1361
1362 begin
1363 -- Empty specification means all the positions
1364
1365 if L < N then
1366 Char_Pos_Set_Len := M;
1367 Char_Pos_Set := Allocate (Char_Pos_Set_Len);
1368
1369 for C in 0 .. Char_Pos_Set_Len - 1 loop
1370 Set_Char_Pos (C, C + 1);
1371 end loop;
1372
1373 else
1374 loop
1375 declare
1376 First, Last : Natural;
1377
1378 begin
1379 First := Parse_Index;
1380 Last := First;
1381
1382 -- Detect a range
1383
1384 if N <= L and then Argument (N) = '-' then
1385 N := N + 1;
1386 Last := Parse_Index;
1387 end if;
1388
1389 -- Include the positions in the selection
1390
1391 for J in First .. Last loop
1392 T (J) := True;
1393 end loop;
1394 end;
1395
1396 exit when L < N;
1397
1398 if Argument (N) /= ',' then
1399 raise Program_Error with "cannot read position argument";
1400 end if;
1401
1402 N := N + 1;
1403 end loop;
1404
1405 -- Compute position selection length
1406
1407 N := 0;
1408 for J in T'Range loop
1409 if T (J) then
1410 N := N + 1;
1411 end if;
1412 end loop;
1413
1414 -- Fill position selection
1415
1416 Char_Pos_Set_Len := N;
1417 Char_Pos_Set := Allocate (Char_Pos_Set_Len);
1418
1419 N := 0;
1420 for J in T'Range loop
1421 if T (J) then
1422 Set_Char_Pos (N, J);
1423 N := N + 1;
1424 end if;
1425 end loop;
1426 end if;
1427 end Parse_Position_Selection;
1428
1429 -------------
1430 -- Produce --
1431 -------------
1432
1433 procedure Produce
1434 (Pkg_Name : String := Default_Pkg_Name;
1435 Use_Stdout : Boolean := False)
1436 is
1437 File : File_Descriptor := Standout;
1438
1439 Status : Boolean;
1440 -- For call to Close
1441
1442 function Array_Img (N, T, R1 : String; R2 : String := "") return String;
1443 -- Return string "N : constant array (R1[, R2]) of T;"
1444
1445 function Range_Img (F, L : Natural; T : String := "") return String;
1446 -- Return string "[T range ]F .. L"
1447
1448 function Type_Img (L : Natural) return String;
1449 -- Return the larger unsigned type T such that T'Last < L
1450
1451 ---------------
1452 -- Array_Img --
1453 ---------------
1454
1455 function Array_Img
1456 (N, T, R1 : String;
1457 R2 : String := "") return String
1458 is
1459 begin
1460 Last := 0;
1461 Add (" ");
1462 Add (N);
1463 Add (" : constant array (");
1464 Add (R1);
1465
1466 if R2 /= "" then
1467 Add (", ");
1468 Add (R2);
1469 end if;
1470
1471 Add (") of ");
1472 Add (T);
1473 Add (" :=");
1474 return Line (1 .. Last);
1475 end Array_Img;
1476
1477 ---------------
1478 -- Range_Img --
1479 ---------------
1480
1481 function Range_Img (F, L : Natural; T : String := "") return String is
1482 FI : constant String := Image (F);
1483 FL : constant Natural := FI'Length;
1484 LI : constant String := Image (L);
1485 LL : constant Natural := LI'Length;
1486 TL : constant Natural := T'Length;
1487 RI : String (1 .. TL + 7 + FL + 4 + LL);
1488 Len : Natural := 0;
1489
1490 begin
1491 if TL /= 0 then
1492 RI (Len + 1 .. Len + TL) := T;
1493 Len := Len + TL;
1494 RI (Len + 1 .. Len + 7) := " range ";
1495 Len := Len + 7;
1496 end if;
1497
1498 RI (Len + 1 .. Len + FL) := FI;
1499 Len := Len + FL;
1500 RI (Len + 1 .. Len + 4) := " .. ";
1501 Len := Len + 4;
1502 RI (Len + 1 .. Len + LL) := LI;
1503 Len := Len + LL;
1504 return RI (1 .. Len);
1505 end Range_Img;
1506
1507 --------------
1508 -- Type_Img --
1509 --------------
1510
1511 function Type_Img (L : Natural) return String is
1512 S : constant String := Image (Type_Size (L));
1513 U : String := "Unsigned_ ";
1514 N : Natural := 9;
1515
1516 begin
1517 for J in S'Range loop
1518 N := N + 1;
1519 U (N) := S (J);
1520 end loop;
1521
1522 return U (1 .. N);
1523 end Type_Img;
1524
1525 F : Natural;
1526 L : Natural;
1527 P : Natural;
1528
1529 FName : String := Ada_File_Base_Name (Pkg_Name) & ".ads";
1530 -- Initially, the name of the spec file, then modified to be the name of
1531 -- the body file. Not used if Use_Stdout is True.
1532
1533 -- Start of processing for Produce
1534
1535 begin
1536
1537 if Verbose and then not Use_Stdout then
1538 Put (Output,
1539 "Producing " & Ada.Directories.Current_Directory & "/" & FName);
1540 New_Line (Output);
1541 end if;
1542
1543 if not Use_Stdout then
1544 File := Create_File (FName, Binary);
1545
1546 if File = Invalid_FD then
1547 raise Program_Error with "cannot create: " & FName;
1548 end if;
1549 end if;
1550
1551 Put (File, "package ");
1552 Put (File, Pkg_Name);
1553 Put (File, " is");
1554 New_Line (File);
1555 Put (File, " function Hash (S : String) return Natural;");
1556 New_Line (File);
1557 Put (File, "end ");
1558 Put (File, Pkg_Name);
1559 Put (File, ";");
1560 New_Line (File);
1561
1562 if not Use_Stdout then
1563 Close (File, Status);
1564
1565 if not Status then
1566 raise Device_Error;
1567 end if;
1568 end if;
1569
1570 if not Use_Stdout then
1571
1572 -- Set to body file name
1573
1574 FName (FName'Last) := 'b';
1575
1576 File := Create_File (FName, Binary);
1577
1578 if File = Invalid_FD then
1579 raise Program_Error with "cannot create: " & FName;
1580 end if;
1581 end if;
1582
1583 Put (File, "with Interfaces; use Interfaces;");
1584 New_Line (File);
1585 New_Line (File);
1586 Put (File, "package body ");
1587 Put (File, Pkg_Name);
1588 Put (File, " is");
1589 New_Line (File);
1590 New_Line (File);
1591
1592 if Opt = CPU_Time then
1593 Put (File, Array_Img ("C", Type_Img (256), "Character"));
1594 New_Line (File);
1595
1596 F := Character'Pos (Character'First);
1597 L := Character'Pos (Character'Last);
1598
1599 for J in Character'Range loop
1600 P := Get_Used_Char (J);
1601 Put (File, Image (P), 1, 0, 1, F, L, Character'Pos (J));
1602 end loop;
1603
1604 New_Line (File);
1605 end if;
1606
1607 F := 0;
1608 L := Char_Pos_Set_Len - 1;
1609
1610 Put (File, Array_Img ("P", "Natural", Range_Img (F, L)));
1611 New_Line (File);
1612
1613 for J in F .. L loop
1614 Put (File, Image (Get_Char_Pos (J)), 1, 0, 1, F, L, J);
1615 end loop;
1616
1617 New_Line (File);
1618
1619 case Opt is
1620 when CPU_Time =>
1621 Put_Int_Matrix
1622 (File,
1623 Array_Img ("T1", Type_Img (NV),
1624 Range_Img (0, T1_Len - 1),
1625 Range_Img (0, T2_Len - 1, Type_Img (256))),
1626 T1, T1_Len, T2_Len);
1627
1628 when Memory_Space =>
1629 Put_Int_Matrix
1630 (File,
1631 Array_Img ("T1", Type_Img (NV),
1632 Range_Img (0, T1_Len - 1)),
1633 T1, T1_Len, 0);
1634 end case;
1635
1636 New_Line (File);
1637
1638 case Opt is
1639 when CPU_Time =>
1640 Put_Int_Matrix
1641 (File,
1642 Array_Img ("T2", Type_Img (NV),
1643 Range_Img (0, T1_Len - 1),
1644 Range_Img (0, T2_Len - 1, Type_Img (256))),
1645 T2, T1_Len, T2_Len);
1646
1647 when Memory_Space =>
1648 Put_Int_Matrix
1649 (File,
1650 Array_Img ("T2", Type_Img (NV),
1651 Range_Img (0, T1_Len - 1)),
1652 T2, T1_Len, 0);
1653 end case;
1654
1655 New_Line (File);
1656
1657 Put_Int_Vector
1658 (File,
1659 Array_Img ("G", Type_Img (NK),
1660 Range_Img (0, G_Len - 1)),
1661 G, G_Len);
1662 New_Line (File);
1663
1664 Put (File, " function Hash (S : String) return Natural is");
1665 New_Line (File);
1666 Put (File, " F : constant Natural := S'First - 1;");
1667 New_Line (File);
1668 Put (File, " L : constant Natural := S'Length;");
1669 New_Line (File);
1670 Put (File, " F1, F2 : Natural := 0;");
1671 New_Line (File);
1672
1673 Put (File, " J : ");
1674
1675 case Opt is
1676 when CPU_Time =>
1677 Put (File, Type_Img (256));
1678 when Memory_Space =>
1679 Put (File, "Natural");
1680 end case;
1681
1682 Put (File, ";");
1683 New_Line (File);
1684
1685 Put (File, " begin");
1686 New_Line (File);
1687 Put (File, " for K in P'Range loop");
1688 New_Line (File);
1689 Put (File, " exit when L < P (K);");
1690 New_Line (File);
1691 Put (File, " J := ");
1692
1693 case Opt is
1694 when CPU_Time =>
1695 Put (File, "C");
1696 when Memory_Space =>
1697 Put (File, "Character'Pos");
1698 end case;
1699
1700 Put (File, " (S (P (K) + F));");
1701 New_Line (File);
1702
1703 Put (File, " F1 := (F1 + Natural (T1 (K");
1704
1705 if Opt = CPU_Time then
1706 Put (File, ", J");
1707 end if;
1708
1709 Put (File, "))");
1710
1711 if Opt = Memory_Space then
1712 Put (File, " * J");
1713 end if;
1714
1715 Put (File, ") mod ");
1716 Put (File, Image (NV));
1717 Put (File, ";");
1718 New_Line (File);
1719
1720 Put (File, " F2 := (F2 + Natural (T2 (K");
1721
1722 if Opt = CPU_Time then
1723 Put (File, ", J");
1724 end if;
1725
1726 Put (File, "))");
1727
1728 if Opt = Memory_Space then
1729 Put (File, " * J");
1730 end if;
1731
1732 Put (File, ") mod ");
1733 Put (File, Image (NV));
1734 Put (File, ";");
1735 New_Line (File);
1736
1737 Put (File, " end loop;");
1738 New_Line (File);
1739
1740 Put (File,
1741 " return (Natural (G (F1)) + Natural (G (F2))) mod ");
1742
1743 Put (File, Image (NK));
1744 Put (File, ";");
1745 New_Line (File);
1746 Put (File, " end Hash;");
1747 New_Line (File);
1748 New_Line (File);
1749 Put (File, "end ");
1750 Put (File, Pkg_Name);
1751 Put (File, ";");
1752 New_Line (File);
1753
1754 if not Use_Stdout then
1755 Close (File, Status);
1756
1757 if not Status then
1758 raise Device_Error;
1759 end if;
1760 end if;
1761 end Produce;
1762
1763 ---------
1764 -- Put --
1765 ---------
1766
1767 procedure Put (File : File_Descriptor; Str : String) is
1768 Len : constant Natural := Str'Length;
1769 begin
1770 for J in Str'Range loop
1771 pragma Assert (Str (J) /= ASCII.NUL);
1772 null;
1773 end loop;
1774
1775 if Write (File, Str'Address, Len) /= Len then
1776 raise Program_Error;
1777 end if;
1778 end Put;
1779
1780 ---------
1781 -- Put --
1782 ---------
1783
1784 procedure Put
1785 (F : File_Descriptor;
1786 S : String;
1787 F1 : Natural;
1788 L1 : Natural;
1789 C1 : Natural;
1790 F2 : Natural;
1791 L2 : Natural;
1792 C2 : Natural)
1793 is
1794 Len : constant Natural := S'Length;
1795
1796 procedure Flush;
1797 -- Write current line, followed by LF
1798
1799 -----------
1800 -- Flush --
1801 -----------
1802
1803 procedure Flush is
1804 begin
1805 Put (F, Line (1 .. Last));
1806 New_Line (F);
1807 Last := 0;
1808 end Flush;
1809
1810 -- Start of processing for Put
1811
1812 begin
1813 if C1 = F1 and then C2 = F2 then
1814 Last := 0;
1815 end if;
1816
1817 if Last + Len + 3 >= Max then
1818 Flush;
1819 end if;
1820
1821 if Last = 0 then
1822 Add (" ");
1823
1824 if F1 <= L1 then
1825 if C1 = F1 and then C2 = F2 then
1826 Add ('(');
1827
1828 if F1 = L1 then
1829 Add ("0 .. 0 => ");
1830 end if;
1831
1832 else
1833 Add (' ');
1834 end if;
1835 end if;
1836 end if;
1837
1838 if C2 = F2 then
1839 Add ('(');
1840
1841 if F2 = L2 then
1842 Add ("0 .. 0 => ");
1843 end if;
1844
1845 else
1846 Add (' ');
1847 end if;
1848
1849 Add (S);
1850
1851 if C2 = L2 then
1852 Add (')');
1853
1854 if F1 > L1 then
1855 Add (';');
1856 Flush;
1857
1858 elsif C1 /= L1 then
1859 Add (',');
1860 Flush;
1861
1862 else
1863 Add (')');
1864 Add (';');
1865 Flush;
1866 end if;
1867
1868 else
1869 Add (',');
1870 end if;
1871 end Put;
1872
1873 ---------------
1874 -- Put_Edges --
1875 ---------------
1876
1877 procedure Put_Edges (File : File_Descriptor; Title : String) is
1878 E : Edge_Type;
1879 F1 : constant Natural := 1;
1880 L1 : constant Natural := Edges_Len - 1;
1881 M : constant Natural := Max / 5;
1882
1883 begin
1884 Put (File, Title);
1885 New_Line (File);
1886
1887 -- Edges valid range is 1 .. Edge_Len - 1
1888
1889 for J in F1 .. L1 loop
1890 E := Get_Edges (J);
1891 Put (File, Image (J, M), F1, L1, J, 1, 4, 1);
1892 Put (File, Image (E.X, M), F1, L1, J, 1, 4, 2);
1893 Put (File, Image (E.Y, M), F1, L1, J, 1, 4, 3);
1894 Put (File, Image (E.Key, M), F1, L1, J, 1, 4, 4);
1895 end loop;
1896 end Put_Edges;
1897
1898 ----------------------
1899 -- Put_Initial_Keys --
1900 ----------------------
1901
1902 procedure Put_Initial_Keys (File : File_Descriptor; Title : String) is
1903 F1 : constant Natural := 0;
1904 L1 : constant Natural := NK - 1;
1905 M : constant Natural := Max / 5;
1906 K : Key_Type;
1907
1908 begin
1909 Put (File, Title);
1910 New_Line (File);
1911
1912 for J in F1 .. L1 loop
1913 K := Get_Key (J);
1914 Put (File, Image (J, M), F1, L1, J, 1, 3, 1);
1915 Put (File, Image (K.Edge, M), F1, L1, J, 1, 3, 2);
1916 Put (File, Trim_Trailing_Nuls (WT.Table (Initial (J)).all),
1917 F1, L1, J, 1, 3, 3);
1918 end loop;
1919 end Put_Initial_Keys;
1920
1921 --------------------
1922 -- Put_Int_Matrix --
1923 --------------------
1924
1925 procedure Put_Int_Matrix
1926 (File : File_Descriptor;
1927 Title : String;
1928 Table : Integer;
1929 Len_1 : Natural;
1930 Len_2 : Natural)
1931 is
1932 F1 : constant Integer := 0;
1933 L1 : constant Integer := Len_1 - 1;
1934 F2 : constant Integer := 0;
1935 L2 : constant Integer := Len_2 - 1;
1936 Ix : Natural;
1937
1938 begin
1939 Put (File, Title);
1940 New_Line (File);
1941
1942 if Len_2 = 0 then
1943 for J in F1 .. L1 loop
1944 Ix := IT.Table (Table + J);
1945 Put (File, Image (Ix), 1, 0, 1, F1, L1, J);
1946 end loop;
1947
1948 else
1949 for J in F1 .. L1 loop
1950 for K in F2 .. L2 loop
1951 Ix := IT.Table (Table + J + K * Len_1);
1952 Put (File, Image (Ix), F1, L1, J, F2, L2, K);
1953 end loop;
1954 end loop;
1955 end if;
1956 end Put_Int_Matrix;
1957
1958 --------------------
1959 -- Put_Int_Vector --
1960 --------------------
1961
1962 procedure Put_Int_Vector
1963 (File : File_Descriptor;
1964 Title : String;
1965 Vector : Integer;
1966 Length : Natural)
1967 is
1968 F2 : constant Natural := 0;
1969 L2 : constant Natural := Length - 1;
1970
1971 begin
1972 Put (File, Title);
1973 New_Line (File);
1974
1975 for J in F2 .. L2 loop
1976 Put (File, Image (IT.Table (Vector + J)), 1, 0, 1, F2, L2, J);
1977 end loop;
1978 end Put_Int_Vector;
1979
1980 ----------------------
1981 -- Put_Reduced_Keys --
1982 ----------------------
1983
1984 procedure Put_Reduced_Keys (File : File_Descriptor; Title : String) is
1985 F1 : constant Natural := 0;
1986 L1 : constant Natural := NK - 1;
1987 M : constant Natural := Max / 5;
1988 K : Key_Type;
1989
1990 begin
1991 Put (File, Title);
1992 New_Line (File);
1993
1994 for J in F1 .. L1 loop
1995 K := Get_Key (J);
1996 Put (File, Image (J, M), F1, L1, J, 1, 3, 1);
1997 Put (File, Image (K.Edge, M), F1, L1, J, 1, 3, 2);
1998 Put (File, Trim_Trailing_Nuls (WT.Table (Reduced (J)).all),
1999 F1, L1, J, 1, 3, 3);
2000 end loop;
2001 end Put_Reduced_Keys;
2002
2003 -----------------------
2004 -- Put_Used_Char_Set --
2005 -----------------------
2006
2007 procedure Put_Used_Char_Set (File : File_Descriptor; Title : String) is
2008 F : constant Natural := Character'Pos (Character'First);
2009 L : constant Natural := Character'Pos (Character'Last);
2010
2011 begin
2012 Put (File, Title);
2013 New_Line (File);
2014
2015 for J in Character'Range loop
2016 Put
2017 (File, Image (Get_Used_Char (J)), 1, 0, 1, F, L, Character'Pos (J));
2018 end loop;
2019 end Put_Used_Char_Set;
2020
2021 ----------------------
2022 -- Put_Vertex_Table --
2023 ----------------------
2024
2025 procedure Put_Vertex_Table (File : File_Descriptor; Title : String) is
2026 F1 : constant Natural := 0;
2027 L1 : constant Natural := NV - 1;
2028 M : constant Natural := Max / 4;
2029 V : Vertex_Type;
2030
2031 begin
2032 Put (File, Title);
2033 New_Line (File);
2034
2035 for J in F1 .. L1 loop
2036 V := Get_Vertices (J);
2037 Put (File, Image (J, M), F1, L1, J, 1, 3, 1);
2038 Put (File, Image (V.First, M), F1, L1, J, 1, 3, 2);
2039 Put (File, Image (V.Last, M), F1, L1, J, 1, 3, 3);
2040 end loop;
2041 end Put_Vertex_Table;
2042
2043 ------------
2044 -- Random --
2045 ------------
2046
2047 procedure Random (Seed : in out Natural) is
2048
2049 -- Park & Miller Standard Minimal using Schrage's algorithm to avoid
2050 -- overflow: Xn+1 = 16807 * Xn mod (2 ** 31 - 1)
2051
2052 R : Natural;
2053 Q : Natural;
2054 X : Integer;
2055
2056 begin
2057 R := Seed mod 127773;
2058 Q := Seed / 127773;
2059 X := 16807 * R - 2836 * Q;
2060
2061 Seed := (if X < 0 then X + 2147483647 else X);
2062 end Random;
2063
2064 -------------
2065 -- Reduced --
2066 -------------
2067
2068 function Reduced (K : Key_Id) return Word_Id is
2069 begin
2070 return K + NK + 1;
2071 end Reduced;
2072
2073 -----------------
2074 -- Resize_Word --
2075 -----------------
2076
2077 procedure Resize_Word (W : in out Word_Type; Len : Natural) is
2078 S1 : constant String := W.all;
2079 S2 : String (1 .. Len) := (others => ASCII.NUL);
2080 L : constant Natural := S1'Length;
2081 begin
2082 if L /= Len then
2083 Free_Word (W);
2084 S2 (1 .. L) := S1;
2085 W := New_Word (S2);
2086 end if;
2087 end Resize_Word;
2088
2089 --------------------------
2090 -- Select_Char_Position --
2091 --------------------------
2092
2093 procedure Select_Char_Position is
2094
2095 type Vertex_Table_Type is array (Natural range <>) of Vertex_Type;
2096
2097 procedure Build_Identical_Keys_Sets
2098 (Table : in out Vertex_Table_Type;
2099 Last : in out Natural;
2100 Pos : Natural);
2101 -- Build a list of keys subsets that are identical with the current
2102 -- position selection plus Pos. Once this routine is called, reduced
2103 -- words are sorted by subsets and each item (First, Last) in Sets
2104 -- defines the range of identical keys.
2105 -- Need comment saying exactly what Last is ???
2106
2107 function Count_Different_Keys
2108 (Table : Vertex_Table_Type;
2109 Last : Natural;
2110 Pos : Natural) return Natural;
2111 -- For each subset in Sets, count the number of different keys if we add
2112 -- Pos to the current position selection.
2113
2114 Sel_Position : IT.Table_Type (1 .. Max_Key_Len);
2115 Last_Sel_Pos : Natural := 0;
2116 Max_Sel_Pos : Natural := 0;
2117
2118 -------------------------------
2119 -- Build_Identical_Keys_Sets --
2120 -------------------------------
2121
2122 procedure Build_Identical_Keys_Sets
2123 (Table : in out Vertex_Table_Type;
2124 Last : in out Natural;
2125 Pos : Natural)
2126 is
2127 S : constant Vertex_Table_Type := Table (Table'First .. Last);
2128 C : constant Natural := Pos;
2129 -- Shortcuts (why are these not renames ???)
2130
2131 F : Integer;
2132 L : Integer;
2133 -- First and last words of a subset
2134
2135 Offset : Natural;
2136 -- GNAT.Heap_Sort assumes that the first array index is 1. Offset
2137 -- defines the translation to operate.
2138
2139 function Lt (L, R : Natural) return Boolean;
2140 procedure Move (From : Natural; To : Natural);
2141 -- Subprograms needed by GNAT.Heap_Sort_G
2142
2143 --------
2144 -- Lt --
2145 --------
2146
2147 function Lt (L, R : Natural) return Boolean is
2148 C : constant Natural := Pos;
2149 Left : Natural;
2150 Right : Natural;
2151
2152 begin
2153 if L = 0 then
2154 Left := NK;
2155 Right := Offset + R;
2156 elsif R = 0 then
2157 Left := Offset + L;
2158 Right := NK;
2159 else
2160 Left := Offset + L;
2161 Right := Offset + R;
2162 end if;
2163
2164 return WT.Table (Left)(C) < WT.Table (Right)(C);
2165 end Lt;
2166
2167 ----------
2168 -- Move --
2169 ----------
2170
2171 procedure Move (From : Natural; To : Natural) is
2172 Target, Source : Natural;
2173
2174 begin
2175 if From = 0 then
2176 Source := NK;
2177 Target := Offset + To;
2178 elsif To = 0 then
2179 Source := Offset + From;
2180 Target := NK;
2181 else
2182 Source := Offset + From;
2183 Target := Offset + To;
2184 end if;
2185
2186 WT.Table (Target) := WT.Table (Source);
2187 WT.Table (Source) := null;
2188 end Move;
2189
2190 package Sorting is new GNAT.Heap_Sort_G (Move, Lt);
2191
2192 -- Start of processing for Build_Identical_Key_Sets
2193
2194 begin
2195 Last := 0;
2196
2197 -- For each subset in S, extract the new subsets we have by adding C
2198 -- in the position selection.
2199
2200 for J in S'Range loop
2201 if S (J).First = S (J).Last then
2202 F := S (J).First;
2203 L := S (J).Last;
2204 Last := Last + 1;
2205 Table (Last) := (F, L);
2206
2207 else
2208 Offset := Reduced (S (J).First) - 1;
2209 Sorting.Sort (S (J).Last - S (J).First + 1);
2210
2211 F := S (J).First;
2212 L := F;
2213 for N in S (J).First .. S (J).Last loop
2214
2215 -- For the last item, close the last subset
2216
2217 if N = S (J).Last then
2218 Last := Last + 1;
2219 Table (Last) := (F, N);
2220
2221 -- Two contiguous words are identical when they have the
2222 -- same Cth character.
2223
2224 elsif WT.Table (Reduced (N))(C) =
2225 WT.Table (Reduced (N + 1))(C)
2226 then
2227 L := N + 1;
2228
2229 -- Find a new subset of identical keys. Store the current
2230 -- one and create a new subset.
2231
2232 else
2233 Last := Last + 1;
2234 Table (Last) := (F, L);
2235 F := N + 1;
2236 L := F;
2237 end if;
2238 end loop;
2239 end if;
2240 end loop;
2241 end Build_Identical_Keys_Sets;
2242
2243 --------------------------
2244 -- Count_Different_Keys --
2245 --------------------------
2246
2247 function Count_Different_Keys
2248 (Table : Vertex_Table_Type;
2249 Last : Natural;
2250 Pos : Natural) return Natural
2251 is
2252 N : array (Character) of Natural;
2253 C : Character;
2254 T : Natural := 0;
2255
2256 begin
2257 -- For each subset, count the number of words that are still
2258 -- different when we include Pos in the position selection. Only
2259 -- focus on this position as the other positions already produce
2260 -- identical keys.
2261
2262 for S in 1 .. Last loop
2263
2264 -- Count the occurrences of the different characters
2265
2266 N := (others => 0);
2267 for K in Table (S).First .. Table (S).Last loop
2268 C := WT.Table (Reduced (K))(Pos);
2269 N (C) := N (C) + 1;
2270 end loop;
2271
2272 -- Update the number of different keys. Each character used
2273 -- denotes a different key.
2274
2275 for J in N'Range loop
2276 if N (J) > 0 then
2277 T := T + 1;
2278 end if;
2279 end loop;
2280 end loop;
2281
2282 return T;
2283 end Count_Different_Keys;
2284
2285 -- Start of processing for Select_Char_Position
2286
2287 begin
2288 -- Initialize the reduced words set
2289
2290 for K in 0 .. NK - 1 loop
2291 WT.Table (Reduced (K)) := New_Word (WT.Table (Initial (K)).all);
2292 end loop;
2293
2294 declare
2295 Differences : Natural;
2296 Max_Differences : Natural := 0;
2297 Old_Differences : Natural;
2298 Max_Diff_Sel_Pos : Natural := 0; -- init to kill warning
2299 Max_Diff_Sel_Pos_Idx : Natural := 0; -- init to kill warning
2300 Same_Keys_Sets_Table : Vertex_Table_Type (1 .. NK);
2301 Same_Keys_Sets_Last : Natural := 1;
2302
2303 begin
2304 for C in Sel_Position'Range loop
2305 Sel_Position (C) := C;
2306 end loop;
2307
2308 Same_Keys_Sets_Table (1) := (0, NK - 1);
2309
2310 loop
2311 -- Preserve maximum number of different keys and check later on
2312 -- that this value is strictly incrementing. Otherwise, it means
2313 -- that two keys are strictly identical.
2314
2315 Old_Differences := Max_Differences;
2316
2317 -- The first position should not exceed the minimum key length.
2318 -- Otherwise, we may end up with an empty word once reduced.
2319
2320 Max_Sel_Pos :=
2321 (if Last_Sel_Pos = 0 then Min_Key_Len else Max_Key_Len);
2322
2323 -- Find which position increases more the number of differences
2324
2325 for J in Last_Sel_Pos + 1 .. Max_Sel_Pos loop
2326 Differences := Count_Different_Keys
2327 (Same_Keys_Sets_Table,
2328 Same_Keys_Sets_Last,
2329 Sel_Position (J));
2330
2331 if Verbose then
2332 Put (Output,
2333 "Selecting position" & Sel_Position (J)'Img &
2334 " results in" & Differences'Img &
2335 " differences");
2336 New_Line (Output);
2337 end if;
2338
2339 if Differences > Max_Differences then
2340 Max_Differences := Differences;
2341 Max_Diff_Sel_Pos := Sel_Position (J);
2342 Max_Diff_Sel_Pos_Idx := J;
2343 end if;
2344 end loop;
2345
2346 if Old_Differences = Max_Differences then
2347 raise Program_Error with "some keys are identical";
2348 end if;
2349
2350 -- Insert selected position and sort Sel_Position table
2351
2352 Last_Sel_Pos := Last_Sel_Pos + 1;
2353 Sel_Position (Last_Sel_Pos + 1 .. Max_Diff_Sel_Pos_Idx) :=
2354 Sel_Position (Last_Sel_Pos .. Max_Diff_Sel_Pos_Idx - 1);
2355 Sel_Position (Last_Sel_Pos) := Max_Diff_Sel_Pos;
2356
2357 for P in 1 .. Last_Sel_Pos - 1 loop
2358 if Max_Diff_Sel_Pos < Sel_Position (P) then
2359 Sel_Position (P + 1 .. Last_Sel_Pos) :=
2360 Sel_Position (P .. Last_Sel_Pos - 1);
2361 Sel_Position (P) := Max_Diff_Sel_Pos;
2362 exit;
2363 end if;
2364 end loop;
2365
2366 exit when Max_Differences = NK;
2367
2368 Build_Identical_Keys_Sets
2369 (Same_Keys_Sets_Table,
2370 Same_Keys_Sets_Last,
2371 Max_Diff_Sel_Pos);
2372
2373 if Verbose then
2374 Put (Output,
2375 "Selecting position" & Max_Diff_Sel_Pos'Img &
2376 " results in" & Max_Differences'Img &
2377 " differences");
2378 New_Line (Output);
2379 Put (Output, "--");
2380 New_Line (Output);
2381 for J in 1 .. Same_Keys_Sets_Last loop
2382 for K in
2383 Same_Keys_Sets_Table (J).First ..
2384 Same_Keys_Sets_Table (J).Last
2385 loop
2386 Put (Output,
2387 Trim_Trailing_Nuls (WT.Table (Reduced (K)).all));
2388 New_Line (Output);
2389 end loop;
2390 Put (Output, "--");
2391 New_Line (Output);
2392 end loop;
2393 end if;
2394 end loop;
2395 end;
2396
2397 Char_Pos_Set_Len := Last_Sel_Pos;
2398 Char_Pos_Set := Allocate (Char_Pos_Set_Len);
2399
2400 for C in 1 .. Last_Sel_Pos loop
2401 Set_Char_Pos (C - 1, Sel_Position (C));
2402 end loop;
2403 end Select_Char_Position;
2404
2405 --------------------------
2406 -- Select_Character_Set --
2407 --------------------------
2408
2409 procedure Select_Character_Set is
2410 Last : Natural := 0;
2411 Used : array (Character) of Boolean := (others => False);
2412 Char : Character;
2413
2414 begin
2415 for J in 0 .. NK - 1 loop
2416 for K in 0 .. Char_Pos_Set_Len - 1 loop
2417 Char := WT.Table (Initial (J))(Get_Char_Pos (K));
2418 exit when Char = ASCII.NUL;
2419 Used (Char) := True;
2420 end loop;
2421 end loop;
2422
2423 Used_Char_Set_Len := 256;
2424 Used_Char_Set := Allocate (Used_Char_Set_Len);
2425
2426 for J in Used'Range loop
2427 if Used (J) then
2428 Set_Used_Char (J, Last);
2429 Last := Last + 1;
2430 else
2431 Set_Used_Char (J, 0);
2432 end if;
2433 end loop;
2434 end Select_Character_Set;
2435
2436 ------------------
2437 -- Set_Char_Pos --
2438 ------------------
2439
2440 procedure Set_Char_Pos (P : Natural; Item : Natural) is
2441 N : constant Natural := Char_Pos_Set + P;
2442 begin
2443 IT.Table (N) := Item;
2444 end Set_Char_Pos;
2445
2446 ---------------
2447 -- Set_Edges --
2448 ---------------
2449
2450 procedure Set_Edges (F : Natural; Item : Edge_Type) is
2451 N : constant Natural := Edges + (F * Edge_Size);
2452 begin
2453 IT.Table (N) := Item.X;
2454 IT.Table (N + 1) := Item.Y;
2455 IT.Table (N + 2) := Item.Key;
2456 end Set_Edges;
2457
2458 ---------------
2459 -- Set_Graph --
2460 ---------------
2461
2462 procedure Set_Graph (N : Natural; Item : Integer) is
2463 begin
2464 IT.Table (G + N) := Item;
2465 end Set_Graph;
2466
2467 -------------
2468 -- Set_Key --
2469 -------------
2470
2471 procedure Set_Key (N : Key_Id; Item : Key_Type) is
2472 begin
2473 IT.Table (Keys + N) := Item.Edge;
2474 end Set_Key;
2475
2476 ---------------
2477 -- Set_Table --
2478 ---------------
2479
2480 procedure Set_Table (T : Integer; X, Y : Natural; Item : Natural) is
2481 N : constant Natural := T + ((Y * T1_Len) + X);
2482 begin
2483 IT.Table (N) := Item;
2484 end Set_Table;
2485
2486 -------------------
2487 -- Set_Used_Char --
2488 -------------------
2489
2490 procedure Set_Used_Char (C : Character; Item : Natural) is
2491 N : constant Natural := Used_Char_Set + Character'Pos (C);
2492 begin
2493 IT.Table (N) := Item;
2494 end Set_Used_Char;
2495
2496 ------------------
2497 -- Set_Vertices --
2498 ------------------
2499
2500 procedure Set_Vertices (F : Natural; Item : Vertex_Type) is
2501 N : constant Natural := Vertices + (F * Vertex_Size);
2502 begin
2503 IT.Table (N) := Item.First;
2504 IT.Table (N + 1) := Item.Last;
2505 end Set_Vertices;
2506
2507 ---------
2508 -- Sum --
2509 ---------
2510
2511 function Sum
2512 (Word : Word_Type;
2513 Table : Table_Id;
2514 Opt : Optimization) return Natural
2515 is
2516 S : Natural := 0;
2517 R : Natural;
2518
2519 begin
2520 case Opt is
2521 when CPU_Time =>
2522 for J in 0 .. T1_Len - 1 loop
2523 exit when Word (J + 1) = ASCII.NUL;
2524 R := Get_Table (Table, J, Get_Used_Char (Word (J + 1)));
2525 S := (S + R) mod NV;
2526 end loop;
2527
2528 when Memory_Space =>
2529 for J in 0 .. T1_Len - 1 loop
2530 exit when Word (J + 1) = ASCII.NUL;
2531 R := Get_Table (Table, J, 0);
2532 S := (S + R * Character'Pos (Word (J + 1))) mod NV;
2533 end loop;
2534 end case;
2535
2536 return S;
2537 end Sum;
2538
2539 ------------------------
2540 -- Trim_Trailing_Nuls --
2541 ------------------------
2542
2543 function Trim_Trailing_Nuls (Str : String) return String is
2544 begin
2545 for J in reverse Str'Range loop
2546 if Str (J) /= ASCII.NUL then
2547 return Str (Str'First .. J);
2548 end if;
2549 end loop;
2550
2551 return Str;
2552 end Trim_Trailing_Nuls;
2553
2554 ---------------
2555 -- Type_Size --
2556 ---------------
2557
2558 function Type_Size (L : Natural) return Natural is
2559 begin
2560 if L <= 2 ** 8 then
2561 return 8;
2562 elsif L <= 2 ** 16 then
2563 return 16;
2564 else
2565 return 32;
2566 end if;
2567 end Type_Size;
2568
2569 -----------
2570 -- Value --
2571 -----------
2572
2573 function Value
2574 (Name : Table_Name;
2575 J : Natural;
2576 K : Natural := 0) return Natural
2577 is
2578 begin
2579 case Name is
2580 when Character_Position =>
2581 return Get_Char_Pos (J);
2582
2583 when Used_Character_Set =>
2584 return Get_Used_Char (Character'Val (J));
2585
2586 when Function_Table_1 =>
2587 return Get_Table (T1, J, K);
2588
2589 when Function_Table_2 =>
2590 return Get_Table (T2, J, K);
2591
2592 when Graph_Table =>
2593 return Get_Graph (J);
2594
2595 end case;
2596 end Value;
2597
2598 end GNAT.Perfect_Hash_Generators;