1 ------------------------------------------------------------------------------
3 -- GNAT RUNTIME COMPONENTS --
5 -- S Y S T E M . W C H _ C N V --
9 -- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
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. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
34 -- This package contains generic subprograms used for converting between
35 -- sequences of Character and Wide_Character. All access to wide character
36 -- sequences is isolated in this unit.
38 with Interfaces; use Interfaces;
39 with System.WCh_Con; use System.WCh_Con;
40 with System.WCh_JIS; use System.WCh_JIS;
42 package body System.WCh_Cnv is
44 -----------------------------
45 -- Char_Sequence_To_UTF_32 --
46 -----------------------------
48 function Char_Sequence_To_UTF_32
50 EM : WC_Encoding_Method) return UTF_32_Code
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.
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.
71 procedure Get_Hex (N : Character) is
72 B2 : constant Unsigned_32 := Character'Pos (N);
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);
81 raise Constraint_Error;
89 procedure Get_UTF_Byte is
91 U := Unsigned_32 (Character'Pos (In_Char));
93 if (U and 2#11000000#) /= 2#10_000000# then
94 raise Constraint_Error;
97 W := Shift_Left (W, 6) or (U and 2#00111111#);
100 -- Start of processing for Char_Sequence_To_Wide
106 if C /= ASCII.ESC then
107 return Character'Pos (C);
116 return UTF_32_Code (B1);
120 if C > ASCII.DEL then
121 return 256 * Character'Pos (C) + Character'Pos (In_Char);
123 return Character'Pos (C);
126 when WCEM_Shift_JIS =>
127 if C > ASCII.DEL then
128 return Wide_Character'Pos (Shift_JIS_To_JIS (C, In_Char));
130 return Character'Pos (C);
134 if C > ASCII.DEL then
135 return Wide_Character'Pos (EUC_To_JIS (C, In_Char));
137 return Character'Pos (C);
142 -- Note: for details of UTF8 encoding see RFC 3629
144 U := Unsigned_32 (Character'Pos (C));
146 -- 16#00_0000#-16#00_007F#: 0xxxxxxx
148 if (U and 2#10000000#) = 2#00000000# then
149 return Character'Pos (C);
151 -- 16#00_0080#-16#00_07FF#: 110xxxxx 10xxxxxx
153 elsif (U and 2#11100000#) = 2#110_00000# then
154 W := Shift_Left (U and 2#00011111#, 6);
155 U := Unsigned_32 (Character'Pos (In_Char));
157 if (U and 2#11000000#) /= 2#10_000000# then
158 raise Constraint_Error;
161 W := W or (U and 2#00111111#);
163 return UTF_32_Code (W);
165 -- 16#00_0800#-16#00_ffff#: 1110xxxx 10xxxxxx 10xxxxxx
167 elsif (U and 2#11110000#) = 2#1110_0000# then
168 W := U and 2#00001111#;
171 return UTF_32_Code (W);
173 -- 16#01_0000#-16#10_FFFF#: 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx
175 elsif (U and 2#11111000#) = 2#11110_000# then
176 W := U and 2#00000111#;
182 return UTF_32_Code (W);
184 -- 16#0020_0000#-16#03FF_FFFF#: 111110xx 10xxxxxx 10xxxxxx
187 elsif (U and 2#11111100#) = 2#111110_00# then
188 W := U and 2#00000011#;
194 return UTF_32_Code (W);
196 -- 16#0400_0000#-16#7FFF_FFFF#: 1111110x 10xxxxxx 10xxxxxx
197 -- 10xxxxxx 10xxxxxx 10xxxxxx
199 elsif (U and 2#11111110#) = 2#1111110_0# then
200 W := U and 2#00000001#;
206 return UTF_32_Code (W);
209 raise Constraint_Error;
212 when WCEM_Brackets =>
215 return Character'Pos (C);
218 if In_Char /= '"' then
219 raise Constraint_Error;
244 if B1 > Unsigned_32 (UTF_32_Code'Last) then
245 raise Constraint_Error;
248 if In_Char /= '"' then
249 raise Constraint_Error;
255 if In_Char /= ']' then
256 raise Constraint_Error;
259 return UTF_32_Code (B1);
262 end Char_Sequence_To_UTF_32;
264 --------------------------------
265 -- Char_Sequence_To_Wide_Char --
266 --------------------------------
268 function Char_Sequence_To_Wide_Char
270 EM : System.WCh_Con.WC_Encoding_Method) return Wide_Character
272 function Char_Sequence_To_UTF is new Char_Sequence_To_UTF_32 (In_Char);
274 U : constant UTF_32_Code := Char_Sequence_To_UTF (C, EM);
278 raise Constraint_Error;
280 return Wide_Character'Val (U);
282 end Char_Sequence_To_Wide_Char;
284 -----------------------------
285 -- UTF_32_To_Char_Sequence --
286 -----------------------------
288 procedure UTF_32_To_Char_Sequence
290 EM : System.WCh_Con.WC_Encoding_Method)
292 Hexc : constant array (UTF_32_Code range 0 .. 15) of Character :=
303 Out_Char (Character'Val (Val));
304 elsif Val <= 16#FFFF# then
305 Out_Char (ASCII.ESC);
306 Out_Char (Hexc (Val / (16**3)));
307 Out_Char (Hexc ((Val / (16**2)) mod 16));
308 Out_Char (Hexc ((Val / 16) mod 16));
309 Out_Char (Hexc (Val mod 16));
311 raise Constraint_Error;
316 Out_Char (Character'Val (Val));
317 elsif Val < 16#8000# or else Val > 16#FFFF# then
318 raise Constraint_Error;
320 Out_Char (Character'Val (Val / 256));
321 Out_Char (Character'Val (Val mod 256));
324 when WCEM_Shift_JIS =>
326 Out_Char (Character'Val (Val));
327 elsif Val <= 16#FFFF# then
328 JIS_To_Shift_JIS (Wide_Character'Val (Val), C1, C2);
332 raise Constraint_Error;
337 Out_Char (Character'Val (Val));
338 elsif Val <= 16#FFFF# then
339 JIS_To_EUC (Wide_Character'Val (Val), C1, C2);
343 raise Constraint_Error;
348 -- Note: for details of UTF8 encoding see RFC 3629
350 U := Unsigned_32 (Val);
352 -- 16#00_0000#-16#00_007F#: 0xxxxxxx
354 if U <= 16#00_007F# then
355 Out_Char (Character'Val (U));
357 -- 16#00_0080#-16#00_07FF#: 110xxxxx 10xxxxxx
359 elsif U <= 16#00_07FF# then
360 Out_Char (Character'Val (2#11000000# or Shift_Right (U, 6)));
361 Out_Char (Character'Val (2#10000000# or (U and 2#00111111#)));
363 -- 16#00_0800#-16#00_FFFF#: 1110xxxx 10xxxxxx 10xxxxxx
365 elsif U <= 16#00_FFFF# then
366 Out_Char (Character'Val (2#11100000# or Shift_Right (U, 12)));
367 Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 6)
369 Out_Char (Character'Val (2#10000000# or (U and 2#00111111#)));
371 -- 16#01_0000#-16#10_FFFF#: 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx
373 elsif U <= 16#10_FFFF# then
374 Out_Char (Character'Val (2#11110000# or Shift_Right (U, 18)));
375 Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 12)
377 Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 6)
379 Out_Char (Character'Val (2#10000000# or (U and 2#00111111#)));
381 -- 16#0020_0000#-16#03FF_FFFF#: 111110xx 10xxxxxx 10xxxxxx
384 elsif U <= 16#03FF_FFFF# then
385 Out_Char (Character'Val (2#11111000# or Shift_Right (U, 24)));
386 Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 18)
388 Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 12)
390 Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 6)
392 Out_Char (Character'Val (2#10000000# or (U and 2#00111111#)));
394 -- 16#0400_0000#-16#7FFF_FFFF#: 1111110x 10xxxxxx 10xxxxxx
395 -- 10xxxxxx 10xxxxxx 10xxxxxx
397 elsif U <= 16#7FFF_FFFF# then
398 Out_Char (Character'Val (2#11111100# or Shift_Right (U, 30)));
399 Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 24)
401 Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 18)
403 Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 12)
405 Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 6)
407 Out_Char (Character'Val (2#10000000# or (U and 2#00111111#)));
410 raise Constraint_Error;
413 when WCEM_Brackets =>
415 Out_Char (Character'Val (Val));
421 if Val > 16#FFFF# then
422 if Val > 16#00FF_FFFF# then
423 if Val > 16#7FFF_FFFF# then
424 raise Constraint_Error;
427 Out_Char (Hexc (Val / 16 ** 7));
428 Out_Char (Hexc ((Val / 16 ** 6) mod 16));
431 Out_Char (Hexc ((Val / 16 ** 5) mod 16));
432 Out_Char (Hexc ((Val / 16 ** 4) mod 16));
435 Out_Char (Hexc ((Val / 16 ** 3) mod 16));
436 Out_Char (Hexc ((Val / 16 ** 2) mod 16));
437 Out_Char (Hexc ((Val / 16) mod 16));
438 Out_Char (Hexc (Val mod 16));
444 end UTF_32_To_Char_Sequence;
446 --------------------------------
447 -- Wide_Char_To_Char_Sequence --
448 --------------------------------
450 procedure Wide_Char_To_Char_Sequence
451 (WC : Wide_Character;
452 EM : System.WCh_Con.WC_Encoding_Method)
454 procedure UTF_To_Char_Sequence is new UTF_32_To_Char_Sequence (Out_Char);
456 UTF_To_Char_Sequence (Wide_Character'Pos (WC), EM);
457 end Wide_Char_To_Char_Sequence;