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