diff options
Diffstat (limited to 'gcc-4.8/gcc/ada/g-pehage.adb')
| -rw-r--r-- | gcc-4.8/gcc/ada/g-pehage.adb | 2598 |
1 files changed, 0 insertions, 2598 deletions
diff --git a/gcc-4.8/gcc/ada/g-pehage.adb b/gcc-4.8/gcc/ada/g-pehage.adb deleted file mode 100644 index ce2428ddd..000000000 --- a/gcc-4.8/gcc/ada/g-pehage.adb +++ /dev/null @@ -1,2598 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; |