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 --                            $Revision: 1.19 $
  10 --                                                                          --
  11 --          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
  12 --                                                                          --
  13 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- As a special exception,  if other files  instantiate  generics from this --
  25 -- unit, or you link  this unit with other files  to produce an executable, --
  26 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27 -- covered  by the  GNU  General  Public  License.  This exception does not --
  28 -- however invalidate  any other reasons why  the executable file  might be --
  29 -- covered by the  GNU Public License.                                      --
  30 --                                                                          --
  31 -- GNAT was originally developed  by the GNAT team at  New York University. --
  32 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  33 --                                                                          --
  34 ------------------------------------------------------------------------------
  35
  36 --  Note: parts of this code are derived from the ADAR.CSH public domain
  37 --  Ada 83 versions of the Appendix C string handling packages. The main
  38 --  differences are that we avoid the use of the minimize function which
  39 --  is bit-by-bit or character-by-character and therefore rather slow.
  40 --  Generally for character sets we favor the full 32-byte representation.
  41
  42 package body Ada.Strings.Maps is
  43
  44    use Ada.Characters.Latin_1;
  45
  46    ---------
  47    -- "-" --
  48    ---------
  49
  50    function "-" (Left, Right : Character_Set) return Character_Set is
  51    begin
  52       return Left and not Right;
  53    end "-";
  54
  55    ---------
  56    -- "=" --
  57    ---------
  58
  59    function "=" (Left, Right : in Character_Set) return Boolean is
  60    begin
  61       return Character_Set_Internal (Left) = Character_Set_Internal (Right);
  62    end "=";
  63
  64    -----------
  65    -- "and" --
  66    -----------
  67
  68    function "and" (Left, Right : in Character_Set) return Character_Set is
  69    begin
  70       return Character_Set
  71         (Character_Set_Internal (Left) and Character_Set_Internal (Right));
  72    end "and";
  73
  74    -----------
  75    -- "not" --
  76    -----------
  77
  78    function "not" (Right : in Character_Set) return Character_Set is
  79    begin
  80       return Character_Set (not Character_Set_Internal (Right));
  81    end "not";
  82
  83    ----------
  84    -- "or" --
  85    ----------
  86
  87    function "or" (Left, Right : in Character_Set) return Character_Set is
  88    begin
  89       return Character_Set
  90         (Character_Set_Internal (Left) or Character_Set_Internal (Right));
  91    end "or";
  92
  93    -----------
  94    -- "xor" --
  95    -----------
  96
  97    function "xor" (Left, Right : in Character_Set) return Character_Set is
  98    begin
  99       return Character_Set
 100         (Character_Set_Internal (Left) xor Character_Set_Internal (Right));
 101    end "xor";
 102
 103    -----------
 104    -- Is_In --
 105    -----------
 106
 107    function Is_In
 108      (Element : Character;
 109       Set     : Character_Set)
 110       return    Boolean
 111    is
 112    begin
 113       return Set (Element);
 114    end Is_In;
 115
 116    ---------------
 117    -- Is_Subset --
 118    ---------------
 119
 120    function Is_Subset
 121      (Elements : Character_Set;
 122       Set      : Character_Set)
 123       return     Boolean
 124    is
 125    begin
 126       return (Elements and Set) = Elements;
 127    end Is_Subset;
 128
 129    ---------------
 130    -- To_Domain --
 131    ---------------
 132
 133    function To_Domain (Map : in Character_Mapping) return Character_Sequence
 134    is
 135       Result : String (1 .. Map'Length);
 136       J      : Natural;
 137
 138    begin
 139       J := 0;
 140       for C in Map'Range loop
 141          if Map (C) /= C then
 142             J := J + 1;
 143             Result (J) := C;
 144          end if;
 145       end loop;
 146
 147       return Result (1 .. J);
 148    end To_Domain;
 149
 150    ----------------
 151    -- To_Mapping --
 152    ----------------
 153
 154    function To_Mapping
 155      (From, To : in Character_Sequence)
 156       return     Character_Mapping
 157    is
 158       Result   : Character_Mapping;
 159       Inserted : Character_Set := Null_Set;
 160       From_Len : constant Natural := From'Length;
 161       To_Len   : constant Natural := To'Length;
 162
 163    begin
 164       if From_Len /= To_Len then
 165          raise Strings.Translation_Error;
 166       end if;
 167
 168       for Char in Character loop
 169          Result (Char) := Char;
 170       end loop;
 171
 172       for J in From'Range loop
 173          if Inserted (From (J)) then
 174             raise Strings.Translation_Error;
 175          end if;
 176
 177          Result   (From (J)) := To (J - From'First + To'First);
 178          Inserted (From (J)) := True;
 179       end loop;
 180
 181       return Result;
 182    end To_Mapping;
 183
 184    --------------
 185    -- To_Range --
 186    --------------
 187
 188    function To_Range (Map : in Character_Mapping) return Character_Sequence
 189    is
 190       Result : String (1 .. Map'Length);
 191       J      : Natural;
 192
 193    begin
 194       J := 0;
 195       for C in Map'Range loop
 196          if Map (C) /= C then
 197             J := J + 1;
 198             Result (J) := Map (C);
 199          end if;
 200       end loop;
 201
 202       return Result (1 .. J);
 203    end To_Range;
 204
 205    ---------------
 206    -- To_Ranges --
 207    ---------------
 208
 209    function To_Ranges (Set : in Character_Set) return Character_Ranges is
 210       Max_Ranges : Character_Ranges (1 .. Set'Length / 2 + 1);
 211       Range_Num  : Natural;
 212       C          : Character;
 213
 214    begin
 215       C := Character'First;
 216       Range_Num := 0;
 217
 218       loop
 219          --  Skip gap between subsets.
 220
 221          while not Set (C) loop
 222             exit when C = Character'Last;
 223             C := Character'Succ (C);
 224          end loop;
 225
 226          exit when not Set (C);
 227
 228          Range_Num := Range_Num + 1;
 229          Max_Ranges (Range_Num).Low := C;
 230
 231          --  Span a subset.
 232
 233          loop
 234             exit when not Set (C) or else C = Character'Last;
 235             C := Character' Succ (C);
 236          end loop;
 237
 238          if Set (C) then
 239             Max_Ranges (Range_Num). High := C;
 240             exit;
 241          else
 242             Max_Ranges (Range_Num). High := Character'Pred (C);
 243          end if;
 244       end loop;
 245
 246       return Max_Ranges (1 .. Range_Num);
 247    end To_Ranges;
 248
 249    -----------------
 250    -- To_Sequence --
 251    -----------------
 252
 253    function To_Sequence
 254      (Set  : Character_Set)
 255       return Character_Sequence
 256    is
 257       Result : String (1 .. Character'Pos (Character'Last) + 1);
 258       Count  : Natural := 0;
 259
 260    begin
 261       for Char in Set'Range loop
 262          if Set (Char) then
 263             Count := Count + 1;
 264             Result (Count) := Char;
 265          end if;
 266       end loop;
 267
 268       return Result (1 .. Count);
 269    end To_Sequence;
 270
 271    ------------
 272    -- To_Set --
 273    ------------
 274
 275    function To_Set (Ranges : in Character_Ranges) return Character_Set is
 276       Result : Character_Set;
 277
 278    begin
 279       for C in Result'Range loop
 280          Result (C) := False;
 281       end loop;
 282
 283       for R in Ranges'Range loop
 284          for C in Ranges (R).Low .. Ranges (R).High loop
 285             Result (C) := True;
 286          end loop;
 287       end loop;
 288
 289       return Result;
 290    end To_Set;
 291
 292    function To_Set (Span   : in Character_Range) return Character_Set is
 293       Result : Character_Set;
 294
 295    begin
 296       for C in Result'Range loop
 297          Result (C) := False;
 298       end loop;
 299
 300       for C in Span.Low .. Span.High loop
 301          Result (C) := True;
 302       end loop;
 303
 304       return Result;
 305    end To_Set;
 306
 307    function To_Set (Sequence : Character_Sequence) return Character_Set is
 308       Result : Character_Set := Null_Set;
 309
 310    begin
 311       for J in Sequence'Range loop
 312          Result (Sequence (J)) := True;
 313       end loop;
 314
 315       return Result;
 316    end To_Set;
 317
 318    function To_Set (Singleton : Character) return Character_Set is
 319       Result : Character_Set := Null_Set;
 320
 321    begin
 322       Result (Singleton) := True;
 323       return Result;
 324    end To_Set;
 325
 326    -----------
 327    -- Value --
 328    -----------
 329
 330    function Value (Map : in Character_Mapping; Element : in Character)
 331       return Character is
 332
 333    begin
 334       return Map (Element);
 335    end Value;
 336
 337 end Ada.Strings.Maps;