From c32d045231e086867f117700fbe01dbbbce3ea14 Mon Sep 17 00:00:00 2001 From: kenner Date: Tue, 2 Oct 2001 14:30:19 +0000 Subject: New Language: Ada git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@45957 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/s-wchcnv.adb | 305 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 305 insertions(+) create mode 100644 gcc/ada/s-wchcnv.adb (limited to 'gcc/ada/s-wchcnv.adb') diff --git a/gcc/ada/s-wchcnv.adb b/gcc/ada/s-wchcnv.adb new file mode 100644 index 00000000000..f15b3440077 --- /dev/null +++ b/gcc/ada/s-wchcnv.adb @@ -0,0 +1,305 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . W C H _ C N V -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.8 $ +-- -- +-- 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; -- cgit v1.2.1