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