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