gcc/ada/a-stwiun-shared.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --           A D A . S T R I N G S . W I D E _ U N B O U N D E D            --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2010, 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_Search;
  33 with Ada.Unchecked_Deallocation;
  34
  35 package body Ada.Strings.Wide_Unbounded is
  36
  37    use Ada.Strings.Wide_Maps;
  38
  39    Growth_Factor : constant := 32;
  40    --  The growth factor controls how much extra space is allocated when
  41    --  we have to increase the size of an allocated unbounded string. By
  42    --  allocating extra space, we avoid the need to reallocate on every
  43    --  append, particularly important when a string is built up by repeated
  44    --  append operations of small pieces. This is expressed as a factor so
  45    --  32 means add 1/32 of the length of the string as growth space.
  46
  47    Min_Mul_Alloc : constant := Standard'Maximum_Alignment;
  48    --  Allocation will be done by a multiple of Min_Mul_Alloc. This causes
  49    --  no memory loss as most (all?) malloc implementations are obliged to
  50    --  align the returned memory on the maximum alignment as malloc does not
  51    --  know the target alignment.
  52
  53    procedure Sync_Add_And_Fetch
  54      (Ptr   : access Interfaces.Unsigned_32;
  55       Value : Interfaces.Unsigned_32);
  56    pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_4");
  57
  58    function Sync_Sub_And_Fetch
  59      (Ptr   : access Interfaces.Unsigned_32;
  60       Value : Interfaces.Unsigned_32) return Interfaces.Unsigned_32;
  61    pragma Import (Intrinsic, Sync_Sub_And_Fetch, "__sync_sub_and_fetch_4");
  62
  63    function Aligned_Max_Length (Max_Length : Natural) return Natural;
  64    --  Returns recommended length of the shared string which is greater or
  65    --  equal to specified length. Calculation take in sense alignment of
  66    --  the allocated memory segments to use memory effectively by
  67    --  Append/Insert/etc operations.
  68
  69    ---------
  70    -- "&" --
  71    ---------
  72
  73    function "&"
  74      (Left  : Unbounded_Wide_String;
  75       Right : Unbounded_Wide_String) return Unbounded_Wide_String
  76    is
  77       LR : constant Shared_Wide_String_Access := Left.Reference;
  78       RR : constant Shared_Wide_String_Access := Right.Reference;
  79       DL : constant Natural := LR.Last + RR.Last;
  80       DR : Shared_Wide_String_Access;
  81
  82    begin
  83       --  Result is an empty string, reuse shared empty string.
  84
  85       if DL = 0 then
  86          Reference (Empty_Shared_Wide_String'Access);
  87          DR := Empty_Shared_Wide_String'Access;
  88
  89       --  Left string is empty, return Right string.
  90
  91       elsif LR.Last = 0 then
  92          Reference (RR);
  93          DR := RR;
  94
  95       --  Right string is empty, return Left string.
  96
  97       elsif RR.Last = 0 then
  98          Reference (LR);
  99          DR := LR;
 100
 101       --  Otherwise, allocate new shared string and fill data.
 102
 103       else
 104          DR := Allocate (LR.Last + RR.Last);
 105          DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last);
 106          DR.Data (LR.Last + 1 .. DL) := RR.Data (1 .. RR.Last);
 107          DR.Last := DL;
 108       end if;
 109
 110       return (AF.Controlled with Reference => DR);
 111    end "&";
 112
 113    function "&"
 114      (Left  : Unbounded_Wide_String;
 115       Right : Wide_String) return Unbounded_Wide_String
 116    is
 117       LR : constant Shared_Wide_String_Access := Left.Reference;
 118       DL : constant Natural := LR.Last + Right'Length;
 119       DR : Shared_Wide_String_Access;
 120
 121    begin
 122       --  Result is an empty string, reuse shared empty string.
 123
 124       if DL = 0 then
 125          Reference (Empty_Shared_Wide_String'Access);
 126          DR := Empty_Shared_Wide_String'Access;
 127
 128       --  Right is an empty string, return Left string.
 129
 130       elsif Right'Length = 0 then
 131          Reference (LR);
 132          DR := LR;
 133
 134       --  Otherwise, allocate new shared string and fill it.
 135
 136       else
 137          DR := Allocate (DL);
 138          DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last);
 139          DR.Data (LR.Last + 1 .. DL) := Right;
 140          DR.Last := DL;
 141       end if;
 142
 143       return (AF.Controlled with Reference => DR);
 144    end "&";
 145
 146    function "&"
 147      (Left  : Wide_String;
 148       Right : Unbounded_Wide_String) return Unbounded_Wide_String
 149    is
 150       RR : constant Shared_Wide_String_Access := Right.Reference;
 151       DL : constant Natural := Left'Length + RR.Last;
 152       DR : Shared_Wide_String_Access;
 153
 154    begin
 155       --  Result is an empty string, reuse shared one.
 156
 157       if DL = 0 then
 158          Reference (Empty_Shared_Wide_String'Access);
 159          DR := Empty_Shared_Wide_String'Access;
 160
 161       --  Left is empty string, return Right string.
 162
 163       elsif Left'Length = 0 then
 164          Reference (RR);
 165          DR := RR;
 166
 167       --  Otherwise, allocate new shared string and fill it.
 168
 169       else
 170          DR := Allocate (DL);
 171          DR.Data (1 .. Left'Length) := Left;
 172          DR.Data (Left'Length + 1 .. DL) := RR.Data (1 .. RR.Last);
 173          DR.Last := DL;
 174       end if;
 175
 176       return (AF.Controlled with Reference => DR);
 177    end "&";
 178
 179    function "&"
 180      (Left  : Unbounded_Wide_String;
 181       Right : Wide_Character) return Unbounded_Wide_String
 182    is
 183       LR : constant Shared_Wide_String_Access := Left.Reference;
 184       DL : constant Natural := LR.Last + 1;
 185       DR : Shared_Wide_String_Access;
 186
 187    begin
 188       DR := Allocate (DL);
 189       DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last);
 190       DR.Data (DL) := Right;
 191       DR.Last := DL;
 192
 193       return (AF.Controlled with Reference => DR);
 194    end "&";
 195
 196    function "&"
 197      (Left  : Wide_Character;
 198       Right : Unbounded_Wide_String) return Unbounded_Wide_String
 199    is
 200       RR : constant Shared_Wide_String_Access := Right.Reference;
 201       DL : constant Natural := 1 + RR.Last;
 202       DR : Shared_Wide_String_Access;
 203
 204    begin
 205       DR := Allocate (DL);
 206       DR.Data (1) := Left;
 207       DR.Data (2 .. DL) := RR.Data (1 .. RR.Last);
 208       DR.Last := DL;
 209
 210       return (AF.Controlled with Reference => DR);
 211    end "&";
 212
 213    ---------
 214    -- "*" --
 215    ---------
 216
 217    function "*"
 218      (Left  : Natural;
 219       Right : Wide_Character) return Unbounded_Wide_String
 220    is
 221       DR : Shared_Wide_String_Access;
 222
 223    begin
 224       --  Result is an empty string, reuse shared empty string.
 225
 226       if Left = 0 then
 227          Reference (Empty_Shared_Wide_String'Access);
 228          DR := Empty_Shared_Wide_String'Access;
 229
 230       --  Otherwise, allocate new shared string and fill it.
 231
 232       else
 233          DR := Allocate (Left);
 234
 235          for J in 1 .. Left loop
 236             DR.Data (J) := Right;
 237          end loop;
 238
 239          DR.Last := Left;
 240       end if;
 241
 242       return (AF.Controlled with Reference => DR);
 243    end "*";
 244
 245    function "*"
 246      (Left  : Natural;
 247       Right : Wide_String) return Unbounded_Wide_String
 248    is
 249       DL : constant Natural := Left * Right'Length;
 250       DR : Shared_Wide_String_Access;
 251       K  : Positive;
 252
 253    begin
 254       --  Result is an empty string, reuse shared empty string.
 255
 256       if DL = 0 then
 257          Reference (Empty_Shared_Wide_String'Access);
 258          DR := Empty_Shared_Wide_String'Access;
 259
 260       --  Otherwise, allocate new shared string and fill it.
 261
 262       else
 263          DR := Allocate (DL);
 264          K := 1;
 265
 266          for J in 1 .. Left loop
 267             DR.Data (K .. K + Right'Length - 1) := Right;
 268             K := K + Right'Length;
 269          end loop;
 270
 271          DR.Last := DL;
 272       end if;
 273
 274       return (AF.Controlled with Reference => DR);
 275    end "*";
 276
 277    function "*"
 278      (Left  : Natural;
 279       Right : Unbounded_Wide_String) return Unbounded_Wide_String
 280    is
 281       RR : constant Shared_Wide_String_Access := Right.Reference;
 282       DL : constant Natural := Left * RR.Last;
 283       DR : Shared_Wide_String_Access;
 284       K  : Positive;
 285
 286    begin
 287       --  Result is an empty string, reuse shared empty string.
 288
 289       if DL = 0 then
 290          Reference (Empty_Shared_Wide_String'Access);
 291          DR := Empty_Shared_Wide_String'Access;
 292
 293       --  Coefficient is one, just return string itself.
 294
 295       elsif Left = 1 then
 296          Reference (RR);
 297          DR := RR;
 298
 299       --  Otherwise, allocate new shared string and fill it.
 300
 301       else
 302          DR := Allocate (DL);
 303          K := 1;
 304
 305          for J in 1 .. Left loop
 306             DR.Data (K .. K + RR.Last - 1) := RR.Data (1 .. RR.Last);
 307             K := K + RR.Last;
 308          end loop;
 309
 310          DR.Last := DL;
 311       end if;
 312
 313       return (AF.Controlled with Reference => DR);
 314    end "*";
 315
 316    ---------
 317    -- "<" --
 318    ---------
 319
 320    function "<"
 321      (Left  : Unbounded_Wide_String;
 322       Right : Unbounded_Wide_String) return Boolean
 323    is
 324       LR : constant Shared_Wide_String_Access := Left.Reference;
 325       RR : constant Shared_Wide_String_Access := Right.Reference;
 326    begin
 327       return LR.Data (1 .. LR.Last) < RR.Data (1 .. RR.Last);
 328    end "<";
 329
 330    function "<"
 331      (Left  : Unbounded_Wide_String;
 332       Right : Wide_String) return Boolean
 333    is
 334       LR : constant Shared_Wide_String_Access := Left.Reference;
 335    begin
 336       return LR.Data (1 .. LR.Last) < Right;
 337    end "<";
 338
 339    function "<"
 340      (Left  : Wide_String;
 341       Right : Unbounded_Wide_String) return Boolean
 342    is
 343       RR : constant Shared_Wide_String_Access := Right.Reference;
 344    begin
 345       return Left < RR.Data (1 .. RR.Last);
 346    end "<";
 347
 348    ----------
 349    -- "<=" --
 350    ----------
 351
 352    function "<="
 353      (Left  : Unbounded_Wide_String;
 354       Right : Unbounded_Wide_String) return Boolean
 355    is
 356       LR : constant Shared_Wide_String_Access := Left.Reference;
 357       RR : constant Shared_Wide_String_Access := Right.Reference;
 358
 359    begin
 360       --  LR = RR means two strings shares shared string, thus they are equal
 361
 362       return LR = RR or else LR.Data (1 .. LR.Last) <= RR.Data (1 .. RR.Last);
 363    end "<=";
 364
 365    function "<="
 366      (Left  : Unbounded_Wide_String;
 367       Right : Wide_String) return Boolean
 368    is
 369       LR : constant Shared_Wide_String_Access := Left.Reference;
 370    begin
 371       return LR.Data (1 .. LR.Last) <= Right;
 372    end "<=";
 373
 374    function "<="
 375      (Left  : Wide_String;
 376       Right : Unbounded_Wide_String) return Boolean
 377    is
 378       RR : constant Shared_Wide_String_Access := Right.Reference;
 379    begin
 380       return Left <= RR.Data (1 .. RR.Last);
 381    end "<=";
 382
 383    ---------
 384    -- "=" --
 385    ---------
 386
 387    function "="
 388      (Left  : Unbounded_Wide_String;
 389       Right : Unbounded_Wide_String) return Boolean
 390    is
 391       LR : constant Shared_Wide_String_Access := Left.Reference;
 392       RR : constant Shared_Wide_String_Access := Right.Reference;
 393
 394    begin
 395       return LR = RR or else LR.Data (1 .. LR.Last) = RR.Data (1 .. RR.Last);
 396       --  LR = RR means two strings shares shared string, thus they are equal.
 397    end "=";
 398
 399    function "="
 400      (Left  : Unbounded_Wide_String;
 401       Right : Wide_String) return Boolean
 402    is
 403       LR : constant Shared_Wide_String_Access := Left.Reference;
 404    begin
 405       return LR.Data (1 .. LR.Last) = Right;
 406    end "=";
 407
 408    function "="
 409      (Left  : Wide_String;
 410       Right : Unbounded_Wide_String) return Boolean
 411    is
 412       RR : constant Shared_Wide_String_Access := Right.Reference;
 413    begin
 414       return Left = RR.Data (1 .. RR.Last);
 415    end "=";
 416
 417    ---------
 418    -- ">" --
 419    ---------
 420
 421    function ">"
 422      (Left  : Unbounded_Wide_String;
 423       Right : Unbounded_Wide_String) return Boolean
 424    is
 425       LR : constant Shared_Wide_String_Access := Left.Reference;
 426       RR : constant Shared_Wide_String_Access := Right.Reference;
 427    begin
 428       return LR.Data (1 .. LR.Last) > RR.Data (1 .. RR.Last);
 429    end ">";
 430
 431    function ">"
 432      (Left  : Unbounded_Wide_String;
 433       Right : Wide_String) return Boolean
 434    is
 435       LR : constant Shared_Wide_String_Access := Left.Reference;
 436    begin
 437       return LR.Data (1 .. LR.Last) > Right;
 438    end ">";
 439
 440    function ">"
 441      (Left  : Wide_String;
 442       Right : Unbounded_Wide_String) return Boolean
 443    is
 444       RR : constant Shared_Wide_String_Access := Right.Reference;
 445    begin
 446       return Left > RR.Data (1 .. RR.Last);
 447    end ">";
 448
 449    ----------
 450    -- ">=" --
 451    ----------
 452
 453    function ">="
 454      (Left  : Unbounded_Wide_String;
 455       Right : Unbounded_Wide_String) return Boolean
 456    is
 457       LR : constant Shared_Wide_String_Access := Left.Reference;
 458       RR : constant Shared_Wide_String_Access := Right.Reference;
 459
 460    begin
 461       --  LR = RR means two strings shares shared string, thus they are equal
 462
 463       return LR = RR or else LR.Data (1 .. LR.Last) >= RR.Data (1 .. RR.Last);
 464    end ">=";
 465
 466    function ">="
 467      (Left  : Unbounded_Wide_String;
 468       Right : Wide_String) return Boolean
 469    is
 470       LR : constant Shared_Wide_String_Access := Left.Reference;
 471    begin
 472       return LR.Data (1 .. LR.Last) >= Right;
 473    end ">=";
 474
 475    function ">="
 476      (Left  : Wide_String;
 477       Right : Unbounded_Wide_String) return Boolean
 478    is
 479       RR : constant Shared_Wide_String_Access := Right.Reference;
 480    begin
 481       return Left >= RR.Data (1 .. RR.Last);
 482    end ">=";
 483
 484    ------------
 485    -- Adjust --
 486    ------------
 487
 488    procedure Adjust (Object : in out Unbounded_Wide_String) is
 489    begin
 490       Reference (Object.Reference);
 491    end Adjust;
 492
 493    ------------------------
 494    -- Aligned_Max_Length --
 495    ------------------------
 496
 497    function Aligned_Max_Length (Max_Length : Natural) return Natural is
 498       Static_Size  : constant Natural :=
 499                        Empty_Shared_Wide_String'Size / Standard'Storage_Unit;
 500       --  Total size of all static components
 501
 502       Element_Size : constant Natural :=
 503                        Wide_Character'Size / Standard'Storage_Unit;
 504
 505    begin
 506       return
 507         (((Static_Size + Max_Length * Element_Size - 1) / Min_Mul_Alloc + 2)
 508           * Min_Mul_Alloc - Static_Size) / Element_Size;
 509    end Aligned_Max_Length;
 510
 511    --------------
 512    -- Allocate --
 513    --------------
 514
 515    function Allocate (Max_Length : Natural) return Shared_Wide_String_Access is
 516    begin
 517       --  Empty string requested, return shared empty string
 518
 519       if Max_Length = 0 then
 520          Reference (Empty_Shared_Wide_String'Access);
 521          return Empty_Shared_Wide_String'Access;
 522
 523       --  Otherwise, allocate requested space (and probably some more room)
 524
 525       else
 526          return new Shared_Wide_String (Aligned_Max_Length (Max_Length));
 527       end if;
 528    end Allocate;
 529
 530    ------------
 531    -- Append --
 532    ------------
 533
 534    procedure Append
 535      (Source   : in out Unbounded_Wide_String;
 536       New_Item : Unbounded_Wide_String)
 537    is
 538       SR  : constant Shared_Wide_String_Access := Source.Reference;
 539       NR  : constant Shared_Wide_String_Access := New_Item.Reference;
 540       DL  : constant Natural                   := SR.Last + NR.Last;
 541       DR  : Shared_Wide_String_Access;
 542
 543    begin
 544       --  Source is an empty string, reuse New_Item data
 545
 546       if SR.Last = 0 then
 547          Reference (NR);
 548          Source.Reference := NR;
 549          Unreference (SR);
 550
 551       --  New_Item is empty string, nothing to do
 552
 553       elsif NR.Last = 0 then
 554          null;
 555
 556       --  Try to reuse existent shared string
 557
 558       elsif Can_Be_Reused (SR, DL) then
 559          SR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last);
 560          SR.Last := DL;
 561
 562       --  Otherwise, allocate new one and fill it
 563
 564       else
 565          DR := Allocate (DL + DL / Growth_Factor);
 566          DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
 567          DR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last);
 568          DR.Last := DL;
 569          Source.Reference := DR;
 570          Unreference (SR);
 571       end if;
 572    end Append;
 573
 574    procedure Append
 575      (Source   : in out Unbounded_Wide_String;
 576       New_Item : Wide_String)
 577    is
 578       SR : constant Shared_Wide_String_Access := Source.Reference;
 579       DL : constant Natural                   := SR.Last + New_Item'Length;
 580       DR : Shared_Wide_String_Access;
 581
 582    begin
 583       --  New_Item is an empty string, nothing to do
 584
 585       if New_Item'Length = 0 then
 586          null;
 587
 588       --  Try to reuse existing shared string
 589
 590       elsif Can_Be_Reused (SR, DL) then
 591          SR.Data (SR.Last + 1 .. DL) := New_Item;
 592          SR.Last := DL;
 593
 594       --  Otherwise, allocate new one and fill it
 595
 596       else
 597          DR := Allocate (DL + DL / Growth_Factor);
 598          DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
 599          DR.Data (SR.Last + 1 .. DL) := New_Item;
 600          DR.Last := DL;
 601          Source.Reference := DR;
 602          Unreference (SR);
 603       end if;
 604    end Append;
 605
 606    procedure Append
 607      (Source   : in out Unbounded_Wide_String;
 608       New_Item : Wide_Character)
 609    is
 610       SR : constant Shared_Wide_String_Access := Source.Reference;
 611       DL : constant Natural := SR.Last + 1;
 612       DR : Shared_Wide_String_Access;
 613
 614    begin
 615       --  Try to reuse existing shared string
 616
 617       if Can_Be_Reused (SR, SR.Last + 1) then
 618          SR.Data (SR.Last + 1) := New_Item;
 619          SR.Last := SR.Last + 1;
 620
 621       --  Otherwise, allocate new one and fill it
 622
 623       else
 624          DR := Allocate (DL + DL / Growth_Factor);
 625          DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
 626          DR.Data (DL) := New_Item;
 627          DR.Last := DL;
 628          Source.Reference := DR;
 629          Unreference (SR);
 630       end if;
 631    end Append;
 632
 633    -------------------
 634    -- Can_Be_Reused --
 635    -------------------
 636
 637    function Can_Be_Reused
 638      (Item   : Shared_Wide_String_Access;
 639       Length : Natural) return Boolean
 640    is
 641       use Interfaces;
 642    begin
 643       return
 644         Item.Counter = 1
 645           and then Item.Max_Length >= Length
 646           and then Item.Max_Length <=
 647                      Aligned_Max_Length (Length + Length / Growth_Factor);
 648    end Can_Be_Reused;
 649
 650    -----------
 651    -- Count --
 652    -----------
 653
 654    function Count
 655      (Source  : Unbounded_Wide_String;
 656       Pattern : Wide_String;
 657       Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity)
 658       return Natural
 659    is
 660       SR : constant Shared_Wide_String_Access := Source.Reference;
 661    begin
 662       return Wide_Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping);
 663    end Count;
 664
 665    function Count
 666      (Source  : Unbounded_Wide_String;
 667       Pattern : Wide_String;
 668       Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural
 669    is
 670       SR : constant Shared_Wide_String_Access := Source.Reference;
 671    begin
 672       return Wide_Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping);
 673    end Count;
 674
 675    function Count
 676      (Source : Unbounded_Wide_String;
 677       Set    : Wide_Maps.Wide_Character_Set) return Natural
 678    is
 679       SR : constant Shared_Wide_String_Access := Source.Reference;
 680    begin
 681       return Wide_Search.Count (SR.Data (1 .. SR.Last), Set);
 682    end Count;
 683
 684    ------------
 685    -- Delete --
 686    ------------
 687
 688    function Delete
 689      (Source  : Unbounded_Wide_String;
 690       From    : Positive;
 691       Through : Natural) return Unbounded_Wide_String
 692    is
 693       SR : constant Shared_Wide_String_Access := Source.Reference;
 694       DL : Natural;
 695       DR : Shared_Wide_String_Access;
 696
 697    begin
 698       --  Empty slice is deleted, use the same shared string
 699
 700       if From > Through then
 701          Reference (SR);
 702          DR := SR;
 703
 704       --  Index is out of range
 705
 706       elsif Through > SR.Last then
 707          raise Index_Error;
 708
 709       --  Compute size of the result
 710
 711       else
 712          DL := SR.Last - (Through - From + 1);
 713
 714          --  Result is an empty string, reuse shared empty string
 715
 716          if DL = 0 then
 717             Reference (Empty_Shared_Wide_String'Access);
 718             DR := Empty_Shared_Wide_String'Access;
 719
 720          --  Otherwise, allocate new shared string and fill it
 721
 722          else
 723             DR := Allocate (DL);
 724             DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1);
 725             DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last);
 726             DR.Last := DL;
 727          end if;
 728       end if;
 729
 730       return (AF.Controlled with Reference => DR);
 731    end Delete;
 732
 733    procedure Delete
 734      (Source  : in out Unbounded_Wide_String;
 735       From    : Positive;
 736       Through : Natural)
 737    is
 738       SR : constant Shared_Wide_String_Access := Source.Reference;
 739       DL : Natural;
 740       DR : Shared_Wide_String_Access;
 741
 742    begin
 743       --  Nothing changed, return
 744
 745       if From > Through then
 746          null;
 747
 748       --  Through is outside of the range
 749
 750       elsif Through > SR.Last then
 751          raise Index_Error;
 752
 753       else
 754          DL := SR.Last - (Through - From + 1);
 755
 756          --  Result is empty, reuse shared empty string
 757
 758          if DL = 0 then
 759             Reference (Empty_Shared_Wide_String'Access);
 760             Source.Reference := Empty_Shared_Wide_String'Access;
 761             Unreference (SR);
 762
 763          --  Try to reuse existent shared string
 764
 765          elsif Can_Be_Reused (SR, DL) then
 766             SR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last);
 767             SR.Last := DL;
 768
 769          --  Otherwise, allocate new shared string
 770
 771          else
 772             DR := Allocate (DL);
 773             DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1);
 774             DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last);
 775             DR.Last := DL;
 776             Source.Reference := DR;
 777             Unreference (SR);
 778          end if;
 779       end if;
 780    end Delete;
 781
 782    -------------
 783    -- Element --
 784    -------------
 785
 786    function Element
 787      (Source : Unbounded_Wide_String;
 788       Index  : Positive) return Wide_Character
 789    is
 790       SR : constant Shared_Wide_String_Access := Source.Reference;
 791    begin
 792       if Index <= SR.Last then
 793          return SR.Data (Index);
 794       else
 795          raise Index_Error;
 796       end if;
 797    end Element;
 798
 799    --------------
 800    -- Finalize --
 801    --------------
 802
 803    procedure Finalize (Object : in out Unbounded_Wide_String) is
 804       SR : constant Shared_Wide_String_Access := Object.Reference;
 805
 806    begin
 807       if SR /= null then
 808
 809          --  The same controlled object can be finalized several times for
 810          --  some reason. As per 7.6.1(24) this should have no ill effect,
 811          --  so we need to add a guard for the case of finalizing the same
 812          --  object twice.
 813
 814          Object.Reference := null;
 815          Unreference (SR);
 816       end if;
 817    end Finalize;
 818
 819    ----------------
 820    -- Find_Token --
 821    ----------------
 822
 823    procedure Find_Token
 824      (Source : Unbounded_Wide_String;
 825       Set    : Wide_Maps.Wide_Character_Set;
 826       From   : Positive;
 827       Test   : Strings.Membership;
 828       First  : out Positive;
 829       Last   : out Natural)
 830    is
 831       SR : constant Shared_Wide_String_Access := Source.Reference;
 832    begin
 833       Wide_Search.Find_Token
 834         (SR.Data (From .. SR.Last), Set, Test, First, Last);
 835    end Find_Token;
 836
 837    procedure Find_Token
 838      (Source : Unbounded_Wide_String;
 839       Set    : Wide_Maps.Wide_Character_Set;
 840       Test   : Strings.Membership;
 841       First  : out Positive;
 842       Last   : out Natural)
 843    is
 844       SR : constant Shared_Wide_String_Access := Source.Reference;
 845    begin
 846       Wide_Search.Find_Token
 847         (SR.Data (1 .. SR.Last), Set, Test, First, Last);
 848    end Find_Token;
 849
 850    ----------
 851    -- Free --
 852    ----------
 853
 854    procedure Free (X : in out Wide_String_Access) is
 855       procedure Deallocate is
 856          new Ada.Unchecked_Deallocation (Wide_String, Wide_String_Access);
 857    begin
 858       Deallocate (X);
 859    end Free;
 860
 861    ----------
 862    -- Head --
 863    ----------
 864
 865    function Head
 866      (Source : Unbounded_Wide_String;
 867       Count  : Natural;
 868       Pad    : Wide_Character := Wide_Space) return Unbounded_Wide_String
 869    is
 870       SR : constant Shared_Wide_String_Access := Source.Reference;
 871       DR : Shared_Wide_String_Access;
 872
 873    begin
 874       --  Result is empty, reuse shared empty string
 875
 876       if Count = 0 then
 877          Reference (Empty_Shared_Wide_String'Access);
 878          DR := Empty_Shared_Wide_String'Access;
 879
 880       --  Length of the string is the same as requested, reuse source shared
 881       --  string.
 882
 883       elsif Count = SR.Last then
 884          Reference (SR);
 885          DR := SR;
 886
 887       --  Otherwise, allocate new shared string and fill it
 888
 889       else
 890          DR := Allocate (Count);
 891
 892          --  Length of the source string is more than requested, copy
 893          --  corresponding slice.
 894
 895          if Count < SR.Last then
 896             DR.Data (1 .. Count) := SR.Data (1 .. Count);
 897
 898          --  Length of the source string is less then requested, copy all
 899          --  contents and fill others by Pad character.
 900
 901          else
 902             DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
 903
 904             for J in SR.Last + 1 .. Count loop
 905                DR.Data (J) := Pad;
 906             end loop;
 907          end if;
 908
 909          DR.Last := Count;
 910       end if;
 911
 912       return (AF.Controlled with Reference => DR);
 913    end Head;
 914
 915    procedure Head
 916      (Source : in out Unbounded_Wide_String;
 917       Count  : Natural;
 918       Pad    : Wide_Character := Wide_Space)
 919    is
 920       SR : constant Shared_Wide_String_Access := Source.Reference;
 921       DR : Shared_Wide_String_Access;
 922
 923    begin
 924       --  Result is empty, reuse empty shared string
 925
 926       if Count = 0 then
 927          Reference (Empty_Shared_Wide_String'Access);
 928          Source.Reference := Empty_Shared_Wide_String'Access;
 929          Unreference (SR);
 930
 931       --  Result is same with source string, reuse source shared string
 932
 933       elsif Count = SR.Last then
 934          null;
 935
 936       --  Try to reuse existent shared string
 937
 938       elsif Can_Be_Reused (SR, Count) then
 939          if Count > SR.Last then
 940             for J in SR.Last + 1 .. Count loop
 941                SR.Data (J) := Pad;
 942             end loop;
 943          end if;
 944
 945          SR.Last := Count;
 946
 947       --  Otherwise, allocate new shared string and fill it
 948
 949       else
 950          DR := Allocate (Count);
 951
 952          --  Length of the source string is greater then requested, copy
 953          --  corresponding slice.
 954
 955          if Count < SR.Last then
 956             DR.Data (1 .. Count) := SR.Data (1 .. Count);
 957
 958          --  Length of the source string is less the requested, copy all
 959          --  exists data and fill others by Pad character.
 960
 961          else
 962             DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
 963
 964             for J in SR.Last + 1 .. Count loop
 965                DR.Data (J) := Pad;
 966             end loop;
 967          end if;
 968
 969          DR.Last := Count;
 970          Source.Reference := DR;
 971          Unreference (SR);
 972       end if;
 973    end Head;
 974
 975    -----------
 976    -- Index --
 977    -----------
 978
 979    function Index
 980      (Source  : Unbounded_Wide_String;
 981       Pattern : Wide_String;
 982       Going   : Strings.Direction := Strings.Forward;
 983       Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity)
 984       return Natural
 985    is
 986       SR : constant Shared_Wide_String_Access := Source.Reference;
 987    begin
 988       return Wide_Search.Index
 989         (SR.Data (1 .. SR.Last), Pattern, Going, Mapping);
 990    end Index;
 991
 992    function Index
 993      (Source  : Unbounded_Wide_String;
 994       Pattern : Wide_String;
 995       Going   : Direction := Forward;
 996       Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural
 997    is
 998       SR : constant Shared_Wide_String_Access := Source.Reference;
 999    begin
1000       return Wide_Search.Index
1001         (SR.Data (1 .. SR.Last), Pattern, Going, Mapping);
1002    end Index;
1003
1004    function Index
1005      (Source : Unbounded_Wide_String;
1006       Set    : Wide_Maps.Wide_Character_Set;
1007       Test   : Strings.Membership := Strings.Inside;
1008       Going  : Strings.Direction  := Strings.Forward) return Natural
1009    is
1010       SR : constant Shared_Wide_String_Access := Source.Reference;
1011    begin
1012       return Wide_Search.Index (SR.Data (1 .. SR.Last), Set, Test, Going);
1013    end Index;
1014
1015    function Index
1016      (Source  : Unbounded_Wide_String;
1017       Pattern : Wide_String;
1018       From    : Positive;
1019       Going   : Direction := Forward;
1020       Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity)
1021       return Natural
1022    is
1023       SR : constant Shared_Wide_String_Access := Source.Reference;
1024    begin
1025       return Wide_Search.Index
1026         (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping);
1027    end Index;
1028
1029    function Index
1030      (Source  : Unbounded_Wide_String;
1031       Pattern : Wide_String;
1032       From    : Positive;
1033       Going   : Direction := Forward;
1034       Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural
1035    is
1036       SR : constant Shared_Wide_String_Access := Source.Reference;
1037    begin
1038       return Wide_Search.Index
1039         (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping);
1040    end Index;
1041
1042    function Index
1043      (Source  : Unbounded_Wide_String;
1044       Set     : Wide_Maps.Wide_Character_Set;
1045       From    : Positive;
1046       Test    : Membership := Inside;
1047       Going   : Direction := Forward) return Natural
1048    is
1049       SR : constant Shared_Wide_String_Access := Source.Reference;
1050    begin
1051       return Wide_Search.Index
1052         (SR.Data (1 .. SR.Last), Set, From, Test, Going);
1053    end Index;
1054
1055    ---------------------
1056    -- Index_Non_Blank --
1057    ---------------------
1058
1059    function Index_Non_Blank
1060      (Source : Unbounded_Wide_String;
1061       Going  : Strings.Direction := Strings.Forward) return Natural
1062    is
1063       SR : constant Shared_Wide_String_Access := Source.Reference;
1064    begin
1065       return Wide_Search.Index_Non_Blank (SR.Data (1 .. SR.Last), Going);
1066    end Index_Non_Blank;
1067
1068    function Index_Non_Blank
1069      (Source : Unbounded_Wide_String;
1070       From   : Positive;
1071       Going  : Direction := Forward) return Natural
1072    is
1073       SR : constant Shared_Wide_String_Access := Source.Reference;
1074    begin
1075       return Wide_Search.Index_Non_Blank
1076         (SR.Data (1 .. SR.Last), From, Going);
1077    end Index_Non_Blank;
1078
1079    ----------------
1080    -- Initialize --
1081    ----------------
1082
1083    procedure Initialize (Object : in out Unbounded_Wide_String) is
1084    begin
1085       Reference (Object.Reference);
1086    end Initialize;
1087
1088    ------------
1089    -- Insert --
1090    ------------
1091
1092    function Insert
1093      (Source   : Unbounded_Wide_String;
1094       Before   : Positive;
1095       New_Item : Wide_String) return Unbounded_Wide_String
1096    is
1097       SR : constant Shared_Wide_String_Access := Source.Reference;
1098       DL : constant Natural := SR.Last + New_Item'Length;
1099       DR : Shared_Wide_String_Access;
1100
1101    begin
1102       --  Check index first
1103
1104       if Before > SR.Last + 1 then
1105          raise Index_Error;
1106       end if;
1107
1108       --  Result is empty, reuse empty shared string
1109
1110       if DL = 0 then
1111          Reference (Empty_Shared_Wide_String'Access);
1112          DR := Empty_Shared_Wide_String'Access;
1113
1114       --  Inserted string is empty, reuse source shared string
1115
1116       elsif New_Item'Length = 0 then
1117          Reference (SR);
1118          DR := SR;
1119
1120       --  Otherwise, allocate new shared string and fill it
1121
1122       else
1123          DR := Allocate (DL + DL / Growth_Factor);
1124          DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1);
1125          DR.Data (Before .. Before + New_Item'Length - 1) := New_Item;
1126          DR.Data (Before + New_Item'Length .. DL) :=
1127            SR.Data (Before .. SR.Last);
1128          DR.Last := DL;
1129       end if;
1130
1131       return (AF.Controlled with Reference => DR);
1132    end Insert;
1133
1134    procedure Insert
1135      (Source   : in out Unbounded_Wide_String;
1136       Before   : Positive;
1137       New_Item : Wide_String)
1138    is
1139       SR : constant Shared_Wide_String_Access := Source.Reference;
1140       DL : constant Natural                   := SR.Last + New_Item'Length;
1141       DR : Shared_Wide_String_Access;
1142
1143    begin
1144       --  Check bounds
1145
1146       if Before > SR.Last + 1 then
1147          raise Index_Error;
1148       end if;
1149
1150       --  Result is empty string, reuse empty shared string
1151
1152       if DL = 0 then
1153          Reference (Empty_Shared_Wide_String'Access);
1154          Source.Reference := Empty_Shared_Wide_String'Access;
1155          Unreference (SR);
1156
1157       --  Inserted string is empty, nothing to do
1158
1159       elsif New_Item'Length = 0 then
1160          null;
1161
1162       --  Try to reuse existent shared string first
1163
1164       elsif Can_Be_Reused (SR, DL) then
1165          SR.Data (Before + New_Item'Length .. DL) :=
1166            SR.Data (Before .. SR.Last);
1167          SR.Data (Before .. Before + New_Item'Length - 1) := New_Item;
1168          SR.Last := DL;
1169
1170       --  Otherwise, allocate new shared string and fill it
1171
1172       else
1173          DR := Allocate (DL + DL / Growth_Factor);
1174          DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1);
1175          DR.Data (Before .. Before + New_Item'Length - 1) := New_Item;
1176          DR.Data (Before + New_Item'Length .. DL) :=
1177            SR.Data (Before .. SR.Last);
1178          DR.Last := DL;
1179          Source.Reference := DR;
1180          Unreference (SR);
1181       end if;
1182    end Insert;
1183
1184    ------------
1185    -- Length --
1186    ------------
1187
1188    function Length (Source : Unbounded_Wide_String) return Natural is
1189    begin
1190       return Source.Reference.Last;
1191    end Length;
1192
1193    ---------------
1194    -- Overwrite --
1195    ---------------
1196
1197    function Overwrite
1198      (Source   : Unbounded_Wide_String;
1199       Position : Positive;
1200       New_Item : Wide_String) return Unbounded_Wide_String
1201    is
1202       SR : constant Shared_Wide_String_Access := Source.Reference;
1203       DL : Natural;
1204       DR : Shared_Wide_String_Access;
1205
1206    begin
1207       --  Check bounds
1208
1209       if Position > SR.Last + 1 then
1210          raise Index_Error;
1211       end if;
1212
1213       DL := Integer'Max (SR.Last, Position + New_Item'Length - 1);
1214
1215       --  Result is empty string, reuse empty shared string
1216
1217       if DL = 0 then
1218          Reference (Empty_Shared_Wide_String'Access);
1219          DR := Empty_Shared_Wide_String'Access;
1220
1221       --  Result is same with source string, reuse source shared string
1222
1223       elsif New_Item'Length = 0 then
1224          Reference (SR);
1225          DR := SR;
1226
1227       --  Otherwise, allocate new shared string and fill it
1228
1229       else
1230          DR := Allocate (DL);
1231          DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1);
1232          DR.Data (Position .. Position + New_Item'Length - 1) := New_Item;
1233          DR.Data (Position + New_Item'Length .. DL) :=
1234            SR.Data (Position + New_Item'Length .. SR.Last);
1235          DR.Last := DL;
1236       end if;
1237
1238       return (AF.Controlled with Reference => DR);
1239    end Overwrite;
1240
1241    procedure Overwrite
1242      (Source    : in out Unbounded_Wide_String;
1243       Position  : Positive;
1244       New_Item  : Wide_String)
1245    is
1246       SR : constant Shared_Wide_String_Access := Source.Reference;
1247       DL : Natural;
1248       DR : Shared_Wide_String_Access;
1249
1250    begin
1251       --  Bounds check
1252
1253       if Position > SR.Last + 1 then
1254          raise Index_Error;
1255       end if;
1256
1257       DL := Integer'Max (SR.Last, Position + New_Item'Length - 1);
1258
1259       --  Result is empty string, reuse empty shared string
1260
1261       if DL = 0 then
1262          Reference (Empty_Shared_Wide_String'Access);
1263          Source.Reference := Empty_Shared_Wide_String'Access;
1264          Unreference (SR);
1265
1266       --  String unchanged, nothing to do
1267
1268       elsif New_Item'Length = 0 then
1269          null;
1270
1271       --  Try to reuse existent shared string
1272
1273       elsif Can_Be_Reused (SR, DL) then
1274          SR.Data (Position .. Position + New_Item'Length - 1) := New_Item;
1275          SR.Last := DL;
1276
1277       --  Otherwise allocate new shared string and fill it
1278
1279       else
1280          DR := Allocate (DL);
1281          DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1);
1282          DR.Data (Position .. Position + New_Item'Length - 1) := New_Item;
1283          DR.Data (Position + New_Item'Length .. DL) :=
1284            SR.Data (Position + New_Item'Length .. SR.Last);
1285          DR.Last := DL;
1286          Source.Reference := DR;
1287          Unreference (SR);
1288       end if;
1289    end Overwrite;
1290
1291    ---------------
1292    -- Reference --
1293    ---------------
1294
1295    procedure Reference (Item : not null Shared_Wide_String_Access) is
1296    begin
1297       Sync_Add_And_Fetch (Item.Counter'Access, 1);
1298    end Reference;
1299
1300    ---------------------
1301    -- Replace_Element --
1302    ---------------------
1303
1304    procedure Replace_Element
1305      (Source : in out Unbounded_Wide_String;
1306       Index  : Positive;
1307       By     : Wide_Character)
1308    is
1309       SR : constant Shared_Wide_String_Access := Source.Reference;
1310       DR : Shared_Wide_String_Access;
1311
1312    begin
1313       --  Bounds check.
1314
1315       if Index <= SR.Last then
1316
1317          --  Try to reuse existent shared string
1318
1319          if Can_Be_Reused (SR, SR.Last) then
1320             SR.Data (Index) := By;
1321
1322          --  Otherwise allocate new shared string and fill it
1323
1324          else
1325             DR := Allocate (SR.Last);
1326             DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
1327             DR.Data (Index) := By;
1328             DR.Last := SR.Last;
1329             Source.Reference := DR;
1330             Unreference (SR);
1331          end if;
1332
1333       else
1334          raise Index_Error;
1335       end if;
1336    end Replace_Element;
1337
1338    -------------------
1339    -- Replace_Slice --
1340    -------------------
1341
1342    function Replace_Slice
1343      (Source : Unbounded_Wide_String;
1344       Low    : Positive;
1345       High   : Natural;
1346       By     : Wide_String) return Unbounded_Wide_String
1347    is
1348       SR : constant Shared_Wide_String_Access := Source.Reference;
1349       DL : Natural;
1350       DR : Shared_Wide_String_Access;
1351
1352    begin
1353       --  Check bounds
1354
1355       if Low > SR.Last + 1 then
1356          raise Index_Error;
1357       end if;
1358
1359       --  Do replace operation when removed slice is not empty
1360
1361       if High >= Low then
1362          DL := By'Length + SR.Last + Low - High - 1;
1363
1364          --  Result is empty string, reuse empty shared string
1365
1366          if DL = 0 then
1367             Reference (Empty_Shared_Wide_String'Access);
1368             DR := Empty_Shared_Wide_String'Access;
1369
1370          --  Otherwise allocate new shared string and fill it
1371
1372          else
1373             DR := Allocate (DL);
1374             DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1);
1375             DR.Data (Low .. Low + By'Length - 1) := By;
1376             DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last);
1377             DR.Last := DL;
1378          end if;
1379
1380          return (AF.Controlled with Reference => DR);
1381
1382       --  Otherwise just insert string
1383
1384       else
1385          return Insert (Source, Low, By);
1386       end if;
1387    end Replace_Slice;
1388
1389    procedure Replace_Slice
1390      (Source : in out Unbounded_Wide_String;
1391       Low    : Positive;
1392       High   : Natural;
1393       By     : Wide_String)
1394    is
1395       SR : constant Shared_Wide_String_Access := Source.Reference;
1396       DL : Natural;
1397       DR : Shared_Wide_String_Access;
1398
1399    begin
1400       --  Bounds check
1401
1402       if Low > SR.Last + 1 then
1403          raise Index_Error;
1404       end if;
1405
1406       --  Do replace operation only when replaced slice is not empty
1407
1408       if High >= Low then
1409          DL := By'Length + SR.Last + Low - High - 1;
1410
1411          --  Result is empty string, reuse empty shared string
1412
1413          if DL = 0 then
1414             Reference (Empty_Shared_Wide_String'Access);
1415             Source.Reference := Empty_Shared_Wide_String'Access;
1416             Unreference (SR);
1417
1418          --  Try to reuse existent shared string
1419
1420          elsif Can_Be_Reused (SR, DL) then
1421             SR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last);
1422             SR.Data (Low .. Low + By'Length - 1) := By;
1423             SR.Last := DL;
1424
1425          --  Otherwise allocate new shared string and fill it
1426
1427          else
1428             DR := Allocate (DL);
1429             DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1);
1430             DR.Data (Low .. Low + By'Length - 1) := By;
1431             DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last);
1432             DR.Last := DL;
1433             Source.Reference := DR;
1434             Unreference (SR);
1435          end if;
1436
1437       --  Otherwise just insert item
1438
1439       else
1440          Insert (Source, Low, By);
1441       end if;
1442    end Replace_Slice;
1443
1444    -------------------------------
1445    -- Set_Unbounded_Wide_String --
1446    -------------------------------
1447
1448    procedure Set_Unbounded_Wide_String
1449      (Target : out Unbounded_Wide_String;
1450       Source : Wide_String)
1451    is
1452       TR : constant Shared_Wide_String_Access := Target.Reference;
1453       DR : Shared_Wide_String_Access;
1454
1455    begin
1456       --  In case of empty string, reuse empty shared string
1457
1458       if Source'Length = 0 then
1459          Reference (Empty_Shared_Wide_String'Access);
1460          Target.Reference := Empty_Shared_Wide_String'Access;
1461
1462       else
1463          --  Try to reuse existent shared string
1464
1465          if Can_Be_Reused (TR, Source'Length) then
1466             Reference (TR);
1467             DR := TR;
1468
1469          --  Otherwise allocate new shared string
1470
1471          else
1472             DR := Allocate (Source'Length);
1473             Target.Reference := DR;
1474          end if;
1475
1476          DR.Data (1 .. Source'Length) := Source;
1477          DR.Last := Source'Length;
1478       end if;
1479
1480       Unreference (TR);
1481    end Set_Unbounded_Wide_String;
1482
1483    -----------
1484    -- Slice --
1485    -----------
1486
1487    function Slice
1488      (Source : Unbounded_Wide_String;
1489       Low    : Positive;
1490       High   : Natural) return Wide_String
1491    is
1492       SR : constant Shared_Wide_String_Access := Source.Reference;
1493
1494    begin
1495       --  Note: test of High > Length is in accordance with AI95-00128
1496
1497       if Low > SR.Last + 1 or else High > SR.Last then
1498          raise Index_Error;
1499
1500       else
1501          return SR.Data (Low .. High);
1502       end if;
1503    end Slice;
1504
1505    ----------
1506    -- Tail --
1507    ----------
1508
1509    function Tail
1510      (Source : Unbounded_Wide_String;
1511       Count  : Natural;
1512       Pad    : Wide_Character := Wide_Space) return Unbounded_Wide_String
1513    is
1514       SR : constant Shared_Wide_String_Access := Source.Reference;
1515       DR : Shared_Wide_String_Access;
1516
1517    begin
1518       --  For empty result reuse empty shared string
1519
1520       if Count = 0 then
1521          Reference (Empty_Shared_Wide_String'Access);
1522          DR := Empty_Shared_Wide_String'Access;
1523
1524       --  Result is hole source string, reuse source shared string
1525
1526       elsif Count = SR.Last then
1527          Reference (SR);
1528          DR := SR;
1529
1530       --  Otherwise allocate new shared string and fill it
1531
1532       else
1533          DR := Allocate (Count);
1534
1535          if Count < SR.Last then
1536             DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last);
1537
1538          else
1539             for J in 1 .. Count - SR.Last loop
1540                DR.Data (J) := Pad;
1541             end loop;
1542
1543             DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last);
1544          end if;
1545
1546          DR.Last := Count;
1547       end if;
1548
1549       return (AF.Controlled with Reference => DR);
1550    end Tail;
1551
1552    procedure Tail
1553      (Source : in out Unbounded_Wide_String;
1554       Count  : Natural;
1555       Pad    : Wide_Character := Wide_Space)
1556    is
1557       SR : constant Shared_Wide_String_Access := Source.Reference;
1558       DR : Shared_Wide_String_Access;
1559
1560       procedure Common
1561         (SR    : Shared_Wide_String_Access;
1562          DR    : Shared_Wide_String_Access;
1563          Count : Natural);
1564       --  Common code of tail computation. SR/DR can point to the same object
1565
1566       ------------
1567       -- Common --
1568       ------------
1569
1570       procedure Common
1571         (SR    : Shared_Wide_String_Access;
1572          DR    : Shared_Wide_String_Access;
1573          Count : Natural) is
1574       begin
1575          if Count < SR.Last then
1576             DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last);
1577
1578          else
1579             DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last);
1580
1581             for J in 1 .. Count - SR.Last loop
1582                DR.Data (J) := Pad;
1583             end loop;
1584          end if;
1585
1586          DR.Last := Count;
1587       end Common;
1588
1589    begin
1590       --  Result is empty string, reuse empty shared string
1591
1592       if Count = 0 then
1593          Reference (Empty_Shared_Wide_String'Access);
1594          Source.Reference := Empty_Shared_Wide_String'Access;
1595          Unreference (SR);
1596
1597       --  Length of the result is the same with length of the source string,
1598       --  reuse source shared string.
1599
1600       elsif Count = SR.Last then
1601          null;
1602
1603       --  Try to reuse existent shared string
1604
1605       elsif Can_Be_Reused (SR, Count) then
1606          Common (SR, SR, Count);
1607
1608       --  Otherwise allocate new shared string and fill it
1609
1610       else
1611          DR := Allocate (Count);
1612          Common (SR, DR, Count);
1613          Source.Reference := DR;
1614          Unreference (SR);
1615       end if;
1616    end Tail;
1617
1618    --------------------
1619    -- To_Wide_String --
1620    --------------------
1621
1622    function To_Wide_String
1623      (Source : Unbounded_Wide_String) return Wide_String is
1624    begin
1625       return Source.Reference.Data (1 .. Source.Reference.Last);
1626    end To_Wide_String;
1627
1628    ------------------------------
1629    -- To_Unbounded_Wide_String --
1630    ------------------------------
1631
1632    function To_Unbounded_Wide_String
1633      (Source : Wide_String) return Unbounded_Wide_String
1634    is
1635       DR : constant Shared_Wide_String_Access := Allocate (Source'Length);
1636    begin
1637       DR.Data (1 .. Source'Length) := Source;
1638       DR.Last := Source'Length;
1639       return (AF.Controlled with Reference => DR);
1640    end To_Unbounded_Wide_String;
1641
1642    function To_Unbounded_Wide_String
1643      (Length : Natural) return Unbounded_Wide_String
1644    is
1645       DR : constant Shared_Wide_String_Access := Allocate (Length);
1646    begin
1647       DR.Last := Length;
1648       return (AF.Controlled with Reference => DR);
1649    end To_Unbounded_Wide_String;
1650
1651    ---------------
1652    -- Translate --
1653    ---------------
1654
1655    function Translate
1656      (Source  : Unbounded_Wide_String;
1657       Mapping : Wide_Maps.Wide_Character_Mapping) return Unbounded_Wide_String
1658    is
1659       SR : constant Shared_Wide_String_Access := Source.Reference;
1660       DR : Shared_Wide_String_Access;
1661
1662    begin
1663       --  Nothing to translate, reuse empty shared string
1664
1665       if SR.Last = 0 then
1666          Reference (Empty_Shared_Wide_String'Access);
1667          DR := Empty_Shared_Wide_String'Access;
1668
1669       --  Otherwise, allocate new shared string and fill it
1670
1671       else
1672          DR := Allocate (SR.Last);
1673
1674          for J in 1 .. SR.Last loop
1675             DR.Data (J) := Value (Mapping, SR.Data (J));
1676          end loop;
1677
1678          DR.Last := SR.Last;
1679       end if;
1680
1681       return (AF.Controlled with Reference => DR);
1682    end Translate;
1683
1684    procedure Translate
1685      (Source  : in out Unbounded_Wide_String;
1686       Mapping : Wide_Maps.Wide_Character_Mapping)
1687    is
1688       SR : constant Shared_Wide_String_Access := Source.Reference;
1689       DR : Shared_Wide_String_Access;
1690
1691    begin
1692       --  Nothing to translate
1693
1694       if SR.Last = 0 then
1695          null;
1696
1697       --  Try to reuse shared string
1698
1699       elsif Can_Be_Reused (SR, SR.Last) then
1700          for J in 1 .. SR.Last loop
1701             SR.Data (J) := Value (Mapping, SR.Data (J));
1702          end loop;
1703
1704       --  Otherwise, allocate new shared string
1705
1706       else
1707          DR := Allocate (SR.Last);
1708
1709          for J in 1 .. SR.Last loop
1710             DR.Data (J) := Value (Mapping, SR.Data (J));
1711          end loop;
1712
1713          DR.Last := SR.Last;
1714          Source.Reference := DR;
1715          Unreference (SR);
1716       end if;
1717    end Translate;
1718
1719    function Translate
1720      (Source  : Unbounded_Wide_String;
1721       Mapping : Wide_Maps.Wide_Character_Mapping_Function)
1722       return Unbounded_Wide_String
1723    is
1724       SR : constant Shared_Wide_String_Access := Source.Reference;
1725       DR : Shared_Wide_String_Access;
1726
1727    begin
1728       --  Nothing to translate, reuse empty shared string
1729
1730       if SR.Last = 0 then
1731          Reference (Empty_Shared_Wide_String'Access);
1732          DR := Empty_Shared_Wide_String'Access;
1733
1734       --  Otherwise, allocate new shared string and fill it
1735
1736       else
1737          DR := Allocate (SR.Last);
1738
1739          for J in 1 .. SR.Last loop
1740             DR.Data (J) := Mapping.all (SR.Data (J));
1741          end loop;
1742
1743          DR.Last := SR.Last;
1744       end if;
1745
1746       return (AF.Controlled with Reference => DR);
1747
1748    exception
1749       when others =>
1750          Unreference (DR);
1751
1752          raise;
1753    end Translate;
1754
1755    procedure Translate
1756      (Source  : in out Unbounded_Wide_String;
1757       Mapping : Wide_Maps.Wide_Character_Mapping_Function)
1758    is
1759       SR : constant Shared_Wide_String_Access := Source.Reference;
1760       DR : Shared_Wide_String_Access;
1761
1762    begin
1763       --  Nothing to translate
1764
1765       if SR.Last = 0 then
1766          null;
1767
1768       --  Try to reuse shared string
1769
1770       elsif Can_Be_Reused (SR, SR.Last) then
1771          for J in 1 .. SR.Last loop
1772             SR.Data (J) := Mapping.all (SR.Data (J));
1773          end loop;
1774
1775       --  Otherwise allocate new shared string and fill it
1776
1777       else
1778          DR := Allocate (SR.Last);
1779
1780          for J in 1 .. SR.Last loop
1781             DR.Data (J) := Mapping.all (SR.Data (J));
1782          end loop;
1783
1784          DR.Last := SR.Last;
1785          Source.Reference := DR;
1786          Unreference (SR);
1787       end if;
1788
1789    exception
1790       when others =>
1791          if DR /= null then
1792             Unreference (DR);
1793          end if;
1794
1795          raise;
1796    end Translate;
1797
1798    ----------
1799    -- Trim --
1800    ----------
1801
1802    function Trim
1803      (Source : Unbounded_Wide_String;
1804       Side   : Trim_End) return Unbounded_Wide_String
1805    is
1806       SR   : constant Shared_Wide_String_Access := Source.Reference;
1807       DL   : Natural;
1808       DR   : Shared_Wide_String_Access;
1809       Low  : Natural;
1810       High : Natural;
1811
1812    begin
1813       Low := Index_Non_Blank (Source, Forward);
1814
1815       --  All blanks, reuse empty shared string
1816
1817       if Low = 0 then
1818          Reference (Empty_Shared_Wide_String'Access);
1819          DR := Empty_Shared_Wide_String'Access;
1820
1821       else
1822          case Side is
1823             when Left =>
1824                High := SR.Last;
1825                DL   := SR.Last - Low + 1;
1826
1827             when Right =>
1828                Low  := 1;
1829                High := Index_Non_Blank (Source, Backward);
1830                DL   := High;
1831
1832             when Both =>
1833                High := Index_Non_Blank (Source, Backward);
1834                DL   := High - Low + 1;
1835          end case;
1836
1837          --  Length of the result is the same as length of the source string,
1838          --  reuse source shared string.
1839
1840          if DL = SR.Last then
1841             Reference (SR);
1842             DR := SR;
1843
1844          --  Otherwise, allocate new shared string
1845
1846          else
1847             DR := Allocate (DL);
1848             DR.Data (1 .. DL) := SR.Data (Low .. High);
1849             DR.Last := DL;
1850          end if;
1851       end if;
1852
1853       return (AF.Controlled with Reference => DR);
1854    end Trim;
1855
1856    procedure Trim
1857      (Source : in out Unbounded_Wide_String;
1858       Side   : Trim_End)
1859    is
1860       SR   : constant Shared_Wide_String_Access := Source.Reference;
1861       DL   : Natural;
1862       DR   : Shared_Wide_String_Access;
1863       Low  : Natural;
1864       High : Natural;
1865
1866    begin
1867       Low := Index_Non_Blank (Source, Forward);
1868
1869       --  All blanks, reuse empty shared string
1870
1871       if Low = 0 then
1872          Reference (Empty_Shared_Wide_String'Access);
1873          Source.Reference := Empty_Shared_Wide_String'Access;
1874          Unreference (SR);
1875
1876       else
1877          case Side is
1878             when Left =>
1879                High := SR.Last;
1880                DL   := SR.Last - Low + 1;
1881
1882             when Right =>
1883                Low  := 1;
1884                High := Index_Non_Blank (Source, Backward);
1885                DL   := High;
1886
1887             when Both =>
1888                High := Index_Non_Blank (Source, Backward);
1889                DL   := High - Low + 1;
1890          end case;
1891
1892          --  Length of the result is the same as length of the source string,
1893          --  nothing to do.
1894
1895          if DL = SR.Last then
1896             null;
1897
1898          --  Try to reuse existent shared string
1899
1900          elsif Can_Be_Reused (SR, DL) then
1901             SR.Data (1 .. DL) := SR.Data (Low .. High);
1902             SR.Last := DL;
1903
1904          --  Otherwise, allocate new shared string
1905
1906          else
1907             DR := Allocate (DL);
1908             DR.Data (1 .. DL) := SR.Data (Low .. High);
1909             DR.Last := DL;
1910             Source.Reference := DR;
1911             Unreference (SR);
1912          end if;
1913       end if;
1914    end Trim;
1915
1916    function Trim
1917      (Source : Unbounded_Wide_String;
1918       Left   : Wide_Maps.Wide_Character_Set;
1919       Right  : Wide_Maps.Wide_Character_Set) return Unbounded_Wide_String
1920    is
1921       SR   : constant Shared_Wide_String_Access := Source.Reference;
1922       DL   : Natural;
1923       DR   : Shared_Wide_String_Access;
1924       Low  : Natural;
1925       High : Natural;
1926
1927    begin
1928       Low := Index (Source, Left, Outside, Forward);
1929
1930       --  Source includes only characters from Left set, reuse empty shared
1931       --  string.
1932
1933       if Low = 0 then
1934          Reference (Empty_Shared_Wide_String'Access);
1935          DR := Empty_Shared_Wide_String'Access;
1936
1937       else
1938          High := Index (Source, Right, Outside, Backward);
1939          DL   := Integer'Max (0, High - Low + 1);
1940
1941          --  Source includes only characters from Right set or result string
1942          --  is empty, reuse empty shared string.
1943
1944          if High = 0 or else DL = 0 then
1945             Reference (Empty_Shared_Wide_String'Access);
1946             DR := Empty_Shared_Wide_String'Access;
1947
1948          --  Otherwise, allocate new shared string and fill it
1949
1950          else
1951             DR := Allocate (DL);
1952             DR.Data (1 .. DL) := SR.Data (Low .. High);
1953             DR.Last := DL;
1954          end if;
1955       end if;
1956
1957       return (AF.Controlled with Reference => DR);
1958    end Trim;
1959
1960    procedure Trim
1961      (Source : in out Unbounded_Wide_String;
1962       Left   : Wide_Maps.Wide_Character_Set;
1963       Right  : Wide_Maps.Wide_Character_Set)
1964    is
1965       SR   : constant Shared_Wide_String_Access := Source.Reference;
1966       DL   : Natural;
1967       DR   : Shared_Wide_String_Access;
1968       Low  : Natural;
1969       High : Natural;
1970
1971    begin
1972       Low := Index (Source, Left, Outside, Forward);
1973
1974       --  Source includes only characters from Left set, reuse empty shared
1975       --  string.
1976
1977       if Low = 0 then
1978          Reference (Empty_Shared_Wide_String'Access);
1979          Source.Reference := Empty_Shared_Wide_String'Access;
1980          Unreference (SR);
1981
1982       else
1983          High := Index (Source, Right, Outside, Backward);
1984          DL   := Integer'Max (0, High - Low + 1);
1985
1986          --  Source includes only characters from Right set or result string
1987          --  is empty, reuse empty shared string.
1988
1989          if High = 0 or else DL = 0 then
1990             Reference (Empty_Shared_Wide_String'Access);
1991             Source.Reference := Empty_Shared_Wide_String'Access;
1992             Unreference (SR);
1993
1994          --  Try to reuse existent shared string
1995
1996          elsif Can_Be_Reused (SR, DL) then
1997             SR.Data (1 .. DL) := SR.Data (Low .. High);
1998             SR.Last := DL;
1999
2000          --  Otherwise, allocate new shared string and fill it
2001
2002          else
2003             DR := Allocate (DL);
2004             DR.Data (1 .. DL) := SR.Data (Low .. High);
2005             DR.Last := DL;
2006             Source.Reference := DR;
2007             Unreference (SR);
2008          end if;
2009       end if;
2010    end Trim;
2011
2012    ---------------------
2013    -- Unbounded_Slice --
2014    ---------------------
2015
2016    function Unbounded_Slice
2017      (Source : Unbounded_Wide_String;
2018       Low    : Positive;
2019       High   : Natural) return Unbounded_Wide_String
2020    is
2021       SR : constant Shared_Wide_String_Access := Source.Reference;
2022       DL : Natural;
2023       DR : Shared_Wide_String_Access;
2024
2025    begin
2026       --  Check bounds
2027
2028       if Low > SR.Last + 1 or else High > SR.Last then
2029          raise Index_Error;
2030
2031       --  Result is empty slice, reuse empty shared string
2032
2033       elsif Low > High then
2034          Reference (Empty_Shared_Wide_String'Access);
2035          DR := Empty_Shared_Wide_String'Access;
2036
2037       --  Otherwise, allocate new shared string and fill it
2038
2039       else
2040          DL := High - Low + 1;
2041          DR := Allocate (DL);
2042          DR.Data (1 .. DL) := SR.Data (Low .. High);
2043          DR.Last := DL;
2044       end if;
2045
2046       return (AF.Controlled with Reference => DR);
2047    end Unbounded_Slice;
2048
2049    procedure Unbounded_Slice
2050      (Source : Unbounded_Wide_String;
2051       Target : out Unbounded_Wide_String;
2052       Low    : Positive;
2053       High   : Natural)
2054    is
2055       SR : constant Shared_Wide_String_Access := Source.Reference;
2056       TR : constant Shared_Wide_String_Access := Target.Reference;
2057       DL : Natural;
2058       DR : Shared_Wide_String_Access;
2059
2060    begin
2061       --  Check bounds
2062
2063       if Low > SR.Last + 1 or else High > SR.Last then
2064          raise Index_Error;
2065
2066       --  Result is empty slice, reuse empty shared string
2067
2068       elsif Low > High then
2069          Reference (Empty_Shared_Wide_String'Access);
2070          Target.Reference := Empty_Shared_Wide_String'Access;
2071          Unreference (TR);
2072
2073       else
2074          DL := High - Low + 1;
2075
2076          --  Try to reuse existent shared string
2077
2078          if Can_Be_Reused (TR, DL) then
2079             TR.Data (1 .. DL) := SR.Data (Low .. High);
2080             TR.Last := DL;
2081
2082          --  Otherwise, allocate new shared string and fill it
2083
2084          else
2085             DR := Allocate (DL);
2086             DR.Data (1 .. DL) := SR.Data (Low .. High);
2087             DR.Last := DL;
2088             Target.Reference := DR;
2089             Unreference (TR);
2090          end if;
2091       end if;
2092    end Unbounded_Slice;
2093
2094    -----------------
2095    -- Unreference --
2096    -----------------
2097
2098    procedure Unreference (Item : not null Shared_Wide_String_Access) is
2099       use Interfaces;
2100
2101       procedure Free is
2102         new Ada.Unchecked_Deallocation
2103               (Shared_Wide_String, Shared_Wide_String_Access);
2104
2105       Aux : Shared_Wide_String_Access := Item;
2106
2107    begin
2108       if Sync_Sub_And_Fetch (Aux.Counter'Access, 1) = 0 then
2109
2110          --  Reference counter of Empty_Shared_Wide_String must never reach
2111          --  zero.
2112
2113          pragma Assert (Aux /= Empty_Shared_Wide_String'Access);
2114
2115          Free (Aux);
2116       end if;
2117    end Unreference;
2118
2119 end Ada.Strings.Wide_Unbounded;