home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / gnat-2.06-src.tgz / tar.out / fsf / gnat / ada / s-wchjis.adb < prev    next >
Text File  |  1996-09-28  |  6KB  |  164 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT RUNTIME COMPONENTS                          --
  4. --                                                                          --
  5. --                       S Y S T E M . W C H _ J I S                        --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.4 $                              --
  10. --                                                                          --
  11. --           Copyright (c) 1992,1993,1994 NYU, All Rights Reserved          --
  12. --                                                                          --
  13. -- The GNAT library is free software; you can redistribute it and/or modify --
  14. -- it under terms of the GNU Library General Public License as published by --
  15. -- the Free Software  Foundation; either version 2, or (at your option) any --
  16. -- later version.  The GNAT library is distributed in the hope that it will --
  17. -- be useful, but WITHOUT ANY WARRANTY;  without even  the implied warranty --
  18. -- of MERCHANTABILITY  or  FITNESS FOR  A PARTICULAR PURPOSE.  See the  GNU --
  19. -- Library  General  Public  License for  more  details.  You  should  have --
  20. -- received  a copy of the GNU  Library  General Public License  along with --
  21. -- the GNAT library;  see the file  COPYING.LIB.  If not, write to the Free --
  22. -- Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.        --
  23. --                                                                          --
  24. ------------------------------------------------------------------------------
  25.  
  26. package body System.WCh_JIS is
  27.  
  28.    type Byte is mod 256;
  29.  
  30.    EUC_Hankaku_Kana : constant Byte := 16#8E#;
  31.    --  Prefix byte in EUC for Hankaku Kana (small Katakana). Such characters
  32.    --  in EUC are represented by a prefix byte followed by the code, which
  33.    --  is in the upper half (the corresponding JIS internal code is in the
  34.    --  range 16#0080# - 16#00FF#).
  35.  
  36.    function EUC_To_JIS (EUC1, EUC2 : Character) return Wide_Character is
  37.       EUC1B  : constant Byte := Character'Pos (EUC1);
  38.       EUC2B  : constant Byte := Character'Pos (EUC2);
  39.  
  40.    begin
  41.       if EUC2B not in 16#A0# .. 16#FE# then
  42.          raise Constraint_Error;
  43.       end if;
  44.  
  45.       if EUC1B = EUC_Hankaku_Kana then
  46.          return Wide_Character'Val (EUC2B);
  47.  
  48.       else
  49.          if EUC1B not in 16#A0# .. 16#FE# then
  50.             raise Constraint_Error;
  51.          else
  52.             return Wide_Character'Val
  53.               (256 * Natural (EUC1B and 16#7F#) + Natural (EUC2B and 16#7F#));
  54.          end if;
  55.       end if;
  56.    end EUC_To_JIS;
  57.  
  58.    ----------------
  59.    -- JIS_To_EUC --
  60.    ----------------
  61.  
  62.    procedure JIS_To_EUC
  63.      (J    : in Wide_Character;
  64.       EUC1 : out Character;
  65.       EUC2 : out Character)
  66.    is
  67.       JIS1 : constant Natural := Wide_Character'Pos (J) / 256;
  68.       JIS2 : constant Natural := Wide_Character'Pos (J) rem 256;
  69.  
  70.    begin
  71.       if JIS1 = 0 then
  72.          EUC1 := Character'Val (EUC_Hankaku_Kana);
  73.          EUC2 := Character'Val (JIS2);
  74.  
  75.       else
  76.          EUC1 := Character'Val (JIS1 + 16#80#);
  77.          EUC2 := Character'Val (JIS2 + 16#80#);
  78.       end if;
  79.    end JIS_To_EUC;
  80.  
  81.    ----------------------
  82.    -- JIS_To_Shift_JIS --
  83.    ----------------------
  84.  
  85.    procedure JIS_To_Shift_JIS
  86.      (J   : in Wide_Character;
  87.       SJ1 : out Character;
  88.       SJ2 : out Character)
  89.    is
  90.       JIS1 : Byte;
  91.       JIS2 : Byte;
  92.  
  93.    begin
  94.       --  The following is the required algorithm, it's hard to make any
  95.       --  more intelligent comments! This was copied from a public domain
  96.       --  C program called etos.c (author unknown).
  97.  
  98.       JIS1 := Byte (Natural (Wide_Character'Pos (J) / 256));
  99.       JIS2 := Byte (Natural (Wide_Character'Pos (J) rem 256));
  100.  
  101.       if JIS1 > 16#5F# then
  102.          JIS1 := JIS1 + 16#80#;
  103.       end if;
  104.  
  105.       if (JIS1 mod 2) = 0 then
  106.          SJ1 := Character'Val ((JIS1 - 16#30#) / 2 + 16#88#);
  107.          SJ2 := Character'Val (JIS2 + 16#7E#);
  108.  
  109.       else
  110.          if JIS2 >= 16#60# then
  111.             JIS2 := JIS2 + 16#01#;
  112.          end if;
  113.  
  114.          SJ1 := Character'Val ((JIS1 - 16#31#) / 2 + 16#89#);
  115.          SJ2 := Character'Val (JIS2 + 16#1F#);
  116.       end if;
  117.    end JIS_To_Shift_JIS;
  118.  
  119.    ----------------------
  120.    -- Shift_JIS_To_JIS --
  121.    ----------------------
  122.  
  123.    function Shift_JIS_To_JIS (SJ1, SJ2 : Character) return Wide_Character is
  124.       SJIS1 : Byte;
  125.       SJIS2 : Byte;
  126.       JIS1  : Byte;
  127.       JIS2  : Byte;
  128.  
  129.    begin
  130.       --  The following is the required algorithm, it's hard to make any
  131.       --  more intelligent comments! This was copied from a public domain
  132.       --  C program called stoj.c written by shige@csk.JUNET.
  133.  
  134.       SJIS1 := Character'Pos (SJ1);
  135.       SJIS2 := Character'Pos (SJ2);
  136.  
  137.       if SJIS1 >= 16#E0# then
  138.          SJIS1 := SJIS1 - 16#40#;
  139.       end if;
  140.  
  141.       if SJIS2 >= 16#9F# then
  142.          JIS1 := (SJIS1 - 16#88#) * 2 + 16#30#;
  143.          JIS2 := SJIS2 - 16#7E#;
  144.  
  145.       else
  146.          if SJIS2 >= 16#7F# then
  147.             SJIS2 := SJIS2 - 16#01#;
  148.          end if;
  149.  
  150.          JIS1 := (SJIS1 - 16#89#) * 2 + 16#31#;
  151.          JIS2 := SJIS2 - 16#1F#;
  152.       end if;
  153.  
  154.       if JIS1 not in 16#20# .. 16#7E#
  155.         or else JIS2 not in 16#20# .. 16#7E#
  156.       then
  157.          raise Constraint_Error;
  158.       else
  159.          return Wide_Character'Val (256 * Natural (JIS1) + Natural (JIS2));
  160.       end if;
  161.    end Shift_JIS_To_JIS;
  162.  
  163. end System.WCh_JIS;
  164.