gcc/ada/a-strfix.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --                    A D A . S T R I N G S . F I X E D                     --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2010, Free Software Foundation, 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 3,  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.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 --  Note: This code is derived from the ADAR.CSH public domain Ada 83 versions
  33 --  of the Appendix C string handling packages. One change is to avoid the use
  34 --  of Is_In, so that we are not dependent on inlining. Note that the search
  35 --  function implementations are to be found in the auxiliary package
  36 --  Ada.Strings.Search. Also the Move procedure is directly incorporated (ADAR
  37 --  used a subunit for this procedure). The number of errors having to do with
  38 --  bounds of function return results were also fixed, and use of & removed for
  39 --  efficiency reasons.
  40
  41 with Ada.Strings.Maps; use Ada.Strings.Maps;
  42 with Ada.Strings.Search;
  43
  44 package body Ada.Strings.Fixed is
  45
  46    ------------------------
  47    -- Search Subprograms --
  48    ------------------------
  49
  50    function Index
  51      (Source  : String;
  52       Pattern : String;
  53       Going   : Direction := Forward;
  54       Mapping : Maps.Character_Mapping := Maps.Identity) return Natural
  55    renames Ada.Strings.Search.Index;
  56
  57    function Index
  58      (Source  : String;
  59       Pattern : String;
  60       Going   : Direction := Forward;
  61       Mapping : Maps.Character_Mapping_Function) return Natural
  62    renames Ada.Strings.Search.Index;
  63
  64    function Index
  65      (Source : String;
  66       Set    : Maps.Character_Set;
  67       Test   : Membership := Inside;
  68       Going  : Direction  := Forward) return Natural
  69    renames Ada.Strings.Search.Index;
  70
  71    function Index
  72      (Source  : String;
  73       Pattern : String;
  74       From    : Positive;
  75       Going   : Direction := Forward;
  76       Mapping : Maps.Character_Mapping := Maps.Identity) return Natural
  77    renames Ada.Strings.Search.Index;
  78
  79    function Index
  80      (Source  : String;
  81       Pattern : String;
  82       From    : Positive;
  83       Going   : Direction := Forward;
  84       Mapping : Maps.Character_Mapping_Function) return Natural
  85    renames Ada.Strings.Search.Index;
  86
  87    function Index
  88      (Source  : String;
  89       Set     : Maps.Character_Set;
  90       From    : Positive;
  91       Test    : Membership := Inside;
  92       Going   : Direction := Forward) return Natural
  93    renames Ada.Strings.Search.Index;
  94
  95    function Index_Non_Blank
  96      (Source : String;
  97       Going  : Direction := Forward) return Natural
  98    renames Ada.Strings.Search.Index_Non_Blank;
  99
 100    function Index_Non_Blank
 101      (Source : String;
 102       From   : Positive;
 103       Going  : Direction := Forward) return Natural
 104    renames Ada.Strings.Search.Index_Non_Blank;
 105
 106    function Count
 107      (Source  : String;
 108       Pattern : String;
 109       Mapping : Maps.Character_Mapping := Maps.Identity) return Natural
 110    renames Ada.Strings.Search.Count;
 111
 112    function Count
 113      (Source  : String;
 114       Pattern : String;
 115       Mapping : Maps.Character_Mapping_Function) return Natural
 116    renames Ada.Strings.Search.Count;
 117
 118    function Count
 119      (Source : String;
 120       Set    : Maps.Character_Set) return Natural
 121    renames Ada.Strings.Search.Count;
 122
 123    procedure Find_Token
 124      (Source : String;
 125       Set    : Maps.Character_Set;
 126       From   : Positive;
 127       Test   : Membership;
 128       First  : out Positive;
 129       Last   : out Natural)
 130    renames Ada.Strings.Search.Find_Token;
 131
 132    procedure Find_Token
 133      (Source : String;
 134       Set    : Maps.Character_Set;
 135       Test   : Membership;
 136       First  : out Positive;
 137       Last   : out Natural)
 138    renames Ada.Strings.Search.Find_Token;
 139
 140    ---------
 141    -- "*" --
 142    ---------
 143
 144    function "*"
 145      (Left  : Natural;
 146       Right : Character) return String
 147    is
 148       Result : String (1 .. Left);
 149
 150    begin
 151       for J in Result'Range loop
 152          Result (J) := Right;
 153       end loop;
 154
 155       return Result;
 156    end "*";
 157
 158    function "*"
 159      (Left  : Natural;
 160       Right : String) return String
 161    is
 162       Result : String (1 .. Left * Right'Length);
 163       Ptr    : Integer := 1;
 164
 165    begin
 166       for J in 1 .. Left loop
 167          Result (Ptr .. Ptr + Right'Length - 1) := Right;
 168          Ptr := Ptr + Right'Length;
 169       end loop;
 170
 171       return Result;
 172    end "*";
 173
 174    ------------
 175    -- Delete --
 176    ------------
 177
 178    function Delete
 179      (Source  : String;
 180       From    : Positive;
 181       Through : Natural) return String
 182    is
 183    begin
 184       if From > Through then
 185          declare
 186             subtype Result_Type is String (1 .. Source'Length);
 187
 188          begin
 189             return Result_Type (Source);
 190          end;
 191
 192       elsif From not in Source'Range
 193         or else Through > Source'Last
 194       then
 195          raise Index_Error;
 196
 197       else
 198          declare
 199             Front  : constant Integer := From - Source'First;
 200             Result : String (1 .. Source'Length - (Through - From + 1));
 201
 202          begin
 203             Result (1 .. Front) :=
 204               Source (Source'First .. From - 1);
 205             Result (Front + 1 .. Result'Last) :=
 206               Source (Through + 1 .. Source'Last);
 207
 208             return Result;
 209          end;
 210       end if;
 211    end Delete;
 212
 213    procedure Delete
 214      (Source  : in out String;
 215       From    : Positive;
 216       Through : Natural;
 217       Justify : Alignment := Left;
 218       Pad     : Character := Space)
 219    is
 220    begin
 221       Move (Source  => Delete (Source, From, Through),
 222             Target  => Source,
 223             Justify => Justify,
 224             Pad     => Pad);
 225    end Delete;
 226
 227    ----------
 228    -- Head --
 229    ----------
 230
 231    function Head
 232      (Source : String;
 233       Count  : Natural;
 234       Pad    : Character := Space) return String
 235    is
 236       subtype Result_Type is String (1 .. Count);
 237
 238    begin
 239       if Count < Source'Length then
 240          return
 241            Result_Type (Source (Source'First .. Source'First + Count - 1));
 242
 243       else
 244          declare
 245             Result : Result_Type;
 246
 247          begin
 248             Result (1 .. Source'Length) := Source;
 249
 250             for J in Source'Length + 1 .. Count loop
 251                Result (J) := Pad;
 252             end loop;
 253
 254             return Result;
 255          end;
 256       end if;
 257    end Head;
 258
 259    procedure Head
 260      (Source  : in out String;
 261       Count   : Natural;
 262       Justify : Alignment := Left;
 263       Pad     : Character := Space)
 264    is
 265    begin
 266       Move (Source  => Head (Source, Count, Pad),
 267             Target  => Source,
 268             Drop    => Error,
 269             Justify => Justify,
 270             Pad     => Pad);
 271    end Head;
 272
 273    ------------
 274    -- Insert --
 275    ------------
 276
 277    function Insert
 278      (Source   : String;
 279       Before   : Positive;
 280       New_Item : String) return String
 281    is
 282       Result : String (1 .. Source'Length + New_Item'Length);
 283       Front  : constant Integer := Before - Source'First;
 284
 285    begin
 286       if Before not in Source'First .. Source'Last + 1 then
 287          raise Index_Error;
 288       end if;
 289
 290       Result (1 .. Front) :=
 291         Source (Source'First .. Before - 1);
 292       Result (Front + 1 .. Front + New_Item'Length) :=
 293         New_Item;
 294       Result (Front + New_Item'Length + 1 .. Result'Last) :=
 295         Source (Before .. Source'Last);
 296
 297       return Result;
 298    end Insert;
 299
 300    procedure Insert
 301      (Source   : in out String;
 302       Before   : Positive;
 303       New_Item : String;
 304       Drop     : Truncation := Error)
 305    is
 306    begin
 307       Move (Source => Insert (Source, Before, New_Item),
 308             Target => Source,
 309             Drop   => Drop);
 310    end Insert;
 311
 312    ----------
 313    -- Move --
 314    ----------
 315
 316    procedure Move
 317      (Source  : String;
 318       Target  : out String;
 319       Drop    : Truncation := Error;
 320       Justify : Alignment  := Left;
 321       Pad     : Character  := Space)
 322    is
 323       Sfirst  : constant Integer := Source'First;
 324       Slast   : constant Integer := Source'Last;
 325       Slength : constant Integer := Source'Length;
 326
 327       Tfirst  : constant Integer := Target'First;
 328       Tlast   : constant Integer := Target'Last;
 329       Tlength : constant Integer := Target'Length;
 330
 331       function Is_Padding (Item : String) return Boolean;
 332       --  Check if Item is all Pad characters, return True if so, False if not
 333
 334       function Is_Padding (Item : String) return Boolean is
 335       begin
 336          for J in Item'Range loop
 337             if Item (J) /= Pad then
 338                return False;
 339             end if;
 340          end loop;
 341
 342          return True;
 343       end Is_Padding;
 344
 345    --  Start of processing for Move
 346
 347    begin
 348       if Slength = Tlength then
 349          Target := Source;
 350
 351       elsif Slength > Tlength then
 352
 353          case Drop is
 354             when Left =>
 355                Target := Source (Slast - Tlength + 1 .. Slast);
 356
 357             when Right =>
 358                Target := Source (Sfirst .. Sfirst + Tlength - 1);
 359
 360             when Error =>
 361                case Justify is
 362                   when Left =>
 363                      if Is_Padding (Source (Sfirst + Tlength .. Slast)) then
 364                         Target :=
 365                           Source (Sfirst .. Sfirst + Target'Length - 1);
 366                      else
 367                         raise Length_Error;
 368                      end if;
 369
 370                   when Right =>
 371                      if Is_Padding (Source (Sfirst .. Slast - Tlength)) then
 372                         Target := Source (Slast - Tlength + 1 .. Slast);
 373                      else
 374                         raise Length_Error;
 375                      end if;
 376
 377                   when Center =>
 378                      raise Length_Error;
 379                end case;
 380
 381          end case;
 382
 383       --  Source'Length < Target'Length
 384
 385       else
 386          case Justify is
 387             when Left =>
 388                Target (Tfirst .. Tfirst + Slength - 1) := Source;
 389
 390                for I in Tfirst + Slength .. Tlast loop
 391                   Target (I) := Pad;
 392                end loop;
 393
 394             when Right =>
 395                for I in Tfirst .. Tlast - Slength loop
 396                   Target (I) := Pad;
 397                end loop;
 398
 399                Target (Tlast - Slength + 1 .. Tlast) := Source;
 400
 401             when Center =>
 402                declare
 403                   Front_Pad   : constant Integer := (Tlength - Slength) / 2;
 404                   Tfirst_Fpad : constant Integer := Tfirst + Front_Pad;
 405
 406                begin
 407                   for I in Tfirst .. Tfirst_Fpad - 1 loop
 408                      Target (I) := Pad;
 409                   end loop;
 410
 411                   Target (Tfirst_Fpad .. Tfirst_Fpad + Slength - 1) := Source;
 412
 413                   for I in Tfirst_Fpad + Slength .. Tlast loop
 414                      Target (I) := Pad;
 415                   end loop;
 416                end;
 417          end case;
 418       end if;
 419    end Move;
 420
 421    ---------------
 422    -- Overwrite --
 423    ---------------
 424
 425    function Overwrite
 426      (Source   : String;
 427       Position : Positive;
 428       New_Item : String) return String
 429    is
 430    begin
 431       if Position not in Source'First .. Source'Last + 1 then
 432          raise Index_Error;
 433       end if;
 434
 435       declare
 436          Result_Length : constant Natural :=
 437                            Integer'Max
 438                              (Source'Length,
 439                               Position - Source'First + New_Item'Length);
 440
 441          Result : String (1 .. Result_Length);
 442          Front  : constant Integer := Position - Source'First;
 443
 444       begin
 445          Result (1 .. Front) :=
 446            Source (Source'First .. Position - 1);
 447          Result (Front + 1 .. Front + New_Item'Length) :=
 448            New_Item;
 449          Result (Front + New_Item'Length + 1 .. Result'Length) :=
 450            Source (Position + New_Item'Length .. Source'Last);
 451          return Result;
 452       end;
 453    end Overwrite;
 454
 455    procedure Overwrite
 456      (Source   : in out String;
 457       Position : Positive;
 458       New_Item : String;
 459       Drop     : Truncation := Right)
 460    is
 461    begin
 462       Move (Source => Overwrite (Source, Position, New_Item),
 463             Target => Source,
 464             Drop   => Drop);
 465    end Overwrite;
 466
 467    -------------------
 468    -- Replace_Slice --
 469    -------------------
 470
 471    function Replace_Slice
 472      (Source : String;
 473       Low    : Positive;
 474       High   : Natural;
 475       By     : String) return String
 476    is
 477    begin
 478       if Low > Source'Last + 1 or else High < Source'First - 1 then
 479          raise Index_Error;
 480       end if;
 481
 482       if High >= Low then
 483          declare
 484             Front_Len : constant Integer :=
 485                           Integer'Max (0, Low - Source'First);
 486             --  Length of prefix of Source copied to result
 487
 488             Back_Len  : constant Integer :=
 489                           Integer'Max (0, Source'Last - High);
 490             --  Length of suffix of Source copied to result
 491
 492             Result_Length : constant Integer :=
 493                               Front_Len + By'Length + Back_Len;
 494             --  Length of result
 495
 496             Result : String (1 .. Result_Length);
 497
 498          begin
 499             Result (1 .. Front_Len) :=
 500               Source (Source'First .. Low - 1);
 501             Result (Front_Len + 1 .. Front_Len + By'Length) :=
 502               By;
 503             Result (Front_Len + By'Length + 1 .. Result'Length) :=
 504               Source (High + 1 .. Source'Last);
 505
 506             return Result;
 507          end;
 508
 509       else
 510          return Insert (Source, Before => Low, New_Item => By);
 511       end if;
 512    end Replace_Slice;
 513
 514    procedure Replace_Slice
 515      (Source   : in out String;
 516       Low      : Positive;
 517       High     : Natural;
 518       By       : String;
 519       Drop     : Truncation := Error;
 520       Justify  : Alignment  := Left;
 521       Pad      : Character  := Space)
 522    is
 523    begin
 524       Move (Replace_Slice (Source, Low, High, By), Source, Drop, Justify, Pad);
 525    end Replace_Slice;
 526
 527    ----------
 528    -- Tail --
 529    ----------
 530
 531    function Tail
 532      (Source : String;
 533       Count  : Natural;
 534       Pad    : Character := Space) return String
 535    is
 536       subtype Result_Type is String (1 .. Count);
 537
 538    begin
 539       if Count < Source'Length then
 540          return Result_Type (Source (Source'Last - Count + 1 .. Source'Last));
 541
 542       --  Pad on left
 543
 544       else
 545          declare
 546             Result : Result_Type;
 547
 548          begin
 549             for J in 1 .. Count - Source'Length loop
 550                Result (J) := Pad;
 551             end loop;
 552
 553             Result (Count - Source'Length + 1 .. Count) := Source;
 554             return Result;
 555          end;
 556       end if;
 557    end Tail;
 558
 559    procedure Tail
 560      (Source  : in out String;
 561       Count   : Natural;
 562       Justify : Alignment := Left;
 563       Pad     : Character := Space)
 564    is
 565    begin
 566       Move (Source  => Tail (Source, Count, Pad),
 567             Target  => Source,
 568             Drop    => Error,
 569             Justify => Justify,
 570             Pad     => Pad);
 571    end Tail;
 572
 573    ---------------
 574    -- Translate --
 575    ---------------
 576
 577    function Translate
 578      (Source  : String;
 579       Mapping : Maps.Character_Mapping) return String
 580    is
 581       Result : String (1 .. Source'Length);
 582
 583    begin
 584       for J in Source'Range loop
 585          Result (J - (Source'First - 1)) := Value (Mapping, Source (J));
 586       end loop;
 587
 588       return Result;
 589    end Translate;
 590
 591    procedure Translate
 592      (Source  : in out String;
 593       Mapping : Maps.Character_Mapping)
 594    is
 595    begin
 596       for J in Source'Range loop
 597          Source (J) := Value (Mapping, Source (J));
 598       end loop;
 599    end Translate;
 600
 601    function Translate
 602      (Source  : String;
 603       Mapping : Maps.Character_Mapping_Function) return String
 604    is
 605       Result : String (1 .. Source'Length);
 606       pragma Unsuppress (Access_Check);
 607
 608    begin
 609       for J in Source'Range loop
 610          Result (J - (Source'First - 1)) := Mapping.all (Source (J));
 611       end loop;
 612
 613       return Result;
 614    end Translate;
 615
 616    procedure Translate
 617      (Source  : in out String;
 618       Mapping : Maps.Character_Mapping_Function)
 619    is
 620       pragma Unsuppress (Access_Check);
 621    begin
 622       for J in Source'Range loop
 623          Source (J) := Mapping.all (Source (J));
 624       end loop;
 625    end Translate;
 626
 627    ----------
 628    -- Trim --
 629    ----------
 630
 631    function Trim
 632      (Source : String;
 633       Side   : Trim_End) return String
 634    is
 635       Low, High : Integer;
 636
 637    begin
 638       Low := Index_Non_Blank (Source, Forward);
 639
 640       --  All blanks case
 641
 642       if Low = 0 then
 643          return "";
 644
 645       --  At least one non-blank
 646
 647       else
 648          High := Index_Non_Blank (Source, Backward);
 649
 650          case Side is
 651             when Strings.Left =>
 652                declare
 653                   subtype Result_Type is String (1 .. Source'Last - Low + 1);
 654
 655                begin
 656                   return Result_Type (Source (Low .. Source'Last));
 657                end;
 658
 659             when Strings.Right =>
 660                declare
 661                   subtype Result_Type is String (1 .. High - Source'First + 1);
 662
 663                begin
 664                   return Result_Type (Source (Source'First .. High));
 665                end;
 666
 667             when Strings.Both =>
 668                declare
 669                   subtype Result_Type is String (1 .. High - Low + 1);
 670
 671                begin
 672                   return Result_Type (Source (Low .. High));
 673                end;
 674          end case;
 675       end if;
 676    end Trim;
 677
 678    procedure Trim
 679      (Source  : in out String;
 680       Side    : Trim_End;
 681       Justify : Alignment := Left;
 682       Pad     : Character := Space)
 683    is
 684    begin
 685       Move (Trim (Source, Side),
 686             Source,
 687             Justify => Justify,
 688             Pad => Pad);
 689    end Trim;
 690
 691    function Trim
 692      (Source : String;
 693       Left   : Maps.Character_Set;
 694       Right  : Maps.Character_Set) return String
 695    is
 696       High, Low : Integer;
 697
 698    begin
 699       Low := Index (Source, Set => Left, Test  => Outside, Going => Forward);
 700
 701       --  Case where source comprises only characters in Left
 702
 703       if Low = 0 then
 704          return "";
 705       end if;
 706
 707       High :=
 708         Index (Source, Set => Right, Test  => Outside, Going => Backward);
 709
 710       --  Case where source comprises only characters in Right
 711
 712       if High = 0 then
 713          return "";
 714       end if;
 715
 716       declare
 717          subtype Result_Type is String (1 .. High - Low + 1);
 718
 719       begin
 720          return Result_Type (Source (Low .. High));
 721       end;
 722    end Trim;
 723
 724    procedure Trim
 725      (Source  : in out String;
 726       Left    : Maps.Character_Set;
 727       Right   : Maps.Character_Set;
 728       Justify : Alignment := Strings.Left;
 729       Pad     : Character := Space)
 730    is
 731    begin
 732       Move (Source  => Trim (Source, Left, Right),
 733             Target  => Source,
 734             Justify => Justify,
 735             Pad     => Pad);
 736    end Trim;
 737
 738 end Ada.Strings.Fixed;