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-2016, 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          case Drop is
 333             when Left =>
 334                Target := Source (Slast - Tlength + 1 .. Slast);
 335
 336             when Right =>
 337                Target := Source (Sfirst .. Sfirst + Tlength - 1);
 338
 339             when Error =>
 340                case Justify is
 341                   when Left =>
 342                      if Is_Padding (Source (Sfirst + Tlength .. Slast)) then
 343                         Target :=
 344                           Source (Sfirst .. Sfirst + Target'Length - 1);
 345                      else
 346                         raise Length_Error;
 347                      end if;
 348
 349                   when Right =>
 350                      if Is_Padding (Source (Sfirst .. Slast - Tlength)) then
 351                         Target := Source (Slast - Tlength + 1 .. Slast);
 352                      else
 353                         raise Length_Error;
 354                      end if;
 355
 356                   when Center =>
 357                      raise Length_Error;
 358                end case;
 359
 360          end case;
 361
 362       --  Source'Length < Target'Length
 363
 364       else
 365          case Justify is
 366             when Left =>
 367                Target (Tfirst .. Tfirst + Slength - 1) := Source;
 368
 369                for J in Tfirst + Slength .. Tlast loop
 370                   Target (J) := Pad;
 371                end loop;
 372
 373             when Right =>
 374                for J in Tfirst .. Tlast - Slength loop
 375                   Target (J) := Pad;
 376                end loop;
 377
 378                Target (Tlast - Slength + 1 .. Tlast) := Source;
 379
 380             when Center =>
 381                declare
 382                   Front_Pad   : constant Integer := (Tlength - Slength) / 2;
 383                   Tfirst_Fpad : constant Integer := Tfirst + Front_Pad;
 384
 385                begin
 386                   for J in Tfirst .. Tfirst_Fpad - 1 loop
 387                      Target (J) := Pad;
 388                   end loop;
 389
 390                   Target (Tfirst_Fpad .. Tfirst_Fpad + Slength - 1) := Source;
 391
 392                   for J in Tfirst_Fpad + Slength .. Tlast loop
 393                      Target (J) := Pad;
 394                   end loop;
 395                end;
 396          end case;
 397       end if;
 398    end Move;
 399
 400    ---------------
 401    -- Overwrite --
 402    ---------------
 403
 404    function Overwrite
 405      (Source   : Wide_Wide_String;
 406       Position : Positive;
 407       New_Item : Wide_Wide_String) return Wide_Wide_String
 408    is
 409    begin
 410       if Position not in Source'First .. Source'Last + 1 then
 411          raise Index_Error;
 412       else
 413          declare
 414             Result_Length : constant Natural :=
 415               Natural'Max
 416                 (Source'Length,
 417                  Position - Source'First + New_Item'Length);
 418
 419             Result : Wide_Wide_String (1 .. Result_Length);
 420
 421          begin
 422             Result := Source (Source'First .. Position - 1) & New_Item &
 423                         Source (Position + New_Item'Length .. Source'Last);
 424             return Result;
 425          end;
 426       end if;
 427    end Overwrite;
 428
 429    procedure Overwrite
 430      (Source   : in out Wide_Wide_String;
 431       Position : Positive;
 432       New_Item : Wide_Wide_String;
 433       Drop     : Truncation := Right)
 434    is
 435    begin
 436       Move (Source => Overwrite (Source, Position, New_Item),
 437             Target => Source,
 438             Drop   => Drop);
 439    end Overwrite;
 440
 441    -------------------
 442    -- Replace_Slice --
 443    -------------------
 444
 445    function Replace_Slice
 446      (Source : Wide_Wide_String;
 447       Low    : Positive;
 448       High   : Natural;
 449       By     : Wide_Wide_String) return Wide_Wide_String
 450    is
 451    begin
 452       if Low > Source'Last + 1 or else High < Source'First - 1 then
 453          raise Index_Error;
 454       end if;
 455
 456       if High >= Low then
 457          declare
 458             Front_Len : constant Integer :=
 459               Integer'Max (0, Low - Source'First);
 460             --  Length of prefix of Source copied to result
 461
 462             Back_Len : constant Integer :=
 463               Integer'Max (0, Source'Last - High);
 464             --  Length of suffix of Source copied to result
 465
 466             Result_Length : constant Integer :=
 467               Front_Len + By'Length + Back_Len;
 468             --  Length of result
 469
 470             Result : Wide_Wide_String (1 .. Result_Length);
 471
 472          begin
 473             Result (1 .. Front_Len) := Source (Source'First .. Low - 1);
 474             Result (Front_Len + 1 .. Front_Len + By'Length) := By;
 475             Result (Front_Len + By'Length + 1 .. Result'Length) :=
 476               Source (High + 1 .. Source'Last);
 477             return Result;
 478          end;
 479
 480       else
 481          return Insert (Source, Before => Low, New_Item => By);
 482       end if;
 483    end Replace_Slice;
 484
 485    procedure Replace_Slice
 486      (Source   : in out Wide_Wide_String;
 487       Low      : Positive;
 488       High     : Natural;
 489       By       : Wide_Wide_String;
 490       Drop     : Truncation := Error;
 491       Justify  : Alignment  := Left;
 492       Pad      : Wide_Wide_Character  := Wide_Wide_Space)
 493    is
 494    begin
 495       Move (Replace_Slice (Source, Low, High, By), Source, Drop, Justify, Pad);
 496    end Replace_Slice;
 497
 498    ----------
 499    -- Tail --
 500    ----------
 501
 502    function Tail
 503      (Source : Wide_Wide_String;
 504       Count  : Natural;
 505       Pad    : Wide_Wide_Character := Wide_Wide_Space) return Wide_Wide_String
 506    is
 507       Result : Wide_Wide_String (1 .. Count);
 508
 509    begin
 510       if Count < Source'Length then
 511          Result := Source (Source'Last - Count + 1 .. Source'Last);
 512
 513       --  Pad on left
 514
 515       else
 516          for J in 1 .. Count - Source'Length loop
 517             Result (J) := Pad;
 518          end loop;
 519
 520          Result (Count - Source'Length + 1 .. Count) := Source;
 521       end if;
 522
 523       return Result;
 524    end Tail;
 525
 526    procedure Tail
 527      (Source  : in out Wide_Wide_String;
 528       Count   : Natural;
 529       Justify : Alignment := Left;
 530       Pad     : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space)
 531    is
 532    begin
 533       Move (Source  => Tail (Source, Count, Pad),
 534             Target  => Source,
 535             Drop    => Error,
 536             Justify => Justify,
 537             Pad     => Pad);
 538    end Tail;
 539
 540    ---------------
 541    -- Translate --
 542    ---------------
 543
 544    function Translate
 545      (Source  : Wide_Wide_String;
 546       Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping)
 547       return Wide_Wide_String
 548    is
 549       Result : Wide_Wide_String (1 .. Source'Length);
 550
 551    begin
 552       for J in Source'Range loop
 553          Result (J - (Source'First - 1)) := Value (Mapping, Source (J));
 554       end loop;
 555
 556       return Result;
 557    end Translate;
 558
 559    procedure Translate
 560      (Source  : in out Wide_Wide_String;
 561       Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping)
 562    is
 563    begin
 564       for J in Source'Range loop
 565          Source (J) := Value (Mapping, Source (J));
 566       end loop;
 567    end Translate;
 568
 569    function Translate
 570      (Source  : Wide_Wide_String;
 571       Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
 572       return Wide_Wide_String
 573    is
 574       Result : Wide_Wide_String (1 .. Source'Length);
 575
 576    begin
 577       for J in Source'Range loop
 578          Result (J - (Source'First - 1)) := Mapping (Source (J));
 579       end loop;
 580
 581       return Result;
 582    end Translate;
 583
 584    procedure Translate
 585      (Source  : in out Wide_Wide_String;
 586       Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
 587    is
 588    begin
 589       for J in Source'Range loop
 590          Source (J) := Mapping (Source (J));
 591       end loop;
 592    end Translate;
 593
 594    ----------
 595    -- Trim --
 596    ----------
 597
 598    function Trim
 599      (Source : Wide_Wide_String;
 600       Side   : Trim_End) return Wide_Wide_String
 601    is
 602       Low  : Natural := Source'First;
 603       High : Natural := Source'Last;
 604
 605    begin
 606       if Side = Left or else Side = Both then
 607          while Low <= High and then Source (Low) = Wide_Wide_Space loop
 608             Low := Low + 1;
 609          end loop;
 610       end if;
 611
 612       if Side = Right or else Side = Both then
 613          while High >= Low and then Source (High) = Wide_Wide_Space loop
 614             High := High - 1;
 615          end loop;
 616       end if;
 617
 618       --  All blanks case
 619
 620       if Low > High then
 621          return "";
 622
 623       --  At least one non-blank
 624
 625       else
 626          declare
 627             Result : constant Wide_Wide_String (1 .. High - Low + 1) :=
 628               Source (Low .. High);
 629
 630          begin
 631             return Result;
 632          end;
 633       end if;
 634    end Trim;
 635
 636    procedure Trim
 637      (Source  : in out Wide_Wide_String;
 638       Side    : Trim_End;
 639       Justify : Alignment      := Left;
 640       Pad     : Wide_Wide_Character := Wide_Wide_Space)
 641    is
 642    begin
 643       Move (Source  => Trim (Source, Side),
 644             Target  => Source,
 645             Justify => Justify,
 646             Pad     => Pad);
 647    end Trim;
 648
 649    function Trim
 650       (Source : Wide_Wide_String;
 651        Left   : Wide_Wide_Maps.Wide_Wide_Character_Set;
 652        Right  : Wide_Wide_Maps.Wide_Wide_Character_Set) return Wide_Wide_String
 653    is
 654       Low  : Natural := Source'First;
 655       High : Natural := Source'Last;
 656
 657    begin
 658       while Low <= High and then Is_In (Source (Low), Left) loop
 659          Low := Low + 1;
 660       end loop;
 661
 662       while High >= Low and then Is_In (Source (High), Right) loop
 663          High := High - 1;
 664       end loop;
 665
 666       --  Case where source comprises only characters in the sets
 667
 668       if Low > High then
 669          return "";
 670       else
 671          declare
 672             subtype WS is Wide_Wide_String (1 .. High - Low + 1);
 673
 674          begin
 675             return WS (Source (Low .. High));
 676          end;
 677       end if;
 678    end Trim;
 679
 680    procedure Trim
 681       (Source  : in out Wide_Wide_String;
 682        Left    : Wide_Wide_Maps.Wide_Wide_Character_Set;
 683        Right   : Wide_Wide_Maps.Wide_Wide_Character_Set;
 684        Justify : Alignment      := Strings.Left;
 685        Pad     : Wide_Wide_Character := Wide_Wide_Space)
 686    is
 687    begin
 688       Move (Source  => Trim (Source, Left, Right),
 689             Target  => Source,
 690             Justify => Justify,
 691             Pad     => Pad);
 692    end Trim;
 693
 694 end Ada.Strings.Wide_Wide_Fixed;