gcc/ada/libgnat/g-pehage.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --        G N A T . P E R F E C T _ H A S H _ G E N E R A T O R S           --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                     Copyright (C) 2002-2018, 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          =>
 891             Item_Size := Type_Size (NV);
 892             Length_1  := T1_Len;
 893             Length_2  := T2_Len;
 894
 895          when Graph_Table =>
 896             Item_Size := Type_Size (NK);
 897             Length_1  := NV;
 898             Length_2  := 0;
 899       end case;
 900    end Define;
 901
 902    --------------
 903    -- Finalize --
 904    --------------
 905
 906    procedure Finalize is
 907    begin
 908       if Verbose then
 909          Put (Output, "Finalize");
 910          New_Line (Output);
 911       end if;
 912
 913       --  Deallocate all the WT components (both initial and reduced ones) to
 914       --  avoid memory leaks.
 915
 916       for W in 0 .. WT.Last loop
 917
 918          --  Note: WT.Table (NK) is a temporary variable, do not free it since
 919          --  this would cause a double free.
 920
 921          if W /= NK then
 922             Free_Word (WT.Table (W));
 923          end if;
 924       end loop;
 925
 926       WT.Release;
 927       IT.Release;
 928
 929       --  Reset all variables for next usage
 930
 931       Keys := No_Table;
 932
 933       Char_Pos_Set     := No_Table;
 934       Char_Pos_Set_Len := 0;
 935
 936       Used_Char_Set     := No_Table;
 937       Used_Char_Set_Len := 0;
 938
 939       T1 := No_Table;
 940       T2 := No_Table;
 941
 942       T1_Len := 0;
 943       T2_Len := 0;
 944
 945       G     := No_Table;
 946       G_Len := 0;
 947
 948       Edges     := No_Table;
 949       Edges_Len := 0;
 950
 951       Vertices := No_Table;
 952       NV       := 0;
 953
 954       NK := 0;
 955       Max_Key_Len := 0;
 956       Min_Key_Len := 0;
 957    end Finalize;
 958
 959    ----------------------------
 960    -- Generate_Mapping_Table --
 961    ----------------------------
 962
 963    procedure Generate_Mapping_Table
 964      (Tab  : Integer;
 965       L1   : Natural;
 966       L2   : Natural;
 967       Seed : in out Natural)
 968    is
 969    begin
 970       for J in 0 .. L1 - 1 loop
 971          for K in 0 .. L2 - 1 loop
 972             Random (Seed);
 973             Set_Table (Tab, J, K, Seed mod NV);
 974          end loop;
 975       end loop;
 976    end Generate_Mapping_Table;
 977
 978    -----------------------------
 979    -- Generate_Mapping_Tables --
 980    -----------------------------
 981
 982    procedure Generate_Mapping_Tables
 983      (Opt  : Optimization;
 984       Seed : in out Natural)
 985    is
 986    begin
 987       --  If T1 and T2 are already allocated no need to do it twice. Reuse them
 988       --  as their size has not changed.
 989
 990       if T1 = No_Table and then T2 = No_Table then
 991          declare
 992             Used_Char_Last : Natural := 0;
 993             Used_Char      : Natural;
 994
 995          begin
 996             if Opt = CPU_Time then
 997                for P in reverse Character'Range loop
 998                   Used_Char := Get_Used_Char (P);
 999                   if Used_Char /= 0 then
1000                      Used_Char_Last := Used_Char;
1001                      exit;
1002                   end if;
1003                end loop;
1004             end if;
1005
1006             T1_Len := Char_Pos_Set_Len;
1007             T2_Len := Used_Char_Last + 1;
1008             T1 := Allocate (T1_Len * T2_Len);
1009             T2 := Allocate (T1_Len * T2_Len);
1010          end;
1011       end if;
1012
1013       Generate_Mapping_Table (T1, T1_Len, T2_Len, Seed);
1014       Generate_Mapping_Table (T2, T1_Len, T2_Len, Seed);
1015
1016       if Verbose then
1017          Put_Used_Char_Set (Output, "Used Character Set");
1018          Put_Int_Matrix (Output, "Function Table 1", T1,
1019                         T1_Len, T2_Len);
1020          Put_Int_Matrix (Output, "Function Table 2", T2,
1021                         T1_Len, T2_Len);
1022       end if;
1023    end Generate_Mapping_Tables;
1024
1025    ------------------
1026    -- Get_Char_Pos --
1027    ------------------
1028
1029    function Get_Char_Pos (P : Natural) return Natural is
1030       N : constant Natural := Char_Pos_Set + P;
1031    begin
1032       return IT.Table (N);
1033    end Get_Char_Pos;
1034
1035    ---------------
1036    -- Get_Edges --
1037    ---------------
1038
1039    function Get_Edges (F : Natural) return Edge_Type is
1040       N : constant Natural := Edges + (F * Edge_Size);
1041       E : Edge_Type;
1042    begin
1043       E.X   := IT.Table (N);
1044       E.Y   := IT.Table (N + 1);
1045       E.Key := IT.Table (N + 2);
1046       return E;
1047    end Get_Edges;
1048
1049    ---------------
1050    -- Get_Graph --
1051    ---------------
1052
1053    function Get_Graph (N : Natural) return Integer is
1054    begin
1055       return IT.Table (G + N);
1056    end Get_Graph;
1057
1058    -------------
1059    -- Get_Key --
1060    -------------
1061
1062    function Get_Key (N : Key_Id) return Key_Type is
1063       K : Key_Type;
1064    begin
1065       K.Edge := IT.Table (Keys + N);
1066       return K;
1067    end Get_Key;
1068
1069    ---------------
1070    -- Get_Table --
1071    ---------------
1072
1073    function Get_Table (T : Integer; X, Y : Natural) return Natural is
1074       N : constant Natural := T + (Y * T1_Len) + X;
1075    begin
1076       return IT.Table (N);
1077    end Get_Table;
1078
1079    -------------------
1080    -- Get_Used_Char --
1081    -------------------
1082
1083    function Get_Used_Char (C : Character) return Natural is
1084       N : constant Natural := Used_Char_Set + Character'Pos (C);
1085    begin
1086       return IT.Table (N);
1087    end Get_Used_Char;
1088
1089    ------------------
1090    -- Get_Vertices --
1091    ------------------
1092
1093    function Get_Vertices (F : Natural) return Vertex_Type is
1094       N : constant Natural := Vertices + (F * Vertex_Size);
1095       V : Vertex_Type;
1096    begin
1097       V.First := IT.Table (N);
1098       V.Last  := IT.Table (N + 1);
1099       return V;
1100    end Get_Vertices;
1101
1102    -----------
1103    -- Image --
1104    -----------
1105
1106    function Image (Int : Integer; W : Natural := 0) return String is
1107       B : String (1 .. 32);
1108       L : Natural := 0;
1109
1110       procedure Img (V : Natural);
1111       --  Compute image of V into B, starting at B (L), incrementing L
1112
1113       ---------
1114       -- Img --
1115       ---------
1116
1117       procedure Img (V : Natural) is
1118       begin
1119          if V > 9 then
1120             Img (V / 10);
1121          end if;
1122
1123          L := L + 1;
1124          B (L) := Character'Val ((V mod 10) + Character'Pos ('0'));
1125       end Img;
1126
1127    --  Start of processing for Image
1128
1129    begin
1130       if Int < 0 then
1131          L := L + 1;
1132          B (L) := '-';
1133          Img (-Int);
1134       else
1135          Img (Int);
1136       end if;
1137
1138       return Image (B (1 .. L), W);
1139    end Image;
1140
1141    -----------
1142    -- Image --
1143    -----------
1144
1145    function Image (Str : String; W : Natural := 0) return String is
1146       Len : constant Natural := Str'Length;
1147       Max : Natural := Len;
1148
1149    begin
1150       if Max < W then
1151          Max := W;
1152       end if;
1153
1154       declare
1155          Buf : String (1 .. Max) := (1 .. Max => ' ');
1156
1157       begin
1158          for J in 0 .. Len - 1 loop
1159             Buf (Max - Len + 1 + J) := Str (Str'First + J);
1160          end loop;
1161
1162          return Buf;
1163       end;
1164    end Image;
1165
1166    -------------
1167    -- Initial --
1168    -------------
1169
1170    function Initial (K : Key_Id) return Word_Id is
1171    begin
1172       return K;
1173    end Initial;
1174
1175    ----------------
1176    -- Initialize --
1177    ----------------
1178
1179    procedure Initialize
1180      (Seed   : Natural;
1181       K_To_V : Float        := Default_K_To_V;
1182       Optim  : Optimization := Memory_Space;
1183       Tries  : Positive     := Default_Tries)
1184    is
1185    begin
1186       if Verbose then
1187          Put (Output, "Initialize");
1188          New_Line (Output);
1189       end if;
1190
1191       --  Deallocate the part of the table concerning the reduced words.
1192       --  Initial words are already present in the table. We may have reduced
1193       --  words already there because a previous computation failed. We are
1194       --  currently retrying and the reduced words have to be deallocated.
1195
1196       for W in Reduced (0) .. WT.Last loop
1197          Free_Word (WT.Table (W));
1198       end loop;
1199
1200       IT.Init;
1201
1202       --  Initialize of computation variables
1203
1204       Keys := No_Table;
1205
1206       Char_Pos_Set     := No_Table;
1207       Char_Pos_Set_Len := 0;
1208
1209       Used_Char_Set     := No_Table;
1210       Used_Char_Set_Len := 0;
1211
1212       T1 := No_Table;
1213       T2 := No_Table;
1214
1215       T1_Len := 0;
1216       T2_Len := 0;
1217
1218       G     := No_Table;
1219       G_Len := 0;
1220
1221       Edges     := No_Table;
1222       Edges_Len := 0;
1223
1224       Vertices := No_Table;
1225       NV       := 0;
1226
1227       S    := Seed;
1228       K2V  := K_To_V;
1229       Opt  := Optim;
1230       NT   := Tries;
1231
1232       if K2V <= 2.0 then
1233          raise Program_Error with "K to V ratio cannot be lower than 2.0";
1234       end if;
1235
1236       --  Do not accept a value of K2V too close to 2.0 such that once
1237       --  rounded up, NV = 2 * NK because the algorithm would not converge.
1238
1239       NV := Natural (Float (NK) * K2V);
1240       if NV <= 2 * NK then
1241          NV := 2 * NK + 1;
1242       end if;
1243
1244       Keys := Allocate (NK);
1245
1246       --  Resize initial words to have all of them at the same size
1247       --  (so the size of the largest one).
1248
1249       for K in 0 .. NK - 1 loop
1250          Resize_Word (WT.Table (Initial (K)), Max_Key_Len);
1251       end loop;
1252
1253       --  Allocated the table to store the reduced words. As WT is a
1254       --  GNAT.Table (using C memory management), pointers have to be
1255       --  explicitly initialized to null.
1256
1257       WT.Set_Last (Reduced (NK - 1));
1258
1259       --  Note: Reduced (0) = NK + 1
1260
1261       WT.Table (NK) := null;
1262
1263       for W in 0 .. NK - 1 loop
1264          WT.Table (Reduced (W)) := null;
1265       end loop;
1266    end Initialize;
1267
1268    ------------
1269    -- Insert --
1270    ------------
1271
1272    procedure Insert (Value : String) is
1273       Len  : constant Natural := Value'Length;
1274
1275    begin
1276       if Verbose then
1277          Put (Output, "Inserting """ & Value & """");
1278          New_Line (Output);
1279       end if;
1280
1281       for J in Value'Range loop
1282          pragma Assert (Value (J) /= ASCII.NUL);
1283          null;
1284       end loop;
1285
1286       WT.Set_Last (NK);
1287       WT.Table (NK) := New_Word (Value);
1288       NK := NK + 1;
1289
1290       if Max_Key_Len < Len then
1291          Max_Key_Len := Len;
1292       end if;
1293
1294       if Min_Key_Len = 0 or else Len < Min_Key_Len then
1295          Min_Key_Len := Len;
1296       end if;
1297    end Insert;
1298
1299    --------------
1300    -- New_Line --
1301    --------------
1302
1303    procedure New_Line (File : File_Descriptor) is
1304    begin
1305       if Write (File, EOL'Address, 1) /= 1 then
1306          raise Program_Error;
1307       end if;
1308    end New_Line;
1309
1310    --------------
1311    -- New_Word --
1312    --------------
1313
1314    function New_Word (S : String) return Word_Type is
1315    begin
1316       return new String'(S);
1317    end New_Word;
1318
1319    ------------------------------
1320    -- Parse_Position_Selection --
1321    ------------------------------
1322
1323    procedure Parse_Position_Selection (Argument : String) is
1324       N : Natural          := Argument'First;
1325       L : constant Natural := Argument'Last;
1326       M : constant Natural := Max_Key_Len;
1327
1328       T : array (1 .. M) of Boolean := (others => False);
1329
1330       function Parse_Index return Natural;
1331       --  Parse argument starting at index N to find an index
1332
1333       -----------------
1334       -- Parse_Index --
1335       -----------------
1336
1337       function Parse_Index return Natural is
1338          C : Character := Argument (N);
1339          V : Natural   := 0;
1340
1341       begin
1342          if C = '$' then
1343             N := N + 1;
1344             return M;
1345          end if;
1346
1347          if C not in '0' .. '9' then
1348             raise Program_Error with "cannot read position argument";
1349          end if;
1350
1351          while C in '0' .. '9' loop
1352             V := V * 10 + (Character'Pos (C) - Character'Pos ('0'));
1353             N := N + 1;
1354             exit when L < N;
1355             C := Argument (N);
1356          end loop;
1357
1358          return V;
1359       end Parse_Index;
1360
1361    --  Start of processing for Parse_Position_Selection
1362
1363    begin
1364       --  Empty specification means all the positions
1365
1366       if L < N then
1367          Char_Pos_Set_Len := M;
1368          Char_Pos_Set := Allocate (Char_Pos_Set_Len);
1369
1370          for C in 0 .. Char_Pos_Set_Len - 1 loop
1371             Set_Char_Pos (C, C + 1);
1372          end loop;
1373
1374       else
1375          loop
1376             declare
1377                First, Last : Natural;
1378
1379             begin
1380                First := Parse_Index;
1381                Last  := First;
1382
1383                --  Detect a range
1384
1385                if N <= L and then Argument (N) = '-' then
1386                   N := N + 1;
1387                   Last := Parse_Index;
1388                end if;
1389
1390                --  Include the positions in the selection
1391
1392                for J in First .. Last loop
1393                   T (J) := True;
1394                end loop;
1395             end;
1396
1397             exit when L < N;
1398
1399             if Argument (N) /= ',' then
1400                raise Program_Error with "cannot read position argument";
1401             end if;
1402
1403             N := N + 1;
1404          end loop;
1405
1406          --  Compute position selection length
1407
1408          N := 0;
1409          for J in T'Range loop
1410             if T (J) then
1411                N := N + 1;
1412             end if;
1413          end loop;
1414
1415          --  Fill position selection
1416
1417          Char_Pos_Set_Len := N;
1418          Char_Pos_Set := Allocate (Char_Pos_Set_Len);
1419
1420          N := 0;
1421          for J in T'Range loop
1422             if T (J) then
1423                Set_Char_Pos (N, J);
1424                N := N + 1;
1425             end if;
1426          end loop;
1427       end if;
1428    end Parse_Position_Selection;
1429
1430    -------------
1431    -- Produce --
1432    -------------
1433
1434    procedure Produce
1435      (Pkg_Name   : String  := Default_Pkg_Name;
1436       Use_Stdout : Boolean := False)
1437    is
1438       File : File_Descriptor := Standout;
1439
1440       Status : Boolean;
1441       --  For call to Close
1442
1443       function Array_Img (N, T, R1 : String; R2 : String := "") return String;
1444       --  Return string "N : constant array (R1[, R2]) of T;"
1445
1446       function Range_Img (F, L : Natural; T : String := "") return String;
1447       --  Return string "[T range ]F .. L"
1448
1449       function Type_Img (L : Natural) return String;
1450       --  Return the larger unsigned type T such that T'Last < L
1451
1452       ---------------
1453       -- Array_Img --
1454       ---------------
1455
1456       function Array_Img
1457         (N, T, R1 : String;
1458          R2       : String := "") return String
1459       is
1460       begin
1461          Last := 0;
1462          Add ("   ");
1463          Add (N);
1464          Add (" : constant array (");
1465          Add (R1);
1466
1467          if R2 /= "" then
1468             Add (", ");
1469             Add (R2);
1470          end if;
1471
1472          Add (") of ");
1473          Add (T);
1474          Add (" :=");
1475          return Line (1 .. Last);
1476       end Array_Img;
1477
1478       ---------------
1479       -- Range_Img --
1480       ---------------
1481
1482       function Range_Img (F, L : Natural; T : String := "") return String is
1483          FI  : constant String  := Image (F);
1484          FL  : constant Natural := FI'Length;
1485          LI  : constant String  := Image (L);
1486          LL  : constant Natural := LI'Length;
1487          TL  : constant Natural := T'Length;
1488          RI  : String (1 .. TL + 7 + FL + 4 + LL);
1489          Len : Natural := 0;
1490
1491       begin
1492          if TL /= 0 then
1493             RI (Len + 1 .. Len + TL) := T;
1494             Len := Len + TL;
1495             RI (Len + 1 .. Len + 7) := " range ";
1496             Len := Len + 7;
1497          end if;
1498
1499          RI (Len + 1 .. Len + FL) := FI;
1500          Len := Len + FL;
1501          RI (Len + 1 .. Len + 4) := " .. ";
1502          Len := Len + 4;
1503          RI (Len + 1 .. Len + LL) := LI;
1504          Len := Len + LL;
1505          return RI (1 .. Len);
1506       end Range_Img;
1507
1508       --------------
1509       -- Type_Img --
1510       --------------
1511
1512       function Type_Img (L : Natural) return String is
1513          S : constant String := Image (Type_Size (L));
1514          U : String  := "Unsigned_  ";
1515          N : Natural := 9;
1516
1517       begin
1518          for J in S'Range loop
1519             N := N + 1;
1520             U (N) := S (J);
1521          end loop;
1522
1523          return U (1 .. N);
1524       end Type_Img;
1525
1526       F : Natural;
1527       L : Natural;
1528       P : Natural;
1529
1530       FName : String := Ada_File_Base_Name (Pkg_Name) & ".ads";
1531       --  Initially, the name of the spec file, then modified to be the name of
1532       --  the body file. Not used if Use_Stdout is True.
1533
1534    --  Start of processing for Produce
1535
1536    begin
1537
1538       if Verbose and then not Use_Stdout then
1539          Put (Output,
1540               "Producing " & Ada.Directories.Current_Directory & "/" & FName);
1541          New_Line (Output);
1542       end if;
1543
1544       if not Use_Stdout then
1545          File := Create_File (FName, Binary);
1546
1547          if File = Invalid_FD then
1548             raise Program_Error with "cannot create: " & FName;
1549          end if;
1550       end if;
1551
1552       Put      (File, "package ");
1553       Put      (File, Pkg_Name);
1554       Put      (File, " is");
1555       New_Line (File);
1556       Put      (File, "   function Hash (S : String) return Natural;");
1557       New_Line (File);
1558       Put      (File, "end ");
1559       Put      (File, Pkg_Name);
1560       Put      (File, ";");
1561       New_Line (File);
1562
1563       if not Use_Stdout then
1564          Close (File, Status);
1565
1566          if not Status then
1567             raise Device_Error;
1568          end if;
1569       end if;
1570
1571       if not Use_Stdout then
1572
1573          --  Set to body file name
1574
1575          FName (FName'Last) := 'b';
1576
1577          File := Create_File (FName, Binary);
1578
1579          if File = Invalid_FD then
1580             raise Program_Error with "cannot create: " & FName;
1581          end if;
1582       end if;
1583
1584       Put      (File, "with Interfaces; use Interfaces;");
1585       New_Line (File);
1586       New_Line (File);
1587       Put      (File, "package body ");
1588       Put      (File, Pkg_Name);
1589       Put      (File, " is");
1590       New_Line (File);
1591       New_Line (File);
1592
1593       if Opt = CPU_Time then
1594          Put      (File, Array_Img ("C", Type_Img (256), "Character"));
1595          New_Line (File);
1596
1597          F := Character'Pos (Character'First);
1598          L := Character'Pos (Character'Last);
1599
1600          for J in Character'Range loop
1601             P := Get_Used_Char (J);
1602             Put (File, Image (P), 1, 0, 1, F, L, Character'Pos (J));
1603          end loop;
1604
1605          New_Line (File);
1606       end if;
1607
1608       F := 0;
1609       L := Char_Pos_Set_Len - 1;
1610
1611       Put      (File, Array_Img ("P", "Natural", Range_Img (F, L)));
1612       New_Line (File);
1613
1614       for J in F .. L loop
1615          Put (File, Image (Get_Char_Pos (J)), 1, 0, 1, F, L, J);
1616       end loop;
1617
1618       New_Line (File);
1619
1620       case Opt is
1621          when CPU_Time =>
1622             Put_Int_Matrix
1623               (File,
1624                Array_Img ("T1", Type_Img (NV),
1625                           Range_Img (0, T1_Len - 1),
1626                           Range_Img (0, T2_Len - 1, Type_Img (256))),
1627                T1, T1_Len, T2_Len);
1628
1629          when Memory_Space =>
1630             Put_Int_Matrix
1631               (File,
1632                Array_Img ("T1", Type_Img (NV),
1633                           Range_Img (0, T1_Len - 1)),
1634                T1, T1_Len, 0);
1635       end case;
1636
1637       New_Line (File);
1638
1639       case Opt is
1640          when CPU_Time =>
1641             Put_Int_Matrix
1642               (File,
1643                Array_Img ("T2", Type_Img (NV),
1644                           Range_Img (0, T1_Len - 1),
1645                           Range_Img (0, T2_Len - 1, Type_Img (256))),
1646                T2, T1_Len, T2_Len);
1647
1648          when Memory_Space =>
1649             Put_Int_Matrix
1650               (File,
1651                Array_Img ("T2", Type_Img (NV),
1652                           Range_Img (0, T1_Len - 1)),
1653                T2, T1_Len, 0);
1654       end case;
1655
1656       New_Line (File);
1657
1658       Put_Int_Vector
1659         (File,
1660          Array_Img ("G", Type_Img (NK),
1661                     Range_Img (0, G_Len - 1)),
1662          G, G_Len);
1663       New_Line (File);
1664
1665       Put      (File, "   function Hash (S : String) return Natural is");
1666       New_Line (File);
1667       Put      (File, "      F : constant Natural := S'First - 1;");
1668       New_Line (File);
1669       Put      (File, "      L : constant Natural := S'Length;");
1670       New_Line (File);
1671       Put      (File, "      F1, F2 : Natural := 0;");
1672       New_Line (File);
1673
1674       Put (File, "      J : ");
1675
1676       case Opt is
1677          when CPU_Time =>
1678             Put (File, Type_Img (256));
1679
1680          when Memory_Space =>
1681             Put (File, "Natural");
1682       end case;
1683
1684       Put (File, ";");
1685       New_Line (File);
1686
1687       Put      (File, "   begin");
1688       New_Line (File);
1689       Put      (File, "      for K in P'Range loop");
1690       New_Line (File);
1691       Put      (File, "         exit when L < P (K);");
1692       New_Line (File);
1693       Put      (File, "         J  := ");
1694
1695       case Opt is
1696          when CPU_Time =>
1697             Put (File, "C");
1698
1699          when Memory_Space =>
1700             Put (File, "Character'Pos");
1701       end case;
1702
1703       Put      (File, " (S (P (K) + F));");
1704       New_Line (File);
1705
1706       Put (File, "         F1 := (F1 + Natural (T1 (K");
1707
1708       if Opt = CPU_Time then
1709          Put (File, ", J");
1710       end if;
1711
1712       Put (File, "))");
1713
1714       if Opt = Memory_Space then
1715          Put (File, " * J");
1716       end if;
1717
1718       Put      (File, ") mod ");
1719       Put      (File, Image (NV));
1720       Put      (File, ";");
1721       New_Line (File);
1722
1723       Put (File, "         F2 := (F2 + Natural (T2 (K");
1724
1725       if Opt = CPU_Time then
1726          Put (File, ", J");
1727       end if;
1728
1729       Put (File, "))");
1730
1731       if Opt = Memory_Space then
1732          Put (File, " * J");
1733       end if;
1734
1735       Put      (File, ") mod ");
1736       Put      (File, Image (NV));
1737       Put      (File, ";");
1738       New_Line (File);
1739
1740       Put      (File, "      end loop;");
1741       New_Line (File);
1742
1743       Put      (File,
1744                 "      return (Natural (G (F1)) + Natural (G (F2))) mod ");
1745
1746       Put      (File, Image (NK));
1747       Put      (File, ";");
1748       New_Line (File);
1749       Put      (File, "   end Hash;");
1750       New_Line (File);
1751       New_Line (File);
1752       Put      (File, "end ");
1753       Put      (File, Pkg_Name);
1754       Put      (File, ";");
1755       New_Line (File);
1756
1757       if not Use_Stdout then
1758          Close (File, Status);
1759
1760          if not Status then
1761             raise Device_Error;
1762          end if;
1763       end if;
1764    end Produce;
1765
1766    ---------
1767    -- Put --
1768    ---------
1769
1770    procedure Put (File : File_Descriptor; Str : String) is
1771       Len : constant Natural := Str'Length;
1772    begin
1773       for J in Str'Range loop
1774          pragma Assert (Str (J) /= ASCII.NUL);
1775          null;
1776       end loop;
1777
1778       if Write (File, Str'Address, Len) /= Len then
1779          raise Program_Error;
1780       end if;
1781    end Put;
1782
1783    ---------
1784    -- Put --
1785    ---------
1786
1787    procedure Put
1788      (F  : File_Descriptor;
1789       S  : String;
1790       F1 : Natural;
1791       L1 : Natural;
1792       C1 : Natural;
1793       F2 : Natural;
1794       L2 : Natural;
1795       C2 : Natural)
1796    is
1797       Len : constant Natural := S'Length;
1798
1799       procedure Flush;
1800       --  Write current line, followed by LF
1801
1802       -----------
1803       -- Flush --
1804       -----------
1805
1806       procedure Flush is
1807       begin
1808          Put (F, Line (1 .. Last));
1809          New_Line (F);
1810          Last := 0;
1811       end Flush;
1812
1813    --  Start of processing for Put
1814
1815    begin
1816       if C1 = F1 and then C2 = F2 then
1817          Last := 0;
1818       end if;
1819
1820       if Last + Len + 3 >= Max then
1821          Flush;
1822       end if;
1823
1824       if Last = 0 then
1825          Add ("     ");
1826
1827          if F1 <= L1 then
1828             if C1 = F1 and then C2 = F2 then
1829                Add ('(');
1830
1831                if F1 = L1 then
1832                   Add ("0 .. 0 => ");
1833                end if;
1834
1835             else
1836                Add (' ');
1837             end if;
1838          end if;
1839       end if;
1840
1841       if C2 = F2 then
1842          Add ('(');
1843
1844          if F2 = L2 then
1845             Add ("0 .. 0 => ");
1846          end if;
1847
1848       else
1849          Add (' ');
1850       end if;
1851
1852       Add (S);
1853
1854       if C2 = L2 then
1855          Add (')');
1856
1857          if F1 > L1 then
1858             Add (';');
1859             Flush;
1860
1861          elsif C1 /= L1 then
1862             Add (',');
1863             Flush;
1864
1865          else
1866             Add (')');
1867             Add (';');
1868             Flush;
1869          end if;
1870
1871       else
1872          Add (',');
1873       end if;
1874    end Put;
1875
1876    ---------------
1877    -- Put_Edges --
1878    ---------------
1879
1880    procedure Put_Edges (File  : File_Descriptor; Title : String) is
1881       E  : Edge_Type;
1882       F1 : constant Natural := 1;
1883       L1 : constant Natural := Edges_Len - 1;
1884       M  : constant Natural := Max / 5;
1885
1886    begin
1887       Put (File, Title);
1888       New_Line (File);
1889
1890       --  Edges valid range is 1 .. Edge_Len - 1
1891
1892       for J in F1 .. L1 loop
1893          E := Get_Edges (J);
1894          Put (File, Image (J, M),     F1, L1, J, 1, 4, 1);
1895          Put (File, Image (E.X, M),   F1, L1, J, 1, 4, 2);
1896          Put (File, Image (E.Y, M),   F1, L1, J, 1, 4, 3);
1897          Put (File, Image (E.Key, M), F1, L1, J, 1, 4, 4);
1898       end loop;
1899    end Put_Edges;
1900
1901    ----------------------
1902    -- Put_Initial_Keys --
1903    ----------------------
1904
1905    procedure Put_Initial_Keys (File : File_Descriptor; Title : String) is
1906       F1 : constant Natural := 0;
1907       L1 : constant Natural := NK - 1;
1908       M  : constant Natural := Max / 5;
1909       K  : Key_Type;
1910
1911    begin
1912       Put (File, Title);
1913       New_Line (File);
1914
1915       for J in F1 .. L1 loop
1916          K := Get_Key (J);
1917          Put (File, Image (J, M),           F1, L1, J, 1, 3, 1);
1918          Put (File, Image (K.Edge, M),      F1, L1, J, 1, 3, 2);
1919          Put (File, Trim_Trailing_Nuls (WT.Table (Initial (J)).all),
1920                     F1, L1, J, 1, 3, 3);
1921       end loop;
1922    end Put_Initial_Keys;
1923
1924    --------------------
1925    -- Put_Int_Matrix --
1926    --------------------
1927
1928    procedure Put_Int_Matrix
1929      (File   : File_Descriptor;
1930       Title  : String;
1931       Table  : Integer;
1932       Len_1  : Natural;
1933       Len_2  : Natural)
1934    is
1935       F1 : constant Integer := 0;
1936       L1 : constant Integer := Len_1 - 1;
1937       F2 : constant Integer := 0;
1938       L2 : constant Integer := Len_2 - 1;
1939       Ix : Natural;
1940
1941    begin
1942       Put (File, Title);
1943       New_Line (File);
1944
1945       if Len_2 = 0 then
1946          for J in F1 .. L1 loop
1947             Ix := IT.Table (Table + J);
1948             Put (File, Image (Ix), 1, 0, 1, F1, L1, J);
1949          end loop;
1950
1951       else
1952          for J in F1 .. L1 loop
1953             for K in F2 .. L2 loop
1954                Ix := IT.Table (Table + J + K * Len_1);
1955                Put (File, Image (Ix), F1, L1, J, F2, L2, K);
1956             end loop;
1957          end loop;
1958       end if;
1959    end Put_Int_Matrix;
1960
1961    --------------------
1962    -- Put_Int_Vector --
1963    --------------------
1964
1965    procedure Put_Int_Vector
1966      (File   : File_Descriptor;
1967       Title  : String;
1968       Vector : Integer;
1969       Length : Natural)
1970    is
1971       F2 : constant Natural := 0;
1972       L2 : constant Natural := Length - 1;
1973
1974    begin
1975       Put (File, Title);
1976       New_Line (File);
1977
1978       for J in F2 .. L2 loop
1979          Put (File, Image (IT.Table (Vector + J)), 1, 0, 1, F2, L2, J);
1980       end loop;
1981    end Put_Int_Vector;
1982
1983    ----------------------
1984    -- Put_Reduced_Keys --
1985    ----------------------
1986
1987    procedure Put_Reduced_Keys (File : File_Descriptor; Title : String) is
1988       F1 : constant Natural := 0;
1989       L1 : constant Natural := NK - 1;
1990       M  : constant Natural := Max / 5;
1991       K  : Key_Type;
1992
1993    begin
1994       Put (File, Title);
1995       New_Line (File);
1996
1997       for J in F1 .. L1 loop
1998          K := Get_Key (J);
1999          Put (File, Image (J, M),           F1, L1, J, 1, 3, 1);
2000          Put (File, Image (K.Edge, M),      F1, L1, J, 1, 3, 2);
2001          Put (File, Trim_Trailing_Nuls (WT.Table (Reduced (J)).all),
2002                     F1, L1, J, 1, 3, 3);
2003       end loop;
2004    end Put_Reduced_Keys;
2005
2006    -----------------------
2007    -- Put_Used_Char_Set --
2008    -----------------------
2009
2010    procedure Put_Used_Char_Set (File : File_Descriptor; Title : String) is
2011       F : constant Natural := Character'Pos (Character'First);
2012       L : constant Natural := Character'Pos (Character'Last);
2013
2014    begin
2015       Put (File, Title);
2016       New_Line (File);
2017
2018       for J in Character'Range loop
2019          Put
2020            (File, Image (Get_Used_Char (J)), 1, 0, 1, F, L, Character'Pos (J));
2021       end loop;
2022    end Put_Used_Char_Set;
2023
2024    ----------------------
2025    -- Put_Vertex_Table --
2026    ----------------------
2027
2028    procedure Put_Vertex_Table (File : File_Descriptor; Title : String) is
2029       F1 : constant Natural := 0;
2030       L1 : constant Natural := NV - 1;
2031       M  : constant Natural := Max / 4;
2032       V  : Vertex_Type;
2033
2034    begin
2035       Put (File, Title);
2036       New_Line (File);
2037
2038       for J in F1 .. L1 loop
2039          V := Get_Vertices (J);
2040          Put (File, Image (J, M),       F1, L1, J, 1, 3, 1);
2041          Put (File, Image (V.First, M), F1, L1, J, 1, 3, 2);
2042          Put (File, Image (V.Last, M),  F1, L1, J, 1, 3, 3);
2043       end loop;
2044    end Put_Vertex_Table;
2045
2046    ------------
2047    -- Random --
2048    ------------
2049
2050    procedure Random (Seed : in out Natural) is
2051
2052       --  Park & Miller Standard Minimal using Schrage's algorithm to avoid
2053       --  overflow: Xn+1 = 16807 * Xn mod (2 ** 31 - 1)
2054
2055       R : Natural;
2056       Q : Natural;
2057       X : Integer;
2058
2059    begin
2060       R := Seed mod 127773;
2061       Q := Seed / 127773;
2062       X := 16807 * R - 2836 * Q;
2063
2064       Seed := (if X < 0 then X + 2147483647 else X);
2065    end Random;
2066
2067    -------------
2068    -- Reduced --
2069    -------------
2070
2071    function Reduced (K : Key_Id) return Word_Id is
2072    begin
2073       return K + NK + 1;
2074    end Reduced;
2075
2076    -----------------
2077    -- Resize_Word --
2078    -----------------
2079
2080    procedure Resize_Word (W : in out Word_Type; Len : Natural) is
2081       S1 : constant String := W.all;
2082       S2 : String (1 .. Len) := (others => ASCII.NUL);
2083       L  : constant Natural := S1'Length;
2084    begin
2085       if L /= Len then
2086          Free_Word (W);
2087          S2 (1 .. L) := S1;
2088          W := New_Word (S2);
2089       end if;
2090    end Resize_Word;
2091
2092    --------------------------
2093    -- Select_Char_Position --
2094    --------------------------
2095
2096    procedure Select_Char_Position is
2097
2098       type Vertex_Table_Type is array (Natural range <>) of Vertex_Type;
2099
2100       procedure Build_Identical_Keys_Sets
2101         (Table : in out Vertex_Table_Type;
2102          Last  : in out Natural;
2103          Pos   : Natural);
2104       --  Build a list of keys subsets that are identical with the current
2105       --  position selection plus Pos. Once this routine is called, reduced
2106       --  words are sorted by subsets and each item (First, Last) in Sets
2107       --  defines the range of identical keys.
2108       --  Need comment saying exactly what Last is ???
2109
2110       function Count_Different_Keys
2111         (Table : Vertex_Table_Type;
2112          Last  : Natural;
2113          Pos   : Natural) return Natural;
2114       --  For each subset in Sets, count the number of different keys if we add
2115       --  Pos to the current position selection.
2116
2117       Sel_Position : IT.Table_Type (1 .. Max_Key_Len);
2118       Last_Sel_Pos : Natural := 0;
2119       Max_Sel_Pos  : Natural := 0;
2120
2121       -------------------------------
2122       -- Build_Identical_Keys_Sets --
2123       -------------------------------
2124
2125       procedure Build_Identical_Keys_Sets
2126         (Table : in out Vertex_Table_Type;
2127          Last  : in out Natural;
2128          Pos   : Natural)
2129       is
2130          S : constant Vertex_Table_Type := Table (Table'First .. Last);
2131          C : constant Natural           := Pos;
2132          --  Shortcuts (why are these not renames ???)
2133
2134          F : Integer;
2135          L : Integer;
2136          --  First and last words of a subset
2137
2138          Offset : Natural;
2139          --  GNAT.Heap_Sort assumes that the first array index is 1. Offset
2140          --  defines the translation to operate.
2141
2142          function Lt (L, R : Natural) return Boolean;
2143          procedure Move (From : Natural; To : Natural);
2144          --  Subprograms needed by GNAT.Heap_Sort_G
2145
2146          --------
2147          -- Lt --
2148          --------
2149
2150          function Lt (L, R : Natural) return Boolean is
2151             C     : constant Natural := Pos;
2152             Left  : Natural;
2153             Right : Natural;
2154
2155          begin
2156             if L = 0 then
2157                Left  := NK;
2158                Right := Offset + R;
2159             elsif R = 0 then
2160                Left  := Offset + L;
2161                Right := NK;
2162             else
2163                Left  := Offset + L;
2164                Right := Offset + R;
2165             end if;
2166
2167             return WT.Table (Left)(C) < WT.Table (Right)(C);
2168          end Lt;
2169
2170          ----------
2171          -- Move --
2172          ----------
2173
2174          procedure Move (From : Natural; To : Natural) is
2175             Target, Source : Natural;
2176
2177          begin
2178             if From = 0 then
2179                Source := NK;
2180                Target := Offset + To;
2181             elsif To = 0 then
2182                Source := Offset + From;
2183                Target := NK;
2184             else
2185                Source := Offset + From;
2186                Target := Offset + To;
2187             end if;
2188
2189             WT.Table (Target) := WT.Table (Source);
2190             WT.Table (Source) := null;
2191          end Move;
2192
2193          package Sorting is new GNAT.Heap_Sort_G (Move, Lt);
2194
2195       --  Start of processing for Build_Identical_Key_Sets
2196
2197       begin
2198          Last := 0;
2199
2200          --  For each subset in S, extract the new subsets we have by adding C
2201          --  in the position selection.
2202
2203          for J in S'Range loop
2204             if S (J).First = S (J).Last then
2205                F := S (J).First;
2206                L := S (J).Last;
2207                Last := Last + 1;
2208                Table (Last) := (F, L);
2209
2210             else
2211                Offset := Reduced (S (J).First) - 1;
2212                Sorting.Sort (S (J).Last - S (J).First + 1);
2213
2214                F := S (J).First;
2215                L := F;
2216                for N in S (J).First .. S (J).Last loop
2217
2218                   --  For the last item, close the last subset
2219
2220                   if N = S (J).Last then
2221                      Last := Last + 1;
2222                      Table (Last) := (F, N);
2223
2224                   --  Two contiguous words are identical when they have the
2225                   --  same Cth character.
2226
2227                   elsif WT.Table (Reduced (N))(C) =
2228                         WT.Table (Reduced (N + 1))(C)
2229                   then
2230                      L := N + 1;
2231
2232                   --  Find a new subset of identical keys. Store the current
2233                   --  one and create a new subset.
2234
2235                   else
2236                      Last := Last + 1;
2237                      Table (Last) := (F, L);
2238                      F := N + 1;
2239                      L := F;
2240                   end if;
2241                end loop;
2242             end if;
2243          end loop;
2244       end Build_Identical_Keys_Sets;
2245
2246       --------------------------
2247       -- Count_Different_Keys --
2248       --------------------------
2249
2250       function Count_Different_Keys
2251         (Table : Vertex_Table_Type;
2252          Last  : Natural;
2253          Pos   : Natural) return Natural
2254       is
2255          N : array (Character) of Natural;
2256          C : Character;
2257          T : Natural := 0;
2258
2259       begin
2260          --  For each subset, count the number of words that are still
2261          --  different when we include Pos in the position selection. Only
2262          --  focus on this position as the other positions already produce
2263          --  identical keys.
2264
2265          for S in 1 .. Last loop
2266
2267             --  Count the occurrences of the different characters
2268
2269             N := (others => 0);
2270             for K in Table (S).First .. Table (S).Last loop
2271                C := WT.Table (Reduced (K))(Pos);
2272                N (C) := N (C) + 1;
2273             end loop;
2274
2275             --  Update the number of different keys. Each character used
2276             --  denotes a different key.
2277
2278             for J in N'Range loop
2279                if N (J) > 0 then
2280                   T := T + 1;
2281                end if;
2282             end loop;
2283          end loop;
2284
2285          return T;
2286       end Count_Different_Keys;
2287
2288    --  Start of processing for Select_Char_Position
2289
2290    begin
2291       --  Initialize the reduced words set
2292
2293       for K in 0 .. NK - 1 loop
2294          WT.Table (Reduced (K)) := New_Word (WT.Table (Initial (K)).all);
2295       end loop;
2296
2297       declare
2298          Differences          : Natural;
2299          Max_Differences      : Natural := 0;
2300          Old_Differences      : Natural;
2301          Max_Diff_Sel_Pos     : Natural := 0; -- init to kill warning
2302          Max_Diff_Sel_Pos_Idx : Natural := 0; -- init to kill warning
2303          Same_Keys_Sets_Table : Vertex_Table_Type (1 .. NK);
2304          Same_Keys_Sets_Last  : Natural := 1;
2305
2306       begin
2307          for C in Sel_Position'Range loop
2308             Sel_Position (C) := C;
2309          end loop;
2310
2311          Same_Keys_Sets_Table (1) := (0, NK - 1);
2312
2313          loop
2314             --  Preserve maximum number of different keys and check later on
2315             --  that this value is strictly incrementing. Otherwise, it means
2316             --  that two keys are strictly identical.
2317
2318             Old_Differences := Max_Differences;
2319
2320             --  The first position should not exceed the minimum key length.
2321             --  Otherwise, we may end up with an empty word once reduced.
2322
2323             Max_Sel_Pos :=
2324               (if Last_Sel_Pos = 0 then Min_Key_Len else Max_Key_Len);
2325
2326             --  Find which position increases more the number of differences
2327
2328             for J in Last_Sel_Pos + 1 .. Max_Sel_Pos loop
2329                Differences := Count_Different_Keys
2330                  (Same_Keys_Sets_Table,
2331                   Same_Keys_Sets_Last,
2332                   Sel_Position (J));
2333
2334                if Verbose then
2335                   Put (Output,
2336                        "Selecting position" & Sel_Position (J)'Img &
2337                          " results in" & Differences'Img &
2338                          " differences");
2339                   New_Line (Output);
2340                end if;
2341
2342                if Differences > Max_Differences then
2343                   Max_Differences      := Differences;
2344                   Max_Diff_Sel_Pos     := Sel_Position (J);
2345                   Max_Diff_Sel_Pos_Idx := J;
2346                end if;
2347             end loop;
2348
2349             if Old_Differences = Max_Differences then
2350                raise Program_Error with "some keys are identical";
2351             end if;
2352
2353             --  Insert selected position and sort Sel_Position table
2354
2355             Last_Sel_Pos := Last_Sel_Pos + 1;
2356             Sel_Position (Last_Sel_Pos + 1 .. Max_Diff_Sel_Pos_Idx) :=
2357               Sel_Position (Last_Sel_Pos .. Max_Diff_Sel_Pos_Idx - 1);
2358             Sel_Position (Last_Sel_Pos) := Max_Diff_Sel_Pos;
2359
2360             for P in 1 .. Last_Sel_Pos - 1 loop
2361                if Max_Diff_Sel_Pos < Sel_Position (P) then
2362                   Sel_Position (P + 1 .. Last_Sel_Pos) :=
2363                     Sel_Position (P .. Last_Sel_Pos - 1);
2364                   Sel_Position (P) := Max_Diff_Sel_Pos;
2365                   exit;
2366                end if;
2367             end loop;
2368
2369             exit when Max_Differences = NK;
2370
2371             Build_Identical_Keys_Sets
2372               (Same_Keys_Sets_Table,
2373                Same_Keys_Sets_Last,
2374                Max_Diff_Sel_Pos);
2375
2376             if Verbose then
2377                Put (Output,
2378                     "Selecting position" & Max_Diff_Sel_Pos'Img &
2379                       " results in" & Max_Differences'Img &
2380                       " differences");
2381                New_Line (Output);
2382                Put (Output, "--");
2383                New_Line (Output);
2384                for J in 1 .. Same_Keys_Sets_Last loop
2385                   for K in
2386                     Same_Keys_Sets_Table (J).First ..
2387                     Same_Keys_Sets_Table (J).Last
2388                   loop
2389                      Put (Output,
2390                           Trim_Trailing_Nuls (WT.Table (Reduced (K)).all));
2391                      New_Line (Output);
2392                   end loop;
2393                   Put (Output, "--");
2394                   New_Line (Output);
2395                end loop;
2396             end if;
2397          end loop;
2398       end;
2399
2400       Char_Pos_Set_Len := Last_Sel_Pos;
2401       Char_Pos_Set := Allocate (Char_Pos_Set_Len);
2402
2403       for C in 1 .. Last_Sel_Pos loop
2404          Set_Char_Pos (C - 1, Sel_Position (C));
2405       end loop;
2406    end Select_Char_Position;
2407
2408    --------------------------
2409    -- Select_Character_Set --
2410    --------------------------
2411
2412    procedure Select_Character_Set is
2413       Last : Natural := 0;
2414       Used : array (Character) of Boolean := (others => False);
2415       Char : Character;
2416
2417    begin
2418       for J in 0 .. NK - 1 loop
2419          for K in 0 .. Char_Pos_Set_Len - 1 loop
2420             Char := WT.Table (Initial (J))(Get_Char_Pos (K));
2421             exit when Char = ASCII.NUL;
2422             Used (Char) := True;
2423          end loop;
2424       end loop;
2425
2426       Used_Char_Set_Len := 256;
2427       Used_Char_Set := Allocate (Used_Char_Set_Len);
2428
2429       for J in Used'Range loop
2430          if Used (J) then
2431             Set_Used_Char (J, Last);
2432             Last := Last + 1;
2433          else
2434             Set_Used_Char (J, 0);
2435          end if;
2436       end loop;
2437    end Select_Character_Set;
2438
2439    ------------------
2440    -- Set_Char_Pos --
2441    ------------------
2442
2443    procedure Set_Char_Pos (P : Natural; Item : Natural) is
2444       N : constant Natural := Char_Pos_Set + P;
2445    begin
2446       IT.Table (N) := Item;
2447    end Set_Char_Pos;
2448
2449    ---------------
2450    -- Set_Edges --
2451    ---------------
2452
2453    procedure Set_Edges (F : Natural; Item : Edge_Type) is
2454       N : constant Natural := Edges + (F * Edge_Size);
2455    begin
2456       IT.Table (N)     := Item.X;
2457       IT.Table (N + 1) := Item.Y;
2458       IT.Table (N + 2) := Item.Key;
2459    end Set_Edges;
2460
2461    ---------------
2462    -- Set_Graph --
2463    ---------------
2464
2465    procedure Set_Graph (N : Natural; Item : Integer) is
2466    begin
2467       IT.Table (G + N) := Item;
2468    end Set_Graph;
2469
2470    -------------
2471    -- Set_Key --
2472    -------------
2473
2474    procedure Set_Key (N : Key_Id; Item : Key_Type) is
2475    begin
2476       IT.Table (Keys + N) := Item.Edge;
2477    end Set_Key;
2478
2479    ---------------
2480    -- Set_Table --
2481    ---------------
2482
2483    procedure Set_Table (T : Integer; X, Y : Natural; Item : Natural) is
2484       N : constant Natural := T + ((Y * T1_Len) + X);
2485    begin
2486       IT.Table (N) := Item;
2487    end Set_Table;
2488
2489    -------------------
2490    -- Set_Used_Char --
2491    -------------------
2492
2493    procedure Set_Used_Char (C : Character; Item : Natural) is
2494       N : constant Natural := Used_Char_Set + Character'Pos (C);
2495    begin
2496       IT.Table (N) := Item;
2497    end Set_Used_Char;
2498
2499    ------------------
2500    -- Set_Vertices --
2501    ------------------
2502
2503    procedure Set_Vertices (F : Natural; Item : Vertex_Type) is
2504       N : constant Natural := Vertices + (F * Vertex_Size);
2505    begin
2506       IT.Table (N)     := Item.First;
2507       IT.Table (N + 1) := Item.Last;
2508    end Set_Vertices;
2509
2510    ---------
2511    -- Sum --
2512    ---------
2513
2514    function Sum
2515      (Word  : Word_Type;
2516       Table : Table_Id;
2517       Opt   : Optimization) return Natural
2518    is
2519       S : Natural := 0;
2520       R : Natural;
2521
2522    begin
2523       case Opt is
2524          when CPU_Time =>
2525             for J in 0 .. T1_Len - 1 loop
2526                exit when Word (J + 1) = ASCII.NUL;
2527                R := Get_Table (Table, J, Get_Used_Char (Word (J + 1)));
2528                S := (S + R) mod NV;
2529             end loop;
2530
2531          when Memory_Space =>
2532             for J in 0 .. T1_Len - 1 loop
2533                exit when Word (J + 1) = ASCII.NUL;
2534                R := Get_Table (Table, J, 0);
2535                S := (S + R * Character'Pos (Word (J + 1))) mod NV;
2536             end loop;
2537       end case;
2538
2539       return S;
2540    end Sum;
2541
2542    ------------------------
2543    -- Trim_Trailing_Nuls --
2544    ------------------------
2545
2546    function Trim_Trailing_Nuls (Str : String) return String is
2547    begin
2548       for J in reverse Str'Range loop
2549          if Str (J) /= ASCII.NUL then
2550             return Str (Str'First .. J);
2551          end if;
2552       end loop;
2553
2554       return Str;
2555    end Trim_Trailing_Nuls;
2556
2557    ---------------
2558    -- Type_Size --
2559    ---------------
2560
2561    function Type_Size (L : Natural) return Natural is
2562    begin
2563       if L <= 2 ** 8 then
2564          return 8;
2565       elsif L <= 2 ** 16 then
2566          return 16;
2567       else
2568          return 32;
2569       end if;
2570    end Type_Size;
2571
2572    -----------
2573    -- Value --
2574    -----------
2575
2576    function Value
2577      (Name : Table_Name;
2578       J    : Natural;
2579       K    : Natural := 0) return Natural
2580    is
2581    begin
2582       case Name is
2583          when Character_Position =>
2584             return Get_Char_Pos (J);
2585
2586          when Used_Character_Set =>
2587             return Get_Used_Char (Character'Val (J));
2588
2589          when Function_Table_1 =>
2590             return Get_Table (T1, J, K);
2591
2592          when Function_Table_2 =>
2593             return Get_Table (T2, J, K);
2594
2595          when Graph_Table =>
2596             return Get_Graph (J);
2597       end case;
2598    end Value;
2599
2600 end GNAT.Perfect_Hash_Generators;