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