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       From   : Positive;
 823       Test   : Strings.Membership;
 824       First  : out Positive;
 825       Last   : out Natural)
 826    is
 827       SR : constant Shared_String_Access := Source.Reference;
 828    begin
 829       Search.Find_Token (SR.Data (From .. SR.Last), Set, Test, First, Last);
 830    end Find_Token;
 831
 832    procedure Find_Token
 833      (Source : Unbounded_String;
 834       Set    : Maps.Character_Set;
 835       Test   : Strings.Membership;
 836       First  : out Positive;
 837       Last   : out Natural)
 838    is
 839       SR : constant Shared_String_Access := Source.Reference;
 840    begin
 841       Search.Find_Token (SR.Data (1 .. SR.Last), Set, Test, First, Last);
 842    end Find_Token;
 843
 844    ----------
 845    -- Free --
 846    ----------
 847
 848    procedure Free (X : in out String_Access) is
 849       procedure Deallocate is
 850         new Ada.Unchecked_Deallocation (String, String_Access);
 851    begin
 852       Deallocate (X);
 853    end Free;
 854
 855    ----------
 856    -- Head --
 857    ----------
 858
 859    function Head
 860      (Source : Unbounded_String;
 861       Count  : Natural;
 862       Pad    : Character := Space) return Unbounded_String
 863    is
 864       SR : constant Shared_String_Access := Source.Reference;
 865       DR : Shared_String_Access;
 866
 867    begin
 868       --  Result is empty, reuse shared empty string
 869
 870       if Count = 0 then
 871          Reference (Empty_Shared_String'Access);
 872          DR := Empty_Shared_String'Access;
 873
 874       --  Length of the string is the same as requested, reuse source shared
 875       --  string.
 876
 877       elsif Count = SR.Last then
 878          Reference (SR);
 879          DR := SR;
 880
 881       --  Otherwise, allocate new shared string and fill it
 882
 883       else
 884          DR := Allocate (Count);
 885
 886          --  Length of the source string is more than requested, copy
 887          --  corresponding slice.
 888
 889          if Count < SR.Last then
 890             DR.Data (1 .. Count) := SR.Data (1 .. Count);
 891
 892          --  Length of the source string is less then requested, copy all
 893          --  contents and fill others by Pad character.
 894
 895          else
 896             DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
 897
 898             for J in SR.Last + 1 .. Count loop
 899                DR.Data (J) := Pad;
 900             end loop;
 901          end if;
 902
 903          DR.Last := Count;
 904       end if;
 905
 906       return (AF.Controlled with Reference => DR);
 907    end Head;
 908
 909    procedure Head
 910      (Source : in out Unbounded_String;
 911       Count  : Natural;
 912       Pad    : Character := Space)
 913    is
 914       SR : constant Shared_String_Access := Source.Reference;
 915       DR : Shared_String_Access;
 916
 917    begin
 918       --  Result is empty, reuse empty shared string
 919
 920       if Count = 0 then
 921          Reference (Empty_Shared_String'Access);
 922          Source.Reference := Empty_Shared_String'Access;
 923          Unreference (SR);
 924
 925       --  Result is same as source string, reuse source shared string
 926
 927       elsif Count = SR.Last then
 928          null;
 929
 930       --  Try to reuse existing shared string
 931
 932       elsif Can_Be_Reused (SR, Count) then
 933          if Count > SR.Last then
 934             for J in SR.Last + 1 .. Count loop
 935                SR.Data (J) := Pad;
 936             end loop;
 937          end if;
 938
 939          SR.Last := Count;
 940
 941       --  Otherwise, allocate new shared string and fill it
 942
 943       else
 944          DR := Allocate (Count);
 945
 946          --  Length of the source string is greater then requested, copy
 947          --  corresponding slice.
 948
 949          if Count < SR.Last then
 950             DR.Data (1 .. Count) := SR.Data (1 .. Count);
 951
 952          --  Length of the source string is less the requested, copy all
 953          --  existing data and fill remaining positions with Pad characters.
 954
 955          else
 956             DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
 957
 958             for J in SR.Last + 1 .. Count loop
 959                DR.Data (J) := Pad;
 960             end loop;
 961          end if;
 962
 963          DR.Last := Count;
 964          Source.Reference := DR;
 965          Unreference (SR);
 966       end if;
 967    end Head;
 968
 969    -----------
 970    -- Index --
 971    -----------
 972
 973    function Index
 974      (Source  : Unbounded_String;
 975       Pattern : String;
 976       Going   : Strings.Direction := Strings.Forward;
 977       Mapping : Maps.Character_Mapping := Maps.Identity) return Natural
 978    is
 979       SR : constant Shared_String_Access := Source.Reference;
 980    begin
 981       return Search.Index (SR.Data (1 .. SR.Last), Pattern, Going, Mapping);
 982    end Index;
 983
 984    function Index
 985      (Source  : Unbounded_String;
 986       Pattern : String;
 987       Going   : Direction := Forward;
 988       Mapping : Maps.Character_Mapping_Function) return Natural
 989    is
 990       SR : constant Shared_String_Access := Source.Reference;
 991    begin
 992       return Search.Index (SR.Data (1 .. SR.Last), Pattern, Going, Mapping);
 993    end Index;
 994
 995    function Index
 996      (Source : Unbounded_String;
 997       Set    : Maps.Character_Set;
 998       Test   : Strings.Membership := Strings.Inside;
 999       Going  : Strings.Direction  := Strings.Forward) return Natural
1000    is
1001       SR : constant Shared_String_Access := Source.Reference;
1002    begin
1003       return Search.Index (SR.Data (1 .. SR.Last), Set, Test, Going);
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 := Maps.Identity) 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       Pattern : String;
1022       From    : Positive;
1023       Going   : Direction := Forward;
1024       Mapping : Maps.Character_Mapping_Function) return Natural
1025    is
1026       SR : constant Shared_String_Access := Source.Reference;
1027    begin
1028       return Search.Index
1029         (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping);
1030    end Index;
1031
1032    function Index
1033      (Source  : Unbounded_String;
1034       Set     : Maps.Character_Set;
1035       From    : Positive;
1036       Test    : Membership := Inside;
1037       Going   : Direction := Forward) return Natural
1038    is
1039       SR : constant Shared_String_Access := Source.Reference;
1040    begin
1041       return Search.Index (SR.Data (1 .. SR.Last), Set, From, Test, Going);
1042    end Index;
1043
1044    ---------------------
1045    -- Index_Non_Blank --
1046    ---------------------
1047
1048    function Index_Non_Blank
1049      (Source : Unbounded_String;
1050       Going  : Strings.Direction := Strings.Forward) return Natural
1051    is
1052       SR : constant Shared_String_Access := Source.Reference;
1053    begin
1054       return Search.Index_Non_Blank (SR.Data (1 .. SR.Last), Going);
1055    end Index_Non_Blank;
1056
1057    function Index_Non_Blank
1058      (Source : Unbounded_String;
1059       From   : Positive;
1060       Going  : Direction := Forward) return Natural
1061    is
1062       SR : constant Shared_String_Access := Source.Reference;
1063    begin
1064       return Search.Index_Non_Blank (SR.Data (1 .. SR.Last), From, Going);
1065    end Index_Non_Blank;
1066
1067    ----------------
1068    -- Initialize --
1069    ----------------
1070
1071    procedure Initialize (Object : in out Unbounded_String) is
1072    begin
1073       Reference (Object.Reference);
1074    end Initialize;
1075
1076    ------------
1077    -- Insert --
1078    ------------
1079
1080    function Insert
1081      (Source   : Unbounded_String;
1082       Before   : Positive;
1083       New_Item : String) return Unbounded_String
1084    is
1085       SR : constant Shared_String_Access := Source.Reference;
1086       DL : constant Natural := SR.Last + New_Item'Length;
1087       DR : Shared_String_Access;
1088
1089    begin
1090       --  Check index first
1091
1092       if Before > SR.Last + 1 then
1093          raise Index_Error;
1094       end if;
1095
1096       --  Result is empty, reuse empty shared string
1097
1098       if DL = 0 then
1099          Reference (Empty_Shared_String'Access);
1100          DR := Empty_Shared_String'Access;
1101
1102       --  Inserted string is empty, reuse source shared string
1103
1104       elsif New_Item'Length = 0 then
1105          Reference (SR);
1106          DR := SR;
1107
1108       --  Otherwise, allocate new shared string and fill it
1109
1110       else
1111          DR := Allocate (DL + DL /Growth_Factor);
1112          DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1);
1113          DR.Data (Before .. Before + New_Item'Length - 1) := New_Item;
1114          DR.Data (Before + New_Item'Length .. DL) :=
1115            SR.Data (Before .. SR.Last);
1116          DR.Last := DL;
1117       end if;
1118
1119       return (AF.Controlled with Reference => DR);
1120    end Insert;
1121
1122    procedure Insert
1123      (Source   : in out Unbounded_String;
1124       Before   : Positive;
1125       New_Item : String)
1126    is
1127       SR : constant Shared_String_Access := Source.Reference;
1128       DL : constant Natural              := SR.Last + New_Item'Length;
1129       DR : Shared_String_Access;
1130
1131    begin
1132       --  Check bounds
1133
1134       if Before > SR.Last + 1 then
1135          raise Index_Error;
1136       end if;
1137
1138       --  Result is empty string, reuse empty shared string
1139
1140       if DL = 0 then
1141          Reference (Empty_Shared_String'Access);
1142          Source.Reference := Empty_Shared_String'Access;
1143          Unreference (SR);
1144
1145       --  Inserted string is empty, nothing to do
1146
1147       elsif New_Item'Length = 0 then
1148          null;
1149
1150       --  Try to reuse existing shared string first
1151
1152       elsif Can_Be_Reused (SR, DL) then
1153          SR.Data (Before + New_Item'Length .. DL) :=
1154            SR.Data (Before .. SR.Last);
1155          SR.Data (Before .. Before + New_Item'Length - 1) := New_Item;
1156          SR.Last := DL;
1157
1158       --  Otherwise, allocate new shared string and fill it
1159
1160       else
1161          DR := Allocate (DL + DL / Growth_Factor);
1162          DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1);
1163          DR.Data (Before .. Before + New_Item'Length - 1) := New_Item;
1164          DR.Data (Before + New_Item'Length .. DL) :=
1165            SR.Data (Before .. SR.Last);
1166          DR.Last := DL;
1167          Source.Reference := DR;
1168          Unreference (SR);
1169       end if;
1170    end Insert;
1171
1172    ------------
1173    -- Length --
1174    ------------
1175
1176    function Length (Source : Unbounded_String) return Natural is
1177    begin
1178       return Source.Reference.Last;
1179    end Length;
1180
1181    ---------------
1182    -- Overwrite --
1183    ---------------
1184
1185    function Overwrite
1186      (Source   : Unbounded_String;
1187       Position : Positive;
1188       New_Item : String) return Unbounded_String
1189    is
1190       SR : constant Shared_String_Access := Source.Reference;
1191       DL : Natural;
1192       DR : Shared_String_Access;
1193
1194    begin
1195       --  Check bounds
1196
1197       if Position > SR.Last + 1 then
1198          raise Index_Error;
1199       end if;
1200
1201       DL := Integer'Max (SR.Last, Position + New_Item'Length - 1);
1202
1203       --  Result is empty string, reuse empty shared string
1204
1205       if DL = 0 then
1206          Reference (Empty_Shared_String'Access);
1207          DR := Empty_Shared_String'Access;
1208
1209       --  Result is same as source string, reuse source shared string
1210
1211       elsif New_Item'Length = 0 then
1212          Reference (SR);
1213          DR := SR;
1214
1215       --  Otherwise, allocate new shared string and fill it
1216
1217       else
1218          DR := Allocate (DL);
1219          DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1);
1220          DR.Data (Position .. Position + New_Item'Length - 1) := New_Item;
1221          DR.Data (Position + New_Item'Length .. DL) :=
1222            SR.Data (Position + New_Item'Length .. SR.Last);
1223          DR.Last := DL;
1224       end if;
1225
1226       return (AF.Controlled with Reference => DR);
1227    end Overwrite;
1228
1229    procedure Overwrite
1230      (Source    : in out Unbounded_String;
1231       Position  : Positive;
1232       New_Item  : String)
1233    is
1234       SR : constant Shared_String_Access := Source.Reference;
1235       DL : Natural;
1236       DR : Shared_String_Access;
1237
1238    begin
1239       --  Bounds check
1240
1241       if Position > SR.Last + 1 then
1242          raise Index_Error;
1243       end if;
1244
1245       DL := Integer'Max (SR.Last, Position + New_Item'Length - 1);
1246
1247       --  Result is empty string, reuse empty shared string
1248
1249       if DL = 0 then
1250          Reference (Empty_Shared_String'Access);
1251          Source.Reference := Empty_Shared_String'Access;
1252          Unreference (SR);
1253
1254       --  String unchanged, nothing to do
1255
1256       elsif New_Item'Length = 0 then
1257          null;
1258
1259       --  Try to reuse existing shared string
1260
1261       elsif Can_Be_Reused (SR, DL) then
1262          SR.Data (Position .. Position + New_Item'Length - 1) := New_Item;
1263          SR.Last := DL;
1264
1265       --  Otherwise allocate new shared string and fill it
1266
1267       else
1268          DR := Allocate (DL);
1269          DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1);
1270          DR.Data (Position .. Position + New_Item'Length - 1) := New_Item;
1271          DR.Data (Position + New_Item'Length .. DL) :=
1272            SR.Data (Position + New_Item'Length .. SR.Last);
1273          DR.Last := DL;
1274          Source.Reference := DR;
1275          Unreference (SR);
1276       end if;
1277    end Overwrite;
1278
1279    ---------------
1280    -- Reference --
1281    ---------------
1282
1283    procedure Reference (Item : not null Shared_String_Access) is
1284    begin
1285       Sync_Add_And_Fetch (Item.Counter'Access, 1);
1286    end Reference;
1287
1288    ---------------------
1289    -- Replace_Element --
1290    ---------------------
1291
1292    procedure Replace_Element
1293      (Source : in out Unbounded_String;
1294       Index  : Positive;
1295       By     : Character)
1296    is
1297       SR : constant Shared_String_Access := Source.Reference;
1298       DR : Shared_String_Access;
1299
1300    begin
1301       --  Bounds check.
1302
1303       if Index <= SR.Last then
1304
1305          --  Try to reuse existing shared string
1306
1307          if Can_Be_Reused (SR, SR.Last) then
1308             SR.Data (Index) := By;
1309
1310          --  Otherwise allocate new shared string and fill it
1311
1312          else
1313             DR := Allocate (SR.Last);
1314             DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
1315             DR.Data (Index) := By;
1316             DR.Last := SR.Last;
1317             Source.Reference := DR;
1318             Unreference (SR);
1319          end if;
1320
1321       else
1322          raise Index_Error;
1323       end if;
1324    end Replace_Element;
1325
1326    -------------------
1327    -- Replace_Slice --
1328    -------------------
1329
1330    function Replace_Slice
1331      (Source : Unbounded_String;
1332       Low    : Positive;
1333       High   : Natural;
1334       By     : String) return Unbounded_String
1335    is
1336       SR : constant Shared_String_Access := Source.Reference;
1337       DL : Natural;
1338       DR : Shared_String_Access;
1339
1340    begin
1341       --  Check bounds
1342
1343       if Low > SR.Last + 1 then
1344          raise Index_Error;
1345       end if;
1346
1347       --  Do replace operation when removed slice is not empty
1348
1349       if High >= Low then
1350          DL := By'Length + SR.Last + Low - High - 1;
1351
1352          --  Result is empty string, reuse empty shared string
1353
1354          if DL = 0 then
1355             Reference (Empty_Shared_String'Access);
1356             DR := Empty_Shared_String'Access;
1357
1358          --  Otherwise allocate new shared string and fill it
1359
1360          else
1361             DR := Allocate (DL);
1362             DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1);
1363             DR.Data (Low .. Low + By'Length - 1) := By;
1364             DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last);
1365             DR.Last := DL;
1366          end if;
1367
1368          return (AF.Controlled with Reference => DR);
1369
1370       --  Otherwise just insert string
1371
1372       else
1373          return Insert (Source, Low, By);
1374       end if;
1375    end Replace_Slice;
1376
1377    procedure Replace_Slice
1378      (Source : in out Unbounded_String;
1379       Low    : Positive;
1380       High   : Natural;
1381       By     : String)
1382    is
1383       SR : constant Shared_String_Access := Source.Reference;
1384       DL : Natural;
1385       DR : Shared_String_Access;
1386
1387    begin
1388       --  Bounds check
1389
1390       if Low > SR.Last + 1 then
1391          raise Index_Error;
1392       end if;
1393
1394       --  Do replace operation only when replaced slice is not empty
1395
1396       if High >= Low then
1397          DL := By'Length + SR.Last + Low - High - 1;
1398
1399          --  Result is empty string, reuse empty shared string
1400
1401          if DL = 0 then
1402             Reference (Empty_Shared_String'Access);
1403             Source.Reference := Empty_Shared_String'Access;
1404             Unreference (SR);
1405
1406          --  Try to reuse existing shared string
1407
1408          elsif Can_Be_Reused (SR, DL) then
1409             SR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last);
1410             SR.Data (Low .. Low + By'Length - 1) := By;
1411             SR.Last := DL;
1412
1413          --  Otherwise allocate new shared string and fill it
1414
1415          else
1416             DR := Allocate (DL);
1417             DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1);
1418             DR.Data (Low .. Low + By'Length - 1) := By;
1419             DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last);
1420             DR.Last := DL;
1421             Source.Reference := DR;
1422             Unreference (SR);
1423          end if;
1424
1425       --  Otherwise just insert item
1426
1427       else
1428          Insert (Source, Low, By);
1429       end if;
1430    end Replace_Slice;
1431
1432    --------------------------
1433    -- Set_Unbounded_String --
1434    --------------------------
1435
1436    procedure Set_Unbounded_String
1437      (Target : out Unbounded_String;
1438       Source : String)
1439    is
1440       TR : constant Shared_String_Access := Target.Reference;
1441       DR : Shared_String_Access;
1442
1443    begin
1444       --  In case of empty string, reuse empty shared string
1445
1446       if Source'Length = 0 then
1447          Reference (Empty_Shared_String'Access);
1448          Target.Reference := Empty_Shared_String'Access;
1449
1450       else
1451          --  Try to reuse existing shared string
1452
1453          if Can_Be_Reused (TR, Source'Length) then
1454             Reference (TR);
1455             DR := TR;
1456
1457          --  Otherwise allocate new shared string
1458
1459          else
1460             DR := Allocate (Source'Length);
1461             Target.Reference := DR;
1462          end if;
1463
1464          DR.Data (1 .. Source'Length) := Source;
1465          DR.Last := Source'Length;
1466       end if;
1467
1468       Unreference (TR);
1469    end Set_Unbounded_String;
1470
1471    -----------
1472    -- Slice --
1473    -----------
1474
1475    function Slice
1476      (Source : Unbounded_String;
1477       Low    : Positive;
1478       High   : Natural) return String
1479    is
1480       SR : constant Shared_String_Access := Source.Reference;
1481
1482    begin
1483       --  Note: test of High > Length is in accordance with AI95-00128
1484
1485       if Low > SR.Last + 1 or else High > SR.Last then
1486          raise Index_Error;
1487
1488       else
1489          return SR.Data (Low .. High);
1490       end if;
1491    end Slice;
1492
1493    ----------
1494    -- Tail --
1495    ----------
1496
1497    function Tail
1498      (Source : Unbounded_String;
1499       Count  : Natural;
1500       Pad    : Character := Space) return Unbounded_String
1501    is
1502       SR : constant Shared_String_Access := Source.Reference;
1503       DR : Shared_String_Access;
1504
1505    begin
1506       --  For empty result reuse empty shared string
1507
1508       if Count = 0 then
1509          Reference (Empty_Shared_String'Access);
1510          DR := Empty_Shared_String'Access;
1511
1512       --  Result is whole source string, reuse source shared string
1513
1514       elsif Count = SR.Last then
1515          Reference (SR);
1516          DR := SR;
1517
1518       --  Otherwise allocate new shared string and fill it
1519
1520       else
1521          DR := Allocate (Count);
1522
1523          if Count < SR.Last then
1524             DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last);
1525
1526          else
1527             for J in 1 .. Count - SR.Last loop
1528                DR.Data (J) := Pad;
1529             end loop;
1530
1531             DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last);
1532          end if;
1533
1534          DR.Last := Count;
1535       end if;
1536
1537       return (AF.Controlled with Reference => DR);
1538    end Tail;
1539
1540    procedure Tail
1541      (Source : in out Unbounded_String;
1542       Count  : Natural;
1543       Pad    : Character := Space)
1544    is
1545       SR : constant Shared_String_Access := Source.Reference;
1546       DR : Shared_String_Access;
1547
1548       procedure Common
1549         (SR    : Shared_String_Access;
1550          DR    : Shared_String_Access;
1551          Count : Natural);
1552       --  Common code of tail computation. SR/DR can point to the same object
1553
1554       ------------
1555       -- Common --
1556       ------------
1557
1558       procedure Common
1559         (SR    : Shared_String_Access;
1560          DR    : Shared_String_Access;
1561          Count : Natural) is
1562       begin
1563          if Count < SR.Last then
1564             DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last);
1565
1566          else
1567             DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last);
1568
1569             for J in 1 .. Count - SR.Last loop
1570                DR.Data (J) := Pad;
1571             end loop;
1572          end if;
1573
1574          DR.Last := Count;
1575       end Common;
1576
1577    begin
1578       --  Result is empty string, reuse empty shared string
1579
1580       if Count = 0 then
1581          Reference (Empty_Shared_String'Access);
1582          Source.Reference := Empty_Shared_String'Access;
1583          Unreference (SR);
1584
1585       --  Length of the result is the same as length of the source string,
1586       --  reuse source shared string.
1587
1588       elsif Count = SR.Last then
1589          null;
1590
1591       --  Try to reuse existing shared string
1592
1593       elsif Can_Be_Reused (SR, Count) then
1594          Common (SR, SR, Count);
1595
1596       --  Otherwise allocate new shared string and fill it
1597
1598       else
1599          DR := Allocate (Count);
1600          Common (SR, DR, Count);
1601          Source.Reference := DR;
1602          Unreference (SR);
1603       end if;
1604    end Tail;
1605
1606    ---------------
1607    -- To_String --
1608    ---------------
1609
1610    function To_String (Source : Unbounded_String) return String is
1611    begin
1612       return Source.Reference.Data (1 .. Source.Reference.Last);
1613    end To_String;
1614
1615    -------------------------
1616    -- To_Unbounded_String --
1617    -------------------------
1618
1619    function To_Unbounded_String (Source : String) return Unbounded_String is
1620       DR : constant Shared_String_Access := Allocate (Source'Length);
1621    begin
1622       DR.Data (1 .. Source'Length) := Source;
1623       DR.Last := Source'Length;
1624       return (AF.Controlled with Reference => DR);
1625    end To_Unbounded_String;
1626
1627    function To_Unbounded_String (Length : Natural) return Unbounded_String is
1628       DR : constant Shared_String_Access := Allocate (Length);
1629    begin
1630       DR.Last := Length;
1631       return (AF.Controlled with Reference => DR);
1632    end To_Unbounded_String;
1633
1634    ---------------
1635    -- Translate --
1636    ---------------
1637
1638    function Translate
1639      (Source  : Unbounded_String;
1640       Mapping : Maps.Character_Mapping) return Unbounded_String
1641    is
1642       SR : constant Shared_String_Access := Source.Reference;
1643       DR : Shared_String_Access;
1644
1645    begin
1646       --  Nothing to translate, reuse empty shared string
1647
1648       if SR.Last = 0 then
1649          Reference (Empty_Shared_String'Access);
1650          DR := Empty_Shared_String'Access;
1651
1652       --  Otherwise, allocate new shared string and fill it
1653
1654       else
1655          DR := Allocate (SR.Last);
1656
1657          for J in 1 .. SR.Last loop
1658             DR.Data (J) := Value (Mapping, SR.Data (J));
1659          end loop;
1660
1661          DR.Last := SR.Last;
1662       end if;
1663
1664       return (AF.Controlled with Reference => DR);
1665    end Translate;
1666
1667    procedure Translate
1668      (Source  : in out Unbounded_String;
1669       Mapping : Maps.Character_Mapping)
1670    is
1671       SR : constant Shared_String_Access := Source.Reference;
1672       DR : Shared_String_Access;
1673
1674    begin
1675       --  Nothing to translate
1676
1677       if SR.Last = 0 then
1678          null;
1679
1680       --  Try to reuse shared string
1681
1682       elsif Can_Be_Reused (SR, SR.Last) then
1683          for J in 1 .. SR.Last loop
1684             SR.Data (J) := Value (Mapping, SR.Data (J));
1685          end loop;
1686
1687       --  Otherwise, allocate new shared string
1688
1689       else
1690          DR := Allocate (SR.Last);
1691
1692          for J in 1 .. SR.Last loop
1693             DR.Data (J) := Value (Mapping, SR.Data (J));
1694          end loop;
1695
1696          DR.Last := SR.Last;
1697          Source.Reference := DR;
1698          Unreference (SR);
1699       end if;
1700    end Translate;
1701
1702    function Translate
1703      (Source  : Unbounded_String;
1704       Mapping : Maps.Character_Mapping_Function) return Unbounded_String
1705    is
1706       SR : constant Shared_String_Access := Source.Reference;
1707       DR : Shared_String_Access;
1708
1709    begin
1710       --  Nothing to translate, reuse empty shared string
1711
1712       if SR.Last = 0 then
1713          Reference (Empty_Shared_String'Access);
1714          DR := Empty_Shared_String'Access;
1715
1716       --  Otherwise, allocate new shared string and fill it
1717
1718       else
1719          DR := Allocate (SR.Last);
1720
1721          for J in 1 .. SR.Last loop
1722             DR.Data (J) := Mapping.all (SR.Data (J));
1723          end loop;
1724
1725          DR.Last := SR.Last;
1726       end if;
1727
1728       return (AF.Controlled with Reference => DR);
1729
1730    exception
1731       when others =>
1732          Unreference (DR);
1733
1734          raise;
1735    end Translate;
1736
1737    procedure Translate
1738      (Source  : in out Unbounded_String;
1739       Mapping : Maps.Character_Mapping_Function)
1740    is
1741       SR : constant Shared_String_Access := Source.Reference;
1742       DR : Shared_String_Access;
1743
1744    begin
1745       --  Nothing to translate
1746
1747       if SR.Last = 0 then
1748          null;
1749
1750       --  Try to reuse shared string
1751
1752       elsif Can_Be_Reused (SR, SR.Last) then
1753          for J in 1 .. SR.Last loop
1754             SR.Data (J) := Mapping.all (SR.Data (J));
1755          end loop;
1756
1757       --  Otherwise allocate new shared string and fill it
1758
1759       else
1760          DR := Allocate (SR.Last);
1761
1762          for J in 1 .. SR.Last loop
1763             DR.Data (J) := Mapping.all (SR.Data (J));
1764          end loop;
1765
1766          DR.Last := SR.Last;
1767          Source.Reference := DR;
1768          Unreference (SR);
1769       end if;
1770
1771    exception
1772       when others =>
1773          if DR /= null then
1774             Unreference (DR);
1775          end if;
1776
1777          raise;
1778    end Translate;
1779
1780    ----------
1781    -- Trim --
1782    ----------
1783
1784    function Trim
1785      (Source : Unbounded_String;
1786       Side   : Trim_End) return Unbounded_String
1787    is
1788       SR   : constant Shared_String_Access := Source.Reference;
1789       DL   : Natural;
1790       DR   : Shared_String_Access;
1791       Low  : Natural;
1792       High : Natural;
1793
1794    begin
1795       Low := Index_Non_Blank (Source, Forward);
1796
1797       --  All blanks, reuse empty shared string
1798
1799       if Low = 0 then
1800          Reference (Empty_Shared_String'Access);
1801          DR := Empty_Shared_String'Access;
1802
1803       else
1804          case Side is
1805             when Left =>
1806                High := SR.Last;
1807                DL   := SR.Last - Low + 1;
1808
1809             when Right =>
1810                Low  := 1;
1811                High := Index_Non_Blank (Source, Backward);
1812                DL   := High;
1813
1814             when Both =>
1815                High := Index_Non_Blank (Source, Backward);
1816                DL   := High - Low + 1;
1817          end case;
1818
1819          --  Length of the result is the same as length of the source string,
1820          --  reuse source shared string.
1821
1822          if DL = SR.Last then
1823             Reference (SR);
1824             DR := SR;
1825
1826          --  Otherwise, allocate new shared string
1827
1828          else
1829             DR := Allocate (DL);
1830             DR.Data (1 .. DL) := SR.Data (Low .. High);
1831             DR.Last := DL;
1832          end if;
1833       end if;
1834
1835       return (AF.Controlled with Reference => DR);
1836    end Trim;
1837
1838    procedure Trim
1839      (Source : in out Unbounded_String;
1840       Side   : Trim_End)
1841    is
1842       SR   : constant Shared_String_Access := Source.Reference;
1843       DL   : Natural;
1844       DR   : Shared_String_Access;
1845       Low  : Natural;
1846       High : Natural;
1847
1848    begin
1849       Low := Index_Non_Blank (Source, Forward);
1850
1851       --  All blanks, reuse empty shared string
1852
1853       if Low = 0 then
1854          Reference (Empty_Shared_String'Access);
1855          Source.Reference := Empty_Shared_String'Access;
1856          Unreference (SR);
1857
1858       else
1859          case Side is
1860             when Left =>
1861                High := SR.Last;
1862                DL   := SR.Last - Low + 1;
1863
1864             when Right =>
1865                Low  := 1;
1866                High := Index_Non_Blank (Source, Backward);
1867                DL   := High;
1868
1869             when Both =>
1870                High := Index_Non_Blank (Source, Backward);
1871                DL   := High - Low + 1;
1872          end case;
1873
1874          --  Length of the result is the same as length of the source string,
1875          --  nothing to do.
1876
1877          if DL = SR.Last then
1878             null;
1879
1880          --  Try to reuse existing shared string
1881
1882          elsif Can_Be_Reused (SR, DL) then
1883             SR.Data (1 .. DL) := SR.Data (Low .. High);
1884             SR.Last := DL;
1885
1886          --  Otherwise, allocate new shared string
1887
1888          else
1889             DR := Allocate (DL);
1890             DR.Data (1 .. DL) := SR.Data (Low .. High);
1891             DR.Last := DL;
1892             Source.Reference := DR;
1893             Unreference (SR);
1894          end if;
1895       end if;
1896    end Trim;
1897
1898    function Trim
1899      (Source : Unbounded_String;
1900       Left   : Maps.Character_Set;
1901       Right  : Maps.Character_Set) return Unbounded_String
1902    is
1903       SR   : constant Shared_String_Access := Source.Reference;
1904       DL   : Natural;
1905       DR   : Shared_String_Access;
1906       Low  : Natural;
1907       High : Natural;
1908
1909    begin
1910       Low := Index (Source, Left, Outside, Forward);
1911
1912       --  Source includes only characters from Left set, reuse empty shared
1913       --  string.
1914
1915       if Low = 0 then
1916          Reference (Empty_Shared_String'Access);
1917          DR := Empty_Shared_String'Access;
1918
1919       else
1920          High := Index (Source, Right, Outside, Backward);
1921          DL   := Integer'Max (0, High - Low + 1);
1922
1923          --  Source includes only characters from Right set or result string
1924          --  is empty, reuse empty shared string.
1925
1926          if High = 0 or else DL = 0 then
1927             Reference (Empty_Shared_String'Access);
1928             DR := Empty_Shared_String'Access;
1929
1930          --  Otherwise, allocate new shared string and fill it
1931
1932          else
1933             DR := Allocate (DL);
1934             DR.Data (1 .. DL) := SR.Data (Low .. High);
1935             DR.Last := DL;
1936          end if;
1937       end if;
1938
1939       return (AF.Controlled with Reference => DR);
1940    end Trim;
1941
1942    procedure Trim
1943      (Source : in out Unbounded_String;
1944       Left   : Maps.Character_Set;
1945       Right  : Maps.Character_Set)
1946    is
1947       SR   : constant Shared_String_Access := Source.Reference;
1948       DL   : Natural;
1949       DR   : Shared_String_Access;
1950       Low  : Natural;
1951       High : Natural;
1952
1953    begin
1954       Low := Index (Source, Left, Outside, Forward);
1955
1956       --  Source includes only characters from Left set, reuse empty shared
1957       --  string.
1958
1959       if Low = 0 then
1960          Reference (Empty_Shared_String'Access);
1961          Source.Reference := Empty_Shared_String'Access;
1962          Unreference (SR);
1963
1964       else
1965          High := Index (Source, Right, Outside, Backward);
1966          DL   := Integer'Max (0, High - Low + 1);
1967
1968          --  Source includes only characters from Right set or result string
1969          --  is empty, reuse empty shared string.
1970
1971          if High = 0 or else DL = 0 then
1972             Reference (Empty_Shared_String'Access);
1973             Source.Reference := Empty_Shared_String'Access;
1974             Unreference (SR);
1975
1976          --  Try to reuse existing shared string
1977
1978          elsif Can_Be_Reused (SR, DL) then
1979             SR.Data (1 .. DL) := SR.Data (Low .. High);
1980             SR.Last := DL;
1981
1982          --  Otherwise, allocate new shared string and fill it
1983
1984          else
1985             DR := Allocate (DL);
1986             DR.Data (1 .. DL) := SR.Data (Low .. High);
1987             DR.Last := DL;
1988             Source.Reference := DR;
1989             Unreference (SR);
1990          end if;
1991       end if;
1992    end Trim;
1993
1994    ---------------------
1995    -- Unbounded_Slice --
1996    ---------------------
1997
1998    function Unbounded_Slice
1999      (Source : Unbounded_String;
2000       Low    : Positive;
2001       High   : Natural) return Unbounded_String
2002    is
2003       SR : constant Shared_String_Access := Source.Reference;
2004       DL : Natural;
2005       DR : Shared_String_Access;
2006
2007    begin
2008       --  Check bounds
2009
2010       if Low > SR.Last + 1 or else High > SR.Last then
2011          raise Index_Error;
2012
2013       --  Result is empty slice, reuse empty shared string
2014
2015       elsif Low > High then
2016          Reference (Empty_Shared_String'Access);
2017          DR := Empty_Shared_String'Access;
2018
2019       --  Otherwise, allocate new shared string and fill it
2020
2021       else
2022          DL := High - Low + 1;
2023          DR := Allocate (DL);
2024          DR.Data (1 .. DL) := SR.Data (Low .. High);
2025          DR.Last := DL;
2026       end if;
2027
2028       return (AF.Controlled with Reference => DR);
2029    end Unbounded_Slice;
2030
2031    procedure Unbounded_Slice
2032      (Source : Unbounded_String;
2033       Target : out Unbounded_String;
2034       Low    : Positive;
2035       High   : Natural)
2036    is
2037       SR : constant Shared_String_Access := Source.Reference;
2038       TR : constant Shared_String_Access := Target.Reference;
2039       DL : Natural;
2040       DR : Shared_String_Access;
2041
2042    begin
2043       --  Check bounds
2044
2045       if Low > SR.Last + 1 or else High > SR.Last then
2046          raise Index_Error;
2047
2048       --  Result is empty slice, reuse empty shared string
2049
2050       elsif Low > High then
2051          Reference (Empty_Shared_String'Access);
2052          Target.Reference := Empty_Shared_String'Access;
2053          Unreference (TR);
2054
2055       else
2056          DL := High - Low + 1;
2057
2058          --  Try to reuse existing shared string
2059
2060          if Can_Be_Reused (TR, DL) then
2061             TR.Data (1 .. DL) := SR.Data (Low .. High);
2062             TR.Last := DL;
2063
2064          --  Otherwise, allocate new shared string and fill it
2065
2066          else
2067             DR := Allocate (DL);
2068             DR.Data (1 .. DL) := SR.Data (Low .. High);
2069             DR.Last := DL;
2070             Target.Reference := DR;
2071             Unreference (TR);
2072          end if;
2073       end if;
2074    end Unbounded_Slice;
2075
2076    -----------------
2077    -- Unreference --
2078    -----------------
2079
2080    procedure Unreference (Item : not null Shared_String_Access) is
2081       use Interfaces;
2082
2083       procedure Free is
2084         new Ada.Unchecked_Deallocation (Shared_String, Shared_String_Access);
2085
2086       Aux : Shared_String_Access := Item;
2087
2088    begin
2089       if Sync_Sub_And_Fetch (Aux.Counter'Access, 1) = 0 then
2090
2091          --  Reference counter of Empty_Shared_String must never reach zero
2092
2093          pragma Assert (Aux /= Empty_Shared_String'Access);
2094
2095          Free (Aux);
2096       end if;
2097    end Unreference;
2098
2099 end Ada.Strings.Unbounded;