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