home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / adav313.zip / gnat-3_13p-os2-bin-20010916.zip / emx / gnatlib / s-wchcnv.adb < prev    next >
Text File  |  2000-07-19  |  11KB  |  305 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT RUNTIME COMPONENTS                          --
  4. --                                                                          --
  5. --                       S Y S T E M . W C H _ C N V                        --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.7 $
  10. --                                                                          --
  11. --          Copyright (C) 1992-2000 Free Software Foundation, Inc.          --
  12. --                                                                          --
  13. -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14. -- terms of the  GNU General Public License as published  by the Free Soft- --
  15. -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16. -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17. -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18. -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19. -- for  more details.  You should have  received  a copy of the GNU General --
  20. -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21. -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22. -- MA 02111-1307, USA.                                                      --
  23. --                                                                          --
  24. -- As a special exception,  if other files  instantiate  generics from this --
  25. -- unit, or you link  this unit with other files  to produce an executable, --
  26. -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27. -- covered  by the  GNU  General  Public  License.  This exception does not --
  28. -- however invalidate  any other reasons why  the executable file  might be --
  29. -- covered by the  GNU Public License.                                      --
  30. --                                                                          --
  31. -- GNAT was originally developed  by the GNAT team at  New York University. --
  32. -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  33. --                                                                          --
  34. ------------------------------------------------------------------------------
  35.  
  36. --  This package contains generic subprograms used for converting between
  37. --  sequences of Character and Wide_Character. All access to wide character
  38. --  sequences is isolated in this unit.
  39.  
  40. with Interfaces;     use Interfaces;
  41. with System.WCh_Con; use System.WCh_Con;
  42. with System.WCh_JIS; use System.WCh_JIS;
  43.  
  44. package body System.WCh_Cnv is
  45.  
  46.    --------------------------------
  47.    -- Char_Sequence_To_Wide_Char --
  48.    --------------------------------
  49.  
  50.    function Char_Sequence_To_Wide_Char
  51.      (C    : Character;
  52.       EM   : WC_Encoding_Method)
  53.       return Wide_Character
  54.    is
  55.       B1 : Integer;
  56.       C1 : Character;
  57.       U  : Unsigned_16;
  58.       W  : Unsigned_16;
  59.  
  60.       procedure Get_Hex (N : Character);
  61.       --  If N is a hex character, then set B1 to 16 * B1 + character N.
  62.       --  Raise Constraint_Error if character N is not a hex character.
  63.  
  64.       -------------
  65.       -- Get_Hex --
  66.       -------------
  67.  
  68.       procedure Get_Hex (N : Character) is
  69.          B2 : constant Integer := Character'Pos (N);
  70.  
  71.       begin
  72.          if B2 in Character'Pos ('0') .. Character'Pos ('9') then
  73.             B1 := B1 * 16 + B2 - Character'Pos ('0');
  74.  
  75.          elsif B2 in Character'Pos ('A') .. Character'Pos ('F') then
  76.             B1 := B1 * 16 + B2 - (Character'Pos ('A') - 10);
  77.  
  78.          elsif B2 in Character'Pos ('a') .. Character'Pos ('f') then
  79.             B1 := B1 * 16 + B2 - (Character'Pos ('a') - 10);
  80.  
  81.          else
  82.             raise Constraint_Error;
  83.          end if;
  84.       end Get_Hex;
  85.  
  86.    --  Start of processing for Char_Sequence_To_Wide_Char
  87.  
  88.    begin
  89.       case EM is
  90.  
  91.          when WCEM_Hex =>
  92.             if C /= ASCII.ESC then
  93.                return Wide_Character'Val (Character'Pos (C));
  94.  
  95.             else
  96.                B1 := 0;
  97.                Get_Hex (In_Char);
  98.                Get_Hex (In_Char);
  99.                Get_Hex (In_Char);
  100.                Get_Hex (In_Char);
  101.  
  102.                return Wide_Character'Val (B1);
  103.             end if;
  104.  
  105.          when WCEM_Upper =>
  106.             if C > ASCII.DEL then
  107.                return
  108.                  Wide_Character'Val
  109.                    (Integer (256 * Character'Pos (C)) +
  110.                     Character'Pos (In_Char));
  111.             else
  112.                return Wide_Character'Val (Character'Pos (C));
  113.             end if;
  114.  
  115.          when WCEM_Shift_JIS =>
  116.             if C > ASCII.DEL then
  117.                return Shift_JIS_To_JIS (C, In_Char);
  118.             else
  119.                return Wide_Character'Val (Character'Pos (C));
  120.             end if;
  121.  
  122.          when WCEM_EUC =>
  123.             if C > ASCII.DEL then
  124.                return EUC_To_JIS (C, In_Char);
  125.             else
  126.                return Wide_Character'Val (Character'Pos (C));
  127.             end if;
  128.  
  129.          when WCEM_UTF8 =>
  130.             if C > ASCII.DEL then
  131.  
  132.                --  16#0080#-16#07ff#: 2#110xxxxx# 2#10xxxxxx#
  133.                --  16#0800#-16#ffff#: 2#1110xxxx# 2#10xxxxxx# 2#10xxxxxx#
  134.  
  135.                U := Unsigned_16 (Character'Pos (C));
  136.  
  137.                if (U and 2#11100000#) = 2#11000000# then
  138.                   W := Shift_Left (U and 2#00011111#, 6);
  139.                   U := Unsigned_16 (Character'Pos (In_Char));
  140.  
  141.                   if (U and 2#11000000#) /= 2#10000000# then
  142.                      raise Constraint_Error;
  143.                   end if;
  144.  
  145.                   W := W or (U and 2#00111111#);
  146.  
  147.                elsif (U and 2#11110000#) = 2#11100000# then
  148.                   W := Shift_Left (U and 2#00001111#, 12);
  149.                   U := Unsigned_16 (Character'Pos (In_Char));
  150.  
  151.                   if (U and 2#11000000#) /= 2#10000000# then
  152.                      raise Constraint_Error;
  153.                   end if;
  154.  
  155.                   W := W or Shift_Left (U and 2#00111111#, 6);
  156.                   U := Unsigned_16 (Character'Pos (In_Char));
  157.  
  158.                   if (U and 2#11000000#) /= 2#10000000# then
  159.                      raise Constraint_Error;
  160.                   end if;
  161.  
  162.                   W := W or (U and 2#00111111#);
  163.                else
  164.                   raise Constraint_Error;
  165.                end if;
  166.  
  167.                return Wide_Character'Val (W);
  168.  
  169.             else
  170.                return Wide_Character'Val (Character'Pos (C));
  171.             end if;
  172.  
  173.          when WCEM_Brackets =>
  174.  
  175.             if C /= '[' then
  176.                return Wide_Character'Val (Character'Pos (C));
  177.             end if;
  178.  
  179.             if In_Char /= '"' then
  180.                raise Constraint_Error;
  181.             end if;
  182.  
  183.             B1 := 0;
  184.             Get_Hex (In_Char);
  185.             Get_Hex (In_Char);
  186.             C1 := In_Char;
  187.  
  188.             if C1 /= '"' then
  189.                Get_Hex (C1);
  190.                Get_Hex (In_Char);
  191.                C1 := In_Char;
  192.  
  193.                if C1 /= '"' then
  194.                   raise Constraint_Error;
  195.                end if;
  196.             end if;
  197.  
  198.             if In_Char /= ']' then
  199.                raise Constraint_Error;
  200.             end if;
  201.  
  202.             return Wide_Character'Val (B1);
  203.  
  204.       end case;
  205.    end Char_Sequence_To_Wide_Char;
  206.  
  207.    --------------------------------
  208.    -- Wide_Char_To_Char_Sequence --
  209.    --------------------------------
  210.  
  211.    procedure Wide_Char_To_Char_Sequence
  212.      (WC : Wide_Character;
  213.       EM : WC_Encoding_Method)
  214.    is
  215.       Val    : constant Natural := Wide_Character'Pos (WC);
  216.       Hexc   : constant array (0 .. 15) of Character := "0123456789ABCDEF";
  217.       C1, C2 : Character;
  218.       U      : Unsigned_16;
  219.  
  220.    begin
  221.       case EM is
  222.  
  223.          when WCEM_Hex =>
  224.             if Val < 256 then
  225.                Out_Char (Character'Val (Val));
  226.  
  227.             else
  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));
  233.             end if;
  234.  
  235.          when WCEM_Upper =>
  236.             if Val < 128 then
  237.                Out_Char (Character'Val (Val));
  238.  
  239.             elsif Val < 16#8000# then
  240.                raise Constraint_Error;
  241.  
  242.             else
  243.                Out_Char (Character'Val (Val / 256));
  244.                Out_Char (Character'Val (Val mod 256));
  245.             end if;
  246.  
  247.          when WCEM_Shift_JIS =>
  248.             if Val < 128 then
  249.                Out_Char (Character'Val (Val));
  250.             else
  251.                JIS_To_Shift_JIS (WC, C1, C2);
  252.                Out_Char (C1);
  253.                Out_Char (C2);
  254.             end if;
  255.  
  256.          when WCEM_EUC =>
  257.             if Val < 128 then
  258.                Out_Char (Character'Val (Val));
  259.             else
  260.                JIS_To_EUC (WC, C1, C2);
  261.                Out_Char (C1);
  262.                Out_Char (C2);
  263.             end if;
  264.  
  265.          when WCEM_UTF8 =>
  266.             U := Unsigned_16 (Val);
  267.  
  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#
  271.  
  272.             if U < 16#80# then
  273.                Out_Char (Character'Val (U));
  274.  
  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#)));
  278.  
  279.             else
  280.                Out_Char (Character'Val (2#11100000# or Shift_Right (U, 12)));
  281.                Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 6)
  282.                                                          and 2#00111111#)));
  283.                Out_Char (Character'Val (2#10000000# or (U and 2#00111111#)));
  284.             end if;
  285.  
  286.          when WCEM_Brackets =>
  287.  
  288.             if Val < 256 then
  289.                Out_Char (Character'Val (Val));
  290.  
  291.             else
  292.                Out_Char ('[');
  293.                Out_Char ('"');
  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));
  298.                Out_Char ('"');
  299.                Out_Char (']');
  300.             end if;
  301.       end case;
  302.    end Wide_Char_To_Char_Sequence;
  303.  
  304. end System.WCh_Cnv;
  305.