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