File : a-ztenau.adb
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-2012, 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 -- --
19 -- --
20 -- --
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;