fixing pr42337
[official-gcc.git] / gcc / ada / g-pehage.adb
blobe96b9cc0c58603ba3d38af7d92b90a94df56436d
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-2009, 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 2, 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. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
21 -- --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
28 -- --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
31 -- --
32 ------------------------------------------------------------------------------
34 with Ada.IO_Exceptions; use Ada.IO_Exceptions;
36 with GNAT.Heap_Sort_G;
37 with GNAT.OS_Lib; use GNAT.OS_Lib;
38 with GNAT.Table;
40 package body GNAT.Perfect_Hash_Generators is
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
47 -- This minimal perfect hash function generator is based on random graphs
48 -- and produces a hash function of the form:
50 -- h (w) = (g (f1 (w)) + g (f2 (w))) mod m
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.
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.
61 -- a) fk (w) = sum (for i in 1 .. length (w)) (Tk (i, w (i))) mod n
63 -- size (Tk) = max (for w in W) (length (w)) * size (used char set)
65 -- b) fk (w) = sum (for i in 1 .. length (w)) (Tk (i) * w (i)) mod n
67 -- size (Tk) = max (for w in W) (length (w)) but the table lookups are
68 -- replaced by multiplications.
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).
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.
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.
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.
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;
101 No_Vertex : constant Vertex_Id := -1;
102 No_Edge : constant Edge_Id := -1;
103 No_Table : constant Table_Id := -1;
105 type Word_Type is new String_Access;
106 procedure Free_Word (W : in out Word_Type);
107 function New_Word (S : String) return Word_Type;
109 procedure Resize_Word (W : in out Word_Type; Len : Natural);
110 -- Resize string W to have a length Len
112 type Key_Type is record
113 Edge : Edge_Id;
114 end record;
115 -- A key corresponds to an edge in the algorithm graph
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.
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.
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.
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.
146 Output : File_Descriptor renames GNAT.OS_Lib.Standout;
147 -- Shortcuts
149 EOL : constant Character := ASCII.LF;
151 Max : constant := 78;
152 Last : Natural := 0;
153 Line : String (1 .. Max);
154 -- Use this line to provide buffered IO
156 procedure Add (C : Character);
157 procedure Add (S : String);
158 -- Add a character or a string in Line and update Last
160 procedure Put
161 (F : File_Descriptor;
162 S : String;
163 F1 : Natural;
164 L1 : Natural;
165 C1 : Natural;
166 F2 : Natural;
167 L2 : Natural;
168 C2 : Natural);
169 -- Write string S into file F as a element of an array of one or two
170 -- dimensions. Fk (resp. Lk and Ck) indicates the first (resp last and
171 -- current) index in the k-th dimension. If F1 = L1 the array is considered
172 -- as a one dimension array. This dimension is described by F2 and L2. This
173 -- routine takes care of all the parenthesis, spaces and commas needed to
174 -- format correctly the array. Moreover, the array is well indented and is
175 -- wrapped to fit in a 80 col line. When the line is full, the routine
176 -- writes it into file F. When the array is completed, the routine adds
177 -- semi-colon and writes the line into file F.
179 procedure New_Line (File : File_Descriptor);
180 -- Simulate Ada.Text_IO.New_Line with GNAT.OS_Lib
182 procedure Put (File : File_Descriptor; Str : String);
183 -- Simulate Ada.Text_IO.Put with GNAT.OS_Lib
185 procedure Put_Used_Char_Set (File : File_Descriptor; Title : String);
186 -- Output a title and a used character set
188 procedure Put_Int_Vector
189 (File : File_Descriptor;
190 Title : String;
191 Vector : Integer;
192 Length : Natural);
193 -- Output a title and a vector
195 procedure Put_Int_Matrix
196 (File : File_Descriptor;
197 Title : String;
198 Table : Table_Id;
199 Len_1 : Natural;
200 Len_2 : Natural);
201 -- Output a title and a matrix. When the matrix has only one non-empty
202 -- dimension (Len_2 = 0), output a vector.
204 procedure Put_Edges (File : File_Descriptor; Title : String);
205 -- Output a title and an edge table
207 procedure Put_Initial_Keys (File : File_Descriptor; Title : String);
208 -- Output a title and a key table
210 procedure Put_Reduced_Keys (File : File_Descriptor; Title : String);
211 -- Output a title and a key table
213 procedure Put_Vertex_Table (File : File_Descriptor; Title : String);
214 -- Output a title and a vertex table
216 ----------------------------------
217 -- Character Position Selection --
218 ----------------------------------
220 -- We reduce the maximum key size by selecting representative positions
221 -- in these keys. We build a matrix with one word per line. We fill the
222 -- remaining space of a line with ASCII.NUL. The heuristic selects the
223 -- position that induces the minimum number of collisions. If there are
224 -- collisions, select another position on the reduced key set responsible
225 -- of the collisions. Apply the heuristic until there is no more collision.
227 procedure Apply_Position_Selection;
228 -- Apply Position selection and build the reduced key table
230 procedure Parse_Position_Selection (Argument : String);
231 -- Parse Argument and compute the position set. Argument is list of
232 -- substrings separated by commas. Each substring represents a position
233 -- or a range of positions (like x-y).
235 procedure Select_Character_Set;
236 -- Define an optimized used character set like Character'Pos in order not
237 -- to allocate tables of 256 entries.
239 procedure Select_Char_Position;
240 -- Find a min char position set in order to reduce the max key length. The
241 -- heuristic selects the position that induces the minimum number of
242 -- collisions. If there are collisions, select another position on the
243 -- reduced key set responsible of the collisions. Apply the heuristic until
244 -- there is no collision.
246 -----------------------------
247 -- Random Graph Generation --
248 -----------------------------
250 procedure Random (Seed : in out Natural);
251 -- Simulate Ada.Discrete_Numerics.Random
253 procedure Generate_Mapping_Table
254 (Tab : Table_Id;
255 L1 : Natural;
256 L2 : Natural;
257 Seed : in out Natural);
258 -- Random generation of the tables below. T is already allocated
260 procedure Generate_Mapping_Tables
261 (Opt : Optimization;
262 Seed : in out Natural);
263 -- Generate the mapping tables T1 and T2. They are used to define fk (w) =
264 -- sum (for i in 1 .. length (w)) (Tk (i, w (i))) mod n. Keys, NK and Chars
265 -- are used to compute the matrix size.
267 ---------------------------
268 -- Algorithm Computation --
269 ---------------------------
271 procedure Compute_Edges_And_Vertices (Opt : Optimization);
272 -- Compute the edge and vertex tables. These are empty when a self loop is
273 -- detected (f1 (w) = f2 (w)). The edge table is sorted by X value and then
274 -- Y value. Keys is the key table and NK the number of keys. Chars is the
275 -- set of characters really used in Keys. NV is the number of vertices
276 -- recommended by the algorithm. T1 and T2 are the mapping tables needed to
277 -- compute f1 (w) and f2 (w).
279 function Acyclic return Boolean;
280 -- Return True when the graph is acyclic. Vertices is the current vertex
281 -- table and Edges the current edge table.
283 procedure Assign_Values_To_Vertices;
284 -- Execute the assignment step of the algorithm. Keys is the current key
285 -- table. Vertices and Edges represent the random graph. G is the result of
286 -- the assignment step such that:
287 -- h (w) = (g (f1 (w)) + g (f2 (w))) mod m
289 function Sum
290 (Word : Word_Type;
291 Table : Table_Id;
292 Opt : Optimization) return Natural;
293 -- For an optimization of CPU_Time return
294 -- fk (w) = sum (for i in 1 .. length (w)) (Tk (i, w (i))) mod n
295 -- For an optimization of Memory_Space return
296 -- fk (w) = sum (for i in 1 .. length (w)) (Tk (i) * w (i)) mod n
297 -- Here NV = n
299 -------------------------------
300 -- Internal Table Management --
301 -------------------------------
303 function Allocate (N : Natural; S : Natural := 1) return Table_Id;
304 -- Allocate N * S ints from IT table
306 ----------
307 -- Keys --
308 ----------
310 Keys : Table_Id := No_Table;
311 NK : Natural := 0;
312 -- NK : Number of Keys
314 function Initial (K : Key_Id) return Word_Id;
315 pragma Inline (Initial);
317 function Reduced (K : Key_Id) return Word_Id;
318 pragma Inline (Reduced);
320 function Get_Key (N : Key_Id) return Key_Type;
321 procedure Set_Key (N : Key_Id; Item : Key_Type);
322 -- Get or Set Nth element of Keys table
324 ------------------
325 -- Char_Pos_Set --
326 ------------------
328 Char_Pos_Set : Table_Id := No_Table;
329 Char_Pos_Set_Len : Natural;
330 -- Character Selected Position Set
332 function Get_Char_Pos (P : Natural) return Natural;
333 procedure Set_Char_Pos (P : Natural; Item : Natural);
334 -- Get or Set the string position of the Pth selected character
336 -------------------
337 -- Used_Char_Set --
338 -------------------
340 Used_Char_Set : Table_Id := No_Table;
341 Used_Char_Set_Len : Natural;
342 -- Used Character Set : Define a new character mapping. When all the
343 -- characters are not present in the keys, in order to reduce the size
344 -- of some tables, we redefine the character mapping.
346 function Get_Used_Char (C : Character) return Natural;
347 procedure Set_Used_Char (C : Character; Item : Natural);
349 ------------
350 -- Tables --
351 ------------
353 T1 : Table_Id := No_Table;
354 T2 : Table_Id := No_Table;
355 T1_Len : Natural;
356 T2_Len : Natural;
357 -- T1 : Values table to compute F1
358 -- T2 : Values table to compute F2
360 function Get_Table (T : Integer; X, Y : Natural) return Natural;
361 procedure Set_Table (T : Integer; X, Y : Natural; Item : Natural);
363 -----------
364 -- Graph --
365 -----------
367 G : Table_Id := No_Table;
368 G_Len : Natural;
369 -- Values table to compute G
371 NT : Natural := Default_Tries;
372 -- Number of tries running the algorithm before raising an error
374 function Get_Graph (N : Natural) return Integer;
375 procedure Set_Graph (N : Natural; Item : Integer);
376 -- Get or Set Nth element of graph
378 -----------
379 -- Edges --
380 -----------
382 Edge_Size : constant := 3;
383 Edges : Table_Id := No_Table;
384 Edges_Len : Natural;
385 -- Edges : Edge table of the random graph G
387 function Get_Edges (F : Natural) return Edge_Type;
388 procedure Set_Edges (F : Natural; Item : Edge_Type);
390 --------------
391 -- Vertices --
392 --------------
394 Vertex_Size : constant := 2;
396 Vertices : Table_Id := No_Table;
397 -- Vertex table of the random graph G
399 NV : Natural;
400 -- Number of Vertices
402 function Get_Vertices (F : Natural) return Vertex_Type;
403 procedure Set_Vertices (F : Natural; Item : Vertex_Type);
404 -- Comments needed ???
406 K2V : Float;
407 -- Ratio between Keys and Vertices (parameter of Czech's algorithm)
409 Opt : Optimization;
410 -- Optimization mode (memory vs CPU)
412 Max_Key_Len : Natural := 0;
413 Min_Key_Len : Natural := 0;
414 -- Maximum and minimum of all the word length
416 S : Natural;
417 -- Seed
419 function Type_Size (L : Natural) return Natural;
420 -- Given the last L of an unsigned integer type T, return its size
422 -------------
423 -- Acyclic --
424 -------------
426 function Acyclic return Boolean is
427 Marks : array (0 .. NV - 1) of Vertex_Id := (others => No_Vertex);
429 function Traverse (Edge : Edge_Id; Mark : Vertex_Id) return Boolean;
430 -- Propagate Mark from X to Y. X is already marked. Mark Y and propagate
431 -- it to the edges of Y except the one representing the same key. Return
432 -- False when Y is marked with Mark.
434 --------------
435 -- Traverse --
436 --------------
438 function Traverse (Edge : Edge_Id; Mark : Vertex_Id) return Boolean is
439 E : constant Edge_Type := Get_Edges (Edge);
440 K : constant Key_Id := E.Key;
441 Y : constant Vertex_Id := E.Y;
442 M : constant Vertex_Id := Marks (E.Y);
443 V : Vertex_Type;
445 begin
446 if M = Mark then
447 return False;
449 elsif M = No_Vertex then
450 Marks (Y) := Mark;
451 V := Get_Vertices (Y);
453 for J in V.First .. V.Last loop
455 -- Do not propagate to the edge representing the same key
457 if Get_Edges (J).Key /= K
458 and then not Traverse (J, Mark)
459 then
460 return False;
461 end if;
462 end loop;
463 end if;
465 return True;
466 end Traverse;
468 Edge : Edge_Type;
470 -- Start of processing for Acyclic
472 begin
473 -- Edges valid range is
475 for J in 1 .. Edges_Len - 1 loop
477 Edge := Get_Edges (J);
479 -- Mark X of E when it has not been already done
481 if Marks (Edge.X) = No_Vertex then
482 Marks (Edge.X) := Edge.X;
483 end if;
485 -- Traverse E when this has not already been done
487 if Marks (Edge.Y) = No_Vertex
488 and then not Traverse (J, Edge.X)
489 then
490 return False;
491 end if;
492 end loop;
494 return True;
495 end Acyclic;
497 ---------
498 -- Add --
499 ---------
501 procedure Add (C : Character) is
502 begin
503 Line (Last + 1) := C;
504 Last := Last + 1;
505 end Add;
507 ---------
508 -- Add --
509 ---------
511 procedure Add (S : String) is
512 Len : constant Natural := S'Length;
513 begin
514 Line (Last + 1 .. Last + Len) := S;
515 Last := Last + Len;
516 end Add;
518 --------------
519 -- Allocate --
520 --------------
522 function Allocate (N : Natural; S : Natural := 1) return Table_Id is
523 L : constant Integer := IT.Last;
524 begin
525 IT.Set_Last (L + N * S);
526 return L + 1;
527 end Allocate;
529 ------------------------------
530 -- Apply_Position_Selection --
531 ------------------------------
533 procedure Apply_Position_Selection is
534 begin
535 for J in 0 .. NK - 1 loop
536 declare
537 IW : constant String := WT.Table (Initial (J)).all;
538 RW : String (1 .. IW'Length) := (others => ASCII.NUL);
539 N : Natural := IW'First - 1;
541 begin
542 -- Select the characters of Word included in the position
543 -- selection.
545 for C in 0 .. Char_Pos_Set_Len - 1 loop
546 exit when IW (Get_Char_Pos (C)) = ASCII.NUL;
547 N := N + 1;
548 RW (N) := IW (Get_Char_Pos (C));
549 end loop;
551 -- Build the new table with the reduced word. Be careful
552 -- to deallocate the old version to avoid memory leaks.
554 Free_Word (WT.Table (Reduced (J)));
555 WT.Table (Reduced (J)) := New_Word (RW);
556 Set_Key (J, (Edge => No_Edge));
557 end;
558 end loop;
559 end Apply_Position_Selection;
561 -------------------------------
562 -- Assign_Values_To_Vertices --
563 -------------------------------
565 procedure Assign_Values_To_Vertices is
566 X : Vertex_Id;
568 procedure Assign (X : Vertex_Id);
569 -- Execute assignment on X's neighbors except the vertex that we are
570 -- coming from which is already assigned.
572 ------------
573 -- Assign --
574 ------------
576 procedure Assign (X : Vertex_Id) is
577 E : Edge_Type;
578 V : constant Vertex_Type := Get_Vertices (X);
580 begin
581 for J in V.First .. V.Last loop
582 E := Get_Edges (J);
584 if Get_Graph (E.Y) = -1 then
585 Set_Graph (E.Y, (E.Key - Get_Graph (X)) mod NK);
586 Assign (E.Y);
587 end if;
588 end loop;
589 end Assign;
591 -- Start of processing for Assign_Values_To_Vertices
593 begin
594 -- Value -1 denotes an uninitialized value as it is supposed to
595 -- be in the range 0 .. NK.
597 if G = No_Table then
598 G_Len := NV;
599 G := Allocate (G_Len, 1);
600 end if;
602 for J in 0 .. G_Len - 1 loop
603 Set_Graph (J, -1);
604 end loop;
606 for K in 0 .. NK - 1 loop
607 X := Get_Edges (Get_Key (K).Edge).X;
609 if Get_Graph (X) = -1 then
610 Set_Graph (X, 0);
611 Assign (X);
612 end if;
613 end loop;
615 for J in 0 .. G_Len - 1 loop
616 if Get_Graph (J) = -1 then
617 Set_Graph (J, 0);
618 end if;
619 end loop;
621 if Verbose then
622 Put_Int_Vector (Output, "Assign Values To Vertices", G, G_Len);
623 end if;
624 end Assign_Values_To_Vertices;
626 -------------
627 -- Compute --
628 -------------
630 procedure Compute (Position : String := Default_Position) is
631 Success : Boolean := False;
633 begin
634 if NK = 0 then
635 raise Program_Error with "keywords set cannot be empty";
636 end if;
638 if Verbose then
639 Put_Initial_Keys (Output, "Initial Key Table");
640 end if;
642 if Position'Length /= 0 then
643 Parse_Position_Selection (Position);
644 else
645 Select_Char_Position;
646 end if;
648 if Verbose then
649 Put_Int_Vector
650 (Output, "Char Position Set", Char_Pos_Set, Char_Pos_Set_Len);
651 end if;
653 Apply_Position_Selection;
655 if Verbose then
656 Put_Reduced_Keys (Output, "Reduced Keys Table");
657 end if;
659 Select_Character_Set;
661 if Verbose then
662 Put_Used_Char_Set (Output, "Character Position Table");
663 end if;
665 -- Perform Czech's algorithm
667 for J in 1 .. NT loop
668 Generate_Mapping_Tables (Opt, S);
669 Compute_Edges_And_Vertices (Opt);
671 -- When graph is not empty (no self-loop from previous operation) and
672 -- not acyclic.
674 if 0 < Edges_Len and then Acyclic then
675 Success := True;
676 exit;
677 end if;
678 end loop;
680 if not Success then
681 raise Too_Many_Tries;
682 end if;
684 Assign_Values_To_Vertices;
685 end Compute;
687 --------------------------------
688 -- Compute_Edges_And_Vertices --
689 --------------------------------
691 procedure Compute_Edges_And_Vertices (Opt : Optimization) is
692 X : Natural;
693 Y : Natural;
694 Key : Key_Type;
695 Edge : Edge_Type;
696 Vertex : Vertex_Type;
697 Not_Acyclic : Boolean := False;
699 procedure Move (From : Natural; To : Natural);
700 function Lt (L, R : Natural) return Boolean;
701 -- Subprograms needed for GNAT.Heap_Sort_G
703 --------
704 -- Lt --
705 --------
707 function Lt (L, R : Natural) return Boolean is
708 EL : constant Edge_Type := Get_Edges (L);
709 ER : constant Edge_Type := Get_Edges (R);
710 begin
711 return EL.X < ER.X or else (EL.X = ER.X and then EL.Y < ER.Y);
712 end Lt;
714 ----------
715 -- Move --
716 ----------
718 procedure Move (From : Natural; To : Natural) is
719 begin
720 Set_Edges (To, Get_Edges (From));
721 end Move;
723 package Sorting is new GNAT.Heap_Sort_G (Move, Lt);
725 -- Start of processing for Compute_Edges_And_Vertices
727 begin
728 -- We store edges from 1 to 2 * NK and leave zero alone in order to use
729 -- GNAT.Heap_Sort_G.
731 Edges_Len := 2 * NK + 1;
733 if Edges = No_Table then
734 Edges := Allocate (Edges_Len, Edge_Size);
735 end if;
737 if Vertices = No_Table then
738 Vertices := Allocate (NV, Vertex_Size);
739 end if;
741 for J in 0 .. NV - 1 loop
742 Set_Vertices (J, (No_Vertex, No_Vertex - 1));
743 end loop;
745 -- For each w, X = f1 (w) and Y = f2 (w)
747 for J in 0 .. NK - 1 loop
748 Key := Get_Key (J);
749 Key.Edge := No_Edge;
750 Set_Key (J, Key);
752 X := Sum (WT.Table (Reduced (J)), T1, Opt);
753 Y := Sum (WT.Table (Reduced (J)), T2, Opt);
755 -- Discard T1 and T2 as soon as we discover a self loop
757 if X = Y then
758 Not_Acyclic := True;
759 exit;
760 end if;
762 -- We store (X, Y) and (Y, X) to ease assignment step
764 Set_Edges (2 * J + 1, (X, Y, J));
765 Set_Edges (2 * J + 2, (Y, X, J));
766 end loop;
768 -- Return an empty graph when self loop detected
770 if Not_Acyclic then
771 Edges_Len := 0;
773 else
774 if Verbose then
775 Put_Edges (Output, "Unsorted Edge Table");
776 Put_Int_Matrix (Output, "Function Table 1", T1,
777 T1_Len, T2_Len);
778 Put_Int_Matrix (Output, "Function Table 2", T2,
779 T1_Len, T2_Len);
780 end if;
782 -- Enforce consistency between edges and keys. Construct Vertices and
783 -- compute the list of neighbors of a vertex First .. Last as Edges
784 -- is sorted by X and then Y. To compute the neighbor list, sort the
785 -- edges.
787 Sorting.Sort (Edges_Len - 1);
789 if Verbose then
790 Put_Edges (Output, "Sorted Edge Table");
791 Put_Int_Matrix (Output, "Function Table 1", T1,
792 T1_Len, T2_Len);
793 Put_Int_Matrix (Output, "Function Table 2", T2,
794 T1_Len, T2_Len);
795 end if;
797 -- Edges valid range is 1 .. 2 * NK
799 for E in 1 .. Edges_Len - 1 loop
800 Edge := Get_Edges (E);
801 Key := Get_Key (Edge.Key);
803 if Key.Edge = No_Edge then
804 Key.Edge := E;
805 Set_Key (Edge.Key, Key);
806 end if;
808 Vertex := Get_Vertices (Edge.X);
810 if Vertex.First = No_Edge then
811 Vertex.First := E;
812 end if;
814 Vertex.Last := E;
815 Set_Vertices (Edge.X, Vertex);
816 end loop;
818 if Verbose then
819 Put_Reduced_Keys (Output, "Key Table");
820 Put_Edges (Output, "Edge Table");
821 Put_Vertex_Table (Output, "Vertex Table");
822 end if;
823 end if;
824 end Compute_Edges_And_Vertices;
826 ------------
827 -- Define --
828 ------------
830 procedure Define
831 (Name : Table_Name;
832 Item_Size : out Natural;
833 Length_1 : out Natural;
834 Length_2 : out Natural)
836 begin
837 case Name is
838 when Character_Position =>
839 Item_Size := 8;
840 Length_1 := Char_Pos_Set_Len;
841 Length_2 := 0;
843 when Used_Character_Set =>
844 Item_Size := 8;
845 Length_1 := 256;
846 Length_2 := 0;
848 when Function_Table_1
849 | Function_Table_2 =>
850 Item_Size := Type_Size (NV);
851 Length_1 := T1_Len;
852 Length_2 := T2_Len;
854 when Graph_Table =>
855 Item_Size := Type_Size (NK);
856 Length_1 := NV;
857 Length_2 := 0;
858 end case;
859 end Define;
861 --------------
862 -- Finalize --
863 --------------
865 procedure Finalize is
866 begin
867 -- Deallocate all the WT components (both initial and reduced
868 -- ones) to avoid memory leaks.
870 for W in 0 .. WT.Last loop
871 Free_Word (WT.Table (W));
872 end loop;
873 WT.Release;
874 IT.Release;
876 -- Reset all variables for next usage
878 Keys := No_Table;
880 Char_Pos_Set := No_Table;
881 Char_Pos_Set_Len := 0;
883 Used_Char_Set := No_Table;
884 Used_Char_Set_Len := 0;
886 T1 := No_Table;
887 T2 := No_Table;
889 T1_Len := 0;
890 T2_Len := 0;
892 G := No_Table;
893 G_Len := 0;
895 Edges := No_Table;
896 Edges_Len := 0;
898 Vertices := No_Table;
899 NV := 0;
901 NK := 0;
902 Max_Key_Len := 0;
903 Min_Key_Len := 0;
904 end Finalize;
906 ---------------
907 -- Free_Word --
908 ---------------
910 procedure Free_Word (W : in out Word_Type) is
911 begin
912 if W /= null then
913 Free (W);
914 end if;
915 end Free_Word;
917 ----------------------------
918 -- Generate_Mapping_Table --
919 ----------------------------
921 procedure Generate_Mapping_Table
922 (Tab : Integer;
923 L1 : Natural;
924 L2 : Natural;
925 Seed : in out Natural)
927 begin
928 for J in 0 .. L1 - 1 loop
929 for K in 0 .. L2 - 1 loop
930 Random (Seed);
931 Set_Table (Tab, J, K, Seed mod NV);
932 end loop;
933 end loop;
934 end Generate_Mapping_Table;
936 -----------------------------
937 -- Generate_Mapping_Tables --
938 -----------------------------
940 procedure Generate_Mapping_Tables
941 (Opt : Optimization;
942 Seed : in out Natural)
944 begin
945 -- If T1 and T2 are already allocated no need to do it twice. Reuse them
946 -- as their size has not changed.
948 if T1 = No_Table and then T2 = No_Table then
949 declare
950 Used_Char_Last : Natural := 0;
951 Used_Char : Natural;
953 begin
954 if Opt = CPU_Time then
955 for P in reverse Character'Range loop
956 Used_Char := Get_Used_Char (P);
957 if Used_Char /= 0 then
958 Used_Char_Last := Used_Char;
959 exit;
960 end if;
961 end loop;
962 end if;
964 T1_Len := Char_Pos_Set_Len;
965 T2_Len := Used_Char_Last + 1;
966 T1 := Allocate (T1_Len * T2_Len);
967 T2 := Allocate (T1_Len * T2_Len);
968 end;
969 end if;
971 Generate_Mapping_Table (T1, T1_Len, T2_Len, Seed);
972 Generate_Mapping_Table (T2, T1_Len, T2_Len, Seed);
974 if Verbose then
975 Put_Used_Char_Set (Output, "Used Character Set");
976 Put_Int_Matrix (Output, "Function Table 1", T1,
977 T1_Len, T2_Len);
978 Put_Int_Matrix (Output, "Function Table 2", T2,
979 T1_Len, T2_Len);
980 end if;
981 end Generate_Mapping_Tables;
983 ------------------
984 -- Get_Char_Pos --
985 ------------------
987 function Get_Char_Pos (P : Natural) return Natural is
988 N : constant Natural := Char_Pos_Set + P;
989 begin
990 return IT.Table (N);
991 end Get_Char_Pos;
993 ---------------
994 -- Get_Edges --
995 ---------------
997 function Get_Edges (F : Natural) return Edge_Type is
998 N : constant Natural := Edges + (F * Edge_Size);
999 E : Edge_Type;
1000 begin
1001 E.X := IT.Table (N);
1002 E.Y := IT.Table (N + 1);
1003 E.Key := IT.Table (N + 2);
1004 return E;
1005 end Get_Edges;
1007 ---------------
1008 -- Get_Graph --
1009 ---------------
1011 function Get_Graph (N : Natural) return Integer is
1012 begin
1013 return IT.Table (G + N);
1014 end Get_Graph;
1016 -------------
1017 -- Get_Key --
1018 -------------
1020 function Get_Key (N : Key_Id) return Key_Type is
1021 K : Key_Type;
1022 begin
1023 K.Edge := IT.Table (Keys + N);
1024 return K;
1025 end Get_Key;
1027 ---------------
1028 -- Get_Table --
1029 ---------------
1031 function Get_Table (T : Integer; X, Y : Natural) return Natural is
1032 N : constant Natural := T + (Y * T1_Len) + X;
1033 begin
1034 return IT.Table (N);
1035 end Get_Table;
1037 -------------------
1038 -- Get_Used_Char --
1039 -------------------
1041 function Get_Used_Char (C : Character) return Natural is
1042 N : constant Natural := Used_Char_Set + Character'Pos (C);
1043 begin
1044 return IT.Table (N);
1045 end Get_Used_Char;
1047 ------------------
1048 -- Get_Vertices --
1049 ------------------
1051 function Get_Vertices (F : Natural) return Vertex_Type is
1052 N : constant Natural := Vertices + (F * Vertex_Size);
1053 V : Vertex_Type;
1054 begin
1055 V.First := IT.Table (N);
1056 V.Last := IT.Table (N + 1);
1057 return V;
1058 end Get_Vertices;
1060 -----------
1061 -- Image --
1062 -----------
1064 function Image (Int : Integer; W : Natural := 0) return String is
1065 B : String (1 .. 32);
1066 L : Natural := 0;
1068 procedure Img (V : Natural);
1069 -- Compute image of V into B, starting at B (L), incrementing L
1071 ---------
1072 -- Img --
1073 ---------
1075 procedure Img (V : Natural) is
1076 begin
1077 if V > 9 then
1078 Img (V / 10);
1079 end if;
1081 L := L + 1;
1082 B (L) := Character'Val ((V mod 10) + Character'Pos ('0'));
1083 end Img;
1085 -- Start of processing for Image
1087 begin
1088 if Int < 0 then
1089 L := L + 1;
1090 B (L) := '-';
1091 Img (-Int);
1092 else
1093 Img (Int);
1094 end if;
1096 return Image (B (1 .. L), W);
1097 end Image;
1099 -----------
1100 -- Image --
1101 -----------
1103 function Image (Str : String; W : Natural := 0) return String is
1104 Len : constant Natural := Str'Length;
1105 Max : Natural := Len;
1107 begin
1108 if Max < W then
1109 Max := W;
1110 end if;
1112 declare
1113 Buf : String (1 .. Max) := (1 .. Max => ' ');
1115 begin
1116 for J in 0 .. Len - 1 loop
1117 Buf (Max - Len + 1 + J) := Str (Str'First + J);
1118 end loop;
1120 return Buf;
1121 end;
1122 end Image;
1124 -------------
1125 -- Initial --
1126 -------------
1128 function Initial (K : Key_Id) return Word_Id is
1129 begin
1130 return K;
1131 end Initial;
1133 ----------------
1134 -- Initialize --
1135 ----------------
1137 procedure Initialize
1138 (Seed : Natural;
1139 K_To_V : Float := Default_K_To_V;
1140 Optim : Optimization := CPU_Time;
1141 Tries : Positive := Default_Tries)
1143 begin
1144 -- Deallocate the part of the table concerning the reduced words.
1145 -- Initial words are already present in the table. We may have reduced
1146 -- words already there because a previous computation failed. We are
1147 -- currently retrying and the reduced words have to be deallocated.
1149 for W in Reduced (0) .. WT.Last loop
1150 Free_Word (WT.Table (W));
1151 end loop;
1153 IT.Init;
1155 -- Initialize of computation variables
1157 Keys := No_Table;
1159 Char_Pos_Set := No_Table;
1160 Char_Pos_Set_Len := 0;
1162 Used_Char_Set := No_Table;
1163 Used_Char_Set_Len := 0;
1165 T1 := No_Table;
1166 T2 := No_Table;
1168 T1_Len := 0;
1169 T2_Len := 0;
1171 G := No_Table;
1172 G_Len := 0;
1174 Edges := No_Table;
1175 Edges_Len := 0;
1177 Vertices := No_Table;
1178 NV := 0;
1180 S := Seed;
1181 K2V := K_To_V;
1182 Opt := Optim;
1183 NT := Tries;
1185 if K2V <= 2.0 then
1186 raise Program_Error with "K to V ratio cannot be lower than 2.0";
1187 end if;
1189 -- Do not accept a value of K2V too close to 2.0 such that once
1190 -- rounded up, NV = 2 * NK because the algorithm would not converge.
1192 NV := Natural (Float (NK) * K2V);
1193 if NV <= 2 * NK then
1194 NV := 2 * NK + 1;
1195 end if;
1197 Keys := Allocate (NK);
1199 -- Resize initial words to have all of them at the same size
1200 -- (so the size of the largest one).
1202 for K in 0 .. NK - 1 loop
1203 Resize_Word (WT.Table (Initial (K)), Max_Key_Len);
1204 end loop;
1206 -- Allocated the table to store the reduced words. As WT is a
1207 -- GNAT.Table (using C memory management), pointers have to be
1208 -- explicitly initialized to null.
1210 WT.Set_Last (Reduced (NK - 1));
1211 for W in 0 .. NK - 1 loop
1212 WT.Table (Reduced (W)) := null;
1213 end loop;
1214 end Initialize;
1216 ------------
1217 -- Insert --
1218 ------------
1220 procedure Insert (Value : String) is
1221 Len : constant Natural := Value'Length;
1223 begin
1224 WT.Set_Last (NK);
1225 WT.Table (NK) := New_Word (Value);
1226 NK := NK + 1;
1228 if Max_Key_Len < Len then
1229 Max_Key_Len := Len;
1230 end if;
1232 if Min_Key_Len = 0 or else Len < Min_Key_Len then
1233 Min_Key_Len := Len;
1234 end if;
1235 end Insert;
1237 --------------
1238 -- New_Line --
1239 --------------
1241 procedure New_Line (File : File_Descriptor) is
1242 begin
1243 if Write (File, EOL'Address, 1) /= 1 then
1244 raise Program_Error;
1245 end if;
1246 end New_Line;
1248 --------------
1249 -- New_Word --
1250 --------------
1252 function New_Word (S : String) return Word_Type is
1253 begin
1254 return new String'(S);
1255 end New_Word;
1257 ------------------------------
1258 -- Parse_Position_Selection --
1259 ------------------------------
1261 procedure Parse_Position_Selection (Argument : String) is
1262 N : Natural := Argument'First;
1263 L : constant Natural := Argument'Last;
1264 M : constant Natural := Max_Key_Len;
1266 T : array (1 .. M) of Boolean := (others => False);
1268 function Parse_Index return Natural;
1269 -- Parse argument starting at index N to find an index
1271 -----------------
1272 -- Parse_Index --
1273 -----------------
1275 function Parse_Index return Natural is
1276 C : Character := Argument (N);
1277 V : Natural := 0;
1279 begin
1280 if C = '$' then
1281 N := N + 1;
1282 return M;
1283 end if;
1285 if C not in '0' .. '9' then
1286 raise Program_Error with "cannot read position argument";
1287 end if;
1289 while C in '0' .. '9' loop
1290 V := V * 10 + (Character'Pos (C) - Character'Pos ('0'));
1291 N := N + 1;
1292 exit when L < N;
1293 C := Argument (N);
1294 end loop;
1296 return V;
1297 end Parse_Index;
1299 -- Start of processing for Parse_Position_Selection
1301 begin
1302 -- Empty specification means all the positions
1304 if L < N then
1305 Char_Pos_Set_Len := M;
1306 Char_Pos_Set := Allocate (Char_Pos_Set_Len);
1308 for C in 0 .. Char_Pos_Set_Len - 1 loop
1309 Set_Char_Pos (C, C + 1);
1310 end loop;
1312 else
1313 loop
1314 declare
1315 First, Last : Natural;
1317 begin
1318 First := Parse_Index;
1319 Last := First;
1321 -- Detect a range
1323 if N <= L and then Argument (N) = '-' then
1324 N := N + 1;
1325 Last := Parse_Index;
1326 end if;
1328 -- Include the positions in the selection
1330 for J in First .. Last loop
1331 T (J) := True;
1332 end loop;
1333 end;
1335 exit when L < N;
1337 if Argument (N) /= ',' then
1338 raise Program_Error with "cannot read position argument";
1339 end if;
1341 N := N + 1;
1342 end loop;
1344 -- Compute position selection length
1346 N := 0;
1347 for J in T'Range loop
1348 if T (J) then
1349 N := N + 1;
1350 end if;
1351 end loop;
1353 -- Fill position selection
1355 Char_Pos_Set_Len := N;
1356 Char_Pos_Set := Allocate (Char_Pos_Set_Len);
1358 N := 0;
1359 for J in T'Range loop
1360 if T (J) then
1361 Set_Char_Pos (N, J);
1362 N := N + 1;
1363 end if;
1364 end loop;
1365 end if;
1366 end Parse_Position_Selection;
1368 -------------
1369 -- Produce --
1370 -------------
1372 procedure Produce (Pkg_Name : String := Default_Pkg_Name) is
1373 File : File_Descriptor;
1375 Status : Boolean;
1376 -- For call to Close
1378 function Array_Img (N, T, R1 : String; R2 : String := "") return String;
1379 -- Return string "N : constant array (R1[, R2]) of T;"
1381 function Range_Img (F, L : Natural; T : String := "") return String;
1382 -- Return string "[T range ]F .. L"
1384 function Type_Img (L : Natural) return String;
1385 -- Return the larger unsigned type T such that T'Last < L
1387 ---------------
1388 -- Array_Img --
1389 ---------------
1391 function Array_Img
1392 (N, T, R1 : String;
1393 R2 : String := "") return String
1395 begin
1396 Last := 0;
1397 Add (" ");
1398 Add (N);
1399 Add (" : constant array (");
1400 Add (R1);
1402 if R2 /= "" then
1403 Add (", ");
1404 Add (R2);
1405 end if;
1407 Add (") of ");
1408 Add (T);
1409 Add (" :=");
1410 return Line (1 .. Last);
1411 end Array_Img;
1413 ---------------
1414 -- Range_Img --
1415 ---------------
1417 function Range_Img (F, L : Natural; T : String := "") return String is
1418 FI : constant String := Image (F);
1419 FL : constant Natural := FI'Length;
1420 LI : constant String := Image (L);
1421 LL : constant Natural := LI'Length;
1422 TL : constant Natural := T'Length;
1423 RI : String (1 .. TL + 7 + FL + 4 + LL);
1424 Len : Natural := 0;
1426 begin
1427 if TL /= 0 then
1428 RI (Len + 1 .. Len + TL) := T;
1429 Len := Len + TL;
1430 RI (Len + 1 .. Len + 7) := " range ";
1431 Len := Len + 7;
1432 end if;
1434 RI (Len + 1 .. Len + FL) := FI;
1435 Len := Len + FL;
1436 RI (Len + 1 .. Len + 4) := " .. ";
1437 Len := Len + 4;
1438 RI (Len + 1 .. Len + LL) := LI;
1439 Len := Len + LL;
1440 return RI (1 .. Len);
1441 end Range_Img;
1443 --------------
1444 -- Type_Img --
1445 --------------
1447 function Type_Img (L : Natural) return String is
1448 S : constant String := Image (Type_Size (L));
1449 U : String := "Unsigned_ ";
1450 N : Natural := 9;
1452 begin
1453 for J in S'Range loop
1454 N := N + 1;
1455 U (N) := S (J);
1456 end loop;
1458 return U (1 .. N);
1459 end Type_Img;
1461 F : Natural;
1462 L : Natural;
1463 P : Natural;
1465 PLen : constant Natural := Pkg_Name'Length;
1466 FName : String (1 .. PLen + 4);
1468 -- Start of processing for Produce
1470 begin
1471 FName (1 .. PLen) := Pkg_Name;
1472 for J in 1 .. PLen loop
1473 if FName (J) in 'A' .. 'Z' then
1474 FName (J) := Character'Val (Character'Pos (FName (J))
1475 - Character'Pos ('A')
1476 + Character'Pos ('a'));
1478 elsif FName (J) = '.' then
1479 FName (J) := '-';
1480 end if;
1481 end loop;
1483 FName (PLen + 1 .. PLen + 4) := ".ads";
1485 File := Create_File (FName, Binary);
1487 Put (File, "package ");
1488 Put (File, Pkg_Name);
1489 Put (File, " is");
1490 New_Line (File);
1491 Put (File, " function Hash (S : String) return Natural;");
1492 New_Line (File);
1493 Put (File, "end ");
1494 Put (File, Pkg_Name);
1495 Put (File, ";");
1496 New_Line (File);
1497 Close (File, Status);
1499 if not Status then
1500 raise Device_Error;
1501 end if;
1503 FName (PLen + 4) := 'b';
1505 File := Create_File (FName, Binary);
1507 Put (File, "with Interfaces; use Interfaces;");
1508 New_Line (File);
1509 New_Line (File);
1510 Put (File, "package body ");
1511 Put (File, Pkg_Name);
1512 Put (File, " is");
1513 New_Line (File);
1514 New_Line (File);
1516 if Opt = CPU_Time then
1517 Put (File, Array_Img ("C", Type_Img (256), "Character"));
1518 New_Line (File);
1520 F := Character'Pos (Character'First);
1521 L := Character'Pos (Character'Last);
1523 for J in Character'Range loop
1524 P := Get_Used_Char (J);
1525 Put (File, Image (P), 1, 0, 1, F, L, Character'Pos (J));
1526 end loop;
1528 New_Line (File);
1529 end if;
1531 F := 0;
1532 L := Char_Pos_Set_Len - 1;
1534 Put (File, Array_Img ("P", "Natural", Range_Img (F, L)));
1535 New_Line (File);
1537 for J in F .. L loop
1538 Put (File, Image (Get_Char_Pos (J)), 1, 0, 1, F, L, J);
1539 end loop;
1541 New_Line (File);
1543 if Opt = CPU_Time then
1544 Put_Int_Matrix
1545 (File,
1546 Array_Img ("T1", Type_Img (NV),
1547 Range_Img (0, T1_Len - 1),
1548 Range_Img (0, T2_Len - 1, Type_Img (256))),
1549 T1, T1_Len, T2_Len);
1551 else
1552 Put_Int_Matrix
1553 (File,
1554 Array_Img ("T1", Type_Img (NV),
1555 Range_Img (0, T1_Len - 1)),
1556 T1, T1_Len, 0);
1557 end if;
1559 New_Line (File);
1561 if Opt = CPU_Time then
1562 Put_Int_Matrix
1563 (File,
1564 Array_Img ("T2", Type_Img (NV),
1565 Range_Img (0, T1_Len - 1),
1566 Range_Img (0, T2_Len - 1, Type_Img (256))),
1567 T2, T1_Len, T2_Len);
1569 else
1570 Put_Int_Matrix
1571 (File,
1572 Array_Img ("T2", Type_Img (NV),
1573 Range_Img (0, T1_Len - 1)),
1574 T2, T1_Len, 0);
1575 end if;
1577 New_Line (File);
1579 Put_Int_Vector
1580 (File,
1581 Array_Img ("G", Type_Img (NK),
1582 Range_Img (0, G_Len - 1)),
1583 G, G_Len);
1584 New_Line (File);
1586 Put (File, " function Hash (S : String) return Natural is");
1587 New_Line (File);
1588 Put (File, " F : constant Natural := S'First - 1;");
1589 New_Line (File);
1590 Put (File, " L : constant Natural := S'Length;");
1591 New_Line (File);
1592 Put (File, " F1, F2 : Natural := 0;");
1593 New_Line (File);
1595 Put (File, " J : ");
1597 if Opt = CPU_Time then
1598 Put (File, Type_Img (256));
1599 else
1600 Put (File, "Natural");
1601 end if;
1603 Put (File, ";");
1604 New_Line (File);
1606 Put (File, " begin");
1607 New_Line (File);
1608 Put (File, " for K in P'Range loop");
1609 New_Line (File);
1610 Put (File, " exit when L < P (K);");
1611 New_Line (File);
1612 Put (File, " J := ");
1614 if Opt = CPU_Time then
1615 Put (File, "C");
1616 else
1617 Put (File, "Character'Pos");
1618 end if;
1620 Put (File, " (S (P (K) + F));");
1621 New_Line (File);
1623 Put (File, " F1 := (F1 + Natural (T1 (K");
1625 if Opt = CPU_Time then
1626 Put (File, ", J");
1627 end if;
1629 Put (File, "))");
1631 if Opt = Memory_Space then
1632 Put (File, " * J");
1633 end if;
1635 Put (File, ") mod ");
1636 Put (File, Image (NV));
1637 Put (File, ";");
1638 New_Line (File);
1640 Put (File, " F2 := (F2 + Natural (T2 (K");
1642 if Opt = CPU_Time then
1643 Put (File, ", J");
1644 end if;
1646 Put (File, "))");
1648 if Opt = Memory_Space then
1649 Put (File, " * J");
1650 end if;
1652 Put (File, ") mod ");
1653 Put (File, Image (NV));
1654 Put (File, ";");
1655 New_Line (File);
1657 Put (File, " end loop;");
1658 New_Line (File);
1660 Put (File,
1661 " return (Natural (G (F1)) + Natural (G (F2))) mod ");
1663 Put (File, Image (NK));
1664 Put (File, ";");
1665 New_Line (File);
1666 Put (File, " end Hash;");
1667 New_Line (File);
1668 New_Line (File);
1669 Put (File, "end ");
1670 Put (File, Pkg_Name);
1671 Put (File, ";");
1672 New_Line (File);
1673 Close (File, Status);
1675 if not Status then
1676 raise Device_Error;
1677 end if;
1678 end Produce;
1680 ---------
1681 -- Put --
1682 ---------
1684 procedure Put (File : File_Descriptor; Str : String) is
1685 Len : constant Natural := Str'Length;
1686 begin
1687 if Write (File, Str'Address, Len) /= Len then
1688 raise Program_Error;
1689 end if;
1690 end Put;
1692 ---------
1693 -- Put --
1694 ---------
1696 procedure Put
1697 (F : File_Descriptor;
1698 S : String;
1699 F1 : Natural;
1700 L1 : Natural;
1701 C1 : Natural;
1702 F2 : Natural;
1703 L2 : Natural;
1704 C2 : Natural)
1706 Len : constant Natural := S'Length;
1708 procedure Flush;
1709 -- Write current line, followed by LF
1711 -----------
1712 -- Flush --
1713 -----------
1715 procedure Flush is
1716 begin
1717 Put (F, Line (1 .. Last));
1718 New_Line (F);
1719 Last := 0;
1720 end Flush;
1722 -- Start of processing for Put
1724 begin
1725 if C1 = F1 and then C2 = F2 then
1726 Last := 0;
1727 end if;
1729 if Last + Len + 3 > Max then
1730 Flush;
1731 end if;
1733 if Last = 0 then
1734 Line (Last + 1 .. Last + 5) := " ";
1735 Last := Last + 5;
1737 if F1 <= L1 then
1738 if C1 = F1 and then C2 = F2 then
1739 Add ('(');
1741 if F1 = L1 then
1742 Add ("0 .. 0 => ");
1743 end if;
1745 else
1746 Add (' ');
1747 end if;
1748 end if;
1749 end if;
1751 if C2 = F2 then
1752 Add ('(');
1754 if F2 = L2 then
1755 Add ("0 .. 0 => ");
1756 end if;
1758 else
1759 Add (' ');
1760 end if;
1762 Line (Last + 1 .. Last + Len) := S;
1763 Last := Last + Len;
1765 if C2 = L2 then
1766 Add (')');
1768 if F1 > L1 then
1769 Add (';');
1770 Flush;
1772 elsif C1 /= L1 then
1773 Add (',');
1774 Flush;
1776 else
1777 Add (')');
1778 Add (';');
1779 Flush;
1780 end if;
1782 else
1783 Add (',');
1784 end if;
1785 end Put;
1787 ---------------
1788 -- Put_Edges --
1789 ---------------
1791 procedure Put_Edges (File : File_Descriptor; Title : String) is
1792 E : Edge_Type;
1793 F1 : constant Natural := 1;
1794 L1 : constant Natural := Edges_Len - 1;
1795 M : constant Natural := Max / 5;
1797 begin
1798 Put (File, Title);
1799 New_Line (File);
1801 -- Edges valid range is 1 .. Edge_Len - 1
1803 for J in F1 .. L1 loop
1804 E := Get_Edges (J);
1805 Put (File, Image (J, M), F1, L1, J, 1, 4, 1);
1806 Put (File, Image (E.X, M), F1, L1, J, 1, 4, 2);
1807 Put (File, Image (E.Y, M), F1, L1, J, 1, 4, 3);
1808 Put (File, Image (E.Key, M), F1, L1, J, 1, 4, 4);
1809 end loop;
1810 end Put_Edges;
1812 ----------------------
1813 -- Put_Initial_Keys --
1814 ----------------------
1816 procedure Put_Initial_Keys (File : File_Descriptor; Title : String) is
1817 F1 : constant Natural := 0;
1818 L1 : constant Natural := NK - 1;
1819 M : constant Natural := Max / 5;
1820 K : Key_Type;
1822 begin
1823 Put (File, Title);
1824 New_Line (File);
1826 for J in F1 .. L1 loop
1827 K := Get_Key (J);
1828 Put (File, Image (J, M), F1, L1, J, 1, 3, 1);
1829 Put (File, Image (K.Edge, M), F1, L1, J, 1, 3, 2);
1830 Put (File, WT.Table (Initial (J)).all, F1, L1, J, 1, 3, 3);
1831 end loop;
1832 end Put_Initial_Keys;
1834 --------------------
1835 -- Put_Int_Matrix --
1836 --------------------
1838 procedure Put_Int_Matrix
1839 (File : File_Descriptor;
1840 Title : String;
1841 Table : Integer;
1842 Len_1 : Natural;
1843 Len_2 : Natural)
1845 F1 : constant Integer := 0;
1846 L1 : constant Integer := Len_1 - 1;
1847 F2 : constant Integer := 0;
1848 L2 : constant Integer := Len_2 - 1;
1849 Ix : Natural;
1851 begin
1852 Put (File, Title);
1853 New_Line (File);
1855 if Len_2 = 0 then
1856 for J in F1 .. L1 loop
1857 Ix := IT.Table (Table + J);
1858 Put (File, Image (Ix), 1, 0, 1, F1, L1, J);
1859 end loop;
1861 else
1862 for J in F1 .. L1 loop
1863 for K in F2 .. L2 loop
1864 Ix := IT.Table (Table + J + K * Len_1);
1865 Put (File, Image (Ix), F1, L1, J, F2, L2, K);
1866 end loop;
1867 end loop;
1868 end if;
1869 end Put_Int_Matrix;
1871 --------------------
1872 -- Put_Int_Vector --
1873 --------------------
1875 procedure Put_Int_Vector
1876 (File : File_Descriptor;
1877 Title : String;
1878 Vector : Integer;
1879 Length : Natural)
1881 F2 : constant Natural := 0;
1882 L2 : constant Natural := Length - 1;
1884 begin
1885 Put (File, Title);
1886 New_Line (File);
1888 for J in F2 .. L2 loop
1889 Put (File, Image (IT.Table (Vector + J)), 1, 0, 1, F2, L2, J);
1890 end loop;
1891 end Put_Int_Vector;
1893 ----------------------
1894 -- Put_Reduced_Keys --
1895 ----------------------
1897 procedure Put_Reduced_Keys (File : File_Descriptor; Title : String) is
1898 F1 : constant Natural := 0;
1899 L1 : constant Natural := NK - 1;
1900 M : constant Natural := Max / 5;
1901 K : Key_Type;
1903 begin
1904 Put (File, Title);
1905 New_Line (File);
1907 for J in F1 .. L1 loop
1908 K := Get_Key (J);
1909 Put (File, Image (J, M), F1, L1, J, 1, 3, 1);
1910 Put (File, Image (K.Edge, M), F1, L1, J, 1, 3, 2);
1911 Put (File, WT.Table (Reduced (J)).all, F1, L1, J, 1, 3, 3);
1912 end loop;
1913 end Put_Reduced_Keys;
1915 -----------------------
1916 -- Put_Used_Char_Set --
1917 -----------------------
1919 procedure Put_Used_Char_Set (File : File_Descriptor; Title : String) is
1920 F : constant Natural := Character'Pos (Character'First);
1921 L : constant Natural := Character'Pos (Character'Last);
1923 begin
1924 Put (File, Title);
1925 New_Line (File);
1927 for J in Character'Range loop
1929 (File, Image (Get_Used_Char (J)), 1, 0, 1, F, L, Character'Pos (J));
1930 end loop;
1931 end Put_Used_Char_Set;
1933 ----------------------
1934 -- Put_Vertex_Table --
1935 ----------------------
1937 procedure Put_Vertex_Table (File : File_Descriptor; Title : String) is
1938 F1 : constant Natural := 0;
1939 L1 : constant Natural := NV - 1;
1940 M : constant Natural := Max / 4;
1941 V : Vertex_Type;
1943 begin
1944 Put (File, Title);
1945 New_Line (File);
1947 for J in F1 .. L1 loop
1948 V := Get_Vertices (J);
1949 Put (File, Image (J, M), F1, L1, J, 1, 3, 1);
1950 Put (File, Image (V.First, M), F1, L1, J, 1, 3, 2);
1951 Put (File, Image (V.Last, M), F1, L1, J, 1, 3, 3);
1952 end loop;
1953 end Put_Vertex_Table;
1955 ------------
1956 -- Random --
1957 ------------
1959 procedure Random (Seed : in out Natural) is
1961 -- Park & Miller Standard Minimal using Schrage's algorithm to avoid
1962 -- overflow: Xn+1 = 16807 * Xn mod (2 ** 31 - 1)
1964 R : Natural;
1965 Q : Natural;
1966 X : Integer;
1968 begin
1969 R := Seed mod 127773;
1970 Q := Seed / 127773;
1971 X := 16807 * R - 2836 * Q;
1973 Seed := (if X < 0 then X + 2147483647 else X);
1974 end Random;
1976 -------------
1977 -- Reduced --
1978 -------------
1980 function Reduced (K : Key_Id) return Word_Id is
1981 begin
1982 return K + NK + 1;
1983 end Reduced;
1985 -----------------
1986 -- Resize_Word --
1987 -----------------
1989 procedure Resize_Word (W : in out Word_Type; Len : Natural) is
1990 S1 : constant String := W.all;
1991 S2 : String (1 .. Len) := (others => ASCII.NUL);
1992 L : constant Natural := S1'Length;
1993 begin
1994 if L /= Len then
1995 Free_Word (W);
1996 S2 (1 .. L) := S1;
1997 W := New_Word (S2);
1998 end if;
1999 end Resize_Word;
2001 --------------------------
2002 -- Select_Char_Position --
2003 --------------------------
2005 procedure Select_Char_Position is
2007 type Vertex_Table_Type is array (Natural range <>) of Vertex_Type;
2009 procedure Build_Identical_Keys_Sets
2010 (Table : in out Vertex_Table_Type;
2011 Last : in out Natural;
2012 Pos : Natural);
2013 -- Build a list of keys subsets that are identical with the current
2014 -- position selection plus Pos. Once this routine is called, reduced
2015 -- words are sorted by subsets and each item (First, Last) in Sets
2016 -- defines the range of identical keys.
2017 -- Need comment saying exactly what Last is ???
2019 function Count_Different_Keys
2020 (Table : Vertex_Table_Type;
2021 Last : Natural;
2022 Pos : Natural) return Natural;
2023 -- For each subset in Sets, count the number of different keys if we add
2024 -- Pos to the current position selection.
2026 Sel_Position : IT.Table_Type (1 .. Max_Key_Len);
2027 Last_Sel_Pos : Natural := 0;
2028 Max_Sel_Pos : Natural := 0;
2030 -------------------------------
2031 -- Build_Identical_Keys_Sets --
2032 -------------------------------
2034 procedure Build_Identical_Keys_Sets
2035 (Table : in out Vertex_Table_Type;
2036 Last : in out Natural;
2037 Pos : Natural)
2039 S : constant Vertex_Table_Type := Table (Table'First .. Last);
2040 C : constant Natural := Pos;
2041 -- Shortcuts (why are these not renames ???)
2043 F : Integer;
2044 L : Integer;
2045 -- First and last words of a subset
2047 Offset : Natural;
2048 -- GNAT.Heap_Sort assumes that the first array index is 1. Offset
2049 -- defines the translation to operate.
2051 function Lt (L, R : Natural) return Boolean;
2052 procedure Move (From : Natural; To : Natural);
2053 -- Subprograms needed by GNAT.Heap_Sort_G
2055 --------
2056 -- Lt --
2057 --------
2059 function Lt (L, R : Natural) return Boolean is
2060 C : constant Natural := Pos;
2061 Left : Natural;
2062 Right : Natural;
2064 begin
2065 if L = 0 then
2066 Left := NK;
2067 Right := Offset + R;
2068 elsif R = 0 then
2069 Left := Offset + L;
2070 Right := NK;
2071 else
2072 Left := Offset + L;
2073 Right := Offset + R;
2074 end if;
2076 return WT.Table (Left)(C) < WT.Table (Right)(C);
2077 end Lt;
2079 ----------
2080 -- Move --
2081 ----------
2083 procedure Move (From : Natural; To : Natural) is
2084 Target, Source : Natural;
2086 begin
2087 if From = 0 then
2088 Source := NK;
2089 Target := Offset + To;
2090 elsif To = 0 then
2091 Source := Offset + From;
2092 Target := NK;
2093 else
2094 Source := Offset + From;
2095 Target := Offset + To;
2096 end if;
2098 WT.Table (Target) := WT.Table (Source);
2099 WT.Table (Source) := null;
2100 end Move;
2102 package Sorting is new GNAT.Heap_Sort_G (Move, Lt);
2104 -- Start of processing for Build_Identical_Key_Sets
2106 begin
2107 Last := 0;
2109 -- For each subset in S, extract the new subsets we have by adding C
2110 -- in the position selection.
2112 for J in S'Range loop
2113 if S (J).First = S (J).Last then
2114 F := S (J).First;
2115 L := S (J).Last;
2116 Last := Last + 1;
2117 Table (Last) := (F, L);
2119 else
2120 Offset := Reduced (S (J).First) - 1;
2121 Sorting.Sort (S (J).Last - S (J).First + 1);
2123 F := S (J).First;
2124 L := F;
2125 for N in S (J).First .. S (J).Last loop
2127 -- For the last item, close the last subset
2129 if N = S (J).Last then
2130 Last := Last + 1;
2131 Table (Last) := (F, N);
2133 -- Two contiguous words are identical when they have the
2134 -- same Cth character.
2136 elsif WT.Table (Reduced (N))(C) =
2137 WT.Table (Reduced (N + 1))(C)
2138 then
2139 L := N + 1;
2141 -- Find a new subset of identical keys. Store the current
2142 -- one and create a new subset.
2144 else
2145 Last := Last + 1;
2146 Table (Last) := (F, L);
2147 F := N + 1;
2148 L := F;
2149 end if;
2150 end loop;
2151 end if;
2152 end loop;
2153 end Build_Identical_Keys_Sets;
2155 --------------------------
2156 -- Count_Different_Keys --
2157 --------------------------
2159 function Count_Different_Keys
2160 (Table : Vertex_Table_Type;
2161 Last : Natural;
2162 Pos : Natural) return Natural
2164 N : array (Character) of Natural;
2165 C : Character;
2166 T : Natural := 0;
2168 begin
2169 -- For each subset, count the number of words that are still
2170 -- different when we include Pos in the position selection. Only
2171 -- focus on this position as the other positions already produce
2172 -- identical keys.
2174 for S in 1 .. Last loop
2176 -- Count the occurrences of the different characters
2178 N := (others => 0);
2179 for K in Table (S).First .. Table (S).Last loop
2180 C := WT.Table (Reduced (K))(Pos);
2181 N (C) := N (C) + 1;
2182 end loop;
2184 -- Update the number of different keys. Each character used
2185 -- denotes a different key.
2187 for J in N'Range loop
2188 if N (J) > 0 then
2189 T := T + 1;
2190 end if;
2191 end loop;
2192 end loop;
2194 return T;
2195 end Count_Different_Keys;
2197 -- Start of processing for Select_Char_Position
2199 begin
2200 -- Initialize the reduced words set
2202 for K in 0 .. NK - 1 loop
2203 WT.Table (Reduced (K)) := New_Word (WT.Table (Initial (K)).all);
2204 end loop;
2206 declare
2207 Differences : Natural;
2208 Max_Differences : Natural := 0;
2209 Old_Differences : Natural;
2210 Max_Diff_Sel_Pos : Natural := 0; -- init to kill warning
2211 Max_Diff_Sel_Pos_Idx : Natural := 0; -- init to kill warning
2212 Same_Keys_Sets_Table : Vertex_Table_Type (1 .. NK);
2213 Same_Keys_Sets_Last : Natural := 1;
2215 begin
2216 for C in Sel_Position'Range loop
2217 Sel_Position (C) := C;
2218 end loop;
2220 Same_Keys_Sets_Table (1) := (0, NK - 1);
2222 loop
2223 -- Preserve maximum number of different keys and check later on
2224 -- that this value is strictly incrementing. Otherwise, it means
2225 -- that two keys are strictly identical.
2227 Old_Differences := Max_Differences;
2229 -- The first position should not exceed the minimum key length.
2230 -- Otherwise, we may end up with an empty word once reduced.
2232 Max_Sel_Pos :=
2233 (if Last_Sel_Pos = 0 then Min_Key_Len else Max_Key_Len);
2235 -- Find which position increases more the number of differences
2237 for J in Last_Sel_Pos + 1 .. Max_Sel_Pos loop
2238 Differences := Count_Different_Keys
2239 (Same_Keys_Sets_Table,
2240 Same_Keys_Sets_Last,
2241 Sel_Position (J));
2243 if Verbose then
2244 Put (Output,
2245 "Selecting position" & Sel_Position (J)'Img &
2246 " results in" & Differences'Img &
2247 " differences");
2248 New_Line (Output);
2249 end if;
2251 if Differences > Max_Differences then
2252 Max_Differences := Differences;
2253 Max_Diff_Sel_Pos := Sel_Position (J);
2254 Max_Diff_Sel_Pos_Idx := J;
2255 end if;
2256 end loop;
2258 if Old_Differences = Max_Differences then
2259 raise Program_Error with "some keys are identical";
2260 end if;
2262 -- Insert selected position and sort Sel_Position table
2264 Last_Sel_Pos := Last_Sel_Pos + 1;
2265 Sel_Position (Last_Sel_Pos + 1 .. Max_Diff_Sel_Pos_Idx) :=
2266 Sel_Position (Last_Sel_Pos .. Max_Diff_Sel_Pos_Idx - 1);
2267 Sel_Position (Last_Sel_Pos) := Max_Diff_Sel_Pos;
2269 for P in 1 .. Last_Sel_Pos - 1 loop
2270 if Max_Diff_Sel_Pos < Sel_Position (P) then
2271 Sel_Position (P + 1 .. Last_Sel_Pos) :=
2272 Sel_Position (P .. Last_Sel_Pos - 1);
2273 Sel_Position (P) := Max_Diff_Sel_Pos;
2274 exit;
2275 end if;
2276 end loop;
2278 exit when Max_Differences = NK;
2280 Build_Identical_Keys_Sets
2281 (Same_Keys_Sets_Table,
2282 Same_Keys_Sets_Last,
2283 Max_Diff_Sel_Pos);
2285 if Verbose then
2286 Put (Output,
2287 "Selecting position" & Max_Diff_Sel_Pos'Img &
2288 " results in" & Max_Differences'Img &
2289 " differences");
2290 New_Line (Output);
2291 Put (Output, "--");
2292 New_Line (Output);
2293 for J in 1 .. Same_Keys_Sets_Last loop
2294 for K in
2295 Same_Keys_Sets_Table (J).First ..
2296 Same_Keys_Sets_Table (J).Last
2297 loop
2298 Put (Output, WT.Table (Reduced (K)).all);
2299 New_Line (Output);
2300 end loop;
2301 Put (Output, "--");
2302 New_Line (Output);
2303 end loop;
2304 end if;
2305 end loop;
2306 end;
2308 Char_Pos_Set_Len := Last_Sel_Pos;
2309 Char_Pos_Set := Allocate (Char_Pos_Set_Len);
2311 for C in 1 .. Last_Sel_Pos loop
2312 Set_Char_Pos (C - 1, Sel_Position (C));
2313 end loop;
2314 end Select_Char_Position;
2316 --------------------------
2317 -- Select_Character_Set --
2318 --------------------------
2320 procedure Select_Character_Set is
2321 Last : Natural := 0;
2322 Used : array (Character) of Boolean := (others => False);
2323 Char : Character;
2325 begin
2326 for J in 0 .. NK - 1 loop
2327 for K in 0 .. Char_Pos_Set_Len - 1 loop
2328 Char := WT.Table (Initial (J))(Get_Char_Pos (K));
2329 exit when Char = ASCII.NUL;
2330 Used (Char) := True;
2331 end loop;
2332 end loop;
2334 Used_Char_Set_Len := 256;
2335 Used_Char_Set := Allocate (Used_Char_Set_Len);
2337 for J in Used'Range loop
2338 if Used (J) then
2339 Set_Used_Char (J, Last);
2340 Last := Last + 1;
2341 else
2342 Set_Used_Char (J, 0);
2343 end if;
2344 end loop;
2345 end Select_Character_Set;
2347 ------------------
2348 -- Set_Char_Pos --
2349 ------------------
2351 procedure Set_Char_Pos (P : Natural; Item : Natural) is
2352 N : constant Natural := Char_Pos_Set + P;
2353 begin
2354 IT.Table (N) := Item;
2355 end Set_Char_Pos;
2357 ---------------
2358 -- Set_Edges --
2359 ---------------
2361 procedure Set_Edges (F : Natural; Item : Edge_Type) is
2362 N : constant Natural := Edges + (F * Edge_Size);
2363 begin
2364 IT.Table (N) := Item.X;
2365 IT.Table (N + 1) := Item.Y;
2366 IT.Table (N + 2) := Item.Key;
2367 end Set_Edges;
2369 ---------------
2370 -- Set_Graph --
2371 ---------------
2373 procedure Set_Graph (N : Natural; Item : Integer) is
2374 begin
2375 IT.Table (G + N) := Item;
2376 end Set_Graph;
2378 -------------
2379 -- Set_Key --
2380 -------------
2382 procedure Set_Key (N : Key_Id; Item : Key_Type) is
2383 begin
2384 IT.Table (Keys + N) := Item.Edge;
2385 end Set_Key;
2387 ---------------
2388 -- Set_Table --
2389 ---------------
2391 procedure Set_Table (T : Integer; X, Y : Natural; Item : Natural) is
2392 N : constant Natural := T + ((Y * T1_Len) + X);
2393 begin
2394 IT.Table (N) := Item;
2395 end Set_Table;
2397 -------------------
2398 -- Set_Used_Char --
2399 -------------------
2401 procedure Set_Used_Char (C : Character; Item : Natural) is
2402 N : constant Natural := Used_Char_Set + Character'Pos (C);
2403 begin
2404 IT.Table (N) := Item;
2405 end Set_Used_Char;
2407 ------------------
2408 -- Set_Vertices --
2409 ------------------
2411 procedure Set_Vertices (F : Natural; Item : Vertex_Type) is
2412 N : constant Natural := Vertices + (F * Vertex_Size);
2413 begin
2414 IT.Table (N) := Item.First;
2415 IT.Table (N + 1) := Item.Last;
2416 end Set_Vertices;
2418 ---------
2419 -- Sum --
2420 ---------
2422 function Sum
2423 (Word : Word_Type;
2424 Table : Table_Id;
2425 Opt : Optimization) return Natural
2427 S : Natural := 0;
2428 R : Natural;
2430 begin
2431 if Opt = CPU_Time then
2432 for J in 0 .. T1_Len - 1 loop
2433 exit when Word (J + 1) = ASCII.NUL;
2434 R := Get_Table (Table, J, Get_Used_Char (Word (J + 1)));
2435 S := (S + R) mod NV;
2436 end loop;
2438 else
2439 for J in 0 .. T1_Len - 1 loop
2440 exit when Word (J + 1) = ASCII.NUL;
2441 R := Get_Table (Table, J, 0);
2442 S := (S + R * Character'Pos (Word (J + 1))) mod NV;
2443 end loop;
2444 end if;
2446 return S;
2447 end Sum;
2449 ---------------
2450 -- Type_Size --
2451 ---------------
2453 function Type_Size (L : Natural) return Natural is
2454 begin
2455 if L <= 2 ** 8 then
2456 return 8;
2457 elsif L <= 2 ** 16 then
2458 return 16;
2459 else
2460 return 32;
2461 end if;
2462 end Type_Size;
2464 -----------
2465 -- Value --
2466 -----------
2468 function Value
2469 (Name : Table_Name;
2470 J : Natural;
2471 K : Natural := 0) return Natural
2473 begin
2474 case Name is
2475 when Character_Position =>
2476 return Get_Char_Pos (J);
2478 when Used_Character_Set =>
2479 return Get_Used_Char (Character'Val (J));
2481 when Function_Table_1 =>
2482 return Get_Table (T1, J, K);
2484 when Function_Table_2 =>
2485 return Get_Table (T2, J, K);
2487 when Graph_Table =>
2488 return Get_Graph (J);
2490 end case;
2491 end Value;
2493 end GNAT.Perfect_Hash_Generators;