gcc/ada/a-stwima.adb

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