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