gcc/ada/a-stwima.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --                A D A . S T R I N G S . W I D E _ M A P S                 --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2005 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_Maps is
  37
  38    ---------
  39    -- "-" --
  40    ---------
  41
  42    function "-"
  43      (Left, Right : Wide_Character_Set) return Wide_Character_Set
  44    is
  45       LS : constant Wide_Character_Ranges_Access := Left.Set;
  46       RS : constant Wide_Character_Ranges_Access := Right.Set;
  47
  48       Result : 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_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
  73          --  of 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_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_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_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_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 : in 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_Character_Set) return Wide_Character_Set
 162    is
 163       LS : constant Wide_Character_Ranges_Access := Left.Set;
 164       RS : constant Wide_Character_Ranges_Access := Right.Set;
 165
 166       Result : 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 := Wide_Character'Max (LS (L).Low,  RS (R).Low);
 188             Result (N).High :=
 189               Wide_Character'Min (LS (L).High, RS (R).High);
 190
 191             if RS (R).High = LS (L).High then
 192                L := L + 1;
 193                R := R + 1;
 194             elsif RS (R).High < LS (L).High then
 195                R := R + 1;
 196             else
 197                L := L + 1;
 198             end if;
 199          end if;
 200       end loop;
 201
 202       return (AF.Controlled with
 203               Set       => new Wide_Character_Ranges'(Result (1 .. N)));
 204    end "and";
 205
 206    -----------
 207    -- "not" --
 208    -----------
 209
 210    function "not"
 211      (Right : Wide_Character_Set) return Wide_Character_Set
 212    is
 213       RS : constant Wide_Character_Ranges_Access := Right.Set;
 214
 215       Result : Wide_Character_Ranges (1 .. RS'Last + 1);
 216       N      : Natural := 0;
 217
 218    begin
 219       if RS'Last = 0 then
 220          N := 1;
 221          Result (1) := (Low  => Wide_Character'First,
 222                         High => Wide_Character'Last);
 223
 224       else
 225          if RS (1).Low /= Wide_Character'First then
 226             N := N + 1;
 227             Result (N).Low  := Wide_Character'First;
 228             Result (N).High := Wide_Character'Pred (RS (1).Low);
 229          end if;
 230
 231          for K in 1 .. RS'Last - 1 loop
 232             N := N + 1;
 233             Result (N).Low  := Wide_Character'Succ (RS (K).High);
 234             Result (N).High := Wide_Character'Pred (RS (K + 1).Low);
 235          end loop;
 236
 237          if RS (RS'Last).High /= Wide_Character'Last then
 238             N := N + 1;
 239             Result (N).Low  := Wide_Character'Succ (RS (RS'Last).High);
 240             Result (N).High := Wide_Character'Last;
 241          end if;
 242       end if;
 243
 244       return (AF.Controlled with
 245               Set => new Wide_Character_Ranges'(Result (1 .. N)));
 246    end "not";
 247
 248    ----------
 249    -- "or" --
 250    ----------
 251
 252    function "or"
 253      (Left, Right : Wide_Character_Set) return Wide_Character_Set
 254    is
 255       LS : constant Wide_Character_Ranges_Access := Left.Set;
 256       RS : constant Wide_Character_Ranges_Access := Right.Set;
 257
 258       Result : Wide_Character_Ranges (1 .. LS'Last + RS'Last);
 259       N      : Natural;
 260       L, R   : Natural;
 261
 262    begin
 263       N := 0;
 264       L := 1;
 265       R := 1;
 266
 267       --  Loop through ranges in output file
 268
 269       loop
 270          --  If no left ranges left, copy next right range
 271
 272          if L > LS'Last then
 273             exit when R > RS'Last;
 274             N := N + 1;
 275             Result (N) := RS (R);
 276             R := R + 1;
 277
 278          --  If no right ranges left, copy next left range
 279
 280          elsif R > RS'Last then
 281             N := N + 1;
 282             Result (N) := LS (L);
 283             L := L + 1;
 284
 285          else
 286             --  We have two ranges, choose lower one
 287
 288             N := N + 1;
 289
 290             if LS (L).Low <= RS (R).Low then
 291                Result (N) := LS (L);
 292                L := L + 1;
 293             else
 294                Result (N) := RS (R);
 295                R := R + 1;
 296             end if;
 297
 298             --  Loop to collapse ranges into last range
 299
 300             loop
 301                --  Collapse next length range into current result range
 302                --  if possible.
 303
 304                if L <= LS'Last
 305                  and then LS (L).Low <= Wide_Character'Succ (Result (N).High)
 306                then
 307                   Result (N).High :=
 308                     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_Character'Succ (Result (N).High)
 317                then
 318                   Result (N).High :=
 319                     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_Character_Ranges'(Result (1 .. N)));
 333    end "or";
 334
 335    -----------
 336    -- "xor" --
 337    -----------
 338
 339    function "xor"
 340      (Left, Right : Wide_Character_Set) return 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_Character_Mapping) is
 351    begin
 352       Object.Map := new Wide_Character_Mapping_Values'(Object.Map.all);
 353    end Adjust;
 354
 355    procedure Adjust (Object : in out Wide_Character_Set) is
 356    begin
 357       Object.Set := new Wide_Character_Ranges'(Object.Set.all);
 358    end Adjust;
 359
 360    --------------
 361    -- Finalize --
 362    --------------
 363
 364    procedure Finalize (Object : in out Wide_Character_Mapping) is
 365
 366       procedure Free is new Unchecked_Deallocation
 367         (Wide_Character_Mapping_Values,
 368          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_Character_Set) is
 377
 378       procedure Free is new Unchecked_Deallocation
 379         (Wide_Character_Ranges,
 380          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_Character_Mapping) is
 393    begin
 394       Object := Identity;
 395    end Initialize;
 396
 397    procedure Initialize (Object : in out 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_Character;
 408       Set     : Wide_Character_Set) return Boolean
 409    is
 410       L, R, M : Natural;
 411       SS      : constant 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_Character_Set;
 444       Set      : Wide_Character_Set) return Boolean
 445    is
 446       ES : constant Wide_Character_Ranges_Access := Elements.Set;
 447       SS : constant 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_Character_Mapping) return 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_Character_Sequence) return Wide_Character_Mapping
 501    is
 502       Domain : Wide_Character_Sequence (1 .. From'Length);
 503       Rangev : Wide_Character_Sequence (1 .. To'Length);
 504       N      : Natural := 0;
 505
 506    begin
 507       if From'Length /= To'Length then
 508          raise Translation_Error;
 509
 510       else
 511          pragma Warnings (Off); -- apparent uninit use of Domain
 512
 513          for J in From'Range loop
 514             for M in 1 .. N loop
 515                if From (J) = Domain (M) then
 516                   raise Translation_Error;
 517                elsif From (J) < Domain (M) then
 518                   Domain (M + 1 .. N + 1) := Domain (M .. N);
 519                   Rangev (M + 1 .. N + 1) := Rangev (M .. N);
 520                   Domain (M) := From (J);
 521                   Rangev (M) := To   (J);
 522                   goto Continue;
 523                end if;
 524             end loop;
 525
 526             Domain (N + 1) := From (J);
 527             Rangev (N + 1) := To   (J);
 528
 529             <<Continue>>
 530                N := N + 1;
 531          end loop;
 532
 533          pragma Warnings (On);
 534
 535          return (AF.Controlled with
 536                  Map => new Wide_Character_Mapping_Values'(
 537                           Length => N,
 538                           Domain => Domain (1 .. N),
 539                           Rangev => Rangev (1 .. N)));
 540       end if;
 541    end To_Mapping;
 542
 543    --------------
 544    -- To_Range --
 545    --------------
 546
 547    function To_Range
 548      (Map : Wide_Character_Mapping) return Wide_Character_Sequence
 549    is
 550    begin
 551       return Map.Map.Rangev;
 552    end To_Range;
 553
 554    ---------------
 555    -- To_Ranges --
 556    ---------------
 557
 558    function To_Ranges
 559      (Set :  in Wide_Character_Set) return Wide_Character_Ranges
 560    is
 561    begin
 562       return Set.Set.all;
 563    end To_Ranges;
 564
 565    -----------------
 566    -- To_Sequence --
 567    -----------------
 568
 569    function To_Sequence
 570      (Set : Wide_Character_Set) return Wide_Character_Sequence
 571    is
 572       SS : constant Wide_Character_Ranges_Access := Set.Set;
 573
 574       Result : Wide_String (Positive range 1 .. 2 ** 16);
 575       N      : Natural := 0;
 576
 577    begin
 578       for J in SS'Range loop
 579          for K in SS (J).Low .. SS (J).High loop
 580             N := N + 1;
 581             Result (N) := K;
 582          end loop;
 583       end loop;
 584
 585       return Result (1 .. N);
 586    end To_Sequence;
 587
 588    ------------
 589    -- To_Set --
 590    ------------
 591
 592    --  Case of multiple range input
 593
 594    function To_Set
 595      (Ranges : Wide_Character_Ranges) return Wide_Character_Set
 596    is
 597       Result : Wide_Character_Ranges (Ranges'Range);
 598       N      : Natural := 0;
 599       J      : Natural;
 600
 601    begin
 602       --  The output of To_Set is required to be sorted by increasing Low
 603       --  values, and discontiguous, so first we sort them as we enter them,
 604       --  using a simple insertion sort.
 605
 606       pragma Warnings (Off);
 607       --  Kill bogus warning on Result being uninitialized
 608
 609       for J in Ranges'Range loop
 610          for K in 1 .. N loop
 611             if Ranges (J).Low < Result (K).Low then
 612                Result (K + 1 .. N + 1) := Result (K .. N);
 613                Result (K) := Ranges (J);
 614                goto Continue;
 615             end if;
 616          end loop;
 617
 618          Result (N + 1) := Ranges (J);
 619
 620          <<Continue>>
 621             N := N + 1;
 622       end loop;
 623
 624       pragma Warnings (On);
 625
 626       --  Now collapse any contiguous or overlapping ranges
 627
 628       J := 1;
 629       while J < N loop
 630          if Result (J).High < Result (J).Low then
 631             N := N - 1;
 632             Result (J .. N) := Result (J + 1 .. N + 1);
 633
 634          elsif Wide_Character'Succ (Result (J).High) >= Result (J + 1).Low then
 635             Result (J).High :=
 636               Wide_Character'Max (Result (J).High, Result (J + 1).High);
 637
 638             N := N - 1;
 639             Result (J + 1 .. N) := Result (J + 2 .. N + 1);
 640
 641          else
 642             J := J + 1;
 643          end if;
 644       end loop;
 645
 646       if Result (N).High < Result (N).Low then
 647          N := N - 1;
 648       end if;
 649
 650       return (AF.Controlled with
 651               Set => new Wide_Character_Ranges'(Result (1 .. N)));
 652    end To_Set;
 653
 654    --  Case of single range input
 655
 656    function To_Set
 657      (Span : Wide_Character_Range) return Wide_Character_Set
 658    is
 659    begin
 660       if Span.Low > Span.High then
 661          return Null_Set;
 662          --  This is safe, because there is no procedure with parameter
 663          --  Wide_Character_Set of mode "out" or "in out".
 664
 665       else
 666          return (AF.Controlled with
 667                  Set => new Wide_Character_Ranges'(1 => Span));
 668       end if;
 669    end To_Set;
 670
 671    --  Case of wide string input
 672
 673    function To_Set
 674      (Sequence : Wide_Character_Sequence) return Wide_Character_Set
 675    is
 676       R : Wide_Character_Ranges (1 .. Sequence'Length);
 677
 678    begin
 679       for J in R'Range loop
 680          R (J) := (Sequence (J), Sequence (J));
 681       end loop;
 682
 683       return To_Set (R);
 684    end To_Set;
 685
 686    --  Case of single wide character input
 687
 688    function To_Set
 689      (Singleton : Wide_Character) return Wide_Character_Set
 690    is
 691    begin
 692       return
 693         (AF.Controlled with
 694          Set => new Wide_Character_Ranges'(1 => (Singleton, Singleton)));
 695    end To_Set;
 696
 697    -----------
 698    -- Value --
 699    -----------
 700
 701    function Value
 702      (Map     : Wide_Character_Mapping;
 703       Element : Wide_Character) return Wide_Character
 704    is
 705       L, R, M : Natural;
 706
 707       MV : constant Wide_Character_Mapping_Values_Access := Map.Map;
 708
 709    begin
 710       L := 1;
 711       R := MV.Domain'Last;
 712
 713       --  Binary search loop
 714
 715       loop
 716          --  If not found, identity
 717
 718          if L > R then
 719             return Element;
 720
 721          --  Otherwise do binary divide
 722
 723          else
 724             M := (L + R) / 2;
 725
 726             if Element < MV.Domain (M) then
 727                R := M - 1;
 728
 729             elsif Element > MV.Domain (M) then
 730                L := M + 1;
 731
 732             else --  Element = MV.Domain (M) then
 733                return MV.Rangev (M);
 734             end if;
 735          end if;
 736       end loop;
 737    end Value;
 738
 739 end Ada.Strings.Wide_Maps;