|
111
|
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 -- --
|
|
131
|
9 -- Copyright (C) 1992-2018, Free Software Foundation, Inc. --
|
|
111
|
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
|
|
|
32 with System.WCh_Con; use System.WCh_Con;
|
|
|
33 with System.WCh_Cnv; use System.WCh_Cnv;
|
|
|
34
|
|
|
35 package 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
|
|
|
173 end System.WCh_StW;
|
