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    begin
 453       if Low > Source'Last + 1 or else High < Source'First - 1 then
 454          raise Index_Error;
 455       end if;
 456
 457       if High >= Low then
 458          declare
 459             Front_Len : constant Integer :=
 460                           Integer'Max (0, Low - Source'First);
 461             --  Length of prefix of Source copied to result
 462
 463             Back_Len : constant Integer :=
 464                          Integer'Max (0, Source'Last - High);
 465             --  Length of suffix of Source copied to result
 466
 467             Result_Length : constant Integer :=
 468                               Front_Len + By'Length + Back_Len;
 469             --  Length of result
 470
 471             Result : Wide_Wide_String (1 .. Result_Length);
 472
 473          begin
 474             Result (1 .. Front_Len) := Source (Source'First .. Low - 1);
 475             Result (Front_Len + 1 .. Front_Len + By'Length) := By;
 476             Result (Front_Len + By'Length + 1 .. Result'Length) :=
 477               Source (High + 1 .. Source'Last);
 478             return Result;
 479          end;
 480
 481       else
 482          return Insert (Source, Before => Low, New_Item => By);
 483       end if;
 484    end Replace_Slice;
 485
 486    procedure Replace_Slice
 487      (Source   : in out Wide_Wide_String;
 488       Low      : Positive;
 489       High     : Natural;
 490       By       : Wide_Wide_String;
 491       Drop     : Truncation := Error;
 492       Justify  : Alignment  := Left;
 493       Pad      : Wide_Wide_Character  := Wide_Wide_Space)
 494    is
 495    begin
 496       Move (Replace_Slice (Source, Low, High, By), Source, Drop, Justify, Pad);
 497    end Replace_Slice;
 498
 499    ----------
 500    -- Tail --
 501    ----------
 502
 503    function Tail
 504      (Source : Wide_Wide_String;
 505       Count  : Natural;
 506       Pad    : Wide_Wide_Character := Wide_Wide_Space) return Wide_Wide_String
 507    is
 508       Result : Wide_Wide_String (1 .. Count);
 509
 510    begin
 511       if Count < Source'Length then
 512          Result := Source (Source'Last - Count + 1 .. Source'Last);
 513
 514       --  Pad on left
 515
 516       else
 517          for J in 1 .. Count - Source'Length loop
 518             Result (J) := Pad;
 519          end loop;
 520
 521          Result (Count - Source'Length + 1 .. Count) := Source;
 522       end if;
 523
 524       return Result;
 525    end Tail;
 526
 527    procedure Tail
 528      (Source  : in out Wide_Wide_String;
 529       Count   : Natural;
 530       Justify : Alignment := Left;
 531       Pad     : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space)
 532    is
 533    begin
 534       Move (Source  => Tail (Source, Count, Pad),
 535             Target  => Source,
 536             Drop    => Error,
 537             Justify => Justify,
 538             Pad     => Pad);
 539    end Tail;
 540
 541    ---------------
 542    -- Translate --
 543    ---------------
 544
 545    function Translate
 546      (Source  : Wide_Wide_String;
 547       Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping)
 548       return Wide_Wide_String
 549    is
 550       Result : Wide_Wide_String (1 .. Source'Length);
 551
 552    begin
 553       for J in Source'Range loop
 554          Result (J - (Source'First - 1)) := Value (Mapping, Source (J));
 555       end loop;
 556
 557       return Result;
 558    end Translate;
 559
 560    procedure Translate
 561      (Source  : in out Wide_Wide_String;
 562       Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping)
 563    is
 564    begin
 565       for J in Source'Range loop
 566          Source (J) := Value (Mapping, Source (J));
 567       end loop;
 568    end Translate;
 569
 570    function Translate
 571      (Source  : Wide_Wide_String;
 572       Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
 573       return Wide_Wide_String
 574    is
 575       Result : Wide_Wide_String (1 .. Source'Length);
 576
 577    begin
 578       for J in Source'Range loop
 579          Result (J - (Source'First - 1)) := Mapping (Source (J));
 580       end loop;
 581
 582       return Result;
 583    end Translate;
 584
 585    procedure Translate
 586      (Source  : in out Wide_Wide_String;
 587       Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
 588    is
 589    begin
 590       for J in Source'Range loop
 591          Source (J) := Mapping (Source (J));
 592       end loop;
 593    end Translate;
 594
 595    ----------
 596    -- Trim --
 597    ----------
 598
 599    function Trim
 600      (Source : Wide_Wide_String;
 601       Side   : Trim_End) return Wide_Wide_String
 602    is
 603       Low  : Natural := Source'First;
 604       High : Natural := Source'Last;
 605
 606    begin
 607       if Side = Left or else Side = Both then
 608          while Low <= High and then Source (Low) = Wide_Wide_Space loop
 609             Low := Low + 1;
 610          end loop;
 611       end if;
 612
 613       if Side = Right or else Side = Both then
 614          while High >= Low and then Source (High) = Wide_Wide_Space loop
 615             High := High - 1;
 616          end loop;
 617       end if;
 618
 619       --  All blanks case
 620
 621       if Low > High then
 622          return "";
 623
 624       --  At least one non-blank
 625
 626       else
 627          declare
 628             Result : constant Wide_Wide_String (1 .. High - Low + 1) :=
 629                        Source (Low .. High);
 630
 631          begin
 632             return Result;
 633          end;
 634       end if;
 635    end Trim;
 636
 637    procedure Trim
 638      (Source  : in out Wide_Wide_String;
 639       Side    : Trim_End;
 640       Justify : Alignment      := Left;
 641       Pad     : Wide_Wide_Character := Wide_Wide_Space)
 642    is
 643    begin
 644       Move (Source  => Trim (Source, Side),
 645             Target  => Source,
 646             Justify => Justify,
 647             Pad     => Pad);
 648    end Trim;
 649
 650    function Trim
 651       (Source : Wide_Wide_String;
 652        Left   : Wide_Wide_Maps.Wide_Wide_Character_Set;
 653        Right  : Wide_Wide_Maps.Wide_Wide_Character_Set) return Wide_Wide_String
 654    is
 655       Low  : Natural := Source'First;
 656       High : Natural := Source'Last;
 657
 658    begin
 659       while Low <= High and then Is_In (Source (Low), Left) loop
 660          Low := Low + 1;
 661       end loop;
 662
 663       while High >= Low and then Is_In (Source (High), Right) loop
 664          High := High - 1;
 665       end loop;
 666
 667       --  Case where source comprises only characters in the sets
 668
 669       if Low > High then
 670          return "";
 671       else
 672          declare
 673             subtype WS is Wide_Wide_String (1 .. High - Low + 1);
 674
 675          begin
 676             return WS (Source (Low .. High));
 677          end;
 678       end if;
 679    end Trim;
 680
 681    procedure Trim
 682       (Source  : in out Wide_Wide_String;
 683        Left    : Wide_Wide_Maps.Wide_Wide_Character_Set;
 684        Right   : Wide_Wide_Maps.Wide_Wide_Character_Set;
 685        Justify : Alignment      := Strings.Left;
 686        Pad     : Wide_Wide_Character := Wide_Wide_Space)
 687    is
 688    begin
 689       Move (Source  => Trim (Source, Left, Right),
 690             Target  => Source,
 691             Justify => Justify,
 692             Pad     => Pad);
 693    end Trim;
 694
 695 end Ada.Strings.Wide_Wide_Fixed;