------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- S Y S T E M . W C H _ S T W -- -- -- -- B o d y -- -- -- -- -- -- Copyright (C) 1992-2000 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. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ with Interfaces; use Interfaces; with System.WCh_Con; use System.WCh_Con; with System.WCh_JIS; use System.WCh_JIS; package body System.WCh_StW is --------------------------- -- String_To_Wide_String -- --------------------------- function String_To_Wide_String (S : String; EM : WC_Encoding_Method) return Wide_String is R : Wide_String (1 .. S'Length); RP : Natural; SP : Natural; U1 : Unsigned_16; U2 : Unsigned_16; U3 : Unsigned_16; U : Unsigned_16; Last : constant Natural := S'Last; function Get_Hex (C : Character) return Unsigned_16; -- Converts character from hex digit to value in range 0-15. The -- input must be in 0-9, A-F, or a-f, and no check is needed. procedure Get_Hex_4; -- Translates four hex characters starting at S (SP) to a single -- wide character. Used in WCEM_Hex and WCEM_Brackets mode. SP -- is not modified by the call. The resulting wide character value -- is stored in R (RP). RP is not modified by the call. function Get_Hex (C : Character) return Unsigned_16 is begin if C in '0' .. '9' then return Character'Pos (C) - Character'Pos ('0'); elsif C in 'A' .. 'F' then return Character'Pos (C) - Character'Pos ('A') + 10; else return Character'Pos (C) - Character'Pos ('a') + 10; end if; end Get_Hex; procedure Get_Hex_4 is begin R (RP) := Wide_Character'Val ( Get_Hex (S (SP + 3)) + 16 * (Get_Hex (S (SP + 2)) + 16 * (Get_Hex (S (SP + 1)) + 16 * (Get_Hex (S (SP + 0)))))); end Get_Hex_4; -- Start of processing for String_To_Wide_String begin SP := S'First; RP := 0; case EM is -- ESC-Hex representation when WCEM_Hex => while SP <= Last - 4 loop RP := RP + 1; if S (SP) = ASCII.ESC then SP := SP + 1; Get_Hex_4; SP := SP + 4; else R (RP) := Wide_Character'Val (Character'Pos (S (SP))); SP := SP + 1; end if; end loop; -- Upper bit shift, internal code = external code when WCEM_Upper => while SP < Last loop RP := RP + 1; if S (SP) >= Character'Val (16#80#) then U1 := Character'Pos (S (SP)); U2 := Character'Pos (S (SP + 1)); R (RP) := Wide_Character'Val (256 * U1 + U2); SP := SP + 2; else R (RP) := Wide_Character'Val (Character'Pos (S (SP))); SP := SP + 1; end if; end loop; -- Upper bit shift, shift-JIS when WCEM_Shift_JIS => while SP < Last loop RP := RP + 1; if S (SP) >= Character'Val (16#80#) then R (RP) := Shift_JIS_To_JIS (S (SP), S (SP + 1)); SP := SP + 2; else R (RP) := Wide_Character'Val (Character'Pos (S (SP))); SP := SP + 1; end if; end loop; -- Upper bit shift, EUC when WCEM_EUC => while SP < Last loop RP := RP + 1; if S (SP) >= Character'Val (16#80#) then R (RP) := EUC_To_JIS (S (SP), S (SP + 1)); SP := SP + 2; else R (RP) := Wide_Character'Val (Character'Pos (S (SP))); SP := SP + 1; end if; end loop; -- Upper bit shift, UTF-8 when WCEM_UTF8 => while SP < Last loop RP := RP + 1; if S (SP) >= Character'Val (16#80#) then U1 := Character'Pos (S (SP)); U2 := Character'Pos (S (SP + 1)); U := Shift_Left (U1 and 2#00011111#, 6) + (U2 and 2#00111111#); SP := SP + 2; if U1 >= 2#11100000# then U3 := Character'Pos (S (SP)); U := Shift_Left (U, 6) + (U3 and 2#00111111#); SP := SP + 1; end if; R (RP) := Wide_Character'Val (U); else R (RP) := Wide_Character'Val (Character'Pos (S (SP))); SP := SP + 1; end if; end loop; -- Brackets representation when WCEM_Brackets => while SP <= Last - 7 loop RP := RP + 1; if S (SP) = '[' and then S (SP + 1) = '"' and then S (SP + 2) /= '"' then SP := SP + 2; Get_Hex_4; SP := SP + 6; else R (RP) := Wide_Character'Val (Character'Pos (S (SP))); SP := SP + 1; end if; end loop; end case; while SP <= Last loop RP := RP + 1; R (RP) := Wide_Character'Val (Character'Pos (S (SP))); SP := SP + 1; end loop; return R (1 .. RP); end String_To_Wide_String; end System.WCh_StW;