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