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