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