gcc/ada/libgnat/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-2024, 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 3,  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.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 --  Loop invariants in this unit are meant for analysis only, not for run-time
  33 --  checking, as it would be too costly otherwise. This is enforced by setting
  34 --  the assertion policy to Ignore.
  35
  36 pragma Assertion_Policy (Loop_Invariant => Ignore);
  37
  38 with Ada.Characters.Latin_1;     use Ada.Characters.Latin_1;
  39 with Ada.Strings.Maps;           use Ada.Strings.Maps;
  40 with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants;
  41
  42 package body Ada.Characters.Handling
  43   with SPARK_Mode
  44 is
  45
  46    ------------------------------------
  47    -- Character Classification Table --
  48    ------------------------------------
  49
  50    type Character_Flags is mod 256;
  51    for Character_Flags'Size use 8;
  52
  53    Control    : constant Character_Flags := 1;
  54    Lower      : constant Character_Flags := 2;
  55    Upper      : constant Character_Flags := 4;
  56    Basic      : constant Character_Flags := 8;
  57    Hex_Digit  : constant Character_Flags := 16;
  58    Digit      : constant Character_Flags := 32;
  59    Special    : constant Character_Flags := 64;
  60    Line_Term  : constant Character_Flags := 128;
  61
  62    Letter     : constant Character_Flags := Lower or Upper;
  63    Alphanum   : constant Character_Flags := Letter or Digit;
  64    Graphic    : constant Character_Flags := Alphanum or Special;
  65
  66    Char_Map : constant array (Character) of Character_Flags :=
  67    [
  68      NUL                         => Control,
  69      SOH                         => Control,
  70      STX                         => Control,
  71      ETX                         => Control,
  72      EOT                         => Control,
  73      ENQ                         => Control,
  74      ACK                         => Control,
  75      BEL                         => Control,
  76      BS                          => Control,
  77      HT                          => Control,
  78      LF                          => Control + Line_Term,
  79      VT                          => Control + Line_Term,
  80      FF                          => Control + Line_Term,
  81      CR                          => Control + Line_Term,
  82      SO                          => Control,
  83      SI                          => Control,
  84
  85      DLE                         => Control,
  86      DC1                         => Control,
  87      DC2                         => Control,
  88      DC3                         => Control,
  89      DC4                         => Control,
  90      NAK                         => Control,
  91      SYN                         => Control,
  92      ETB                         => Control,
  93      CAN                         => Control,
  94      EM                          => Control,
  95      SUB                         => Control,
  96      ESC                         => Control,
  97      FS                          => Control,
  98      GS                          => Control,
  99      RS                          => Control,
 100      US                          => Control,
 101
 102      Space                       => Special,
 103      Exclamation                 => Special,
 104      Quotation                   => Special,
 105      Number_Sign                 => Special,
 106      Dollar_Sign                 => Special,
 107      Percent_Sign                => Special,
 108      Ampersand                   => Special,
 109      Apostrophe                  => Special,
 110      Left_Parenthesis            => Special,
 111      Right_Parenthesis           => Special,
 112      Asterisk                    => Special,
 113      Plus_Sign                   => Special,
 114      Comma                       => Special,
 115      Hyphen                      => Special,
 116      Full_Stop                   => Special,
 117      Solidus                     => Special,
 118
 119      '0' .. '9'                  => Digit + Hex_Digit,
 120
 121      Colon                       => Special,
 122      Semicolon                   => Special,
 123      Less_Than_Sign              => Special,
 124      Equals_Sign                 => Special,
 125      Greater_Than_Sign           => Special,
 126      Question                    => Special,
 127      Commercial_At               => Special,
 128
 129      'A' .. 'F'                  => Upper + Basic + Hex_Digit,
 130      'G' .. 'Z'                  => Upper + Basic,
 131
 132      Left_Square_Bracket         => Special,
 133      Reverse_Solidus             => Special,
 134      Right_Square_Bracket        => Special,
 135      Circumflex                  => Special,
 136      Low_Line                    => Special,
 137      Grave                       => Special,
 138
 139      'a' .. 'f'                  => Lower + Basic + Hex_Digit,
 140      'g' .. 'z'                  => Lower + Basic,
 141
 142      Left_Curly_Bracket          => Special,
 143      Vertical_Line               => Special,
 144      Right_Curly_Bracket         => Special,
 145      Tilde                       => Special,
 146
 147      DEL                         => Control,
 148      Reserved_128                => Control,
 149      Reserved_129                => Control,
 150      BPH                         => Control,
 151      NBH                         => Control,
 152      Reserved_132                => Control,
 153      NEL                         => Control + Line_Term,
 154      SSA                         => Control,
 155      ESA                         => Control,
 156      HTS                         => Control,
 157      HTJ                         => Control,
 158      VTS                         => Control,
 159      PLD                         => Control,
 160      PLU                         => Control,
 161      RI                          => Control,
 162      SS2                         => Control,
 163      SS3                         => Control,
 164
 165      DCS                         => Control,
 166      PU1                         => Control,
 167      PU2                         => Control,
 168      STS                         => Control,
 169      CCH                         => Control,
 170      MW                          => Control,
 171      SPA                         => Control,
 172      EPA                         => Control,
 173
 174      SOS                         => Control,
 175      Reserved_153                => Control,
 176      SCI                         => Control,
 177      CSI                         => Control,
 178      ST                          => Control,
 179      OSC                         => Control,
 180      PM                          => Control,
 181      APC                         => Control,
 182
 183      No_Break_Space              => Special,
 184      Inverted_Exclamation        => Special,
 185      Cent_Sign                   => Special,
 186      Pound_Sign                  => Special,
 187      Currency_Sign               => Special,
 188      Yen_Sign                    => Special,
 189      Broken_Bar                  => Special,
 190      Section_Sign                => Special,
 191      Diaeresis                   => Special,
 192      Copyright_Sign              => Special,
 193      Feminine_Ordinal_Indicator  => Special,
 194      Left_Angle_Quotation        => Special,
 195      Not_Sign                    => Special,
 196      Soft_Hyphen                 => Special,
 197      Registered_Trade_Mark_Sign  => Special,
 198      Macron                      => Special,
 199      Degree_Sign                 => Special,
 200      Plus_Minus_Sign             => Special,
 201      Superscript_Two             => Special,
 202      Superscript_Three           => Special,
 203      Acute                       => Special,
 204      Micro_Sign                  => Special,
 205      Pilcrow_Sign                => Special,
 206      Middle_Dot                  => Special,
 207      Cedilla                     => Special,
 208      Superscript_One             => Special,
 209      Masculine_Ordinal_Indicator => Special,
 210      Right_Angle_Quotation       => Special,
 211      Fraction_One_Quarter        => Special,
 212      Fraction_One_Half           => Special,
 213      Fraction_Three_Quarters     => Special,
 214      Inverted_Question           => Special,
 215
 216      UC_A_Grave                  => Upper,
 217      UC_A_Acute                  => Upper,
 218      UC_A_Circumflex             => Upper,
 219      UC_A_Tilde                  => Upper,
 220      UC_A_Diaeresis              => Upper,
 221      UC_A_Ring                   => Upper,
 222      UC_AE_Diphthong             => Upper + Basic,
 223      UC_C_Cedilla                => Upper,
 224      UC_E_Grave                  => Upper,
 225      UC_E_Acute                  => Upper,
 226      UC_E_Circumflex             => Upper,
 227      UC_E_Diaeresis              => Upper,
 228      UC_I_Grave                  => Upper,
 229      UC_I_Acute                  => Upper,
 230      UC_I_Circumflex             => Upper,
 231      UC_I_Diaeresis              => Upper,
 232      UC_Icelandic_Eth            => Upper + Basic,
 233      UC_N_Tilde                  => Upper,
 234      UC_O_Grave                  => Upper,
 235      UC_O_Acute                  => Upper,
 236      UC_O_Circumflex             => Upper,
 237      UC_O_Tilde                  => Upper,
 238      UC_O_Diaeresis              => Upper,
 239
 240      Multiplication_Sign         => Special,
 241
 242      UC_O_Oblique_Stroke         => Upper,
 243      UC_U_Grave                  => Upper,
 244      UC_U_Acute                  => Upper,
 245      UC_U_Circumflex             => Upper,
 246      UC_U_Diaeresis              => Upper,
 247      UC_Y_Acute                  => Upper,
 248      UC_Icelandic_Thorn          => Upper + Basic,
 249
 250      LC_German_Sharp_S           => Lower + Basic,
 251      LC_A_Grave                  => Lower,
 252      LC_A_Acute                  => Lower,
 253      LC_A_Circumflex             => Lower,
 254      LC_A_Tilde                  => Lower,
 255      LC_A_Diaeresis              => Lower,
 256      LC_A_Ring                   => Lower,
 257      LC_AE_Diphthong             => Lower + Basic,
 258      LC_C_Cedilla                => Lower,
 259      LC_E_Grave                  => Lower,
 260      LC_E_Acute                  => Lower,
 261      LC_E_Circumflex             => Lower,
 262      LC_E_Diaeresis              => Lower,
 263      LC_I_Grave                  => Lower,
 264      LC_I_Acute                  => Lower,
 265      LC_I_Circumflex             => Lower,
 266      LC_I_Diaeresis              => Lower,
 267      LC_Icelandic_Eth            => Lower + Basic,
 268      LC_N_Tilde                  => Lower,
 269      LC_O_Grave                  => Lower,
 270      LC_O_Acute                  => Lower,
 271      LC_O_Circumflex             => Lower,
 272      LC_O_Tilde                  => Lower,
 273      LC_O_Diaeresis              => Lower,
 274
 275      Division_Sign               => Special,
 276
 277      LC_O_Oblique_Stroke         => Lower,
 278      LC_U_Grave                  => Lower,
 279      LC_U_Acute                  => Lower,
 280      LC_U_Circumflex             => Lower,
 281      LC_U_Diaeresis              => Lower,
 282      LC_Y_Acute                  => Lower,
 283      LC_Icelandic_Thorn          => Lower + Basic,
 284      LC_Y_Diaeresis              => Lower
 285    ];
 286
 287    ---------------------
 288    -- Is_Alphanumeric --
 289    ---------------------
 290
 291    function Is_Alphanumeric (Item : Character) return Boolean is
 292    begin
 293       return (Char_Map (Item) and Alphanum) /= 0;
 294    end Is_Alphanumeric;
 295
 296    --------------
 297    -- Is_Basic --
 298    --------------
 299
 300    function Is_Basic (Item : Character) return Boolean is
 301    begin
 302       return (Char_Map (Item) and Basic) /= 0;
 303    end Is_Basic;
 304
 305    ------------------
 306    -- Is_Character --
 307    ------------------
 308
 309    function Is_Character (Item : Wide_Character) return Boolean is
 310      (Wide_Character'Pos (Item) < 256);
 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      (Item in ISO_646);
 354
 355    --  Note: much more efficient coding of the following function is possible
 356    --  by testing several 16#80# bits in a complete word in a single operation
 357
 358    function Is_ISO_646 (Item : String) return Boolean is
 359    begin
 360       for J in Item'Range loop
 361          if Item (J) not in ISO_646 then
 362             return False;
 363          end if;
 364          pragma Loop_Invariant
 365            (for all K in Item'First .. J => Is_ISO_646 (Item (K)));
 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_Line_Terminator --
 382    ------------------------
 383
 384    function Is_Line_Terminator (Item : Character) return Boolean is
 385    begin
 386       return (Char_Map (Item) and Line_Term) /= 0;
 387    end Is_Line_Terminator;
 388
 389    --------------
 390    -- Is_Lower --
 391    --------------
 392
 393    function Is_Lower (Item : Character) return Boolean is
 394    begin
 395       return (Char_Map (Item) and Lower) /= 0;
 396    end Is_Lower;
 397
 398    -------------
 399    -- Is_Mark --
 400    -------------
 401
 402    function Is_Mark (Item : Character) return Boolean is
 403       pragma Unreferenced (Item);
 404    begin
 405       return False;
 406    end Is_Mark;
 407
 408    -------------
 409    -- Is_NFKC --
 410    -------------
 411
 412    function Is_NFKC (Item : Character) return Boolean is
 413    begin
 414       return Character'Pos (Item) not in
 415         160 | 168 | 170 | 175 | 178 | 179 | 180 | 181 | 184 | 185 | 186 |
 416         188 | 189 | 190;
 417    end Is_NFKC;
 418
 419    ---------------------
 420    -- Is_Other_Format --
 421    ---------------------
 422
 423    function Is_Other_Format (Item : Character) return Boolean is
 424    begin
 425       return Item = Soft_Hyphen;
 426    end Is_Other_Format;
 427
 428    ------------------------------
 429    -- Is_Punctuation_Connector --
 430    ------------------------------
 431
 432    function Is_Punctuation_Connector (Item : Character) return Boolean is
 433    begin
 434       return Item = '_';
 435    end Is_Punctuation_Connector;
 436
 437    --------------
 438    -- Is_Space --
 439    --------------
 440
 441    function Is_Space (Item : Character) return Boolean is
 442    begin
 443       return Item = ' ' or else Item = No_Break_Space;
 444    end Is_Space;
 445
 446    ----------------
 447    -- Is_Special --
 448    ----------------
 449
 450    function Is_Special (Item : Character) return Boolean is
 451    begin
 452       return (Char_Map (Item) and Special) /= 0;
 453    end Is_Special;
 454
 455    ---------------
 456    -- Is_String --
 457    ---------------
 458
 459    function Is_String (Item : Wide_String) return Boolean is
 460    begin
 461       for J in Item'Range loop
 462          if Wide_Character'Pos (Item (J)) >= 256 then
 463             return False;
 464          end if;
 465          pragma Loop_Invariant
 466            (for all K in Item'First .. J => Is_Character (Item (K)));
 467       end loop;
 468
 469       return True;
 470    end Is_String;
 471
 472    --------------
 473    -- Is_Upper --
 474    --------------
 475
 476    function Is_Upper (Item : Character) return Boolean is
 477    begin
 478       return (Char_Map (Item) and Upper) /= 0;
 479    end Is_Upper;
 480
 481    --------------
 482    -- To_Basic --
 483    --------------
 484
 485    function To_Basic (Item : Character) return Character is
 486       (Value (Basic_Map, Item));
 487
 488    function To_Basic (Item : String) return String is
 489    begin
 490       return Result : String (1 .. Item'Length) with Relaxed_Initialization do
 491          for J in Item'Range loop
 492             Result (J - (Item'First - 1)) := Value (Basic_Map, Item (J));
 493             pragma Loop_Invariant
 494               (Result (1 .. J - Item'First + 1)'Initialized);
 495             pragma Loop_Invariant
 496               (for all K in Item'First .. J =>
 497                  Result (K - (Item'First - 1)) = To_Basic (Item (K)));
 498          end loop;
 499       end return;
 500    end To_Basic;
 501
 502    ------------------
 503    -- To_Character --
 504    ------------------
 505
 506    function To_Character
 507      (Item       : Wide_Character;
 508       Substitute : Character := ' ') return Character
 509    is
 510    begin
 511       if Is_Character (Item) then
 512          return Character'Val (Wide_Character'Pos (Item));
 513       else
 514          return Substitute;
 515       end if;
 516    end To_Character;
 517
 518    ----------------
 519    -- To_ISO_646 --
 520    ----------------
 521
 522    function To_ISO_646
 523      (Item       : Character;
 524       Substitute : ISO_646 := ' ') return ISO_646
 525    is (if Item in ISO_646 then Item else Substitute);
 526
 527    function To_ISO_646
 528      (Item       : String;
 529       Substitute : ISO_646 := ' ') return String
 530    is
 531    begin
 532       return Result : String (1 .. Item'Length) with Relaxed_Initialization do
 533          for J in Item'Range loop
 534             Result (J - (Item'First - 1)) :=
 535               (if Item (J) in ISO_646 then Item (J) else Substitute);
 536             pragma Loop_Invariant
 537               (Result (1 .. J - Item'First + 1)'Initialized);
 538             pragma Loop_Invariant
 539               (for all K in Item'First .. J =>
 540                  Result (K - (Item'First - 1)) =
 541                    To_ISO_646 (Item (K), Substitute));
 542          end loop;
 543       end return;
 544    end To_ISO_646;
 545
 546    --------------
 547    -- To_Lower --
 548    --------------
 549
 550    function To_Lower (Item : Character) return Character is
 551      (Value (Lower_Case_Map, Item));
 552
 553    function To_Lower (Item : String) return String is
 554    begin
 555       return Result : String (1 .. Item'Length) with Relaxed_Initialization do
 556          for J in Item'Range loop
 557             Result (J - (Item'First - 1)) := Value (Lower_Case_Map, Item (J));
 558             pragma Loop_Invariant
 559               (Result (1 .. J - Item'First + 1)'Initialized);
 560             pragma Loop_Invariant
 561               (for all K in Item'First .. J =>
 562                  Result (K - (Item'First - 1)) = To_Lower (Item (K)));
 563          end loop;
 564       end return;
 565    end To_Lower;
 566
 567    ---------------
 568    -- To_String --
 569    ---------------
 570
 571    function To_String
 572      (Item       : Wide_String;
 573       Substitute : Character := ' ') return String
 574    is
 575    begin
 576       return Result : String (1 .. Item'Length) with Relaxed_Initialization do
 577          for J in Item'Range loop
 578             Result (J - (Item'First - 1)) :=
 579               To_Character (Item (J), Substitute);
 580             pragma Loop_Invariant
 581               (Result (1 .. J - (Item'First - 1))'Initialized);
 582             pragma Loop_Invariant
 583               (for all K in Item'First .. J =>
 584                  Result (K - (Item'First - 1)) =
 585                    To_Character (Item (K), Substitute));
 586          end loop;
 587       end return;
 588    end To_String;
 589
 590    --------------
 591    -- To_Upper --
 592    --------------
 593
 594    function To_Upper (Item : Character) return Character is
 595      (Value (Upper_Case_Map, Item));
 596
 597    function To_Upper
 598      (Item : String) return String
 599    is
 600    begin
 601       return Result : String (1 .. Item'Length) with Relaxed_Initialization do
 602          for J in Item'Range loop
 603             Result (J - (Item'First - 1)) := Value (Upper_Case_Map, Item (J));
 604             pragma Loop_Invariant
 605               (Result (1 .. J - Item'First + 1)'Initialized);
 606             pragma Loop_Invariant
 607               (for all K in Item'First .. J =>
 608                  Result (K - (Item'First - 1)) = To_Upper (Item (K)));
 609          end loop;
 610       end return;
 611    end To_Upper;
 612
 613    -----------------------
 614    -- To_Wide_Character --
 615    -----------------------
 616
 617    function To_Wide_Character
 618      (Item : Character) return Wide_Character
 619    is
 620    begin
 621       return Wide_Character'Val (Character'Pos (Item));
 622    end To_Wide_Character;
 623
 624    --------------------
 625    -- To_Wide_String --
 626    --------------------
 627
 628    function To_Wide_String
 629      (Item : String) return Wide_String
 630    is
 631    begin
 632       return Result : Wide_String (1 .. Item'Length)
 633         with Relaxed_Initialization
 634       do
 635          for J in Item'Range loop
 636             Result (J - (Item'First - 1)) := To_Wide_Character (Item (J));
 637             pragma Loop_Invariant
 638               (Result (1 .. J - (Item'First - 1))'Initialized);
 639             pragma Loop_Invariant
 640               (for all K in Item'First .. J =>
 641                  Result (K - (Item'First - 1)) = To_Wide_Character (Item (K)));
 642          end loop;
 643       end return;
 644    end To_Wide_String;
 645
 646 end Ada.Characters.Handling;