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