Mercurial > hg > CbC > CbC_gcc
comparison gcc/ada/libgnat/a-ztenau.adb @ 111:04ced10e8804
gcc 7
author | kono |
---|---|
date | Fri, 27 Oct 2017 22:46:09 +0900 |
parents | |
children | 84e7813d76e9 |
comparison
equal
deleted
inserted
replaced
68:561a7518be6b | 111:04ced10e8804 |
---|---|
1 ------------------------------------------------------------------------------ | |
2 -- -- | |
3 -- GNAT RUN-TIME COMPONENTS -- | |
4 -- -- | |
5 -- ADA.WIDE_WIDE_TEXT_IO.ENUMERATION_AUX -- | |
6 -- -- | |
7 -- B o d y -- | |
8 -- -- | |
9 -- Copyright (C) 1992-2017, 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 | |
32 with Ada.Wide_Wide_Text_IO.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux; | |
33 with Ada.Characters.Conversions; use Ada.Characters.Conversions; | |
34 with Ada.Characters.Handling; use Ada.Characters.Handling; | |
35 with Interfaces.C_Streams; use Interfaces.C_Streams; | |
36 with System.WCh_Con; use System.WCh_Con; | |
37 | |
38 package body Ada.Wide_Wide_Text_IO.Enumeration_Aux is | |
39 | |
40 subtype TFT is Ada.Wide_Wide_Text_IO.File_Type; | |
41 -- File type required for calls to routines in Aux | |
42 | |
43 ----------------------- | |
44 -- Local Subprograms -- | |
45 ----------------------- | |
46 | |
47 procedure Store_Char | |
48 (WC : Wide_Wide_Character; | |
49 Buf : out Wide_Wide_String; | |
50 Ptr : in out Integer); | |
51 -- Store a single character in buffer, checking for overflow | |
52 | |
53 -- These definitions replace the ones in Ada.Characters.Handling, which | |
54 -- do not seem to work for some strange not understood reason ??? at | |
55 -- least in the OS/2 version. | |
56 | |
57 function To_Lower (C : Character) return Character; | |
58 | |
59 ------------------ | |
60 -- Get_Enum_Lit -- | |
61 ------------------ | |
62 | |
63 procedure Get_Enum_Lit | |
64 (File : File_Type; | |
65 Buf : out Wide_Wide_String; | |
66 Buflen : out Natural) | |
67 is | |
68 ch : int; | |
69 WC : Wide_Wide_Character; | |
70 | |
71 begin | |
72 Buflen := 0; | |
73 Load_Skip (TFT (File)); | |
74 ch := Nextc (TFT (File)); | |
75 | |
76 -- Character literal case. If the initial character is a quote, then | |
77 -- we read as far as we can without backup (see ACVC test CE3905L) | |
78 | |
79 if ch = Character'Pos (''') then | |
80 Get (File, WC); | |
81 Store_Char (WC, Buf, Buflen); | |
82 | |
83 ch := Nextc (TFT (File)); | |
84 | |
85 if ch = LM or else ch = EOF then | |
86 return; | |
87 end if; | |
88 | |
89 Get (File, WC); | |
90 Store_Char (WC, Buf, Buflen); | |
91 | |
92 ch := Nextc (TFT (File)); | |
93 | |
94 if ch /= Character'Pos (''') then | |
95 return; | |
96 end if; | |
97 | |
98 Get (File, WC); | |
99 Store_Char (WC, Buf, Buflen); | |
100 | |
101 -- Similarly for identifiers, read as far as we can, in particular, | |
102 -- do read a trailing underscore (again see ACVC test CE3905L to | |
103 -- understand why we do this, although it seems somewhat peculiar). | |
104 | |
105 else | |
106 -- Identifier must start with a letter. Any wide character value | |
107 -- outside the normal Latin-1 range counts as a letter for this. | |
108 | |
109 if ch < 255 and then not Is_Letter (Character'Val (ch)) then | |
110 return; | |
111 end if; | |
112 | |
113 -- If we do have a letter, loop through the characters quitting on | |
114 -- the first non-identifier character (note that this includes the | |
115 -- cases of hitting a line mark or page mark). | |
116 | |
117 loop | |
118 Get (File, WC); | |
119 Store_Char (WC, Buf, Buflen); | |
120 | |
121 ch := Nextc (TFT (File)); | |
122 | |
123 exit when ch = EOF; | |
124 | |
125 if ch = Character'Pos ('_') then | |
126 exit when Buf (Buflen) = '_'; | |
127 | |
128 elsif ch = Character'Pos (ASCII.ESC) then | |
129 null; | |
130 | |
131 elsif File.WC_Method in WC_Upper_Half_Encoding_Method | |
132 and then ch > 127 | |
133 then | |
134 null; | |
135 | |
136 else | |
137 exit when not Is_Letter (Character'Val (ch)) | |
138 and then | |
139 not Is_Digit (Character'Val (ch)); | |
140 end if; | |
141 end loop; | |
142 end if; | |
143 end Get_Enum_Lit; | |
144 | |
145 --------- | |
146 -- Put -- | |
147 --------- | |
148 | |
149 procedure Put | |
150 (File : File_Type; | |
151 Item : Wide_Wide_String; | |
152 Width : Field; | |
153 Set : Type_Set) | |
154 is | |
155 Actual_Width : constant Integer := | |
156 Integer'Max (Integer (Width), Item'Length); | |
157 | |
158 begin | |
159 Check_On_One_Line (TFT (File), Actual_Width); | |
160 | |
161 if Set = Lower_Case and then Item (Item'First) /= ''' then | |
162 declare | |
163 Iteml : Wide_Wide_String (Item'First .. Item'Last); | |
164 | |
165 begin | |
166 for J in Item'Range loop | |
167 if Is_Character (Item (J)) then | |
168 Iteml (J) := | |
169 To_Wide_Wide_Character | |
170 (To_Lower (To_Character (Item (J)))); | |
171 else | |
172 Iteml (J) := Item (J); | |
173 end if; | |
174 end loop; | |
175 | |
176 Put (File, Iteml); | |
177 end; | |
178 | |
179 else | |
180 Put (File, Item); | |
181 end if; | |
182 | |
183 for J in 1 .. Actual_Width - Item'Length loop | |
184 Put (File, ' '); | |
185 end loop; | |
186 end Put; | |
187 | |
188 ---------- | |
189 -- Puts -- | |
190 ---------- | |
191 | |
192 procedure Puts | |
193 (To : out Wide_Wide_String; | |
194 Item : Wide_Wide_String; | |
195 Set : Type_Set) | |
196 is | |
197 Ptr : Natural; | |
198 | |
199 begin | |
200 if Item'Length > To'Length then | |
201 raise Layout_Error; | |
202 | |
203 else | |
204 Ptr := To'First; | |
205 for J in Item'Range loop | |
206 if Set = Lower_Case | |
207 and then Item (Item'First) /= ''' | |
208 and then Is_Character (Item (J)) | |
209 then | |
210 To (Ptr) := | |
211 To_Wide_Wide_Character (To_Lower (To_Character (Item (J)))); | |
212 else | |
213 To (Ptr) := Item (J); | |
214 end if; | |
215 | |
216 Ptr := Ptr + 1; | |
217 end loop; | |
218 | |
219 while Ptr <= To'Last loop | |
220 To (Ptr) := ' '; | |
221 Ptr := Ptr + 1; | |
222 end loop; | |
223 end if; | |
224 end Puts; | |
225 | |
226 ------------------- | |
227 -- Scan_Enum_Lit -- | |
228 ------------------- | |
229 | |
230 procedure Scan_Enum_Lit | |
231 (From : Wide_Wide_String; | |
232 Start : out Natural; | |
233 Stop : out Natural) | |
234 is | |
235 WC : Wide_Wide_Character; | |
236 | |
237 -- Processing for Scan_Enum_Lit | |
238 | |
239 begin | |
240 Start := From'First; | |
241 | |
242 loop | |
243 if Start > From'Last then | |
244 raise End_Error; | |
245 | |
246 elsif Is_Character (From (Start)) | |
247 and then not Is_Blank (To_Character (From (Start))) | |
248 then | |
249 exit; | |
250 | |
251 else | |
252 Start := Start + 1; | |
253 end if; | |
254 end loop; | |
255 | |
256 -- Character literal case. If the initial character is a quote, then | |
257 -- we read as far as we can without backup (see ACVC test CE3905L | |
258 -- which is for the analogous case for reading from a file). | |
259 | |
260 if From (Start) = ''' then | |
261 Stop := Start; | |
262 | |
263 if Stop = From'Last then | |
264 raise Data_Error; | |
265 else | |
266 Stop := Stop + 1; | |
267 end if; | |
268 | |
269 if From (Stop) in ' ' .. '~' | |
270 or else From (Stop) >= Wide_Wide_Character'Val (16#80#) | |
271 then | |
272 if Stop = From'Last then | |
273 raise Data_Error; | |
274 else | |
275 Stop := Stop + 1; | |
276 | |
277 if From (Stop) = ''' then | |
278 return; | |
279 end if; | |
280 end if; | |
281 end if; | |
282 | |
283 raise Data_Error; | |
284 | |
285 -- Similarly for identifiers, read as far as we can, in particular, | |
286 -- do read a trailing underscore (again see ACVC test CE3905L to | |
287 -- understand why we do this, although it seems somewhat peculiar). | |
288 | |
289 else | |
290 -- Identifier must start with a letter, any wide character outside | |
291 -- the normal Latin-1 range is considered a letter for this test. | |
292 | |
293 if Is_Character (From (Start)) | |
294 and then not Is_Letter (To_Character (From (Start))) | |
295 then | |
296 raise Data_Error; | |
297 end if; | |
298 | |
299 -- If we do have a letter, loop through the characters quitting on | |
300 -- the first non-identifier character (note that this includes the | |
301 -- cases of hitting a line mark or page mark). | |
302 | |
303 Stop := Start + 1; | |
304 while Stop < From'Last loop | |
305 WC := From (Stop + 1); | |
306 | |
307 exit when | |
308 Is_Character (WC) | |
309 and then | |
310 not Is_Letter (To_Character (WC)) | |
311 and then | |
312 not Is_Letter (To_Character (WC)) | |
313 and then | |
314 (WC /= '_' or else From (Stop - 1) = '_'); | |
315 | |
316 Stop := Stop + 1; | |
317 end loop; | |
318 end if; | |
319 | |
320 end Scan_Enum_Lit; | |
321 | |
322 ---------------- | |
323 -- Store_Char -- | |
324 ---------------- | |
325 | |
326 procedure Store_Char | |
327 (WC : Wide_Wide_Character; | |
328 Buf : out Wide_Wide_String; | |
329 Ptr : in out Integer) | |
330 is | |
331 begin | |
332 if Ptr = Buf'Last then | |
333 raise Data_Error; | |
334 else | |
335 Ptr := Ptr + 1; | |
336 Buf (Ptr) := WC; | |
337 end if; | |
338 end Store_Char; | |
339 | |
340 -------------- | |
341 -- To_Lower -- | |
342 -------------- | |
343 | |
344 function To_Lower (C : Character) return Character is | |
345 begin | |
346 if C in 'A' .. 'Z' then | |
347 return Character'Val (Character'Pos (C) + 32); | |
348 else | |
349 return C; | |
350 end if; | |
351 end To_Lower; | |
352 | |
353 end Ada.Wide_Wide_Text_IO.Enumeration_Aux; |