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-2009, 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       Test   : Membership;
 127       First  : out Positive;
 128       Last   : out Natural)
 129    renames Ada.Strings.Search.Find_Token;
 130
 131    ---------
 132    -- "*" --
 133    ---------
 134
 135    function "*"
 136      (Left  : Natural;
 137       Right : Character) return String
 138    is
 139       Result : String (1 .. Left);
 140
 141    begin
 142       for J in Result'Range loop
 143          Result (J) := Right;
 144       end loop;
 145
 146       return Result;
 147    end "*";
 148
 149    function "*"
 150      (Left  : Natural;
 151       Right : String) return String
 152    is
 153       Result : String (1 .. Left * Right'Length);
 154       Ptr    : Integer := 1;
 155
 156    begin
 157       for J in 1 .. Left loop
 158          Result (Ptr .. Ptr + Right'Length - 1) := Right;
 159          Ptr := Ptr + Right'Length;
 160       end loop;
 161
 162       return Result;
 163    end "*";
 164
 165    ------------
 166    -- Delete --
 167    ------------
 168
 169    function Delete
 170      (Source  : String;
 171       From    : Positive;
 172       Through : Natural) return String
 173    is
 174    begin
 175       if From > Through then
 176          declare
 177             subtype Result_Type is String (1 .. Source'Length);
 178
 179          begin
 180             return Result_Type (Source);
 181          end;
 182
 183       elsif From not in Source'Range
 184         or else Through > Source'Last
 185       then
 186          raise Index_Error;
 187
 188       else
 189          declare
 190             Front  : constant Integer := From - Source'First;
 191             Result : String (1 .. Source'Length - (Through - From + 1));
 192
 193          begin
 194             Result (1 .. Front) :=
 195               Source (Source'First .. From - 1);
 196             Result (Front + 1 .. Result'Last) :=
 197               Source (Through + 1 .. Source'Last);
 198
 199             return Result;
 200          end;
 201       end if;
 202    end Delete;
 203
 204    procedure Delete
 205      (Source  : in out String;
 206       From    : Positive;
 207       Through : Natural;
 208       Justify : Alignment := Left;
 209       Pad     : Character := Space)
 210    is
 211    begin
 212       Move (Source  => Delete (Source, From, Through),
 213             Target  => Source,
 214             Justify => Justify,
 215             Pad     => Pad);
 216    end Delete;
 217
 218    ----------
 219    -- Head --
 220    ----------
 221
 222    function Head
 223      (Source : String;
 224       Count  : Natural;
 225       Pad    : Character := Space) return String
 226    is
 227       subtype Result_Type is String (1 .. Count);
 228
 229    begin
 230       if Count < Source'Length then
 231          return
 232            Result_Type (Source (Source'First .. Source'First + Count - 1));
 233
 234       else
 235          declare
 236             Result : Result_Type;
 237
 238          begin
 239             Result (1 .. Source'Length) := Source;
 240
 241             for J in Source'Length + 1 .. Count loop
 242                Result (J) := Pad;
 243             end loop;
 244
 245             return Result;
 246          end;
 247       end if;
 248    end Head;
 249
 250    procedure Head
 251      (Source  : in out String;
 252       Count   : Natural;
 253       Justify : Alignment := Left;
 254       Pad     : Character := Space)
 255    is
 256    begin
 257       Move (Source  => Head (Source, Count, Pad),
 258             Target  => Source,
 259             Drop    => Error,
 260             Justify => Justify,
 261             Pad     => Pad);
 262    end Head;
 263
 264    ------------
 265    -- Insert --
 266    ------------
 267
 268    function Insert
 269      (Source   : String;
 270       Before   : Positive;
 271       New_Item : String) return String
 272    is
 273       Result : String (1 .. Source'Length + New_Item'Length);
 274       Front  : constant Integer := Before - Source'First;
 275
 276    begin
 277       if Before not in Source'First .. Source'Last + 1 then
 278          raise Index_Error;
 279       end if;
 280
 281       Result (1 .. Front) :=
 282         Source (Source'First .. Before - 1);
 283       Result (Front + 1 .. Front + New_Item'Length) :=
 284         New_Item;
 285       Result (Front + New_Item'Length + 1 .. Result'Last) :=
 286         Source (Before .. Source'Last);
 287
 288       return Result;
 289    end Insert;
 290
 291    procedure Insert
 292      (Source   : in out String;
 293       Before   : Positive;
 294       New_Item : String;
 295       Drop     : Truncation := Error)
 296    is
 297    begin
 298       Move (Source => Insert (Source, Before, New_Item),
 299             Target => Source,
 300             Drop   => Drop);
 301    end Insert;
 302
 303    ----------
 304    -- Move --
 305    ----------
 306
 307    procedure Move
 308      (Source  : String;
 309       Target  : out String;
 310       Drop    : Truncation := Error;
 311       Justify : Alignment  := Left;
 312       Pad     : Character  := Space)
 313    is
 314       Sfirst  : constant Integer := Source'First;
 315       Slast   : constant Integer := Source'Last;
 316       Slength : constant Integer := Source'Length;
 317
 318       Tfirst  : constant Integer := Target'First;
 319       Tlast   : constant Integer := Target'Last;
 320       Tlength : constant Integer := Target'Length;
 321
 322       function Is_Padding (Item : String) return Boolean;
 323       --  Check if Item is all Pad characters, return True if so, False if not
 324
 325       function Is_Padding (Item : String) return Boolean is
 326       begin
 327          for J in Item'Range loop
 328             if Item (J) /= Pad then
 329                return False;
 330             end if;
 331          end loop;
 332
 333          return True;
 334       end Is_Padding;
 335
 336    --  Start of processing for Move
 337
 338    begin
 339       if Slength = Tlength then
 340          Target := Source;
 341
 342       elsif Slength > Tlength then
 343
 344          case Drop is
 345             when Left =>
 346                Target := Source (Slast - Tlength + 1 .. Slast);
 347
 348             when Right =>
 349                Target := Source (Sfirst .. Sfirst + Tlength - 1);
 350
 351             when Error =>
 352                case Justify is
 353                   when Left =>
 354                      if Is_Padding (Source (Sfirst + Tlength .. Slast)) then
 355                         Target :=
 356                           Source (Sfirst .. Sfirst + Target'Length - 1);
 357                      else
 358                         raise Length_Error;
 359                      end if;
 360
 361                   when Right =>
 362                      if Is_Padding (Source (Sfirst .. Slast - Tlength)) then
 363                         Target := Source (Slast - Tlength + 1 .. Slast);
 364                      else
 365                         raise Length_Error;
 366                      end if;
 367
 368                   when Center =>
 369                      raise Length_Error;
 370                end case;
 371
 372          end case;
 373
 374       --  Source'Length < Target'Length
 375
 376       else
 377          case Justify is
 378             when Left =>
 379                Target (Tfirst .. Tfirst + Slength - 1) := Source;
 380
 381                for I in Tfirst + Slength .. Tlast loop
 382                   Target (I) := Pad;
 383                end loop;
 384
 385             when Right =>
 386                for I in Tfirst .. Tlast - Slength loop
 387                   Target (I) := Pad;
 388                end loop;
 389
 390                Target (Tlast - Slength + 1 .. Tlast) := Source;
 391
 392             when Center =>
 393                declare
 394                   Front_Pad   : constant Integer := (Tlength - Slength) / 2;
 395                   Tfirst_Fpad : constant Integer := Tfirst + Front_Pad;
 396
 397                begin
 398                   for I in Tfirst .. Tfirst_Fpad - 1 loop
 399                      Target (I) := Pad;
 400                   end loop;
 401
 402                   Target (Tfirst_Fpad .. Tfirst_Fpad + Slength - 1) := Source;
 403
 404                   for I in Tfirst_Fpad + Slength .. Tlast loop
 405                      Target (I) := Pad;
 406                   end loop;
 407                end;
 408          end case;
 409       end if;
 410    end Move;
 411
 412    ---------------
 413    -- Overwrite --
 414    ---------------
 415
 416    function Overwrite
 417      (Source   : String;
 418       Position : Positive;
 419       New_Item : String) return String
 420    is
 421    begin
 422       if Position not in Source'First .. Source'Last + 1 then
 423          raise Index_Error;
 424       end if;
 425
 426       declare
 427          Result_Length : constant Natural :=
 428                            Integer'Max
 429                              (Source'Length,
 430                               Position - Source'First + New_Item'Length);
 431
 432          Result : String (1 .. Result_Length);
 433          Front  : constant Integer := Position - Source'First;
 434
 435       begin
 436          Result (1 .. Front) :=
 437            Source (Source'First .. Position - 1);
 438          Result (Front + 1 .. Front + New_Item'Length) :=
 439            New_Item;
 440          Result (Front + New_Item'Length + 1 .. Result'Length) :=
 441            Source (Position + New_Item'Length .. Source'Last);
 442          return Result;
 443       end;
 444    end Overwrite;
 445
 446    procedure Overwrite
 447      (Source   : in out String;
 448       Position : Positive;
 449       New_Item : String;
 450       Drop     : Truncation := Right)
 451    is
 452    begin
 453       Move (Source => Overwrite (Source, Position, New_Item),
 454             Target => Source,
 455             Drop   => Drop);
 456    end Overwrite;
 457
 458    -------------------
 459    -- Replace_Slice --
 460    -------------------
 461
 462    function Replace_Slice
 463      (Source : String;
 464       Low    : Positive;
 465       High   : Natural;
 466       By     : String) return String
 467    is
 468    begin
 469       if Low > Source'Last + 1 or else High < Source'First - 1 then
 470          raise Index_Error;
 471       end if;
 472
 473       if High >= Low then
 474          declare
 475             Front_Len : constant Integer :=
 476                           Integer'Max (0, Low - Source'First);
 477             --  Length of prefix of Source copied to result
 478
 479             Back_Len  : constant Integer :=
 480                           Integer'Max (0, Source'Last - High);
 481             --  Length of suffix of Source copied to result
 482
 483             Result_Length : constant Integer :=
 484                               Front_Len + By'Length + Back_Len;
 485             --  Length of result
 486
 487             Result : String (1 .. Result_Length);
 488
 489          begin
 490             Result (1 .. Front_Len) :=
 491               Source (Source'First .. Low - 1);
 492             Result (Front_Len + 1 .. Front_Len + By'Length) :=
 493               By;
 494             Result (Front_Len + By'Length + 1 .. Result'Length) :=
 495               Source (High + 1 .. Source'Last);
 496
 497             return Result;
 498          end;
 499
 500       else
 501          return Insert (Source, Before => Low, New_Item => By);
 502       end if;
 503    end Replace_Slice;
 504
 505    procedure Replace_Slice
 506      (Source   : in out String;
 507       Low      : Positive;
 508       High     : Natural;
 509       By       : String;
 510       Drop     : Truncation := Error;
 511       Justify  : Alignment  := Left;
 512       Pad      : Character  := Space)
 513    is
 514    begin
 515       Move (Replace_Slice (Source, Low, High, By), Source, Drop, Justify, Pad);
 516    end Replace_Slice;
 517
 518    ----------
 519    -- Tail --
 520    ----------
 521
 522    function Tail
 523      (Source : String;
 524       Count  : Natural;
 525       Pad    : Character := Space) return String
 526    is
 527       subtype Result_Type is String (1 .. Count);
 528
 529    begin
 530       if Count < Source'Length then
 531          return Result_Type (Source (Source'Last - Count + 1 .. Source'Last));
 532
 533       --  Pad on left
 534
 535       else
 536          declare
 537             Result : Result_Type;
 538
 539          begin
 540             for J in 1 .. Count - Source'Length loop
 541                Result (J) := Pad;
 542             end loop;
 543
 544             Result (Count - Source'Length + 1 .. Count) := Source;
 545             return Result;
 546          end;
 547       end if;
 548    end Tail;
 549
 550    procedure Tail
 551      (Source  : in out String;
 552       Count   : Natural;
 553       Justify : Alignment := Left;
 554       Pad     : Character := Space)
 555    is
 556    begin
 557       Move (Source  => Tail (Source, Count, Pad),
 558             Target  => Source,
 559             Drop    => Error,
 560             Justify => Justify,
 561             Pad     => Pad);
 562    end Tail;
 563
 564    ---------------
 565    -- Translate --
 566    ---------------
 567
 568    function Translate
 569      (Source  : String;
 570       Mapping : Maps.Character_Mapping) return String
 571    is
 572       Result : String (1 .. Source'Length);
 573
 574    begin
 575       for J in Source'Range loop
 576          Result (J - (Source'First - 1)) := Value (Mapping, Source (J));
 577       end loop;
 578
 579       return Result;
 580    end Translate;
 581
 582    procedure Translate
 583      (Source  : in out String;
 584       Mapping : Maps.Character_Mapping)
 585    is
 586    begin
 587       for J in Source'Range loop
 588          Source (J) := Value (Mapping, Source (J));
 589       end loop;
 590    end Translate;
 591
 592    function Translate
 593      (Source  : String;
 594       Mapping : Maps.Character_Mapping_Function) return String
 595    is
 596       Result : String (1 .. Source'Length);
 597       pragma Unsuppress (Access_Check);
 598
 599    begin
 600       for J in Source'Range loop
 601          Result (J - (Source'First - 1)) := Mapping.all (Source (J));
 602       end loop;
 603
 604       return Result;
 605    end Translate;
 606
 607    procedure Translate
 608      (Source  : in out String;
 609       Mapping : Maps.Character_Mapping_Function)
 610    is
 611       pragma Unsuppress (Access_Check);
 612    begin
 613       for J in Source'Range loop
 614          Source (J) := Mapping.all (Source (J));
 615       end loop;
 616    end Translate;
 617
 618    ----------
 619    -- Trim --
 620    ----------
 621
 622    function Trim
 623      (Source : String;
 624       Side   : Trim_End) return String
 625    is
 626       Low, High : Integer;
 627
 628    begin
 629       Low := Index_Non_Blank (Source, Forward);
 630
 631       --  All blanks case
 632
 633       if Low = 0 then
 634          return "";
 635
 636       --  At least one non-blank
 637
 638       else
 639          High := Index_Non_Blank (Source, Backward);
 640
 641          case Side is
 642             when Strings.Left =>
 643                declare
 644                   subtype Result_Type is String (1 .. Source'Last - Low + 1);
 645
 646                begin
 647                   return Result_Type (Source (Low .. Source'Last));
 648                end;
 649
 650             when Strings.Right =>
 651                declare
 652                   subtype Result_Type is String (1 .. High - Source'First + 1);
 653
 654                begin
 655                   return Result_Type (Source (Source'First .. High));
 656                end;
 657
 658             when Strings.Both =>
 659                declare
 660                   subtype Result_Type is String (1 .. High - Low + 1);
 661
 662                begin
 663                   return Result_Type (Source (Low .. High));
 664                end;
 665          end case;
 666       end if;
 667    end Trim;
 668
 669    procedure Trim
 670      (Source  : in out String;
 671       Side    : Trim_End;
 672       Justify : Alignment := Left;
 673       Pad     : Character := Space)
 674    is
 675    begin
 676       Move (Trim (Source, Side),
 677             Source,
 678             Justify => Justify,
 679             Pad => Pad);
 680    end Trim;
 681
 682    function Trim
 683      (Source : String;
 684       Left   : Maps.Character_Set;
 685       Right  : Maps.Character_Set) return String
 686    is
 687       High, Low : Integer;
 688
 689    begin
 690       Low := Index (Source, Set => Left, Test  => Outside, Going => Forward);
 691
 692       --  Case where source comprises only characters in Left
 693
 694       if Low = 0 then
 695          return "";
 696       end if;
 697
 698       High :=
 699         Index (Source, Set => Right, Test  => Outside, Going => Backward);
 700
 701       --  Case where source comprises only characters in Right
 702
 703       if High = 0 then
 704          return "";
 705       end if;
 706
 707       declare
 708          subtype Result_Type is String (1 .. High - Low + 1);
 709
 710       begin
 711          return Result_Type (Source (Low .. High));
 712       end;
 713    end Trim;
 714
 715    procedure Trim
 716      (Source  : in out String;
 717       Left    : Maps.Character_Set;
 718       Right   : Maps.Character_Set;
 719       Justify : Alignment := Strings.Left;
 720       Pad     : Character := Space)
 721    is
 722    begin
 723       Move (Source  => Trim (Source, Left, Right),
 724             Target  => Source,
 725             Justify => Justify,
 726             Pad     => Pad);
 727    end Trim;
 728
 729 end Ada.Strings.Fixed;