gcc/ada/a-strunb-shared.adb

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