gcc/ada/a-strfix.adb

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