URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [g-pehage.adb] - Rev 714
Go to most recent revision | Compare with Previous | Blame | View Log
------------------------------------------------------------------------------ -- -- -- 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-2011, AdaCore -- -- -- -- 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 3, 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. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- <http://www.gnu.org/licenses/>. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ with Ada.IO_Exceptions; use Ada.IO_Exceptions; with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Directories; with GNAT.Heap_Sort_G; 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 assignment. -- In the mapping step, a graph G = (V, E) is constructed, where = {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 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 (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; type Word_Type is new String_Access; procedure Free_Word (W : in out Word_Type) renames Free; function New_Word (S : String) return Word_Type; procedure Resize_Word (W : in out Word_Type; Len : Natural); -- Resize string W to have a length Len 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. WT is used to store the words in their initial -- version and in their reduced version (that is words reduced to their -- significant characters). As an instance of GNAT.Table, WT does not -- initialize string pointers to null. This initialization has to be done -- manually when the table is allocated. 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. function Trim_Trailing_Nuls (Str : String) return String; -- Return Str with trailing NUL characters removed Output : File_Descriptor renames GNAT.OS_Lib.Standout; -- Shortcuts EOL : constant Character := ASCII.LF; 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 -- semi-colon and writes the line into file F. procedure New_Line (File : File_Descriptor); -- Simulate Ada.Text_IO.New_Line with GNAT.OS_Lib procedure Put (File : File_Descriptor; Str : 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; Vector : Integer; Length : Natural); -- Output a title and a vector procedure Put_Int_Matrix (File : File_Descriptor; Title : String; Table : Table_Id; Len_1 : Natural; Len_2 : Natural); -- Output a title and a matrix. When the matrix has only one non-empty -- dimension (Len_2 = 0), output 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 function Ada_File_Base_Name (Pkg_Name : String) return String; -- Return the base file name (i.e. without .ads/.adb extension) for an -- Ada source file containing the named package, using the standard GNAT -- file-naming convention. For example, if Pkg_Name is "Parent.Child", we -- return "parent-child". ---------------------------------- -- 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 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 (Tab : Table_Id; L1 : Natural; L2 : Natural; Seed : in out Natural); -- Random generation of the tables below. T is already allocated procedure Generate_Mapping_Tables (Opt : Optimization; Seed : 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 := 1) return Table_Id; -- Allocate N * S ints from IT table ---------- -- Keys -- ---------- Keys : Table_Id := No_Table; NK : Natural := 0; -- 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 (N : Key_Id) return Key_Type; procedure Set_Key (N : Key_Id; Item : Key_Type); -- Get or Set Nth element of Keys table ------------------ -- Char_Pos_Set -- ------------------ 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); -- Get or Set the string position of the Pth selected character ------------------- -- Used_Char_Set -- ------------------- 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); ------------ -- Tables -- ------------ T1 : Table_Id := No_Table; T2 : Table_Id := No_Table; T1_Len : Natural; T2_Len : Natural; -- T1 : Values table to compute F1 -- T2 : Values table to compute F2 function Get_Table (T : Integer; X, Y : Natural) return Natural; procedure Set_Table (T : Integer; X, Y : Natural; Item : Natural); ----------- -- Graph -- ----------- G : Table_Id := No_Table; G_Len : Natural; -- Values table to compute G NT : Natural := Default_Tries; -- Number of tries running the algorithm before raising an error function Get_Graph (N : Natural) return Integer; procedure Set_Graph (N : Natural; Item : Integer); -- Get or Set Nth element of graph ----------- -- 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) Max_Key_Len : Natural := 0; Min_Key_Len : Natural := 0; -- Maximum and minimum 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; ------------------------ -- Ada_File_Base_Name -- ------------------------ function Ada_File_Base_Name (Pkg_Name : String) return String is begin -- Convert to lower case, then replace '.' with '-' return Result : String := To_Lower (Pkg_Name) do for J in Result'Range loop if Result (J) = '.' then Result (J) := '-'; end if; end loop; end return; end Ada_File_Base_Name; --------- -- Add -- --------- procedure Add (C : Character) is pragma Assert (C /= ASCII.NUL); begin Line (Last + 1) := C; Last := Last + 1; end Add; --------- -- Add -- --------- procedure Add (S : String) is Len : constant Natural := S'Length; begin for J in S'Range loop pragma Assert (S (J) /= ASCII.NUL); null; end loop; Line (Last + 1 .. Last + Len) := S; Last := Last + Len; end Add; -------------- -- Allocate -- -------------- function Allocate (N : Natural; S : Natural := 1) return Table_Id is L : constant Integer := IT.Last; begin IT.Set_Last (L + N * S); -- Initialize, so debugging printouts don't trip over uninitialized -- components. for J in L + 1 .. IT.Last loop IT.Table (J) := -1; end loop; return L + 1; end Allocate; ------------------------------ -- Apply_Position_Selection -- ------------------------------ procedure Apply_Position_Selection is begin for J in 0 .. NK - 1 loop declare IW : constant String := WT.Table (Initial (J)).all; RW : String (1 .. IW'Length) := (others => ASCII.NUL); N : Natural := IW'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 IW (Get_Char_Pos (C)) = ASCII.NUL; N := N + 1; RW (N) := IW (Get_Char_Pos (C)); end loop; -- Build the new table with the reduced word. Be careful -- to deallocate the old version to avoid memory leaks. Free_Word (WT.Table (Reduced (J))); WT.Table (Reduced (J)) := New_Word (RW); Set_Key (J, (Edge => No_Edge)); end; end loop; end Apply_Position_Selection; ------------------------------- -- 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 uninitialized value as it is supposed to -- be in the range 0 .. NK. if G = No_Table then G_Len := NV; G := Allocate (G_Len, 1); end if; for J in 0 .. G_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 .. G_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, G_Len); end if; end Assign_Values_To_Vertices; ------------- -- Compute -- ------------- procedure Compute (Position : String := Default_Position) is Success : Boolean := False; begin if NK = 0 then raise Program_Error with "keywords set cannot be empty"; end if; 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 for J in 1 .. NT 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. if 0 < Edges_Len and then Acyclic then Success := True; exit; end if; end loop; if not Success then raise Too_Many_Tries; end if; Assign_Values_To_Vertices; end Compute; -------------------------------- -- 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_G -------- -- 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; ---------- -- Move -- ---------- procedure Move (From : Natural; To : Natural) is begin Set_Edges (To, Get_Edges (From)); end Move; package Sorting is new GNAT.Heap_Sort_G (Move, 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_G. 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, T1_Len, T2_Len); Put_Int_Matrix (Output, "Function Table 2", T2, T1_Len, T2_Len); 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. Sorting.Sort (Edges_Len - 1); if Verbose then Put_Edges (Output, "Sorted Edge Table"); Put_Int_Matrix (Output, "Function Table 1", T1, T1_Len, T2_Len); Put_Int_Matrix (Output, "Function Table 2", T2, T1_Len, T2_Len); 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 := T1_Len; Length_2 := T2_Len; when Graph_Table => Item_Size := Type_Size (NK); Length_1 := NV; Length_2 := 0; end case; end Define; -------------- -- Finalize -- -------------- procedure Finalize is begin if Verbose then Put (Output, "Finalize"); New_Line (Output); end if; -- Deallocate all the WT components (both initial and reduced ones) to -- avoid memory leaks. for W in 0 .. WT.Last loop -- Note: WT.Table (NK) is a temporary variable, do not free it since -- this would cause a double free. if W /= NK then Free_Word (WT.Table (W)); end if; end loop; WT.Release; IT.Release; -- Reset all variables for next usage Keys := No_Table; 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; T1_Len := 0; T2_Len := 0; G := No_Table; G_Len := 0; Edges := No_Table; Edges_Len := 0; Vertices := No_Table; NV := 0; NK := 0; Max_Key_Len := 0; Min_Key_Len := 0; end Finalize; ---------------------------- -- Generate_Mapping_Table -- ---------------------------- procedure Generate_Mapping_Table (Tab : Integer; L1 : Natural; L2 : Natural; Seed : in out Natural) is begin for J in 0 .. L1 - 1 loop for K in 0 .. L2 - 1 loop Random (Seed); Set_Table (Tab, J, K, Seed mod NV); end loop; end loop; end Generate_Mapping_Table; ----------------------------- -- Generate_Mapping_Tables -- ----------------------------- procedure Generate_Mapping_Tables (Opt : Optimization; Seed : 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 changed. 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; T1_Len := Char_Pos_Set_Len; T2_Len := Used_Char_Last + 1; T1 := Allocate (T1_Len * T2_Len); T2 := Allocate (T1_Len * T2_Len); end; end if; Generate_Mapping_Table (T1, T1_Len, T2_Len, Seed); Generate_Mapping_Table (T2, T1_Len, T2_Len, Seed); if Verbose then Put_Used_Char_Set (Output, "Used Character Set"); Put_Int_Matrix (Output, "Function Table 1", T1, T1_Len, T2_Len); Put_Int_Matrix (Output, "Function Table 2", T2, T1_Len, T2_Len); 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 (N : Natural) return Integer is begin return IT.Table (G + N); end Get_Graph; ------------- -- Get_Key -- ------------- function Get_Key (N : Key_Id) return Key_Type is K : Key_Type; begin K.Edge := IT.Table (Keys + N); return K; end Get_Key; --------------- -- Get_Table -- --------------- function Get_Table (T : Integer; X, Y : Natural) return Natural is N : constant Natural := T + (Y * T1_Len) + X; begin return IT.Table (N); end Get_Table; ------------------- -- Get_Used_Char -- ------------------- function Get_Used_Char (C : Character) return Natural is N : constant Natural := Used_Char_Set + Character'Pos (C); 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 := Memory_Space; Tries : Positive := Default_Tries) is begin if Verbose then Put (Output, "Initialize"); New_Line (Output); end if; -- Deallocate the part of the table concerning the reduced words. -- Initial words are already present in the table. We may have reduced -- words already there because a previous computation failed. We are -- currently retrying and the reduced words have to be deallocated. for W in Reduced (0) .. WT.Last loop Free_Word (WT.Table (W)); end loop; IT.Init; -- Initialize of computation variables Keys := No_Table; 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; T1_Len := 0; T2_Len := 0; G := No_Table; G_Len := 0; Edges := No_Table; Edges_Len := 0; Vertices := No_Table; NV := 0; S := Seed; K2V := K_To_V; Opt := Optim; NT := Tries; if K2V <= 2.0 then raise Program_Error with "K to V ratio cannot be lower than 2.0"; end if; -- Do not accept a value of K2V too close to 2.0 such that once -- rounded up, NV = 2 * NK because the algorithm would not converge. NV := Natural (Float (NK) * K2V); if NV <= 2 * NK then NV := 2 * NK + 1; end if; Keys := Allocate (NK); -- Resize initial words to have all of them at the same size -- (so the size of the largest one). for K in 0 .. NK - 1 loop Resize_Word (WT.Table (Initial (K)), Max_Key_Len); end loop; -- Allocated the table to store the reduced words. As WT is a -- GNAT.Table (using C memory management), pointers have to be -- explicitly initialized to null. WT.Set_Last (Reduced (NK - 1)); -- Note: Reduced (0) = NK + 1 WT.Table (NK) := null; for W in 0 .. NK - 1 loop WT.Table (Reduced (W)) := null; end loop; end Initialize; ------------ -- Insert -- ------------ procedure Insert (Value : String) is Len : constant Natural := Value'Length; begin if Verbose then Put (Output, "Inserting """ & Value & """"); New_Line (Output); end if; for J in Value'Range loop pragma Assert (Value (J) /= ASCII.NUL); null; end loop; WT.Set_Last (NK); WT.Table (NK) := New_Word (Value); NK := NK + 1; if Max_Key_Len < Len then Max_Key_Len := Len; end if; if Min_Key_Len = 0 or else Len < Min_Key_Len then Min_Key_Len := Len; end if; end Insert; -------------- -- New_Line -- -------------- procedure New_Line (File : File_Descriptor) is begin if Write (File, EOL'Address, 1) /= 1 then raise Program_Error; end if; end New_Line; -------------- -- New_Word -- -------------- function New_Word (S : String) return Word_Type is begin return new String'(S); end New_Word; ------------------------------ -- Parse_Position_Selection -- ------------------------------ procedure Parse_Position_Selection (Argument : String) is N : Natural := Argument'First; L : constant Natural := Argument'Last; M : constant Natural := Max_Key_Len; 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 Program_Error with "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 -- Empty specification means all the positions if L < N then Char_Pos_Set_Len := M; Char_Pos_Set := Allocate (Char_Pos_Set_Len); 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 Program_Error with "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); 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; Use_Stdout : Boolean := False) is File : File_Descriptor := Standout; Status : Boolean; -- For call to Close function Array_Img (N, T, R1 : String; R2 : String := "") return String; -- Return string "N : constant array (R1[, R2]) of T;" function Range_Img (F, L : Natural; T : String := "") return String; -- Return string "[T range ]F .. L" function Type_Img (L : Natural) return String; -- Return the larger unsigned type T such that T'Last < L --------------- -- 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; --------------- -- 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; -------------- -- 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; F : Natural; L : Natural; P : Natural; FName : String := Ada_File_Base_Name (Pkg_Name) & ".ads"; -- Initially, the name of the spec file, then modified to be the name of -- the body file. Not used if Use_Stdout is True. -- Start of processing for Produce begin if Verbose and then not Use_Stdout then Put (Output, "Producing " & Ada.Directories.Current_Directory & "/" & FName); New_Line (Output); end if; if not Use_Stdout then File := Create_File (FName, Binary); if File = Invalid_FD then raise Program_Error with "cannot create: " & FName; end if; end if; 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); if not Use_Stdout then Close (File, Status); if not Status then raise Device_Error; end if; end if; if not Use_Stdout then -- Set to body file name FName (FName'Last) := 'b'; File := Create_File (FName, Binary); if File = Invalid_FD then raise Program_Error with "cannot create: " & FName; end if; end if; 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), 1, 0, 1, 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)), 1, 0, 1, F, L, J); end loop; New_Line (File); case Opt is when CPU_Time => Put_Int_Matrix (File, Array_Img ("T1", Type_Img (NV), Range_Img (0, T1_Len - 1), Range_Img (0, T2_Len - 1, Type_Img (256))), T1, T1_Len, T2_Len); when Memory_Space => Put_Int_Matrix (File, Array_Img ("T1", Type_Img (NV), Range_Img (0, T1_Len - 1)), T1, T1_Len, 0); end case; New_Line (File); case Opt is when CPU_Time => Put_Int_Matrix (File, Array_Img ("T2", Type_Img (NV), Range_Img (0, T1_Len - 1), Range_Img (0, T2_Len - 1, Type_Img (256))), T2, T1_Len, T2_Len); when Memory_Space => Put_Int_Matrix (File, Array_Img ("T2", Type_Img (NV), Range_Img (0, T1_Len - 1)), T2, T1_Len, 0); end case; New_Line (File); Put_Int_Vector (File, Array_Img ("G", Type_Img (NK), Range_Img (0, G_Len - 1)), G, G_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 : "); case Opt is when CPU_Time => Put (File, Type_Img (256)); when Memory_Space => Put (File, "Natural"); end case; 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 := "); case Opt is when CPU_Time => Put (File, "C"); when Memory_Space => Put (File, "Character'Pos"); end case; 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); if not Use_Stdout then Close (File, Status); if not Status then raise Device_Error; end if; end if; end Produce; --------- -- Put -- --------- procedure Put (File : File_Descriptor; Str : String) is Len : constant Natural := Str'Length; begin for J in Str'Range loop pragma Assert (Str (J) /= ASCII.NUL); null; end loop; if Write (File, Str'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; -- Write current line, followed by LF ----------- -- 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 Add (" "); if F1 <= L1 then if C1 = F1 and then C2 = F2 then Add ('('); if F1 = L1 then Add ("0 .. 0 => "); end if; else Add (' '); end if; end if; end if; if C2 = F2 then Add ('('); if F2 = L2 then Add ("0 .. 0 => "); end if; else Add (' '); end if; Add (S); 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_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, Trim_Trailing_Nuls (WT.Table (Initial (J)).all), F1, L1, J, 1, 3, 3); end loop; end Put_Initial_Keys; -------------------- -- Put_Int_Matrix -- -------------------- procedure Put_Int_Matrix (File : File_Descriptor; Title : String; Table : Integer; Len_1 : Natural; Len_2 : Natural) is F1 : constant Integer := 0; L1 : constant Integer := Len_1 - 1; F2 : constant Integer := 0; L2 : constant Integer := Len_2 - 1; Ix : Natural; begin Put (File, Title); New_Line (File); if Len_2 = 0 then for J in F1 .. L1 loop Ix := IT.Table (Table + J); Put (File, Image (Ix), 1, 0, 1, F1, L1, J); end loop; else for J in F1 .. L1 loop for K in F2 .. L2 loop Ix := IT.Table (Table + J + K * Len_1); Put (File, Image (Ix), 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; Vector : 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 (Vector + J)), 1, 0, 1, F2, L2, J); end loop; end Put_Int_Vector; ---------------------- -- 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, Trim_Trailing_Nuls (WT.Table (Reduced (J)).all), F1, L1, J, 1, 3, 3); end loop; end Put_Reduced_Keys; ----------------------- -- 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)), 1, 0, 1, F, L, Character'Pos (J)); end loop; end Put_Used_Char_Set; ---------------------- -- 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; Seed := (if X < 0 then X + 2147483647 else X); end Random; ------------- -- Reduced -- ------------- function Reduced (K : Key_Id) return Word_Id is begin return K + NK + 1; end Reduced; ----------------- -- Resize_Word -- ----------------- procedure Resize_Word (W : in out Word_Type; Len : Natural) is S1 : constant String := W.all; S2 : String (1 .. Len) := (others => ASCII.NUL); L : constant Natural := S1'Length; begin if L /= Len then Free_Word (W); S2 (1 .. L) := S1; W := New_Word (S2); end if; end Resize_Word; -------------------------- -- 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 : 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. -- Need comment saying exactly what Last is ??? function Count_Different_Keys (Table : Vertex_Table_Type; Last : Natural; Pos : Natural) return Natural; -- For each subset in Sets, count the number of different keys if we add -- Pos to the current position selection. Sel_Position : IT.Table_Type (1 .. Max_Key_Len); Last_Sel_Pos : Natural := 0; Max_Sel_Pos : Natural := 0; ------------------------------- -- Build_Identical_Keys_Sets -- ------------------------------- procedure Build_Identical_Keys_Sets (Table : in out Vertex_Table_Type; Last : in out Natural; Pos : Natural) is S : constant Vertex_Table_Type := Table (Table'First .. Last); C : constant Natural := Pos; -- Shortcuts (why are these not renames ???) F : Integer; L : Integer; -- First and last words of a subset Offset : Natural; -- GNAT.Heap_Sort assumes that the first array index is 1. Offset -- defines the translation to operate. function Lt (L, R : Natural) return Boolean; procedure Move (From : Natural; To : Natural); -- Subprograms needed by GNAT.Heap_Sort_G -------- -- Lt -- -------- function Lt (L, R : Natural) return Boolean is C : constant Natural := Pos; Left : Natural; Right : Natural; begin if L = 0 then Left := NK; Right := Offset + R; elsif R = 0 then Left := Offset + L; Right := NK; else Left := Offset + L; Right := Offset + R; end if; return WT.Table (Left)(C) < WT.Table (Right)(C); end Lt; ---------- -- Move -- ---------- procedure Move (From : Natural; To : Natural) is Target, Source : Natural; begin if From = 0 then Source := NK; Target := Offset + To; elsif To = 0 then Source := Offset + From; Target := NK; else Source := Offset + From; Target := Offset + To; end if; WT.Table (Target) := WT.Table (Source); WT.Table (Source) := null; end Move; package Sorting is new GNAT.Heap_Sort_G (Move, Lt); -- Start of processing for Build_Identical_Key_Sets 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 if S (J).First = S (J).Last then F := S (J).First; L := S (J).Last; Last := Last + 1; Table (Last) := (F, L); else Offset := Reduced (S (J).First) - 1; Sorting.Sort (S (J).Last - S (J).First + 1); F := S (J).First; L := F; for N in S (J).First .. S (J).Last loop -- For the last item, close the last subset if N = S (J).Last then Last := Last + 1; Table (Last) := (F, N); -- Two contiguous words are identical when they have the -- same Cth character. elsif WT.Table (Reduced (N))(C) = WT.Table (Reduced (N + 1))(C) then L := N + 1; -- Find a new subset of identical keys. Store the current -- one and create a new subset. else Last := Last + 1; Table (Last) := (F, L); F := N + 1; L := F; end if; end loop; end if; end loop; end Build_Identical_Keys_Sets; -------------------------- -- Count_Different_Keys -- -------------------------- function Count_Different_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 -- different when we include 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; -- Update the number of different keys. Each character used -- denotes a different key. for J in N'Range loop if N (J) > 0 then T := T + 1; end if; end loop; end loop; return T; end Count_Different_Keys; -- Start of processing for Select_Char_Position begin -- Initialize the reduced words set for K in 0 .. NK - 1 loop WT.Table (Reduced (K)) := New_Word (WT.Table (Initial (K)).all); end loop; declare Differences : Natural; Max_Differences : Natural := 0; Old_Differences : Natural; Max_Diff_Sel_Pos : Natural := 0; -- init to kill warning Max_Diff_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 for C in Sel_Position'Range loop Sel_Position (C) := C; end loop; Same_Keys_Sets_Table (1) := (0, NK - 1); loop -- Preserve maximum number of different keys and check later on -- that this value is strictly incrementing. Otherwise, it means -- that two keys are strictly identical. Old_Differences := Max_Differences; -- The first position should not exceed the minimum key length. -- Otherwise, we may end up with an empty word once reduced. Max_Sel_Pos := (if Last_Sel_Pos = 0 then Min_Key_Len else Max_Key_Len); -- Find which position increases more the number of differences for J in Last_Sel_Pos + 1 .. Max_Sel_Pos loop Differences := Count_Different_Keys (Same_Keys_Sets_Table, Same_Keys_Sets_Last, Sel_Position (J)); if Verbose then Put (Output, "Selecting position" & Sel_Position (J)'Img & " results in" & Differences'Img & " differences"); New_Line (Output); end if; if Differences > Max_Differences then Max_Differences := Differences; Max_Diff_Sel_Pos := Sel_Position (J); Max_Diff_Sel_Pos_Idx := J; end if; end loop; if Old_Differences = Max_Differences then raise Program_Error with "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 .. Max_Diff_Sel_Pos_Idx) := Sel_Position (Last_Sel_Pos .. Max_Diff_Sel_Pos_Idx - 1); Sel_Position (Last_Sel_Pos) := Max_Diff_Sel_Pos; for P in 1 .. Last_Sel_Pos - 1 loop if Max_Diff_Sel_Pos < Sel_Position (P) then Sel_Position (P + 1 .. Last_Sel_Pos) := Sel_Position (P .. Last_Sel_Pos - 1); Sel_Position (P) := Max_Diff_Sel_Pos; exit; end if; end loop; exit when Max_Differences = NK; Build_Identical_Keys_Sets (Same_Keys_Sets_Table, Same_Keys_Sets_Last, Max_Diff_Sel_Pos); if Verbose then Put (Output, "Selecting position" & Max_Diff_Sel_Pos'Img & " results in" & Max_Differences'Img & " differences"); New_Line (Output); Put (Output, "--"); New_Line (Output); for J in 1 .. Same_Keys_Sets_Last loop for K in Same_Keys_Sets_Table (J).First .. Same_Keys_Sets_Table (J).Last loop Put (Output, Trim_Trailing_Nuls (WT.Table (Reduced (K)).all)); New_Line (Output); end loop; Put (Output, "--"); New_Line (Output); end loop; end if; end loop; end; Char_Pos_Set_Len := Last_Sel_Pos; Char_Pos_Set := Allocate (Char_Pos_Set_Len); for C in 1 .. Last_Sel_Pos loop Set_Char_Pos (C - 1, Sel_Position (C)); end loop; end Select_Char_Position; -------------------------- -- Select_Character_Set -- -------------------------- procedure Select_Character_Set is Last : Natural := 0; Used : array (Character) of Boolean := (others => False); Char : Character; begin for J in 0 .. NK - 1 loop for K in 0 .. Char_Pos_Set_Len - 1 loop Char := WT.Table (Initial (J))(Get_Char_Pos (K)); exit when Char = ASCII.NUL; Used (Char) := True; end loop; end loop; Used_Char_Set_Len := 256; Used_Char_Set := Allocate (Used_Char_Set_Len); 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; ------------------ -- 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 (N : Natural; Item : Integer) is begin IT.Table (G + N) := Item; end Set_Graph; ------------- -- Set_Key -- ------------- procedure Set_Key (N : Key_Id; Item : Key_Type) is begin IT.Table (Keys + N) := Item.Edge; end Set_Key; --------------- -- Set_Table -- --------------- procedure Set_Table (T : Integer; X, Y : Natural; Item : Natural) is N : constant Natural := T + ((Y * T1_Len) + X); begin IT.Table (N) := Item; end Set_Table; ------------------- -- Set_Used_Char -- ------------------- procedure Set_Used_Char (C : Character; Item : Natural) is N : constant Natural := Used_Char_Set + Character'Pos (C); 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 case Opt is when CPU_Time => for J in 0 .. T1_Len - 1 loop exit when Word (J + 1) = ASCII.NUL; R := Get_Table (Table, J, Get_Used_Char (Word (J + 1))); S := (S + R) mod NV; end loop; when Memory_Space => for J in 0 .. T1_Len - 1 loop exit when Word (J + 1) = ASCII.NUL; R := Get_Table (Table, J, 0); S := (S + R * Character'Pos (Word (J + 1))) mod NV; end loop; end case; return S; end Sum; ------------------------ -- Trim_Trailing_Nuls -- ------------------------ function Trim_Trailing_Nuls (Str : String) return String is begin for J in reverse Str'Range loop if Str (J) /= ASCII.NUL then return Str (Str'First .. J); end if; end loop; return Str; end Trim_Trailing_Nuls; --------------- -- 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_Table (T1, J, K); when Function_Table_2 => return Get_Table (T2, J, K); when Graph_Table => return Get_Graph (J); end case; end Value; end GNAT.Perfect_Hash_Generators;
Go to most recent revision | Compare with Previous | Blame | View Log