gcc/ada/a-stzfix.adb

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