gcc/ada/libgnat/g-pehage.adb

   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-2024, 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
  32 with Ada.IO_Exceptions;       use Ada.IO_Exceptions;
  33 with Ada.Characters.Handling; use Ada.Characters.Handling;
  34
  35 with GNAT.OS_Lib;             use GNAT.OS_Lib;
  36
  37 package 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
 759 end GNAT.Perfect_Hash_Generators;