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