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