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