gcc/ada/s-wchcnv.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --                       S Y S T E M . W C H _ C N V                        --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2013, 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 pragma Compiler_Unit_Warning;
  33
  34 with Interfaces;     use Interfaces;
  35 with System.WCh_Con; use System.WCh_Con;
  36 with System.WCh_JIS; use System.WCh_JIS;
  37
  38 package body System.WCh_Cnv is
  39
  40    -----------------------------
  41    -- Char_Sequence_To_UTF_32 --
  42    -----------------------------
  43
  44    function Char_Sequence_To_UTF_32
  45      (C  : Character;
  46       EM : System.WCh_Con.WC_Encoding_Method) return UTF_32_Code
  47    is
  48       B1 : Unsigned_32;
  49       C1 : Character;
  50       U  : Unsigned_32;
  51       W  : Unsigned_32;
  52
  53       procedure Get_Hex (N : Character);
  54       --  If N is a hex character, then set B1 to 16 * B1 + character N.
  55       --  Raise Constraint_Error if character N is not a hex character.
  56
  57       procedure Get_UTF_Byte;
  58       pragma Inline (Get_UTF_Byte);
  59       --  Used to interpret a 2#10xxxxxx# continuation byte in UTF-8 mode.
  60       --  Reads a byte, and raises CE if the first two bits are not 10.
  61       --  Otherwise shifts W 6 bits left and or's in the 6 xxxxxx bits.
  62
  63       -------------
  64       -- Get_Hex --
  65       -------------
  66
  67       procedure Get_Hex (N : Character) is
  68          B2 : constant Unsigned_32 := Character'Pos (N);
  69       begin
  70          if B2 in Character'Pos ('0') .. Character'Pos ('9') then
  71             B1 := B1 * 16 + B2 - Character'Pos ('0');
  72          elsif B2 in Character'Pos ('A') .. Character'Pos ('F') then
  73             B1 := B1 * 16 + B2 - (Character'Pos ('A') - 10);
  74          elsif B2 in Character'Pos ('a') .. Character'Pos ('f') then
  75             B1 := B1 * 16 + B2 - (Character'Pos ('a') - 10);
  76          else
  77             raise Constraint_Error;
  78          end if;
  79       end Get_Hex;
  80
  81       ------------------
  82       -- Get_UTF_Byte --
  83       ------------------
  84
  85       procedure Get_UTF_Byte is
  86       begin
  87          U := Unsigned_32 (Character'Pos (In_Char));
  88
  89          if (U and 2#11000000#) /= 2#10_000000# then
  90             raise Constraint_Error;
  91          end if;
  92
  93          W := Shift_Left (W, 6) or (U and 2#00111111#);
  94       end Get_UTF_Byte;
  95
  96    --  Start of processing for Char_Sequence_To_Wide
  97
  98    begin
  99       case EM is
 100
 101          when WCEM_Hex =>
 102             if C /= ASCII.ESC then
 103                return Character'Pos (C);
 104
 105             else
 106                B1 := 0;
 107                Get_Hex (In_Char);
 108                Get_Hex (In_Char);
 109                Get_Hex (In_Char);
 110                Get_Hex (In_Char);
 111
 112                return UTF_32_Code (B1);
 113             end if;
 114
 115          when WCEM_Upper =>
 116             if C > ASCII.DEL then
 117                return 256 * Character'Pos (C) + Character'Pos (In_Char);
 118             else
 119                return Character'Pos (C);
 120             end if;
 121
 122          when WCEM_Shift_JIS =>
 123             if C > ASCII.DEL then
 124                return Wide_Character'Pos (Shift_JIS_To_JIS (C, In_Char));
 125             else
 126                return Character'Pos (C);
 127             end if;
 128
 129          when WCEM_EUC =>
 130             if C > ASCII.DEL then
 131                return Wide_Character'Pos (EUC_To_JIS (C, In_Char));
 132             else
 133                return Character'Pos (C);
 134             end if;
 135
 136          when WCEM_UTF8 =>
 137
 138             --  Note: for details of UTF8 encoding see RFC 3629
 139
 140             U := Unsigned_32 (Character'Pos (C));
 141
 142             --  16#00_0000#-16#00_007F#: 0xxxxxxx
 143
 144             if (U and 2#10000000#) = 2#00000000# then
 145                return Character'Pos (C);
 146
 147             --  16#00_0080#-16#00_07FF#: 110xxxxx 10xxxxxx
 148
 149             elsif (U and 2#11100000#) = 2#110_00000# then
 150                W := U and 2#00011111#;
 151                Get_UTF_Byte;
 152                return UTF_32_Code (W);
 153
 154             --  16#00_0800#-16#00_ffff#: 1110xxxx 10xxxxxx 10xxxxxx
 155
 156             elsif (U and 2#11110000#) = 2#1110_0000# then
 157                W := U and 2#00001111#;
 158                Get_UTF_Byte;
 159                Get_UTF_Byte;
 160                return UTF_32_Code (W);
 161
 162             --  16#01_0000#-16#10_FFFF#: 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx
 163
 164             elsif (U and 2#11111000#) = 2#11110_000# then
 165                W := U and 2#00000111#;
 166
 167                for K in 1 .. 3 loop
 168                   Get_UTF_Byte;
 169                end loop;
 170
 171                return UTF_32_Code (W);
 172
 173             --  16#0020_0000#-16#03FF_FFFF#: 111110xx 10xxxxxx 10xxxxxx
 174             --                               10xxxxxx 10xxxxxx
 175
 176             elsif (U and 2#11111100#) = 2#111110_00# then
 177                W := U and 2#00000011#;
 178
 179                for K in 1 .. 4 loop
 180                   Get_UTF_Byte;
 181                end loop;
 182
 183                return UTF_32_Code (W);
 184
 185             --  16#0400_0000#-16#7FFF_FFFF#: 1111110x 10xxxxxx 10xxxxxx
 186             --                               10xxxxxx 10xxxxxx 10xxxxxx
 187
 188             elsif (U and 2#11111110#) = 2#1111110_0# then
 189                W := U and 2#00000001#;
 190
 191                for K in 1 .. 5 loop
 192                   Get_UTF_Byte;
 193                end loop;
 194
 195                return UTF_32_Code (W);
 196
 197             else
 198                raise Constraint_Error;
 199             end if;
 200
 201          when WCEM_Brackets =>
 202             if C /= '[' then
 203                return Character'Pos (C);
 204             end if;
 205
 206             if In_Char /= '"' then
 207                raise Constraint_Error;
 208             end if;
 209
 210             B1 := 0;
 211             Get_Hex (In_Char);
 212             Get_Hex (In_Char);
 213
 214             C1 := In_Char;
 215
 216             if C1 /= '"' then
 217                Get_Hex (C1);
 218                Get_Hex (In_Char);
 219
 220                C1 := In_Char;
 221
 222                if C1 /= '"' then
 223                   Get_Hex (C1);
 224                   Get_Hex (In_Char);
 225
 226                   C1 := In_Char;
 227
 228                   if C1 /= '"' then
 229                      Get_Hex (C1);
 230                      Get_Hex (In_Char);
 231
 232                      if B1 > Unsigned_32 (UTF_32_Code'Last) then
 233                         raise Constraint_Error;
 234                      end if;
 235
 236                      if In_Char /= '"' then
 237                         raise Constraint_Error;
 238                      end if;
 239                   end if;
 240                end if;
 241             end if;
 242
 243             if In_Char /= ']' then
 244                raise Constraint_Error;
 245             end if;
 246
 247             return UTF_32_Code (B1);
 248
 249       end case;
 250    end Char_Sequence_To_UTF_32;
 251
 252    --------------------------------
 253    -- Char_Sequence_To_Wide_Char --
 254    --------------------------------
 255
 256    function Char_Sequence_To_Wide_Char
 257      (C  : Character;
 258       EM : System.WCh_Con.WC_Encoding_Method) return Wide_Character
 259    is
 260       function Char_Sequence_To_UTF is new Char_Sequence_To_UTF_32 (In_Char);
 261
 262       U : constant UTF_32_Code := Char_Sequence_To_UTF (C, EM);
 263
 264    begin
 265       if U > 16#FFFF# then
 266          raise Constraint_Error;
 267       else
 268          return Wide_Character'Val (U);
 269       end if;
 270    end Char_Sequence_To_Wide_Char;
 271
 272    -----------------------------
 273    -- UTF_32_To_Char_Sequence --
 274    -----------------------------
 275
 276    procedure UTF_32_To_Char_Sequence
 277      (Val : UTF_32_Code;
 278       EM  : System.WCh_Con.WC_Encoding_Method)
 279    is
 280       Hexc : constant array (UTF_32_Code range 0 .. 15) of Character :=
 281                "0123456789ABCDEF";
 282
 283       C1, C2 : Character;
 284       U      : Unsigned_32;
 285
 286    begin
 287       --  Raise CE for invalid UTF_32_Code
 288
 289       if not Val'Valid then
 290          raise Constraint_Error;
 291       end if;
 292
 293       --  Processing depends on encoding mode
 294
 295       case EM is
 296
 297          when WCEM_Hex =>
 298             if Val < 256 then
 299                Out_Char (Character'Val (Val));
 300             elsif Val <= 16#FFFF# then
 301                Out_Char (ASCII.ESC);
 302                Out_Char (Hexc (Val / (16**3)));
 303                Out_Char (Hexc ((Val / (16**2)) mod 16));
 304                Out_Char (Hexc ((Val / 16) mod 16));
 305                Out_Char (Hexc (Val mod 16));
 306             else
 307                raise Constraint_Error;
 308             end if;
 309
 310          when WCEM_Upper =>
 311             if Val < 128 then
 312                Out_Char (Character'Val (Val));
 313             elsif Val < 16#8000# or else Val > 16#FFFF# then
 314                raise Constraint_Error;
 315             else
 316                Out_Char (Character'Val (Val / 256));
 317                Out_Char (Character'Val (Val mod 256));
 318             end if;
 319
 320          when WCEM_Shift_JIS =>
 321             if Val < 128 then
 322                Out_Char (Character'Val (Val));
 323             elsif Val <= 16#FFFF# then
 324                JIS_To_Shift_JIS (Wide_Character'Val (Val), C1, C2);
 325                Out_Char (C1);
 326                Out_Char (C2);
 327             else
 328                raise Constraint_Error;
 329             end if;
 330
 331          when WCEM_EUC =>
 332             if Val < 128 then
 333                Out_Char (Character'Val (Val));
 334             elsif Val <= 16#FFFF# then
 335                JIS_To_EUC (Wide_Character'Val (Val), C1, C2);
 336                Out_Char (C1);
 337                Out_Char (C2);
 338             else
 339                raise Constraint_Error;
 340             end if;
 341
 342          when WCEM_UTF8 =>
 343
 344             --  Note: for details of UTF8 encoding see RFC 3629
 345
 346             U := Unsigned_32 (Val);
 347
 348             --  16#00_0000#-16#00_007F#: 0xxxxxxx
 349
 350             if U <= 16#00_007F# then
 351                Out_Char (Character'Val (U));
 352
 353             --  16#00_0080#-16#00_07FF#: 110xxxxx 10xxxxxx
 354
 355             elsif U <= 16#00_07FF# then
 356                Out_Char (Character'Val (2#11000000# or Shift_Right (U, 6)));
 357                Out_Char (Character'Val (2#10000000# or (U and 2#00111111#)));
 358
 359             --  16#00_0800#-16#00_FFFF#: 1110xxxx 10xxxxxx 10xxxxxx
 360
 361             elsif U <= 16#00_FFFF# then
 362                Out_Char (Character'Val (2#11100000# or Shift_Right (U, 12)));
 363                Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 6)
 364                                                           and 2#00111111#)));
 365                Out_Char (Character'Val (2#10000000# or (U and 2#00111111#)));
 366
 367             --  16#01_0000#-16#10_FFFF#: 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx
 368
 369             elsif U <= 16#10_FFFF# then
 370                Out_Char (Character'Val (2#11110000# or Shift_Right (U, 18)));
 371                Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 12)
 372                                                           and 2#00111111#)));
 373                Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 6)
 374                                                           and 2#00111111#)));
 375                Out_Char (Character'Val (2#10000000# or (U and 2#00111111#)));
 376
 377             --  16#0020_0000#-16#03FF_FFFF#: 111110xx 10xxxxxx 10xxxxxx
 378             --                               10xxxxxx 10xxxxxx
 379
 380             elsif U <= 16#03FF_FFFF# then
 381                Out_Char (Character'Val (2#11111000# or Shift_Right (U, 24)));
 382                Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 18)
 383                                                           and 2#00111111#)));
 384                Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 12)
 385                                                           and 2#00111111#)));
 386                Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 6)
 387                                                           and 2#00111111#)));
 388                Out_Char (Character'Val (2#10000000# or (U and 2#00111111#)));
 389
 390             --  16#0400_0000#-16#7FFF_FFFF#: 1111110x 10xxxxxx 10xxxxxx
 391             --                               10xxxxxx 10xxxxxx 10xxxxxx
 392
 393             elsif U <= 16#7FFF_FFFF# then
 394                Out_Char (Character'Val (2#11111100# or Shift_Right (U, 30)));
 395                Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 24)
 396                                                           and 2#00111111#)));
 397                Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 18)
 398                                                           and 2#00111111#)));
 399                Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 12)
 400                                                           and 2#00111111#)));
 401                Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 6)
 402                                                           and 2#00111111#)));
 403                Out_Char (Character'Val (2#10000000# or (U and 2#00111111#)));
 404
 405             else
 406                raise Constraint_Error;
 407             end if;
 408
 409          when WCEM_Brackets =>
 410
 411             --  Values in the range 0-255 are directly output. Note that there
 412             --  is some issue with [ (16#5B#] since this will cause confusion
 413             --  if the resulting string is interpreted using brackets encoding.
 414
 415             --  One possibility would be to always output [ as ["5B"] but in
 416             --  practice this is undesirable, since for example normal use of
 417             --  Wide_Text_IO for output (much more common than input), really
 418             --  does want to be able to say something like
 419
 420             --     Put_Line ("Start of output [first run]");
 421
 422             --  and have it come out as intended, rather than contaminated by
 423             --  a ["5B"] sequence in place of the left bracket.
 424
 425             if Val < 256 then
 426                Out_Char (Character'Val (Val));
 427
 428             --  Otherwise use brackets notation for vales greater than 255
 429
 430             else
 431                Out_Char ('[');
 432                Out_Char ('"');
 433
 434                if Val > 16#FFFF# then
 435                   if Val > 16#00FF_FFFF# then
 436                      Out_Char (Hexc (Val / 16 ** 7));
 437                      Out_Char (Hexc ((Val / 16 ** 6) mod 16));
 438                   end if;
 439
 440                   Out_Char (Hexc ((Val / 16 ** 5) mod 16));
 441                   Out_Char (Hexc ((Val / 16 ** 4) mod 16));
 442                end if;
 443
 444                Out_Char (Hexc ((Val / 16 ** 3) mod 16));
 445                Out_Char (Hexc ((Val / 16 ** 2) mod 16));
 446                Out_Char (Hexc ((Val / 16) mod 16));
 447                Out_Char (Hexc (Val mod 16));
 448
 449                Out_Char ('"');
 450                Out_Char (']');
 451             end if;
 452       end case;
 453    end UTF_32_To_Char_Sequence;
 454
 455    --------------------------------
 456    -- Wide_Char_To_Char_Sequence --
 457    --------------------------------
 458
 459    procedure Wide_Char_To_Char_Sequence
 460      (WC : Wide_Character;
 461       EM : System.WCh_Con.WC_Encoding_Method)
 462    is
 463       procedure UTF_To_Char_Sequence is new UTF_32_To_Char_Sequence (Out_Char);
 464    begin
 465       UTF_To_Char_Sequence (Wide_Character'Pos (WC), EM);
 466    end Wide_Char_To_Char_Sequence;
 467
 468 end System.WCh_Cnv;