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-2007, 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 2,  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.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 with Ada.Strings;               use Ada.Strings;
  35 with Ada.Strings.Unbounded.Aux; use Ada.Strings.Unbounded.Aux;
  36
  37 with GNAT.Debug_Utilities;      use GNAT.Debug_Utilities;
  38 with GNAT.IO;                   use GNAT.IO;
  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 : 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 : 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 : 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_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 : 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 > 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 (Str : String) return Unsigned_32;
 330       --  Compute hash function for given String
 331
 332       ------------
 333       -- Adjust --
 334       ------------
 335
 336       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_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 : 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       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 : 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       -- Hash --
 618       ----------
 619
 620       function Hash (Str : String) return Unsigned_32 is
 621          Result : Unsigned_32 := Str'Length;
 622
 623       begin
 624          for J in Str'Range loop
 625             Result := Rotate_Left (Result, 3) +
 626                       Unsigned_32 (Character'Pos (Str (J)));
 627          end loop;
 628
 629          return Result;
 630       end Hash;
 631
 632       -------------
 633       -- Present --
 634       -------------
 635
 636       function Present (T : Table; Name : Character) return Boolean is
 637       begin
 638          return Present (T, String'(1 => Name));
 639       end Present;
 640
 641       function Present (T : Table; Name : VString) return Boolean is
 642          S : String_Access;
 643          L : Natural;
 644       begin
 645          Get_String (Name, S, L);
 646          return Present (T, S (1 .. L));
 647       end Present;
 648
 649       function Present (T : Table; Name : String) return Boolean is
 650          Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1;
 651          Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access;
 652
 653       begin
 654          if Elmt.Name = null then
 655             return False;
 656
 657          else
 658             loop
 659                if Name = Elmt.Name.all then
 660                   return True;
 661
 662                else
 663                   Elmt := Elmt.Next;
 664
 665                   if Elmt = null then
 666                      return False;
 667                   end if;
 668                end if;
 669             end loop;
 670          end if;
 671       end Present;
 672
 673       ---------
 674       -- Set --
 675       ---------
 676
 677       procedure Set (T : in out Table; Name : VString; Value : Value_Type) is
 678          S : String_Access;
 679          L : Natural;
 680       begin
 681          Get_String (Name, S, L);
 682          Set (T, S (1 .. L), Value);
 683       end Set;
 684
 685       procedure Set (T : in out Table; Name : Character; Value : Value_Type) is
 686       begin
 687          Set (T, String'(1 => Name), Value);
 688       end Set;
 689
 690       procedure Set
 691         (T     : in out Table;
 692          Name  : String;
 693          Value : Value_Type)
 694       is
 695       begin
 696          if Value = Null_Value then
 697             Delete (T, Name);
 698
 699          else
 700             declare
 701                Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1;
 702                Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access;
 703
 704                subtype String1 is String (1 .. Name'Length);
 705
 706             begin
 707                if Elmt.Name = null then
 708                   Elmt.Name  := new String'(String1 (Name));
 709                   Elmt.Value := Value;
 710                   return;
 711
 712                else
 713                   loop
 714                      if Name = Elmt.Name.all then
 715                         Elmt.Value := Value;
 716                         return;
 717
 718                      elsif Elmt.Next = null then
 719                         Elmt.Next := new Hash_Element'(
 720                                        Name  => new String'(String1 (Name)),
 721                                        Value => Value,
 722                                        Next  => null);
 723                         return;
 724
 725                      else
 726                         Elmt := Elmt.Next;
 727                      end if;
 728                   end loop;
 729                end if;
 730             end;
 731          end if;
 732       end Set;
 733    end Table;
 734
 735    ----------
 736    -- Trim --
 737    ----------
 738
 739    function Trim (Str : VString) return VString is
 740    begin
 741       return Trim (Str, Right);
 742    end Trim;
 743
 744    function Trim (Str : String) return VString is
 745    begin
 746       for J in reverse Str'Range loop
 747          if Str (J) /= ' ' then
 748             return V (Str (Str'First .. J));
 749          end if;
 750       end loop;
 751
 752       return Nul;
 753    end Trim;
 754
 755    procedure Trim (Str : in out VString) is
 756    begin
 757       Trim (Str, Right);
 758    end Trim;
 759
 760    -------
 761    -- V --
 762    -------
 763
 764    function V (Num : Integer) return VString is
 765       Buf : String (1 .. 30);
 766       Ptr : Natural := Buf'Last + 1;
 767       Val : Natural := abs (Num);
 768
 769    begin
 770       loop
 771          Ptr := Ptr - 1;
 772          Buf (Ptr) := Character'Val (Val mod 10 + Character'Pos ('0'));
 773          Val := Val / 10;
 774          exit when Val = 0;
 775       end loop;
 776
 777       if Num < 0 then
 778          Ptr := Ptr - 1;
 779          Buf (Ptr) := '-';
 780       end if;
 781
 782       return V (Buf (Ptr .. Buf'Last));
 783    end V;
 784
 785 end GNAT.Spitbol;