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