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