1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT RUN-TIME 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-2009, 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
32with System.WCh_Con; use System.WCh_Con;
33with System.WCh_Cnv; use System.WCh_Cnv;
34
35package body System.WCh_StW is
36
37   -----------------------
38   -- Local Subprograms --
39   -----------------------
40
41   procedure Get_Next_Code
42     (S  : String;
43      P  : in out Natural;
44      V  : out UTF_32_Code;
45      EM : WC_Encoding_Method);
46   --  Scans next character starting at S(P) and returns its value in V. On
47   --  exit P is updated past the last character read. Raises Constraint_Error
48   --  if the string is not well formed. Raises Constraint_Error if the code
49   --  value is greater than 16#7FFF_FFFF#. On entry P <= S'Last.
50
51   -------------------
52   -- Get_Next_Code --
53   -------------------
54
55   procedure Get_Next_Code
56     (S  : String;
57      P  : in out Natural;
58      V  : out UTF_32_Code;
59      EM : WC_Encoding_Method)
60   is
61      function In_Char return Character;
62      --  Function to return a character, bumping P, raises Constraint_Error
63      --  if P > S'Last on entry.
64
65      function Get_UTF_32 is new Char_Sequence_To_UTF_32 (In_Char);
66      --  Function to get next UFT_32 value
67
68      -------------
69      -- In_Char --
70      -------------
71
72      function In_Char return Character is
73      begin
74         if P > S'Last then
75            raise Constraint_Error with "badly formed wide character code";
76         else
77            P := P + 1;
78            return S (P - 1);
79         end if;
80      end In_Char;
81
82   --  Start of processing for Get_Next_Code
83
84   begin
85      --  Check for wide character encoding
86
87      case EM is
88         when WCEM_Hex =>
89            if S (P) = ASCII.ESC then
90               V := Get_UTF_32 (In_Char, EM);
91               return;
92            end if;
93
94         when WCEM_Upper | WCEM_Shift_JIS | WCEM_EUC | WCEM_UTF8 =>
95            if S (P) >= Character'Val (16#80#) then
96               V := Get_UTF_32 (In_Char, EM);
97               return;
98            end if;
99
100         when WCEM_Brackets =>
101            if P + 2 <= S'Last
102              and then S (P) = '['
103              and then S (P + 1) = '"'
104              and then S (P + 2) /= '"'
105            then
106               V := Get_UTF_32 (In_Char, EM);
107               return;
108            end if;
109      end case;
110
111      --  If it is not a wide character code, just get it
112
113      V := Character'Pos (S (P));
114      P := P + 1;
115   end Get_Next_Code;
116
117   ---------------------------
118   -- String_To_Wide_String --
119   ---------------------------
120
121   procedure String_To_Wide_String
122     (S  : String;
123      R  : out Wide_String;
124      L  : out Natural;
125      EM : System.WCh_Con.WC_Encoding_Method)
126   is
127      SP : Natural;
128      V  : UTF_32_Code;
129
130   begin
131      pragma Assert (S'First = 1);
132
133      SP := S'First;
134      L  := 0;
135      while SP <= S'Last loop
136         Get_Next_Code (S, SP, V, EM);
137
138         if V > 16#FFFF# then
139            raise Constraint_Error with
140              "out of range value for wide character";
141         end if;
142
143         L := L + 1;
144         R (L) := Wide_Character'Val (V);
145      end loop;
146   end String_To_Wide_String;
147
148   --------------------------------
149   -- String_To_Wide_Wide_String --
150   --------------------------------
151
152   procedure String_To_Wide_Wide_String
153     (S  : String;
154      R  : out Wide_Wide_String;
155      L  : out Natural;
156      EM : System.WCh_Con.WC_Encoding_Method)
157   is
158      pragma Assert (S'First = 1);
159
160      SP : Natural;
161      V  : UTF_32_Code;
162
163   begin
164      SP := S'First;
165      L := 0;
166      while SP <= S'Last loop
167         Get_Next_Code (S, SP, V, EM);
168         L := L + 1;
169         R (L) := Wide_Wide_Character'Val (V);
170      end loop;
171   end String_To_Wide_Wide_String;
172
173end System.WCh_StW;
174