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 Right string
  90
  91       elsif LR.Last = 0 then
  92          Reference (RR);
  93          DR := RR;
  94
  95       --  Right string is empty, return Left string
  96
  97       elsif RR.Last = 0 then
  98          Reference (LR);
  99          DR := LR;
 100
 101       --  Otherwise, allocate new shared string and fill data
 102
 103       else
 104          DR := Allocate (LR.Last + RR.Last);
 105          DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last);
 106          DR.Data (LR.Last + 1 .. DL) := RR.Data (1 .. RR.Last);
 107          DR.Last := DL;
 108       end if;
 109
 110       return (AF.Controlled with Reference => DR);
 111    end "&";
 112
 113    function "&"
 114      (Left  : Unbounded_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 - Integer'Min (High, SR.Last) - 1;
1351          --  This is the number of characters remaining in the string after
1352          --  replacing the slice.
1353
1354          --  Result is empty string, reuse empty shared string
1355
1356          if DL = 0 then
1357             Reference (Empty_Shared_String'Access);
1358             DR := Empty_Shared_String'Access;
1359
1360          --  Otherwise allocate new shared string and fill it
1361
1362          else
1363             DR := Allocate (DL);
1364             DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1);
1365             DR.Data (Low .. Low + By'Length - 1) := By;
1366             DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last);
1367             DR.Last := DL;
1368          end if;
1369
1370          return (AF.Controlled with Reference => DR);
1371
1372       --  Otherwise just insert string
1373
1374       else
1375          return Insert (Source, Low, By);
1376       end if;
1377    end Replace_Slice;
1378
1379    procedure Replace_Slice
1380      (Source : in out Unbounded_String;
1381       Low    : Positive;
1382       High   : Natural;
1383       By     : String)
1384    is
1385       SR : constant Shared_String_Access := Source.Reference;
1386       DL : Natural;
1387       DR : Shared_String_Access;
1388
1389    begin
1390       --  Bounds check
1391
1392       if Low > SR.Last + 1 then
1393          raise Index_Error;
1394       end if;
1395
1396       --  Do replace operation only when replaced slice is not empty
1397
1398       if High >= Low then
1399          DL := By'Length + SR.Last + Low - Integer'Min (High, SR.Last) - 1;
1400          --  This is the number of characters remaining in the string after
1401          --  replacing the slice.
1402
1403          --  Result is empty string, reuse empty shared string
1404
1405          if DL = 0 then
1406             Reference (Empty_Shared_String'Access);
1407             Source.Reference := Empty_Shared_String'Access;
1408             Unreference (SR);
1409
1410          --  Try to reuse existing shared string
1411
1412          elsif Can_Be_Reused (SR, DL) then
1413             SR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last);
1414             SR.Data (Low .. Low + By'Length - 1) := By;
1415             SR.Last := DL;
1416
1417          --  Otherwise allocate new shared string and fill it
1418
1419          else
1420             DR := Allocate (DL);
1421             DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1);
1422             DR.Data (Low .. Low + By'Length - 1) := By;
1423             DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last);
1424             DR.Last := DL;
1425             Source.Reference := DR;
1426             Unreference (SR);
1427          end if;
1428
1429       --  Otherwise just insert item
1430
1431       else
1432          Insert (Source, Low, By);
1433       end if;
1434    end Replace_Slice;
1435
1436    --------------------------
1437    -- Set_Unbounded_String --
1438    --------------------------
1439
1440    procedure Set_Unbounded_String
1441      (Target : out Unbounded_String;
1442       Source : String)
1443    is
1444       TR : constant Shared_String_Access := Target.Reference;
1445       DR : Shared_String_Access;
1446
1447    begin
1448       --  In case of empty string, reuse empty shared string
1449
1450       if Source'Length = 0 then
1451          Reference (Empty_Shared_String'Access);
1452          Target.Reference := Empty_Shared_String'Access;
1453
1454       else
1455          --  Try to reuse existing shared string
1456
1457          if Can_Be_Reused (TR, Source'Length) then
1458             Reference (TR);
1459             DR := TR;
1460
1461          --  Otherwise allocate new shared string
1462
1463          else
1464             DR := Allocate (Source'Length);
1465             Target.Reference := DR;
1466          end if;
1467
1468          DR.Data (1 .. Source'Length) := Source;
1469          DR.Last := Source'Length;
1470       end if;
1471
1472       Unreference (TR);
1473    end Set_Unbounded_String;
1474
1475    -----------
1476    -- Slice --
1477    -----------
1478
1479    function Slice
1480      (Source : Unbounded_String;
1481       Low    : Positive;
1482       High   : Natural) return String
1483    is
1484       SR : constant Shared_String_Access := Source.Reference;
1485
1486    begin
1487       --  Note: test of High > Length is in accordance with AI95-00128
1488
1489       if Low > SR.Last + 1 or else High > SR.Last then
1490          raise Index_Error;
1491
1492       else
1493          return SR.Data (Low .. High);
1494       end if;
1495    end Slice;
1496
1497    ----------
1498    -- Tail --
1499    ----------
1500
1501    function Tail
1502      (Source : Unbounded_String;
1503       Count  : Natural;
1504       Pad    : Character := Space) return Unbounded_String
1505    is
1506       SR : constant Shared_String_Access := Source.Reference;
1507       DR : Shared_String_Access;
1508
1509    begin
1510       --  For empty result reuse empty shared string
1511
1512       if Count = 0 then
1513          Reference (Empty_Shared_String'Access);
1514          DR := Empty_Shared_String'Access;
1515
1516       --  Result is whole source string, reuse source shared string
1517
1518       elsif Count = SR.Last then
1519          Reference (SR);
1520          DR := SR;
1521
1522       --  Otherwise allocate new shared string and fill it
1523
1524       else
1525          DR := Allocate (Count);
1526
1527          if Count < SR.Last then
1528             DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last);
1529
1530          else
1531             for J in 1 .. Count - SR.Last loop
1532                DR.Data (J) := Pad;
1533             end loop;
1534
1535             DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last);
1536          end if;
1537
1538          DR.Last := Count;
1539       end if;
1540
1541       return (AF.Controlled with Reference => DR);
1542    end Tail;
1543
1544    procedure Tail
1545      (Source : in out Unbounded_String;
1546       Count  : Natural;
1547       Pad    : Character := Space)
1548    is
1549       SR : constant Shared_String_Access := Source.Reference;
1550       DR : Shared_String_Access;
1551
1552       procedure Common
1553         (SR    : Shared_String_Access;
1554          DR    : Shared_String_Access;
1555          Count : Natural);
1556       --  Common code of tail computation. SR/DR can point to the same object
1557
1558       ------------
1559       -- Common --
1560       ------------
1561
1562       procedure Common
1563         (SR    : Shared_String_Access;
1564          DR    : Shared_String_Access;
1565          Count : Natural) is
1566       begin
1567          if Count < SR.Last then
1568             DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last);
1569
1570          else
1571             DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last);
1572
1573             for J in 1 .. Count - SR.Last loop
1574                DR.Data (J) := Pad;
1575             end loop;
1576          end if;
1577
1578          DR.Last := Count;
1579       end Common;
1580
1581    begin
1582       --  Result is empty string, reuse empty shared string
1583
1584       if Count = 0 then
1585          Reference (Empty_Shared_String'Access);
1586          Source.Reference := Empty_Shared_String'Access;
1587          Unreference (SR);
1588
1589       --  Length of the result is the same as length of the source string,
1590       --  reuse source shared string.
1591
1592       elsif Count = SR.Last then
1593          null;
1594
1595       --  Try to reuse existing shared string
1596
1597       elsif Can_Be_Reused (SR, Count) then
1598          Common (SR, SR, Count);
1599
1600       --  Otherwise allocate new shared string and fill it
1601
1602       else
1603          DR := Allocate (Count);
1604          Common (SR, DR, Count);
1605          Source.Reference := DR;
1606          Unreference (SR);
1607       end if;
1608    end Tail;
1609
1610    ---------------
1611    -- To_String --
1612    ---------------
1613
1614    function To_String (Source : Unbounded_String) return String is
1615    begin
1616       return Source.Reference.Data (1 .. Source.Reference.Last);
1617    end To_String;
1618
1619    -------------------------
1620    -- To_Unbounded_String --
1621    -------------------------
1622
1623    function To_Unbounded_String (Source : String) return Unbounded_String is
1624       DR : constant Shared_String_Access := Allocate (Source'Length);
1625    begin
1626       DR.Data (1 .. Source'Length) := Source;
1627       DR.Last := Source'Length;
1628       return (AF.Controlled with Reference => DR);
1629    end To_Unbounded_String;
1630
1631    function To_Unbounded_String (Length : Natural) return Unbounded_String is
1632       DR : constant Shared_String_Access := Allocate (Length);
1633    begin
1634       DR.Last := Length;
1635       return (AF.Controlled with Reference => DR);
1636    end To_Unbounded_String;
1637
1638    ---------------
1639    -- Translate --
1640    ---------------
1641
1642    function Translate
1643      (Source  : Unbounded_String;
1644       Mapping : Maps.Character_Mapping) return Unbounded_String
1645    is
1646       SR : constant Shared_String_Access := Source.Reference;
1647       DR : Shared_String_Access;
1648
1649    begin
1650       --  Nothing to translate, reuse empty shared string
1651
1652       if SR.Last = 0 then
1653          Reference (Empty_Shared_String'Access);
1654          DR := Empty_Shared_String'Access;
1655
1656       --  Otherwise, allocate new shared string and fill it
1657
1658       else
1659          DR := Allocate (SR.Last);
1660
1661          for J in 1 .. SR.Last loop
1662             DR.Data (J) := Value (Mapping, SR.Data (J));
1663          end loop;
1664
1665          DR.Last := SR.Last;
1666       end if;
1667
1668       return (AF.Controlled with Reference => DR);
1669    end Translate;
1670
1671    procedure Translate
1672      (Source  : in out Unbounded_String;
1673       Mapping : Maps.Character_Mapping)
1674    is
1675       SR : constant Shared_String_Access := Source.Reference;
1676       DR : Shared_String_Access;
1677
1678    begin
1679       --  Nothing to translate
1680
1681       if SR.Last = 0 then
1682          null;
1683
1684       --  Try to reuse shared string
1685
1686       elsif Can_Be_Reused (SR, SR.Last) then
1687          for J in 1 .. SR.Last loop
1688             SR.Data (J) := Value (Mapping, SR.Data (J));
1689          end loop;
1690
1691       --  Otherwise, allocate new shared string
1692
1693       else
1694          DR := Allocate (SR.Last);
1695
1696          for J in 1 .. SR.Last loop
1697             DR.Data (J) := Value (Mapping, SR.Data (J));
1698          end loop;
1699
1700          DR.Last := SR.Last;
1701          Source.Reference := DR;
1702          Unreference (SR);
1703       end if;
1704    end Translate;
1705
1706    function Translate
1707      (Source  : Unbounded_String;
1708       Mapping : Maps.Character_Mapping_Function) return Unbounded_String
1709    is
1710       SR : constant Shared_String_Access := Source.Reference;
1711       DR : Shared_String_Access;
1712
1713    begin
1714       --  Nothing to translate, reuse empty shared string
1715
1716       if SR.Last = 0 then
1717          Reference (Empty_Shared_String'Access);
1718          DR := Empty_Shared_String'Access;
1719
1720       --  Otherwise, allocate new shared string and fill it
1721
1722       else
1723          DR := Allocate (SR.Last);
1724
1725          for J in 1 .. SR.Last loop
1726             DR.Data (J) := Mapping.all (SR.Data (J));
1727          end loop;
1728
1729          DR.Last := SR.Last;
1730       end if;
1731
1732       return (AF.Controlled with Reference => DR);
1733
1734    exception
1735       when others =>
1736          Unreference (DR);
1737
1738          raise;
1739    end Translate;
1740
1741    procedure Translate
1742      (Source  : in out Unbounded_String;
1743       Mapping : Maps.Character_Mapping_Function)
1744    is
1745       SR : constant Shared_String_Access := Source.Reference;
1746       DR : Shared_String_Access;
1747
1748    begin
1749       --  Nothing to translate
1750
1751       if SR.Last = 0 then
1752          null;
1753
1754       --  Try to reuse shared string
1755
1756       elsif Can_Be_Reused (SR, SR.Last) then
1757          for J in 1 .. SR.Last loop
1758             SR.Data (J) := Mapping.all (SR.Data (J));
1759          end loop;
1760
1761       --  Otherwise allocate new shared string and fill it
1762
1763       else
1764          DR := Allocate (SR.Last);
1765
1766          for J in 1 .. SR.Last loop
1767             DR.Data (J) := Mapping.all (SR.Data (J));
1768          end loop;
1769
1770          DR.Last := SR.Last;
1771          Source.Reference := DR;
1772          Unreference (SR);
1773       end if;
1774
1775    exception
1776       when others =>
1777          if DR /= null then
1778             Unreference (DR);
1779          end if;
1780
1781          raise;
1782    end Translate;
1783
1784    ----------
1785    -- Trim --
1786    ----------
1787
1788    function Trim
1789      (Source : Unbounded_String;
1790       Side   : Trim_End) return Unbounded_String
1791    is
1792       SR   : constant Shared_String_Access := Source.Reference;
1793       DL   : Natural;
1794       DR   : Shared_String_Access;
1795       Low  : Natural;
1796       High : Natural;
1797
1798    begin
1799       Low := Index_Non_Blank (Source, Forward);
1800
1801       --  All blanks, reuse empty shared string
1802
1803       if Low = 0 then
1804          Reference (Empty_Shared_String'Access);
1805          DR := Empty_Shared_String'Access;
1806
1807       else
1808          case Side is
1809             when Left =>
1810                High := SR.Last;
1811                DL   := SR.Last - Low + 1;
1812
1813             when Right =>
1814                Low  := 1;
1815                High := Index_Non_Blank (Source, Backward);
1816                DL   := High;
1817
1818             when Both =>
1819                High := Index_Non_Blank (Source, Backward);
1820                DL   := High - Low + 1;
1821          end case;
1822
1823          --  Length of the result is the same as length of the source string,
1824          --  reuse source shared string.
1825
1826          if DL = SR.Last then
1827             Reference (SR);
1828             DR := SR;
1829
1830          --  Otherwise, allocate new shared string
1831
1832          else
1833             DR := Allocate (DL);
1834             DR.Data (1 .. DL) := SR.Data (Low .. High);
1835             DR.Last := DL;
1836          end if;
1837       end if;
1838
1839       return (AF.Controlled with Reference => DR);
1840    end Trim;
1841
1842    procedure Trim
1843      (Source : in out Unbounded_String;
1844       Side   : Trim_End)
1845    is
1846       SR   : constant Shared_String_Access := Source.Reference;
1847       DL   : Natural;
1848       DR   : Shared_String_Access;
1849       Low  : Natural;
1850       High : Natural;
1851
1852    begin
1853       Low := Index_Non_Blank (Source, Forward);
1854
1855       --  All blanks, reuse empty shared string
1856
1857       if Low = 0 then
1858          Reference (Empty_Shared_String'Access);
1859          Source.Reference := Empty_Shared_String'Access;
1860          Unreference (SR);
1861
1862       else
1863          case Side is
1864             when Left =>
1865                High := SR.Last;
1866                DL   := SR.Last - Low + 1;
1867
1868             when Right =>
1869                Low  := 1;
1870                High := Index_Non_Blank (Source, Backward);
1871                DL   := High;
1872
1873             when Both =>
1874                High := Index_Non_Blank (Source, Backward);
1875                DL   := High - Low + 1;
1876          end case;
1877
1878          --  Length of the result is the same as length of the source string,
1879          --  nothing to do.
1880
1881          if DL = SR.Last then
1882             null;
1883
1884          --  Try to reuse existing shared string
1885
1886          elsif Can_Be_Reused (SR, DL) then
1887             SR.Data (1 .. DL) := SR.Data (Low .. High);
1888             SR.Last := DL;
1889
1890          --  Otherwise, allocate new shared string
1891
1892          else
1893             DR := Allocate (DL);
1894             DR.Data (1 .. DL) := SR.Data (Low .. High);
1895             DR.Last := DL;
1896             Source.Reference := DR;
1897             Unreference (SR);
1898          end if;
1899       end if;
1900    end Trim;
1901
1902    function Trim
1903      (Source : Unbounded_String;
1904       Left   : Maps.Character_Set;
1905       Right  : Maps.Character_Set) return Unbounded_String
1906    is
1907       SR   : constant Shared_String_Access := Source.Reference;
1908       DL   : Natural;
1909       DR   : Shared_String_Access;
1910       Low  : Natural;
1911       High : Natural;
1912
1913    begin
1914       Low := Index (Source, Left, Outside, Forward);
1915
1916       --  Source includes only characters from Left set, reuse empty shared
1917       --  string.
1918
1919       if Low = 0 then
1920          Reference (Empty_Shared_String'Access);
1921          DR := Empty_Shared_String'Access;
1922
1923       else
1924          High := Index (Source, Right, Outside, Backward);
1925          DL   := Integer'Max (0, High - Low + 1);
1926
1927          --  Source includes only characters from Right set or result string
1928          --  is empty, reuse empty shared string.
1929
1930          if High = 0 or else DL = 0 then
1931             Reference (Empty_Shared_String'Access);
1932             DR := Empty_Shared_String'Access;
1933
1934          --  Otherwise, allocate new shared string and fill it
1935
1936          else
1937             DR := Allocate (DL);
1938             DR.Data (1 .. DL) := SR.Data (Low .. High);
1939             DR.Last := DL;
1940          end if;
1941       end if;
1942
1943       return (AF.Controlled with Reference => DR);
1944    end Trim;
1945
1946    procedure Trim
1947      (Source : in out Unbounded_String;
1948       Left   : Maps.Character_Set;
1949       Right  : Maps.Character_Set)
1950    is
1951       SR   : constant Shared_String_Access := Source.Reference;
1952       DL   : Natural;
1953       DR   : Shared_String_Access;
1954       Low  : Natural;
1955       High : Natural;
1956
1957    begin
1958       Low := Index (Source, Left, Outside, Forward);
1959
1960       --  Source includes only characters from Left set, reuse empty shared
1961       --  string.
1962
1963       if Low = 0 then
1964          Reference (Empty_Shared_String'Access);
1965          Source.Reference := Empty_Shared_String'Access;
1966          Unreference (SR);
1967
1968       else
1969          High := Index (Source, Right, Outside, Backward);
1970          DL   := Integer'Max (0, High - Low + 1);
1971
1972          --  Source includes only characters from Right set or result string
1973          --  is empty, reuse empty shared string.
1974
1975          if High = 0 or else DL = 0 then
1976             Reference (Empty_Shared_String'Access);
1977             Source.Reference := Empty_Shared_String'Access;
1978             Unreference (SR);
1979
1980          --  Try to reuse existing shared string
1981
1982          elsif Can_Be_Reused (SR, DL) then
1983             SR.Data (1 .. DL) := SR.Data (Low .. High);
1984             SR.Last := DL;
1985
1986          --  Otherwise, allocate new shared string and fill it
1987
1988          else
1989             DR := Allocate (DL);
1990             DR.Data (1 .. DL) := SR.Data (Low .. High);
1991             DR.Last := DL;
1992             Source.Reference := DR;
1993             Unreference (SR);
1994          end if;
1995       end if;
1996    end Trim;
1997
1998    ---------------------
1999    -- Unbounded_Slice --
2000    ---------------------
2001
2002    function Unbounded_Slice
2003      (Source : Unbounded_String;
2004       Low    : Positive;
2005       High   : Natural) return Unbounded_String
2006    is
2007       SR : constant Shared_String_Access := Source.Reference;
2008       DL : Natural;
2009       DR : Shared_String_Access;
2010
2011    begin
2012       --  Check bounds
2013
2014       if Low > SR.Last + 1 or else High > SR.Last then
2015          raise Index_Error;
2016
2017       --  Result is empty slice, reuse empty shared string
2018
2019       elsif Low > High then
2020          Reference (Empty_Shared_String'Access);
2021          DR := Empty_Shared_String'Access;
2022
2023       --  Otherwise, allocate new shared string and fill it
2024
2025       else
2026          DL := High - Low + 1;
2027          DR := Allocate (DL);
2028          DR.Data (1 .. DL) := SR.Data (Low .. High);
2029          DR.Last := DL;
2030       end if;
2031
2032       return (AF.Controlled with Reference => DR);
2033    end Unbounded_Slice;
2034
2035    procedure Unbounded_Slice
2036      (Source : Unbounded_String;
2037       Target : out Unbounded_String;
2038       Low    : Positive;
2039       High   : Natural)
2040    is
2041       SR : constant Shared_String_Access := Source.Reference;
2042       TR : constant Shared_String_Access := Target.Reference;
2043       DL : Natural;
2044       DR : Shared_String_Access;
2045
2046    begin
2047       --  Check bounds
2048
2049       if Low > SR.Last + 1 or else High > SR.Last then
2050          raise Index_Error;
2051
2052       --  Result is empty slice, reuse empty shared string
2053
2054       elsif Low > High then
2055          Reference (Empty_Shared_String'Access);
2056          Target.Reference := Empty_Shared_String'Access;
2057          Unreference (TR);
2058
2059       else
2060          DL := High - Low + 1;
2061
2062          --  Try to reuse existing shared string
2063
2064          if Can_Be_Reused (TR, DL) then
2065             TR.Data (1 .. DL) := SR.Data (Low .. High);
2066             TR.Last := DL;
2067
2068          --  Otherwise, allocate new shared string and fill it
2069
2070          else
2071             DR := Allocate (DL);
2072             DR.Data (1 .. DL) := SR.Data (Low .. High);
2073             DR.Last := DL;
2074             Target.Reference := DR;
2075             Unreference (TR);
2076          end if;
2077       end if;
2078    end Unbounded_Slice;
2079
2080    -----------------
2081    -- Unreference --
2082    -----------------
2083
2084    procedure Unreference (Item : not null Shared_String_Access) is
2085       use Interfaces;
2086
2087       procedure Free is
2088         new Ada.Unchecked_Deallocation (Shared_String, Shared_String_Access);
2089
2090       Aux : Shared_String_Access := Item;
2091
2092    begin
2093       if Sync_Sub_And_Fetch (Aux.Counter'Access, 1) = 0 then
2094
2095          --  Reference counter of Empty_Shared_String must never reach zero
2096
2097          pragma Assert (Aux /= Empty_Shared_String'Access);
2098
2099          Free (Aux);
2100       end if;
2101    end Unreference;
2102
2103 end Ada.Strings.Unbounded;