diff options
Diffstat (limited to 'gcc/ada/g-pehage.adb')
| -rw-r--r-- | gcc/ada/g-pehage.adb | 2400 |
1 files changed, 2400 insertions, 0 deletions
diff --git a/gcc/ada/g-pehage.adb b/gcc/ada/g-pehage.adb new file mode 100644 index 00000000000..91ec4182d7d --- /dev/null +++ b/gcc/ada/g-pehage.adb @@ -0,0 +1,2400 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- 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 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-2003 Ada Core Technologies, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Exceptions; use Ada.Exceptions; +with Ada.IO_Exceptions; use Ada.IO_Exceptions; + +with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A; +with GNAT.OS_Lib; use GNAT.OS_Lib; +with GNAT.Table; + +package body GNAT.Perfect_Hash.Generators is + + -- We are using the algorithm of J. Czech as described in Zbigniew + -- J. Czech, George Havas, and Bohdan S. Majewski ``An Optimal + -- Algorithm for Generating Minimal Perfect Hash Functions'', + -- Information Processing Letters, 43(1992) pp.257-264, Oct.1992 + + -- This minimal perfect hash function generator is based on random + -- graphs and produces a hash function of the form: + + -- h (w) = (g (f1 (w)) + g (f2 (w))) mod m + + -- where f1 and f2 are functions that map strings into integers, + -- and g is a function that maps integers into [0, m-1]. h can be + -- order preserving. For instance, let W = {w_0, ..., w_i, ..., + -- w_m-1}, h can be defined such that h (w_i) = i. + + -- This algorithm defines two possible constructions of f1 and + -- f2. Method b) stores the hash function in less memory space at + -- the expense of greater CPU time. + + -- a) fk (w) = sum (for i in 1 .. length (w)) (Tk (i, w (i))) mod n + + -- size (Tk) = max (for w in W) (length (w)) * size (used char set) + + -- b) fk (w) = sum (for i in 1 .. length (w)) (Tk (i) * w (i)) mod n + + -- size (Tk) = max (for w in W) (length (w)) but the table + -- lookups are replaced by multiplications. + + -- where Tk values are randomly generated. n is defined later on + -- but the algorithm recommends to use a value a little bit + -- greater than 2m. Note that for large values of m, the main + -- memory space requirements comes from the memory space for + -- storing function g (>= 2m entries). + + -- Random graphs are frequently used to solve difficult problems + -- that do not have polynomial solutions. This algorithm is based + -- on a weighted undirected graph. It comprises two steps: mapping + -- and assigment. + + -- In the mapping step, a graph G = (V, E) is constructed, where V + -- = {0, 1, ..., n-1} and E = {(for w in W) (f1 (w), f2 (w))}. In + -- order for the assignment step to be successful, G has to be + -- acyclic. To have a high probability of generating an acyclic + -- graph, n >= 2m. If it is not acyclic, Tk have to be regenerated. + + -- In the assignment step, the algorithm builds function g. As G + -- is acyclic, there is a vertex v1 with only one neighbor v2. Let + -- w_i be the word such that v1 = f1 (w_i) and v2 = f2 (w_i). Let + -- g (v1) = 0 by construction and g (v2) = (i - g (v1)) mod n (or + -- to be general, (h (i) - g (v1) mod n). If word w_j is such that + -- v2 = f1 (w_j) and v3 = f2 (w_j), g (v3) = (j - g (v2)) mod n + -- (or to be general, (h (j) - g (v2)) mod n). If w_i has no + -- neighbor, then another vertex is selected. The algorithm + -- traverses G to assign values to all the vertices. It cannot + -- assign a value to an already assigned vertex as G is acyclic. + + subtype Word_Id is Integer; + subtype Key_Id is Integer; + subtype Vertex_Id is Integer; + subtype Edge_Id is Integer; + subtype Table_Id is Integer; + + No_Vertex : constant Vertex_Id := -1; + No_Edge : constant Edge_Id := -1; + No_Table : constant Table_Id := -1; + + Max_Word_Length : constant := 32; + subtype Word_Type is String (1 .. Max_Word_Length); + Null_Word : constant Word_Type := (others => ASCII.NUL); + -- Store keyword in a word. Note that the length of word is + -- limited to 32 characters. + + type Key_Type is record + Edge : Edge_Id; + end record; + -- A key corresponds to an edge in the algorithm graph. + + type Vertex_Type is record + First : Edge_Id; + Last : Edge_Id; + end record; + -- A vertex can be involved in several edges. First and Last are + -- the bounds of an array of edges stored in a global edge table. + + type Edge_Type is record + X : Vertex_Id; + Y : Vertex_Id; + Key : Key_Id; + end record; + -- An edge is a peer of vertices. In the algorithm, a key + -- is associated to an edge. + + package WT is new GNAT.Table (Word_Type, Word_Id, 0, 32, 32); + package IT is new GNAT.Table (Integer, Integer, 0, 32, 32); + -- The two main tables. IT is used to store several tables of + -- components containing only integers. + + function Image (Int : Integer; W : Natural := 0) return String; + function Image (Str : String; W : Natural := 0) return String; + -- Return a string which includes string Str or integer Int + -- preceded by leading spaces if required by width W. + + Output : File_Descriptor renames GNAT.OS_Lib.Standout; + -- Shortcuts + + Max : constant := 78; + Last : Natural := 0; + Line : String (1 .. Max); + -- Use this line to provide buffered IO + + procedure Add (C : Character); + procedure Add (S : String); + -- Add a character or a string in Line and update Last + + procedure Put + (F : File_Descriptor; + S : String; + F1 : Natural; + L1 : Natural; + C1 : Natural; + F2 : Natural; + L2 : Natural; + C2 : Natural); + -- Write string S into file F as a element of an array of one or + -- two dimensions. Fk (resp. Lk and Ck) indicates the first (resp + -- last and current) index in the k-th dimension. If F1 = L1 the + -- array is considered as a one dimension array. This dimension is + -- described by F2 and L2. This routine takes care of all the + -- parenthesis, spaces and commas needed to format correctly the + -- array. Moreover, the array is well indented and is wrapped to + -- fit in a 80 col line. When the line is full, the routine writes + -- it into file F. When the array is completed, the routine adds a + -- semi-colon and writes the line into file F. + + procedure New_Line + (F : File_Descriptor); + -- Simulate Ada.Text_IO.New_Line with GNAT.OS_Lib + + procedure Put + (F : File_Descriptor; + S : String); + -- Simulate Ada.Text_IO.Put with GNAT.OS_Lib + + procedure Put_Used_Char_Set + (File : File_Descriptor; + Title : String); + -- Output a title and a used character set + + procedure Put_Int_Vector + (File : File_Descriptor; + Title : String; + Root : Integer; + Length : Natural); + -- Output a title and a vector + + procedure Put_Int_Matrix + (File : File_Descriptor; + Title : String; + Table : Table_Id); + -- Output a title and a matrix. When the matrix has only one + -- non-empty dimension, it is output as a vector. + + procedure Put_Edges + (File : File_Descriptor; + Title : String); + -- Output a title and an edge table + + procedure Put_Initial_Keys + (File : File_Descriptor; + Title : String); + -- Output a title and a key table + + procedure Put_Reduced_Keys + (File : File_Descriptor; + Title : String); + -- Output a title and a key table + + procedure Put_Vertex_Table + (File : File_Descriptor; + Title : String); + -- Output a title and a vertex table + + ---------------------------------- + -- Character Position Selection -- + ---------------------------------- + + -- We reduce the maximum key size by selecting representative + -- positions in these keys. We build a matrix with one word per + -- line. We fill the remaining space of a line with ASCII.NUL. The + -- heuristic selects the position that induces the minimum number + -- of collisions. If there are collisions, select another position + -- on the reduced key set responsible of the collisions. Apply the + -- heuristic until there is no more collision. + + procedure Apply_Position_Selection; + -- Apply Position selection and build the reduced key table + + procedure Parse_Position_Selection (Argument : String); + -- Parse Argument and compute the position set. Argument is a + -- list of substrings separated by commas. Each substring + -- represents a position or a range of positions (like x-y). + + procedure Select_Character_Set; + -- Define an optimized used character set like Character'Pos in + -- order not to allocate tables of 256 entries. + + procedure Select_Char_Position; + -- Find a min char position set in order to reduce the max key + -- length. The heuristic selects the position that induces the + -- minimum number of collisions. If there are collisions, select + -- another position on the reduced key set responsible of the + -- collisions. Apply the heuristic until there is no collision. + + ----------------------------- + -- Random Graph Generation -- + ----------------------------- + + procedure Random (Seed : in out Natural); + -- Simulate Ada.Discrete_Numerics.Random. + + procedure Generate_Mapping_Table + (T : Table_Id; + L1 : Natural; + L2 : Natural; + S : in out Natural); + -- Random generation of the tables below. T is already allocated. + + procedure Generate_Mapping_Tables + (Opt : Optimization; + S : in out Natural); + -- Generate the mapping tables T1 and T2. They are used to define : + -- fk (w) = sum (for i in 1 .. length (w)) (Tk (i, w (i))) mod n. + -- Keys, NK and Chars are used to compute the matrix size. + + --------------------------- + -- Algorithm Computation -- + --------------------------- + + procedure Compute_Edges_And_Vertices (Opt : Optimization); + -- Compute the edge and vertex tables. These are empty when a self + -- loop is detected (f1 (w) = f2 (w)). The edge table is sorted by + -- X value and then Y value. Keys is the key table and NK the + -- number of keys. Chars is the set of characters really used in + -- Keys. NV is the number of vertices recommended by the + -- algorithm. T1 and T2 are the mapping tables needed to compute + -- f1 (w) and f2 (w). + + function Acyclic return Boolean; + -- Return True when the graph is acyclic. Vertices is the current + -- vertex table and Edges the current edge table. + + procedure Assign_Values_To_Vertices; + -- Execute the assignment step of the algorithm. Keys is the + -- current key table. Vertices and Edges represent the random + -- graph. G is the result of the assignment step such that: + -- h (w) = (g (f1 (w)) + g (f2 (w))) mod m + + function Sum + (Word : Word_Type; + Table : Table_Id; + Opt : Optimization) + return Natural; + -- For an optimization of CPU_Time return + -- fk (w) = sum (for i in 1 .. length (w)) (Tk (i, w (i))) mod n + -- For an optimization of Memory_Space return + -- fk (w) = sum (for i in 1 .. length (w)) (Tk (i) * w (i)) mod n + -- Here NV = n + + ------------------------------- + -- Internal Table Management -- + ------------------------------- + + function Allocate (N : Natural; S : Natural) return Table_Id; + -- procedure Deallocate (N : Natural; S : Natural); + + ---------- + -- Keys -- + ---------- + + Key_Size : constant := 1; + Keys : Table_Id := No_Table; + NK : Natural; + -- NK : Number of Keys + + function Initial (K : Key_Id) return Word_Id; + pragma Inline (Initial); + + function Reduced (K : Key_Id) return Word_Id; + pragma Inline (Reduced); + + function Get_Key (F : Key_Id) return Key_Type; + procedure Set_Key (F : Key_Id; Item : Key_Type); + -- Comments needed here ??? + + ------------------ + -- Char_Pos_Set -- + ------------------ + + Char_Pos_Size : constant := 1; + Char_Pos_Set : Table_Id := No_Table; + Char_Pos_Set_Len : Natural; + -- Character Selected Position Set + + function Get_Char_Pos (P : Natural) return Natural; + procedure Set_Char_Pos (P : Natural; Item : Natural); + -- Comments needed here ??? + + ------------------- + -- Used_Char_Set -- + ------------------- + + Used_Char_Size : constant := 1; + Used_Char_Set : Table_Id := No_Table; + Used_Char_Set_Len : Natural; + -- Used Character Set : Define a new character mapping. When all + -- the characters are not present in the keys, in order to reduce + -- the size of some tables, we redefine the character mapping. + + function Get_Used_Char (C : Character) return Natural; + procedure Set_Used_Char (C : Character; Item : Natural); + + ------------------- + -- Random Tables -- + ------------------- + + Rand_Tab_Item_Size : constant := 1; + T1 : Table_Id := No_Table; + T2 : Table_Id := No_Table; + Rand_Tab_Len_1 : Natural; + Rand_Tab_Len_2 : Natural; + -- T1 : Values table to compute F1 + -- T2 : Values table to compute F2 + + function Get_Rand_Tab (T : Integer; X, Y : Natural) return Natural; + procedure Set_Rand_Tab (T : Integer; X, Y : Natural; Item : Natural); + + ------------------ + -- Random Graph -- + ------------------ + + Graph_Item_Size : constant := 1; + G : Table_Id := No_Table; + Graph_Len : Natural; + -- G : Values table to compute G + + function Get_Graph (F : Natural) return Integer; + procedure Set_Graph (F : Natural; Item : Integer); + -- Comments needed ??? + + ----------- + -- Edges -- + ----------- + + Edge_Size : constant := 3; + Edges : Table_Id := No_Table; + Edges_Len : Natural; + -- Edges : Edge table of the random graph G + + function Get_Edges (F : Natural) return Edge_Type; + procedure Set_Edges (F : Natural; Item : Edge_Type); + + -------------- + -- Vertices -- + -------------- + + Vertex_Size : constant := 2; + + Vertices : Table_Id := No_Table; + -- Vertex table of the random graph G + + NV : Natural; + -- Number of Vertices + + function Get_Vertices (F : Natural) return Vertex_Type; + procedure Set_Vertices (F : Natural; Item : Vertex_Type); + -- Comments needed ??? + + K2V : Float; + -- Ratio between Keys and Vertices (parameter of Czech's algorithm) + + Opt : Optimization; + -- Optimization mode (memory vs CPU) + + MKL : Natural; + -- Maximum of all the word length + + S : Natural; + -- Seed + + function Type_Size (L : Natural) return Natural; + -- Given the last L of an unsigned integer type T, return its size + + ------------- + -- Acyclic -- + ------------- + + function Acyclic return Boolean + is + Marks : array (0 .. NV - 1) of Vertex_Id := (others => No_Vertex); + + function Traverse + (Edge : Edge_Id; + Mark : Vertex_Id) + return Boolean; + -- Propagate Mark from X to Y. X is already marked. Mark Y and + -- propagate it to the edges of Y except the one representing + -- the same key. Return False when Y is marked with Mark. + + -------------- + -- Traverse -- + -------------- + + function Traverse + (Edge : Edge_Id; + Mark : Vertex_Id) + return Boolean + is + E : constant Edge_Type := Get_Edges (Edge); + K : constant Key_Id := E.Key; + Y : constant Vertex_Id := E.Y; + M : constant Vertex_Id := Marks (E.Y); + V : Vertex_Type; + + begin + if M = Mark then + return False; + + elsif M = No_Vertex then + Marks (Y) := Mark; + V := Get_Vertices (Y); + + for J in V.First .. V.Last loop + + -- Do not propagate to the edge representing the same key. + + if Get_Edges (J).Key /= K + and then not Traverse (J, Mark) + then + return False; + end if; + end loop; + end if; + + return True; + end Traverse; + + Edge : Edge_Type; + + -- Start of processing for Acyclic + + begin + -- Edges valid range is + + for J in 1 .. Edges_Len - 1 loop + + Edge := Get_Edges (J); + + -- Mark X of E when it has not been already done + + if Marks (Edge.X) = No_Vertex then + Marks (Edge.X) := Edge.X; + end if; + + -- Traverse E when this has not already been done + + if Marks (Edge.Y) = No_Vertex + and then not Traverse (J, Edge.X) + then + return False; + end if; + end loop; + + return True; + end Acyclic; + + --------- + -- Add -- + --------- + + procedure Add (C : Character) is + begin + Line (Last + 1) := C; + Last := Last + 1; + end Add; + + --------- + -- Add -- + --------- + + procedure Add (S : String) is + Len : constant Natural := S'Length; + + begin + Line (Last + 1 .. Last + Len) := S; + Last := Last + Len; + end Add; + + -------------- + -- Allocate -- + -------------- + + function Allocate (N : Natural; S : Natural) return Table_Id is + L : constant Integer := IT.Last; + + begin + IT.Set_Last (L + N * S); + return L + 1; + end Allocate; + + ------------------------------ + -- Apply_Position_Selection -- + ------------------------------ + + procedure Apply_Position_Selection is + begin + WT.Set_Last (2 * NK - 1); + for J in 0 .. NK - 1 loop + declare + I_Word : constant Word_Type := WT.Table (Initial (J)); + R_Word : Word_Type := Null_Word; + Index : Natural := I_Word'First - 1; + + begin + -- Select the characters of Word included in the + -- position selection. + + for C in 0 .. Char_Pos_Set_Len - 1 loop + exit when I_Word (Get_Char_Pos (C)) = ASCII.NUL; + Index := Index + 1; + R_Word (Index) := I_Word (Get_Char_Pos (C)); + end loop; + + -- Build the new table with the reduced word + + WT.Table (Reduced (J)) := R_Word; + Set_Key (J, (Edge => No_Edge)); + end; + end loop; + end Apply_Position_Selection; + + ------------- + -- Compute -- + ------------- + + procedure Compute (Position : String := Default_Position) is + begin + Keys := Allocate (NK, Key_Size); + + if Verbose then + Put_Initial_Keys (Output, "Initial Key Table"); + end if; + + if Position'Length /= 0 then + Parse_Position_Selection (Position); + else + Select_Char_Position; + end if; + + if Verbose then + Put_Int_Vector + (Output, "Char Position Set", Char_Pos_Set, Char_Pos_Set_Len); + end if; + + Apply_Position_Selection; + + if Verbose then + Put_Reduced_Keys (Output, "Reduced Keys Table"); + end if; + + Select_Character_Set; + + if Verbose then + Put_Used_Char_Set (Output, "Character Position Table"); + end if; + + -- Perform Czech's algorithm + + loop + Generate_Mapping_Tables (Opt, S); + Compute_Edges_And_Vertices (Opt); + + -- When graph is not empty (no self-loop from previous + -- operation) and not acyclic. + + exit when 0 < Edges_Len and then Acyclic; + end loop; + + Assign_Values_To_Vertices; + end Compute; + + ------------------------------- + -- Assign_Values_To_Vertices -- + ------------------------------- + + procedure Assign_Values_To_Vertices is + X : Vertex_Id; + + procedure Assign (X : Vertex_Id); + -- Execute assignment on X's neighbors except the vertex that + -- we are coming from which is already assigned. + + ------------ + -- Assign -- + ------------ + + procedure Assign (X : Vertex_Id) + is + E : Edge_Type; + V : constant Vertex_Type := Get_Vertices (X); + + begin + for J in V.First .. V.Last loop + E := Get_Edges (J); + if Get_Graph (E.Y) = -1 then + Set_Graph (E.Y, (E.Key - Get_Graph (X)) mod NK); + Assign (E.Y); + end if; + end loop; + end Assign; + + -- Start of processing for Assign_Values_To_Vertices + + begin + -- Value -1 denotes an unitialized value as it is supposed to + -- be in the range 0 .. NK. + + if G = No_Table then + Graph_Len := NV; + G := Allocate (Graph_Len, Graph_Item_Size); + end if; + + for J in 0 .. Graph_Len - 1 loop + Set_Graph (J, -1); + end loop; + + for K in 0 .. NK - 1 loop + X := Get_Edges (Get_Key (K).Edge).X; + + if Get_Graph (X) = -1 then + Set_Graph (X, 0); + Assign (X); + end if; + end loop; + + for J in 0 .. Graph_Len - 1 loop + if Get_Graph (J) = -1 then + Set_Graph (J, 0); + end if; + end loop; + + if Verbose then + Put_Int_Vector (Output, "Assign Values To Vertices", G, Graph_Len); + end if; + end Assign_Values_To_Vertices; + + -------------------------------- + -- Compute_Edges_And_Vertices -- + -------------------------------- + + procedure Compute_Edges_And_Vertices (Opt : Optimization) is + X : Natural; + Y : Natural; + Key : Key_Type; + Edge : Edge_Type; + Vertex : Vertex_Type; + Not_Acyclic : Boolean := False; + + procedure Move (From : Natural; To : Natural); + function Lt (L, R : Natural) return Boolean; + -- Subprograms needed for GNAT.Heap_Sort_A + + ---------- + -- Move -- + ---------- + + procedure Move (From : Natural; To : Natural) is + begin + Set_Edges (To, Get_Edges (From)); + end Move; + + -------- + -- Lt -- + -------- + + function Lt (L, R : Natural) return Boolean is + EL : constant Edge_Type := Get_Edges (L); + ER : constant Edge_Type := Get_Edges (R); + + begin + return EL.X < ER.X or else (EL.X = ER.X and then EL.Y < ER.Y); + end Lt; + + -- Start of processing for Compute_Edges_And_Vertices + + begin + -- We store edges from 1 to 2 * NK and leave + -- zero alone in order to use GNAT.Heap_Sort_A. + + Edges_Len := 2 * NK + 1; + + if Edges = No_Table then + Edges := Allocate (Edges_Len, Edge_Size); + end if; + + if Vertices = No_Table then + Vertices := Allocate (NV, Vertex_Size); + end if; + + for J in 0 .. NV - 1 loop + Set_Vertices (J, (No_Vertex, No_Vertex - 1)); + end loop; + + -- For each w, X = f1 (w) and Y = f2 (w) + + for J in 0 .. NK - 1 loop + Key := Get_Key (J); + Key.Edge := No_Edge; + Set_Key (J, Key); + + X := Sum (WT.Table (Reduced (J)), T1, Opt); + Y := Sum (WT.Table (Reduced (J)), T2, Opt); + + -- Discard T1 and T2 as soon as we discover a self loop + + if X = Y then + Not_Acyclic := True; + exit; + end if; + + -- We store (X, Y) and (Y, X) to ease assignment step + + Set_Edges (2 * J + 1, (X, Y, J)); + Set_Edges (2 * J + 2, (Y, X, J)); + end loop; + + -- Return an empty graph when self loop detected + + if Not_Acyclic then + Edges_Len := 0; + + else + if Verbose then + Put_Edges (Output, "Unsorted Edge Table"); + Put_Int_Matrix (Output, "Function Table 1", T1); + Put_Int_Matrix (Output, "Function Table 2", T2); + end if; + + -- Enforce consistency between edges and keys. Construct + -- Vertices and compute the list of neighbors of a vertex + -- First .. Last as Edges is sorted by X and then Y. To + -- compute the neighbor list, sort the edges. + + Sort + (Edges_Len - 1, + Move'Unrestricted_Access, + Lt'Unrestricted_Access); + + if Verbose then + Put_Edges (Output, "Sorted Edge Table"); + Put_Int_Matrix (Output, "Function Table 1", T1); + Put_Int_Matrix (Output, "Function Table 2", T2); + end if; + + -- Edges valid range is 1 .. 2 * NK + + for E in 1 .. Edges_Len - 1 loop + Edge := Get_Edges (E); + Key := Get_Key (Edge.Key); + + if Key.Edge = No_Edge then + Key.Edge := E; + Set_Key (Edge.Key, Key); + end if; + + Vertex := Get_Vertices (Edge.X); + + if Vertex.First = No_Edge then + Vertex.First := E; + end if; + + Vertex.Last := E; + Set_Vertices (Edge.X, Vertex); + end loop; + + if Verbose then + Put_Reduced_Keys (Output, "Key Table"); + Put_Edges (Output, "Edge Table"); + Put_Vertex_Table (Output, "Vertex Table"); + end if; + end if; + end Compute_Edges_And_Vertices; + + ------------ + -- Define -- + ------------ + + procedure Define + (Name : Table_Name; + Item_Size : out Natural; + Length_1 : out Natural; + Length_2 : out Natural) + is + begin + case Name is + when Character_Position => + Item_Size := 8; + Length_1 := Char_Pos_Set_Len; + Length_2 := 0; + + when Used_Character_Set => + Item_Size := 8; + Length_1 := 256; + Length_2 := 0; + + when Function_Table_1 + | Function_Table_2 => + Item_Size := Type_Size (NV); + Length_1 := Rand_Tab_Len_1; + Length_2 := Rand_Tab_Len_2; + + when Graph_Table => + Item_Size := Type_Size (NK); + Length_1 := NV; + Length_2 := 0; + end case; + end Define; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize is + begin + WT.Release; + IT.Release; + + Keys := No_Table; + NK := 0; + + Char_Pos_Set := No_Table; + Char_Pos_Set_Len := 0; + + Used_Char_Set := No_Table; + Used_Char_Set_Len := 0; + + T1 := No_Table; + T2 := No_Table; + + Rand_Tab_Len_1 := 0; + Rand_Tab_Len_2 := 0; + + G := No_Table; + Graph_Len := 0; + + Edges := No_Table; + Edges_Len := 0; + + Vertices := No_Table; + NV := 0; + end Finalize; + + ---------------------------- + -- Generate_Mapping_Table -- + ---------------------------- + + procedure Generate_Mapping_Table + (T : Integer; + L1 : Natural; + L2 : Natural; + S : in out Natural) + is + begin + for J in 0 .. L1 - 1 loop + for K in 0 .. L2 - 1 loop + Random (S); + Set_Rand_Tab (T, J, K, S mod NV); + end loop; + end loop; + end Generate_Mapping_Table; + + ----------------------------- + -- Generate_Mapping_Tables -- + ----------------------------- + + procedure Generate_Mapping_Tables + (Opt : Optimization; + S : in out Natural) + is + begin + -- If T1 and T2 are already allocated no need to do it + -- twice. Reuse them as their size has not changes. + + if T1 = No_Table and then T2 = No_Table then + declare + Used_Char_Last : Natural := 0; + Used_Char : Natural; + + begin + if Opt = CPU_Time then + for P in reverse Character'Range loop + Used_Char := Get_Used_Char (P); + if Used_Char /= 0 then + Used_Char_Last := Used_Char; + exit; + end if; + end loop; + end if; + + Rand_Tab_Len_1 := Char_Pos_Set_Len; + Rand_Tab_Len_2 := Used_Char_Last + 1; + T1 := Allocate (Rand_Tab_Len_1 * Rand_Tab_Len_2, + Rand_Tab_Item_Size); + T2 := Allocate (Rand_Tab_Len_1 * Rand_Tab_Len_2, + Rand_Tab_Item_Size); + end; + end if; + + Generate_Mapping_Table (T1, Rand_Tab_Len_1, Rand_Tab_Len_2, S); + Generate_Mapping_Table (T2, Rand_Tab_Len_1, Rand_Tab_Len_2, S); + + if Verbose then + Put_Used_Char_Set (Output, "Used Character Set"); + Put_Int_Matrix (Output, "Function Table 1", T1); + Put_Int_Matrix (Output, "Function Table 2", T2); + end if; + end Generate_Mapping_Tables; + + ------------------ + -- Get_Char_Pos -- + ------------------ + + function Get_Char_Pos (P : Natural) return Natural is + N : constant Natural := Char_Pos_Set + P; + + begin + return IT.Table (N); + end Get_Char_Pos; + + --------------- + -- Get_Edges -- + --------------- + + function Get_Edges (F : Natural) return Edge_Type is + N : constant Natural := Edges + (F * Edge_Size); + E : Edge_Type; + + begin + E.X := IT.Table (N); + E.Y := IT.Table (N + 1); + E.Key := IT.Table (N + 2); + return E; + end Get_Edges; + + --------------- + -- Get_Graph -- + --------------- + + function Get_Graph (F : Natural) return Integer is + N : constant Natural := G + F * Graph_Item_Size; + + begin + return IT.Table (N); + end Get_Graph; + + ------------- + -- Get_Key -- + ------------- + + function Get_Key (F : Key_Id) return Key_Type is + N : constant Natural := Keys + F * Key_Size; + K : Key_Type; + + begin + K.Edge := IT.Table (N); + return K; + end Get_Key; + + ------------------ + -- Get_Rand_Tab -- + ------------------ + + function Get_Rand_Tab (T : Integer; X, Y : Natural) return Natural is + N : constant Natural := + T + ((Y * Rand_Tab_Len_1) + X) * Rand_Tab_Item_Size; + + begin + return IT.Table (N); + end Get_Rand_Tab; + + ------------------- + -- Get_Used_Char -- + ------------------- + + function Get_Used_Char (C : Character) return Natural is + N : constant Natural := + Used_Char_Set + Character'Pos (C) * Used_Char_Size; + + begin + return IT.Table (N); + end Get_Used_Char; + + ------------------ + -- Get_Vertices -- + ------------------ + + function Get_Vertices (F : Natural) return Vertex_Type is + N : constant Natural := Vertices + (F * Vertex_Size); + V : Vertex_Type; + + begin + V.First := IT.Table (N); + V.Last := IT.Table (N + 1); + return V; + end Get_Vertices; + + ----------- + -- Image -- + ----------- + + function Image (Int : Integer; W : Natural := 0) return String is + B : String (1 .. 32); + L : Natural := 0; + + procedure Img (V : Natural); + -- Compute image of V into B, starting at B (L), incrementing L + + --------- + -- Img -- + --------- + + procedure Img (V : Natural) is + begin + if V > 9 then + Img (V / 10); + end if; + + L := L + 1; + B (L) := Character'Val ((V mod 10) + Character'Pos ('0')); + end Img; + + -- Start of processing for Image + + begin + if Int < 0 then + L := L + 1; + B (L) := '-'; + Img (-Int); + else + Img (Int); + end if; + + return Image (B (1 .. L), W); + end Image; + + ----------- + -- Image -- + ----------- + + function Image (Str : String; W : Natural := 0) return String is + Len : constant Natural := Str'Length; + Max : Natural := Len; + + begin + if Max < W then + Max := W; + end if; + + declare + Buf : String (1 .. Max) := (1 .. Max => ' '); + + begin + for J in 0 .. Len - 1 loop + Buf (Max - Len + 1 + J) := Str (Str'First + J); + end loop; + + return Buf; + end; + end Image; + + ------------- + -- Initial -- + ------------- + + function Initial (K : Key_Id) return Word_Id is + begin + return K; + end Initial; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize + (Seed : Natural; + K_To_V : Float := Default_K_To_V; + Optim : Optimization := CPU_Time) + is + begin + WT.Init; + IT.Init; + S := Seed; + + Keys := No_Table; + NK := 0; + + Char_Pos_Set := No_Table; + Char_Pos_Set_Len := 0; + + K2V := K_To_V; + Opt := Optim; + MKL := 0; + end Initialize; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Value : String) + is + Word : Word_Type := Null_Word; + Len : constant Natural := Value'Length; + + begin + Word (1 .. Len) := Value (Value'First .. Value'First + Len - 1); + WT.Set_Last (NK); + WT.Table (NK) := Word; + NK := NK + 1; + NV := Natural (Float (NK) * K2V); + + if MKL < Len then + MKL := Len; + end if; + end Insert; + + -------------- + -- New_Line -- + -------------- + + procedure New_Line (F : File_Descriptor) is + EOL : constant Character := ASCII.LF; + + begin + if Write (F, EOL'Address, 1) /= 1 then + raise Program_Error; + end if; + end New_Line; + + ------------------------------ + -- Parse_Position_Selection -- + ------------------------------ + + procedure Parse_Position_Selection (Argument : String) is + N : Natural := Argument'First; + L : constant Natural := Argument'Last; + M : constant Natural := MKL; + + T : array (1 .. M) of Boolean := (others => False); + + function Parse_Index return Natural; + -- Parse argument starting at index N to find an index + + ----------------- + -- Parse_Index -- + ----------------- + + function Parse_Index return Natural + is + C : Character := Argument (N); + V : Natural := 0; + + begin + if C = '$' then + N := N + 1; + return M; + end if; + + if C not in '0' .. '9' then + Raise_Exception + (Program_Error'Identity, "cannot read position argument"); + end if; + + while C in '0' .. '9' loop + V := V * 10 + (Character'Pos (C) - Character'Pos ('0')); + N := N + 1; + exit when L < N; + C := Argument (N); + end loop; + + return V; + end Parse_Index; + + -- Start of processing for Parse_Position_Selection + + begin + Char_Pos_Set_Len := 2 * NK; + + -- Empty specification means all the positions + + if L < N then + Char_Pos_Set_Len := M; + Char_Pos_Set := Allocate (Char_Pos_Set_Len, Char_Pos_Size); + + for C in 0 .. Char_Pos_Set_Len - 1 loop + Set_Char_Pos (C, C + 1); + end loop; + + else + loop + declare + First, Last : Natural; + + begin + First := Parse_Index; + Last := First; + + -- Detect a range + + if N <= L and then Argument (N) = '-' then + N := N + 1; + Last := Parse_Index; + end if; + + -- Include the positions in the selection + + for J in First .. Last loop + T (J) := True; + end loop; + end; + + exit when L < N; + + if Argument (N) /= ',' then + Raise_Exception + (Program_Error'Identity, "cannot read position argument"); + end if; + + N := N + 1; + end loop; + + -- Compute position selection length + + N := 0; + for J in T'Range loop + if T (J) then + N := N + 1; + end if; + end loop; + + -- Fill position selection + + Char_Pos_Set_Len := N; + Char_Pos_Set := Allocate (Char_Pos_Set_Len, Char_Pos_Size); + + N := 0; + for J in T'Range loop + if T (J) then + Set_Char_Pos (N, J); + N := N + 1; + end if; + end loop; + end if; + end Parse_Position_Selection; + + ------------- + -- Produce -- + ------------- + + procedure Produce (Pkg_Name : String := Default_Pkg_Name) is + File : File_Descriptor; + + Status : Boolean; + -- For call to Close; + + function Type_Img (L : Natural) return String; + -- Return the larger unsigned type T such that T'Last < L + + function Range_Img (F, L : Natural; T : String := "") return String; + -- Return string "[T range ]F .. L" + + function Array_Img (N, T, R1 : String; R2 : String := "") return String; + -- Return string "N : constant array (R1[, R2]) of T;" + + -------------- + -- Type_Img -- + -------------- + + function Type_Img (L : Natural) return String is + S : constant String := Image (Type_Size (L)); + U : String := "Unsigned_ "; + N : Natural := 9; + + begin + for J in S'Range loop + N := N + 1; + U (N) := S (J); + end loop; + + return U (1 .. N); + end Type_Img; + + --------------- + -- Range_Img -- + --------------- + + function Range_Img (F, L : Natural; T : String := "") return String is + FI : constant String := Image (F); + FL : constant Natural := FI'Length; + LI : constant String := Image (L); + LL : constant Natural := LI'Length; + TL : constant Natural := T'Length; + RI : String (1 .. TL + 7 + FL + 4 + LL); + Len : Natural := 0; + + begin + if TL /= 0 then + RI (Len + 1 .. Len + TL) := T; + Len := Len + TL; + RI (Len + 1 .. Len + 7) := " range "; + Len := Len + 7; + end if; + + RI (Len + 1 .. Len + FL) := FI; + Len := Len + FL; + RI (Len + 1 .. Len + 4) := " .. "; + Len := Len + 4; + RI (Len + 1 .. Len + LL) := LI; + Len := Len + LL; + return RI (1 .. Len); + end Range_Img; + + --------------- + -- Array_Img -- + --------------- + + function Array_Img + (N, T, R1 : String; + R2 : String := "") + return String + is + begin + Last := 0; + Add (" "); + Add (N); + Add (" : constant array ("); + Add (R1); + + if R2 /= "" then + Add (", "); + Add (R2); + end if; + + Add (") of "); + Add (T); + Add (" :="); + return Line (1 .. Last); + end Array_Img; + + F : Natural; + L : Natural; + P : Natural; + + PLen : constant Natural := Pkg_Name'Length; + FName : String (1 .. PLen + 4); + + -- Start of processing for Produce + + begin + FName (1 .. PLen) := Pkg_Name; + for J in 1 .. PLen loop + if FName (J) in 'A' .. 'Z' then + FName (J) := Character'Val (Character'Pos (FName (J)) + - Character'Pos ('A') + + Character'Pos ('a')); + + elsif FName (J) = '.' then + FName (J) := '-'; + end if; + end loop; + + FName (PLen + 1 .. PLen + 4) := ".ads"; + + File := Create_File (FName, Text); + Put (File, "package "); + Put (File, Pkg_Name); + Put (File, " is"); + New_Line (File); + Put (File, " function Hash (S : String) return Natural;"); + New_Line (File); + Put (File, "end "); + Put (File, Pkg_Name); + Put (File, ";"); + New_Line (File); + Close (File, Status); + + if not Status then + raise Device_Error; + end if; + + FName (PLen + 4) := 'b'; + + File := Create_File (FName, Text); + Put (File, "with Interfaces; use Interfaces;"); + New_Line (File); + New_Line (File); + Put (File, "package body "); + Put (File, Pkg_Name); + Put (File, " is"); + New_Line (File); + New_Line (File); + + if Opt = CPU_Time then + Put (File, Array_Img ("C", Type_Img (256), "Character")); + New_Line (File); + + F := Character'Pos (Character'First); + L := Character'Pos (Character'Last); + + for J in Character'Range loop + P := Get_Used_Char (J); + Put (File, Image (P), 0, 0, 0, F, L, Character'Pos (J)); + end loop; + + New_Line (File); + end if; + + F := 0; + L := Char_Pos_Set_Len - 1; + + Put (File, Array_Img ("P", "Natural", Range_Img (F, L))); + New_Line (File); + + for J in F .. L loop + Put (File, Image (Get_Char_Pos (J)), 0, 0, 0, F, L, J); + end loop; + + New_Line (File); + + if Opt = CPU_Time then + Put_Int_Matrix + (File, + Array_Img ("T1", Type_Img (NV), + Range_Img (0, Rand_Tab_Len_1 - 1), + Range_Img (0, Rand_Tab_Len_2 - 1, + Type_Img (256))), + T1); + + else + Put_Int_Matrix + (File, + Array_Img ("T1", Type_Img (NV), + Range_Img (0, Rand_Tab_Len_1 - 1)), + T1); + end if; + + New_Line (File); + + if Opt = CPU_Time then + Put_Int_Matrix + (File, + Array_Img ("T2", Type_Img (NV), + Range_Img (0, Rand_Tab_Len_1 - 1), + Range_Img (0, Rand_Tab_Len_2 - 1, + Type_Img (256))), + T2); + + else + Put_Int_Matrix + (File, + Array_Img ("T2", Type_Img (NV), + Range_Img (0, Rand_Tab_Len_1 - 1)), + T2); + end if; + + New_Line (File); + + Put_Int_Vector + (File, + Array_Img ("G", Type_Img (NK), + Range_Img (0, Graph_Len - 1)), + G, Graph_Len); + New_Line (File); + + Put (File, " function Hash (S : String) return Natural is"); + New_Line (File); + Put (File, " F : constant Natural := S'First - 1;"); + New_Line (File); + Put (File, " L : constant Natural := S'Length;"); + New_Line (File); + Put (File, " F1, F2 : Natural := 0;"); + New_Line (File); + + Put (File, " J : "); + + if Opt = CPU_Time then + Put (File, Type_Img (256)); + else + Put (File, "Natural"); + end if; + + Put (File, ";"); + New_Line (File); + + Put (File, " begin"); + New_Line (File); + Put (File, " for K in P'Range loop"); + New_Line (File); + Put (File, " exit when L < P (K);"); + New_Line (File); + Put (File, " J := "); + + if Opt = CPU_Time then + Put (File, "C"); + else + Put (File, "Character'Pos"); + end if; + + Put (File, " (S (P (K) + F));"); + New_Line (File); + + Put (File, " F1 := (F1 + Natural (T1 (K"); + + if Opt = CPU_Time then + Put (File, ", J"); + end if; + + Put (File, "))"); + + if Opt = Memory_Space then + Put (File, " * J"); + end if; + + Put (File, ") mod "); + Put (File, Image (NV)); + Put (File, ";"); + New_Line (File); + + Put (File, " F2 := (F2 + Natural (T2 (K"); + + if Opt = CPU_Time then + Put (File, ", J"); + end if; + + Put (File, "))"); + + if Opt = Memory_Space then + Put (File, " * J"); + end if; + + Put (File, ") mod "); + Put (File, Image (NV)); + Put (File, ";"); + New_Line (File); + + Put (File, " end loop;"); + New_Line (File); + + Put (File, + " return (Natural (G (F1)) + Natural (G (F2))) mod "); + + Put (File, Image (NK)); + Put (File, ";"); + New_Line (File); + Put (File, " end Hash;"); + New_Line (File); + New_Line (File); + Put (File, "end "); + Put (File, Pkg_Name); + Put (File, ";"); + New_Line (File); + Close (File, Status); + + if not Status then + raise Device_Error; + end if; + end Produce; + + --------- + -- Put -- + --------- + + procedure Put (F : File_Descriptor; S : String) is + Len : constant Natural := S'Length; + + begin + if Write (F, S'Address, Len) /= Len then + raise Program_Error; + end if; + end Put; + + --------- + -- Put -- + --------- + + procedure Put + (F : File_Descriptor; + S : String; + F1 : Natural; + L1 : Natural; + C1 : Natural; + F2 : Natural; + L2 : Natural; + C2 : Natural) + is + Len : constant Natural := S'Length; + + procedure Flush; + + ----------- + -- Flush -- + ----------- + + procedure Flush is + begin + Put (F, Line (1 .. Last)); + New_Line (F); + Last := 0; + end Flush; + + -- Start of processing for Put + + begin + if C1 = F1 and then C2 = F2 then + Last := 0; + end if; + + if Last + Len + 3 > Max then + Flush; + end if; + + if Last = 0 then + Line (Last + 1 .. Last + 5) := " "; + Last := Last + 5; + + if F1 /= L1 then + if C1 = F1 and then C2 = F2 then + Add ('('); + else + Add (' '); + end if; + end if; + end if; + + if C2 = F2 then + Add ('('); + else + Add (' '); + end if; + + Line (Last + 1 .. Last + Len) := S; + Last := Last + Len; + + if C2 = L2 then + Add (')'); + + if F1 = L1 then + Add (';'); + Flush; + elsif C1 /= L1 then + Add (','); + Flush; + else + Add (')'); + Add (';'); + Flush; + end if; + + else + Add (','); + end if; + end Put; + + ----------------------- + -- Put_Used_Char_Set -- + ----------------------- + + procedure Put_Used_Char_Set + (File : File_Descriptor; + Title : String) + is + F : constant Natural := Character'Pos (Character'First); + L : constant Natural := Character'Pos (Character'Last); + + begin + Put (File, Title); + New_Line (File); + + for J in Character'Range loop + Put + (File, Image (Get_Used_Char (J)), 0, 0, 0, F, L, Character'Pos (J)); + end loop; + end Put_Used_Char_Set; + + ---------- + -- Put -- + ---------- + + procedure Put_Int_Matrix + (File : File_Descriptor; + Title : String; + Table : Integer) + is + F1 : constant Natural := 0; + L1 : constant Natural := Rand_Tab_Len_1 - 1; + F2 : constant Natural := 0; + L2 : constant Natural := Rand_Tab_Len_2 - 1; + + begin + Put (File, Title); + New_Line (File); + + if L2 = F2 then + for J in F1 .. L1 loop + Put (File, + Image (Get_Rand_Tab (Table, J, F2)), 0, 0, 0, F1, L1, J); + end loop; + + else + for J in F1 .. L1 loop + for K in F2 .. L2 loop + Put (File, + Image (Get_Rand_Tab (Table, J, K)), F1, L1, J, F2, L2, K); + end loop; + end loop; + end if; + end Put_Int_Matrix; + + -------------------- + -- Put_Int_Vector -- + -------------------- + + procedure Put_Int_Vector + (File : File_Descriptor; + Title : String; + Root : Integer; + Length : Natural) + is + F2 : constant Natural := 0; + L2 : constant Natural := Length - 1; + + begin + Put (File, Title); + New_Line (File); + + for J in F2 .. L2 loop + Put (File, Image (IT.Table (Root + J)), 0, 0, 0, F2, L2, J); + end loop; + end Put_Int_Vector; + + --------------- + -- Put_Edges -- + --------------- + + procedure Put_Edges + (File : File_Descriptor; + Title : String) + is + E : Edge_Type; + F1 : constant Natural := 1; + L1 : constant Natural := Edges_Len - 1; + M : constant Natural := Max / 5; + + begin + Put (File, Title); + New_Line (File); + + -- Edges valid range is 1 .. Edge_Len - 1 + + for J in F1 .. L1 loop + E := Get_Edges (J); + Put (File, Image (J, M), F1, L1, J, 1, 4, 1); + Put (File, Image (E.X, M), F1, L1, J, 1, 4, 2); + Put (File, Image (E.Y, M), F1, L1, J, 1, 4, 3); + Put (File, Image (E.Key, M), F1, L1, J, 1, 4, 4); + end loop; + end Put_Edges; + + --------------------------- + -- Put_Initial_Keys -- + --------------------------- + + procedure Put_Initial_Keys + (File : File_Descriptor; + Title : String) + is + F1 : constant Natural := 0; + L1 : constant Natural := NK - 1; + M : constant Natural := Max / 5; + K : Key_Type; + + begin + Put (File, Title); + New_Line (File); + + for J in F1 .. L1 loop + K := Get_Key (J); + Put (File, Image (J, M), F1, L1, J, 1, 3, 1); + Put (File, Image (K.Edge, M), F1, L1, J, 1, 3, 2); + Put (File, WT.Table (Initial (J)), F1, L1, J, 1, 3, 3); + end loop; + end Put_Initial_Keys; + + --------------------------- + -- Put_Reduced_Keys -- + --------------------------- + + procedure Put_Reduced_Keys + (File : File_Descriptor; + Title : String) + is + F1 : constant Natural := 0; + L1 : constant Natural := NK - 1; + M : constant Natural := Max / 5; + K : Key_Type; + + begin + Put (File, Title); + New_Line (File); + + for J in F1 .. L1 loop + K := Get_Key (J); + Put (File, Image (J, M), F1, L1, J, 1, 3, 1); + Put (File, Image (K.Edge, M), F1, L1, J, 1, 3, 2); + Put (File, WT.Table (Reduced (J)), F1, L1, J, 1, 3, 3); + end loop; + end Put_Reduced_Keys; + + ---------------------- + -- Put_Vertex_Table -- + ---------------------- + + procedure Put_Vertex_Table + (File : File_Descriptor; + Title : String) + is + F1 : constant Natural := 0; + L1 : constant Natural := NV - 1; + M : constant Natural := Max / 4; + V : Vertex_Type; + + begin + Put (File, Title); + New_Line (File); + + for J in F1 .. L1 loop + V := Get_Vertices (J); + Put (File, Image (J, M), F1, L1, J, 1, 3, 1); + Put (File, Image (V.First, M), F1, L1, J, 1, 3, 2); + Put (File, Image (V.Last, M), F1, L1, J, 1, 3, 3); + end loop; + end Put_Vertex_Table; + + ------------ + -- Random -- + ------------ + + procedure Random (Seed : in out Natural) + is + -- Park & Miller Standard Minimal using Schrage's algorithm to + -- avoid overflow: Xn+1 = 16807 * Xn mod (2 ** 31 - 1) + + R : Natural; + Q : Natural; + X : Integer; + + begin + R := Seed mod 127773; + Q := Seed / 127773; + X := 16807 * R - 2836 * Q; + + if X < 0 then + Seed := X + 2147483647; + else + Seed := X; + end if; + end Random; + + ------------- + -- Reduced -- + ------------- + + function Reduced (K : Key_Id) return Word_Id is + begin + return K + NK; + end Reduced; + + -------------------------- + -- Select_Character_Set -- + -------------------------- + + procedure Select_Character_Set + is + Last : Natural := 0; + Used : array (Character) of Boolean := (others => False); + + begin + for J in 0 .. NK - 1 loop + for K in 1 .. Max_Word_Length loop + exit when WT.Table (Initial (J))(K) = ASCII.NUL; + Used (WT.Table (Initial (J))(K)) := True; + end loop; + end loop; + + Used_Char_Set_Len := 256; + Used_Char_Set := Allocate (Used_Char_Set_Len, Used_Char_Size); + + for J in Used'Range loop + if Used (J) then + Set_Used_Char (J, Last); + Last := Last + 1; + else + Set_Used_Char (J, 0); + end if; + end loop; + end Select_Character_Set; + + -------------------------- + -- Select_Char_Position -- + -------------------------- + + procedure Select_Char_Position is + + type Vertex_Table_Type is array (Natural range <>) of Vertex_Type; + + procedure Build_Identical_Keys_Sets + (Table : in out Vertex_Table_Type; + Last : in out Natural; + Pos : in Natural); + -- Build a list of keys subsets that are identical with the + -- current position selection plus Pos. Once this routine is + -- called, reduced words are sorted by subsets and each item + -- (First, Last) in Sets defines the range of identical keys. + + function Count_Identical_Keys + (Table : Vertex_Table_Type; + Last : Natural; + Pos : Natural) + return Natural; + -- For each subset in Sets, count the number of identical keys + -- if we add Pos to the current position selection. + + Sel_Position : IT.Table_Type (1 .. MKL); + Last_Sel_Pos : Natural := 0; + + ------------------------------- + -- Build_Identical_Keys_Sets -- + ------------------------------- + + procedure Build_Identical_Keys_Sets + (Table : in out Vertex_Table_Type; + Last : in out Natural; + Pos : in Natural) + is + S : constant Vertex_Table_Type := Table (1 .. Last); + C : constant Natural := Pos; + -- Shortcuts + + F : Integer; + L : Integer; + -- First and last words of a subset + + begin + Last := 0; + + -- For each subset in S, extract the new subsets we have by + -- adding C in the position selection. + + for J in S'Range loop + declare + Offset : Natural; + -- GNAT.Heap_Sort assumes that the first array index + -- is 1. Offset defines the translation to operate. + + procedure Move (From : Natural; To : Natural); + function Lt (L, R : Natural) return Boolean; + -- Subprograms needed by GNAT.Heap_Sort_A + + ---------- + -- Move -- + ---------- + + procedure Move (From : Natural; To : Natural) is + Target, Source : Natural; + + begin + if From = 0 then + Source := 0; + Target := Offset + To; + elsif To = 0 then + Source := Offset + From; + Target := 0; + else + Source := Offset + From; + Target := Offset + To; + end if; + + WT.Table (Reduced (Target)) := WT.Table (Reduced (Source)); + end Move; + + -------- + -- Lt -- + -------- + + function Lt (L, R : Natural) return Boolean is + C : constant Natural := Pos; + Left : Natural; + Right : Natural; + + begin + if L = 0 then + Left := 0; + Right := Offset + R; + elsif R = 0 then + Left := Offset + L; + Right := 0; + else + Left := Offset + L; + Right := Offset + R; + end if; + + return WT.Table (Reduced (Left))(C) + < WT.Table (Reduced (Right))(C); + end Lt; + + -- Start of processing for Build_Identical_Key_Sets + + begin + Offset := S (J).First - 1; + Sort + (S (J).Last - S (J).First + 1, + Move'Unrestricted_Access, + Lt'Unrestricted_Access); + + F := -1; + L := -1; + for N in S (J).First .. S (J).Last - 1 loop + + -- Two contiguous words are identical + + if WT.Table (Reduced (N))(C) = + WT.Table (Reduced (N + 1))(C) + then + -- This is the first word of the subset + + if F = -1 then + F := N; + end if; + + L := N + 1; + + -- This is the last word of the subset + + elsif F /= -1 then + Last := Last + 1; + Table (Last) := (F, L); + F := -1; + end if; + end loop; + + -- This is the last word of the subset and of the set + + if F /= -1 then + Last := Last + 1; + Table (Last) := (F, L); + end if; + end; + end loop; + end Build_Identical_Keys_Sets; + + -------------------------- + -- Count_Identical_Keys -- + -------------------------- + + function Count_Identical_Keys + (Table : Vertex_Table_Type; + Last : Natural; + Pos : Natural) + return Natural + is + N : array (Character) of Natural; + C : Character; + T : Natural := 0; + + begin + -- For each subset, count the number of words that are still + -- identical when we include Sel_Position (Last_Sel_Pos) in + -- the position selection. Only focus on this position as the + -- other positions already produce identical keys. + + for S in 1 .. Last loop + + -- Count the occurrences of the different characters + + N := (others => 0); + for K in Table (S).First .. Table (S).Last loop + C := WT.Table (Reduced (K))(Pos); + N (C) := N (C) + 1; + end loop; + + -- Add to the total when there are two identical keys + + for J in N'Range loop + if N (J) > 1 then + T := T + N (J); + end if; + end loop; + end loop; + + return T; + end Count_Identical_Keys; + + -- Start of processing for Select_Char_Position + + begin + for C in Sel_Position'Range loop + Sel_Position (C) := C; + end loop; + + -- Initialization of Words + + WT.Set_Last (2 * NK - 1); + + for K in 0 .. NK - 1 loop + WT.Table (Reduced (K) + 1) := WT.Table (Initial (K)); + end loop; + + declare + Collisions : Natural; + Min_Collisions : Natural := NK; + Old_Collisions : Natural; + Min_Coll_Sel_Pos : Natural := 0; -- init to kill warning + Min_Coll_Sel_Pos_Idx : Natural := 0; -- init to kill warning + Same_Keys_Sets_Table : Vertex_Table_Type (1 .. NK); + Same_Keys_Sets_Last : Natural := 1; + + begin + Same_Keys_Sets_Table (1) := (1, NK); + + loop + -- Preserve minimum identical keys and check later on + -- that this value is strictly decrementing. Otherwise, + -- it means that two keys are stricly identical. + + Old_Collisions := Min_Collisions; + + -- Find which position reduces the most of collisions + + for J in Last_Sel_Pos + 1 .. Sel_Position'Last loop + Collisions := Count_Identical_Keys + (Same_Keys_Sets_Table, + Same_Keys_Sets_Last, + Sel_Position (J)); + + if Collisions < Min_Collisions then + Min_Collisions := Collisions; + Min_Coll_Sel_Pos := Sel_Position (J); + Min_Coll_Sel_Pos_Idx := J; + end if; + end loop; + + if Old_Collisions = Min_Collisions then + Raise_Exception + (Program_Error'Identity, "some keys are identical"); + end if; + + -- Insert selected position and sort Sel_Position table + + Last_Sel_Pos := Last_Sel_Pos + 1; + Sel_Position (Last_Sel_Pos + 1 .. Min_Coll_Sel_Pos_Idx) := + Sel_Position (Last_Sel_Pos .. Min_Coll_Sel_Pos_Idx - 1); + Sel_Position (Last_Sel_Pos) := Min_Coll_Sel_Pos; + + for P in 1 .. Last_Sel_Pos - 1 loop + if Min_Coll_Sel_Pos < Sel_Position (P) then + Sel_Position (P + 1 .. Last_Sel_Pos) := + Sel_Position (P .. Last_Sel_Pos - 1); + Sel_Position (P) := Min_Coll_Sel_Pos; + exit; + end if; + end loop; + + exit when Min_Collisions = 0; + + Build_Identical_Keys_Sets + (Same_Keys_Sets_Table, + Same_Keys_Sets_Last, + Min_Coll_Sel_Pos); + end loop; + end; + + Char_Pos_Set_Len := Last_Sel_Pos; + Char_Pos_Set := Allocate (Char_Pos_Set_Len, Char_Pos_Size); + + for C in 1 .. Last_Sel_Pos loop + Set_Char_Pos (C - 1, Sel_Position (C)); + end loop; + end Select_Char_Position; + + ------------------ + -- Set_Char_Pos -- + ------------------ + + procedure Set_Char_Pos (P : Natural; Item : Natural) is + N : constant Natural := Char_Pos_Set + P; + + begin + IT.Table (N) := Item; + end Set_Char_Pos; + + --------------- + -- Set_Edges -- + --------------- + + procedure Set_Edges (F : Natural; Item : Edge_Type) is + N : constant Natural := Edges + (F * Edge_Size); + + begin + IT.Table (N) := Item.X; + IT.Table (N + 1) := Item.Y; + IT.Table (N + 2) := Item.Key; + end Set_Edges; + + --------------- + -- Set_Graph -- + --------------- + + procedure Set_Graph (F : Natural; Item : Integer) is + N : constant Natural := G + (F * Graph_Item_Size); + + begin + IT.Table (N) := Item; + end Set_Graph; + + ------------- + -- Set_Key -- + ------------- + + procedure Set_Key (F : Key_Id; Item : Key_Type) is + N : constant Natural := Keys + F * Key_Size; + + begin + IT.Table (N) := Item.Edge; + end Set_Key; + + ------------------ + -- Set_Rand_Tab -- + ------------------ + + procedure Set_Rand_Tab (T : Integer; X, Y : Natural; Item : Natural) is + N : constant Natural := + T + ((Y * Rand_Tab_Len_1) + X) * Rand_Tab_Item_Size; + + begin + IT.Table (N) := Item; + end Set_Rand_Tab; + + ------------------- + -- Set_Used_Char -- + ------------------- + + procedure Set_Used_Char (C : Character; Item : Natural) is + N : constant Natural := + Used_Char_Set + Character'Pos (C) * Used_Char_Size; + + begin + IT.Table (N) := Item; + end Set_Used_Char; + + ------------------ + -- Set_Vertices -- + ------------------ + + procedure Set_Vertices (F : Natural; Item : Vertex_Type) is + N : constant Natural := Vertices + (F * Vertex_Size); + + begin + IT.Table (N) := Item.First; + IT.Table (N + 1) := Item.Last; + end Set_Vertices; + + --------- + -- Sum -- + --------- + + function Sum + (Word : Word_Type; + Table : Table_Id; + Opt : Optimization) + return Natural + is + S : Natural := 0; + R : Natural; + + begin + if Opt = CPU_Time then + for J in 0 .. Rand_Tab_Len_1 - 1 loop + exit when Word (J + 1) = ASCII.NUL; + R := Get_Rand_Tab (Table, J, Get_Used_Char (Word (J + 1))); + S := (S + R) mod NV; + end loop; + + else + for J in 0 .. Rand_Tab_Len_1 - 1 loop + exit when Word (J + 1) = ASCII.NUL; + R := Get_Rand_Tab (Table, J, 0); + S := (S + R * Character'Pos (Word (J + 1))) mod NV; + end loop; + end if; + + return S; + end Sum; + + --------------- + -- Type_Size -- + --------------- + + function Type_Size (L : Natural) return Natural is + begin + if L <= 2 ** 8 then + return 8; + elsif L <= 2 ** 16 then + return 16; + else + return 32; + end if; + end Type_Size; + + ----------- + -- Value -- + ----------- + + function Value + (Name : Table_Name; + J : Natural; + K : Natural := 0) + return Natural + is + begin + case Name is + when Character_Position => + return Get_Char_Pos (J); + + when Used_Character_Set => + return Get_Used_Char (Character'Val (J)); + + when Function_Table_1 => + return Get_Rand_Tab (T1, J, K); + + when Function_Table_2 => + return Get_Rand_Tab (T2, J, K); + + when Graph_Table => + return Get_Graph (J); + + end case; + end Value; + +end GNAT.Perfect_Hash.Generators; |