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 --                            $Revision: 1.17 $                             --
  10 --                                                                          --
  11 --          Copyright (C) 1992-1997 Free Software Foundation, Inc.          --
  12 --                                                                          --
  13 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- As a special exception,  if other files  instantiate  generics from this --
  25 -- unit, or you link  this unit with other files  to produce an executable, --
  26 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27 -- covered  by the  GNU  General  Public  License.  This exception does not --
  28 -- however invalidate  any other reasons why  the executable file  might be --
  29 -- covered by the  GNU Public License.                                      --
  30 --                                                                          --
  31 -- GNAT was originally developed  by the GNAT team at  New York University. --
  32 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  33 --                                                                          --
  34 ------------------------------------------------------------------------------
  35
  36
  37 with Ada.Strings.Wide_Maps; use Ada.Strings.Wide_Maps;
  38 with Ada.Strings.Wide_Search;
  39
  40 package body Ada.Strings.Wide_Fixed is
  41
  42    ------------------------
  43    -- Search Subprograms --
  44    ------------------------
  45
  46    function Index
  47      (Source  : in Wide_String;
  48       Pattern : in Wide_String;
  49       Going   : in Direction := Forward;
  50       Mapping : in Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity)
  51       return    Natural
  52    renames Ada.Strings.Wide_Search.Index;
  53
  54    function Index
  55      (Source  : in Wide_String;
  56       Pattern : in Wide_String;
  57       Going   : in Direction := Forward;
  58       Mapping : in Wide_Maps.Wide_Character_Mapping_Function)
  59       return    Natural
  60    renames Ada.Strings.Wide_Search.Index;
  61
  62    function Index
  63      (Source : in Wide_String;
  64       Set    : in Wide_Maps.Wide_Character_Set;
  65       Test   : in Membership := Inside;
  66       Going  : in Direction  := Forward)
  67       return   Natural
  68    renames Ada.Strings.Wide_Search.Index;
  69
  70    function Index_Non_Blank
  71      (Source : in Wide_String;
  72       Going  : in Direction := Forward)
  73       return   Natural
  74    renames Ada.Strings.Wide_Search.Index_Non_Blank;
  75
  76    function Count
  77      (Source  : in Wide_String;
  78       Pattern : in Wide_String;
  79       Mapping : in Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity)
  80       return    Natural
  81    renames Ada.Strings.Wide_Search.Count;
  82
  83    function Count
  84      (Source   : in Wide_String;
  85       Pattern  : in Wide_String;
  86       Mapping  : in Wide_Maps.Wide_Character_Mapping_Function)
  87       return     Natural
  88    renames Ada.Strings.Wide_Search.Count;
  89
  90    function Count
  91      (Source : in Wide_String;
  92       Set    : in Wide_Maps.Wide_Character_Set)
  93       return   Natural
  94    renames Ada.Strings.Wide_Search.Count;
  95
  96    procedure Find_Token
  97      (Source : in Wide_String;
  98       Set    : in Wide_Maps.Wide_Character_Set;
  99       Test   : in Membership;
 100       First  : out Positive;
 101       Last   : out Natural)
 102    renames Ada.Strings.Wide_Search.Find_Token;
 103
 104    ---------
 105    -- "*" --
 106    ---------
 107
 108    function "*"
 109      (Left  : in Natural;
 110       Right : in Wide_Character)
 111       return  Wide_String
 112    is
 113       Result : Wide_String (1 .. Left);
 114
 115    begin
 116       for J in Result'Range loop
 117          Result (J) := Right;
 118       end loop;
 119
 120       return Result;
 121    end "*";
 122
 123    function "*"
 124      (Left  : in Natural;
 125       Right : in Wide_String)
 126       return  Wide_String
 127    is
 128       Result : Wide_String (1 .. Left * Right'Length);
 129       Ptr    : Integer := 1;
 130
 131    begin
 132       for J in 1 .. Left loop
 133          Result (Ptr .. Ptr + Right'Length - 1) := Right;
 134          Ptr := Ptr + Right'Length;
 135       end loop;
 136
 137       return Result;
 138    end "*";
 139
 140    ------------
 141    -- Delete --
 142    ------------
 143
 144    function Delete
 145      (Source  : in Wide_String;
 146       From    : in Positive;
 147       Through : in Natural)
 148       return    Wide_String
 149    is
 150    begin
 151       if From not in Source'Range
 152         or else Through > Source'Last
 153       then
 154          raise Index_Error;
 155
 156       elsif From > Through then
 157          return Source;
 158
 159       else
 160          declare
 161             Result : constant Wide_String :=
 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 (Source'Length,
 385                              Position - Source'First + New_Item'Length);
 386             Result : Wide_String (1 .. Result_Length);
 387
 388          begin
 389             Result := Source (Source'First .. Position - 1) & New_Item &
 390                      Source (Position + New_Item'Length .. Source'Last);
 391             return Result;
 392          end;
 393       end if;
 394    end Overwrite;
 395
 396    procedure Overwrite
 397      (Source   : in out Wide_String;
 398       Position : in Positive;
 399       New_Item : in Wide_String;
 400       Drop     : in Truncation := Right)
 401    is
 402    begin
 403       Move (Source => Overwrite (Source, Position, New_Item),
 404             Target => Source,
 405             Drop   => Drop);
 406    end Overwrite;
 407
 408    -------------------
 409    -- Replace_Slice --
 410    -------------------
 411
 412    function Replace_Slice
 413      (Source   : in Wide_String;
 414       Low      : in Positive;
 415       High     : in Natural;
 416       By       : in Wide_String)
 417       return     Wide_String
 418    is
 419       Result_Length : Natural;
 420
 421    begin
 422       if Low > Source'Last + 1 or else High < Source'First - 1 then
 423          raise Index_Error;
 424       else
 425          Result_Length :=
 426            Source'Length - Natural'Max (High - Low + 1, 0) + By'Length;
 427
 428          declare
 429             Result : Wide_String (1 .. Result_Length);
 430
 431          begin
 432             if High >= Low then
 433                Result :=
 434                   Source (Source'First .. Low - 1) & By &
 435                   Source (High + 1 .. Source'Last);
 436             else
 437                Result := Source (Source'First .. Low - 1) & By &
 438                          Source (Low .. Source'Last);
 439             end if;
 440
 441             return Result;
 442          end;
 443       end if;
 444    end Replace_Slice;
 445
 446    procedure Replace_Slice
 447      (Source   : in out Wide_String;
 448       Low      : in Positive;
 449       High     : in Natural;
 450       By       : in Wide_String;
 451       Drop     : in Truncation := Error;
 452       Justify  : in Alignment  := Left;
 453       Pad      : in Wide_Character  := Wide_Space)
 454    is
 455    begin
 456       Move (Replace_Slice (Source, Low, High, By), Source, Drop, Justify, Pad);
 457    end Replace_Slice;
 458
 459    ----------
 460    -- Tail --
 461    ----------
 462
 463    function Tail
 464      (Source : in Wide_String;
 465       Count  : in Natural;
 466       Pad    : in Wide_Character := Wide_Space)
 467       return   Wide_String
 468    is
 469       Result : Wide_String (1 .. Count);
 470
 471    begin
 472       if Count < Source'Length then
 473          Result := Source (Source'Last - Count + 1 .. Source'Last);
 474
 475       --  Pad on left
 476
 477       else
 478          for J in 1 .. Count - Source'Length loop
 479             Result (J) := Pad;
 480          end loop;
 481
 482          Result (Count - Source'Length + 1 .. Count) := Source;
 483       end if;
 484
 485       return Result;
 486    end Tail;
 487
 488    procedure Tail
 489      (Source  : in out Wide_String;
 490       Count   : in Natural;
 491       Justify : in Alignment := Left;
 492       Pad     : in Wide_Character := Ada.Strings.Wide_Space)
 493    is
 494    begin
 495       Move (Source  => Tail (Source, Count, Pad),
 496             Target  => Source,
 497             Drop    => Error,
 498             Justify => Justify,
 499             Pad     => Pad);
 500    end Tail;
 501
 502    ---------------
 503    -- Translate --
 504    ---------------
 505
 506    function Translate
 507      (Source  : in Wide_String;
 508       Mapping : in Wide_Maps.Wide_Character_Mapping)
 509       return    Wide_String
 510    is
 511       Result : Wide_String (1 .. Source'Length);
 512
 513    begin
 514       for J in Source'Range loop
 515          Result (J - (Source'First - 1)) := Value (Mapping, Source (J));
 516       end loop;
 517
 518       return Result;
 519    end Translate;
 520
 521    procedure Translate
 522      (Source  : in out Wide_String;
 523       Mapping : in Wide_Maps.Wide_Character_Mapping)
 524    is
 525    begin
 526       for J in Source'Range loop
 527          Source (J) := Value (Mapping, Source (J));
 528       end loop;
 529    end Translate;
 530
 531    function Translate
 532      (Source  : in Wide_String;
 533       Mapping : in Wide_Maps.Wide_Character_Mapping_Function)
 534       return    Wide_String
 535    is
 536       Result : Wide_String (1 .. Source'Length);
 537
 538    begin
 539       for J in Source'Range loop
 540          Result (J - (Source'First - 1)) := Mapping (Source (J));
 541       end loop;
 542
 543       return Result;
 544    end Translate;
 545
 546    procedure Translate
 547      (Source  : in out Wide_String;
 548       Mapping : in Wide_Maps.Wide_Character_Mapping_Function)
 549    is
 550    begin
 551       for J in Source'Range loop
 552          Source (J) := Mapping (Source (J));
 553       end loop;
 554    end Translate;
 555
 556    ----------
 557    -- Trim --
 558    ----------
 559
 560    function Trim
 561      (Source : in Wide_String;
 562       Side   : in Trim_End)
 563       return   Wide_String
 564    is
 565       Low  : Natural := Source'First;
 566       High : Natural := Source'Last;
 567
 568    begin
 569       if Side = Left or else Side = Both then
 570          while Low <= High and then Source (Low) = Wide_Space loop
 571             Low := Low + 1;
 572          end loop;
 573       end if;
 574
 575       if Side = Right or else Side = Both then
 576          while High >= Low and then Source (High) = Wide_Space loop
 577             High := High - 1;
 578          end loop;
 579       end if;
 580
 581       --  All blanks case
 582
 583       if Low > High then
 584          return "";
 585
 586       --  At least one non-blank
 587
 588       else
 589          declare
 590             Result : Wide_String (1 .. High - Low + 1) := Source (Low .. High);
 591
 592          begin
 593             return Result;
 594          end;
 595       end if;
 596    end Trim;
 597
 598    procedure Trim
 599      (Source  : in out Wide_String;
 600       Side    : in Trim_End;
 601       Justify : in Alignment      := Left;
 602       Pad     : in Wide_Character := Wide_Space)
 603    is
 604    begin
 605       Move (Source  => Trim (Source, Side),
 606             Target  => Source,
 607             Justify => Justify,
 608             Pad     => Pad);
 609    end Trim;
 610
 611    function Trim
 612       (Source : in Wide_String;
 613        Left   : in Wide_Maps.Wide_Character_Set;
 614        Right  : in Wide_Maps.Wide_Character_Set)
 615        return   Wide_String
 616    is
 617       Low  : Natural := Source'First;
 618       High : Natural := Source'Last;
 619
 620    begin
 621       while Low <= High and then Is_In (Source (Low), Left) loop
 622          Low := Low + 1;
 623       end loop;
 624
 625       while High >= Low and then Is_In (Source (High), Right) loop
 626          High := High - 1;
 627       end loop;
 628
 629       --  Case where source comprises only characters in the sets
 630
 631       if Low > High then
 632          return "";
 633       else
 634          declare
 635             subtype WS is Wide_String (1 .. High - Low + 1);
 636
 637          begin
 638             return WS (Source (Low .. High));
 639          end;
 640       end if;
 641    end Trim;
 642
 643    procedure Trim
 644       (Source  : in out Wide_String;
 645        Left    : in Wide_Maps.Wide_Character_Set;
 646        Right   : in Wide_Maps.Wide_Character_Set;
 647        Justify : in Alignment      := Strings.Left;
 648        Pad     : in Wide_Character := Wide_Space)
 649    is
 650    begin
 651       Move (Source  => Trim (Source, Left, Right),
 652             Target  => Source,
 653             Justify => Justify,
 654             Pad     => Pad);
 655    end Trim;
 656
 657 end Ada.Strings.Wide_Fixed;