1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
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           --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--                     Copyright (C) 2002-2021, AdaCore                     --
10--                                                                          --
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.                                     --
17--                                                                          --
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.               --
21--                                                                          --
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/>.                                          --
26--                                                                          --
27-- GNAT was originally developed  by the GNAT team at  New York University. --
28-- Extensive contributions were provided by Ada Core Technologies Inc.      --
29--                                                                          --
30------------------------------------------------------------------------------
31
32with Ada.IO_Exceptions;       use Ada.IO_Exceptions;
33with Ada.Characters.Handling; use Ada.Characters.Handling;
34
35with GNAT.OS_Lib;             use GNAT.OS_Lib;
36
37package body GNAT.Perfect_Hash_Generators is
38
39   use SPHG;
40
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.
45
46   EOL : constant Character := ASCII.LF;
47
48   Max  : constant := 78;
49   Last : Natural  := 0;
50   Line : String (1 .. Max);
51   --  Use this line to provide buffered IO
52
53   NK : Natural  := 0;
54   --  NK : Number of Keys
55
56   Opt : Optimization;
57   --  Optimization mode (memory vs CPU)
58
59   procedure Add (C : Character);
60   procedure Add (S : String);
61   --  Add a character or a string in Line and update Last
62
63   procedure Put
64     (F  : File_Descriptor;
65      S  : String;
66      F1 : Natural;
67      L1 : Natural;
68      C1 : Natural;
69      F2 : Natural;
70      L2 : Natural;
71      C2 : Natural);
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.
81
82   procedure New_Line (File : File_Descriptor);
83   --  Simulate Ada.Text_IO.New_Line with GNAT.OS_Lib
84
85   procedure Put (File : File_Descriptor; Str : String);
86   --  Simulate Ada.Text_IO.Put with GNAT.OS_Lib
87
88   procedure Put_Int_Matrix
89     (File  : File_Descriptor;
90      Title : String;
91      Table : Table_Name;
92      Len_1 : Natural;
93      Len_2 : Natural);
94   --  Output a title and a matrix. When the matrix has only one non-empty
95   --  dimension (Len_2 = 0), output a vector.
96
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".
102
103   ------------------------
104   -- Ada_File_Base_Name --
105   ------------------------
106
107   function Ada_File_Base_Name (Pkg_Name : String) return String is
108   begin
109      --  Convert to lower case, then replace '.' with '-'
110
111      return Result : String := To_Lower (Pkg_Name) do
112         for J in Result'Range loop
113            if Result (J) = '.' then
114               Result (J) := '-';
115            end if;
116         end loop;
117      end return;
118   end Ada_File_Base_Name;
119
120   ---------
121   -- Add --
122   ---------
123
124   procedure Add (C : Character) is
125      pragma Assert (C /= ASCII.NUL);
126   begin
127      Line (Last + 1) := C;
128      Last := Last + 1;
129   end Add;
130
131   ---------
132   -- Add --
133   ---------
134
135   procedure Add (S : String) is
136      Len : constant Natural := S'Length;
137   begin
138      for J in S'Range loop
139         pragma Assert (S (J) /= ASCII.NUL);
140         null;
141      end loop;
142
143      Line (Last + 1 .. Last + Len) := S;
144      Last := Last + Len;
145   end Add;
146
147   -------------
148   -- Compute --
149   -------------
150
151   procedure Compute (Position : String := Default_Position) is
152   begin
153      SPHG.Compute (Position);
154   end Compute;
155
156   --------------
157   -- Finalize --
158   --------------
159
160   procedure Finalize is
161   begin
162      NK := 0;
163      SPHG.Finalize;
164   end Finalize;
165
166   -----------
167   -- Image --
168   -----------
169
170   function Image (Int : Integer; W : Natural := 0) return String is
171      B : String (1 .. 32);
172      L : Natural := 0;
173
174      procedure Img (V : Natural);
175      --  Compute image of V into B, starting at B (L), incrementing L
176
177      ---------
178      -- Img --
179      ---------
180
181      procedure Img (V : Natural) is
182      begin
183         if V > 9 then
184            Img (V / 10);
185         end if;
186
187         L := L + 1;
188         B (L) := Character'Val ((V mod 10) + Character'Pos ('0'));
189      end Img;
190
191   --  Start of processing for Image
192
193   begin
194      if Int < 0 then
195         L := L + 1;
196         B (L) := '-';
197         Img (-Int);
198      else
199         Img (Int);
200      end if;
201
202      return Image (B (1 .. L), W);
203   end Image;
204
205   -----------
206   -- Image --
207   -----------
208
209   function Image (Str : String; W : Natural := 0) return String is
210      Len : constant Natural := Str'Length;
211      Max : Natural := Len;
212
213   begin
214      if Max < W then
215         Max := W;
216      end if;
217
218      declare
219         Buf : String (1 .. Max) := (1 .. Max => ' ');
220
221      begin
222         for J in 0 .. Len - 1 loop
223            Buf (Max - Len + 1 + J) := Str (Str'First + J);
224         end loop;
225
226         return Buf;
227      end;
228   end Image;
229
230   ----------------
231   -- Initialize --
232   ----------------
233
234   procedure Initialize
235     (Seed   : Natural;
236      K_To_V : Float        := Default_K_To_V;
237      Optim  : Optimization := Memory_Space;
238      Tries  : Positive     := Default_Tries)
239   is
240      V : constant Positive := Positive (Float (NK) * K_To_V);
241
242   begin
243      Opt := Optim;
244      SPHG.Initialize (Seed, V, SPHG.Optimization (Optim), Tries);
245   end Initialize;
246
247   ------------
248   -- Insert --
249   ------------
250
251   procedure Insert (Value : String) is
252   begin
253      NK := NK + 1;
254      SPHG.Insert (Value);
255   end Insert;
256
257   --------------
258   -- New_Line --
259   --------------
260
261   procedure New_Line (File : File_Descriptor) is
262   begin
263      if Write (File, EOL'Address, 1) /= 1 then
264         raise Program_Error;
265      end if;
266   end New_Line;
267
268   -------------
269   -- Produce --
270   -------------
271
272   procedure Produce
273     (Pkg_Name   : String  := Default_Pkg_Name;
274      Use_Stdout : Boolean := False)
275   is
276      File : File_Descriptor := Standout;
277
278      Siz, L1, L2 : Natural;
279      --  For calls to Define
280
281      Status : Boolean;
282      --  For call to Close
283
284      function Array_Img (N, T, R1 : String; R2 : String := "") return String;
285      --  Return string "N : constant array (R1[, R2]) of T;"
286
287      function Range_Img (F, L : Natural; T : String := "") return String;
288      --  Return string "[T range ]F .. L"
289
290      function Type_Img (Siz : Positive) return String;
291      --  Return the name of the unsigned type of size S
292
293      ---------------
294      -- Array_Img --
295      ---------------
296
297      function Array_Img
298        (N, T, R1 : String;
299         R2       : String := "") return String
300      is
301      begin
302         Last := 0;
303         Add ("   ");
304         Add (N);
305         Add (" : constant array (");
306         Add (R1);
307
308         if R2 /= "" then
309            Add (", ");
310            Add (R2);
311         end if;
312
313         Add (") of ");
314         Add (T);
315         Add (" :=");
316         return Line (1 .. Last);
317      end Array_Img;
318
319      ---------------
320      -- Range_Img --
321      ---------------
322
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);
330         Len : Natural := 0;
331
332      begin
333         if TL /= 0 then
334            RI (Len + 1 .. Len + TL) := T;
335            Len := Len + TL;
336            RI (Len + 1 .. Len + 7) := " range ";
337            Len := Len + 7;
338         end if;
339
340         RI (Len + 1 .. Len + FL) := FI;
341         Len := Len + FL;
342         RI (Len + 1 .. Len + 4) := " .. ";
343         Len := Len + 4;
344         RI (Len + 1 .. Len + LL) := LI;
345         Len := Len + LL;
346         return RI (1 .. Len);
347      end Range_Img;
348
349      --------------
350      -- Type_Img --
351      --------------
352
353      function Type_Img (Siz : Positive) return String is
354         S : constant String := Image (Siz);
355         U : String  := "Unsigned_  ";
356         N : Natural := 9;
357
358      begin
359         for J in S'Range loop
360            N := N + 1;
361            U (N) := S (J);
362         end loop;
363
364         return U (1 .. N);
365      end Type_Img;
366
367      P : Natural;
368
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.
372
373   --  Start of processing for Produce
374
375   begin
376      if not Use_Stdout then
377         File := Create_File (FName, Binary);
378
379         if File = Invalid_FD then
380            raise Program_Error with "cannot create: " & FName;
381         end if;
382      end if;
383
384      Put      (File, "package ");
385      Put      (File, Pkg_Name);
386      Put      (File, " is");
387      New_Line (File);
388      Put      (File, "   function Hash (S : String) return Natural;");
389      New_Line (File);
390      Put      (File, "end ");
391      Put      (File, Pkg_Name);
392      Put      (File, ";");
393      New_Line (File);
394
395      if not Use_Stdout then
396         Close (File, Status);
397
398         if not Status then
399            raise Device_Error;
400         end if;
401      end if;
402
403      if not Use_Stdout then
404
405         --  Set to body file name
406
407         FName (FName'Last) := 'b';
408
409         File := Create_File (FName, Binary);
410
411         if File = Invalid_FD then
412            raise Program_Error with "cannot create: " & FName;
413         end if;
414      end if;
415
416      Put      (File, "with Interfaces; use Interfaces;");
417      New_Line (File);
418      New_Line (File);
419      Put      (File, "package body ");
420      Put      (File, Pkg_Name);
421      Put      (File, " is");
422      New_Line (File);
423      New_Line (File);
424
425      if Opt = CPU_Time then
426         --  The format of this table is fixed
427
428         Define (Used_Character_Set, Siz, L1, L2);
429         pragma Assert (L1 = 256 and then L2 = 0);
430
431         Put      (File, Array_Img ("C", Type_Img (Siz), "Character"));
432         New_Line (File);
433
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);
437         end loop;
438
439         New_Line (File);
440      end if;
441
442      Define (Character_Position, Siz, L1, L2);
443      pragma Assert (Siz = 31 and then L2 = 0);
444
445      Put      (File, Array_Img ("P", "Natural", Range_Img (0, L1 - 1)));
446      New_Line (File);
447
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);
451      end loop;
452
453      New_Line (File);
454
455      Define (Function_Table_1, Siz, L1, L2);
456
457      case Opt is
458         when CPU_Time =>
459            Put_Int_Matrix
460              (File,
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);
465
466         when Memory_Space =>
467            Put_Int_Matrix
468              (File,
469               Array_Img ("T1", Type_Img (Siz),
470                          Range_Img (0, L1 - 1)),
471               Function_Table_1, L1, 0);
472      end case;
473
474      New_Line (File);
475
476      Define (Function_Table_2, Siz, L1, L2);
477
478      case Opt is
479         when CPU_Time =>
480            Put_Int_Matrix
481              (File,
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);
486
487         when Memory_Space =>
488            Put_Int_Matrix
489              (File,
490               Array_Img ("T2", Type_Img (Siz),
491                          Range_Img (0, L1 - 1)),
492               Function_Table_2, L1, 0);
493      end case;
494
495      New_Line (File);
496
497      Define (Graph_Table, Siz, L1, L2);
498      pragma Assert (L2 = 0);
499
500      Put (File, Array_Img ("G", Type_Img (Siz),
501                    Range_Img (0, L1 - 1)));
502      New_Line (File);
503
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);
507      end loop;
508
509      New_Line (File);
510
511      Put      (File, "   function Hash (S : String) return Natural is");
512      New_Line (File);
513      Put      (File, "      F : constant Natural := S'First - 1;");
514      New_Line (File);
515      Put      (File, "      L : constant Natural := S'Length;");
516      New_Line (File);
517      Put      (File, "      F1, F2 : Natural := 0;");
518      New_Line (File);
519
520      Put (File, "      J : ");
521
522      case Opt is
523         when CPU_Time =>
524            Put (File, Type_Img (8));
525
526         when Memory_Space =>
527            Put (File, "Natural");
528      end case;
529
530      Put (File, ";");
531      New_Line (File);
532
533      Put      (File, "   begin");
534      New_Line (File);
535      Put      (File, "      for K in P'Range loop");
536      New_Line (File);
537      Put      (File, "         exit when L < P (K);");
538      New_Line (File);
539      Put      (File, "         J  := ");
540
541      case Opt is
542         when CPU_Time =>
543            Put (File, "C");
544
545         when Memory_Space =>
546            Put (File, "Character'Pos");
547      end case;
548
549      Put      (File, " (S (P (K) + F));");
550      New_Line (File);
551
552      Put (File, "         F1 := (F1 + Natural (T1 (K");
553
554      if Opt = CPU_Time then
555         Put (File, ", J");
556      end if;
557
558      Put (File, "))");
559
560      if Opt = Memory_Space then
561         Put (File, " * J");
562      end if;
563
564      Put      (File, ") mod ");
565      Put      (File, Image (L1));
566      Put      (File, ";");
567      New_Line (File);
568
569      Put (File, "         F2 := (F2 + Natural (T2 (K");
570
571      if Opt = CPU_Time then
572         Put (File, ", J");
573      end if;
574
575      Put (File, "))");
576
577      if Opt = Memory_Space then
578         Put (File, " * J");
579      end if;
580
581      Put      (File, ") mod ");
582      Put      (File, Image (L1));
583      Put      (File, ";");
584      New_Line (File);
585
586      Put      (File, "      end loop;");
587      New_Line (File);
588
589      Put      (File,
590                "      return (Natural (G (F1)) + Natural (G (F2))) mod ");
591
592      Put      (File, Image (NK));
593      Put      (File, ";");
594      New_Line (File);
595      Put      (File, "   end Hash;");
596      New_Line (File);
597      New_Line (File);
598      Put      (File, "end ");
599      Put      (File, Pkg_Name);
600      Put      (File, ";");
601      New_Line (File);
602
603      if not Use_Stdout then
604         Close (File, Status);
605
606         if not Status then
607            raise Device_Error;
608         end if;
609      end if;
610   end Produce;
611
612   ---------
613   -- Put --
614   ---------
615
616   procedure Put (File : File_Descriptor; Str : String) is
617      Len : constant Natural := Str'Length;
618   begin
619      for J in Str'Range loop
620         pragma Assert (Str (J) /= ASCII.NUL);
621         null;
622      end loop;
623
624      if Write (File, Str'Address, Len) /= Len then
625         raise Program_Error;
626      end if;
627   end Put;
628
629   ---------
630   -- Put --
631   ---------
632
633   procedure Put
634     (F  : File_Descriptor;
635      S  : String;
636      F1 : Natural;
637      L1 : Natural;
638      C1 : Natural;
639      F2 : Natural;
640      L2 : Natural;
641      C2 : Natural)
642   is
643      Len : constant Natural := S'Length;
644
645      procedure Flush;
646      --  Write current line, followed by LF
647
648      -----------
649      -- Flush --
650      -----------
651
652      procedure Flush is
653      begin
654         Put (F, Line (1 .. Last));
655         New_Line (F);
656         Last := 0;
657      end Flush;
658
659   --  Start of processing for Put
660
661   begin
662      if C1 = F1 and then C2 = F2 then
663         Last := 0;
664      end if;
665
666      if Last + Len + 3 >= Max then
667         Flush;
668      end if;
669
670      if Last = 0 then
671         Add ("     ");
672
673         if F1 <= L1 then
674            if C1 = F1 and then C2 = F2 then
675               Add ('(');
676
677               if F1 = L1 then
678                  Add ("0 .. 0 => ");
679               end if;
680
681            else
682               Add (' ');
683            end if;
684         end if;
685      end if;
686
687      if C2 = F2 then
688         Add ('(');
689
690         if F2 = L2 then
691            Add ("0 .. 0 => ");
692         end if;
693
694      else
695         Add (' ');
696      end if;
697
698      Add (S);
699
700      if C2 = L2 then
701         Add (')');
702
703         if F1 > L1 then
704            Add (';');
705            Flush;
706
707         elsif C1 /= L1 then
708            Add (',');
709            Flush;
710
711         else
712            Add (')');
713            Add (';');
714            Flush;
715         end if;
716
717      else
718         Add (',');
719      end if;
720   end Put;
721
722   --------------------
723   -- Put_Int_Matrix --
724   --------------------
725
726   procedure Put_Int_Matrix
727     (File   : File_Descriptor;
728      Title  : String;
729      Table  : Table_Name;
730      Len_1  : Natural;
731      Len_2  : Natural)
732   is
733      F1 : constant Integer := 0;
734      L1 : constant Integer := Len_1 - 1;
735      F2 : constant Integer := 0;
736      L2 : constant Integer := Len_2 - 1;
737      Ix : Natural;
738
739   begin
740      Put (File, Title);
741      New_Line (File);
742
743      if Len_2 = 0 then
744         for J in F1 .. L1 loop
745            Ix := Value (Table, J, 0);
746            Put (File, Image (Ix), 1, 0, 1, F1, L1, J);
747         end loop;
748
749      else
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);
754            end loop;
755         end loop;
756      end if;
757   end Put_Int_Matrix;
758
759end GNAT.Perfect_Hash_Generators;
760