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