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