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