|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- S C N G --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
145
|
9 -- Copyright (C) 1992-2019, 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. 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 ------------------------------------------------------------------------------
|
|
|
25
|
|
|
26 with Atree; use Atree;
|
|
|
27 with Csets; use Csets;
|
|
|
28 with Hostparm; use Hostparm;
|
|
|
29 with Namet; use Namet;
|
|
|
30 with Opt; use Opt;
|
|
|
31 with Restrict; use Restrict;
|
|
|
32 with Rident; use Rident;
|
|
|
33 with Scans; use Scans;
|
|
|
34 with Sinput; use Sinput;
|
|
|
35 with Snames; use Snames;
|
|
|
36 with Stringt; use Stringt;
|
|
|
37 with Stylesw; use Stylesw;
|
|
|
38 with Uintp; use Uintp;
|
|
|
39 with Urealp; use Urealp;
|
|
|
40 with Widechar; use Widechar;
|
|
|
41
|
|
|
42 pragma Warnings (Off);
|
|
|
43 -- This package is used also by gnatcoll
|
|
|
44 with System.CRC32;
|
|
|
45 with System.UTF_32; use System.UTF_32;
|
|
|
46 with System.WCh_Con; use System.WCh_Con;
|
|
|
47 pragma Warnings (On);
|
|
|
48
|
|
|
49 package body Scng is
|
|
|
50
|
|
|
51 use ASCII;
|
|
|
52 -- Make control characters visible
|
|
|
53
|
|
|
54 Special_Characters : array (Character) of Boolean := (others => False);
|
|
|
55 -- For characters that are Special token, the value is True
|
|
|
56
|
|
|
57 Comment_Is_Token : Boolean := False;
|
|
|
58 -- True if comments are tokens
|
|
|
59
|
|
|
60 End_Of_Line_Is_Token : Boolean := False;
|
|
|
61 -- True if End_Of_Line is a token
|
|
|
62
|
|
|
63 -----------------------
|
|
|
64 -- Local Subprograms --
|
|
|
65 -----------------------
|
|
|
66
|
|
|
67 procedure Accumulate_Token_Checksum;
|
|
|
68 pragma Inline (Accumulate_Token_Checksum);
|
|
|
69 -- Called after each numeric literal and identifier/keyword. For keywords,
|
|
|
70 -- the token used is Tok_Identifier. This allows detection of additional
|
|
|
71 -- spaces added in sources when using the builder switch -m.
|
|
|
72
|
|
|
73 procedure Accumulate_Token_Checksum_GNAT_6_3;
|
|
|
74 -- Used in place of Accumulate_Token_Checksum for GNAT versions 5.04 to
|
|
|
75 -- 6.3, when Tok_Some was not included in Token_Type and the actual
|
|
|
76 -- Token_Type was used for keywords. This procedure is never used in the
|
|
|
77 -- compiler or gnatmake, only in gprbuild.
|
|
|
78
|
|
|
79 procedure Accumulate_Token_Checksum_GNAT_5_03;
|
|
|
80 -- Used in place of Accumulate_Token_Checksum for GNAT version 5.03, when
|
|
|
81 -- Tok_Interface, Tok_Some, Tok_Synchronized and Tok_Overriding were not
|
|
|
82 -- included in Token_Type and the actual Token_Type was used for keywords.
|
|
|
83 -- This procedure is never used in the compiler or gnatmake, only in
|
|
|
84 -- gprbuild.
|
|
|
85
|
|
|
86 procedure Accumulate_Checksum (C : Character);
|
|
|
87 pragma Inline (Accumulate_Checksum);
|
|
|
88 -- This routine accumulates the checksum given character C. During the
|
|
|
89 -- scanning of a source file, this routine is called with every character
|
|
|
90 -- in the source, excluding blanks, and all control characters (except
|
|
|
91 -- that ESC is included in the checksum). Upper case letters not in string
|
|
|
92 -- literals are folded by the caller. See Sinput spec for the documentation
|
|
|
93 -- of the checksum algorithm. Note: checksum values are only used if we
|
|
|
94 -- generate code, so it is not necessary to worry about making the right
|
|
|
95 -- sequence of calls in any error situation.
|
|
|
96
|
|
|
97 procedure Accumulate_Checksum (C : Char_Code);
|
|
|
98 pragma Inline (Accumulate_Checksum);
|
|
|
99 -- This version is identical, except that the argument, C, is a character
|
|
|
100 -- code value instead of a character. This is used when wide characters
|
|
|
101 -- are scanned. We use the character code rather than the ASCII characters
|
|
|
102 -- so that the checksum is independent of wide character encoding method.
|
|
|
103
|
|
|
104 procedure Initialize_Checksum;
|
|
|
105 pragma Inline (Initialize_Checksum);
|
|
|
106 -- Initialize checksum value
|
|
|
107
|
|
|
108 -------------------------
|
|
|
109 -- Accumulate_Checksum --
|
|
|
110 -------------------------
|
|
|
111
|
|
|
112 procedure Accumulate_Checksum (C : Character) is
|
|
|
113 begin
|
|
|
114 System.CRC32.Update (System.CRC32.CRC32 (Checksum), C);
|
|
|
115 end Accumulate_Checksum;
|
|
|
116
|
|
|
117 procedure Accumulate_Checksum (C : Char_Code) is
|
|
|
118 begin
|
|
|
119 if C > 16#FFFF# then
|
|
|
120 Accumulate_Checksum (Character'Val (C / 2 ** 24));
|
|
|
121 Accumulate_Checksum (Character'Val ((C / 2 ** 16) mod 256));
|
|
|
122 Accumulate_Checksum (Character'Val ((C / 256) mod 256));
|
|
|
123 else
|
|
|
124 Accumulate_Checksum (Character'Val (C / 256));
|
|
|
125 end if;
|
|
|
126
|
|
|
127 Accumulate_Checksum (Character'Val (C mod 256));
|
|
|
128 end Accumulate_Checksum;
|
|
|
129
|
|
|
130 -------------------------------
|
|
|
131 -- Accumulate_Token_Checksum --
|
|
|
132 -------------------------------
|
|
|
133
|
|
|
134 procedure Accumulate_Token_Checksum is
|
|
|
135 begin
|
|
|
136 System.CRC32.Update
|
|
|
137 (System.CRC32.CRC32 (Checksum),
|
|
|
138 Character'Val (Token_Type'Pos (Token)));
|
|
|
139 end Accumulate_Token_Checksum;
|
|
|
140
|
|
|
141 ----------------------------------------
|
|
|
142 -- Accumulate_Token_Checksum_GNAT_6_3 --
|
|
|
143 ----------------------------------------
|
|
|
144
|
|
|
145 procedure Accumulate_Token_Checksum_GNAT_6_3 is
|
|
|
146 begin
|
|
|
147 -- Individual values of Token_Type are used, instead of subranges, so
|
|
|
148 -- that additions or suppressions of enumerated values in type
|
|
|
149 -- Token_Type are detected by the compiler.
|
|
|
150
|
|
|
151 case Token is
|
|
|
152 when Tok_Abs
|
|
|
153 | Tok_Abstract
|
|
|
154 | Tok_Access
|
|
|
155 | Tok_Aliased
|
|
|
156 | Tok_All
|
|
|
157 | Tok_Ampersand
|
|
|
158 | Tok_And
|
|
|
159 | Tok_Apostrophe
|
|
|
160 | Tok_Array
|
|
|
161 | Tok_Asterisk
|
|
|
162 | Tok_At
|
|
|
163 | Tok_At_Sign
|
|
|
164 | Tok_Body
|
|
|
165 | Tok_Box
|
|
|
166 | Tok_Char_Literal
|
|
|
167 | Tok_Colon
|
|
|
168 | Tok_Colon_Equal
|
|
|
169 | Tok_Comma
|
|
|
170 | Tok_Constant
|
|
|
171 | Tok_Delta
|
|
|
172 | Tok_Digits
|
|
|
173 | Tok_Do
|
|
|
174 | Tok_Dot
|
|
|
175 | Tok_Double_Asterisk
|
|
|
176 | Tok_Equal
|
|
|
177 | Tok_Greater
|
|
|
178 | Tok_Greater_Equal
|
|
|
179 | Tok_Greater_Greater
|
|
|
180 | Tok_Identifier
|
|
|
181 | Tok_In
|
|
|
182 | Tok_Integer_Literal
|
|
|
183 | Tok_Interface
|
|
|
184 | Tok_Is
|
|
145
|
185 | Tok_Left_Bracket
|
|
111
|
186 | Tok_Left_Paren
|
|
|
187 | Tok_Less
|
|
|
188 | Tok_Less_Equal
|
|
|
189 | Tok_Limited
|
|
|
190 | Tok_Minus
|
|
|
191 | Tok_Mod
|
|
|
192 | Tok_New
|
|
|
193 | Tok_Not
|
|
|
194 | Tok_Not_Equal
|
|
|
195 | Tok_Null
|
|
|
196 | Tok_Of
|
|
|
197 | Tok_Operator_Symbol
|
|
|
198 | Tok_Or
|
|
|
199 | Tok_Others
|
|
|
200 | Tok_Out
|
|
|
201 | Tok_Plus
|
|
|
202 | Tok_Range
|
|
|
203 | Tok_Real_Literal
|
|
|
204 | Tok_Record
|
|
|
205 | Tok_Rem
|
|
|
206 | Tok_Renames
|
|
|
207 | Tok_Reverse
|
|
145
|
208 | Tok_Right_Bracket
|
|
111
|
209 | Tok_Right_Paren
|
|
|
210 | Tok_Slash
|
|
|
211 | Tok_String_Literal
|
|
|
212 | Tok_Xor
|
|
|
213 =>
|
|
|
214 System.CRC32.Update
|
|
|
215 (System.CRC32.CRC32 (Checksum),
|
|
|
216 Character'Val (Token_Type'Pos (Token)));
|
|
|
217
|
|
|
218 when Tok_Some =>
|
|
|
219 System.CRC32.Update
|
|
|
220 (System.CRC32.CRC32 (Checksum),
|
|
|
221 Character'Val (Token_Type'Pos (Tok_Identifier)));
|
|
|
222
|
|
|
223 when No_Token
|
|
|
224 | Tok_Abort
|
|
|
225 | Tok_Accept
|
|
|
226 | Tok_Arrow
|
|
|
227 | Tok_Begin
|
|
|
228 | Tok_Case
|
|
|
229 | Tok_Comment
|
|
|
230 | Tok_Declare
|
|
|
231 | Tok_Delay
|
|
|
232 | Tok_Dot_Dot
|
|
|
233 | Tok_Else
|
|
|
234 | Tok_Elsif
|
|
|
235 | Tok_End
|
|
|
236 | Tok_End_Of_Line
|
|
|
237 | Tok_Entry
|
|
|
238 | Tok_EOF
|
|
|
239 | Tok_Exception
|
|
|
240 | Tok_Exit
|
|
|
241 | Tok_Extends
|
|
|
242 | Tok_External
|
|
|
243 | Tok_External_As_List
|
|
|
244 | Tok_For
|
|
|
245 | Tok_Function
|
|
|
246 | Tok_Generic
|
|
|
247 | Tok_Goto
|
|
|
248 | Tok_If
|
|
|
249 | Tok_Less_Less
|
|
|
250 | Tok_Loop
|
|
|
251 | Tok_Overriding
|
|
|
252 | Tok_Package
|
|
|
253 | Tok_Pragma
|
|
|
254 | Tok_Private
|
|
|
255 | Tok_Procedure
|
|
|
256 | Tok_Project
|
|
|
257 | Tok_Protected
|
|
|
258 | Tok_Raise
|
|
|
259 | Tok_Requeue
|
|
|
260 | Tok_Return
|
|
|
261 | Tok_Select
|
|
|
262 | Tok_Semicolon
|
|
|
263 | Tok_Separate
|
|
|
264 | Tok_SPARK_Hide
|
|
|
265 | Tok_Special
|
|
|
266 | Tok_Subtype
|
|
|
267 | Tok_Synchronized
|
|
|
268 | Tok_Tagged
|
|
|
269 | Tok_Task
|
|
|
270 | Tok_Terminate
|
|
|
271 | Tok_Then
|
|
|
272 | Tok_Type
|
|
|
273 | Tok_Until
|
|
|
274 | Tok_Use
|
|
|
275 | Tok_Vertical_Bar
|
|
|
276 | Tok_When
|
|
|
277 | Tok_While
|
|
|
278 | Tok_With
|
|
|
279 =>
|
|
|
280 System.CRC32.Update
|
|
|
281 (System.CRC32.CRC32 (Checksum),
|
|
|
282 Character'Val (Token_Type'Pos (Token_Type'Pred (Token))));
|
|
|
283 end case;
|
|
|
284 end Accumulate_Token_Checksum_GNAT_6_3;
|
|
|
285
|
|
|
286 -----------------------------------------
|
|
|
287 -- Accumulate_Token_Checksum_GNAT_5_03 --
|
|
|
288 -----------------------------------------
|
|
|
289
|
|
|
290 procedure Accumulate_Token_Checksum_GNAT_5_03 is
|
|
|
291 begin
|
|
|
292 -- Individual values of Token_Type are used, instead of subranges, so
|
|
|
293 -- that additions or suppressions of enumerated values in type
|
|
|
294 -- Token_Type are detected by the compiler.
|
|
|
295
|
|
|
296 case Token is
|
|
|
297 when Tok_Abs
|
|
|
298 | Tok_Abstract
|
|
|
299 | Tok_Access
|
|
|
300 | Tok_Aliased
|
|
|
301 | Tok_All
|
|
|
302 | Tok_Ampersand
|
|
|
303 | Tok_And
|
|
|
304 | Tok_Apostrophe
|
|
|
305 | Tok_Array
|
|
|
306 | Tok_Asterisk
|
|
|
307 | Tok_At
|
|
|
308 | Tok_At_Sign
|
|
|
309 | Tok_Body
|
|
|
310 | Tok_Box
|
|
|
311 | Tok_Char_Literal
|
|
|
312 | Tok_Colon
|
|
|
313 | Tok_Colon_Equal
|
|
|
314 | Tok_Comma
|
|
|
315 | Tok_Constant
|
|
|
316 | Tok_Delta
|
|
|
317 | Tok_Digits
|
|
|
318 | Tok_Do
|
|
|
319 | Tok_Dot
|
|
|
320 | Tok_Double_Asterisk
|
|
|
321 | Tok_Equal
|
|
|
322 | Tok_Greater
|
|
|
323 | Tok_Greater_Equal
|
|
|
324 | Tok_Greater_Greater
|
|
|
325 | Tok_Identifier
|
|
|
326 | Tok_In
|
|
|
327 | Tok_Integer_Literal
|
|
|
328 | Tok_Is
|
|
145
|
329 | Tok_Left_Bracket
|
|
111
|
330 | Tok_Left_Paren
|
|
|
331 | Tok_Less
|
|
|
332 | Tok_Less_Equal
|
|
|
333 | Tok_Minus
|
|
|
334 | Tok_Mod
|
|
|
335 | Tok_New
|
|
|
336 | Tok_Not
|
|
|
337 | Tok_Not_Equal
|
|
|
338 | Tok_Null
|
|
|
339 | Tok_Operator_Symbol
|
|
|
340 | Tok_Or
|
|
|
341 | Tok_Others
|
|
|
342 | Tok_Plus
|
|
|
343 | Tok_Range
|
|
|
344 | Tok_Real_Literal
|
|
|
345 | Tok_Rem
|
|
145
|
346 | Tok_Right_Bracket
|
|
111
|
347 | Tok_Right_Paren
|
|
|
348 | Tok_Slash
|
|
|
349 | Tok_String_Literal
|
|
|
350 | Tok_Xor
|
|
|
351 =>
|
|
|
352 System.CRC32.Update
|
|
|
353 (System.CRC32.CRC32 (Checksum),
|
|
|
354 Character'Val (Token_Type'Pos (Token)));
|
|
|
355
|
|
|
356 when Tok_Interface
|
|
|
357 | Tok_Overriding
|
|
|
358 | Tok_Some
|
|
|
359 | Tok_Synchronized
|
|
|
360 =>
|
|
|
361 System.CRC32.Update
|
|
|
362 (System.CRC32.CRC32 (Checksum),
|
|
|
363 Character'Val (Token_Type'Pos (Tok_Identifier)));
|
|
|
364
|
|
|
365 when Tok_Limited
|
|
|
366 | Tok_Of
|
|
|
367 | Tok_Out
|
|
|
368 | Tok_Record
|
|
|
369 | Tok_Renames
|
|
|
370 | Tok_Reverse
|
|
|
371 =>
|
|
|
372 System.CRC32.Update
|
|
|
373 (System.CRC32.CRC32 (Checksum),
|
|
|
374 Character'Val (Token_Type'Pos (Token) - 1));
|
|
|
375
|
|
|
376 when Tok_Abort
|
|
|
377 | Tok_Accept
|
|
|
378 | Tok_Begin
|
|
|
379 | Tok_Case
|
|
|
380 | Tok_Declare
|
|
|
381 | Tok_Delay
|
|
|
382 | Tok_Else
|
|
|
383 | Tok_Elsif
|
|
|
384 | Tok_End
|
|
|
385 | Tok_Entry
|
|
|
386 | Tok_Exception
|
|
|
387 | Tok_Exit
|
|
|
388 | Tok_For
|
|
|
389 | Tok_Goto
|
|
|
390 | Tok_If
|
|
|
391 | Tok_Less_Less
|
|
|
392 | Tok_Loop
|
|
|
393 | Tok_Pragma
|
|
|
394 | Tok_Protected
|
|
|
395 | Tok_Raise
|
|
|
396 | Tok_Requeue
|
|
|
397 | Tok_Return
|
|
|
398 | Tok_Select
|
|
|
399 | Tok_Subtype
|
|
|
400 | Tok_Tagged
|
|
|
401 | Tok_Task
|
|
|
402 | Tok_Terminate
|
|
|
403 | Tok_Then
|
|
|
404 | Tok_Type
|
|
|
405 | Tok_Until
|
|
|
406 | Tok_When
|
|
|
407 | Tok_While
|
|
|
408 =>
|
|
|
409 System.CRC32.Update
|
|
|
410 (System.CRC32.CRC32 (Checksum),
|
|
|
411 Character'Val (Token_Type'Pos (Token) - 2));
|
|
|
412
|
|
|
413 when No_Token
|
|
|
414 | Tok_Arrow
|
|
|
415 | Tok_Comment
|
|
|
416 | Tok_Dot_Dot
|
|
|
417 | Tok_End_Of_Line
|
|
|
418 | Tok_EOF
|
|
|
419 | Tok_Extends
|
|
|
420 | Tok_External
|
|
|
421 | Tok_External_As_List
|
|
|
422 | Tok_Function
|
|
|
423 | Tok_Generic
|
|
|
424 | Tok_Package
|
|
|
425 | Tok_Private
|
|
|
426 | Tok_Procedure
|
|
|
427 | Tok_Project
|
|
|
428 | Tok_Semicolon
|
|
|
429 | Tok_Separate
|
|
|
430 | Tok_SPARK_Hide
|
|
|
431 | Tok_Special
|
|
|
432 | Tok_Use
|
|
|
433 | Tok_Vertical_Bar
|
|
|
434 | Tok_With
|
|
|
435 =>
|
|
|
436 System.CRC32.Update
|
|
|
437 (System.CRC32.CRC32 (Checksum),
|
|
|
438 Character'Val (Token_Type'Pos (Token) - 4));
|
|
|
439 end case;
|
|
|
440 end Accumulate_Token_Checksum_GNAT_5_03;
|
|
|
441
|
|
|
442 -----------------------
|
|
|
443 -- Check_End_Of_Line --
|
|
|
444 -----------------------
|
|
|
445
|
|
|
446 procedure Check_End_Of_Line is
|
|
|
447 Len : constant Int :=
|
|
|
448 Int (Scan_Ptr) -
|
|
|
449 Int (Current_Line_Start) -
|
|
|
450 Wide_Char_Byte_Count;
|
|
|
451
|
|
|
452 -- Start of processing for Check_End_Of_Line
|
|
|
453
|
|
|
454 begin
|
|
|
455 if Style_Check then
|
|
|
456 Style.Check_Line_Terminator (Len);
|
|
|
457 end if;
|
|
|
458
|
|
|
459 -- Deal with checking maximum line length
|
|
|
460
|
|
|
461 if Style_Check and Style_Check_Max_Line_Length then
|
|
|
462 Style.Check_Line_Max_Length (Len);
|
|
|
463
|
|
|
464 -- If style checking is inactive, check maximum line length against
|
|
|
465 -- standard value.
|
|
|
466
|
|
|
467 elsif Len > Max_Line_Length then
|
|
|
468 Error_Msg
|
|
|
469 ("this line is too long",
|
|
|
470 Current_Line_Start + Source_Ptr (Max_Line_Length));
|
|
|
471 end if;
|
|
|
472
|
|
|
473 -- Now one more checking circuit. Normally we are only enforcing a limit
|
|
|
474 -- of physical characters, with tabs counting as one character. But if
|
|
|
475 -- after tab expansion we would have a total line length that exceeded
|
|
|
476 -- 32766, that would really cause trouble, because column positions
|
|
|
477 -- would exceed the maximum we allow for a column count. Note: the limit
|
|
|
478 -- is 32766 rather than 32767, since we use a value of 32767 for special
|
|
|
479 -- purposes (see Sinput). Now we really do not want to go messing with
|
|
|
480 -- tabs in the normal case, so what we do is to check for a line that
|
|
|
481 -- has more than 4096 physical characters. Any shorter line could not
|
|
|
482 -- be a problem, even if it was all tabs.
|
|
|
483
|
|
|
484 if Len >= 4096 then
|
|
|
485 declare
|
|
|
486 Col : Natural;
|
|
|
487 Ptr : Source_Ptr;
|
|
|
488
|
|
|
489 begin
|
|
|
490 Col := 1;
|
|
|
491 Ptr := Current_Line_Start;
|
|
|
492 loop
|
|
|
493 exit when Ptr = Scan_Ptr;
|
|
|
494
|
|
|
495 if Source (Ptr) = ASCII.HT then
|
|
|
496 Col := (Col - 1 + 8) / 8 * 8 + 1;
|
|
|
497 else
|
|
|
498 Col := Col + 1;
|
|
|
499 end if;
|
|
|
500
|
|
|
501 if Col > 32766 then
|
|
|
502 Error_Msg
|
|
|
503 ("this line is longer than 32766 characters",
|
|
|
504 Current_Line_Start);
|
|
|
505 raise Unrecoverable_Error;
|
|
|
506 end if;
|
|
|
507
|
|
|
508 Ptr := Ptr + 1;
|
|
|
509 end loop;
|
|
|
510 end;
|
|
|
511 end if;
|
|
|
512
|
|
|
513 -- Reset wide character byte count for next line
|
|
|
514
|
|
|
515 Wide_Char_Byte_Count := 0;
|
|
|
516 end Check_End_Of_Line;
|
|
|
517
|
|
|
518 ----------------------------
|
|
|
519 -- Determine_Token_Casing --
|
|
|
520 ----------------------------
|
|
|
521
|
|
|
522 function Determine_Token_Casing return Casing_Type is
|
|
|
523 begin
|
|
|
524 return Determine_Casing (Source (Token_Ptr .. Scan_Ptr - 1));
|
|
|
525 end Determine_Token_Casing;
|
|
|
526
|
|
|
527 -------------------------
|
|
|
528 -- Initialize_Checksum --
|
|
|
529 -------------------------
|
|
|
530
|
|
|
531 procedure Initialize_Checksum is
|
|
|
532 begin
|
|
|
533 System.CRC32.Initialize (System.CRC32.CRC32 (Checksum));
|
|
|
534 end Initialize_Checksum;
|
|
|
535
|
|
|
536 ------------------------
|
|
|
537 -- Initialize_Scanner --
|
|
|
538 ------------------------
|
|
|
539
|
|
|
540 procedure Initialize_Scanner (Index : Source_File_Index) is
|
|
|
541 begin
|
|
|
542 -- Establish reserved words
|
|
|
543
|
|
|
544 Scans.Initialize_Ada_Keywords;
|
|
|
545
|
|
|
546 -- Initialize scan control variables
|
|
|
547
|
|
|
548 Current_Source_File := Index;
|
|
|
549 Source := Source_Text (Current_Source_File);
|
|
|
550 Scan_Ptr := Source_First (Current_Source_File);
|
|
|
551 Token := No_Token;
|
|
|
552 Token_Ptr := Scan_Ptr;
|
|
|
553 Current_Line_Start := Scan_Ptr;
|
|
|
554 Token_Node := Empty;
|
|
|
555 Token_Name := No_Name;
|
|
|
556 Start_Column := Set_Start_Column;
|
|
|
557 First_Non_Blank_Location := Scan_Ptr;
|
|
|
558
|
|
|
559 Initialize_Checksum;
|
|
|
560 Wide_Char_Byte_Count := 0;
|
|
|
561
|
|
|
562 -- Do not call Scan, otherwise the License stuff does not work in Scn
|
|
|
563
|
|
|
564 end Initialize_Scanner;
|
|
|
565
|
|
|
566 ------------------------------
|
|
|
567 -- Reset_Special_Characters --
|
|
|
568 ------------------------------
|
|
|
569
|
|
|
570 procedure Reset_Special_Characters is
|
|
|
571 begin
|
|
|
572 Special_Characters := (others => False);
|
|
|
573 end Reset_Special_Characters;
|
|
|
574
|
|
|
575 ----------
|
|
|
576 -- Scan --
|
|
|
577 ----------
|
|
|
578
|
|
|
579 procedure Scan is
|
|
|
580
|
|
|
581 Start_Of_Comment : Source_Ptr;
|
|
|
582 -- Record start of comment position
|
|
|
583
|
|
|
584 Underline_Found : Boolean;
|
|
|
585 -- During scanning of an identifier, set to True if last character
|
|
|
586 -- scanned was an underline or other punctuation character. This
|
|
|
587 -- is used to flag the error of two underlines/punctuations in a
|
|
|
588 -- row or ending an identifier with a underline/punctuation. Here
|
|
|
589 -- punctuation means any UTF_32 character in the Unicode category
|
|
|
590 -- Punctuation,Connector.
|
|
|
591
|
|
|
592 Wptr : Source_Ptr;
|
|
|
593 -- Used to remember start of last wide character scanned
|
|
|
594
|
|
|
595 function Double_Char_Token (C : Character) return Boolean;
|
|
|
596 -- This function is used for double character tokens like := or <>. It
|
|
|
597 -- checks if the character following Source (Scan_Ptr) is C, and if so
|
|
|
598 -- bumps Scan_Ptr past the pair of characters and returns True. A space
|
|
|
599 -- between the two characters is also recognized with an appropriate
|
|
|
600 -- error message being issued. If C is not present, False is returned.
|
|
|
601 -- Note that Double_Char_Token can only be used for tokens defined in
|
|
|
602 -- the Ada syntax (it's use for error cases like && is not appropriate
|
|
|
603 -- since we do not want a junk message for a case like &-space-&).
|
|
|
604
|
|
|
605 procedure Error_Illegal_Character;
|
|
|
606 -- Give illegal character error, Scan_Ptr points to character. On
|
|
|
607 -- return, Scan_Ptr is bumped past the illegal character.
|
|
|
608
|
|
|
609 procedure Error_Illegal_Wide_Character;
|
|
|
610 -- Give illegal wide character message. On return, Scan_Ptr is bumped
|
|
|
611 -- past the illegal character, which may still leave us pointing to
|
|
|
612 -- junk, not much we can do if the escape sequence is messed up.
|
|
|
613
|
|
|
614 procedure Error_No_Double_Underline;
|
|
|
615 -- Signal error of two underline or punctuation characters in a row.
|
|
|
616 -- Called with Scan_Ptr pointing to second underline/punctuation char.
|
|
|
617
|
|
|
618 procedure Nlit;
|
|
|
619 -- This is the procedure for scanning out numeric literals. On entry,
|
|
|
620 -- Scan_Ptr points to the digit that starts the numeric literal (the
|
|
|
621 -- checksum for this character has not been accumulated yet). On return
|
|
|
622 -- Scan_Ptr points past the last character of the numeric literal, Token
|
|
|
623 -- and Token_Node are set appropriately, and the checksum is updated.
|
|
|
624
|
|
|
625 procedure Slit;
|
|
|
626 -- This is the procedure for scanning out string literals. On entry,
|
|
|
627 -- Scan_Ptr points to the opening string quote (the checksum for this
|
|
|
628 -- character has not been accumulated yet). On return Scan_Ptr points
|
|
|
629 -- past the closing quote of the string literal, Token and Token_Node
|
|
|
630 -- are set appropriately, and the checksum is updated.
|
|
|
631
|
|
|
632 procedure Skip_Other_Format_Characters;
|
|
|
633 -- Skips past any "other format" category characters at the current
|
|
|
634 -- cursor location (does not skip past spaces or any other characters).
|
|
|
635
|
|
|
636 function Start_Of_Wide_Character return Boolean;
|
|
|
637 -- Returns True if the scan pointer is pointing to the start of a wide
|
|
|
638 -- character sequence, does not modify the scan pointer in any case.
|
|
|
639
|
|
|
640 -----------------------
|
|
|
641 -- Double_Char_Token --
|
|
|
642 -----------------------
|
|
|
643
|
|
|
644 function Double_Char_Token (C : Character) return Boolean is
|
|
|
645 begin
|
|
|
646 if Source (Scan_Ptr + 1) = C then
|
|
|
647 Accumulate_Checksum (C);
|
|
|
648 Scan_Ptr := Scan_Ptr + 2;
|
|
|
649 return True;
|
|
|
650
|
|
|
651 elsif Source (Scan_Ptr + 1) = ' '
|
|
|
652 and then Source (Scan_Ptr + 2) = C
|
|
|
653 then
|
|
|
654 Scan_Ptr := Scan_Ptr + 1;
|
|
|
655 Error_Msg_S -- CODEFIX
|
|
|
656 ("no space allowed here");
|
|
|
657 Scan_Ptr := Scan_Ptr + 2;
|
|
|
658 return True;
|
|
|
659
|
|
|
660 else
|
|
|
661 return False;
|
|
|
662 end if;
|
|
|
663 end Double_Char_Token;
|
|
|
664
|
|
|
665 -----------------------------
|
|
|
666 -- Error_Illegal_Character --
|
|
|
667 -----------------------------
|
|
|
668
|
|
|
669 procedure Error_Illegal_Character is
|
|
|
670 begin
|
|
|
671 Error_Msg_S ("illegal character");
|
|
|
672 Scan_Ptr := Scan_Ptr + 1;
|
|
|
673 end Error_Illegal_Character;
|
|
|
674
|
|
|
675 ----------------------------------
|
|
|
676 -- Error_Illegal_Wide_Character --
|
|
|
677 ----------------------------------
|
|
|
678
|
|
|
679 procedure Error_Illegal_Wide_Character is
|
|
|
680 begin
|
|
|
681 Scan_Ptr := Scan_Ptr + 1;
|
|
|
682 Error_Msg ("illegal wide character", Wptr);
|
|
|
683 end Error_Illegal_Wide_Character;
|
|
|
684
|
|
|
685 -------------------------------
|
|
|
686 -- Error_No_Double_Underline --
|
|
|
687 -------------------------------
|
|
|
688
|
|
|
689 procedure Error_No_Double_Underline is
|
|
|
690 begin
|
|
|
691 Underline_Found := False;
|
|
|
692
|
|
|
693 -- There are four cases, and we special case the messages
|
|
|
694
|
|
|
695 if Source (Scan_Ptr) = '_' then
|
|
|
696 if Source (Scan_Ptr - 1) = '_' then
|
|
|
697 Error_Msg_S -- CODEFIX
|
|
|
698 ("two consecutive underlines not permitted");
|
|
|
699 else
|
|
|
700 Error_Msg_S ("underline cannot follow punctuation character");
|
|
|
701 end if;
|
|
|
702
|
|
|
703 else
|
|
|
704 if Source (Scan_Ptr - 1) = '_' then
|
|
|
705 Error_Msg_S ("punctuation character cannot follow underline");
|
|
|
706 else
|
|
|
707 Error_Msg_S
|
|
|
708 ("two consecutive punctuation characters not permitted");
|
|
|
709 end if;
|
|
|
710 end if;
|
|
|
711 end Error_No_Double_Underline;
|
|
|
712
|
|
|
713 ----------
|
|
|
714 -- Nlit --
|
|
|
715 ----------
|
|
|
716
|
|
|
717 procedure Nlit is
|
|
|
718
|
|
|
719 C : Character;
|
|
|
720 -- Current source program character
|
|
|
721
|
|
|
722 Base_Char : Character;
|
|
|
723 -- Either # or : (character at start of based number)
|
|
|
724
|
|
|
725 Base : Int;
|
|
|
726 -- Value of base
|
|
|
727
|
|
|
728 UI_Base : Uint;
|
|
|
729 -- Value of base in Uint format
|
|
|
730
|
|
|
731 UI_Int_Value : Uint;
|
|
|
732 -- Value of integer scanned by Scan_Integer in Uint format
|
|
|
733
|
|
|
734 UI_Num_Value : Uint;
|
|
|
735 -- Value of integer in numeric value being scanned
|
|
|
736
|
|
|
737 Scale : Int;
|
|
|
738 -- Scale value for real literal
|
|
|
739
|
|
|
740 UI_Scale : Uint;
|
|
|
741 -- Scale in Uint format
|
|
|
742
|
|
|
743 Exponent_Is_Negative : Boolean;
|
|
|
744 -- Set true for negative exponent
|
|
|
745
|
|
|
746 Extended_Digit_Value : Int;
|
|
|
747 -- Extended digit value
|
|
|
748
|
|
|
749 Point_Scanned : Boolean;
|
|
|
750 -- Flag for decimal point scanned in numeric literal
|
|
|
751
|
|
|
752 -----------------------
|
|
|
753 -- Local Subprograms --
|
|
|
754 -----------------------
|
|
|
755
|
|
|
756 procedure Error_Digit_Expected;
|
|
|
757 -- Signal error of bad digit, Scan_Ptr points to the location at
|
|
|
758 -- which the digit was expected on input, and is unchanged on return.
|
|
|
759
|
|
|
760 procedure Scan_Integer;
|
|
|
761 -- Scan integer literal. On entry, Scan_Ptr points to a digit, on
|
|
|
762 -- exit Scan_Ptr points past the last character of the integer.
|
|
|
763 --
|
|
|
764 -- For each digit encountered, UI_Int_Value is multiplied by 10, and
|
|
|
765 -- the value of the digit added to the result. In addition, the value
|
|
|
766 -- in Scale is decremented by one for each actual digit scanned.
|
|
|
767
|
|
|
768 --------------------------
|
|
|
769 -- Error_Digit_Expected --
|
|
|
770 --------------------------
|
|
|
771
|
|
|
772 procedure Error_Digit_Expected is
|
|
|
773 begin
|
|
|
774 Error_Msg_S ("digit expected");
|
|
|
775 end Error_Digit_Expected;
|
|
|
776
|
|
|
777 ------------------
|
|
|
778 -- Scan_Integer --
|
|
|
779 ------------------
|
|
|
780
|
|
|
781 procedure Scan_Integer is
|
|
|
782 C : Character;
|
|
|
783 -- Next character scanned
|
|
|
784
|
|
|
785 begin
|
|
|
786 C := Source (Scan_Ptr);
|
|
|
787
|
|
|
788 -- Loop through digits (allowing underlines)
|
|
|
789
|
|
|
790 loop
|
|
|
791 Accumulate_Checksum (C);
|
|
|
792 UI_Int_Value :=
|
|
|
793 UI_Int_Value * 10 + (Character'Pos (C) - Character'Pos ('0'));
|
|
|
794 Scan_Ptr := Scan_Ptr + 1;
|
|
|
795 Scale := Scale - 1;
|
|
|
796 C := Source (Scan_Ptr);
|
|
|
797
|
|
|
798 -- Case of underline encountered
|
|
|
799
|
|
|
800 if C = '_' then
|
|
|
801
|
|
|
802 -- We do not accumulate the '_' in the checksum, so that
|
|
|
803 -- 1_234 is equivalent to 1234, and does not trigger
|
|
|
804 -- compilation for "minimal recompilation" (gnatmake -m).
|
|
|
805
|
|
|
806 loop
|
|
|
807 Scan_Ptr := Scan_Ptr + 1;
|
|
|
808 C := Source (Scan_Ptr);
|
|
|
809 exit when C /= '_';
|
|
|
810 Error_No_Double_Underline;
|
|
|
811 end loop;
|
|
|
812
|
|
|
813 if C not in '0' .. '9' then
|
|
|
814 Error_Digit_Expected;
|
|
|
815 exit;
|
|
|
816 end if;
|
|
|
817
|
|
|
818 else
|
|
|
819 exit when C not in '0' .. '9';
|
|
|
820 end if;
|
|
|
821 end loop;
|
|
|
822 end Scan_Integer;
|
|
|
823
|
|
|
824 -- Start of processing for Nlit
|
|
|
825
|
|
|
826 begin
|
|
|
827 Base := 10;
|
|
|
828 UI_Base := Uint_10;
|
|
|
829 UI_Int_Value := Uint_0;
|
|
|
830 Based_Literal_Uses_Colon := False;
|
|
|
831 Scale := 0;
|
|
|
832 Scan_Integer;
|
|
|
833 Point_Scanned := False;
|
|
|
834 UI_Num_Value := UI_Int_Value;
|
|
|
835
|
|
|
836 -- Various possibilities now for continuing the literal are period,
|
|
|
837 -- E/e (for exponent), or :/# (for based literal).
|
|
|
838
|
|
|
839 Scale := 0;
|
|
|
840 C := Source (Scan_Ptr);
|
|
|
841
|
|
|
842 if C = '.' then
|
|
|
843
|
|
|
844 -- Scan out point, but do not scan past .. which is a range
|
|
|
845 -- sequence, and must not be eaten up scanning a numeric literal.
|
|
|
846
|
|
|
847 while C = '.' and then Source (Scan_Ptr + 1) /= '.' loop
|
|
|
848 Accumulate_Checksum ('.');
|
|
|
849
|
|
|
850 if Point_Scanned then
|
|
|
851 Error_Msg_S ("duplicate point ignored");
|
|
|
852 end if;
|
|
|
853
|
|
|
854 Point_Scanned := True;
|
|
|
855 Scan_Ptr := Scan_Ptr + 1;
|
|
|
856 C := Source (Scan_Ptr);
|
|
|
857
|
|
|
858 if C not in '0' .. '9' then
|
|
|
859 Error_Msg
|
|
|
860 ("real literal cannot end with point", Scan_Ptr - 1);
|
|
|
861 else
|
|
|
862 Scan_Integer;
|
|
|
863 UI_Num_Value := UI_Int_Value;
|
|
|
864 end if;
|
|
|
865 end loop;
|
|
|
866
|
|
|
867 -- Based literal case. The base is the value we already scanned.
|
|
|
868 -- In the case of colon, we insist that the following character
|
|
|
869 -- is indeed an extended digit or a period. This catches a number
|
|
|
870 -- of common errors, as well as catching the well known tricky
|
|
|
871 -- bug otherwise arising from "x : integer range 1 .. 10:= 6;"
|
|
|
872
|
|
|
873 elsif C = '#'
|
|
|
874 or else (C = ':' and then
|
|
|
875 (Source (Scan_Ptr + 1) = '.'
|
|
|
876 or else
|
|
|
877 Source (Scan_Ptr + 1) in '0' .. '9'
|
|
|
878 or else
|
|
|
879 Source (Scan_Ptr + 1) in 'A' .. 'Z'
|
|
|
880 or else
|
|
|
881 Source (Scan_Ptr + 1) in 'a' .. 'z'))
|
|
|
882 then
|
|
|
883 Accumulate_Checksum (C);
|
|
|
884 Base_Char := C;
|
|
|
885 UI_Base := UI_Int_Value;
|
|
|
886
|
|
|
887 if Base_Char = ':' then
|
|
|
888 Based_Literal_Uses_Colon := True;
|
|
|
889 end if;
|
|
|
890
|
|
|
891 if UI_Base < 2 or else UI_Base > 16 then
|
|
|
892 Error_Msg_SC ("base not 2-16");
|
|
|
893 UI_Base := Uint_16;
|
|
|
894 end if;
|
|
|
895
|
|
|
896 Base := UI_To_Int (UI_Base);
|
|
|
897 Scan_Ptr := Scan_Ptr + 1;
|
|
|
898
|
|
|
899 -- Scan out extended integer [. integer]
|
|
|
900
|
|
|
901 C := Source (Scan_Ptr);
|
|
|
902 UI_Int_Value := Uint_0;
|
|
|
903 Scale := 0;
|
|
|
904
|
|
|
905 loop
|
|
|
906 if C in '0' .. '9' then
|
|
|
907 Accumulate_Checksum (C);
|
|
|
908 Extended_Digit_Value :=
|
|
|
909 Int'(Character'Pos (C)) - Int'(Character'Pos ('0'));
|
|
|
910
|
|
|
911 elsif C in 'A' .. 'F' then
|
|
|
912 Accumulate_Checksum (Character'Val (Character'Pos (C) + 32));
|
|
|
913 Extended_Digit_Value :=
|
|
|
914 Int'(Character'Pos (C)) - Int'(Character'Pos ('A')) + 10;
|
|
|
915
|
|
|
916 elsif C in 'a' .. 'f' then
|
|
|
917 Accumulate_Checksum (C);
|
|
|
918 Extended_Digit_Value :=
|
|
|
919 Int'(Character'Pos (C)) - Int'(Character'Pos ('a')) + 10;
|
|
|
920
|
|
|
921 else
|
|
|
922 Error_Msg_S ("extended digit expected");
|
|
|
923 exit;
|
|
|
924 end if;
|
|
|
925
|
|
|
926 if Extended_Digit_Value >= Base then
|
|
|
927 Error_Msg_S ("digit '>= base");
|
|
|
928 end if;
|
|
|
929
|
|
|
930 UI_Int_Value := UI_Int_Value * UI_Base + Extended_Digit_Value;
|
|
|
931 Scale := Scale - 1;
|
|
|
932 Scan_Ptr := Scan_Ptr + 1;
|
|
|
933 C := Source (Scan_Ptr);
|
|
|
934
|
|
|
935 if C = '_' then
|
|
|
936 loop
|
|
|
937 Accumulate_Checksum ('_');
|
|
|
938 Scan_Ptr := Scan_Ptr + 1;
|
|
|
939 C := Source (Scan_Ptr);
|
|
|
940 exit when C /= '_';
|
|
|
941 Error_No_Double_Underline;
|
|
|
942 end loop;
|
|
|
943
|
|
|
944 elsif C = '.' then
|
|
|
945 Accumulate_Checksum ('.');
|
|
|
946
|
|
|
947 if Point_Scanned then
|
|
|
948 Error_Msg_S ("duplicate point ignored");
|
|
|
949 end if;
|
|
|
950
|
|
|
951 Scan_Ptr := Scan_Ptr + 1;
|
|
|
952 C := Source (Scan_Ptr);
|
|
|
953 Point_Scanned := True;
|
|
|
954 Scale := 0;
|
|
|
955
|
|
|
956 elsif C = Base_Char then
|
|
|
957 Accumulate_Checksum (C);
|
|
|
958 Scan_Ptr := Scan_Ptr + 1;
|
|
|
959 exit;
|
|
|
960
|
|
|
961 elsif C = '#' or else C = ':' then
|
|
|
962 Error_Msg_S ("based number delimiters must match");
|
|
|
963 Scan_Ptr := Scan_Ptr + 1;
|
|
|
964 exit;
|
|
|
965
|
|
|
966 elsif not Identifier_Char (C) then
|
|
|
967 if Base_Char = '#' then
|
|
|
968 Error_Msg_S -- CODEFIX
|
|
|
969 ("missing '#");
|
|
|
970 else
|
|
|
971 Error_Msg_S -- CODEFIX
|
|
|
972 ("missing ':");
|
|
|
973 end if;
|
|
|
974
|
|
|
975 exit;
|
|
|
976 end if;
|
|
|
977
|
|
|
978 end loop;
|
|
|
979
|
|
|
980 UI_Num_Value := UI_Int_Value;
|
|
|
981 end if;
|
|
|
982
|
|
|
983 -- Scan out exponent
|
|
|
984
|
|
|
985 if not Point_Scanned then
|
|
|
986 Scale := 0;
|
|
|
987 UI_Scale := Uint_0;
|
|
|
988 else
|
|
|
989 UI_Scale := UI_From_Int (Scale);
|
|
|
990 end if;
|
|
|
991
|
|
|
992 if Source (Scan_Ptr) = 'e' or else Source (Scan_Ptr) = 'E' then
|
|
|
993 Accumulate_Checksum ('e');
|
|
|
994 Scan_Ptr := Scan_Ptr + 1;
|
|
|
995 Exponent_Is_Negative := False;
|
|
|
996
|
|
|
997 if Source (Scan_Ptr) = '+' then
|
|
|
998 Accumulate_Checksum ('+');
|
|
|
999 Scan_Ptr := Scan_Ptr + 1;
|
|
|
1000
|
|
|
1001 elsif Source (Scan_Ptr) = '-' then
|
|
|
1002 Accumulate_Checksum ('-');
|
|
|
1003
|
|
|
1004 if not Point_Scanned then
|
|
|
1005 Error_Msg_S
|
|
|
1006 ("negative exponent not allowed for integer literal");
|
|
|
1007 else
|
|
|
1008 Exponent_Is_Negative := True;
|
|
|
1009 end if;
|
|
|
1010
|
|
|
1011 Scan_Ptr := Scan_Ptr + 1;
|
|
|
1012 end if;
|
|
|
1013
|
|
|
1014 UI_Int_Value := Uint_0;
|
|
|
1015
|
|
|
1016 if Source (Scan_Ptr) in '0' .. '9' then
|
|
|
1017 Scan_Integer;
|
|
|
1018 else
|
|
|
1019 Error_Digit_Expected;
|
|
|
1020 end if;
|
|
|
1021
|
|
|
1022 if Exponent_Is_Negative then
|
|
|
1023 UI_Scale := UI_Scale - UI_Int_Value;
|
|
|
1024 else
|
|
|
1025 UI_Scale := UI_Scale + UI_Int_Value;
|
|
|
1026 end if;
|
|
|
1027 end if;
|
|
|
1028
|
|
|
1029 -- Case of real literal to be returned
|
|
|
1030
|
|
|
1031 if Point_Scanned then
|
|
|
1032 Token := Tok_Real_Literal;
|
|
|
1033 Real_Literal_Value :=
|
|
|
1034 UR_From_Components (
|
|
|
1035 Num => UI_Num_Value,
|
|
|
1036 Den => -UI_Scale,
|
|
|
1037 Rbase => Base);
|
|
|
1038
|
|
|
1039 -- Case of integer literal to be returned
|
|
|
1040
|
|
|
1041 else
|
|
|
1042 Token := Tok_Integer_Literal;
|
|
|
1043
|
|
|
1044 if UI_Scale = 0 then
|
|
|
1045 Int_Literal_Value := UI_Num_Value;
|
|
|
1046
|
|
|
1047 -- Avoid doing possibly expensive calculations in cases like
|
|
|
1048 -- parsing 163E800_000# when semantics will not be done anyway.
|
|
|
1049 -- This is especially useful when parsing garbled input.
|
|
|
1050
|
|
|
1051 elsif Operating_Mode /= Check_Syntax
|
|
|
1052 and then (Serious_Errors_Detected = 0 or else Try_Semantics)
|
|
|
1053 then
|
|
|
1054 Int_Literal_Value := UI_Num_Value * UI_Base ** UI_Scale;
|
|
|
1055
|
|
|
1056 else
|
|
|
1057 Int_Literal_Value := No_Uint;
|
|
|
1058 end if;
|
|
|
1059 end if;
|
|
|
1060
|
|
|
1061 if Checksum_Accumulate_Token_Checksum then
|
|
|
1062 Accumulate_Token_Checksum;
|
|
|
1063 end if;
|
|
|
1064
|
|
|
1065 return;
|
|
|
1066 end Nlit;
|
|
|
1067
|
|
|
1068 ----------
|
|
|
1069 -- Slit --
|
|
|
1070 ----------
|
|
|
1071
|
|
|
1072 procedure Slit is
|
|
|
1073
|
|
|
1074 Delimiter : Character;
|
|
|
1075 -- Delimiter (first character of string)
|
|
|
1076
|
|
|
1077 C : Character;
|
|
|
1078 -- Current source program character
|
|
|
1079
|
|
|
1080 Code : Char_Code;
|
|
|
1081 -- Current character code value
|
|
|
1082
|
|
|
1083 Err : Boolean;
|
|
|
1084 -- Error flag for Scan_Wide call
|
|
|
1085
|
|
|
1086 String_Start : Source_Ptr;
|
|
|
1087 -- Point to first character of string
|
|
|
1088
|
|
|
1089 procedure Error_Bad_String_Char;
|
|
|
1090 -- Signal bad character in string/character literal. On entry
|
|
|
1091 -- Scan_Ptr points to the improper character encountered during the
|
|
|
1092 -- scan. Scan_Ptr is not modified, so it still points to the bad
|
|
|
1093 -- character on return.
|
|
|
1094
|
|
|
1095 procedure Error_Unterminated_String;
|
|
|
1096 -- Procedure called if a line terminator character is encountered
|
|
|
1097 -- during scanning a string, meaning that the string is not properly
|
|
|
1098 -- terminated.
|
|
|
1099
|
|
|
1100 procedure Set_String;
|
|
|
1101 -- Procedure used to distinguish between string and operator symbol.
|
|
|
1102 -- On entry the string has been scanned out, and its characters start
|
|
|
1103 -- at Token_Ptr and end one character before Scan_Ptr. On exit Token
|
|
|
1104 -- is set to Tok_String_Literal/Tok_Operator_Symbol as appropriate,
|
|
|
1105 -- and Token_Node is appropriately initialized. In addition, in the
|
|
|
1106 -- operator symbol case, Token_Name is appropriately set, and the
|
|
|
1107 -- flags [Wide_]Wide_Character_Found are set appropriately.
|
|
|
1108
|
|
|
1109 ---------------------------
|
|
|
1110 -- Error_Bad_String_Char --
|
|
|
1111 ---------------------------
|
|
|
1112
|
|
|
1113 procedure Error_Bad_String_Char is
|
|
|
1114 C : constant Character := Source (Scan_Ptr);
|
|
|
1115
|
|
|
1116 begin
|
|
|
1117 if C = HT then
|
|
|
1118 Error_Msg_S ("horizontal tab not allowed in string");
|
|
|
1119
|
|
|
1120 elsif C = VT or else C = FF then
|
|
|
1121 Error_Msg_S ("format effector not allowed in string");
|
|
|
1122
|
|
|
1123 elsif C in Upper_Half_Character then
|
|
|
1124 Error_Msg_S ("(Ada 83) upper half character not allowed");
|
|
|
1125
|
|
|
1126 else
|
|
|
1127 Error_Msg_S ("control character not allowed in string");
|
|
|
1128 end if;
|
|
|
1129 end Error_Bad_String_Char;
|
|
|
1130
|
|
|
1131 -------------------------------
|
|
|
1132 -- Error_Unterminated_String --
|
|
|
1133 -------------------------------
|
|
|
1134
|
|
|
1135 procedure Error_Unterminated_String is
|
|
|
1136 S : Source_Ptr;
|
|
|
1137
|
|
|
1138 begin
|
|
|
1139 -- An interesting little refinement. Consider the following
|
|
|
1140 -- examples:
|
|
|
1141
|
|
|
1142 -- A := "this is an unterminated string;
|
|
|
1143 -- A := "this is an unterminated string &
|
|
|
1144 -- P(A, "this is a parameter that didn't get terminated);
|
|
|
1145 -- P("this is a parameter that didn't get terminated, A);
|
|
|
1146
|
|
|
1147 -- We fiddle a little to do slightly better placement in these
|
|
|
1148 -- cases also if there is white space at the end of the line we
|
|
|
1149 -- place the flag at the start of this white space, not at the
|
|
|
1150 -- end. Note that we only have to test for blanks, since tabs
|
|
|
1151 -- aren't allowed in strings in the first place and would have
|
|
|
1152 -- caused an error message.
|
|
|
1153
|
|
|
1154 -- Two more cases that we treat specially are:
|
|
|
1155
|
|
|
1156 -- A := "this string uses the wrong terminator'
|
|
|
1157 -- A := "this string uses the wrong terminator' &
|
|
|
1158
|
|
|
1159 -- In these cases we give a different error message as well
|
|
|
1160
|
|
|
1161 -- We actually reposition the scan pointer to the point where we
|
|
|
1162 -- place the flag in these cases, since it seems a better bet on
|
|
|
1163 -- the original intention.
|
|
|
1164
|
|
|
1165 while Source (Scan_Ptr - 1) = ' '
|
|
|
1166 or else Source (Scan_Ptr - 1) = '&'
|
|
|
1167 loop
|
|
|
1168 Scan_Ptr := Scan_Ptr - 1;
|
|
|
1169 Unstore_String_Char;
|
|
|
1170 end loop;
|
|
|
1171
|
|
|
1172 -- Check for case of incorrect string terminator, but single quote
|
|
|
1173 -- is not considered incorrect if the opening terminator misused
|
|
|
1174 -- a single quote (error message already given).
|
|
|
1175
|
|
|
1176 if Delimiter /= '''
|
|
|
1177 and then Source (Scan_Ptr - 1) = '''
|
|
|
1178 then
|
|
|
1179 Unstore_String_Char;
|
|
|
1180 Error_Msg
|
|
|
1181 ("incorrect string terminator character", Scan_Ptr - 1);
|
|
|
1182 return;
|
|
|
1183 end if;
|
|
|
1184
|
|
|
1185 -- Backup over semicolon or right-paren/semicolon sequence
|
|
|
1186
|
|
|
1187 if Source (Scan_Ptr - 1) = ';' then
|
|
|
1188 Scan_Ptr := Scan_Ptr - 1;
|
|
|
1189 Unstore_String_Char;
|
|
|
1190
|
|
|
1191 if Source (Scan_Ptr - 1) = ')' then
|
|
|
1192 Scan_Ptr := Scan_Ptr - 1;
|
|
|
1193 Unstore_String_Char;
|
|
|
1194 end if;
|
|
|
1195 end if;
|
|
|
1196
|
|
|
1197 -- See if there is a comma in the string, if so, guess that
|
|
|
1198 -- the first comma terminates the string.
|
|
|
1199
|
|
|
1200 S := String_Start;
|
|
|
1201 while S < Scan_Ptr loop
|
|
|
1202 if Source (S) = ',' then
|
|
|
1203 while Scan_Ptr > S loop
|
|
|
1204 Scan_Ptr := Scan_Ptr - 1;
|
|
|
1205 Unstore_String_Char;
|
|
|
1206 end loop;
|
|
|
1207
|
|
|
1208 exit;
|
|
|
1209 end if;
|
|
|
1210
|
|
|
1211 S := S + 1;
|
|
|
1212 end loop;
|
|
|
1213
|
|
|
1214 -- Now we have adjusted the scan pointer, give message
|
|
|
1215
|
|
|
1216 Error_Msg_S -- CODEFIX
|
|
|
1217 ("missing string quote");
|
|
|
1218 end Error_Unterminated_String;
|
|
|
1219
|
|
|
1220 ----------------
|
|
|
1221 -- Set_String --
|
|
|
1222 ----------------
|
|
|
1223
|
|
|
1224 procedure Set_String is
|
|
|
1225 Slen : constant Int := Int (Scan_Ptr - Token_Ptr - 2);
|
|
|
1226 C1 : Character;
|
|
|
1227 C2 : Character;
|
|
|
1228 C3 : Character;
|
|
|
1229
|
|
|
1230 begin
|
|
|
1231 -- Token_Name is currently set to Error_Name. The following
|
|
|
1232 -- section of code resets Token_Name to the proper Name_Op_xx
|
|
|
1233 -- value if the string is a valid operator symbol, otherwise it is
|
|
|
1234 -- left set to Error_Name.
|
|
|
1235
|
|
|
1236 if Slen = 1 then
|
|
|
1237 C1 := Source (Token_Ptr + 1);
|
|
|
1238
|
|
|
1239 case C1 is
|
|
|
1240 when '=' =>
|
|
|
1241 Token_Name := Name_Op_Eq;
|
|
|
1242
|
|
|
1243 when '>' =>
|
|
|
1244 Token_Name := Name_Op_Gt;
|
|
|
1245
|
|
|
1246 when '<' =>
|
|
|
1247 Token_Name := Name_Op_Lt;
|
|
|
1248
|
|
|
1249 when '+' =>
|
|
|
1250 Token_Name := Name_Op_Add;
|
|
|
1251
|
|
|
1252 when '-' =>
|
|
|
1253 Token_Name := Name_Op_Subtract;
|
|
|
1254
|
|
|
1255 when '&' =>
|
|
|
1256 Token_Name := Name_Op_Concat;
|
|
|
1257
|
|
|
1258 when '*' =>
|
|
|
1259 Token_Name := Name_Op_Multiply;
|
|
|
1260
|
|
|
1261 when '/' =>
|
|
|
1262 Token_Name := Name_Op_Divide;
|
|
|
1263
|
|
|
1264 when others =>
|
|
|
1265 null;
|
|
|
1266 end case;
|
|
|
1267
|
|
|
1268 elsif Slen = 2 then
|
|
|
1269 C1 := Source (Token_Ptr + 1);
|
|
|
1270 C2 := Source (Token_Ptr + 2);
|
|
|
1271
|
|
|
1272 if C1 = '*' and then C2 = '*' then
|
|
|
1273 Token_Name := Name_Op_Expon;
|
|
|
1274
|
|
|
1275 elsif C2 = '=' then
|
|
|
1276
|
|
|
1277 if C1 = '/' then
|
|
|
1278 Token_Name := Name_Op_Ne;
|
|
|
1279 elsif C1 = '<' then
|
|
|
1280 Token_Name := Name_Op_Le;
|
|
|
1281 elsif C1 = '>' then
|
|
|
1282 Token_Name := Name_Op_Ge;
|
|
|
1283 end if;
|
|
|
1284
|
|
|
1285 elsif (C1 = 'O' or else C1 = 'o') and then -- OR
|
|
|
1286 (C2 = 'R' or else C2 = 'r')
|
|
|
1287 then
|
|
|
1288 Token_Name := Name_Op_Or;
|
|
|
1289 end if;
|
|
|
1290
|
|
|
1291 elsif Slen = 3 then
|
|
|
1292 C1 := Source (Token_Ptr + 1);
|
|
|
1293 C2 := Source (Token_Ptr + 2);
|
|
|
1294 C3 := Source (Token_Ptr + 3);
|
|
|
1295
|
|
|
1296 if (C1 = 'A' or else C1 = 'a') and then -- AND
|
|
|
1297 (C2 = 'N' or else C2 = 'n') and then
|
|
|
1298 (C3 = 'D' or else C3 = 'd')
|
|
|
1299 then
|
|
|
1300 Token_Name := Name_Op_And;
|
|
|
1301
|
|
|
1302 elsif (C1 = 'A' or else C1 = 'a') and then -- ABS
|
|
|
1303 (C2 = 'B' or else C2 = 'b') and then
|
|
|
1304 (C3 = 'S' or else C3 = 's')
|
|
|
1305 then
|
|
|
1306 Token_Name := Name_Op_Abs;
|
|
|
1307
|
|
|
1308 elsif (C1 = 'M' or else C1 = 'm') and then -- MOD
|
|
|
1309 (C2 = 'O' or else C2 = 'o') and then
|
|
|
1310 (C3 = 'D' or else C3 = 'd')
|
|
|
1311 then
|
|
|
1312 Token_Name := Name_Op_Mod;
|
|
|
1313
|
|
|
1314 elsif (C1 = 'N' or else C1 = 'n') and then -- NOT
|
|
|
1315 (C2 = 'O' or else C2 = 'o') and then
|
|
|
1316 (C3 = 'T' or else C3 = 't')
|
|
|
1317 then
|
|
|
1318 Token_Name := Name_Op_Not;
|
|
|
1319
|
|
|
1320 elsif (C1 = 'R' or else C1 = 'r') and then -- REM
|
|
|
1321 (C2 = 'E' or else C2 = 'e') and then
|
|
|
1322 (C3 = 'M' or else C3 = 'm')
|
|
|
1323 then
|
|
|
1324 Token_Name := Name_Op_Rem;
|
|
|
1325
|
|
|
1326 elsif (C1 = 'X' or else C1 = 'x') and then -- XOR
|
|
|
1327 (C2 = 'O' or else C2 = 'o') and then
|
|
|
1328 (C3 = 'R' or else C3 = 'r')
|
|
|
1329 then
|
|
|
1330 Token_Name := Name_Op_Xor;
|
|
|
1331 end if;
|
|
|
1332
|
|
|
1333 end if;
|
|
|
1334
|
|
|
1335 -- If it is an operator symbol, then Token_Name is set. If it is
|
|
|
1336 -- some other string value, then Token_Name still contains
|
|
|
1337 -- Error_Name.
|
|
|
1338
|
|
|
1339 if Token_Name = Error_Name then
|
|
|
1340 Token := Tok_String_Literal;
|
|
|
1341
|
|
|
1342 else
|
|
|
1343 Token := Tok_Operator_Symbol;
|
|
|
1344 end if;
|
|
|
1345 end Set_String;
|
|
|
1346
|
|
|
1347 -- Start of processing for Slit
|
|
|
1348
|
|
|
1349 begin
|
|
|
1350 -- On entry, Scan_Ptr points to the opening character of the string
|
|
|
1351 -- which is either a percent, double quote, or apostrophe (single
|
|
|
1352 -- quote). The latter case is an error detected by the character
|
|
|
1353 -- literal circuit.
|
|
|
1354
|
|
|
1355 String_Start := Scan_Ptr;
|
|
|
1356
|
|
|
1357 Delimiter := Source (Scan_Ptr);
|
|
|
1358 Accumulate_Checksum (Delimiter);
|
|
|
1359
|
|
|
1360 Start_String;
|
|
|
1361 Wide_Character_Found := False;
|
|
|
1362 Wide_Wide_Character_Found := False;
|
|
|
1363 Scan_Ptr := Scan_Ptr + 1;
|
|
|
1364
|
|
|
1365 -- Loop to scan out characters of string literal
|
|
|
1366
|
|
|
1367 loop
|
|
|
1368 C := Source (Scan_Ptr);
|
|
|
1369
|
|
|
1370 if C = Delimiter then
|
|
|
1371 Accumulate_Checksum (C);
|
|
|
1372 Scan_Ptr := Scan_Ptr + 1;
|
|
|
1373 exit when Source (Scan_Ptr) /= Delimiter;
|
|
|
1374 Code := Get_Char_Code (C);
|
|
|
1375 Accumulate_Checksum (C);
|
|
|
1376 Scan_Ptr := Scan_Ptr + 1;
|
|
|
1377
|
|
|
1378 else
|
|
|
1379 if C = '"' and then Delimiter = '%' then
|
|
|
1380 Error_Msg_S
|
|
|
1381 ("quote not allowed in percent delimited string");
|
|
|
1382 Code := Get_Char_Code (C);
|
|
|
1383 Scan_Ptr := Scan_Ptr + 1;
|
|
|
1384
|
|
|
1385 elsif Start_Of_Wide_Character then
|
|
|
1386 Wptr := Scan_Ptr;
|
|
|
1387 Scan_Wide (Source, Scan_Ptr, Code, Err);
|
|
|
1388
|
|
|
1389 if Err then
|
|
|
1390 Error_Illegal_Wide_Character;
|
|
|
1391 Code := Get_Char_Code (' ');
|
|
|
1392 end if;
|
|
|
1393
|
|
|
1394 Accumulate_Checksum (Code);
|
|
|
1395
|
|
|
1396 -- In Ada 95 mode we allow any wide characters in a string
|
|
|
1397 -- but in Ada 2005, the set of characters allowed has been
|
|
|
1398 -- restricted to graphic characters.
|
|
|
1399
|
|
|
1400 if Ada_Version >= Ada_2005
|
|
|
1401 and then Is_UTF_32_Non_Graphic (UTF_32 (Code))
|
|
|
1402 then
|
|
|
1403 Error_Msg
|
|
|
1404 ("(Ada 2005) non-graphic character not permitted " &
|
|
|
1405 "in string literal", Wptr);
|
|
|
1406 end if;
|
|
|
1407
|
|
|
1408 else
|
|
|
1409 Accumulate_Checksum (C);
|
|
|
1410
|
|
|
1411 if C not in Graphic_Character then
|
|
|
1412 if C in Line_Terminator then
|
|
|
1413 Error_Unterminated_String;
|
|
|
1414 exit;
|
|
|
1415
|
|
|
1416 elsif C in Upper_Half_Character then
|
|
|
1417 if Ada_Version = Ada_83 then
|
|
|
1418 Error_Bad_String_Char;
|
|
|
1419 end if;
|
|
|
1420
|
|
|
1421 else
|
|
|
1422 Error_Bad_String_Char;
|
|
|
1423 end if;
|
|
|
1424 end if;
|
|
|
1425
|
|
|
1426 Code := Get_Char_Code (C);
|
|
|
1427 Scan_Ptr := Scan_Ptr + 1;
|
|
|
1428 end if;
|
|
|
1429 end if;
|
|
|
1430
|
|
|
1431 Store_String_Char (Code);
|
|
|
1432
|
|
|
1433 if not In_Character_Range (Code) then
|
|
|
1434 if In_Wide_Character_Range (Code) then
|
|
|
1435 Wide_Character_Found := True;
|
|
|
1436 else
|
|
|
1437 Wide_Wide_Character_Found := True;
|
|
|
1438 end if;
|
|
|
1439 end if;
|
|
|
1440 end loop;
|
|
|
1441
|
|
|
1442 String_Literal_Id := End_String;
|
|
|
1443 Set_String;
|
|
|
1444 return;
|
|
|
1445 end Slit;
|
|
|
1446
|
|
|
1447 ----------------------------------
|
|
|
1448 -- Skip_Other_Format_Characters --
|
|
|
1449 ----------------------------------
|
|
|
1450
|
|
|
1451 procedure Skip_Other_Format_Characters is
|
|
|
1452 P : Source_Ptr;
|
|
|
1453 Code : Char_Code;
|
|
|
1454 Err : Boolean;
|
|
|
1455
|
|
|
1456 begin
|
|
|
1457 while Start_Of_Wide_Character loop
|
|
|
1458 P := Scan_Ptr;
|
|
|
1459 Scan_Wide (Source, Scan_Ptr, Code, Err);
|
|
|
1460
|
|
|
1461 if not Is_UTF_32_Other (UTF_32 (Code)) then
|
|
|
1462 Scan_Ptr := P;
|
|
|
1463 return;
|
|
|
1464 end if;
|
|
|
1465 end loop;
|
|
|
1466 end Skip_Other_Format_Characters;
|
|
|
1467
|
|
|
1468 -----------------------------
|
|
|
1469 -- Start_Of_Wide_Character --
|
|
|
1470 -----------------------------
|
|
|
1471
|
|
|
1472 function Start_Of_Wide_Character return Boolean is
|
|
|
1473 C : constant Character := Source (Scan_Ptr);
|
|
|
1474
|
|
|
1475 begin
|
|
|
1476 -- ESC encoding method with ESC present
|
|
|
1477
|
|
|
1478 if C = ESC
|
|
|
1479 and then Wide_Character_Encoding_Method in WC_ESC_Encoding_Method
|
|
|
1480 then
|
|
|
1481 return True;
|
|
|
1482
|
|
|
1483 -- Upper half character with upper half encoding
|
|
|
1484
|
|
|
1485 elsif C in Upper_Half_Character and then Upper_Half_Encoding then
|
|
|
1486 return True;
|
|
|
1487
|
|
|
1488 -- Brackets encoding
|
|
|
1489
|
|
|
1490 elsif C = '['
|
|
|
1491 and then Source (Scan_Ptr + 1) = '"'
|
|
|
1492 and then Identifier_Char (Source (Scan_Ptr + 2))
|
|
|
1493 then
|
|
|
1494 return True;
|
|
|
1495
|
|
|
1496 -- Not the start of a wide character
|
|
|
1497
|
|
|
1498 else
|
|
|
1499 return False;
|
|
|
1500 end if;
|
|
|
1501 end Start_Of_Wide_Character;
|
|
|
1502
|
|
|
1503 -- Start of processing for Scan
|
|
|
1504
|
|
|
1505 begin
|
|
|
1506 Prev_Token := Token;
|
|
|
1507 Prev_Token_Ptr := Token_Ptr;
|
|
|
1508 Token_Name := Error_Name;
|
|
|
1509
|
|
|
1510 -- The following loop runs more than once only if a format effector
|
|
|
1511 -- (tab, vertical tab, form feed, line feed, carriage return) is
|
|
|
1512 -- encountered and skipped, or some error situation, such as an
|
|
|
1513 -- illegal character, is encountered.
|
|
|
1514
|
|
|
1515 <<Scan_Next_Character>>
|
|
|
1516
|
|
|
1517 loop
|
|
|
1518 -- Skip past blanks, loop is opened up for speed
|
|
|
1519
|
|
|
1520 while Source (Scan_Ptr) = ' ' loop
|
|
|
1521 if Source (Scan_Ptr + 1) /= ' ' then
|
|
|
1522 Scan_Ptr := Scan_Ptr + 1;
|
|
|
1523 exit;
|
|
|
1524 end if;
|
|
|
1525
|
|
|
1526 if Source (Scan_Ptr + 2) /= ' ' then
|
|
|
1527 Scan_Ptr := Scan_Ptr + 2;
|
|
|
1528 exit;
|
|
|
1529 end if;
|
|
|
1530
|
|
|
1531 if Source (Scan_Ptr + 3) /= ' ' then
|
|
|
1532 Scan_Ptr := Scan_Ptr + 3;
|
|
|
1533 exit;
|
|
|
1534 end if;
|
|
|
1535
|
|
|
1536 if Source (Scan_Ptr + 4) /= ' ' then
|
|
|
1537 Scan_Ptr := Scan_Ptr + 4;
|
|
|
1538 exit;
|
|
|
1539 end if;
|
|
|
1540
|
|
|
1541 if Source (Scan_Ptr + 5) /= ' ' then
|
|
|
1542 Scan_Ptr := Scan_Ptr + 5;
|
|
|
1543 exit;
|
|
|
1544 end if;
|
|
|
1545
|
|
|
1546 if Source (Scan_Ptr + 6) /= ' ' then
|
|
|
1547 Scan_Ptr := Scan_Ptr + 6;
|
|
|
1548 exit;
|
|
|
1549 end if;
|
|
|
1550
|
|
|
1551 if Source (Scan_Ptr + 7) /= ' ' then
|
|
|
1552 Scan_Ptr := Scan_Ptr + 7;
|
|
|
1553 exit;
|
|
|
1554 end if;
|
|
|
1555
|
|
|
1556 Scan_Ptr := Scan_Ptr + 8;
|
|
|
1557 end loop;
|
|
|
1558
|
|
|
1559 -- We are now at a non-blank character, which is the first character
|
|
|
1560 -- of the token we will scan, and hence the value of Token_Ptr.
|
|
|
1561
|
|
|
1562 Token_Ptr := Scan_Ptr;
|
|
|
1563
|
|
|
1564 -- Here begins the main case statement which transfers control on the
|
|
|
1565 -- basis of the non-blank character we have encountered.
|
|
|
1566
|
|
|
1567 case Source (Scan_Ptr) is
|
|
|
1568
|
|
|
1569 -- Line terminator characters
|
|
|
1570
|
|
|
1571 when CR | LF | FF | VT =>
|
|
|
1572 goto Scan_Line_Terminator;
|
|
|
1573
|
|
|
1574 -- Horizontal tab, just skip past it
|
|
|
1575
|
|
|
1576 when HT =>
|
|
|
1577 if Style_Check then
|
|
|
1578 Style.Check_HT;
|
|
|
1579 end if;
|
|
|
1580
|
|
|
1581 Scan_Ptr := Scan_Ptr + 1;
|
|
|
1582
|
|
|
1583 -- End of file character, treated as an end of file only if it is
|
|
|
1584 -- the last character in the buffer, otherwise it is ignored.
|
|
|
1585
|
|
|
1586 when EOF =>
|
|
|
1587 if Scan_Ptr = Source_Last (Current_Source_File) then
|
|
|
1588 Check_End_Of_Line;
|
|
|
1589
|
|
|
1590 if Style_Check then
|
|
|
1591 Style.Check_EOF;
|
|
|
1592 end if;
|
|
|
1593
|
|
|
1594 Token := Tok_EOF;
|
|
|
1595 return;
|
|
|
1596 else
|
|
|
1597 Scan_Ptr := Scan_Ptr + 1;
|
|
|
1598 end if;
|
|
|
1599
|
|
|
1600 -- Ampersand
|
|
|
1601
|
|
|
1602 when '&' =>
|
|
|
1603 Accumulate_Checksum ('&');
|
|
|
1604
|
|
|
1605 if Source (Scan_Ptr + 1) = '&' then
|
|
|
1606 Error_Msg_S -- CODEFIX
|
|
|
1607 ("'&'& should be `AND THEN`");
|
|
|
1608 Scan_Ptr := Scan_Ptr + 2;
|
|
|
1609 Token := Tok_And;
|
|
|
1610 return;
|
|
|
1611
|
|
|
1612 else
|
|
|
1613 Scan_Ptr := Scan_Ptr + 1;
|
|
|
1614 Token := Tok_Ampersand;
|
|
|
1615 return;
|
|
|
1616 end if;
|
|
|
1617
|
|
|
1618 when '@' =>
|
|
|
1619 if Ada_Version < Ada_2020 then
|
|
|
1620 Error_Msg ("target_name is an Ada 2020 feature", Scan_Ptr);
|
|
|
1621 Scan_Ptr := Scan_Ptr + 1;
|
|
|
1622
|
|
|
1623 else
|
|
|
1624 -- AI12-0125-03 : @ is target_name
|
|
|
1625
|
|
|
1626 Accumulate_Checksum ('@');
|
|
|
1627 Scan_Ptr := Scan_Ptr + 1;
|
|
|
1628 Token := Tok_At_Sign;
|
|
|
1629 return;
|
|
|
1630 end if;
|
|
|
1631
|
|
|
1632 -- Asterisk (can be multiplication operator or double asterisk which
|
|
|
1633 -- is the exponentiation compound delimiter).
|
|
|
1634
|
|
|
1635 when '*' =>
|
|
|
1636 Accumulate_Checksum ('*');
|
|
|
1637
|
|
|
1638 if Source (Scan_Ptr + 1) = '*' then
|
|
|
1639 Accumulate_Checksum ('*');
|
|
|
1640 Scan_Ptr := Scan_Ptr + 2;
|
|
|
1641 Token := Tok_Double_Asterisk;
|
|
|
1642 return;
|
|
|
1643
|
|
|
1644 else
|
|
|
1645 Scan_Ptr := Scan_Ptr + 1;
|
|
|
1646 Token := Tok_Asterisk;
|
|
|
1647 return;
|
|
|
1648 end if;
|
|
|
1649
|
|
|
1650 -- Colon, which can either be an isolated colon, or part of an
|
|
|
1651 -- assignment compound delimiter.
|
|
|
1652
|
|
|
1653 when ':' =>
|
|
|
1654 Accumulate_Checksum (':');
|
|
|
1655
|
|
|
1656 if Double_Char_Token ('=') then
|
|
|
1657 Token := Tok_Colon_Equal;
|
|
|
1658
|
|
|
1659 if Style_Check then
|
|
|
1660 Style.Check_Colon_Equal;
|
|
|
1661 end if;
|
|
|
1662
|
|
|
1663 return;
|
|
|
1664
|
|
|
1665 elsif Source (Scan_Ptr + 1) = '-'
|
|
|
1666 and then Source (Scan_Ptr + 2) /= '-'
|
|
|
1667 then
|
|
|
1668 Token := Tok_Colon_Equal;
|
|
|
1669 Error_Msg -- CODEFIX
|
|
|
1670 (":- should be :=", Scan_Ptr);
|
|
|
1671 Scan_Ptr := Scan_Ptr + 2;
|
|
|
1672 return;
|
|
|
1673
|
|
|
1674 else
|
|
|
1675 Scan_Ptr := Scan_Ptr + 1;
|
|
|
1676 Token := Tok_Colon;
|
|
|
1677
|
|
|
1678 if Style_Check then
|
|
|
1679 Style.Check_Colon;
|
|
|
1680 end if;
|
|
|
1681
|
|
|
1682 return;
|
|
|
1683 end if;
|
|
|
1684
|
|
|
1685 -- Left parenthesis
|
|
|
1686
|
|
|
1687 when '(' =>
|
|
|
1688 Accumulate_Checksum ('(');
|
|
|
1689 Scan_Ptr := Scan_Ptr + 1;
|
|
|
1690 Token := Tok_Left_Paren;
|
|
|
1691
|
|
|
1692 if Style_Check then
|
|
|
1693 Style.Check_Left_Paren;
|
|
|
1694 end if;
|
|
|
1695
|
|
|
1696 return;
|
|
|
1697
|
|
|
1698 -- Left bracket
|
|
|
1699
|
|
|
1700 when '[' =>
|
|
|
1701 if Source (Scan_Ptr + 1) = '"' then
|
|
|
1702 goto Scan_Wide_Character;
|
|
|
1703
|
|
145
|
1704 elsif Ada_Version = Ada_2020 then
|
|
|
1705 Scan_Ptr := Scan_Ptr + 1;
|
|
|
1706 Token := Tok_Left_Bracket;
|
|
|
1707 return;
|
|
|
1708
|
|
111
|
1709 else
|
|
|
1710 Error_Msg_S ("illegal character, replaced by ""(""");
|
|
|
1711 Scan_Ptr := Scan_Ptr + 1;
|
|
|
1712 Token := Tok_Left_Paren;
|
|
|
1713 return;
|
|
|
1714 end if;
|
|
|
1715
|
|
|
1716 -- Left brace
|
|
|
1717
|
|
|
1718 when '{' =>
|
|
|
1719 Error_Msg_S ("illegal character, replaced by ""(""");
|
|
|
1720 Scan_Ptr := Scan_Ptr + 1;
|
|
|
1721 Token := Tok_Left_Paren;
|
|
|
1722 return;
|
|
|
1723
|
|
|
1724 -- Comma
|
|
|
1725
|
|
|
1726 when ',' =>
|
|
|
1727 Accumulate_Checksum (',');
|
|
|
1728 Scan_Ptr := Scan_Ptr + 1;
|
|
|
1729 Token := Tok_Comma;
|
|
|
1730
|
|
|
1731 if Style_Check then
|
|
|
1732 Style.Check_Comma;
|
|
|
1733 end if;
|
|
|
1734
|
|
|
1735 return;
|
|
|
1736
|
|
|
1737 -- Dot, which is either an isolated period, or part of a double dot
|
|
|
1738 -- compound delimiter sequence. We also check for the case of a
|
|
|
1739 -- digit following the period, to give a better error message.
|
|
|
1740
|
|
|
1741 when '.' =>
|
|
|
1742 Accumulate_Checksum ('.');
|
|
|
1743
|
|
|
1744 if Double_Char_Token ('.') then
|
|
|
1745 Token := Tok_Dot_Dot;
|
|
|
1746
|
|
|
1747 if Style_Check then
|
|
|
1748 Style.Check_Dot_Dot;
|
|
|
1749 end if;
|
|
|
1750
|
|
|
1751 return;
|
|
|
1752
|
|
|
1753 elsif Source (Scan_Ptr + 1) in '0' .. '9' then
|
|
|
1754 Error_Msg_S ("numeric literal cannot start with point");
|
|
|
1755 Scan_Ptr := Scan_Ptr + 1;
|
|
|
1756
|
|
|
1757 else
|
|
|
1758 Scan_Ptr := Scan_Ptr + 1;
|
|
|
1759 Token := Tok_Dot;
|
|
|
1760 return;
|
|
|
1761 end if;
|
|
|
1762
|
|
|
1763 -- Equal, which can either be an equality operator, or part of the
|
|
|
1764 -- arrow (=>) compound delimiter.
|
|
|
1765
|
|
|
1766 when '=' =>
|
|
|
1767 Accumulate_Checksum ('=');
|
|
|
1768
|
|
|
1769 if Double_Char_Token ('>') then
|
|
|
1770 Token := Tok_Arrow;
|
|
|
1771
|
|
|
1772 if Style_Check then
|
|
|
1773 Style.Check_Arrow (Inside_Depends);
|
|
|
1774 end if;
|
|
|
1775
|
|
|
1776 return;
|
|
|
1777
|
|
|
1778 elsif Source (Scan_Ptr + 1) = '=' then
|
|
|
1779 Error_Msg_S -- CODEFIX
|
|
|
1780 ("== should be =");
|
|
|
1781 Scan_Ptr := Scan_Ptr + 1;
|
|
|
1782 end if;
|
|
|
1783
|
|
|
1784 Scan_Ptr := Scan_Ptr + 1;
|
|
|
1785 Token := Tok_Equal;
|
|
|
1786 return;
|
|
|
1787
|
|
|
1788 -- Greater than, which can be a greater than operator, greater than
|
|
|
1789 -- or equal operator, or first character of a right label bracket.
|
|
|
1790
|
|
|
1791 when '>' =>
|
|
|
1792 Accumulate_Checksum ('>');
|
|
|
1793
|
|
|
1794 if Double_Char_Token ('=') then
|
|
|
1795 Token := Tok_Greater_Equal;
|
|
|
1796 return;
|
|
|
1797
|
|
|
1798 elsif Double_Char_Token ('>') then
|
|
|
1799 Token := Tok_Greater_Greater;
|
|
|
1800 return;
|
|
|
1801
|
|
|
1802 else
|
|
|
1803 Scan_Ptr := Scan_Ptr + 1;
|
|
|
1804 Token := Tok_Greater;
|
|
|
1805 return;
|
|
|
1806 end if;
|
|
|
1807
|
|
|
1808 -- Less than, which can be a less than operator, less than or equal
|
|
|
1809 -- operator, or the first character of a left label bracket, or the
|
|
|
1810 -- first character of a box (<>) compound delimiter.
|
|
|
1811
|
|
|
1812 when '<' =>
|
|
|
1813 Accumulate_Checksum ('<');
|
|
|
1814
|
|
|
1815 if Double_Char_Token ('=') then
|
|
|
1816 Token := Tok_Less_Equal;
|
|
|
1817 return;
|
|
|
1818
|
|
|
1819 elsif Double_Char_Token ('>') then
|
|
|
1820 Token := Tok_Box;
|
|
|
1821
|
|
|
1822 if Style_Check then
|
|
|
1823 Style.Check_Box;
|
|
|
1824 end if;
|
|
|
1825
|
|
|
1826 return;
|
|
|
1827
|
|
|
1828 elsif Double_Char_Token ('<') then
|
|
|
1829 Token := Tok_Less_Less;
|
|
|
1830 return;
|
|
|
1831
|
|
|
1832 else
|
|
|
1833 Scan_Ptr := Scan_Ptr + 1;
|
|
|
1834 Token := Tok_Less;
|
|
|
1835 return;
|
|
|
1836 end if;
|
|
|
1837
|
|
|
1838 -- Minus, which is either a subtraction operator, or the first
|
|
|
1839 -- character of double minus starting a comment
|
|
|
1840
|
|
|
1841 when '-' => Minus_Case : begin
|
|
|
1842 if Source (Scan_Ptr + 1) = '>' then
|
|
|
1843 Error_Msg_S ("invalid token");
|
|
|
1844 Scan_Ptr := Scan_Ptr + 2;
|
|
|
1845 Token := Tok_Arrow;
|
|
|
1846 return;
|
|
|
1847
|
|
|
1848 elsif Source (Scan_Ptr + 1) /= '-' then
|
|
|
1849 Accumulate_Checksum ('-');
|
|
|
1850 Scan_Ptr := Scan_Ptr + 1;
|
|
|
1851 Token := Tok_Minus;
|
|
|
1852 return;
|
|
|
1853
|
|
|
1854 -- Comment
|
|
|
1855
|
|
|
1856 else -- Source (Scan_Ptr + 1) = '-' then
|
|
|
1857 if Style_Check then
|
|
|
1858 Style.Check_Comment;
|
|
|
1859 end if;
|
|
|
1860
|
|
|
1861 Scan_Ptr := Scan_Ptr + 2;
|
|
|
1862
|
|
|
1863 -- If we are in preprocessor mode with Replace_In_Comments set,
|
|
|
1864 -- then we return the "--" as a token on its own.
|
|
|
1865
|
|
|
1866 if Replace_In_Comments then
|
|
|
1867 Token := Tok_Comment;
|
|
|
1868 return;
|
|
|
1869 end if;
|
|
|
1870
|
|
|
1871 -- Otherwise scan out the comment
|
|
|
1872
|
|
|
1873 Start_Of_Comment := Scan_Ptr;
|
|
|
1874
|
|
|
1875 -- Loop to scan comment (this loop runs more than once only if
|
|
|
1876 -- a horizontal tab or other non-graphic character is scanned)
|
|
|
1877
|
|
|
1878 loop
|
|
|
1879 -- Scan to non graphic character (opened up for speed)
|
|
|
1880
|
|
|
1881 -- Note that we just eat left brackets, which means that
|
|
|
1882 -- bracket notation cannot be used for end of line
|
|
|
1883 -- characters in comments. This seems a reasonable choice,
|
|
|
1884 -- since no one would ever use brackets notation in a real
|
|
|
1885 -- program in this situation, and if we allow brackets
|
|
|
1886 -- notation, we forbid some valid comments which contain a
|
|
|
1887 -- brackets sequence that happens to match an end of line
|
|
|
1888 -- character.
|
|
|
1889
|
|
|
1890 loop
|
|
|
1891 exit when Source (Scan_Ptr) not in Graphic_Character;
|
|
|
1892 Scan_Ptr := Scan_Ptr + 1;
|
|
|
1893 exit when Source (Scan_Ptr) not in Graphic_Character;
|
|
|
1894 Scan_Ptr := Scan_Ptr + 1;
|
|
|
1895 exit when Source (Scan_Ptr) not in Graphic_Character;
|
|
|
1896 Scan_Ptr := Scan_Ptr + 1;
|
|
|
1897 exit when Source (Scan_Ptr) not in Graphic_Character;
|
|
|
1898 Scan_Ptr := Scan_Ptr + 1;
|
|
|
1899 exit when Source (Scan_Ptr) not in Graphic_Character;
|
|
|
1900 Scan_Ptr := Scan_Ptr + 1;
|
|
|
1901 end loop;
|
|
|
1902
|
|
|
1903 -- Keep going if horizontal tab
|
|
|
1904
|
|
|
1905 if Source (Scan_Ptr) = HT then
|
|
|
1906 if Style_Check then
|
|
|
1907 Style.Check_HT;
|
|
|
1908 end if;
|
|
|
1909
|
|
|
1910 Scan_Ptr := Scan_Ptr + 1;
|
|
|
1911
|
|
|
1912 -- Terminate scan of comment if line terminator
|
|
|
1913
|
|
|
1914 elsif Source (Scan_Ptr) in Line_Terminator then
|
|
|
1915 exit;
|
|
|
1916
|
|
|
1917 -- Terminate scan of comment if end of file encountered
|
|
|
1918 -- (embedded EOF character or real last character in file)
|
|
|
1919
|
|
|
1920 elsif Source (Scan_Ptr) = EOF then
|
|
|
1921 exit;
|
|
|
1922
|
|
|
1923 -- If we have a wide character, we have to scan it out,
|
|
|
1924 -- because it might be a legitimate line terminator
|
|
|
1925
|
|
|
1926 elsif Start_Of_Wide_Character then
|
|
|
1927 declare
|
|
|
1928 Wptr : constant Source_Ptr := Scan_Ptr;
|
|
|
1929 Code : Char_Code;
|
|
|
1930 Err : Boolean;
|
|
|
1931
|
|
|
1932 begin
|
|
|
1933 Scan_Wide (Source, Scan_Ptr, Code, Err);
|
|
|
1934
|
|
|
1935 -- If not well formed wide character, then just skip
|
|
|
1936 -- past it and ignore it.
|
|
|
1937
|
|
|
1938 if Err then
|
|
|
1939 Scan_Ptr := Wptr + 1;
|
|
|
1940
|
|
|
1941 -- If UTF_32 terminator, terminate comment scan
|
|
|
1942
|
|
|
1943 elsif Is_UTF_32_Line_Terminator (UTF_32 (Code)) then
|
|
|
1944 Scan_Ptr := Wptr;
|
|
|
1945 exit;
|
|
|
1946 end if;
|
|
|
1947 end;
|
|
|
1948
|
|
|
1949 -- Keep going if character in 80-FF range, or is ESC. These
|
|
|
1950 -- characters are allowed in comments by RM-2.1(1), 2.7(2).
|
|
|
1951 -- They are allowed even in Ada 83 mode according to the
|
|
|
1952 -- approved AI. ESC was added to the AI in June 93.
|
|
|
1953
|
|
|
1954 elsif Source (Scan_Ptr) in Upper_Half_Character
|
|
|
1955 or else Source (Scan_Ptr) = ESC
|
|
|
1956 then
|
|
|
1957 Scan_Ptr := Scan_Ptr + 1;
|
|
|
1958
|
|
|
1959 -- Otherwise we have an illegal comment character, ignore
|
|
|
1960 -- this error in relaxed semantics mode.
|
|
|
1961
|
|
|
1962 else
|
|
|
1963 if Relaxed_RM_Semantics then
|
|
|
1964 Scan_Ptr := Scan_Ptr + 1;
|
|
|
1965 else
|
|
|
1966 Error_Illegal_Character;
|
|
|
1967 end if;
|
|
|
1968 end if;
|
|
|
1969 end loop;
|
|
|
1970
|
|
|
1971 -- Note that, except when comments are tokens, we do NOT
|
|
|
1972 -- execute a return here, instead we fall through to reexecute
|
|
|
1973 -- the scan loop to look for a token.
|
|
|
1974
|
|
|
1975 if Comment_Is_Token then
|
|
|
1976 Name_Len := Integer (Scan_Ptr - Start_Of_Comment);
|
|
|
1977 Name_Buffer (1 .. Name_Len) :=
|
|
|
1978 String (Source (Start_Of_Comment .. Scan_Ptr - 1));
|
|
|
1979 Comment_Id := Name_Find;
|
|
|
1980 Token := Tok_Comment;
|
|
|
1981 return;
|
|
|
1982 end if;
|
|
|
1983
|
|
|
1984 -- If the SPARK restriction is set for this unit, then generate
|
|
|
1985 -- a token Tok_SPARK_Hide for a SPARK HIDE directive.
|
|
|
1986
|
|
|
1987 if Restriction_Check_Required (SPARK_05)
|
|
|
1988 and then Source (Start_Of_Comment) = '#'
|
|
|
1989 then
|
|
|
1990 declare
|
|
|
1991 Scan_SPARK_Ptr : Source_Ptr;
|
|
|
1992
|
|
|
1993 begin
|
|
|
1994 Scan_SPARK_Ptr := Start_Of_Comment + 1;
|
|
|
1995
|
|
|
1996 -- Scan out blanks
|
|
|
1997
|
|
|
1998 while Source (Scan_SPARK_Ptr) = ' '
|
|
|
1999 or else Source (Scan_SPARK_Ptr) = HT
|
|
|
2000 loop
|
|
|
2001 Scan_SPARK_Ptr := Scan_SPARK_Ptr + 1;
|
|
|
2002 end loop;
|
|
|
2003
|
|
|
2004 -- Recognize HIDE directive. SPARK input cannot be
|
|
|
2005 -- encoded as wide characters, so only deal with
|
|
|
2006 -- lower/upper case.
|
|
|
2007
|
|
|
2008 if (Source (Scan_SPARK_Ptr) = 'h'
|
|
|
2009 or else Source (Scan_SPARK_Ptr) = 'H')
|
|
|
2010 and then (Source (Scan_SPARK_Ptr + 1) = 'i'
|
|
|
2011 or else Source (Scan_SPARK_Ptr + 1) = 'I')
|
|
|
2012 and then (Source (Scan_SPARK_Ptr + 2) = 'd'
|
|
|
2013 or else Source (Scan_SPARK_Ptr + 2) = 'D')
|
|
|
2014 and then (Source (Scan_SPARK_Ptr + 3) = 'e'
|
|
|
2015 or else Source (Scan_SPARK_Ptr + 3) = 'E')
|
|
|
2016 and then (Source (Scan_SPARK_Ptr + 4) = ' '
|
|
|
2017 or else Source (Scan_SPARK_Ptr + 4) = HT)
|
|
|
2018 then
|
|
|
2019 Token := Tok_SPARK_Hide;
|
|
|
2020 return;
|
|
|
2021 end if;
|
|
|
2022 end;
|
|
|
2023 end if;
|
|
|
2024 end if;
|
|
|
2025 end Minus_Case;
|
|
|
2026
|
|
|
2027 -- Double quote or percent starting a string literal
|
|
|
2028
|
|
|
2029 when '"' | '%' =>
|
|
|
2030 Slit;
|
|
|
2031 Post_Scan;
|
|
|
2032 return;
|
|
|
2033
|
|
|
2034 -- Apostrophe. This can either be the start of a character literal,
|
|
|
2035 -- or an isolated apostrophe used in a qualified expression or an
|
|
|
2036 -- attribute. In the following:
|
|
|
2037
|
|
|
2038 -- A := CHARACTER'('A');
|
|
|
2039
|
|
|
2040 -- the first apostrophe is treated as an isolated apostrophe, and the
|
|
|
2041 -- second one is treated as the start of the character literal 'A'.
|
|
|
2042 -- Note that RM-2.2(7) does not require a separator between "'" and
|
|
|
2043 -- "(" in the above, so we cannot use lookahead to distinguish the
|
|
|
2044 -- cases; we use look-back instead. Analysis of the grammar shows
|
|
|
2045 -- that some tokens can be followed by an apostrophe, and some by a
|
|
|
2046 -- character literal, but none by both. Some cannot be followed by
|
|
|
2047 -- either, so it doesn't matter what we do in those cases, except to
|
|
|
2048 -- get good error behavior.
|
|
|
2049
|
|
|
2050 when ''' => Char_Literal_Case : declare
|
|
|
2051 Code : Char_Code;
|
|
|
2052 Err : Boolean;
|
|
|
2053
|
|
|
2054 begin
|
|
|
2055 Accumulate_Checksum (''');
|
|
|
2056 Scan_Ptr := Scan_Ptr + 1;
|
|
|
2057
|
|
|
2058 -- Distinguish between apostrophe and character literal. It's an
|
|
|
2059 -- apostrophe if the previous token is one of the following.
|
|
|
2060 -- Reserved words are included for things like A.all'Address and
|
|
|
2061 -- T'Digits'Img. Strings literals are included for things like
|
|
|
2062 -- "abs"'Address. Other literals are included to give better error
|
|
|
2063 -- behavior for illegal cases like 123'Img.
|
|
|
2064 --
|
|
|
2065 -- In Ada 2020, a target name (i.e. @) is a valid prefix of an
|
|
|
2066 -- attribute, and functions like a name.
|
|
|
2067
|
|
|
2068 if Prev_Token = Tok_All
|
|
|
2069 or else Prev_Token = Tok_At_Sign
|
|
|
2070 or else Prev_Token = Tok_Delta
|
|
|
2071 or else Prev_Token = Tok_Digits
|
|
|
2072 or else Prev_Token = Tok_Identifier
|
|
|
2073 or else Prev_Token = Tok_Project
|
|
|
2074 or else Prev_Token = Tok_Right_Paren
|
|
145
|
2075 or else Prev_Token = Tok_Right_Bracket
|
|
111
|
2076 or else Prev_Token in Token_Class_Literal
|
|
|
2077 then
|
|
|
2078 Token := Tok_Apostrophe;
|
|
|
2079
|
|
|
2080 if Style_Check then
|
|
|
2081 Style.Check_Apostrophe;
|
|
|
2082 end if;
|
|
|
2083
|
|
|
2084 return;
|
|
|
2085
|
|
|
2086 -- Otherwise the apostrophe starts a character literal
|
|
|
2087
|
|
|
2088 else
|
|
|
2089 -- Case of wide character literal
|
|
|
2090
|
|
|
2091 if Start_Of_Wide_Character then
|
|
|
2092 Wptr := Scan_Ptr;
|
|
|
2093 Scan_Wide (Source, Scan_Ptr, Code, Err);
|
|
|
2094 Accumulate_Checksum (Code);
|
|
|
2095
|
|
|
2096 if Err then
|
|
|
2097 Error_Illegal_Wide_Character;
|
|
|
2098 Code := Character'Pos (' ');
|
|
|
2099
|
|
|
2100 -- In Ada 95 mode we allow any wide character in a character
|
|
|
2101 -- literal, but in Ada 2005, the set of characters allowed
|
|
|
2102 -- is restricted to graphic characters.
|
|
|
2103
|
|
|
2104 elsif Ada_Version >= Ada_2005
|
|
|
2105 and then Is_UTF_32_Non_Graphic (UTF_32 (Code))
|
|
|
2106 then
|
|
|
2107 Error_Msg -- CODEFIX????
|
|
|
2108 ("(Ada 2005) non-graphic character not permitted " &
|
|
|
2109 "in character literal", Wptr);
|
|
|
2110 end if;
|
|
|
2111
|
|
|
2112 if Source (Scan_Ptr) /= ''' then
|
|
|
2113 Error_Msg_S ("missing apostrophe");
|
|
|
2114 else
|
|
|
2115 Scan_Ptr := Scan_Ptr + 1;
|
|
|
2116 end if;
|
|
|
2117
|
|
|
2118 -- If we do not find a closing quote in the expected place then
|
|
|
2119 -- assume that we have a misguided attempt at a string literal.
|
|
|
2120
|
|
|
2121 -- However, if previous token is RANGE, then we return an
|
|
|
2122 -- apostrophe instead since this gives better error recovery
|
|
|
2123
|
|
|
2124 elsif Source (Scan_Ptr + 1) /= ''' then
|
|
|
2125 if Prev_Token = Tok_Range then
|
|
|
2126 Token := Tok_Apostrophe;
|
|
|
2127 return;
|
|
|
2128
|
|
|
2129 else
|
|
|
2130 Scan_Ptr := Scan_Ptr - 1;
|
|
|
2131 Error_Msg_S
|
|
|
2132 ("strings are delimited by double quote character");
|
|
|
2133 Slit;
|
|
|
2134 Post_Scan;
|
|
|
2135 return;
|
|
|
2136 end if;
|
|
|
2137
|
|
|
2138 -- Otherwise we have a (non-wide) character literal
|
|
|
2139
|
|
|
2140 else
|
|
|
2141 Accumulate_Checksum (Source (Scan_Ptr));
|
|
|
2142
|
|
|
2143 if Source (Scan_Ptr) not in Graphic_Character then
|
|
|
2144 if Source (Scan_Ptr) in Upper_Half_Character then
|
|
|
2145 if Ada_Version = Ada_83 then
|
|
|
2146 Error_Illegal_Character;
|
|
|
2147 end if;
|
|
|
2148
|
|
|
2149 else
|
|
|
2150 Error_Illegal_Character;
|
|
|
2151 end if;
|
|
|
2152 end if;
|
|
|
2153
|
|
|
2154 Code := Get_Char_Code (Source (Scan_Ptr));
|
|
|
2155 Scan_Ptr := Scan_Ptr + 2;
|
|
|
2156 end if;
|
|
|
2157
|
|
|
2158 -- Fall through here with Scan_Ptr updated past the closing
|
|
|
2159 -- quote, and Code set to the Char_Code value for the literal
|
|
|
2160
|
|
|
2161 Accumulate_Checksum (''');
|
|
|
2162 Token := Tok_Char_Literal;
|
|
|
2163 Set_Character_Literal_Name (Code);
|
|
|
2164 Token_Name := Name_Find;
|
|
|
2165 Character_Code := Code;
|
|
|
2166 Post_Scan;
|
|
|
2167 return;
|
|
|
2168 end if;
|
|
|
2169 end Char_Literal_Case;
|
|
|
2170
|
|
|
2171 -- Right parenthesis
|
|
|
2172
|
|
|
2173 when ')' =>
|
|
|
2174 Accumulate_Checksum (')');
|
|
|
2175 Scan_Ptr := Scan_Ptr + 1;
|
|
|
2176 Token := Tok_Right_Paren;
|
|
|
2177
|
|
|
2178 if Style_Check then
|
|
|
2179 Style.Check_Right_Paren;
|
|
|
2180 end if;
|
|
|
2181
|
|
|
2182 return;
|
|
|
2183
|
|
|
2184 -- Right bracket or right brace, treated as right paren
|
|
145
|
2185 -- but proper aggregate delimiter in Ada_2020
|
|
111
|
2186
|
|
|
2187 when ']' | '}' =>
|
|
145
|
2188 if Ada_Version >= Ada_2020 then
|
|
|
2189 Token := Tok_Right_Bracket;
|
|
|
2190
|
|
|
2191 else
|
|
|
2192 Error_Msg_S ("illegal character, replaced by "")""");
|
|
|
2193 Token := Tok_Right_Paren;
|
|
|
2194 end if;
|
|
|
2195
|
|
111
|
2196 Scan_Ptr := Scan_Ptr + 1;
|
|
|
2197 return;
|
|
|
2198
|
|
|
2199 -- Slash (can be division operator or first character of not equal)
|
|
|
2200
|
|
|
2201 when '/' =>
|
|
|
2202 Accumulate_Checksum ('/');
|
|
|
2203
|
|
|
2204 if Double_Char_Token ('=') then
|
|
|
2205 Token := Tok_Not_Equal;
|
|
|
2206 return;
|
|
|
2207 else
|
|
|
2208 Scan_Ptr := Scan_Ptr + 1;
|
|
|
2209 Token := Tok_Slash;
|
|
|
2210 return;
|
|
|
2211 end if;
|
|
|
2212
|
|
|
2213 -- Semicolon
|
|
|
2214
|
|
|
2215 when ';' =>
|
|
|
2216 Accumulate_Checksum (';');
|
|
|
2217 Scan_Ptr := Scan_Ptr + 1;
|
|
|
2218 Token := Tok_Semicolon;
|
|
|
2219
|
|
|
2220 if Style_Check then
|
|
|
2221 Style.Check_Semicolon;
|
|
|
2222 end if;
|
|
|
2223
|
|
|
2224 return;
|
|
|
2225
|
|
|
2226 -- Vertical bar
|
|
|
2227
|
|
|
2228 when '|' => Vertical_Bar_Case : begin
|
|
|
2229 Accumulate_Checksum ('|');
|
|
|
2230
|
|
|
2231 -- Special check for || to give nice message
|
|
|
2232
|
|
|
2233 if Source (Scan_Ptr + 1) = '|' then
|
|
|
2234 Error_Msg_S -- CODEFIX
|
|
|
2235 ("""'|'|"" should be `OR ELSE`");
|
|
|
2236 Scan_Ptr := Scan_Ptr + 2;
|
|
|
2237 Token := Tok_Or;
|
|
|
2238 return;
|
|
|
2239
|
|
|
2240 else
|
|
|
2241 Scan_Ptr := Scan_Ptr + 1;
|
|
|
2242 Token := Tok_Vertical_Bar;
|
|
|
2243
|
|
|
2244 if Style_Check then
|
|
|
2245 Style.Check_Vertical_Bar;
|
|
|
2246 end if;
|
|
|
2247
|
|
|
2248 Post_Scan;
|
|
|
2249 return;
|
|
|
2250 end if;
|
|
|
2251 end Vertical_Bar_Case;
|
|
|
2252
|
|
|
2253 -- Exclamation, replacement character for vertical bar
|
|
|
2254
|
|
|
2255 when '!' => Exclamation_Case : begin
|
|
|
2256 Accumulate_Checksum ('!');
|
|
|
2257
|
|
|
2258 if Source (Scan_Ptr + 1) = '=' then
|
|
|
2259 Error_Msg_S -- CODEFIX
|
|
|
2260 ("'!= should be /=");
|
|
|
2261 Scan_Ptr := Scan_Ptr + 2;
|
|
|
2262 Token := Tok_Not_Equal;
|
|
|
2263 return;
|
|
|
2264
|
|
|
2265 else
|
|
|
2266 Scan_Ptr := Scan_Ptr + 1;
|
|
|
2267 Token := Tok_Vertical_Bar;
|
|
|
2268 Post_Scan;
|
|
|
2269 return;
|
|
|
2270 end if;
|
|
|
2271 end Exclamation_Case;
|
|
|
2272
|
|
|
2273 -- Plus
|
|
|
2274
|
|
|
2275 when '+' => Plus_Case : begin
|
|
|
2276 Accumulate_Checksum ('+');
|
|
|
2277 Scan_Ptr := Scan_Ptr + 1;
|
|
|
2278 Token := Tok_Plus;
|
|
|
2279 return;
|
|
|
2280 end Plus_Case;
|
|
|
2281
|
|
|
2282 -- Digits starting a numeric literal
|
|
|
2283
|
|
|
2284 when '0' .. '9' =>
|
|
|
2285
|
|
|
2286 -- First a bit of a scan ahead to see if we have a case of an
|
|
|
2287 -- identifier starting with a digit (remembering exponent case).
|
|
|
2288
|
|
|
2289 declare
|
|
|
2290 C : constant Character := Source (Scan_Ptr + 1);
|
|
|
2291
|
|
|
2292 begin
|
|
|
2293 -- OK literal if digit followed by digit or underscore
|
|
|
2294
|
|
|
2295 if C in '0' .. '9' or else C = '_' then
|
|
|
2296 null;
|
|
|
2297
|
|
|
2298 -- OK literal if digit not followed by identifier char
|
|
|
2299
|
|
|
2300 elsif not Identifier_Char (C) then
|
|
|
2301 null;
|
|
|
2302
|
|
|
2303 -- OK literal if digit followed by e/E followed by digit/sign.
|
|
|
2304 -- We also allow underscore after the E, which is an error, but
|
|
|
2305 -- better handled by Nlit than deciding this is an identifier.
|
|
|
2306
|
|
|
2307 elsif (C = 'e' or else C = 'E')
|
|
|
2308 and then (Source (Scan_Ptr + 2) in '0' .. '9'
|
|
|
2309 or else Source (Scan_Ptr + 2) = '+'
|
|
|
2310 or else Source (Scan_Ptr + 2) = '-'
|
|
|
2311 or else Source (Scan_Ptr + 2) = '_')
|
|
|
2312 then
|
|
|
2313 null;
|
|
|
2314
|
|
|
2315 -- Here we have what really looks like an identifier that
|
|
|
2316 -- starts with a digit, so give error msg.
|
|
|
2317
|
|
|
2318 else
|
|
|
2319 Error_Msg_S ("identifier may not start with digit");
|
|
|
2320 Name_Len := 1;
|
|
|
2321 Underline_Found := False;
|
|
|
2322 Name_Buffer (1) := Source (Scan_Ptr);
|
|
|
2323 Accumulate_Checksum (Name_Buffer (1));
|
|
|
2324 Scan_Ptr := Scan_Ptr + 1;
|
|
|
2325 goto Scan_Identifier;
|
|
|
2326 end if;
|
|
|
2327 end;
|
|
|
2328
|
|
|
2329 -- Here we have an OK integer literal
|
|
|
2330
|
|
|
2331 Nlit;
|
|
|
2332
|
|
|
2333 -- Check for proper delimiter, ignoring other format characters
|
|
|
2334
|
|
|
2335 Skip_Other_Format_Characters;
|
|
|
2336
|
|
|
2337 if Identifier_Char (Source (Scan_Ptr)) then
|
|
|
2338 Error_Msg_S
|
|
|
2339 ("delimiter required between literal and identifier");
|
|
|
2340 end if;
|
|
|
2341
|
|
|
2342 Post_Scan;
|
|
|
2343 return;
|
|
|
2344
|
|
|
2345 -- Lower case letters
|
|
|
2346
|
|
|
2347 when 'a' .. 'z' =>
|
|
|
2348 Name_Len := 1;
|
|
|
2349 Underline_Found := False;
|
|
|
2350 Name_Buffer (1) := Source (Scan_Ptr);
|
|
|
2351 Accumulate_Checksum (Name_Buffer (1));
|
|
|
2352 Scan_Ptr := Scan_Ptr + 1;
|
|
|
2353 goto Scan_Identifier;
|
|
|
2354
|
|
|
2355 -- Upper case letters
|
|
|
2356
|
|
|
2357 when 'A' .. 'Z' =>
|
|
|
2358 Name_Len := 1;
|
|
|
2359 Underline_Found := False;
|
|
|
2360 Name_Buffer (1) :=
|
|
|
2361 Character'Val (Character'Pos (Source (Scan_Ptr)) + 32);
|
|
|
2362 Accumulate_Checksum (Name_Buffer (1));
|
|
|
2363 Scan_Ptr := Scan_Ptr + 1;
|
|
|
2364 goto Scan_Identifier;
|
|
|
2365
|
|
|
2366 -- Underline character
|
|
|
2367
|
|
|
2368 when '_' =>
|
|
|
2369 if Special_Characters ('_') then
|
|
|
2370 Token_Ptr := Scan_Ptr;
|
|
|
2371 Scan_Ptr := Scan_Ptr + 1;
|
|
|
2372 Token := Tok_Special;
|
|
|
2373 Special_Character := '_';
|
|
|
2374 return;
|
|
|
2375 end if;
|
|
|
2376
|
|
|
2377 Error_Msg_S ("identifier cannot start with underline");
|
|
|
2378 Name_Len := 1;
|
|
|
2379 Name_Buffer (1) := '_';
|
|
|
2380 Scan_Ptr := Scan_Ptr + 1;
|
|
|
2381 Underline_Found := False;
|
|
|
2382 goto Scan_Identifier;
|
|
|
2383
|
|
|
2384 -- Space (not possible, because we scanned past blanks)
|
|
|
2385
|
|
|
2386 when ' ' =>
|
|
|
2387 raise Program_Error;
|
|
|
2388
|
|
|
2389 -- Characters in top half of ASCII 8-bit chart
|
|
|
2390
|
|
|
2391 when Upper_Half_Character =>
|
|
|
2392
|
|
|
2393 -- Wide character case
|
|
|
2394
|
|
|
2395 if Upper_Half_Encoding then
|
|
|
2396 goto Scan_Wide_Character;
|
|
|
2397
|
|
|
2398 -- Otherwise we have OK Latin-1 character
|
|
|
2399
|
|
|
2400 else
|
|
|
2401 -- Upper half characters may possibly be identifier letters
|
|
|
2402 -- but can never be digits, so Identifier_Char can be used to
|
|
|
2403 -- test for a valid start of identifier character.
|
|
|
2404
|
|
|
2405 if Identifier_Char (Source (Scan_Ptr)) then
|
|
|
2406 Name_Len := 0;
|
|
|
2407 Underline_Found := False;
|
|
|
2408 goto Scan_Identifier;
|
|
|
2409 else
|
|
|
2410 Error_Illegal_Character;
|
|
|
2411 end if;
|
|
|
2412 end if;
|
|
|
2413
|
|
|
2414 when ESC =>
|
|
|
2415
|
|
|
2416 -- ESC character, possible start of identifier if wide characters
|
|
|
2417 -- using ESC encoding are allowed in identifiers, which we can
|
|
|
2418 -- tell by looking at the Identifier_Char flag for ESC, which is
|
|
|
2419 -- only true if these conditions are met. In Ada 2005 mode, may
|
|
|
2420 -- also be valid UTF_32 space or line terminator character.
|
|
|
2421
|
|
|
2422 if Identifier_Char (ESC) then
|
|
|
2423 Name_Len := 0;
|
|
|
2424 goto Scan_Wide_Character;
|
|
|
2425 else
|
|
|
2426 Error_Illegal_Character;
|
|
|
2427 end if;
|
|
|
2428
|
|
|
2429 -- Invalid control characters
|
|
|
2430
|
|
|
2431 when ACK
|
|
|
2432 | ASCII.SO
|
|
|
2433 | BEL
|
|
|
2434 | BS
|
|
|
2435 | CAN
|
|
|
2436 | DC1
|
|
|
2437 | DC2
|
|
|
2438 | DC3
|
|
|
2439 | DC4
|
|
|
2440 | DEL
|
|
|
2441 | DLE
|
|
|
2442 | EM
|
|
|
2443 | ENQ
|
|
|
2444 | EOT
|
|
|
2445 | ETB
|
|
|
2446 | ETX
|
|
|
2447 | FS
|
|
|
2448 | GS
|
|
|
2449 | NAK
|
|
|
2450 | NUL
|
|
|
2451 | RS
|
|
|
2452 | SI
|
|
|
2453 | SOH
|
|
|
2454 | STX
|
|
|
2455 | SYN
|
|
|
2456 | US
|
|
|
2457 =>
|
|
|
2458 Error_Illegal_Character;
|
|
|
2459
|
|
|
2460 -- Invalid graphic characters
|
|
|
2461 -- Note that '@' is handled elsewhere, because following AI12-125
|
|
|
2462 -- it denotes the target_name of an assignment.
|
|
|
2463
|
|
|
2464 when '#' | '$' | '?' | '`' | '\' | '^' | '~' =>
|
|
|
2465
|
|
|
2466 -- If Set_Special_Character has been called for this character,
|
|
|
2467 -- set Scans.Special_Character and return a Special token.
|
|
|
2468
|
|
|
2469 if Special_Characters (Source (Scan_Ptr)) then
|
|
|
2470 Token_Ptr := Scan_Ptr;
|
|
|
2471 Token := Tok_Special;
|
|
|
2472 Special_Character := Source (Scan_Ptr);
|
|
|
2473 Scan_Ptr := Scan_Ptr + 1;
|
|
|
2474 return;
|
|
|
2475
|
|
|
2476 -- Check for something looking like a preprocessor directive
|
|
|
2477
|
|
|
2478 elsif Source (Scan_Ptr) = '#'
|
|
|
2479 and then (Source (Scan_Ptr + 1 .. Scan_Ptr + 2) = "if"
|
|
|
2480 or else
|
|
|
2481 Source (Scan_Ptr + 1 .. Scan_Ptr + 5) = "elsif"
|
|
|
2482 or else
|
|
|
2483 Source (Scan_Ptr + 1 .. Scan_Ptr + 4) = "else"
|
|
|
2484 or else
|
|
|
2485 Source (Scan_Ptr + 1 .. Scan_Ptr + 3) = "end")
|
|
|
2486 then
|
|
|
2487 Error_Msg_S
|
|
|
2488 ("preprocessor directive ignored, preprocessor not active");
|
|
|
2489
|
|
|
2490 -- Skip to end of line
|
|
|
2491
|
|
|
2492 loop
|
|
|
2493 if Source (Scan_Ptr) in Graphic_Character
|
|
|
2494 or else
|
|
|
2495 Source (Scan_Ptr) = HT
|
|
|
2496 then
|
|
|
2497 Scan_Ptr := Scan_Ptr + 1;
|
|
|
2498
|
|
|
2499 -- Done if line terminator or EOF
|
|
|
2500
|
|
|
2501 elsif Source (Scan_Ptr) in Line_Terminator
|
|
|
2502 or else
|
|
|
2503 Source (Scan_Ptr) = EOF
|
|
|
2504 then
|
|
|
2505 exit;
|
|
|
2506
|
|
|
2507 -- If we have a wide character, we have to scan it out,
|
|
|
2508 -- because it might be a legitimate line terminator
|
|
|
2509
|
|
|
2510 elsif Start_Of_Wide_Character then
|
|
|
2511 declare
|
|
|
2512 Wptr : constant Source_Ptr := Scan_Ptr;
|
|
|
2513 Code : Char_Code;
|
|
|
2514 Err : Boolean;
|
|
|
2515
|
|
|
2516 begin
|
|
|
2517 Scan_Wide (Source, Scan_Ptr, Code, Err);
|
|
|
2518
|
|
|
2519 -- If not well formed wide character, then just skip
|
|
|
2520 -- past it and ignore it.
|
|
|
2521
|
|
|
2522 if Err then
|
|
|
2523 Scan_Ptr := Wptr + 1;
|
|
|
2524
|
|
|
2525 -- If UTF_32 terminator, terminate comment scan
|
|
|
2526
|
|
|
2527 elsif Is_UTF_32_Line_Terminator (UTF_32 (Code)) then
|
|
|
2528 Scan_Ptr := Wptr;
|
|
|
2529 exit;
|
|
|
2530 end if;
|
|
|
2531 end;
|
|
|
2532
|
|
|
2533 -- Else keep going (don't worry about bad comment chars
|
|
|
2534 -- in this context, we just want to find the end of line.
|
|
|
2535
|
|
|
2536 else
|
|
|
2537 Scan_Ptr := Scan_Ptr + 1;
|
|
|
2538 end if;
|
|
|
2539 end loop;
|
|
|
2540
|
|
|
2541 -- Otherwise, this is an illegal character
|
|
|
2542
|
|
|
2543 else
|
|
|
2544 Error_Illegal_Character;
|
|
|
2545 end if;
|
|
|
2546
|
|
|
2547 -- End switch on non-blank character
|
|
|
2548
|
|
|
2549 end case;
|
|
|
2550
|
|
|
2551 -- End loop past format effectors. The exit from this loop is by
|
|
|
2552 -- executing a return statement following completion of token scan
|
|
|
2553 -- (control never falls out of this loop to the code that follows).
|
|
|
2554
|
|
|
2555 end loop;
|
|
|
2556
|
|
|
2557 pragma Assert (False);
|
|
|
2558
|
|
|
2559 -- Wide_Character scanning routine. On entry we have encountered the
|
|
|
2560 -- initial character of a wide character sequence.
|
|
|
2561
|
|
|
2562 <<Scan_Wide_Character>>
|
|
|
2563 declare
|
|
|
2564 Code : Char_Code;
|
|
|
2565 Cat : Category;
|
|
|
2566 Err : Boolean;
|
|
|
2567
|
|
|
2568 begin
|
|
|
2569 Wptr := Scan_Ptr;
|
|
|
2570 Scan_Wide (Source, Scan_Ptr, Code, Err);
|
|
|
2571
|
|
|
2572 -- If bad wide character, signal error and continue scan
|
|
|
2573
|
|
|
2574 if Err then
|
|
|
2575 Error_Illegal_Wide_Character;
|
|
|
2576 goto Scan_Next_Character;
|
|
|
2577 end if;
|
|
|
2578
|
|
|
2579 Cat := Get_Category (UTF_32 (Code));
|
|
|
2580
|
|
|
2581 -- If OK letter, reset scan ptr and go scan identifier
|
|
|
2582
|
|
|
2583 if Is_UTF_32_Letter (Cat) then
|
|
|
2584 Scan_Ptr := Wptr;
|
|
|
2585 Name_Len := 0;
|
|
|
2586 Underline_Found := False;
|
|
|
2587 goto Scan_Identifier;
|
|
|
2588
|
|
|
2589 -- If OK wide space, ignore and keep scanning (we do not include
|
|
|
2590 -- any ignored spaces in checksum)
|
|
|
2591
|
|
|
2592 elsif Is_UTF_32_Space (Cat) then
|
|
|
2593 goto Scan_Next_Character;
|
|
|
2594
|
|
|
2595 -- If other format character, ignore and keep scanning (again we
|
|
|
2596 -- do not include in the checksum) (this is for AI-0079).
|
|
|
2597
|
|
|
2598 elsif Is_UTF_32_Other (Cat) then
|
|
|
2599 goto Scan_Next_Character;
|
|
|
2600
|
|
|
2601 -- If OK wide line terminator, terminate current line
|
|
|
2602
|
|
|
2603 elsif Is_UTF_32_Line_Terminator (UTF_32 (Code)) then
|
|
|
2604 Scan_Ptr := Wptr;
|
|
|
2605 goto Scan_Line_Terminator;
|
|
|
2606
|
|
|
2607 -- Punctuation is an error (at start of identifier)
|
|
|
2608
|
|
|
2609 elsif Is_UTF_32_Punctuation (Cat) then
|
|
|
2610 Error_Msg ("identifier cannot start with punctuation", Wptr);
|
|
|
2611 Scan_Ptr := Wptr;
|
|
|
2612 Name_Len := 0;
|
|
|
2613 Underline_Found := False;
|
|
|
2614 goto Scan_Identifier;
|
|
|
2615
|
|
|
2616 -- Mark character is an error (at start of identifier)
|
|
|
2617
|
|
|
2618 elsif Is_UTF_32_Mark (Cat) then
|
|
|
2619 Error_Msg ("identifier cannot start with mark character", Wptr);
|
|
|
2620 Scan_Ptr := Wptr;
|
|
|
2621 Name_Len := 0;
|
|
|
2622 Underline_Found := False;
|
|
|
2623 goto Scan_Identifier;
|
|
|
2624
|
|
|
2625 -- Extended digit character is an error. Could be bad start of
|
|
|
2626 -- identifier or bad literal. Not worth doing too much to try to
|
|
|
2627 -- distinguish these cases, but we will do a little bit.
|
|
|
2628
|
|
|
2629 elsif Is_UTF_32_Digit (Cat) then
|
|
|
2630 Error_Msg
|
|
|
2631 ("identifier cannot start with digit character", Wptr);
|
|
|
2632 Scan_Ptr := Wptr;
|
|
|
2633 Name_Len := 0;
|
|
|
2634 Underline_Found := False;
|
|
|
2635 goto Scan_Identifier;
|
|
|
2636
|
|
|
2637 -- All other wide characters are illegal here
|
|
|
2638
|
|
|
2639 else
|
|
|
2640 Error_Illegal_Wide_Character;
|
|
|
2641 goto Scan_Next_Character;
|
|
|
2642 end if;
|
|
|
2643 end;
|
|
|
2644
|
|
|
2645 -- Routine to scan line terminator. On entry Scan_Ptr points to a
|
|
|
2646 -- character which is one of FF,LR,CR,VT, or one of the wide characters
|
|
|
2647 -- that is treated as a line terminator.
|
|
|
2648
|
|
|
2649 <<Scan_Line_Terminator>>
|
|
|
2650
|
|
|
2651 -- Check line too long
|
|
|
2652
|
|
|
2653 Check_End_Of_Line;
|
|
|
2654
|
|
|
2655 -- Set Token_Ptr, if End_Of_Line is a token, for the case when it is
|
|
|
2656 -- a physical line.
|
|
|
2657
|
|
|
2658 if End_Of_Line_Is_Token then
|
|
|
2659 Token_Ptr := Scan_Ptr;
|
|
|
2660 end if;
|
|
|
2661
|
|
|
2662 declare
|
|
|
2663 Physical : Boolean;
|
|
|
2664
|
|
|
2665 begin
|
|
|
2666 Skip_Line_Terminators (Scan_Ptr, Physical);
|
|
|
2667
|
|
|
2668 -- If we are at start of physical line, update scan pointers to
|
|
|
2669 -- reflect the start of the new line.
|
|
|
2670
|
|
|
2671 if Physical then
|
|
|
2672 Current_Line_Start := Scan_Ptr;
|
|
|
2673 Start_Column := Set_Start_Column;
|
|
|
2674 First_Non_Blank_Location := Scan_Ptr;
|
|
|
2675
|
|
|
2676 -- If End_Of_Line is a token, we return it as it is a
|
|
|
2677 -- physical line.
|
|
|
2678
|
|
|
2679 if End_Of_Line_Is_Token then
|
|
|
2680 Token := Tok_End_Of_Line;
|
|
|
2681 return;
|
|
|
2682 end if;
|
|
|
2683 end if;
|
|
|
2684 end;
|
|
|
2685
|
|
|
2686 goto Scan_Next_Character;
|
|
|
2687
|
|
|
2688 -- Identifier scanning routine. On entry, some initial characters of
|
|
|
2689 -- the identifier may have already been stored in Name_Buffer. If so,
|
|
|
2690 -- Name_Len has the number of characters stored, otherwise Name_Len is
|
|
|
2691 -- set to zero on entry. Underline_Found is also set False on entry.
|
|
|
2692
|
|
|
2693 <<Scan_Identifier>>
|
|
|
2694
|
|
|
2695 -- This loop scans as fast as possible past lower half letters and
|
|
|
2696 -- digits, which we expect to be the most common characters.
|
|
|
2697
|
|
|
2698 loop
|
|
|
2699 if Source (Scan_Ptr) in 'a' .. 'z'
|
|
|
2700 or else Source (Scan_Ptr) in '0' .. '9'
|
|
|
2701 then
|
|
|
2702 Name_Buffer (Name_Len + 1) := Source (Scan_Ptr);
|
|
|
2703 Accumulate_Checksum (Source (Scan_Ptr));
|
|
|
2704
|
|
|
2705 elsif Source (Scan_Ptr) in 'A' .. 'Z' then
|
|
|
2706 Name_Buffer (Name_Len + 1) :=
|
|
|
2707 Character'Val (Character'Pos (Source (Scan_Ptr)) + 32);
|
|
|
2708 Accumulate_Checksum (Name_Buffer (Name_Len + 1));
|
|
|
2709
|
|
|
2710 else
|
|
|
2711 exit;
|
|
|
2712 end if;
|
|
|
2713
|
|
|
2714 Underline_Found := False;
|
|
|
2715 Scan_Ptr := Scan_Ptr + 1;
|
|
|
2716 Name_Len := Name_Len + 1;
|
|
|
2717 end loop;
|
|
|
2718
|
|
|
2719 -- If we fall through, then we have encountered either an underline
|
|
|
2720 -- character, or an extended identifier character (i.e. one from the
|
|
|
2721 -- upper half), or a wide character, or an identifier terminator. The
|
|
|
2722 -- initial test speeds us up in the most common case where we have
|
|
|
2723 -- an identifier terminator. Note that ESC is an identifier character
|
|
|
2724 -- only if a wide character encoding method that uses ESC encoding
|
|
|
2725 -- is active, so if we find an ESC character we know that we have a
|
|
|
2726 -- wide character.
|
|
|
2727
|
|
|
2728 if Identifier_Char (Source (Scan_Ptr))
|
|
|
2729 or else (Source (Scan_Ptr) in Upper_Half_Character
|
|
|
2730 and then Upper_Half_Encoding)
|
|
|
2731 then
|
|
|
2732 -- Case of underline
|
|
|
2733
|
|
|
2734 if Source (Scan_Ptr) = '_' then
|
|
|
2735 Accumulate_Checksum ('_');
|
|
|
2736
|
|
|
2737 if Underline_Found then
|
|
|
2738 Error_No_Double_Underline;
|
|
|
2739 else
|
|
|
2740 Underline_Found := True;
|
|
|
2741 Name_Len := Name_Len + 1;
|
|
|
2742 Name_Buffer (Name_Len) := '_';
|
|
|
2743 end if;
|
|
|
2744
|
|
|
2745 Scan_Ptr := Scan_Ptr + 1;
|
|
|
2746 goto Scan_Identifier;
|
|
|
2747
|
|
|
2748 -- Upper half character
|
|
|
2749
|
|
|
2750 elsif Source (Scan_Ptr) in Upper_Half_Character
|
|
|
2751 and then not Upper_Half_Encoding
|
|
|
2752 then
|
|
|
2753 Accumulate_Checksum (Source (Scan_Ptr));
|
|
|
2754 Store_Encoded_Character
|
|
|
2755 (Get_Char_Code (Fold_Lower (Source (Scan_Ptr))));
|
|
|
2756 Scan_Ptr := Scan_Ptr + 1;
|
|
|
2757 Underline_Found := False;
|
|
|
2758 goto Scan_Identifier;
|
|
|
2759
|
|
|
2760 -- Left bracket not followed by a quote terminates an identifier.
|
|
|
2761 -- This is an error, but we don't want to give a junk error msg
|
|
|
2762 -- about wide characters in this case.
|
|
|
2763
|
|
|
2764 elsif Source (Scan_Ptr) = '['
|
|
|
2765 and then Source (Scan_Ptr + 1) /= '"'
|
|
|
2766 then
|
|
|
2767 null;
|
|
|
2768
|
|
|
2769 -- We know we have a wide character encoding here (the current
|
|
|
2770 -- character is either ESC, left bracket, or an upper half
|
|
|
2771 -- character depending on the encoding method).
|
|
|
2772
|
|
|
2773 else
|
|
|
2774 -- Scan out the wide character and insert the appropriate
|
|
|
2775 -- encoding into the name table entry for the identifier.
|
|
|
2776
|
|
|
2777 declare
|
|
|
2778 Code : Char_Code;
|
|
|
2779 Err : Boolean;
|
|
|
2780 Chr : Character;
|
|
|
2781 Cat : Category;
|
|
|
2782
|
|
|
2783 begin
|
|
|
2784 Wptr := Scan_Ptr;
|
|
|
2785 Scan_Wide (Source, Scan_Ptr, Code, Err);
|
|
|
2786
|
|
|
2787 -- If error, signal error
|
|
|
2788
|
|
|
2789 if Err then
|
|
|
2790 Error_Illegal_Wide_Character;
|
|
|
2791
|
|
|
2792 -- If the character scanned is a normal identifier
|
|
|
2793 -- character, then we treat it that way.
|
|
|
2794
|
|
|
2795 elsif In_Character_Range (Code)
|
|
|
2796 and then Identifier_Char (Get_Character (Code))
|
|
|
2797 then
|
|
|
2798 Chr := Get_Character (Code);
|
|
|
2799 Accumulate_Checksum (Chr);
|
|
|
2800 Store_Encoded_Character
|
|
|
2801 (Get_Char_Code (Fold_Lower (Chr)));
|
|
|
2802 Underline_Found := False;
|
|
|
2803
|
|
|
2804 -- Here if not a normal identifier character
|
|
|
2805
|
|
|
2806 else
|
|
|
2807 Cat := Get_Category (UTF_32 (Code));
|
|
|
2808
|
|
|
2809 -- Wide character in Unicode category "Other, Format"
|
|
|
2810 -- is not accepted in an identifier. This is because it
|
|
|
2811 -- it is considered a security risk (AI-0091).
|
|
|
2812
|
|
|
2813 -- However, it is OK for such a character to appear at
|
|
|
2814 -- the end of an identifier.
|
|
|
2815
|
|
|
2816 if Is_UTF_32_Other (Cat) then
|
|
|
2817 if not Identifier_Char (Source (Scan_Ptr)) then
|
|
|
2818 goto Scan_Identifier_Complete;
|
|
|
2819 else
|
|
|
2820 Error_Msg
|
|
|
2821 ("identifier cannot contain other_format "
|
|
|
2822 & "character", Wptr);
|
|
|
2823 goto Scan_Identifier;
|
|
|
2824 end if;
|
|
|
2825
|
|
|
2826 -- Wide character in category Separator,Space terminates
|
|
|
2827
|
|
|
2828 elsif Is_UTF_32_Space (Cat) then
|
|
|
2829 goto Scan_Identifier_Complete;
|
|
|
2830 end if;
|
|
|
2831
|
|
|
2832 -- Here if wide character is part of the identifier
|
|
|
2833
|
|
|
2834 -- Make sure we are allowing wide characters in
|
|
|
2835 -- identifiers. Note that we allow wide character
|
|
|
2836 -- notation for an OK identifier character. This in
|
|
|
2837 -- particular allows bracket or other notation to be
|
|
|
2838 -- used for upper half letters.
|
|
|
2839
|
|
|
2840 -- Wide characters are always allowed in Ada 2005
|
|
|
2841
|
|
|
2842 if Identifier_Character_Set /= 'w'
|
|
|
2843 and then Ada_Version < Ada_2005
|
|
|
2844 then
|
|
|
2845 Error_Msg
|
|
|
2846 ("wide character not allowed in identifier", Wptr);
|
|
|
2847 end if;
|
|
|
2848
|
|
|
2849 -- If OK letter, store it folding to upper case. Note
|
|
|
2850 -- that we include the folded letter in the checksum.
|
|
|
2851
|
|
|
2852 if Is_UTF_32_Letter (Cat) then
|
|
|
2853 Code :=
|
|
|
2854 Char_Code (UTF_32_To_Upper_Case (UTF_32 (Code)));
|
|
|
2855 Accumulate_Checksum (Code);
|
|
|
2856 Store_Encoded_Character (Code);
|
|
|
2857 Underline_Found := False;
|
|
|
2858
|
|
|
2859 -- If OK extended digit or mark, then store it
|
|
|
2860
|
|
|
2861 elsif Is_UTF_32_Digit (Cat)
|
|
|
2862 or else Is_UTF_32_Mark (Cat)
|
|
|
2863 then
|
|
|
2864 Accumulate_Checksum (Code);
|
|
|
2865 Store_Encoded_Character (Code);
|
|
|
2866 Underline_Found := False;
|
|
|
2867
|
|
|
2868 -- Wide punctuation is also stored, but counts as an
|
|
|
2869 -- underline character for error checking purposes.
|
|
|
2870
|
|
|
2871 elsif Is_UTF_32_Punctuation (Cat) then
|
|
|
2872 Accumulate_Checksum (Code);
|
|
|
2873
|
|
|
2874 if Underline_Found then
|
|
|
2875 declare
|
|
|
2876 Cend : constant Source_Ptr := Scan_Ptr;
|
|
|
2877 begin
|
|
|
2878 Scan_Ptr := Wptr;
|
|
|
2879 Error_No_Double_Underline;
|
|
|
2880 Scan_Ptr := Cend;
|
|
|
2881 end;
|
|
|
2882
|
|
|
2883 else
|
|
|
2884 Store_Encoded_Character (Code);
|
|
|
2885 Underline_Found := True;
|
|
|
2886 end if;
|
|
|
2887
|
|
|
2888 -- Any other wide character is not acceptable
|
|
|
2889
|
|
|
2890 else
|
|
|
2891 Error_Msg
|
|
|
2892 ("invalid wide character in identifier", Wptr);
|
|
|
2893 end if;
|
|
|
2894 end if;
|
|
|
2895
|
|
|
2896 goto Scan_Identifier;
|
|
|
2897 end;
|
|
|
2898 end if;
|
|
|
2899 end if;
|
|
|
2900
|
|
|
2901 -- Scan of identifier is complete. The identifier is stored in
|
|
|
2902 -- Name_Buffer, and Scan_Ptr points past the last character.
|
|
|
2903
|
|
|
2904 <<Scan_Identifier_Complete>>
|
|
|
2905 Token_Name := Name_Find;
|
|
|
2906
|
|
|
2907 -- Check for identifier ending with underline or punctuation char
|
|
|
2908
|
|
|
2909 if Underline_Found then
|
|
|
2910 Underline_Found := False;
|
|
|
2911
|
|
|
2912 if Source (Scan_Ptr - 1) = '_' then
|
|
|
2913 Error_Msg
|
|
|
2914 ("identifier cannot end with underline", Scan_Ptr - 1);
|
|
|
2915 else
|
|
|
2916 Error_Msg
|
|
|
2917 ("identifier cannot end with punctuation character", Wptr);
|
|
|
2918 end if;
|
|
|
2919 end if;
|
|
|
2920
|
|
|
2921 -- We will assume it is an identifier, not a keyword, so that the
|
|
|
2922 -- checksum is independent of the Ada version.
|
|
|
2923
|
|
|
2924 Token := Tok_Identifier;
|
|
|
2925
|
|
|
2926 -- Here is where we check if it was a keyword
|
|
|
2927
|
|
|
2928 if Is_Keyword_Name (Token_Name) then
|
|
|
2929 if Opt.Checksum_GNAT_6_3 then
|
|
|
2930 Token := Token_Type'Val (Get_Name_Table_Byte (Token_Name));
|
|
|
2931
|
|
|
2932 if Checksum_Accumulate_Token_Checksum then
|
|
|
2933 if Checksum_GNAT_5_03 then
|
|
|
2934 Accumulate_Token_Checksum_GNAT_5_03;
|
|
|
2935 else
|
|
|
2936 Accumulate_Token_Checksum_GNAT_6_3;
|
|
|
2937 end if;
|
|
|
2938 end if;
|
|
|
2939
|
|
|
2940 else
|
|
|
2941 Accumulate_Token_Checksum;
|
|
|
2942 Token := Token_Type'Val (Get_Name_Table_Byte (Token_Name));
|
|
|
2943 end if;
|
|
|
2944
|
|
|
2945 -- Keyword style checks
|
|
|
2946
|
|
|
2947 if Style_Check then
|
|
|
2948
|
|
|
2949 -- Deal with possible style check for non-lower case keyword,
|
|
|
2950 -- but we don't treat ACCESS, DELTA, DIGITS, RANGE as keywords
|
|
|
2951 -- for this purpose if they appear as attribute designators.
|
|
|
2952 -- Actually we only check the first character for speed.
|
|
|
2953
|
|
|
2954 -- Ada 2005 (AI-284): Do not apply the style check in case of
|
|
|
2955 -- "pragma Interface"
|
|
|
2956
|
|
|
2957 -- Ada 2005 (AI-340): Do not apply the style check in case of
|
|
|
2958 -- MOD attribute.
|
|
|
2959
|
|
|
2960 if Source (Token_Ptr) <= 'Z'
|
|
|
2961 and then (Prev_Token /= Tok_Apostrophe
|
|
|
2962 or else
|
|
|
2963 (Token /= Tok_Access and then
|
|
|
2964 Token /= Tok_Delta and then
|
|
|
2965 Token /= Tok_Digits and then
|
|
|
2966 Token /= Tok_Mod and then
|
|
|
2967 Token /= Tok_Range))
|
|
|
2968 and then (Token /= Tok_Interface
|
|
|
2969 or else
|
|
|
2970 (Token = Tok_Interface
|
|
|
2971 and then Prev_Token /= Tok_Pragma))
|
|
|
2972 then
|
|
|
2973 Style.Non_Lower_Case_Keyword;
|
|
|
2974 end if;
|
|
|
2975
|
|
|
2976 -- Check THEN/ELSE style rules. These do not apply to AND THEN
|
|
|
2977 -- or OR ELSE, and do not apply in if expressions.
|
|
|
2978
|
|
|
2979 if (Token = Tok_Then and then Prev_Token /= Tok_And)
|
|
|
2980 or else
|
|
|
2981 (Token = Tok_Else and then Prev_Token /= Tok_Or)
|
|
|
2982 then
|
|
|
2983 if Inside_If_Expression = 0 then
|
|
|
2984 Style.Check_Separate_Stmt_Lines;
|
|
|
2985 end if;
|
|
|
2986 end if;
|
|
|
2987 end if;
|
|
|
2988
|
|
|
2989 -- We must reset Token_Name since this is not an identifier and
|
|
|
2990 -- if we leave Token_Name set, the parser gets confused because
|
|
|
2991 -- it thinks it is dealing with an identifier instead of the
|
|
|
2992 -- corresponding keyword.
|
|
|
2993
|
|
|
2994 Token_Name := No_Name;
|
|
|
2995 return;
|
|
|
2996
|
|
|
2997 -- It is an identifier after all
|
|
|
2998
|
|
|
2999 else
|
|
|
3000 if Checksum_Accumulate_Token_Checksum then
|
|
|
3001 Accumulate_Token_Checksum;
|
|
|
3002 end if;
|
|
|
3003
|
|
|
3004 Post_Scan;
|
|
|
3005 return;
|
|
|
3006 end if;
|
|
|
3007 end Scan;
|
|
|
3008
|
|
|
3009 --------------------------
|
|
|
3010 -- Set_Comment_As_Token --
|
|
|
3011 --------------------------
|
|
|
3012
|
|
|
3013 procedure Set_Comment_As_Token (Value : Boolean) is
|
|
|
3014 begin
|
|
|
3015 Comment_Is_Token := Value;
|
|
|
3016 end Set_Comment_As_Token;
|
|
|
3017
|
|
|
3018 ------------------------------
|
|
|
3019 -- Set_End_Of_Line_As_Token --
|
|
|
3020 ------------------------------
|
|
|
3021
|
|
|
3022 procedure Set_End_Of_Line_As_Token (Value : Boolean) is
|
|
|
3023 begin
|
|
|
3024 End_Of_Line_Is_Token := Value;
|
|
|
3025 end Set_End_Of_Line_As_Token;
|
|
|
3026
|
|
|
3027 ---------------------------
|
|
|
3028 -- Set_Special_Character --
|
|
|
3029 ---------------------------
|
|
|
3030
|
|
|
3031 procedure Set_Special_Character (C : Character) is
|
|
|
3032 begin
|
|
|
3033 case C is
|
|
|
3034 when '#' | '$' | '_' | '?' | '@' | '`' | '\' | '^' | '~' =>
|
|
|
3035 Special_Characters (C) := True;
|
|
|
3036
|
|
|
3037 when others =>
|
|
|
3038 null;
|
|
|
3039 end case;
|
|
|
3040 end Set_Special_Character;
|
|
|
3041
|
|
|
3042 ----------------------
|
|
|
3043 -- Set_Start_Column --
|
|
|
3044 ----------------------
|
|
|
3045
|
|
|
3046 -- Note: it seems at first glance a little expensive to compute this value
|
|
|
3047 -- for every source line (since it is certainly not used for all source
|
|
|
3048 -- lines). On the other hand, it doesn't take much more work to skip past
|
|
|
3049 -- the initial white space on the line counting the columns than it would
|
|
|
3050 -- to scan past the white space using the standard scanning circuits.
|
|
|
3051
|
|
|
3052 function Set_Start_Column return Column_Number is
|
|
|
3053 Start_Column : Column_Number := 0;
|
|
|
3054
|
|
|
3055 begin
|
|
|
3056 -- Outer loop scans past horizontal tab characters
|
|
|
3057
|
|
|
3058 Tabs_Loop : loop
|
|
|
3059
|
|
|
3060 -- Inner loop scans past blanks as fast as possible, bumping Scan_Ptr
|
|
|
3061 -- past the blanks and adjusting Start_Column to account for them.
|
|
|
3062
|
|
|
3063 Blanks_Loop : loop
|
|
|
3064 if Source (Scan_Ptr) = ' ' then
|
|
|
3065 if Source (Scan_Ptr + 1) = ' ' then
|
|
|
3066 if Source (Scan_Ptr + 2) = ' ' then
|
|
|
3067 if Source (Scan_Ptr + 3) = ' ' then
|
|
|
3068 if Source (Scan_Ptr + 4) = ' ' then
|
|
|
3069 if Source (Scan_Ptr + 5) = ' ' then
|
|
|
3070 if Source (Scan_Ptr + 6) = ' ' then
|
|
|
3071 Scan_Ptr := Scan_Ptr + 7;
|
|
|
3072 Start_Column := Start_Column + 7;
|
|
|
3073 else
|
|
|
3074 Scan_Ptr := Scan_Ptr + 6;
|
|
|
3075 Start_Column := Start_Column + 6;
|
|
|
3076 exit Blanks_Loop;
|
|
|
3077 end if;
|
|
|
3078 else
|
|
|
3079 Scan_Ptr := Scan_Ptr + 5;
|
|
|
3080 Start_Column := Start_Column + 5;
|
|
|
3081 exit Blanks_Loop;
|
|
|
3082 end if;
|
|
|
3083 else
|
|
|
3084 Scan_Ptr := Scan_Ptr + 4;
|
|
|
3085 Start_Column := Start_Column + 4;
|
|
|
3086 exit Blanks_Loop;
|
|
|
3087 end if;
|
|
|
3088 else
|
|
|
3089 Scan_Ptr := Scan_Ptr + 3;
|
|
|
3090 Start_Column := Start_Column + 3;
|
|
|
3091 exit Blanks_Loop;
|
|
|
3092 end if;
|
|
|
3093 else
|
|
|
3094 Scan_Ptr := Scan_Ptr + 2;
|
|
|
3095 Start_Column := Start_Column + 2;
|
|
|
3096 exit Blanks_Loop;
|
|
|
3097 end if;
|
|
|
3098 else
|
|
|
3099 Scan_Ptr := Scan_Ptr + 1;
|
|
|
3100 Start_Column := Start_Column + 1;
|
|
|
3101 exit Blanks_Loop;
|
|
|
3102 end if;
|
|
|
3103 else
|
|
|
3104 exit Blanks_Loop;
|
|
|
3105 end if;
|
|
|
3106 end loop Blanks_Loop;
|
|
|
3107
|
|
|
3108 -- Outer loop keeps going only if a horizontal tab follows
|
|
|
3109
|
|
|
3110 if Source (Scan_Ptr) = HT then
|
|
|
3111 if Style_Check then
|
|
|
3112 Style.Check_HT;
|
|
|
3113 end if;
|
|
|
3114
|
|
|
3115 Scan_Ptr := Scan_Ptr + 1;
|
|
|
3116 Start_Column := (Start_Column / 8) * 8 + 8;
|
|
|
3117 else
|
|
|
3118 exit Tabs_Loop;
|
|
|
3119 end if;
|
|
|
3120 end loop Tabs_Loop;
|
|
|
3121
|
|
|
3122 return Start_Column;
|
|
|
3123
|
|
|
3124 -- A constraint error can happen only if we have a compiler with checks on
|
|
|
3125 -- and a line with a ludicrous number of tabs or spaces at the start. In
|
|
|
3126 -- such a case, we really don't care if Start_Column is right or not.
|
|
|
3127
|
|
|
3128 exception
|
|
|
3129 when Constraint_Error =>
|
|
|
3130 return Start_Column;
|
|
|
3131 end Set_Start_Column;
|
|
|
3132
|
|
|
3133 end Scng;
|
