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