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