1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT RUNTIME COMPONENTS                          --
4--                                                                          --
5--                       S Y S T E M . W C H _ S T W                        --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 1992-2000 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 2,  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.  See the GNU General Public License --
17-- for  more details.  You should have  received  a copy of the GNU General --
18-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
19-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
20-- MA 02111-1307, USA.                                                      --
21--                                                                          --
22-- As a special exception,  if other files  instantiate  generics from this --
23-- unit, or you link  this unit with other files  to produce an executable, --
24-- this  unit  does not  by itself cause  the resulting  executable  to  be --
25-- covered  by the  GNU  General  Public  License.  This exception does not --
26-- however invalidate  any other reasons why  the executable file  might be --
27-- covered by the  GNU Public License.                                      --
28--                                                                          --
29-- GNAT was originally developed  by the GNAT team at  New York University. --
30-- Extensive contributions were provided by Ada Core Technologies Inc.      --
31--                                                                          --
32------------------------------------------------------------------------------
33
34with Interfaces;     use Interfaces;
35with System.WCh_Con; use System.WCh_Con;
36with System.WCh_JIS; use System.WCh_JIS;
37
38package body System.WCh_StW is
39
40   ---------------------------
41   -- String_To_Wide_String --
42   ---------------------------
43
44   function String_To_Wide_String
45     (S    : String;
46      EM   : WC_Encoding_Method)
47      return Wide_String
48   is
49      R  : Wide_String (1 .. S'Length);
50      RP : Natural;
51      SP : Natural;
52      U1 : Unsigned_16;
53      U2 : Unsigned_16;
54      U3 : Unsigned_16;
55      U  : Unsigned_16;
56
57      Last : constant Natural := S'Last;
58
59      function Get_Hex (C : Character) return Unsigned_16;
60      --  Converts character from hex digit to value in range 0-15. The
61      --  input must be in 0-9, A-F, or a-f, and no check is needed.
62
63      procedure Get_Hex_4;
64      --  Translates four hex characters starting at S (SP) to a single
65      --  wide character. Used in WCEM_Hex and WCEM_Brackets mode. SP
66      --  is not modified by the call. The resulting wide character value
67      --  is stored in R (RP). RP is not modified by the call.
68
69      function Get_Hex (C : Character) return Unsigned_16 is
70      begin
71         if C in '0' .. '9' then
72            return Character'Pos (C) - Character'Pos ('0');
73         elsif C in 'A' .. 'F' then
74            return Character'Pos (C) - Character'Pos ('A') + 10;
75         else
76            return Character'Pos (C) - Character'Pos ('a') + 10;
77         end if;
78      end Get_Hex;
79
80      procedure Get_Hex_4 is
81      begin
82         R (RP) := Wide_Character'Val (
83            Get_Hex (S (SP + 3)) + 16 *
84              (Get_Hex (S (SP + 2)) + 16 *
85                (Get_Hex (S (SP + 1)) + 16 *
86                  (Get_Hex (S (SP + 0))))));
87      end Get_Hex_4;
88
89   --  Start of processing for String_To_Wide_String
90
91   begin
92      SP := S'First;
93      RP := 0;
94
95      case EM is
96
97         --  ESC-Hex representation
98
99         when WCEM_Hex =>
100            while SP <= Last - 4 loop
101               RP := RP + 1;
102
103               if S (SP) = ASCII.ESC then
104                  SP := SP + 1;
105                  Get_Hex_4;
106                  SP := SP + 4;
107               else
108                  R (RP) := Wide_Character'Val (Character'Pos (S (SP)));
109                  SP := SP + 1;
110               end if;
111            end loop;
112
113         --  Upper bit shift, internal code = external code
114
115         when WCEM_Upper =>
116            while SP < Last loop
117               RP := RP + 1;
118
119               if S (SP) >= Character'Val (16#80#) then
120                  U1 := Character'Pos (S (SP));
121                  U2 := Character'Pos (S (SP + 1));
122                  R (RP) := Wide_Character'Val (256 * U1 + U2);
123                  SP := SP + 2;
124               else
125                  R (RP) := Wide_Character'Val (Character'Pos (S (SP)));
126                  SP := SP + 1;
127               end if;
128            end loop;
129
130         --  Upper bit shift, shift-JIS
131
132         when WCEM_Shift_JIS =>
133            while SP < Last loop
134               RP := RP + 1;
135
136               if S (SP) >= Character'Val (16#80#) then
137                  R (RP) := Shift_JIS_To_JIS (S (SP), S (SP + 1));
138                  SP := SP + 2;
139               else
140                  R (RP) := Wide_Character'Val (Character'Pos (S (SP)));
141                  SP := SP + 1;
142               end if;
143            end loop;
144
145         --  Upper bit shift, EUC
146
147         when WCEM_EUC =>
148            while SP < Last loop
149               RP := RP + 1;
150
151               if S (SP) >= Character'Val (16#80#) then
152                  R (RP) := EUC_To_JIS (S (SP), S (SP + 1));
153                  SP := SP + 2;
154               else
155                  R (RP) := Wide_Character'Val (Character'Pos (S (SP)));
156                  SP := SP + 1;
157               end if;
158            end loop;
159
160         --  Upper bit shift, UTF-8
161
162         when WCEM_UTF8 =>
163            while SP < Last loop
164               RP := RP + 1;
165
166               if S (SP) >= Character'Val (16#80#) then
167                  U1 := Character'Pos (S (SP));
168                  U2 := Character'Pos (S (SP + 1));
169
170                  U := Shift_Left (U1 and 2#00011111#, 6) +
171                         (U2 and 2#00111111#);
172                  SP := SP + 2;
173
174                  if U1 >= 2#11100000# then
175                     U3 := Character'Pos (S (SP));
176                     U := Shift_Left (U, 6) + (U3 and 2#00111111#);
177                     SP := SP + 1;
178                  end if;
179
180                  R (RP) := Wide_Character'Val (U);
181
182               else
183                  R (RP) := Wide_Character'Val (Character'Pos (S (SP)));
184                  SP := SP + 1;
185               end if;
186            end loop;
187
188         --  Brackets representation
189
190         when WCEM_Brackets =>
191            while SP <= Last - 7 loop
192               RP := RP + 1;
193
194               if S (SP) = '['
195                 and then S (SP + 1) = '"'
196                 and then S (SP + 2) /= '"'
197               then
198                  SP := SP + 2;
199                  Get_Hex_4;
200                  SP := SP + 6;
201
202               else
203                  R (RP) := Wide_Character'Val (Character'Pos (S (SP)));
204                  SP := SP + 1;
205               end if;
206            end loop;
207
208      end case;
209
210      while SP <= Last loop
211         RP := RP + 1;
212         R (RP) := Wide_Character'Val (Character'Pos (S (SP)));
213         SP := SP + 1;
214      end loop;
215
216      return R (1 .. RP);
217   end String_To_Wide_String;
218
219end System.WCh_StW;
220