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