gcc/ada/libgnat/a-stwima.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --                A D A . S T R I N G S . W I D E _ M A P S                 --
   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.Unchecked_Deallocation;
  33
  34 package body Ada.Strings.Wide_Maps is
  35
  36    ---------
  37    -- "-" --
  38    ---------
  39
  40    function "-"
  41      (Left, Right : Wide_Character_Set) return Wide_Character_Set
  42    is
  43       LS : constant Wide_Character_Ranges_Access := Left.Set;
  44       RS : constant Wide_Character_Ranges_Access := Right.Set;
  45
  46       Result : Wide_Character_Ranges (1 .. LS'Last + RS'Last);
  47       --  Each range on the right can generate at least one more range in
  48       --  the result, by splitting one of the left operand ranges.
  49
  50       N  : Natural := 0;
  51       R  : Natural := 1;
  52       L  : Natural := 1;
  53
  54       Left_Low : Wide_Character;
  55       --  Left_Low is lowest character of the L'th range not yet dealt with
  56
  57    begin
  58       if LS'Last = 0 or else RS'Last = 0 then
  59          return Left;
  60       end if;
  61
  62       Left_Low := LS (L).Low;
  63       while R <= RS'Last loop
  64
  65          --  If next right range is below current left range, skip it
  66
  67          if RS (R).High < Left_Low then
  68             R := R + 1;
  69
  70          --  If next right range above current left range, copy remainder
  71          --  of the left range to the result
  72
  73          elsif RS (R).Low > LS (L).High then
  74             N := N + 1;
  75             Result (N).Low  := Left_Low;
  76             Result (N).High := LS (L).High;
  77             L := L + 1;
  78             exit when L > LS'Last;
  79             Left_Low := LS (L).Low;
  80
  81          else
  82             --  Next right range overlaps bottom of left range
  83
  84             if RS (R).Low <= Left_Low then
  85
  86                --  Case of right range complete overlaps left range
  87
  88                if RS (R).High >= LS (L).High then
  89                   L := L + 1;
  90                   exit when L > LS'Last;
  91                   Left_Low := LS (L).Low;
  92
  93                --  Case of right range eats lower part of left range
  94
  95                else
  96                   Left_Low := Wide_Character'Succ (RS (R).High);
  97                   R := R + 1;
  98                end if;
  99
 100             --  Next right range overlaps some of left range, but not bottom
 101
 102             else
 103                N := N + 1;
 104                Result (N).Low  := Left_Low;
 105                Result (N).High := Wide_Character'Pred (RS (R).Low);
 106
 107                --  Case of right range splits left range
 108
 109                if RS (R).High < LS (L).High then
 110                   Left_Low := Wide_Character'Succ (RS (R).High);
 111                   R := R + 1;
 112
 113                --  Case of right range overlaps top of left range
 114
 115                else
 116                   L := L + 1;
 117                   exit when L > LS'Last;
 118                   Left_Low := LS (L).Low;
 119                end if;
 120             end if;
 121          end if;
 122       end loop;
 123
 124       --  Copy remainder of left ranges to result
 125
 126       if L <= LS'Last then
 127          N := N + 1;
 128          Result (N).Low  := Left_Low;
 129          Result (N).High := LS (L).High;
 130
 131          loop
 132             L := L + 1;
 133             exit when L > LS'Last;
 134             N := N + 1;
 135             Result (N) := LS (L);
 136          end loop;
 137       end if;
 138
 139       return (AF.Controlled with
 140               Set => new Wide_Character_Ranges'(Result (1 .. N)));
 141    end "-";
 142
 143    ---------
 144    -- "=" --
 145    ---------
 146
 147    --  The sorted, discontiguous form is canonical, so equality can be used
 148
 149    function "=" (Left, Right : Wide_Character_Set) return Boolean is
 150    begin
 151       return Left.Set.all = Right.Set.all;
 152    end "=";
 153
 154    -----------
 155    -- "and" --
 156    -----------
 157
 158    function "and"
 159      (Left, Right : Wide_Character_Set) return Wide_Character_Set
 160    is
 161       LS : constant Wide_Character_Ranges_Access := Left.Set;
 162       RS : constant Wide_Character_Ranges_Access := Right.Set;
 163
 164       Result : Wide_Character_Ranges (1 .. LS'Last + RS'Last);
 165       N      : Natural := 0;
 166       L, R   : Natural := 1;
 167
 168    begin
 169       --  Loop to search for overlapping character ranges
 170
 171       while L <= LS'Last and then R <= RS'Last loop
 172
 173          if LS (L).High < RS (R).Low then
 174             L := L + 1;
 175
 176          elsif RS (R).High < LS (L).Low then
 177             R := R + 1;
 178
 179          --  Here we have LS (L).High >= RS (R).Low
 180          --           and RS (R).High >= LS (L).Low
 181          --  so we have an overlapping range
 182
 183          else
 184             N := N + 1;
 185             Result (N).Low := Wide_Character'Max (LS (L).Low,  RS (R).Low);
 186             Result (N).High :=
 187               Wide_Character'Min (LS (L).High, RS (R).High);
 188
 189             if RS (R).High = LS (L).High then
 190                L := L + 1;
 191                R := R + 1;
 192             elsif RS (R).High < LS (L).High then
 193                R := R + 1;
 194             else
 195                L := L + 1;
 196             end if;
 197          end if;
 198       end loop;
 199
 200       return (AF.Controlled with
 201               Set       => new Wide_Character_Ranges'(Result (1 .. N)));
 202    end "and";
 203
 204    -----------
 205    -- "not" --
 206    -----------
 207
 208    function "not"
 209      (Right : Wide_Character_Set) return Wide_Character_Set
 210    is
 211       RS : constant Wide_Character_Ranges_Access := Right.Set;
 212
 213       Result : Wide_Character_Ranges (1 .. RS'Last + 1);
 214       N      : Natural := 0;
 215
 216    begin
 217       if RS'Last = 0 then
 218          N := 1;
 219          Result (1) := (Low  => Wide_Character'First,
 220                         High => Wide_Character'Last);
 221
 222       else
 223          if RS (1).Low /= Wide_Character'First then
 224             N := N + 1;
 225             Result (N).Low  := Wide_Character'First;
 226             Result (N).High := Wide_Character'Pred (RS (1).Low);
 227          end if;
 228
 229          for K in 1 .. RS'Last - 1 loop
 230             N := N + 1;
 231             Result (N).Low  := Wide_Character'Succ (RS (K).High);
 232             Result (N).High := Wide_Character'Pred (RS (K + 1).Low);
 233          end loop;
 234
 235          if RS (RS'Last).High /= Wide_Character'Last then
 236             N := N + 1;
 237             Result (N).Low  := Wide_Character'Succ (RS (RS'Last).High);
 238             Result (N).High := Wide_Character'Last;
 239          end if;
 240       end if;
 241
 242       return (AF.Controlled with
 243               Set => new Wide_Character_Ranges'(Result (1 .. N)));
 244    end "not";
 245
 246    ----------
 247    -- "or" --
 248    ----------
 249
 250    function "or"
 251      (Left, Right : Wide_Character_Set) return Wide_Character_Set
 252    is
 253       LS : constant Wide_Character_Ranges_Access := Left.Set;
 254       RS : constant Wide_Character_Ranges_Access := Right.Set;
 255
 256       Result : Wide_Character_Ranges (1 .. LS'Last + RS'Last);
 257       N      : Natural;
 258       L, R   : Natural;
 259
 260    begin
 261       N := 0;
 262       L := 1;
 263       R := 1;
 264
 265       --  Loop through ranges in output file
 266
 267       loop
 268          --  If no left ranges left, copy next right range
 269
 270          if L > LS'Last then
 271             exit when R > RS'Last;
 272             N := N + 1;
 273             Result (N) := RS (R);
 274             R := R + 1;
 275
 276          --  If no right ranges left, copy next left range
 277
 278          elsif R > RS'Last then
 279             N := N + 1;
 280             Result (N) := LS (L);
 281             L := L + 1;
 282
 283          else
 284             --  We have two ranges, choose lower one
 285
 286             N := N + 1;
 287
 288             if LS (L).Low <= RS (R).Low then
 289                Result (N) := LS (L);
 290                L := L + 1;
 291             else
 292                Result (N) := RS (R);
 293                R := R + 1;
 294             end if;
 295
 296             --  Loop to collapse ranges into last range
 297
 298             loop
 299                --  Collapse next length range into current result range
 300                --  if possible.
 301
 302                if L <= LS'Last
 303                  and then LS (L).Low <= Wide_Character'Succ (Result (N).High)
 304                then
 305                   Result (N).High :=
 306                     Wide_Character'Max (Result (N).High, LS (L).High);
 307                   L := L + 1;
 308
 309                --  Collapse next right range into current result range
 310                --  if possible
 311
 312                elsif R <= RS'Last
 313                  and then RS (R).Low <=
 314                             Wide_Character'Succ (Result (N).High)
 315                then
 316                   Result (N).High :=
 317                     Wide_Character'Max (Result (N).High, RS (R).High);
 318                   R := R + 1;
 319
 320                --  If neither range collapses, then done with this range
 321
 322                else
 323                   exit;
 324                end if;
 325             end loop;
 326          end if;
 327       end loop;
 328
 329       return (AF.Controlled with
 330               Set => new Wide_Character_Ranges'(Result (1 .. N)));
 331    end "or";
 332
 333    -----------
 334    -- "xor" --
 335    -----------
 336
 337    function "xor"
 338      (Left, Right : Wide_Character_Set) return Wide_Character_Set
 339    is
 340    begin
 341       return (Left or Right) - (Left and Right);
 342    end "xor";
 343
 344    ------------
 345    -- Adjust --
 346    ------------
 347
 348    procedure Adjust (Object : in out Wide_Character_Mapping) is
 349    begin
 350       Object.Map := new Wide_Character_Mapping_Values'(Object.Map.all);
 351    end Adjust;
 352
 353    procedure Adjust (Object : in out Wide_Character_Set) is
 354    begin
 355       Object.Set := new Wide_Character_Ranges'(Object.Set.all);
 356    end Adjust;
 357
 358    --------------
 359    -- Finalize --
 360    --------------
 361
 362    procedure Finalize (Object : in out Wide_Character_Mapping) is
 363
 364       procedure Free is new Ada.Unchecked_Deallocation
 365         (Wide_Character_Mapping_Values,
 366          Wide_Character_Mapping_Values_Access);
 367
 368    begin
 369       if Object.Map /= Null_Map'Unrestricted_Access then
 370          Free (Object.Map);
 371       end if;
 372    end Finalize;
 373
 374    procedure Finalize (Object : in out Wide_Character_Set) is
 375
 376       procedure Free is new Ada.Unchecked_Deallocation
 377         (Wide_Character_Ranges,
 378          Wide_Character_Ranges_Access);
 379
 380    begin
 381       if Object.Set /= Null_Range'Unrestricted_Access then
 382          Free (Object.Set);
 383       end if;
 384    end Finalize;
 385
 386    ----------------
 387    -- Initialize --
 388    ----------------
 389
 390    procedure Initialize (Object : in out Wide_Character_Mapping) is
 391    begin
 392       Object := Identity;
 393    end Initialize;
 394
 395    procedure Initialize (Object : in out Wide_Character_Set) is
 396    begin
 397       Object := Null_Set;
 398    end Initialize;
 399
 400    -----------
 401    -- Is_In --
 402    -----------
 403
 404    function Is_In
 405      (Element : Wide_Character;
 406       Set     : Wide_Character_Set) return Boolean
 407    is
 408       L, R, M : Natural;
 409       SS      : constant Wide_Character_Ranges_Access := Set.Set;
 410
 411    begin
 412       L := 1;
 413       R := SS'Last;
 414
 415       --  Binary search loop. The invariant is that if Element is in any of
 416       --  of the constituent ranges it is in one between Set (L) and Set (R).
 417
 418       loop
 419          if L > R then
 420             return False;
 421
 422          else
 423             M := (L + R) / 2;
 424
 425             if Element > SS (M).High then
 426                L := M + 1;
 427             elsif Element < SS (M).Low then
 428                R := M - 1;
 429             else
 430                return True;
 431             end if;
 432          end if;
 433       end loop;
 434    end Is_In;
 435
 436    ---------------
 437    -- Is_Subset --
 438    ---------------
 439
 440    function Is_Subset
 441      (Elements : Wide_Character_Set;
 442       Set      : Wide_Character_Set) return Boolean
 443    is
 444       ES : constant Wide_Character_Ranges_Access := Elements.Set;
 445       SS : constant Wide_Character_Ranges_Access := Set.Set;
 446
 447       S  : Positive := 1;
 448       E  : Positive := 1;
 449
 450    begin
 451       loop
 452          --  If no more element ranges, done, and result is true
 453
 454          if E > ES'Last then
 455             return True;
 456
 457          --  If more element ranges, but no more set ranges, result is false
 458
 459          elsif S > SS'Last then
 460             return False;
 461
 462          --  Remove irrelevant set range
 463
 464          elsif SS (S).High < ES (E).Low then
 465             S := S + 1;
 466
 467          --  Get rid of element range that is properly covered by set
 468
 469          elsif SS (S).Low <= ES (E).Low
 470             and then ES (E).High <= SS (S).High
 471          then
 472             E := E + 1;
 473
 474          --  Otherwise we have a non-covered element range, result is false
 475
 476          else
 477             return False;
 478          end if;
 479       end loop;
 480    end Is_Subset;
 481
 482    ---------------
 483    -- To_Domain --
 484    ---------------
 485
 486    function To_Domain
 487      (Map : Wide_Character_Mapping) return Wide_Character_Sequence
 488    is
 489    begin
 490       return Map.Map.Domain;
 491    end To_Domain;
 492
 493    ----------------
 494    -- To_Mapping --
 495    ----------------
 496
 497    function To_Mapping
 498      (From, To : Wide_Character_Sequence) return Wide_Character_Mapping
 499    is
 500       Domain : Wide_Character_Sequence (1 .. From'Length);
 501       Rangev : Wide_Character_Sequence (1 .. To'Length);
 502       N      : Natural := 0;
 503
 504    begin
 505       if From'Length /= To'Length then
 506          raise Translation_Error;
 507
 508       else
 509          pragma Warnings (Off); -- apparent uninit use of Domain
 510
 511          for J in From'Range loop
 512             for M in 1 .. N loop
 513                if From (J) = Domain (M) then
 514                   raise Translation_Error;
 515                elsif From (J) < Domain (M) then
 516                   Domain (M + 1 .. N + 1) := Domain (M .. N);
 517                   Rangev (M + 1 .. N + 1) := Rangev (M .. N);
 518                   Domain (M) := From (J);
 519                   Rangev (M) := To   (J);
 520                   goto Continue;
 521                end if;
 522             end loop;
 523
 524             Domain (N + 1) := From (J);
 525             Rangev (N + 1) := To   (J);
 526
 527             <<Continue>>
 528                N := N + 1;
 529          end loop;
 530
 531          pragma Warnings (On);
 532
 533          return (AF.Controlled with
 534                  Map => new Wide_Character_Mapping_Values'(
 535                           Length => N,
 536                           Domain => Domain (1 .. N),
 537                           Rangev => Rangev (1 .. N)));
 538       end if;
 539    end To_Mapping;
 540
 541    --------------
 542    -- To_Range --
 543    --------------
 544
 545    function To_Range
 546      (Map : Wide_Character_Mapping) return Wide_Character_Sequence
 547    is
 548    begin
 549       return Map.Map.Rangev;
 550    end To_Range;
 551
 552    ---------------
 553    -- To_Ranges --
 554    ---------------
 555
 556    function To_Ranges
 557      (Set : Wide_Character_Set) return Wide_Character_Ranges
 558    is
 559    begin
 560       return Set.Set.all;
 561    end To_Ranges;
 562
 563    -----------------
 564    -- To_Sequence --
 565    -----------------
 566
 567    function To_Sequence
 568      (Set : Wide_Character_Set) return Wide_Character_Sequence
 569    is
 570       SS    : constant Wide_Character_Ranges_Access := Set.Set;
 571       N     : Natural := 0;
 572       Count : Natural := 0;
 573
 574    begin
 575       for J in SS'Range loop
 576          Count :=
 577            Count + (Wide_Character'Pos (SS (J).High) -
 578                     Wide_Character'Pos (SS (J).Low) + 1);
 579       end loop;
 580
 581       return Result : Wide_String (1 .. Count) do
 582          for J in SS'Range loop
 583             for K in SS (J).Low .. SS (J).High loop
 584                N := N + 1;
 585                Result (N) := K;
 586             end loop;
 587          end loop;
 588       end return;
 589    end To_Sequence;
 590
 591    ------------
 592    -- To_Set --
 593    ------------
 594
 595    --  Case of multiple range input
 596
 597    function To_Set
 598      (Ranges : Wide_Character_Ranges) return Wide_Character_Set
 599    is
 600       Result : Wide_Character_Ranges (Ranges'Range);
 601       N      : Natural := 0;
 602       J      : Natural;
 603
 604    begin
 605       --  The output of To_Set is required to be sorted by increasing Low
 606       --  values, and discontiguous, so first we sort them as we enter them,
 607       --  using a simple insertion sort.
 608
 609       pragma Warnings (Off);
 610       --  Kill bogus warning on Result being uninitialized
 611
 612       for J in Ranges'Range loop
 613          for K in 1 .. N loop
 614             if Ranges (J).Low < Result (K).Low then
 615                Result (K + 1 .. N + 1) := Result (K .. N);
 616                Result (K) := Ranges (J);
 617                goto Continue;
 618             end if;
 619          end loop;
 620
 621          Result (N + 1) := Ranges (J);
 622
 623          <<Continue>>
 624             N := N + 1;
 625       end loop;
 626
 627       pragma Warnings (On);
 628
 629       --  Now collapse any contiguous or overlapping ranges
 630
 631       J := 1;
 632       while J < N loop
 633          if Result (J).High < Result (J).Low then
 634             N := N - 1;
 635             Result (J .. N) := Result (J + 1 .. N + 1);
 636
 637          elsif Wide_Character'Succ (Result (J).High) >= Result (J + 1).Low then
 638             Result (J).High :=
 639               Wide_Character'Max (Result (J).High, Result (J + 1).High);
 640
 641             N := N - 1;
 642             Result (J + 1 .. N) := Result (J + 2 .. N + 1);
 643
 644          else
 645             J := J + 1;
 646          end if;
 647       end loop;
 648
 649       if N > 0 and then Result (N).High < Result (N).Low then
 650          N := N - 1;
 651       end if;
 652
 653       return (AF.Controlled with
 654               Set => new Wide_Character_Ranges'(Result (1 .. N)));
 655    end To_Set;
 656
 657    --  Case of single range input
 658
 659    function To_Set
 660      (Span : Wide_Character_Range) return Wide_Character_Set
 661    is
 662    begin
 663       if Span.Low > Span.High then
 664          return Null_Set;
 665          --  This is safe, because there is no procedure with parameter
 666          --  Wide_Character_Set of mode "out" or "in out".
 667
 668       else
 669          return (AF.Controlled with
 670                  Set => new Wide_Character_Ranges'(1 => Span));
 671       end if;
 672    end To_Set;
 673
 674    --  Case of wide string input
 675
 676    function To_Set
 677      (Sequence : Wide_Character_Sequence) return Wide_Character_Set
 678    is
 679       R : Wide_Character_Ranges (1 .. Sequence'Length);
 680
 681    begin
 682       for J in R'Range loop
 683          R (J) := (Sequence (J), Sequence (J));
 684       end loop;
 685
 686       return To_Set (R);
 687    end To_Set;
 688
 689    --  Case of single wide character input
 690
 691    function To_Set
 692      (Singleton : Wide_Character) return Wide_Character_Set
 693    is
 694    begin
 695       return
 696         (AF.Controlled with
 697          Set => new Wide_Character_Ranges'(1 => (Singleton, Singleton)));
 698    end To_Set;
 699
 700    -----------
 701    -- Value --
 702    -----------
 703
 704    function Value
 705      (Map     : Wide_Character_Mapping;
 706       Element : Wide_Character) return Wide_Character
 707    is
 708       L, R, M : Natural;
 709
 710       MV : constant Wide_Character_Mapping_Values_Access := Map.Map;
 711
 712    begin
 713       L := 1;
 714       R := MV.Domain'Last;
 715
 716       --  Binary search loop
 717
 718       loop
 719          --  If not found, identity
 720
 721          if L > R then
 722             return Element;
 723
 724          --  Otherwise do binary divide
 725
 726          else
 727             M := (L + R) / 2;
 728
 729             if Element < MV.Domain (M) then
 730                R := M - 1;
 731
 732             elsif Element > MV.Domain (M) then
 733                L := M + 1;
 734
 735             else --  Element = MV.Domain (M) then
 736                return MV.Rangev (M);
 737             end if;
 738          end if;
 739       end loop;
 740    end Value;
 741
 742 end Ada.Strings.Wide_Maps;