gcc/ada/a-chahan.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --              A D A . C H A R A C T E R S . H A N D L I N G               --
   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 with Ada.Characters.Latin_1;      use Ada.Characters.Latin_1;
  36 with Ada.Strings.Maps;            use Ada.Strings.Maps;
  37 with Ada.Strings.Maps.Constants;  use Ada.Strings.Maps.Constants;
  38
  39 package body Ada.Characters.Handling is
  40
  41    ------------------------------------
  42    -- Character Classification Table --
  43    ------------------------------------
  44
  45    type Character_Flags is mod 256;
  46    for Character_Flags'Size use 8;
  47
  48    Control    : constant Character_Flags := 1;
  49    Lower      : constant Character_Flags := 2;
  50    Upper      : constant Character_Flags := 4;
  51    Basic      : constant Character_Flags := 8;
  52    Hex_Digit  : constant Character_Flags := 16;
  53    Digit      : constant Character_Flags := 32;
  54    Special    : constant Character_Flags := 64;
  55
  56    Letter     : constant Character_Flags := Lower or Upper;
  57    Alphanum   : constant Character_Flags := Letter or Digit;
  58    Graphic    : constant Character_Flags := Alphanum or Special;
  59
  60    Char_Map : constant array (Character) of Character_Flags :=
  61    (
  62      NUL                         => Control,
  63      SOH                         => Control,
  64      STX                         => Control,
  65      ETX                         => Control,
  66      EOT                         => Control,
  67      ENQ                         => Control,
  68      ACK                         => Control,
  69      BEL                         => Control,
  70      BS                          => Control,
  71      HT                          => Control,
  72      LF                          => Control,
  73      VT                          => Control,
  74      FF                          => Control,
  75      CR                          => Control,
  76      SO                          => Control,
  77      SI                          => Control,
  78
  79      DLE                         => Control,
  80      DC1                         => Control,
  81      DC2                         => Control,
  82      DC3                         => Control,
  83      DC4                         => Control,
  84      NAK                         => Control,
  85      SYN                         => Control,
  86      ETB                         => Control,
  87      CAN                         => Control,
  88      EM                          => Control,
  89      SUB                         => Control,
  90      ESC                         => Control,
  91      FS                          => Control,
  92      GS                          => Control,
  93      RS                          => Control,
  94      US                          => Control,
  95
  96      Space                       => Special,
  97      Exclamation                 => Special,
  98      Quotation                   => Special,
  99      Number_Sign                 => Special,
 100      Dollar_Sign                 => Special,
 101      Percent_Sign                => Special,
 102      Ampersand                   => Special,
 103      Apostrophe                  => Special,
 104      Left_Parenthesis            => Special,
 105      Right_Parenthesis           => Special,
 106      Asterisk                    => Special,
 107      Plus_Sign                   => Special,
 108      Comma                       => Special,
 109      Hyphen                      => Special,
 110      Full_Stop                   => Special,
 111      Solidus                     => Special,
 112
 113      '0' .. '9'                  => Digit + Hex_Digit,
 114
 115      Colon                       => Special,
 116      Semicolon                   => Special,
 117      Less_Than_Sign              => Special,
 118      Equals_Sign                 => Special,
 119      Greater_Than_Sign           => Special,
 120      Question                    => Special,
 121      Commercial_At               => Special,
 122
 123      'A' .. 'F'                  => Upper + Basic + Hex_Digit,
 124      'G' .. 'Z'                  => Upper + Basic,
 125
 126      Left_Square_Bracket         => Special,
 127      Reverse_Solidus             => Special,
 128      Right_Square_Bracket        => Special,
 129      Circumflex                  => Special,
 130      Low_Line                    => Special,
 131      Grave                       => Special,
 132
 133      'a' .. 'f'                  => Lower + Basic + Hex_Digit,
 134      'g' .. 'z'                  => Lower + Basic,
 135
 136      Left_Curly_Bracket          => Special,
 137      Vertical_Line               => Special,
 138      Right_Curly_Bracket         => Special,
 139      Tilde                       => Special,
 140
 141      DEL                         => Control,
 142      Reserved_128                => Control,
 143      Reserved_129                => Control,
 144      BPH                         => Control,
 145      NBH                         => Control,
 146      Reserved_132                => Control,
 147      NEL                         => Control,
 148      SSA                         => Control,
 149      ESA                         => Control,
 150      HTS                         => Control,
 151      HTJ                         => Control,
 152      VTS                         => Control,
 153      PLD                         => Control,
 154      PLU                         => Control,
 155      RI                          => Control,
 156      SS2                         => Control,
 157      SS3                         => Control,
 158
 159      DCS                         => Control,
 160      PU1                         => Control,
 161      PU2                         => Control,
 162      STS                         => Control,
 163      CCH                         => Control,
 164      MW                          => Control,
 165      SPA                         => Control,
 166      EPA                         => Control,
 167
 168      SOS                         => Control,
 169      Reserved_153                => Control,
 170      SCI                         => Control,
 171      CSI                         => Control,
 172      ST                          => Control,
 173      OSC                         => Control,
 174      PM                          => Control,
 175      APC                         => Control,
 176
 177      No_Break_Space              => Special,
 178      Inverted_Exclamation        => Special,
 179      Cent_Sign                   => Special,
 180      Pound_Sign                  => Special,
 181      Currency_Sign               => Special,
 182      Yen_Sign                    => Special,
 183      Broken_Bar                  => Special,
 184      Section_Sign                => Special,
 185      Diaeresis                   => Special,
 186      Copyright_Sign              => Special,
 187      Feminine_Ordinal_Indicator  => Special,
 188      Left_Angle_Quotation        => Special,
 189      Not_Sign                    => Special,
 190      Soft_Hyphen                 => Special,
 191      Registered_Trade_Mark_Sign  => Special,
 192      Macron                      => Special,
 193      Degree_Sign                 => Special,
 194      Plus_Minus_Sign             => Special,
 195      Superscript_Two             => Special,
 196      Superscript_Three           => Special,
 197      Acute                       => Special,
 198      Micro_Sign                  => Special,
 199      Pilcrow_Sign                => Special,
 200      Middle_Dot                  => Special,
 201      Cedilla                     => Special,
 202      Superscript_One             => Special,
 203      Masculine_Ordinal_Indicator => Special,
 204      Right_Angle_Quotation       => Special,
 205      Fraction_One_Quarter        => Special,
 206      Fraction_One_Half           => Special,
 207      Fraction_Three_Quarters     => Special,
 208      Inverted_Question           => Special,
 209
 210      UC_A_Grave                  => Upper,
 211      UC_A_Acute                  => Upper,
 212      UC_A_Circumflex             => Upper,
 213      UC_A_Tilde                  => Upper,
 214      UC_A_Diaeresis              => Upper,
 215      UC_A_Ring                   => Upper,
 216      UC_AE_Diphthong             => Upper + Basic,
 217      UC_C_Cedilla                => Upper,
 218      UC_E_Grave                  => Upper,
 219      UC_E_Acute                  => Upper,
 220      UC_E_Circumflex             => Upper,
 221      UC_E_Diaeresis              => Upper,
 222      UC_I_Grave                  => Upper,
 223      UC_I_Acute                  => Upper,
 224      UC_I_Circumflex             => Upper,
 225      UC_I_Diaeresis              => Upper,
 226      UC_Icelandic_Eth            => Upper + Basic,
 227      UC_N_Tilde                  => Upper,
 228      UC_O_Grave                  => Upper,
 229      UC_O_Acute                  => Upper,
 230      UC_O_Circumflex             => Upper,
 231      UC_O_Tilde                  => Upper,
 232      UC_O_Diaeresis              => Upper,
 233
 234      Multiplication_Sign         => Special,
 235
 236      UC_O_Oblique_Stroke         => Upper,
 237      UC_U_Grave                  => Upper,
 238      UC_U_Acute                  => Upper,
 239      UC_U_Circumflex             => Upper,
 240      UC_U_Diaeresis              => Upper,
 241      UC_Y_Acute                  => Upper,
 242      UC_Icelandic_Thorn          => Upper + Basic,
 243
 244      LC_German_Sharp_S           => Lower + Basic,
 245      LC_A_Grave                  => Lower,
 246      LC_A_Acute                  => Lower,
 247      LC_A_Circumflex             => Lower,
 248      LC_A_Tilde                  => Lower,
 249      LC_A_Diaeresis              => Lower,
 250      LC_A_Ring                   => Lower,
 251      LC_AE_Diphthong             => Lower + Basic,
 252      LC_C_Cedilla                => Lower,
 253      LC_E_Grave                  => Lower,
 254      LC_E_Acute                  => Lower,
 255      LC_E_Circumflex             => Lower,
 256      LC_E_Diaeresis              => Lower,
 257      LC_I_Grave                  => Lower,
 258      LC_I_Acute                  => Lower,
 259      LC_I_Circumflex             => Lower,
 260      LC_I_Diaeresis              => Lower,
 261      LC_Icelandic_Eth            => Lower + Basic,
 262      LC_N_Tilde                  => Lower,
 263      LC_O_Grave                  => Lower,
 264      LC_O_Acute                  => Lower,
 265      LC_O_Circumflex             => Lower,
 266      LC_O_Tilde                  => Lower,
 267      LC_O_Diaeresis              => Lower,
 268
 269      Division_Sign               => Special,
 270
 271      LC_O_Oblique_Stroke         => Lower,
 272      LC_U_Grave                  => Lower,
 273      LC_U_Acute                  => Lower,
 274      LC_U_Circumflex             => Lower,
 275      LC_U_Diaeresis              => Lower,
 276      LC_Y_Acute                  => Lower,
 277      LC_Icelandic_Thorn          => Lower + Basic,
 278      LC_Y_Diaeresis              => Lower
 279    );
 280
 281    ---------------------
 282    -- Is_Alphanumeric --
 283    ---------------------
 284
 285    function Is_Alphanumeric (Item : in Character) return Boolean is
 286    begin
 287       return (Char_Map (Item) and Alphanum) /= 0;
 288    end Is_Alphanumeric;
 289
 290    --------------
 291    -- Is_Basic --
 292    --------------
 293
 294    function Is_Basic (Item : in Character) return Boolean is
 295    begin
 296       return (Char_Map (Item) and Basic) /= 0;
 297    end Is_Basic;
 298
 299    ------------------
 300    -- Is_Character --
 301    ------------------
 302
 303    function Is_Character (Item : in Wide_Character) return Boolean is
 304    begin
 305       return Wide_Character'Pos (Item) < 256;
 306    end Is_Character;
 307
 308    ----------------
 309    -- Is_Control --
 310    ----------------
 311
 312    function Is_Control (Item : in Character) return Boolean is
 313    begin
 314       return (Char_Map (Item) and Control) /= 0;
 315    end Is_Control;
 316
 317    --------------
 318    -- Is_Digit --
 319    --------------
 320
 321    function Is_Digit (Item : in Character) return Boolean is
 322    begin
 323       return Item in '0' .. '9';
 324    end Is_Digit;
 325
 326    ----------------
 327    -- Is_Graphic --
 328    ----------------
 329
 330    function Is_Graphic (Item : in Character) return Boolean is
 331    begin
 332       return (Char_Map (Item) and Graphic) /= 0;
 333    end Is_Graphic;
 334
 335    --------------------------
 336    -- Is_Hexadecimal_Digit --
 337    --------------------------
 338
 339    function Is_Hexadecimal_Digit (Item : in Character) return Boolean is
 340    begin
 341       return (Char_Map (Item) and Hex_Digit) /= 0;
 342    end Is_Hexadecimal_Digit;
 343
 344    ----------------
 345    -- Is_ISO_646 --
 346    ----------------
 347
 348    function Is_ISO_646 (Item : in Character) return Boolean is
 349    begin
 350       return Item in ISO_646;
 351    end Is_ISO_646;
 352
 353    --  Note: much more efficient coding of the following function is possible
 354    --  by testing several 16#80# bits in a complete word in a single operation
 355
 356    function Is_ISO_646 (Item : in String) return Boolean is
 357    begin
 358       for J in Item'Range loop
 359          if Item (J) not in ISO_646 then
 360             return False;
 361          end if;
 362       end loop;
 363
 364       return True;
 365    end Is_ISO_646;
 366
 367    ---------------
 368    -- Is_Letter --
 369    ---------------
 370
 371    function Is_Letter (Item : in Character) return Boolean is
 372    begin
 373       return (Char_Map (Item) and Letter) /= 0;
 374    end Is_Letter;
 375
 376    --------------
 377    -- Is_Lower --
 378    --------------
 379
 380    function Is_Lower (Item : in Character) return Boolean is
 381    begin
 382       return (Char_Map (Item) and Lower) /= 0;
 383    end Is_Lower;
 384
 385    ----------------
 386    -- Is_Special --
 387    ----------------
 388
 389    function Is_Special (Item : in Character) return Boolean is
 390    begin
 391       return (Char_Map (Item) and Special) /= 0;
 392    end Is_Special;
 393
 394    ---------------
 395    -- Is_String --
 396    ---------------
 397
 398    function Is_String (Item : in Wide_String) return Boolean is
 399    begin
 400       for J in Item'Range loop
 401          if Wide_Character'Pos (Item (J)) >= 256 then
 402             return False;
 403          end if;
 404       end loop;
 405
 406       return True;
 407    end Is_String;
 408
 409    --------------
 410    -- Is_Upper --
 411    --------------
 412
 413    function Is_Upper (Item : in Character) return Boolean is
 414    begin
 415       return (Char_Map (Item) and Upper) /= 0;
 416    end Is_Upper;
 417
 418    --------------
 419    -- To_Basic --
 420    --------------
 421
 422    function To_Basic (Item : in Character) return Character is
 423    begin
 424       return Value (Basic_Map, Item);
 425    end To_Basic;
 426
 427    function To_Basic (Item : in String) return String is
 428       Result : String (1 .. Item'Length);
 429
 430    begin
 431       for J in Item'Range loop
 432          Result (J - (Item'First - 1)) := Value (Basic_Map, Item (J));
 433       end loop;
 434
 435       return Result;
 436    end To_Basic;
 437
 438    ------------------
 439    -- To_Character --
 440    ------------------
 441
 442    function To_Character
 443      (Item       : in Wide_Character;
 444       Substitute : in Character := ' ')
 445       return       Character
 446    is
 447    begin
 448       if Is_Character (Item) then
 449          return Character'Val (Wide_Character'Pos (Item));
 450       else
 451          return Substitute;
 452       end if;
 453    end To_Character;
 454
 455    ----------------
 456    -- To_ISO_646 --
 457    ----------------
 458
 459    function To_ISO_646
 460      (Item       : in Character;
 461       Substitute : in ISO_646 := ' ')
 462       return       ISO_646
 463    is
 464    begin
 465       if Item in ISO_646 then
 466          return Item;
 467       else
 468          return Substitute;
 469       end if;
 470    end To_ISO_646;
 471
 472    function To_ISO_646
 473      (Item       : in String;
 474       Substitute : in ISO_646 := ' ')
 475       return       String
 476    is
 477       Result : String (1 .. Item'Length);
 478
 479    begin
 480       for J in Item'Range loop
 481          if Item (J) in ISO_646 then
 482             Result (J - (Item'First - 1)) := Item (J);
 483          else
 484             Result (J - (Item'First - 1)) := Substitute;
 485          end if;
 486       end loop;
 487
 488       return Result;
 489    end To_ISO_646;
 490
 491    --------------
 492    -- To_Lower --
 493    --------------
 494
 495    function To_Lower (Item : in Character) return Character is
 496    begin
 497       return Value (Lower_Case_Map, Item);
 498    end To_Lower;
 499
 500    function To_Lower (Item : in String) return String is
 501       Result : String (1 .. Item'Length);
 502
 503    begin
 504       for J in Item'Range loop
 505          Result (J - (Item'First - 1)) := Value (Lower_Case_Map, Item (J));
 506       end loop;
 507
 508       return Result;
 509    end To_Lower;
 510
 511    ---------------
 512    -- To_String --
 513    ---------------
 514
 515    function To_String
 516      (Item       : in Wide_String;
 517       Substitute : in Character := ' ')
 518      return        String
 519    is
 520       Result : String (1 .. Item'Length);
 521
 522    begin
 523       for J in Item'Range loop
 524          Result (J - (Item'First - 1)) := To_Character (Item (J), Substitute);
 525       end loop;
 526       return Result;
 527    end To_String;
 528
 529    --------------
 530    -- To_Upper --
 531    --------------
 532
 533    function To_Upper
 534      (Item : in Character)
 535      return  Character
 536    is
 537    begin
 538       return Value (Upper_Case_Map, Item);
 539    end To_Upper;
 540
 541    function To_Upper
 542      (Item : in String)
 543       return String
 544    is
 545       Result : String (1 .. Item'Length);
 546
 547    begin
 548       for J in Item'Range loop
 549          Result (J - (Item'First - 1)) := Value (Upper_Case_Map, Item (J));
 550       end loop;
 551
 552       return Result;
 553    end To_Upper;
 554
 555    -----------------------
 556    -- To_Wide_Character --
 557    -----------------------
 558
 559    function To_Wide_Character
 560      (Item : in Character)
 561       return Wide_Character
 562    is
 563    begin
 564       return Wide_Character'Val (Character'Pos (Item));
 565    end To_Wide_Character;
 566
 567    --------------------
 568    -- To_Wide_String --
 569    --------------------
 570
 571    function To_Wide_String
 572      (Item : in String)
 573       return Wide_String
 574    is
 575       Result : Wide_String (1 .. Item'Length);
 576
 577    begin
 578       for J in Item'Range loop
 579          Result (J - (Item'First - 1)) := To_Wide_Character (Item (J));
 580       end loop;
 581
 582       return Result;
 583    end To_Wide_String;
 584 end Ada.Characters.Handling;