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