gcc/ada/a-stzmap.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --           A D A . S T R I N G S . W I D E _ W I D E _ M A P S            --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2009, 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_Wide_Maps is
  35
  36    ---------
  37    -- "-" --
  38    ---------
  39
  40    function "-"
  41      (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set
  42    is
  43       LS : constant Wide_Wide_Character_Ranges_Access := Left.Set;
  44       RS : constant Wide_Wide_Character_Ranges_Access := Right.Set;
  45
  46       Result : Wide_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_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 of
  71          --  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_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_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_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_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_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_Wide_Character_Set) return Wide_Wide_Character_Set
 160    is
 161       LS : constant Wide_Wide_Character_Ranges_Access := Left.Set;
 162       RS : constant Wide_Wide_Character_Ranges_Access := Right.Set;
 163
 164       Result : Wide_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 :=
 186               Wide_Wide_Character'Max (LS (L).Low,  RS (R).Low);
 187             Result (N).High :=
 188               Wide_Wide_Character'Min (LS (L).High, RS (R).High);
 189
 190             if RS (R).High = LS (L).High then
 191                L := L + 1;
 192                R := R + 1;
 193             elsif RS (R).High < LS (L).High then
 194                R := R + 1;
 195             else
 196                L := L + 1;
 197             end if;
 198          end if;
 199       end loop;
 200
 201       return (AF.Controlled with
 202               Set => new Wide_Wide_Character_Ranges'(Result (1 .. N)));
 203    end "and";
 204
 205    -----------
 206    -- "not" --
 207    -----------
 208
 209    function "not"
 210      (Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set
 211    is
 212       RS : constant Wide_Wide_Character_Ranges_Access := Right.Set;
 213
 214       Result : Wide_Wide_Character_Ranges (1 .. RS'Last + 1);
 215       N      : Natural := 0;
 216
 217    begin
 218       if RS'Last = 0 then
 219          N := 1;
 220          Result (1) := (Low  => Wide_Wide_Character'First,
 221                         High => Wide_Wide_Character'Last);
 222
 223       else
 224          if RS (1).Low /= Wide_Wide_Character'First then
 225             N := N + 1;
 226             Result (N).Low  := Wide_Wide_Character'First;
 227             Result (N).High := Wide_Wide_Character'Pred (RS (1).Low);
 228          end if;
 229
 230          for K in 1 .. RS'Last - 1 loop
 231             N := N + 1;
 232             Result (N).Low  := Wide_Wide_Character'Succ (RS (K).High);
 233             Result (N).High := Wide_Wide_Character'Pred (RS (K + 1).Low);
 234          end loop;
 235
 236          if RS (RS'Last).High /= Wide_Wide_Character'Last then
 237             N := N + 1;
 238             Result (N).Low  := Wide_Wide_Character'Succ (RS (RS'Last).High);
 239             Result (N).High := Wide_Wide_Character'Last;
 240          end if;
 241       end if;
 242
 243       return (AF.Controlled with
 244               Set => new Wide_Wide_Character_Ranges'(Result (1 .. N)));
 245    end "not";
 246
 247    ----------
 248    -- "or" --
 249    ----------
 250
 251    function "or"
 252      (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set
 253    is
 254       LS : constant Wide_Wide_Character_Ranges_Access := Left.Set;
 255       RS : constant Wide_Wide_Character_Ranges_Access := Right.Set;
 256
 257       Result : Wide_Wide_Character_Ranges (1 .. LS'Last + RS'Last);
 258       N      : Natural;
 259       L, R   : Natural;
 260
 261    begin
 262       N := 0;
 263       L := 1;
 264       R := 1;
 265
 266       --  Loop through ranges in output file
 267
 268       loop
 269          --  If no left ranges left, copy next right range
 270
 271          if L > LS'Last then
 272             exit when R > RS'Last;
 273             N := N + 1;
 274             Result (N) := RS (R);
 275             R := R + 1;
 276
 277          --  If no right ranges left, copy next left range
 278
 279          elsif R > RS'Last then
 280             N := N + 1;
 281             Result (N) := LS (L);
 282             L := L + 1;
 283
 284          else
 285             --  We have two ranges, choose lower one
 286
 287             N := N + 1;
 288
 289             if LS (L).Low <= RS (R).Low then
 290                Result (N) := LS (L);
 291                L := L + 1;
 292             else
 293                Result (N) := RS (R);
 294                R := R + 1;
 295             end if;
 296
 297             --  Loop to collapse ranges into last range
 298
 299             loop
 300                --  Collapse next length range into current result range
 301                --  if possible.
 302
 303                if L <= LS'Last
 304                  and then LS (L).Low <=
 305                           Wide_Wide_Character'Succ (Result (N).High)
 306                then
 307                   Result (N).High :=
 308                     Wide_Wide_Character'Max (Result (N).High, LS (L).High);
 309                   L := L + 1;
 310
 311                --  Collapse next right range into current result range
 312                --  if possible
 313
 314                elsif R <= RS'Last
 315                  and then RS (R).Low <=
 316                             Wide_Wide_Character'Succ (Result (N).High)
 317                then
 318                   Result (N).High :=
 319                     Wide_Wide_Character'Max (Result (N).High, RS (R).High);
 320                   R := R + 1;
 321
 322                --  If neither range collapses, then done with this range
 323
 324                else
 325                   exit;
 326                end if;
 327             end loop;
 328          end if;
 329       end loop;
 330
 331       return (AF.Controlled with
 332               Set => new Wide_Wide_Character_Ranges'(Result (1 .. N)));
 333    end "or";
 334
 335    -----------
 336    -- "xor" --
 337    -----------
 338
 339    function "xor"
 340      (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set
 341    is
 342    begin
 343       return (Left or Right) - (Left and Right);
 344    end "xor";
 345
 346    ------------
 347    -- Adjust --
 348    ------------
 349
 350    procedure Adjust (Object : in out Wide_Wide_Character_Mapping) is
 351    begin
 352       Object.Map := new Wide_Wide_Character_Mapping_Values'(Object.Map.all);
 353    end Adjust;
 354
 355    procedure Adjust (Object : in out Wide_Wide_Character_Set) is
 356    begin
 357       Object.Set := new Wide_Wide_Character_Ranges'(Object.Set.all);
 358    end Adjust;
 359
 360    --------------
 361    -- Finalize --
 362    --------------
 363
 364    procedure Finalize (Object : in out Wide_Wide_Character_Mapping) is
 365
 366       procedure Free is new Ada.Unchecked_Deallocation
 367         (Wide_Wide_Character_Mapping_Values,
 368          Wide_Wide_Character_Mapping_Values_Access);
 369
 370    begin
 371       if Object.Map /=  Null_Map'Unrestricted_Access then
 372          Free (Object.Map);
 373       end if;
 374    end Finalize;
 375
 376    procedure Finalize (Object : in out Wide_Wide_Character_Set) is
 377
 378       procedure Free is new Ada.Unchecked_Deallocation
 379         (Wide_Wide_Character_Ranges,
 380          Wide_Wide_Character_Ranges_Access);
 381
 382    begin
 383       if Object.Set /= Null_Range'Unrestricted_Access then
 384          Free (Object.Set);
 385       end if;
 386    end Finalize;
 387
 388    ----------------
 389    -- Initialize --
 390    ----------------
 391
 392    procedure Initialize (Object : in out Wide_Wide_Character_Mapping) is
 393    begin
 394       Object := Identity;
 395    end Initialize;
 396
 397    procedure Initialize (Object : in out Wide_Wide_Character_Set) is
 398    begin
 399       Object := Null_Set;
 400    end Initialize;
 401
 402    -----------
 403    -- Is_In --
 404    -----------
 405
 406    function Is_In
 407      (Element : Wide_Wide_Character;
 408       Set     : Wide_Wide_Character_Set) return Boolean
 409    is
 410       L, R, M : Natural;
 411       SS      : constant Wide_Wide_Character_Ranges_Access := Set.Set;
 412
 413    begin
 414       L := 1;
 415       R := SS'Last;
 416
 417       --  Binary search loop. The invariant is that if Element is in any of
 418       --  of the constituent ranges it is in one between Set (L) and Set (R).
 419
 420       loop
 421          if L > R then
 422             return False;
 423
 424          else
 425             M := (L + R) / 2;
 426
 427             if Element > SS (M).High then
 428                L := M + 1;
 429             elsif Element < SS (M).Low then
 430                R := M - 1;
 431             else
 432                return True;
 433             end if;
 434          end if;
 435       end loop;
 436    end Is_In;
 437
 438    ---------------
 439    -- Is_Subset --
 440    ---------------
 441
 442    function Is_Subset
 443      (Elements : Wide_Wide_Character_Set;
 444       Set      : Wide_Wide_Character_Set) return Boolean
 445    is
 446       ES : constant Wide_Wide_Character_Ranges_Access := Elements.Set;
 447       SS : constant Wide_Wide_Character_Ranges_Access := Set.Set;
 448
 449       S  : Positive := 1;
 450       E  : Positive := 1;
 451
 452    begin
 453       loop
 454          --  If no more element ranges, done, and result is true
 455
 456          if E > ES'Last then
 457             return True;
 458
 459          --  If more element ranges, but no more set ranges, result is false
 460
 461          elsif S > SS'Last then
 462             return False;
 463
 464          --  Remove irrelevant set range
 465
 466          elsif SS (S).High < ES (E).Low then
 467             S := S + 1;
 468
 469          --  Get rid of element range that is properly covered by set
 470
 471          elsif SS (S).Low <= ES (E).Low
 472             and then ES (E).High <= SS (S).High
 473          then
 474             E := E + 1;
 475
 476          --  Otherwise we have a non-covered element range, result is false
 477
 478          else
 479             return False;
 480          end if;
 481       end loop;
 482    end Is_Subset;
 483
 484    ---------------
 485    -- To_Domain --
 486    ---------------
 487
 488    function To_Domain
 489      (Map : Wide_Wide_Character_Mapping) return Wide_Wide_Character_Sequence
 490    is
 491    begin
 492       return Map.Map.Domain;
 493    end To_Domain;
 494
 495    ----------------
 496    -- To_Mapping --
 497    ----------------
 498
 499    function To_Mapping
 500      (From, To : Wide_Wide_Character_Sequence)
 501      return Wide_Wide_Character_Mapping
 502    is
 503       Domain : Wide_Wide_Character_Sequence (1 .. From'Length);
 504       Rangev : Wide_Wide_Character_Sequence (1 .. To'Length);
 505       N      : Natural := 0;
 506
 507    begin
 508       if From'Length /= To'Length then
 509          raise Translation_Error;
 510
 511       else
 512          pragma Warnings (Off); -- apparent uninit use of Domain
 513
 514          for J in From'Range loop
 515             for M in 1 .. N loop
 516                if From (J) = Domain (M) then
 517                   raise Translation_Error;
 518                elsif From (J) < Domain (M) then
 519                   Domain (M + 1 .. N + 1) := Domain (M .. N);
 520                   Rangev (M + 1 .. N + 1) := Rangev (M .. N);
 521                   Domain (M) := From (J);
 522                   Rangev (M) := To   (J);
 523                   goto Continue;
 524                end if;
 525             end loop;
 526
 527             Domain (N + 1) := From (J);
 528             Rangev (N + 1) := To   (J);
 529
 530             <<Continue>>
 531                N := N + 1;
 532          end loop;
 533
 534          pragma Warnings (On);
 535
 536          return (AF.Controlled with
 537                  Map => new Wide_Wide_Character_Mapping_Values'(
 538                           Length => N,
 539                           Domain => Domain (1 .. N),
 540                           Rangev => Rangev (1 .. N)));
 541       end if;
 542    end To_Mapping;
 543
 544    --------------
 545    -- To_Range --
 546    --------------
 547
 548    function To_Range
 549      (Map : Wide_Wide_Character_Mapping) return Wide_Wide_Character_Sequence
 550    is
 551    begin
 552       return Map.Map.Rangev;
 553    end To_Range;
 554
 555    ---------------
 556    -- To_Ranges --
 557    ---------------
 558
 559    function To_Ranges
 560      (Set : Wide_Wide_Character_Set) return Wide_Wide_Character_Ranges
 561    is
 562    begin
 563       return Set.Set.all;
 564    end To_Ranges;
 565
 566    -----------------
 567    -- To_Sequence --
 568    -----------------
 569
 570    function To_Sequence
 571      (Set : Wide_Wide_Character_Set) return Wide_Wide_Character_Sequence
 572    is
 573       SS : constant Wide_Wide_Character_Ranges_Access := Set.Set;
 574
 575       Result : Wide_Wide_String (Positive range 1 .. 2 ** 16);
 576       N      : Natural := 0;
 577
 578    begin
 579       for J in SS'Range loop
 580          for K in SS (J).Low .. SS (J).High loop
 581             N := N + 1;
 582             Result (N) := K;
 583          end loop;
 584       end loop;
 585
 586       return Result (1 .. N);
 587    end To_Sequence;
 588
 589    ------------
 590    -- To_Set --
 591    ------------
 592
 593    --  Case of multiple range input
 594
 595    function To_Set
 596      (Ranges : Wide_Wide_Character_Ranges) return Wide_Wide_Character_Set
 597    is
 598       Result : Wide_Wide_Character_Ranges (Ranges'Range);
 599       N      : Natural := 0;
 600       J      : Natural;
 601
 602    begin
 603       --  The output of To_Set is required to be sorted by increasing Low
 604       --  values, and discontiguous, so first we sort them as we enter them,
 605       --  using a simple insertion sort.
 606
 607       pragma Warnings (Off);
 608       --  Kill bogus warning on Result being uninitialized
 609
 610       for J in Ranges'Range loop
 611          for K in 1 .. N loop
 612             if Ranges (J).Low < Result (K).Low then
 613                Result (K + 1 .. N + 1) := Result (K .. N);
 614                Result (K) := Ranges (J);
 615                goto Continue;
 616             end if;
 617          end loop;
 618
 619          Result (N + 1) := Ranges (J);
 620
 621          <<Continue>>
 622             N := N + 1;
 623       end loop;
 624
 625       pragma Warnings (On);
 626
 627       --  Now collapse any contiguous or overlapping ranges
 628
 629       J := 1;
 630       while J < N loop
 631          if Result (J).High < Result (J).Low then
 632             N := N - 1;
 633             Result (J .. N) := Result (J + 1 .. N + 1);
 634
 635          elsif Wide_Wide_Character'Succ (Result (J).High) >=
 636            Result (J + 1).Low
 637          then
 638             Result (J).High :=
 639               Wide_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 Result (N).High < Result (N).Low then
 650          N := N - 1;
 651       end if;
 652
 653       return (AF.Controlled with
 654               Set => new Wide_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_Wide_Character_Range) return Wide_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_Wide_Character_Set of mode "out" or "in out".
 667
 668       else
 669          return (AF.Controlled with
 670                  Set => new Wide_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_Wide_Character_Sequence) return Wide_Wide_Character_Set
 678    is
 679       R : Wide_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_Wide_Character) return Wide_Wide_Character_Set
 693    is
 694    begin
 695       return
 696         (AF.Controlled with
 697          Set => new Wide_Wide_Character_Ranges'(1 => (Singleton, Singleton)));
 698    end To_Set;
 699
 700    -----------
 701    -- Value --
 702    -----------
 703
 704    function Value
 705      (Map     : Wide_Wide_Character_Mapping;
 706       Element : Wide_Wide_Character) return Wide_Wide_Character
 707    is
 708       L, R, M : Natural;
 709
 710       MV : constant Wide_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_Wide_Maps;