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