gcc/ada/a-strmap.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUNTIME COMPONENTS                          --
   4 --                                                                          --
   5 --                     A D A . S T R I N G S . 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 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  32 --                                                                          --
  33 ------------------------------------------------------------------------------
  34
  35 --  Note: parts of this code are derived from the ADAR.CSH public domain
  36 --  Ada 83 versions of the Appendix C string handling packages. The main
  37 --  differences are that we avoid the use of the minimize function which
  38 --  is bit-by-bit or character-by-character and therefore rather slow.
  39 --  Generally for character sets we favor the full 32-byte representation.
  40
  41 package body Ada.Strings.Maps is
  42
  43    use Ada.Characters.Latin_1;
  44
  45    ---------
  46    -- "-" --
  47    ---------
  48
  49    function "-" (Left, Right : Character_Set) return Character_Set is
  50    begin
  51       return Left and not Right;
  52    end "-";
  53
  54    ---------
  55    -- "=" --
  56    ---------
  57
  58    function "=" (Left, Right : in Character_Set) return Boolean is
  59    begin
  60       return Character_Set_Internal (Left) = Character_Set_Internal (Right);
  61    end "=";
  62
  63    -----------
  64    -- "and" --
  65    -----------
  66
  67    function "and" (Left, Right : in Character_Set) return Character_Set is
  68    begin
  69       return Character_Set
  70         (Character_Set_Internal (Left) and Character_Set_Internal (Right));
  71    end "and";
  72
  73    -----------
  74    -- "not" --
  75    -----------
  76
  77    function "not" (Right : in Character_Set) return Character_Set is
  78    begin
  79       return Character_Set (not Character_Set_Internal (Right));
  80    end "not";
  81
  82    ----------
  83    -- "or" --
  84    ----------
  85
  86    function "or" (Left, Right : in Character_Set) return Character_Set is
  87    begin
  88       return Character_Set
  89         (Character_Set_Internal (Left) or Character_Set_Internal (Right));
  90    end "or";
  91
  92    -----------
  93    -- "xor" --
  94    -----------
  95
  96    function "xor" (Left, Right : in Character_Set) return Character_Set is
  97    begin
  98       return Character_Set
  99         (Character_Set_Internal (Left) xor Character_Set_Internal (Right));
 100    end "xor";
 101
 102    -----------
 103    -- Is_In --
 104    -----------
 105
 106    function Is_In
 107      (Element : Character;
 108       Set     : Character_Set)
 109       return    Boolean
 110    is
 111    begin
 112       return Set (Element);
 113    end Is_In;
 114
 115    ---------------
 116    -- Is_Subset --
 117    ---------------
 118
 119    function Is_Subset
 120      (Elements : Character_Set;
 121       Set      : Character_Set)
 122       return     Boolean
 123    is
 124    begin
 125       return (Elements and Set) = Elements;
 126    end Is_Subset;
 127
 128    ---------------
 129    -- To_Domain --
 130    ---------------
 131
 132    function To_Domain (Map : in Character_Mapping) return Character_Sequence
 133    is
 134       Result : String (1 .. Map'Length);
 135       J      : Natural;
 136
 137    begin
 138       J := 0;
 139       for C in Map'Range loop
 140          if Map (C) /= C then
 141             J := J + 1;
 142             Result (J) := C;
 143          end if;
 144       end loop;
 145
 146       return Result (1 .. J);
 147    end To_Domain;
 148
 149    ----------------
 150    -- To_Mapping --
 151    ----------------
 152
 153    function To_Mapping
 154      (From, To : in Character_Sequence)
 155       return     Character_Mapping
 156    is
 157       Result   : Character_Mapping;
 158       Inserted : Character_Set := Null_Set;
 159       From_Len : constant Natural := From'Length;
 160       To_Len   : constant Natural := To'Length;
 161
 162    begin
 163       if From_Len /= To_Len then
 164          raise Strings.Translation_Error;
 165       end if;
 166
 167       for Char in Character loop
 168          Result (Char) := Char;
 169       end loop;
 170
 171       for J in From'Range loop
 172          if Inserted (From (J)) then
 173             raise Strings.Translation_Error;
 174          end if;
 175
 176          Result   (From (J)) := To (J - From'First + To'First);
 177          Inserted (From (J)) := True;
 178       end loop;
 179
 180       return Result;
 181    end To_Mapping;
 182
 183    --------------
 184    -- To_Range --
 185    --------------
 186
 187    function To_Range (Map : in Character_Mapping) return Character_Sequence
 188    is
 189       Result : String (1 .. Map'Length);
 190       J      : Natural;
 191
 192    begin
 193       J := 0;
 194       for C in Map'Range loop
 195          if Map (C) /= C then
 196             J := J + 1;
 197             Result (J) := Map (C);
 198          end if;
 199       end loop;
 200
 201       return Result (1 .. J);
 202    end To_Range;
 203
 204    ---------------
 205    -- To_Ranges --
 206    ---------------
 207
 208    function To_Ranges (Set : in Character_Set) return Character_Ranges is
 209       Max_Ranges : Character_Ranges (1 .. Set'Length / 2 + 1);
 210       Range_Num  : Natural;
 211       C          : Character;
 212
 213    begin
 214       C := Character'First;
 215       Range_Num := 0;
 216
 217       loop
 218          --  Skip gap between subsets.
 219
 220          while not Set (C) loop
 221             exit when C = Character'Last;
 222             C := Character'Succ (C);
 223          end loop;
 224
 225          exit when not Set (C);
 226
 227          Range_Num := Range_Num + 1;
 228          Max_Ranges (Range_Num).Low := C;
 229
 230          --  Span a subset.
 231
 232          loop
 233             exit when not Set (C) or else C = Character'Last;
 234             C := Character' Succ (C);
 235          end loop;
 236
 237          if Set (C) then
 238             Max_Ranges (Range_Num). High := C;
 239             exit;
 240          else
 241             Max_Ranges (Range_Num). High := Character'Pred (C);
 242          end if;
 243       end loop;
 244
 245       return Max_Ranges (1 .. Range_Num);
 246    end To_Ranges;
 247
 248    -----------------
 249    -- To_Sequence --
 250    -----------------
 251
 252    function To_Sequence
 253      (Set  : Character_Set)
 254       return Character_Sequence
 255    is
 256       Result : String (1 .. Character'Pos (Character'Last) + 1);
 257       Count  : Natural := 0;
 258
 259    begin
 260       for Char in Set'Range loop
 261          if Set (Char) then
 262             Count := Count + 1;
 263             Result (Count) := Char;
 264          end if;
 265       end loop;
 266
 267       return Result (1 .. Count);
 268    end To_Sequence;
 269
 270    ------------
 271    -- To_Set --
 272    ------------
 273
 274    function To_Set (Ranges : in Character_Ranges) return Character_Set is
 275       Result : Character_Set;
 276
 277    begin
 278       for C in Result'Range loop
 279          Result (C) := False;
 280       end loop;
 281
 282       for R in Ranges'Range loop
 283          for C in Ranges (R).Low .. Ranges (R).High loop
 284             Result (C) := True;
 285          end loop;
 286       end loop;
 287
 288       return Result;
 289    end To_Set;
 290
 291    function To_Set (Span   : in Character_Range) return Character_Set is
 292       Result : Character_Set;
 293
 294    begin
 295       for C in Result'Range loop
 296          Result (C) := False;
 297       end loop;
 298
 299       for C in Span.Low .. Span.High loop
 300          Result (C) := True;
 301       end loop;
 302
 303       return Result;
 304    end To_Set;
 305
 306    function To_Set (Sequence : Character_Sequence) return Character_Set is
 307       Result : Character_Set := Null_Set;
 308
 309    begin
 310       for J in Sequence'Range loop
 311          Result (Sequence (J)) := True;
 312       end loop;
 313
 314       return Result;
 315    end To_Set;
 316
 317    function To_Set (Singleton : Character) return Character_Set is
 318       Result : Character_Set := Null_Set;
 319
 320    begin
 321       Result (Singleton) := True;
 322       return Result;
 323    end To_Set;
 324
 325    -----------
 326    -- Value --
 327    -----------
 328
 329    function Value (Map : in Character_Mapping; Element : in Character)
 330       return Character is
 331
 332    begin
 333       return Map (Element);
 334    end Value;
 335
 336 end Ada.Strings.Maps;