hppa: Revise REG+D address support to allow long displacements before reload
[official-gcc.git] / gcc / ada / widechar.adb
blobc932d044acb1902abed2610d2a16d9f13645273a
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- W I D E C H A R --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2023, 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. 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 COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
26 -- Note: this package uses the generic subprograms in System.WCh_Cnv, which
27 -- completely encapsulate the set of wide character encoding methods, so no
28 -- modifications are required when adding new encoding methods.
30 with Opt; use Opt;
32 with System.WCh_Cnv; use System.WCh_Cnv;
33 with System.WCh_Con; use System.WCh_Con;
35 package body Widechar is
37 ---------------------------
38 -- Is_Start_Of_Wide_Char --
39 ---------------------------
41 function Is_Start_Of_Wide_Char
42 (S : Source_Buffer_Ptr;
43 P : Source_Ptr) return Boolean
45 begin
46 case Wide_Character_Encoding_Method is
48 -- For Hex mode, just test for an ESC character. The ESC character
49 -- cannot appear in any other context in a legal Ada program.
51 when WCEM_Hex =>
52 return S (P) = ASCII.ESC;
54 -- For brackets, just test ["x where x is a hex character. This is
55 -- sufficient test, since this sequence cannot otherwise appear in a
56 -- legal Ada program.
58 when WCEM_Brackets =>
59 return P <= S'Last - 2
60 and then S (P) = '['
61 and then S (P + 1) = '"'
62 and then (S (P + 2) in '0' .. '9'
63 or else
64 S (P + 2) in 'a' .. 'f'
65 or else
66 S (P + 2) in 'A' .. 'F');
68 -- All other encoding methods use the upper bit set in the first
69 -- character to uniquely represent a wide character.
71 when WCEM_EUC
72 | WCEM_Shift_JIS
73 | WCEM_Upper
74 | WCEM_UTF8
76 return S (P) >= Character'Val (16#80#);
77 end case;
78 end Is_Start_Of_Wide_Char;
80 -----------------
81 -- Length_Wide --
82 -----------------
84 function Length_Wide return Nat is
85 begin
86 return WC_Longest_Sequence;
87 end Length_Wide;
89 ---------------
90 -- Scan_Wide --
91 ---------------
93 procedure Scan_Wide
94 (S : Source_Buffer_Ptr;
95 P : in out Source_Ptr;
96 C : out Char_Code;
97 Err : out Boolean)
99 P_Init : constant Source_Ptr := P;
100 Chr : Character;
102 function In_Char return Character;
103 -- Function to obtain characters of wide character escape sequence
105 -------------
106 -- In_Char --
107 -------------
109 function In_Char return Character is
110 begin
111 P := P + 1;
112 return S (P - 1);
113 end In_Char;
115 function WC_In is new Char_Sequence_To_UTF_32 (In_Char);
117 -- Start of processing for Scan_Wide
119 begin
120 Chr := In_Char;
122 -- Scan out the wide character. If the first character is a bracket,
123 -- we allow brackets encoding regardless of the standard encoding
124 -- method being used, but otherwise we use this standard method.
126 if Chr = '[' then
127 C := Char_Code (WC_In (Chr, WCEM_Brackets));
128 else
129 C := Char_Code (WC_In (Chr, Wide_Character_Encoding_Method));
130 end if;
132 Err := False;
133 Wide_Char_Byte_Count := Wide_Char_Byte_Count + Nat (P - P_Init - 1);
135 exception
136 when Constraint_Error =>
137 C := Char_Code (0);
138 P := P - 1;
139 Err := True;
140 end Scan_Wide;
142 --------------
143 -- Set_Wide --
144 --------------
146 procedure Set_Wide
147 (C : Char_Code;
148 S : in out String;
149 P : in out Natural)
151 procedure Out_Char (C : Character);
152 -- Procedure to store one character of wide character sequence
154 --------------
155 -- Out_Char --
156 --------------
158 procedure Out_Char (C : Character) is
159 begin
160 P := P + 1;
161 S (P) := C;
162 end Out_Char;
164 procedure WC_Out is new UTF_32_To_Char_Sequence (Out_Char);
166 -- Start of processing for Set_Wide
168 begin
169 WC_Out (UTF_32_Code (C), Wide_Character_Encoding_Method);
170 end Set_Wide;
172 ---------------
173 -- Skip_Wide --
174 ---------------
176 procedure Skip_Wide (S : String; P : in out Natural) is
177 P_Init : constant Natural := P;
179 function Skip_Char return Character;
180 -- Function to skip one character of wide character escape sequence
182 ---------------
183 -- Skip_Char --
184 ---------------
186 function Skip_Char return Character is
187 begin
188 P := P + 1;
189 return S (P - 1);
190 end Skip_Char;
192 function WC_Skip is new Char_Sequence_To_UTF_32 (Skip_Char);
194 Discard : UTF_32_Code;
195 pragma Warnings (Off, Discard);
197 -- Start of processing for Skip_Wide
199 begin
200 -- Capture invalid wide characters errors since we are going to discard
201 -- the result anyway. We just want to move past it.
203 begin
204 Discard := WC_Skip (Skip_Char, Wide_Character_Encoding_Method);
205 exception
206 when Constraint_Error =>
207 null;
208 end;
210 Wide_Char_Byte_Count := Wide_Char_Byte_Count + Nat (P - P_Init - 1);
211 end Skip_Wide;
213 ---------------
214 -- Skip_Wide --
215 ---------------
217 procedure Skip_Wide (S : Source_Buffer_Ptr; P : in out Source_Ptr) is
218 P_Init : constant Source_Ptr := P;
220 function Skip_Char return Character;
221 -- Function to skip one character of wide character escape sequence
223 ---------------
224 -- Skip_Char --
225 ---------------
227 function Skip_Char return Character is
228 begin
229 P := P + 1;
230 return S (P - 1);
231 end Skip_Char;
233 function WC_Skip is new Char_Sequence_To_UTF_32 (Skip_Char);
235 Discard : UTF_32_Code;
236 pragma Warnings (Off, Discard);
238 -- Start of processing for Skip_Wide
240 begin
241 -- Capture invalid wide characters errors since we are going to discard
242 -- the result anyway. We just want to move past it.
244 begin
245 Discard := WC_Skip (Skip_Char, Wide_Character_Encoding_Method);
246 exception
247 when Constraint_Error =>
248 null;
249 end;
251 Wide_Char_Byte_Count := Wide_Char_Byte_Count + Nat (P - P_Init - 1);
252 end Skip_Wide;
254 end Widechar;