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