s-wchcnv.adb   [plain text]

------------------------------------------------------------------------------
--                                                                          --
--                         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. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

--  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;