gcc/ada/a-stwifi.adb

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