------------------------------------------------------------------------------ -- -- -- 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-2022, 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 -- -- . -- -- -- -- 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 GNAT.OS_Lib; use GNAT.OS_Lib; package body GNAT.Perfect_Hash_Generators is use SPHG; 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. EOL : constant Character := ASCII.LF; Max : constant := 78; Last : Natural := 0; Line : String (1 .. Max); -- Use this line to provide buffered IO NK : Natural := 0; -- NK : Number of Keys Opt : Optimization; -- Optimization mode (memory vs CPU) 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_Int_Matrix (File : File_Descriptor; Title : String; Table : Table_Name; 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. 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". ------------------------ -- 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; ------------- -- Compute -- ------------- procedure Compute (Position : String := Default_Position) is begin SPHG.Compute (Position); end Compute; -------------- -- Finalize -- -------------- procedure Finalize is begin NK := 0; SPHG.Finalize; end Finalize; ----------- -- 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; ---------------- -- Initialize -- ---------------- procedure Initialize (Seed : Natural; K_To_V : Float := Default_K_To_V; Optim : Optimization := Memory_Space; Tries : Positive := Default_Tries) is V : constant Positive := Positive (Float (NK) * K_To_V); begin Opt := Optim; SPHG.Initialize (Seed, V, SPHG.Optimization (Optim), Tries); end Initialize; ------------ -- Insert -- ------------ procedure Insert (Value : String) is begin NK := NK + 1; SPHG.Insert (Value); 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; ------------- -- Produce -- ------------- procedure Produce (Pkg_Name : String := Default_Pkg_Name; Use_Stdout : Boolean := False) is File : File_Descriptor := Standout; Siz, L1, L2 : Natural; -- For calls to Define 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 (Siz : Positive) return String; -- Return the name of the unsigned type of size S --------------- -- 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 (Siz : Positive) return String is S : constant String := Image (Siz); 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; 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 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 -- The format of this table is fixed Define (Used_Character_Set, Siz, L1, L2); pragma Assert (L1 = 256 and then L2 = 0); Put (File, Array_Img ("C", Type_Img (Siz), "Character")); New_Line (File); for J in 0 .. 255 loop P := Value (Used_Character_Set, J); Put (File, Image (P), 1, 0, 1, 0, 255, J); end loop; New_Line (File); end if; Define (Character_Position, Siz, L1, L2); pragma Assert (Siz = 31 and then L2 = 0); Put (File, Array_Img ("P", "Natural", Range_Img (0, L1 - 1))); New_Line (File); for J in 0 .. L1 - 1 loop P := Value (Character_Position, J); Put (File, Image (P), 1, 0, 1, 0, L1 - 1, J); end loop; New_Line (File); Define (Function_Table_1, Siz, L1, L2); case Opt is when CPU_Time => Put_Int_Matrix (File, Array_Img ("T1", Type_Img (Siz), Range_Img (0, L1 - 1), Range_Img (0, L2 - 1, Type_Img (8))), Function_Table_1, L1, L2); when Memory_Space => Put_Int_Matrix (File, Array_Img ("T1", Type_Img (Siz), Range_Img (0, L1 - 1)), Function_Table_1, L1, 0); end case; New_Line (File); Define (Function_Table_2, Siz, L1, L2); case Opt is when CPU_Time => Put_Int_Matrix (File, Array_Img ("T2", Type_Img (Siz), Range_Img (0, L1 - 1), Range_Img (0, L2 - 1, Type_Img (8))), Function_Table_2, L1, L2); when Memory_Space => Put_Int_Matrix (File, Array_Img ("T2", Type_Img (Siz), Range_Img (0, L1 - 1)), Function_Table_2, L1, 0); end case; New_Line (File); Define (Graph_Table, Siz, L1, L2); pragma Assert (L2 = 0); Put (File, Array_Img ("G", Type_Img (Siz), Range_Img (0, L1 - 1))); New_Line (File); for J in 0 .. L1 - 1 loop P := Value (Graph_Table, J); Put (File, Image (P), 1, 0, 1, 0, L1 - 1, J); end loop; 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 (8)); 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 (L1)); 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 (L1)); 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_Int_Matrix -- -------------------- procedure Put_Int_Matrix (File : File_Descriptor; Title : String; Table : Table_Name; 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 := Value (Table, J, 0); 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 := Value (Table, J, K); Put (File, Image (Ix), F1, L1, J, F2, L2, K); end loop; end loop; end if; end Put_Int_Matrix; end GNAT.Perfect_Hash_Generators;