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