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