gcc/ada/s-wchcnv.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUNTIME COMPONENTS                          --
   4 --                                                                          --
   5 --                       S Y S T E M . W C H _ C N V                        --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                            $Revision: 1.1 $
  10 --                                                                          --
  11 --          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
  12 --                                                                          --
  13 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- As a special exception,  if other files  instantiate  generics from this --
  25 -- unit, or you link  this unit with other files  to produce an executable, --
  26 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27 -- covered  by the  GNU  General  Public  License.  This exception does not --
  28 -- however invalidate  any other reasons why  the executable file  might be --
  29 -- covered by the  GNU Public License.                                      --
  30 --                                                                          --
  31 -- GNAT was originally developed  by the GNAT team at  New York University. --
  32 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  33 --                                                                          --
  34 ------------------------------------------------------------------------------
  35
  36 --  This package contains generic subprograms used for converting between
  37 --  sequences of Character and Wide_Character. All access to wide character
  38 --  sequences is isolated in this unit.
  39
  40 with Interfaces;     use Interfaces;
  41 with System.WCh_Con; use System.WCh_Con;
  42 with System.WCh_JIS; use System.WCh_JIS;
  43
  44 package body System.WCh_Cnv is
  45
  46    --------------------------------
  47    -- Char_Sequence_To_Wide_Char --
  48    --------------------------------
  49
  50    function Char_Sequence_To_Wide_Char
  51      (C    : Character;
  52       EM   : WC_Encoding_Method)
  53       return Wide_Character
  54    is
  55       B1 : Integer;
  56       C1 : Character;
  57       U  : Unsigned_16;
  58       W  : Unsigned_16;
  59
  60       procedure Get_Hex (N : Character);
  61       --  If N is a hex character, then set B1 to 16 * B1 + character N.
  62       --  Raise Constraint_Error if character N is not a hex character.
  63
  64       -------------
  65       -- Get_Hex --
  66       -------------
  67
  68       procedure Get_Hex (N : Character) is
  69          B2 : constant Integer := Character'Pos (N);
  70
  71       begin
  72          if B2 in Character'Pos ('0') .. Character'Pos ('9') then
  73             B1 := B1 * 16 + B2 - Character'Pos ('0');
  74
  75          elsif B2 in Character'Pos ('A') .. Character'Pos ('F') then
  76             B1 := B1 * 16 + B2 - (Character'Pos ('A') - 10);
  77
  78          elsif B2 in Character'Pos ('a') .. Character'Pos ('f') then
  79             B1 := B1 * 16 + B2 - (Character'Pos ('a') - 10);
  80
  81          else
  82             raise Constraint_Error;
  83          end if;
  84       end Get_Hex;
  85
  86    --  Start of processing for Char_Sequence_To_Wide_Char
  87
  88    begin
  89       case EM is
  90
  91          when WCEM_Hex =>
  92             if C /= ASCII.ESC then
  93                return Wide_Character'Val (Character'Pos (C));
  94
  95             else
  96                B1 := 0;
  97                Get_Hex (In_Char);
  98                Get_Hex (In_Char);
  99                Get_Hex (In_Char);
 100                Get_Hex (In_Char);
 101
 102                return Wide_Character'Val (B1);
 103             end if;
 104
 105          when WCEM_Upper =>
 106             if C > ASCII.DEL then
 107                return
 108                  Wide_Character'Val
 109                    (Integer (256 * Character'Pos (C)) +
 110                     Character'Pos (In_Char));
 111             else
 112                return Wide_Character'Val (Character'Pos (C));
 113             end if;
 114
 115          when WCEM_Shift_JIS =>
 116             if C > ASCII.DEL then
 117                return Shift_JIS_To_JIS (C, In_Char);
 118             else
 119                return Wide_Character'Val (Character'Pos (C));
 120             end if;
 121
 122          when WCEM_EUC =>
 123             if C > ASCII.DEL then
 124                return EUC_To_JIS (C, In_Char);
 125             else
 126                return Wide_Character'Val (Character'Pos (C));
 127             end if;
 128
 129          when WCEM_UTF8 =>
 130             if C > ASCII.DEL then
 131
 132                --  16#0080#-16#07ff#: 2#110xxxxx# 2#10xxxxxx#
 133                --  16#0800#-16#ffff#: 2#1110xxxx# 2#10xxxxxx# 2#10xxxxxx#
 134
 135                U := Unsigned_16 (Character'Pos (C));
 136
 137                if (U and 2#11100000#) = 2#11000000# then
 138                   W := Shift_Left (U and 2#00011111#, 6);
 139                   U := Unsigned_16 (Character'Pos (In_Char));
 140
 141                   if (U and 2#11000000#) /= 2#10000000# then
 142                      raise Constraint_Error;
 143                   end if;
 144
 145                   W := W or (U and 2#00111111#);
 146
 147                elsif (U and 2#11110000#) = 2#11100000# then
 148                   W := Shift_Left (U and 2#00001111#, 12);
 149                   U := Unsigned_16 (Character'Pos (In_Char));
 150
 151                   if (U and 2#11000000#) /= 2#10000000# then
 152                      raise Constraint_Error;
 153                   end if;
 154
 155                   W := W or Shift_Left (U and 2#00111111#, 6);
 156                   U := Unsigned_16 (Character'Pos (In_Char));
 157
 158                   if (U and 2#11000000#) /= 2#10000000# then
 159                      raise Constraint_Error;
 160                   end if;
 161
 162                   W := W or (U and 2#00111111#);
 163
 164                else
 165                   raise Constraint_Error;
 166                end if;
 167
 168                return Wide_Character'Val (W);
 169
 170             else
 171                return Wide_Character'Val (Character'Pos (C));
 172             end if;
 173
 174          when WCEM_Brackets =>
 175
 176             if C /= '[' then
 177                return Wide_Character'Val (Character'Pos (C));
 178             end if;
 179
 180             if In_Char /= '"' then
 181                raise Constraint_Error;
 182             end if;
 183
 184             B1 := 0;
 185             Get_Hex (In_Char);
 186             Get_Hex (In_Char);
 187             C1 := In_Char;
 188
 189             if C1 /= '"' then
 190                Get_Hex (C1);
 191                Get_Hex (In_Char);
 192                C1 := In_Char;
 193
 194                if C1 /= '"' then
 195                   raise Constraint_Error;
 196                end if;
 197             end if;
 198
 199             if In_Char /= ']' then
 200                raise Constraint_Error;
 201             end if;
 202
 203             return Wide_Character'Val (B1);
 204
 205       end case;
 206    end Char_Sequence_To_Wide_Char;
 207
 208    --------------------------------
 209    -- Wide_Char_To_Char_Sequence --
 210    --------------------------------
 211
 212    procedure Wide_Char_To_Char_Sequence
 213      (WC : Wide_Character;
 214       EM : WC_Encoding_Method)
 215    is
 216       Val    : constant Natural := Wide_Character'Pos (WC);
 217       Hexc   : constant array (0 .. 15) of Character := "0123456789ABCDEF";
 218       C1, C2 : Character;
 219       U      : Unsigned_16;
 220
 221    begin
 222       case EM is
 223
 224          when WCEM_Hex =>
 225             if Val < 256 then
 226                Out_Char (Character'Val (Val));
 227
 228             else
 229                Out_Char (ASCII.ESC);
 230                Out_Char (Hexc (Val / (16**3)));
 231                Out_Char (Hexc ((Val / (16**2)) mod 16));
 232                Out_Char (Hexc ((Val / 16) mod 16));
 233                Out_Char (Hexc (Val mod 16));
 234             end if;
 235
 236          when WCEM_Upper =>
 237             if Val < 128 then
 238                Out_Char (Character'Val (Val));
 239
 240             elsif Val < 16#8000# then
 241                raise Constraint_Error;
 242
 243             else
 244                Out_Char (Character'Val (Val / 256));
 245                Out_Char (Character'Val (Val mod 256));
 246             end if;
 247
 248          when WCEM_Shift_JIS =>
 249             if Val < 128 then
 250                Out_Char (Character'Val (Val));
 251             else
 252                JIS_To_Shift_JIS (WC, C1, C2);
 253                Out_Char (C1);
 254                Out_Char (C2);
 255             end if;
 256
 257          when WCEM_EUC =>
 258             if Val < 128 then
 259                Out_Char (Character'Val (Val));
 260             else
 261                JIS_To_EUC (WC, C1, C2);
 262                Out_Char (C1);
 263                Out_Char (C2);
 264             end if;
 265
 266          when WCEM_UTF8 =>
 267             U := Unsigned_16 (Val);
 268
 269             --  16#0000#-16#007f#: 2#0xxxxxxx#
 270             --  16#0080#-16#07ff#: 2#110xxxxx# 2#10xxxxxx#
 271             --  16#0800#-16#ffff#: 2#1110xxxx# 2#10xxxxxx# 2#10xxxxxx#
 272
 273             if U < 16#80# then
 274                Out_Char (Character'Val (U));
 275
 276             elsif U < 16#0800# then
 277                Out_Char (Character'Val (2#11000000# or Shift_Right (U, 6)));
 278                Out_Char (Character'Val (2#10000000# or (U and 2#00111111#)));
 279
 280             else
 281                Out_Char (Character'Val (2#11100000# or Shift_Right (U, 12)));
 282                Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 6)
 283                                                          and 2#00111111#)));
 284                Out_Char (Character'Val (2#10000000# or (U and 2#00111111#)));
 285             end if;
 286
 287          when WCEM_Brackets =>
 288
 289             if Val < 256 then
 290                Out_Char (Character'Val (Val));
 291
 292             else
 293                Out_Char ('[');
 294                Out_Char ('"');
 295                Out_Char (Hexc (Val / (16**3)));
 296                Out_Char (Hexc ((Val / (16**2)) mod 16));
 297                Out_Char (Hexc ((Val / 16) mod 16));
 298                Out_Char (Hexc (Val mod 16));
 299                Out_Char ('"');
 300                Out_Char (']');
 301             end if;
 302       end case;
 303    end Wide_Char_To_Char_Sequence;
 304
 305 end System.WCh_Cnv;