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