1 ------------------------------------------------------------------------------
3 -- GNAT RUNTIME COMPONENTS --
5 -- S Y S T E M . W C H _ C N V --
10 -- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
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. --
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. --
30 -- GNAT was originally developed by the GNAT team at New York University. --
31 -- Extensive contributions were provided by Ada Core Technologies Inc. --
33 ------------------------------------------------------------------------------
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.
39 with Interfaces
; use Interfaces
;
40 with System
.WCh_Con
; use System
.WCh_Con
;
41 with System
.WCh_JIS
; use System
.WCh_JIS
;
43 package body System
.WCh_Cnv
is
45 --------------------------------
46 -- Char_Sequence_To_Wide_Char --
47 --------------------------------
49 function Char_Sequence_To_Wide_Char
51 EM
: WC_Encoding_Method
)
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.
67 procedure Get_Hex
(N
: Character) is
68 B2
: constant Integer := Character'Pos (N
);
71 if B2
in Character'Pos ('0') .. Character'Pos ('9') then
72 B1
:= B1
* 16 + B2
- Character'Pos ('0');
74 elsif B2
in Character'Pos ('A') .. Character'Pos ('F') then
75 B1
:= B1
* 16 + B2
- (Character'Pos ('A') - 10);
77 elsif B2
in Character'Pos ('a') .. Character'Pos ('f') then
78 B1
:= B1
* 16 + B2
- (Character'Pos ('a') - 10);
81 raise Constraint_Error
;
85 -- Start of processing for Char_Sequence_To_Wide_Char
91 if C
/= ASCII
.ESC
then
92 return Wide_Character'Val (Character'Pos (C
));
101 return Wide_Character'Val (B1
);
105 if C
> ASCII
.DEL
then
108 (Integer (256 * Character'Pos (C
)) +
109 Character'Pos (In_Char
));
111 return Wide_Character'Val (Character'Pos (C
));
114 when WCEM_Shift_JIS
=>
115 if C
> ASCII
.DEL
then
116 return Shift_JIS_To_JIS
(C
, In_Char
);
118 return Wide_Character'Val (Character'Pos (C
));
122 if C
> ASCII
.DEL
then
123 return EUC_To_JIS
(C
, In_Char
);
125 return Wide_Character'Val (Character'Pos (C
));
129 if C
> ASCII
.DEL
then
131 -- 16#0080#-16#07ff#: 2#110xxxxx# 2#10xxxxxx#
132 -- 16#0800#-16#ffff#: 2#1110xxxx# 2#10xxxxxx# 2#10xxxxxx#
134 U
:= Unsigned_16
(Character'Pos (C
));
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
));
140 if (U
and 2#
11000000#
) /= 2#
10000000#
then
141 raise Constraint_Error
;
144 W
:= W
or (U
and 2#
00111111#
);
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
));
150 if (U
and 2#
11000000#
) /= 2#
10000000#
then
151 raise Constraint_Error
;
154 W
:= W
or Shift_Left
(U
and 2#
00111111#
, 6);
155 U
:= Unsigned_16
(Character'Pos (In_Char
));
157 if (U
and 2#
11000000#
) /= 2#
10000000#
then
158 raise Constraint_Error
;
161 W
:= W
or (U
and 2#
00111111#
);
164 raise Constraint_Error
;
167 return Wide_Character'Val (W
);
170 return Wide_Character'Val (Character'Pos (C
));
173 when WCEM_Brackets
=>
176 return Wide_Character'Val (Character'Pos (C
));
179 if In_Char
/= '"' then
180 raise Constraint_Error
;
194 raise Constraint_Error
;
198 if In_Char
/= ']' then
199 raise Constraint_Error
;
202 return Wide_Character'Val (B1
);
205 end Char_Sequence_To_Wide_Char
;
207 --------------------------------
208 -- Wide_Char_To_Char_Sequence --
209 --------------------------------
211 procedure Wide_Char_To_Char_Sequence
212 (WC
: Wide_Character;
213 EM
: WC_Encoding_Method
)
215 Val
: constant Natural := Wide_Character'Pos (WC
);
216 Hexc
: constant array (0 .. 15) of Character := "0123456789ABCDEF";
225 Out_Char
(Character'Val (Val
));
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));
237 Out_Char
(Character'Val (Val
));
239 elsif Val
< 16#
8000#
then
240 raise Constraint_Error
;
243 Out_Char
(Character'Val (Val
/ 256));
244 Out_Char
(Character'Val (Val
mod 256));
247 when WCEM_Shift_JIS
=>
249 Out_Char
(Character'Val (Val
));
251 JIS_To_Shift_JIS
(WC
, C1
, C2
);
258 Out_Char
(Character'Val (Val
));
260 JIS_To_EUC
(WC
, C1
, C2
);
266 U
:= Unsigned_16
(Val
);
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#
273 Out_Char
(Character'Val (U
));
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#
)));
280 Out_Char
(Character'Val (2#
11100000#
or Shift_Right
(U
, 12)));
281 Out_Char
(Character'Val (2#
10000000#
or (Shift_Right
(U
, 6)
283 Out_Char
(Character'Val (2#
10000000#
or (U
and 2#
00111111#
)));
286 when WCEM_Brackets
=>
289 Out_Char
(Character'Val (Val
));
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));
302 end Wide_Char_To_Char_Sequence
;