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