gcc/ada/g-spitbo.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --                         G N A T . S P I T B O L                          --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                     Copyright (C) 1998-2016, 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.Strings;               use Ada.Strings;
  33 with Ada.Strings.Unbounded.Aux; use Ada.Strings.Unbounded.Aux;
  34
  35 with GNAT.Debug_Utilities;      use GNAT.Debug_Utilities;
  36 with GNAT.IO;                   use GNAT.IO;
  37
  38 with System.String_Hash;
  39
  40 with Ada.Unchecked_Deallocation;
  41
  42 package body GNAT.Spitbol is
  43
  44    ---------
  45    -- "&" --
  46    ---------
  47
  48    function "&" (Num : Integer; Str : String)  return String is
  49    begin
  50       return S (Num) & Str;
  51    end "&";
  52
  53    function "&" (Str : String;  Num : Integer) return String is
  54    begin
  55       return Str & S (Num);
  56    end "&";
  57
  58    function "&" (Num : Integer; Str : VString) return VString is
  59    begin
  60       return S (Num) & Str;
  61    end "&";
  62
  63    function "&" (Str : VString; Num : Integer) return VString is
  64    begin
  65       return Str & S (Num);
  66    end "&";
  67
  68    ----------
  69    -- Char --
  70    ----------
  71
  72    function Char (Num : Natural) return Character is
  73    begin
  74       return Character'Val (Num);
  75    end Char;
  76
  77    ----------
  78    -- Lpad --
  79    ----------
  80
  81    function Lpad
  82      (Str : VString;
  83       Len : Natural;
  84       Pad : Character := ' ') return VString
  85    is
  86    begin
  87       if Length (Str) >= Len then
  88          return Str;
  89       else
  90          return Tail (Str, Len, Pad);
  91       end if;
  92    end Lpad;
  93
  94    function Lpad
  95      (Str : String;
  96       Len : Natural;
  97       Pad : Character := ' ') return VString
  98    is
  99    begin
 100       if Str'Length >= Len then
 101          return V (Str);
 102
 103       else
 104          declare
 105             R : String (1 .. Len);
 106
 107          begin
 108             for J in 1 .. Len - Str'Length loop
 109                R (J) := Pad;
 110             end loop;
 111
 112             R (Len - Str'Length + 1 .. Len) := Str;
 113             return V (R);
 114          end;
 115       end if;
 116    end Lpad;
 117
 118    procedure Lpad
 119      (Str  : in out VString;
 120       Len  : Natural;
 121       Pad  : Character := ' ')
 122    is
 123    begin
 124       if Length (Str) >= Len then
 125          return;
 126       else
 127          Tail (Str, Len, Pad);
 128       end if;
 129    end Lpad;
 130
 131    -------
 132    -- N --
 133    -------
 134
 135    function N (Str : VString) return Integer is
 136       S : Big_String_Access;
 137       L : Natural;
 138    begin
 139       Get_String (Str, S, L);
 140       return Integer'Value (S (1 .. L));
 141    end N;
 142
 143    --------------------
 144    -- Reverse_String --
 145    --------------------
 146
 147    function Reverse_String (Str : VString) return VString is
 148       S : Big_String_Access;
 149       L : Natural;
 150
 151    begin
 152       Get_String (Str, S, L);
 153
 154       declare
 155          Result : String (1 .. L);
 156
 157       begin
 158          for J in 1 .. L loop
 159             Result (J) := S (L + 1 - J);
 160          end loop;
 161
 162          return V (Result);
 163       end;
 164    end Reverse_String;
 165
 166    function Reverse_String (Str : String) return VString is
 167       Result : String (1 .. Str'Length);
 168
 169    begin
 170       for J in 1 .. Str'Length loop
 171          Result (J) := Str (Str'Last + 1 - J);
 172       end loop;
 173
 174       return V (Result);
 175    end Reverse_String;
 176
 177    procedure Reverse_String (Str : in out VString) is
 178       S : Big_String_Access;
 179       L : Natural;
 180
 181    begin
 182       Get_String (Str, S, L);
 183
 184       declare
 185          Result : String (1 .. L);
 186
 187       begin
 188          for J in 1 .. L loop
 189             Result (J) := S (L + 1 - J);
 190          end loop;
 191
 192          Set_Unbounded_String (Str, Result);
 193       end;
 194    end Reverse_String;
 195
 196    ----------
 197    -- Rpad --
 198    ----------
 199
 200    function Rpad
 201      (Str : VString;
 202       Len : Natural;
 203       Pad : Character := ' ') return VString
 204    is
 205    begin
 206       if Length (Str) >= Len then
 207          return Str;
 208       else
 209          return Head (Str, Len, Pad);
 210       end if;
 211    end Rpad;
 212
 213    function Rpad
 214      (Str : String;
 215       Len : Natural;
 216       Pad : Character := ' ') return VString
 217    is
 218    begin
 219       if Str'Length >= Len then
 220          return V (Str);
 221
 222       else
 223          declare
 224             R : String (1 .. Len);
 225
 226          begin
 227             for J in Str'Length + 1 .. Len loop
 228                R (J) := Pad;
 229             end loop;
 230
 231             R (1 .. Str'Length) := Str;
 232             return V (R);
 233          end;
 234       end if;
 235    end Rpad;
 236
 237    procedure Rpad
 238      (Str  : in out VString;
 239       Len  : Natural;
 240       Pad  : Character := ' ')
 241    is
 242    begin
 243       if Length (Str) >= Len then
 244          return;
 245
 246       else
 247          Head (Str, Len, Pad);
 248       end if;
 249    end Rpad;
 250
 251    -------
 252    -- S --
 253    -------
 254
 255    function S (Num : Integer) return String is
 256       Buf : String (1 .. 30);
 257       Ptr : Natural := Buf'Last + 1;
 258       Val : Natural := abs (Num);
 259
 260    begin
 261       loop
 262          Ptr := Ptr - 1;
 263          Buf (Ptr) := Character'Val (Val mod 10 + Character'Pos ('0'));
 264          Val := Val / 10;
 265          exit when Val = 0;
 266       end loop;
 267
 268       if Num < 0 then
 269          Ptr := Ptr - 1;
 270          Buf (Ptr) := '-';
 271       end if;
 272
 273       return Buf (Ptr .. Buf'Last);
 274    end S;
 275
 276    ------------
 277    -- Substr --
 278    ------------
 279
 280    function Substr
 281      (Str   : VString;
 282       Start : Positive;
 283       Len   : Natural) return VString
 284    is
 285       S : Big_String_Access;
 286       L : Natural;
 287
 288    begin
 289       Get_String (Str, S, L);
 290
 291       if Start > L then
 292          raise Index_Error;
 293       elsif Start + Len - 1 > L then
 294          raise Length_Error;
 295       else
 296          return V (S (Start .. Start + Len - 1));
 297       end if;
 298    end Substr;
 299
 300    function Substr
 301      (Str   : String;
 302       Start : Positive;
 303       Len   : Natural) return VString
 304    is
 305    begin
 306       if Start > Str'Length then
 307          raise Index_Error;
 308       elsif Start + Len - 1 > Str'Length then
 309          raise Length_Error;
 310       else
 311          return
 312            V (Str (Str'First + Start - 1 .. Str'First + Start + Len - 2));
 313       end if;
 314    end Substr;
 315
 316    -----------
 317    -- Table --
 318    -----------
 319
 320    package body Table is
 321
 322       procedure Free is new
 323         Ada.Unchecked_Deallocation (Hash_Element, Hash_Element_Ptr);
 324
 325       -----------------------
 326       -- Local Subprograms --
 327       -----------------------
 328
 329       function Hash is new System.String_Hash.Hash
 330         (Character, String, Unsigned_32);
 331
 332       ------------
 333       -- Adjust --
 334       ------------
 335
 336       overriding procedure Adjust (Object : in out Table) is
 337          Ptr1 : Hash_Element_Ptr;
 338          Ptr2 : Hash_Element_Ptr;
 339
 340       begin
 341          for J in Object.Elmts'Range loop
 342             Ptr1 := Object.Elmts (J)'Unrestricted_Access;
 343
 344             if Ptr1.Name /= null then
 345                loop
 346                   Ptr1.Name := new String'(Ptr1.Name.all);
 347                   exit when Ptr1.Next = null;
 348                   Ptr2 := Ptr1.Next;
 349                   Ptr1.Next := new Hash_Element'(Ptr2.all);
 350                   Ptr1 := Ptr1.Next;
 351                end loop;
 352             end if;
 353          end loop;
 354       end Adjust;
 355
 356       -----------
 357       -- Clear --
 358       -----------
 359
 360       procedure Clear (T : in out Table) is
 361          Ptr1 : Hash_Element_Ptr;
 362          Ptr2 : Hash_Element_Ptr;
 363
 364       begin
 365          for J in T.Elmts'Range loop
 366             if T.Elmts (J).Name /= null then
 367                Free (T.Elmts (J).Name);
 368                T.Elmts (J).Value := Null_Value;
 369
 370                Ptr1 := T.Elmts (J).Next;
 371                T.Elmts (J).Next := null;
 372
 373                while Ptr1 /= null loop
 374                   Ptr2 := Ptr1.Next;
 375                   Free (Ptr1.Name);
 376                   Free (Ptr1);
 377                   Ptr1 := Ptr2;
 378                end loop;
 379             end if;
 380          end loop;
 381       end Clear;
 382
 383       ----------------------
 384       -- Convert_To_Array --
 385       ----------------------
 386
 387       function Convert_To_Array (T : Table) return Table_Array is
 388          Num_Elmts : Natural := 0;
 389          Elmt      : Hash_Element_Ptr;
 390
 391       begin
 392          for J in T.Elmts'Range loop
 393             Elmt := T.Elmts (J)'Unrestricted_Access;
 394
 395             if Elmt.Name /= null then
 396                loop
 397                   Num_Elmts := Num_Elmts + 1;
 398                   Elmt := Elmt.Next;
 399                   exit when Elmt = null;
 400                end loop;
 401             end if;
 402          end loop;
 403
 404          declare
 405             TA  : Table_Array (1 .. Num_Elmts);
 406             P   : Natural := 1;
 407
 408          begin
 409             for J in T.Elmts'Range loop
 410                Elmt := T.Elmts (J)'Unrestricted_Access;
 411
 412                if Elmt.Name /= null then
 413                   loop
 414                      Set_Unbounded_String (TA (P).Name, Elmt.Name.all);
 415                      TA (P).Value := Elmt.Value;
 416                      P := P + 1;
 417                      Elmt := Elmt.Next;
 418                      exit when Elmt = null;
 419                   end loop;
 420                end if;
 421             end loop;
 422
 423             return TA;
 424          end;
 425       end Convert_To_Array;
 426
 427       ----------
 428       -- Copy --
 429       ----------
 430
 431       procedure Copy (From : Table; To : in out Table) is
 432          Elmt : Hash_Element_Ptr;
 433
 434       begin
 435          Clear (To);
 436
 437          for J in From.Elmts'Range loop
 438             Elmt := From.Elmts (J)'Unrestricted_Access;
 439             if Elmt.Name /= null then
 440                loop
 441                   Set (To, Elmt.Name.all, Elmt.Value);
 442                   Elmt := Elmt.Next;
 443                   exit when Elmt = null;
 444                end loop;
 445             end if;
 446          end loop;
 447       end Copy;
 448
 449       ------------
 450       -- Delete --
 451       ------------
 452
 453       procedure Delete (T : in out Table; Name : Character) is
 454       begin
 455          Delete (T, String'(1 => Name));
 456       end Delete;
 457
 458       procedure Delete (T : in out Table; Name  : VString) is
 459          S : Big_String_Access;
 460          L : Natural;
 461       begin
 462          Get_String (Name, S, L);
 463          Delete (T, S (1 .. L));
 464       end Delete;
 465
 466       procedure Delete (T : in out Table; Name  : String) is
 467          Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1;
 468          Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access;
 469          Next : Hash_Element_Ptr;
 470
 471       begin
 472          if Elmt.Name = null then
 473             null;
 474
 475          elsif Elmt.Name.all = Name then
 476             Free (Elmt.Name);
 477
 478             if Elmt.Next = null then
 479                Elmt.Value := Null_Value;
 480                return;
 481
 482             else
 483                Next := Elmt.Next;
 484                Elmt.Name  := Next.Name;
 485                Elmt.Value := Next.Value;
 486                Elmt.Next  := Next.Next;
 487                Free (Next);
 488                return;
 489             end if;
 490
 491          else
 492             loop
 493                Next := Elmt.Next;
 494
 495                if Next = null then
 496                   return;
 497
 498                elsif Next.Name.all = Name then
 499                   Free (Next.Name);
 500                   Elmt.Next := Next.Next;
 501                   Free (Next);
 502                   return;
 503
 504                else
 505                   Elmt := Next;
 506                end if;
 507             end loop;
 508          end if;
 509       end Delete;
 510
 511       ----------
 512       -- Dump --
 513       ----------
 514
 515       procedure Dump (T : Table; Str : String := "Table") is
 516          Num_Elmts : Natural := 0;
 517          Elmt      : Hash_Element_Ptr;
 518
 519       begin
 520          for J in T.Elmts'Range loop
 521             Elmt := T.Elmts (J)'Unrestricted_Access;
 522
 523             if Elmt.Name /= null then
 524                loop
 525                   Num_Elmts := Num_Elmts + 1;
 526                   Put_Line
 527                     (Str & '<' & Image (Elmt.Name.all) & "> = " &
 528                      Img (Elmt.Value));
 529                   Elmt := Elmt.Next;
 530                   exit when Elmt = null;
 531                end loop;
 532             end if;
 533          end loop;
 534
 535          if Num_Elmts = 0 then
 536             Put_Line (Str & " is empty");
 537          end if;
 538       end Dump;
 539
 540       procedure Dump (T : Table_Array; Str : String := "Table_Array") is
 541       begin
 542          if T'Length = 0 then
 543             Put_Line (Str & " is empty");
 544
 545          else
 546             for J in T'Range loop
 547                Put_Line
 548                  (Str & '(' & Image (To_String (T (J).Name)) & ") = " &
 549                   Img (T (J).Value));
 550             end loop;
 551          end if;
 552       end Dump;
 553
 554       --------------
 555       -- Finalize --
 556       --------------
 557
 558       overriding procedure Finalize (Object : in out Table) is
 559          Ptr1 : Hash_Element_Ptr;
 560          Ptr2 : Hash_Element_Ptr;
 561
 562       begin
 563          for J in Object.Elmts'Range loop
 564             Ptr1 := Object.Elmts (J).Next;
 565             Free (Object.Elmts (J).Name);
 566             while Ptr1 /= null loop
 567                Ptr2 := Ptr1.Next;
 568                Free (Ptr1.Name);
 569                Free (Ptr1);
 570                Ptr1 := Ptr2;
 571             end loop;
 572          end loop;
 573       end Finalize;
 574
 575       ---------
 576       -- Get --
 577       ---------
 578
 579       function Get (T : Table; Name : Character) return Value_Type is
 580       begin
 581          return Get (T, String'(1 => Name));
 582       end Get;
 583
 584       function Get (T : Table; Name : VString) return Value_Type is
 585          S : Big_String_Access;
 586          L : Natural;
 587       begin
 588          Get_String (Name, S, L);
 589          return Get (T, S (1 .. L));
 590       end Get;
 591
 592       function Get (T : Table; Name : String) return Value_Type is
 593          Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1;
 594          Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access;
 595
 596       begin
 597          if Elmt.Name = null then
 598             return Null_Value;
 599
 600          else
 601             loop
 602                if Name = Elmt.Name.all then
 603                   return Elmt.Value;
 604
 605                else
 606                   Elmt := Elmt.Next;
 607
 608                   if Elmt = null then
 609                      return Null_Value;
 610                   end if;
 611                end if;
 612             end loop;
 613          end if;
 614       end Get;
 615
 616       -------------
 617       -- Present --
 618       -------------
 619
 620       function Present (T : Table; Name : Character) return Boolean is
 621       begin
 622          return Present (T, String'(1 => Name));
 623       end Present;
 624
 625       function Present (T : Table; Name : VString) return Boolean is
 626          S : Big_String_Access;
 627          L : Natural;
 628       begin
 629          Get_String (Name, S, L);
 630          return Present (T, S (1 .. L));
 631       end Present;
 632
 633       function Present (T : Table; Name : String) return Boolean is
 634          Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1;
 635          Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access;
 636
 637       begin
 638          if Elmt.Name = null then
 639             return False;
 640
 641          else
 642             loop
 643                if Name = Elmt.Name.all then
 644                   return True;
 645
 646                else
 647                   Elmt := Elmt.Next;
 648
 649                   if Elmt = null then
 650                      return False;
 651                   end if;
 652                end if;
 653             end loop;
 654          end if;
 655       end Present;
 656
 657       ---------
 658       -- Set --
 659       ---------
 660
 661       procedure Set (T : in out Table; Name : VString; Value : Value_Type) is
 662          S : Big_String_Access;
 663          L : Natural;
 664       begin
 665          Get_String (Name, S, L);
 666          Set (T, S (1 .. L), Value);
 667       end Set;
 668
 669       procedure Set (T : in out Table; Name : Character; Value : Value_Type) is
 670       begin
 671          Set (T, String'(1 => Name), Value);
 672       end Set;
 673
 674       procedure Set
 675         (T     : in out Table;
 676          Name  : String;
 677          Value : Value_Type)
 678       is
 679       begin
 680          if Value = Null_Value then
 681             Delete (T, Name);
 682
 683          else
 684             declare
 685                Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1;
 686                Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access;
 687
 688                subtype String1 is String (1 .. Name'Length);
 689
 690             begin
 691                if Elmt.Name = null then
 692                   Elmt.Name  := new String'(String1 (Name));
 693                   Elmt.Value := Value;
 694                   return;
 695
 696                else
 697                   loop
 698                      if Name = Elmt.Name.all then
 699                         Elmt.Value := Value;
 700                         return;
 701
 702                      elsif Elmt.Next = null then
 703                         Elmt.Next := new Hash_Element'(
 704                                        Name  => new String'(String1 (Name)),
 705                                        Value => Value,
 706                                        Next  => null);
 707                         return;
 708
 709                      else
 710                         Elmt := Elmt.Next;
 711                      end if;
 712                   end loop;
 713                end if;
 714             end;
 715          end if;
 716       end Set;
 717    end Table;
 718
 719    ----------
 720    -- Trim --
 721    ----------
 722
 723    function Trim (Str : VString) return VString is
 724    begin
 725       return Trim (Str, Right);
 726    end Trim;
 727
 728    function Trim (Str : String) return VString is
 729    begin
 730       for J in reverse Str'Range loop
 731          if Str (J) /= ' ' then
 732             return V (Str (Str'First .. J));
 733          end if;
 734       end loop;
 735
 736       return Nul;
 737    end Trim;
 738
 739    procedure Trim (Str : in out VString) is
 740    begin
 741       Trim (Str, Right);
 742    end Trim;
 743
 744    -------
 745    -- V --
 746    -------
 747
 748    function V (Num : Integer) return VString is
 749       Buf : String (1 .. 30);
 750       Ptr : Natural := Buf'Last + 1;
 751       Val : Natural := abs (Num);
 752
 753    begin
 754       loop
 755          Ptr := Ptr - 1;
 756          Buf (Ptr) := Character'Val (Val mod 10 + Character'Pos ('0'));
 757          Val := Val / 10;
 758          exit when Val = 0;
 759       end loop;
 760
 761       if Num < 0 then
 762          Ptr := Ptr - 1;
 763          Buf (Ptr) := '-';
 764       end if;
 765
 766       return V (Buf (Ptr .. Buf'Last));
 767    end V;
 768
 769 end GNAT.Spitbol;