1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- S Y S T E M . W C H _ J I S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. -- 17-- -- 18-- As a special exception under Section 7 of GPL version 3, you are granted -- 19-- additional permissions described in the GCC Runtime Library Exception, -- 20-- version 3.1, as published by the Free Software Foundation. -- 21-- -- 22-- You should have received a copy of the GNU General Public License and -- 23-- a copy of the GCC Runtime Library Exception along with this program; -- 24-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25-- <http://www.gnu.org/licenses/>. -- 26-- -- 27-- GNAT was originally developed by the GNAT team at New York University. -- 28-- Extensive contributions were provided by Ada Core Technologies Inc. -- 29-- -- 30------------------------------------------------------------------------------ 31 32pragma Compiler_Unit_Warning; 33 34package body System.WCh_JIS is 35 36 type Byte is mod 256; 37 38 EUC_Hankaku_Kana : constant Byte := 16#8E#; 39 -- Prefix byte in EUC for Hankaku Kana (small Katakana). Such characters 40 -- in EUC are represented by a prefix byte followed by the code, which 41 -- is in the upper half (the corresponding JIS internal code is in the 42 -- range 16#0080# - 16#00FF#). 43 44 function EUC_To_JIS (EUC1, EUC2 : Character) return Wide_Character is 45 EUC1B : constant Byte := Character'Pos (EUC1); 46 EUC2B : constant Byte := Character'Pos (EUC2); 47 48 begin 49 if EUC2B not in 16#A0# .. 16#FE# then 50 raise Constraint_Error; 51 end if; 52 53 if EUC1B = EUC_Hankaku_Kana then 54 return Wide_Character'Val (EUC2B); 55 56 else 57 if EUC1B not in 16#A0# .. 16#FE# then 58 raise Constraint_Error; 59 else 60 return Wide_Character'Val 61 (256 * Natural (EUC1B and 16#7F#) + Natural (EUC2B and 16#7F#)); 62 end if; 63 end if; 64 end EUC_To_JIS; 65 66 ---------------- 67 -- JIS_To_EUC -- 68 ---------------- 69 70 procedure JIS_To_EUC 71 (J : Wide_Character; 72 EUC1 : out Character; 73 EUC2 : out Character) 74 is 75 JIS1 : constant Natural := Wide_Character'Pos (J) / 256; 76 JIS2 : constant Natural := Wide_Character'Pos (J) rem 256; 77 78 begin 79 -- Special case of small Katakana 80 81 if JIS1 = 0 then 82 83 -- The value must be in the range 16#80# to 16#FF# so that the upper 84 -- bit is set in both bytes. 85 86 if JIS2 < 16#80# then 87 raise Constraint_Error; 88 end if; 89 90 EUC1 := Character'Val (EUC_Hankaku_Kana); 91 EUC2 := Character'Val (JIS2); 92 93 -- The upper bit of both characters must be clear, or this is not 94 -- a valid character for representation in EUC form. 95 96 elsif JIS1 > 16#7F# or else JIS2 > 16#7F# then 97 raise Constraint_Error; 98 99 -- Result is just the two characters with upper bits set 100 101 else 102 EUC1 := Character'Val (JIS1 + 16#80#); 103 EUC2 := Character'Val (JIS2 + 16#80#); 104 end if; 105 end JIS_To_EUC; 106 107 ---------------------- 108 -- JIS_To_Shift_JIS -- 109 ---------------------- 110 111 procedure JIS_To_Shift_JIS 112 (J : Wide_Character; 113 SJ1 : out Character; 114 SJ2 : out Character) 115 is 116 JIS1 : Byte; 117 JIS2 : Byte; 118 119 begin 120 -- The following is the required algorithm, it's hard to make any 121 -- more intelligent comments. This was copied from a public domain 122 -- C program called etos.c (author unknown). 123 124 JIS1 := Byte (Natural (Wide_Character'Pos (J) / 256)); 125 JIS2 := Byte (Natural (Wide_Character'Pos (J) rem 256)); 126 127 if JIS1 > 16#5F# then 128 JIS1 := JIS1 + 16#80#; 129 end if; 130 131 if (JIS1 mod 2) = 0 then 132 SJ1 := Character'Val ((JIS1 - 16#30#) / 2 + 16#88#); 133 SJ2 := Character'Val (JIS2 + 16#7E#); 134 135 else 136 if JIS2 >= 16#60# then 137 JIS2 := JIS2 + 16#01#; 138 end if; 139 140 SJ1 := Character'Val ((JIS1 - 16#31#) / 2 + 16#89#); 141 SJ2 := Character'Val (JIS2 + 16#1F#); 142 end if; 143 end JIS_To_Shift_JIS; 144 145 ---------------------- 146 -- Shift_JIS_To_JIS -- 147 ---------------------- 148 149 function Shift_JIS_To_JIS (SJ1, SJ2 : Character) return Wide_Character is 150 SJIS1 : Byte; 151 SJIS2 : Byte; 152 JIS1 : Byte; 153 JIS2 : Byte; 154 155 begin 156 -- The following is the required algorithm, it's hard to make any 157 -- more intelligent comments. This was copied from a public domain 158 -- C program called stoj.c written by shige@csk.JUNET. 159 160 SJIS1 := Character'Pos (SJ1); 161 SJIS2 := Character'Pos (SJ2); 162 163 if SJIS1 >= 16#E0# then 164 SJIS1 := SJIS1 - 16#40#; 165 end if; 166 167 if SJIS2 >= 16#9F# then 168 JIS1 := (SJIS1 - 16#88#) * 2 + 16#30#; 169 JIS2 := SJIS2 - 16#7E#; 170 171 else 172 if SJIS2 >= 16#7F# then 173 SJIS2 := SJIS2 - 16#01#; 174 end if; 175 176 JIS1 := (SJIS1 - 16#89#) * 2 + 16#31#; 177 JIS2 := SJIS2 - 16#1F#; 178 end if; 179 180 if JIS1 not in 16#20# .. 16#7E# 181 or else JIS2 not in 16#20# .. 16#7E# 182 then 183 raise Constraint_Error; 184 else 185 return Wide_Character'Val (256 * Natural (JIS1) + Natural (JIS2)); 186 end if; 187 end Shift_JIS_To_JIS; 188 189end System.WCh_JIS; 190