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       --  Determinbe if all characters in Item are pad characters
 300
 301       function Is_Padding (Item : Wide_String) return Boolean is
 302       begin
 303          for J in Item'Range loop
 304             if Item (J) /= Pad then
 305                return False;
 306             end if;
 307          end loop;
 308
 309          return True;
 310       end Is_Padding;
 311
 312    --  Start of processing for Move
 313
 314    begin
 315       if Slength = Tlength then
 316          Target := Source;
 317
 318       elsif Slength > Tlength then
 319
 320          case Drop is
 321             when Left =>
 322                Target := Source (Slast - Tlength + 1 .. Slast);
 323
 324             when Right =>
 325                Target := Source (Sfirst .. Sfirst + Tlength - 1);
 326
 327             when Error =>
 328                case Justify is
 329                   when Left =>
 330                      if Is_Padding (Source (Sfirst + Tlength .. Slast)) then
 331                         Target :=
 332                           Source (Sfirst .. Sfirst + Target'Length - 1);
 333                      else
 334                         raise Length_Error;
 335                      end if;
 336
 337                   when Right =>
 338                      if Is_Padding (Source (Sfirst .. Slast - Tlength)) then
 339                         Target := Source (Slast - Tlength + 1 .. Slast);
 340                      else
 341                         raise Length_Error;
 342                      end if;
 343
 344                   when Center =>
 345                      raise Length_Error;
 346                end case;
 347
 348          end case;
 349
 350       --  Source'Length < Target'Length
 351
 352       else
 353          case Justify is
 354             when Left =>
 355                Target (Tfirst .. Tfirst + Slength - 1) := Source;
 356
 357                for J in Tfirst + Slength .. Tlast loop
 358                   Target (J) := Pad;
 359                end loop;
 360
 361             when Right =>
 362                for J in Tfirst .. Tlast - Slength loop
 363                   Target (J) := Pad;
 364                end loop;
 365
 366                Target (Tlast - Slength + 1 .. Tlast) := Source;
 367
 368             when Center =>
 369                declare
 370                   Front_Pad   : constant Integer := (Tlength - Slength) / 2;
 371                   Tfirst_Fpad : constant Integer := Tfirst + Front_Pad;
 372
 373                begin
 374                   for J in Tfirst .. Tfirst_Fpad - 1 loop
 375                      Target (J) := Pad;
 376                   end loop;
 377
 378                   Target (Tfirst_Fpad .. Tfirst_Fpad + Slength - 1) := Source;
 379
 380                   for J in Tfirst_Fpad + Slength .. Tlast loop
 381                      Target (J) := Pad;
 382                   end loop;
 383                end;
 384          end case;
 385       end if;
 386    end Move;
 387
 388    ---------------
 389    -- Overwrite --
 390    ---------------
 391
 392    function Overwrite
 393      (Source   : Wide_String;
 394       Position : Positive;
 395       New_Item : Wide_String) return Wide_String
 396    is
 397    begin
 398       if Position not in Source'First .. Source'Last + 1 then
 399          raise Index_Error;
 400       else
 401          declare
 402             Result_Length : constant Natural :=
 403                               Natural'Max
 404                                 (Source'Length,
 405                                  Position - Source'First + New_Item'Length);
 406
 407             Result : Wide_String (1 .. Result_Length);
 408
 409          begin
 410             Result := Source (Source'First .. Position - 1) & New_Item &
 411                         Source (Position + New_Item'Length .. Source'Last);
 412             return Result;
 413          end;
 414       end if;
 415    end Overwrite;
 416
 417    procedure Overwrite
 418      (Source   : in out Wide_String;
 419       Position : Positive;
 420       New_Item : Wide_String;
 421       Drop     : Truncation := Right)
 422    is
 423    begin
 424       Move (Source => Overwrite (Source, Position, New_Item),
 425             Target => Source,
 426             Drop   => Drop);
 427    end Overwrite;
 428
 429    -------------------
 430    -- Replace_Slice --
 431    -------------------
 432
 433    function Replace_Slice
 434      (Source : Wide_String;
 435       Low    : Positive;
 436       High   : Natural;
 437       By     : Wide_String) return Wide_String
 438    is
 439       Result_Length : Natural;
 440
 441    begin
 442       if Low > Source'Last + 1 or else High < Source'First - 1 then
 443          raise Index_Error;
 444       else
 445          Result_Length :=
 446            Source'Length - Natural'Max (High - Low + 1, 0) + By'Length;
 447
 448          declare
 449             Result : Wide_String (1 .. Result_Length);
 450
 451          begin
 452             if High >= Low then
 453                Result :=
 454                   Source (Source'First .. Low - 1) & By &
 455                   Source (High + 1 .. Source'Last);
 456             else
 457                Result := Source (Source'First .. Low - 1) & By &
 458                          Source (Low .. Source'Last);
 459             end if;
 460
 461             return Result;
 462          end;
 463       end if;
 464    end Replace_Slice;
 465
 466    procedure Replace_Slice
 467      (Source   : in out Wide_String;
 468       Low      : Positive;
 469       High     : Natural;
 470       By       : Wide_String;
 471       Drop     : Truncation := Error;
 472       Justify  : Alignment  := Left;
 473       Pad      : Wide_Character  := Wide_Space)
 474    is
 475    begin
 476       Move (Replace_Slice (Source, Low, High, By), Source, Drop, Justify, Pad);
 477    end Replace_Slice;
 478
 479    ----------
 480    -- Tail --
 481    ----------
 482
 483    function Tail
 484      (Source : Wide_String;
 485       Count  : Natural;
 486       Pad    : Wide_Character := Wide_Space) return Wide_String
 487    is
 488       Result : Wide_String (1 .. Count);
 489
 490    begin
 491       if Count < Source'Length then
 492          Result := Source (Source'Last - Count + 1 .. Source'Last);
 493
 494       --  Pad on left
 495
 496       else
 497          for J in 1 .. Count - Source'Length loop
 498             Result (J) := Pad;
 499          end loop;
 500
 501          Result (Count - Source'Length + 1 .. Count) := Source;
 502       end if;
 503
 504       return Result;
 505    end Tail;
 506
 507    procedure Tail
 508      (Source  : in out Wide_String;
 509       Count   : Natural;
 510       Justify : Alignment := Left;
 511       Pad     : Wide_Character := Ada.Strings.Wide_Space)
 512    is
 513    begin
 514       Move (Source  => Tail (Source, Count, Pad),
 515             Target  => Source,
 516             Drop    => Error,
 517             Justify => Justify,
 518             Pad     => Pad);
 519    end Tail;
 520
 521    ---------------
 522    -- Translate --
 523    ---------------
 524
 525    function Translate
 526      (Source  : Wide_String;
 527       Mapping : Wide_Maps.Wide_Character_Mapping) return Wide_String
 528    is
 529       Result : Wide_String (1 .. Source'Length);
 530
 531    begin
 532       for J in Source'Range loop
 533          Result (J - (Source'First - 1)) := Value (Mapping, Source (J));
 534       end loop;
 535
 536       return Result;
 537    end Translate;
 538
 539    procedure Translate
 540      (Source  : in out Wide_String;
 541       Mapping : Wide_Maps.Wide_Character_Mapping)
 542    is
 543    begin
 544       for J in Source'Range loop
 545          Source (J) := Value (Mapping, Source (J));
 546       end loop;
 547    end Translate;
 548
 549    function Translate
 550      (Source  : Wide_String;
 551       Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Wide_String
 552    is
 553       Result : Wide_String (1 .. Source'Length);
 554
 555    begin
 556       for J in Source'Range loop
 557          Result (J - (Source'First - 1)) := Mapping (Source (J));
 558       end loop;
 559
 560       return Result;
 561    end Translate;
 562
 563    procedure Translate
 564      (Source  : in out Wide_String;
 565       Mapping : Wide_Maps.Wide_Character_Mapping_Function)
 566    is
 567    begin
 568       for J in Source'Range loop
 569          Source (J) := Mapping (Source (J));
 570       end loop;
 571    end Translate;
 572
 573    ----------
 574    -- Trim --
 575    ----------
 576
 577    function Trim
 578      (Source : Wide_String;
 579       Side   : Trim_End) return Wide_String
 580    is
 581       Low  : Natural := Source'First;
 582       High : Natural := Source'Last;
 583
 584    begin
 585       if Side = Left or else Side = Both then
 586          while Low <= High and then Source (Low) = Wide_Space loop
 587             Low := Low + 1;
 588          end loop;
 589       end if;
 590
 591       if Side = Right or else Side = Both then
 592          while High >= Low and then Source (High) = Wide_Space loop
 593             High := High - 1;
 594          end loop;
 595       end if;
 596
 597       --  All blanks case
 598
 599       if Low > High then
 600          return "";
 601
 602       --  At least one non-blank
 603
 604       else
 605          declare
 606             Result : constant Wide_String (1 .. High - Low + 1) :=
 607                        Source (Low .. High);
 608
 609          begin
 610             return Result;
 611          end;
 612       end if;
 613    end Trim;
 614
 615    procedure Trim
 616      (Source  : in out Wide_String;
 617       Side    : Trim_End;
 618       Justify : Alignment      := Left;
 619       Pad     : Wide_Character := Wide_Space)
 620    is
 621    begin
 622       Move (Source  => Trim (Source, Side),
 623             Target  => Source,
 624             Justify => Justify,
 625             Pad     => Pad);
 626    end Trim;
 627
 628    function Trim
 629       (Source : Wide_String;
 630        Left   : Wide_Maps.Wide_Character_Set;
 631        Right  : Wide_Maps.Wide_Character_Set) return Wide_String
 632    is
 633       Low  : Natural := Source'First;
 634       High : Natural := Source'Last;
 635
 636    begin
 637       while Low <= High and then Is_In (Source (Low), Left) loop
 638          Low := Low + 1;
 639       end loop;
 640
 641       while High >= Low and then Is_In (Source (High), Right) loop
 642          High := High - 1;
 643       end loop;
 644
 645       --  Case where source comprises only characters in the sets
 646
 647       if Low > High then
 648          return "";
 649       else
 650          declare
 651             subtype WS is Wide_String (1 .. High - Low + 1);
 652
 653          begin
 654             return WS (Source (Low .. High));
 655          end;
 656       end if;
 657    end Trim;
 658
 659    procedure Trim
 660       (Source  : in out Wide_String;
 661        Left    : Wide_Maps.Wide_Character_Set;
 662        Right   : Wide_Maps.Wide_Character_Set;
 663        Justify : Alignment      := Strings.Left;
 664        Pad     : Wide_Character := Wide_Space)
 665    is
 666    begin
 667       Move (Source  => Trim (Source, Left, Right),
 668             Target  => Source,
 669             Justify => Justify,
 670             Pad     => Pad);
 671    end Trim;
 672
 673 end Ada.Strings.Wide_Fixed;