gcc/ada/widechar.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             W I D E C H A R                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2019, 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 --  Note: this package uses the generic subprograms in System.WCh_Cnv, which
  33 --  completely encapsulate the set of wide character encoding methods, so no
  34 --  modifications are required when adding new encoding methods.
  35
  36 with Opt; use Opt;
  37
  38 with System.WCh_Cnv; use System.WCh_Cnv;
  39 with System.WCh_Con; use System.WCh_Con;
  40
  41 package body Widechar is
  42
  43    ---------------------------
  44    -- Is_Start_Of_Wide_Char --
  45    ---------------------------
  46
  47    function Is_Start_Of_Wide_Char
  48      (S : Source_Buffer_Ptr;
  49       P : Source_Ptr) return Boolean
  50    is
  51    begin
  52       case Wide_Character_Encoding_Method is
  53
  54          --  For Hex mode, just test for an ESC character. The ESC character
  55          --  cannot appear in any other context in a legal Ada program.
  56
  57          when WCEM_Hex =>
  58             return S (P) = ASCII.ESC;
  59
  60          --  For brackets, just test ["x where x is a hex character. This is
  61          --  sufficient test, since this sequence cannot otherwise appear in a
  62          --  legal Ada program.
  63
  64          when WCEM_Brackets =>
  65             return P <= S'Last - 2
  66               and then S (P) = '['
  67               and then S (P + 1) = '"'
  68               and then (S (P + 2) in '0' .. '9'
  69                             or else
  70                            S (P + 2) in 'a' .. 'f'
  71                             or else
  72                         S (P + 2) in 'A' .. 'F');
  73
  74          --  All other encoding methods use the upper bit set in the first
  75          --  character to uniquely represent a wide character.
  76
  77          when WCEM_EUC
  78             | WCEM_Shift_JIS
  79             | WCEM_Upper
  80             | WCEM_UTF8
  81          =>
  82             return S (P) >= Character'Val (16#80#);
  83       end case;
  84    end Is_Start_Of_Wide_Char;
  85
  86    -----------------
  87    -- Length_Wide --
  88    -----------------
  89
  90    function Length_Wide return Nat is
  91    begin
  92       return WC_Longest_Sequence;
  93    end Length_Wide;
  94
  95    ---------------
  96    -- Scan_Wide --
  97    ---------------
  98
  99    procedure Scan_Wide
 100      (S   : Source_Buffer_Ptr;
 101       P   : in out Source_Ptr;
 102       C   : out Char_Code;
 103       Err : out Boolean)
 104    is
 105       P_Init : constant Source_Ptr := P;
 106       Chr    : Character;
 107
 108       function In_Char return Character;
 109       --  Function to obtain characters of wide character escape sequence
 110
 111       -------------
 112       -- In_Char --
 113       -------------
 114
 115       function In_Char return Character is
 116       begin
 117          P := P + 1;
 118          return S (P - 1);
 119       end In_Char;
 120
 121       function WC_In is new Char_Sequence_To_UTF_32 (In_Char);
 122
 123    --  Start of processing for Scan_Wide
 124
 125    begin
 126       Chr := In_Char;
 127
 128       --  Scan out the wide character. If the first character is a bracket,
 129       --  we allow brackets encoding regardless of the standard encoding
 130       --  method being used, but otherwise we use this standard method.
 131
 132       if Chr = '[' then
 133          C := Char_Code (WC_In (Chr, WCEM_Brackets));
 134       else
 135          C := Char_Code (WC_In (Chr, Wide_Character_Encoding_Method));
 136       end if;
 137
 138       Err := False;
 139       Wide_Char_Byte_Count := Wide_Char_Byte_Count + Nat (P - P_Init - 1);
 140
 141    exception
 142       when Constraint_Error =>
 143          C := Char_Code (0);
 144          P := P - 1;
 145          Err := True;
 146    end Scan_Wide;
 147
 148    --------------
 149    -- Set_Wide --
 150    --------------
 151
 152    procedure Set_Wide
 153      (C : Char_Code;
 154       S : in out String;
 155       P : in out Natural)
 156    is
 157       procedure Out_Char (C : Character);
 158       --  Procedure to store one character of wide character sequence
 159
 160       --------------
 161       -- Out_Char --
 162       --------------
 163
 164       procedure Out_Char (C : Character) is
 165       begin
 166          P := P + 1;
 167          S (P) := C;
 168       end Out_Char;
 169
 170       procedure WC_Out is new UTF_32_To_Char_Sequence (Out_Char);
 171
 172    --  Start of processing for Set_Wide
 173
 174    begin
 175       WC_Out (UTF_32_Code (C), Wide_Character_Encoding_Method);
 176    end Set_Wide;
 177
 178    ---------------
 179    -- Skip_Wide --
 180    ---------------
 181
 182    procedure Skip_Wide (S : String; P : in out Natural) is
 183       P_Init : constant Natural := P;
 184
 185       function Skip_Char return Character;
 186       --  Function to skip one character of wide character escape sequence
 187
 188       ---------------
 189       -- Skip_Char --
 190       ---------------
 191
 192       function Skip_Char return Character is
 193       begin
 194          P := P + 1;
 195          return S (P - 1);
 196       end Skip_Char;
 197
 198       function WC_Skip is new Char_Sequence_To_UTF_32 (Skip_Char);
 199
 200       Discard : UTF_32_Code;
 201       pragma Warnings (Off, Discard);
 202
 203    --  Start of processing for Skip_Wide
 204
 205    begin
 206       Discard := WC_Skip (Skip_Char, Wide_Character_Encoding_Method);
 207       Wide_Char_Byte_Count := Wide_Char_Byte_Count + Nat (P - P_Init - 1);
 208    end Skip_Wide;
 209
 210    ---------------
 211    -- Skip_Wide --
 212    ---------------
 213
 214    procedure Skip_Wide (S : Source_Buffer_Ptr; P : in out Source_Ptr) is
 215       P_Init : constant Source_Ptr := P;
 216
 217       function Skip_Char return Character;
 218       --  Function to skip one character of wide character escape sequence
 219
 220       ---------------
 221       -- Skip_Char --
 222       ---------------
 223
 224       function Skip_Char return Character is
 225       begin
 226          P := P + 1;
 227          return S (P - 1);
 228       end Skip_Char;
 229
 230       function WC_Skip is new Char_Sequence_To_UTF_32 (Skip_Char);
 231
 232       Discard : UTF_32_Code;
 233       pragma Warnings (Off, Discard);
 234
 235    --  Start of processing for Skip_Wide
 236
 237    begin
 238       Discard := WC_Skip (Skip_Char, Wide_Character_Encoding_Method);
 239       Wide_Char_Byte_Count := Wide_Char_Byte_Count + Nat (P - P_Init - 1);
 240    end Skip_Wide;
 241
 242 end Widechar;