305 lines
10 KiB
Ada
305 lines
10 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT RUNTIME COMPONENTS --
|
|
-- --
|
|
-- S Y S T E M . W C H _ C N V --
|
|
-- --
|
|
-- B o d y --
|
|
-- --
|
|
-- --
|
|
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
|
|
-- --
|
|
-- GNAT is free software; you can redistribute it and/or modify it under --
|
|
-- terms of the GNU General Public License as published by the Free Soft- --
|
|
-- ware Foundation; either version 2, or (at your option) any later ver- --
|
|
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
|
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
|
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
|
|
-- for more details. You should have received a copy of the GNU General --
|
|
-- Public License distributed with GNAT; see file COPYING. If not, write --
|
|
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
|
-- MA 02111-1307, USA. --
|
|
-- --
|
|
-- As a special exception, if other files instantiate generics from this --
|
|
-- unit, or you link this unit with other files to produce an executable, --
|
|
-- this unit does not by itself cause the resulting executable to be --
|
|
-- covered by the GNU General Public License. This exception does not --
|
|
-- however invalidate any other reasons why the executable file might be --
|
|
-- covered by the GNU Public License. --
|
|
-- --
|
|
-- GNAT was originally developed by the GNAT team at New York University. --
|
|
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
|
-- --
|
|
------------------------------------------------------------------------------
|
|
|
|
-- This package contains generic subprograms used for converting between
|
|
-- sequences of Character and Wide_Character. All access to wide character
|
|
-- sequences is isolated in this unit.
|
|
|
|
with Interfaces; use Interfaces;
|
|
with System.WCh_Con; use System.WCh_Con;
|
|
with System.WCh_JIS; use System.WCh_JIS;
|
|
|
|
package body System.WCh_Cnv is
|
|
|
|
--------------------------------
|
|
-- Char_Sequence_To_Wide_Char --
|
|
--------------------------------
|
|
|
|
function Char_Sequence_To_Wide_Char
|
|
(C : Character;
|
|
EM : WC_Encoding_Method)
|
|
return Wide_Character
|
|
is
|
|
B1 : Integer;
|
|
C1 : Character;
|
|
U : Unsigned_16;
|
|
W : Unsigned_16;
|
|
|
|
procedure Get_Hex (N : Character);
|
|
-- If N is a hex character, then set B1 to 16 * B1 + character N.
|
|
-- Raise Constraint_Error if character N is not a hex character.
|
|
|
|
-------------
|
|
-- Get_Hex --
|
|
-------------
|
|
|
|
procedure Get_Hex (N : Character) is
|
|
B2 : constant Integer := Character'Pos (N);
|
|
|
|
begin
|
|
if B2 in Character'Pos ('0') .. Character'Pos ('9') then
|
|
B1 := B1 * 16 + B2 - Character'Pos ('0');
|
|
|
|
elsif B2 in Character'Pos ('A') .. Character'Pos ('F') then
|
|
B1 := B1 * 16 + B2 - (Character'Pos ('A') - 10);
|
|
|
|
elsif B2 in Character'Pos ('a') .. Character'Pos ('f') then
|
|
B1 := B1 * 16 + B2 - (Character'Pos ('a') - 10);
|
|
|
|
else
|
|
raise Constraint_Error;
|
|
end if;
|
|
end Get_Hex;
|
|
|
|
-- Start of processing for Char_Sequence_To_Wide_Char
|
|
|
|
begin
|
|
case EM is
|
|
|
|
when WCEM_Hex =>
|
|
if C /= ASCII.ESC then
|
|
return Wide_Character'Val (Character'Pos (C));
|
|
|
|
else
|
|
B1 := 0;
|
|
Get_Hex (In_Char);
|
|
Get_Hex (In_Char);
|
|
Get_Hex (In_Char);
|
|
Get_Hex (In_Char);
|
|
|
|
return Wide_Character'Val (B1);
|
|
end if;
|
|
|
|
when WCEM_Upper =>
|
|
if C > ASCII.DEL then
|
|
return
|
|
Wide_Character'Val
|
|
(Integer (256 * Character'Pos (C)) +
|
|
Character'Pos (In_Char));
|
|
else
|
|
return Wide_Character'Val (Character'Pos (C));
|
|
end if;
|
|
|
|
when WCEM_Shift_JIS =>
|
|
if C > ASCII.DEL then
|
|
return Shift_JIS_To_JIS (C, In_Char);
|
|
else
|
|
return Wide_Character'Val (Character'Pos (C));
|
|
end if;
|
|
|
|
when WCEM_EUC =>
|
|
if C > ASCII.DEL then
|
|
return EUC_To_JIS (C, In_Char);
|
|
else
|
|
return Wide_Character'Val (Character'Pos (C));
|
|
end if;
|
|
|
|
when WCEM_UTF8 =>
|
|
if C > ASCII.DEL then
|
|
|
|
-- 16#0080#-16#07ff#: 2#110xxxxx# 2#10xxxxxx#
|
|
-- 16#0800#-16#ffff#: 2#1110xxxx# 2#10xxxxxx# 2#10xxxxxx#
|
|
|
|
U := Unsigned_16 (Character'Pos (C));
|
|
|
|
if (U and 2#11100000#) = 2#11000000# then
|
|
W := Shift_Left (U and 2#00011111#, 6);
|
|
U := Unsigned_16 (Character'Pos (In_Char));
|
|
|
|
if (U and 2#11000000#) /= 2#10000000# then
|
|
raise Constraint_Error;
|
|
end if;
|
|
|
|
W := W or (U and 2#00111111#);
|
|
|
|
elsif (U and 2#11110000#) = 2#11100000# then
|
|
W := Shift_Left (U and 2#00001111#, 12);
|
|
U := Unsigned_16 (Character'Pos (In_Char));
|
|
|
|
if (U and 2#11000000#) /= 2#10000000# then
|
|
raise Constraint_Error;
|
|
end if;
|
|
|
|
W := W or Shift_Left (U and 2#00111111#, 6);
|
|
U := Unsigned_16 (Character'Pos (In_Char));
|
|
|
|
if (U and 2#11000000#) /= 2#10000000# then
|
|
raise Constraint_Error;
|
|
end if;
|
|
|
|
W := W or (U and 2#00111111#);
|
|
|
|
else
|
|
raise Constraint_Error;
|
|
end if;
|
|
|
|
return Wide_Character'Val (W);
|
|
|
|
else
|
|
return Wide_Character'Val (Character'Pos (C));
|
|
end if;
|
|
|
|
when WCEM_Brackets =>
|
|
|
|
if C /= '[' then
|
|
return Wide_Character'Val (Character'Pos (C));
|
|
end if;
|
|
|
|
if In_Char /= '"' then
|
|
raise Constraint_Error;
|
|
end if;
|
|
|
|
B1 := 0;
|
|
Get_Hex (In_Char);
|
|
Get_Hex (In_Char);
|
|
C1 := In_Char;
|
|
|
|
if C1 /= '"' then
|
|
Get_Hex (C1);
|
|
Get_Hex (In_Char);
|
|
C1 := In_Char;
|
|
|
|
if C1 /= '"' then
|
|
raise Constraint_Error;
|
|
end if;
|
|
end if;
|
|
|
|
if In_Char /= ']' then
|
|
raise Constraint_Error;
|
|
end if;
|
|
|
|
return Wide_Character'Val (B1);
|
|
|
|
end case;
|
|
end Char_Sequence_To_Wide_Char;
|
|
|
|
--------------------------------
|
|
-- Wide_Char_To_Char_Sequence --
|
|
--------------------------------
|
|
|
|
procedure Wide_Char_To_Char_Sequence
|
|
(WC : Wide_Character;
|
|
EM : WC_Encoding_Method)
|
|
is
|
|
Val : constant Natural := Wide_Character'Pos (WC);
|
|
Hexc : constant array (0 .. 15) of Character := "0123456789ABCDEF";
|
|
C1, C2 : Character;
|
|
U : Unsigned_16;
|
|
|
|
begin
|
|
case EM is
|
|
|
|
when WCEM_Hex =>
|
|
if Val < 256 then
|
|
Out_Char (Character'Val (Val));
|
|
|
|
else
|
|
Out_Char (ASCII.ESC);
|
|
Out_Char (Hexc (Val / (16**3)));
|
|
Out_Char (Hexc ((Val / (16**2)) mod 16));
|
|
Out_Char (Hexc ((Val / 16) mod 16));
|
|
Out_Char (Hexc (Val mod 16));
|
|
end if;
|
|
|
|
when WCEM_Upper =>
|
|
if Val < 128 then
|
|
Out_Char (Character'Val (Val));
|
|
|
|
elsif Val < 16#8000# then
|
|
raise Constraint_Error;
|
|
|
|
else
|
|
Out_Char (Character'Val (Val / 256));
|
|
Out_Char (Character'Val (Val mod 256));
|
|
end if;
|
|
|
|
when WCEM_Shift_JIS =>
|
|
if Val < 128 then
|
|
Out_Char (Character'Val (Val));
|
|
else
|
|
JIS_To_Shift_JIS (WC, C1, C2);
|
|
Out_Char (C1);
|
|
Out_Char (C2);
|
|
end if;
|
|
|
|
when WCEM_EUC =>
|
|
if Val < 128 then
|
|
Out_Char (Character'Val (Val));
|
|
else
|
|
JIS_To_EUC (WC, C1, C2);
|
|
Out_Char (C1);
|
|
Out_Char (C2);
|
|
end if;
|
|
|
|
when WCEM_UTF8 =>
|
|
U := Unsigned_16 (Val);
|
|
|
|
-- 16#0000#-16#007f#: 2#0xxxxxxx#
|
|
-- 16#0080#-16#07ff#: 2#110xxxxx# 2#10xxxxxx#
|
|
-- 16#0800#-16#ffff#: 2#1110xxxx# 2#10xxxxxx# 2#10xxxxxx#
|
|
|
|
if U < 16#80# then
|
|
Out_Char (Character'Val (U));
|
|
|
|
elsif U < 16#0800# then
|
|
Out_Char (Character'Val (2#11000000# or Shift_Right (U, 6)));
|
|
Out_Char (Character'Val (2#10000000# or (U and 2#00111111#)));
|
|
|
|
else
|
|
Out_Char (Character'Val (2#11100000# or Shift_Right (U, 12)));
|
|
Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 6)
|
|
and 2#00111111#)));
|
|
Out_Char (Character'Val (2#10000000# or (U and 2#00111111#)));
|
|
end if;
|
|
|
|
when WCEM_Brackets =>
|
|
|
|
if Val < 256 then
|
|
Out_Char (Character'Val (Val));
|
|
|
|
else
|
|
Out_Char ('[');
|
|
Out_Char ('"');
|
|
Out_Char (Hexc (Val / (16**3)));
|
|
Out_Char (Hexc ((Val / (16**2)) mod 16));
|
|
Out_Char (Hexc ((Val / 16) mod 16));
|
|
Out_Char (Hexc (Val mod 16));
|
|
Out_Char ('"');
|
|
Out_Char (']');
|
|
end if;
|
|
end case;
|
|
end Wide_Char_To_Char_Sequence;
|
|
|
|
end System.WCh_Cnv;
|