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