OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [g-pehage.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.