1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- G N A T . P E R F E C T _ H A S H _ G E N E R A T O R S --
9 -- Copyright (C) 2002-2024, AdaCore --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 with Ada
.IO_Exceptions
; use Ada
.IO_Exceptions
;
33 with Ada
.Characters
.Handling
; use Ada
.Characters
.Handling
;
35 with GNAT
.OS_Lib
; use GNAT
.OS_Lib
;
37 package body GNAT
.Perfect_Hash_Generators
is
41 function Image
(Int
: Integer; W
: Natural := 0) return String;
42 function Image
(Str
: String; W
: Natural := 0) return String;
43 -- Return a string which includes string Str or integer Int preceded by
44 -- leading spaces if required by width W.
46 EOL
: constant Character := ASCII
.LF
;
50 Line
: String (1 .. Max
);
51 -- Use this line to provide buffered IO
54 -- NK : Number of Keys
57 -- Optimization mode (memory vs CPU)
59 procedure Add
(C
: Character);
60 procedure Add
(S
: String);
61 -- Add a character or a string in Line and update Last
72 -- Write string S into file F as a element of an array of one or two
73 -- dimensions. Fk (resp. Lk and Ck) indicates the first (resp last and
74 -- current) index in the k-th dimension. If F1 = L1 the array is considered
75 -- as a one dimension array. This dimension is described by F2 and L2. This
76 -- routine takes care of all the parenthesis, spaces and commas needed to
77 -- format correctly the array. Moreover, the array is well indented and is
78 -- wrapped to fit in a 80 col line. When the line is full, the routine
79 -- writes it into file F. When the array is completed, the routine adds
80 -- semi-colon and writes the line into file F.
82 procedure New_Line
(File
: File_Descriptor
);
83 -- Simulate Ada.Text_IO.New_Line with GNAT.OS_Lib
85 procedure Put
(File
: File_Descriptor
; Str
: String);
86 -- Simulate Ada.Text_IO.Put with GNAT.OS_Lib
88 procedure Put_Int_Matrix
89 (File
: File_Descriptor
;
94 -- Output a title and a matrix. When the matrix has only one non-empty
95 -- dimension (Len_2 = 0), output a vector.
97 function Ada_File_Base_Name
(Pkg_Name
: String) return String;
98 -- Return the base file name (i.e. without .ads/.adb extension) for an
99 -- Ada source file containing the named package, using the standard GNAT
100 -- file-naming convention. For example, if Pkg_Name is "Parent.Child", we
101 -- return "parent-child".
103 ------------------------
104 -- Ada_File_Base_Name --
105 ------------------------
107 function Ada_File_Base_Name
(Pkg_Name
: String) return String is
109 -- Convert to lower case, then replace '.' with '-'
111 return Result
: String := To_Lower
(Pkg_Name
) do
112 for J
in Result
'Range loop
113 if Result
(J
) = '.' then
118 end Ada_File_Base_Name
;
124 procedure Add
(C
: Character) is
125 pragma Assert
(C
/= ASCII
.NUL
);
127 Line
(Last
+ 1) := C
;
135 procedure Add
(S
: String) is
136 Len
: constant Natural := S
'Length;
138 for J
in S
'Range loop
139 pragma Assert
(S
(J
) /= ASCII
.NUL
);
143 Line
(Last
+ 1 .. Last
+ Len
) := S
;
151 procedure Compute
(Position
: String := Default_Position
) is
153 SPHG
.Compute
(Position
);
160 procedure Finalize
is
170 function Image
(Int
: Integer; W
: Natural := 0) return String is
171 B
: String (1 .. 32);
174 procedure Img
(V
: Natural);
175 -- Compute image of V into B, starting at B (L), incrementing L
181 procedure Img
(V
: Natural) is
188 B
(L
) := Character'Val ((V
mod 10) + Character'Pos ('0'));
191 -- Start of processing for Image
202 return Image
(B
(1 .. L
), W
);
209 function Image
(Str
: String; W
: Natural := 0) return String is
210 Len
: constant Natural := Str
'Length;
211 Max
: Natural := Len
;
219 Buf
: String (1 .. Max
) := (1 .. Max
=> ' ');
222 for J
in 0 .. Len
- 1 loop
223 Buf
(Max
- Len
+ 1 + J
) := Str
(Str
'First + J
);
236 K_To_V
: Float := Default_K_To_V
;
237 Optim
: Optimization
:= Memory_Space
;
238 Tries
: Positive := Default_Tries
)
240 V
: constant Positive := Positive (Float (NK
) * K_To_V
);
244 SPHG
.Initialize
(Seed
, V
, SPHG
.Optimization
(Optim
), Tries
);
251 procedure Insert
(Value
: String) is
261 procedure New_Line
(File
: File_Descriptor
) is
263 if Write
(File
, EOL
'Address, 1) /= 1 then
273 (Pkg_Name
: String := Default_Pkg_Name
;
274 Use_Stdout
: Boolean := False)
276 File
: File_Descriptor
:= Standout
;
278 Siz
, L1
, L2
: Natural;
279 -- For calls to Define
284 function Array_Img
(N
, T
, R1
: String; R2
: String := "") return String;
285 -- Return string "N : constant array (R1[, R2]) of T;"
287 function Range_Img
(F
, L
: Natural; T
: String := "") return String;
288 -- Return string "[T range ]F .. L"
290 function Type_Img
(Siz
: Positive) return String;
291 -- Return the name of the unsigned type of size S
299 R2
: String := "") return String
305 Add
(" : constant array (");
316 return Line
(1 .. Last
);
323 function Range_Img
(F
, L
: Natural; T
: String := "") return String is
324 FI
: constant String := Image
(F
);
325 FL
: constant Natural := FI
'Length;
326 LI
: constant String := Image
(L
);
327 LL
: constant Natural := LI
'Length;
328 TL
: constant Natural := T
'Length;
329 RI
: String (1 .. TL
+ 7 + FL
+ 4 + LL
);
334 RI
(Len
+ 1 .. Len
+ TL
) := T
;
336 RI
(Len
+ 1 .. Len
+ 7) := " range ";
340 RI
(Len
+ 1 .. Len
+ FL
) := FI
;
342 RI
(Len
+ 1 .. Len
+ 4) := " .. ";
344 RI
(Len
+ 1 .. Len
+ LL
) := LI
;
346 return RI
(1 .. Len
);
353 function Type_Img
(Siz
: Positive) return String is
354 S
: constant String := Image
(Siz
);
355 U
: String := "Unsigned_ ";
359 for J
in S
'Range loop
369 FName
: String := Ada_File_Base_Name
(Pkg_Name
) & ".ads";
370 -- Initially, the name of the spec file, then modified to be the name of
371 -- the body file. Not used if Use_Stdout is True.
373 -- Start of processing for Produce
376 if not Use_Stdout
then
377 File
:= Create_File
(FName
, Binary
);
379 if File
= Invalid_FD
then
380 raise Program_Error
with "cannot create: " & FName
;
384 Put
(File
, "package ");
385 Put
(File
, Pkg_Name
);
388 Put
(File
, " function Hash (S : String) return Natural;");
391 Put
(File
, Pkg_Name
);
395 if not Use_Stdout
then
396 Close
(File
, Status
);
403 if not Use_Stdout
then
405 -- Set to body file name
407 FName
(FName
'Last) := 'b';
409 File
:= Create_File
(FName
, Binary
);
411 if File
= Invalid_FD
then
412 raise Program_Error
with "cannot create: " & FName
;
416 Put
(File
, "with Interfaces; use Interfaces;");
419 Put
(File
, "package body ");
420 Put
(File
, Pkg_Name
);
425 if Opt
= CPU_Time
then
426 -- The format of this table is fixed
428 Define
(Used_Character_Set
, Siz
, L1
, L2
);
429 pragma Assert
(L1
= 256 and then L2
= 0);
431 Put
(File
, Array_Img
("C", Type_Img
(Siz
), "Character"));
434 for J
in 0 .. 255 loop
435 P
:= Value
(Used_Character_Set
, J
);
436 Put
(File
, Image
(P
), 1, 0, 1, 0, 255, J
);
442 Define
(Character_Position
, Siz
, L1
, L2
);
443 pragma Assert
(Siz
= 31 and then L2
= 0);
445 Put
(File
, Array_Img
("P", "Natural", Range_Img
(0, L1
- 1)));
448 for J
in 0 .. L1
- 1 loop
449 P
:= Value
(Character_Position
, J
);
450 Put
(File
, Image
(P
), 1, 0, 1, 0, L1
- 1, J
);
455 Define
(Function_Table_1
, Siz
, L1
, L2
);
461 Array_Img
("T1", Type_Img
(Siz
),
462 Range_Img
(0, L1
- 1),
463 Range_Img
(0, L2
- 1, Type_Img
(8))),
464 Function_Table_1
, L1
, L2
);
469 Array_Img
("T1", Type_Img
(Siz
),
470 Range_Img
(0, L1
- 1)),
471 Function_Table_1
, L1
, 0);
476 Define
(Function_Table_2
, Siz
, L1
, L2
);
482 Array_Img
("T2", Type_Img
(Siz
),
483 Range_Img
(0, L1
- 1),
484 Range_Img
(0, L2
- 1, Type_Img
(8))),
485 Function_Table_2
, L1
, L2
);
490 Array_Img
("T2", Type_Img
(Siz
),
491 Range_Img
(0, L1
- 1)),
492 Function_Table_2
, L1
, 0);
497 Define
(Graph_Table
, Siz
, L1
, L2
);
498 pragma Assert
(L2
= 0);
500 Put
(File
, Array_Img
("G", Type_Img
(Siz
),
501 Range_Img
(0, L1
- 1)));
504 for J
in 0 .. L1
- 1 loop
505 P
:= Value
(Graph_Table
, J
);
506 Put
(File
, Image
(P
), 1, 0, 1, 0, L1
- 1, J
);
511 Put
(File
, " function Hash (S : String) return Natural is");
513 Put
(File
, " F : constant Natural := S'First - 1;");
515 Put
(File
, " L : constant Natural := S'Length;");
517 Put
(File
, " F1, F2 : Natural := 0;");
524 Put
(File
, Type_Img
(8));
527 Put
(File
, "Natural");
533 Put
(File
, " begin");
535 Put
(File
, " for K in P'Range loop");
537 Put
(File
, " exit when L < P (K);");
539 Put
(File
, " J := ");
546 Put
(File
, "Character'Pos");
549 Put
(File
, " (S (P (K) + F));");
552 Put
(File
, " F1 := (F1 + Natural (T1 (K");
554 if Opt
= CPU_Time
then
560 if Opt
= Memory_Space
then
564 Put
(File
, ") mod ");
565 Put
(File
, Image
(L1
));
569 Put
(File
, " F2 := (F2 + Natural (T2 (K");
571 if Opt
= CPU_Time
then
577 if Opt
= Memory_Space
then
581 Put
(File
, ") mod ");
582 Put
(File
, Image
(L1
));
586 Put
(File
, " end loop;");
590 " return (Natural (G (F1)) + Natural (G (F2))) mod ");
592 Put
(File
, Image
(NK
));
595 Put
(File
, " end Hash;");
599 Put
(File
, Pkg_Name
);
603 if not Use_Stdout
then
604 Close
(File
, Status
);
616 procedure Put
(File
: File_Descriptor
; Str
: String) is
617 Len
: constant Natural := Str
'Length;
619 for J
in Str
'Range loop
620 pragma Assert
(Str
(J
) /= ASCII
.NUL
);
624 if Write
(File
, Str
'Address, Len
) /= Len
then
634 (F
: File_Descriptor
;
643 Len
: constant Natural := S
'Length;
646 -- Write current line, followed by LF
654 Put
(F
, Line
(1 .. Last
));
659 -- Start of processing for Put
662 if C1
= F1
and then C2
= F2
then
666 if Last
+ Len
+ 3 >= Max
then
674 if C1
= F1
and then C2
= F2
then
726 procedure Put_Int_Matrix
727 (File
: File_Descriptor
;
733 F1
: constant Integer := 0;
734 L1
: constant Integer := Len_1
- 1;
735 F2
: constant Integer := 0;
736 L2
: constant Integer := Len_2
- 1;
744 for J
in F1
.. L1
loop
745 Ix
:= Value
(Table
, J
, 0);
746 Put
(File
, Image
(Ix
), 1, 0, 1, F1
, L1
, J
);
750 for J
in F1
.. L1
loop
751 for K
in F2
.. L2
loop
752 Ix
:= Value
(Table
, J
, K
);
753 Put
(File
, Image
(Ix
), F1
, L1
, J
, F2
, L2
, K
);
759 end GNAT
.Perfect_Hash_Generators
;