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