1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2024, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Csets
; use Csets
;
28 with Errout
; use Errout
;
29 with Hostparm
; use Hostparm
;
31 with Namet
; use Namet
;
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
;
41 pragma Warnings
(Off
);
42 -- This package is used also by gnatcoll
43 with System
.Case_Util
;
45 with System
.UTF_32
; use System
.UTF_32
;
46 with System
.WCh_Con
; use System
.WCh_Con
;
52 -- Make control characters visible
54 Special_Characters
: array (Character) of Boolean := (others => False);
55 -- For characters that are Special token, the value is True
57 End_Of_Line_Is_Token
: Boolean := False;
58 -- True if End_Of_Line is a token
60 -----------------------
61 -- Local Subprograms --
62 -----------------------
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.
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.
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.
88 procedure Initialize_Checksum
;
89 pragma Inline
(Initialize_Checksum
);
90 -- Initialize checksum value
92 -------------------------
93 -- Accumulate_Checksum --
94 -------------------------
96 procedure Accumulate_Checksum
(C
: Character) is
98 System
.CRC32
.Update
(System
.CRC32
.CRC32
(Checksum
), C
);
99 end Accumulate_Checksum
;
101 procedure Accumulate_Checksum
(C
: Char_Code
) is
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));
108 Accumulate_Checksum
(Character'Val (C
/ 256));
111 Accumulate_Checksum
(Character'Val (C
mod 256));
112 end Accumulate_Checksum
;
114 -------------------------------
115 -- Accumulate_Token_Checksum --
116 -------------------------------
118 procedure Accumulate_Token_Checksum
is
121 (System
.CRC32
.CRC32
(Checksum
),
122 Character'Val (Token_Type
'Pos (Token
)));
123 end Accumulate_Token_Checksum
;
125 -----------------------
126 -- Check_End_Of_Line --
127 -----------------------
129 procedure Check_End_Of_Line
is
130 Len
: constant Int
:=
131 Int
(Scan_Ptr
- Current_Line_Start
) - Wide_Char_Byte_Count
;
135 Style
.Check_Line_Terminator
(Len
);
138 -- Deal with checking maximum line length
140 if Style_Check
and Style_Check_Max_Line_Length
then
141 Style
.Check_Line_Max_Length
(Len
);
143 -- If style checking is inactive, check maximum line length against
146 elsif Len
> Max_Line_Length
then
148 ("this line is too long",
149 Current_Line_Start
+ Source_Ptr
(Max_Line_Length
));
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.
170 Ptr
:= Current_Line_Start
;
172 exit when Ptr
= Scan_Ptr
;
174 if Source
(Ptr
) = ASCII
.HT
then
175 Col
:= (Col
- 1 + 8) / 8 * 8 + 1;
182 ("this line is longer than 32766 characters",
184 raise Unrecoverable_Error
;
192 -- Reset wide character byte count for next line
194 Wide_Char_Byte_Count
:= 0;
195 end Check_End_Of_Line
;
197 ----------------------------
198 -- Determine_Token_Casing --
199 ----------------------------
201 function Determine_Token_Casing
return Casing_Type
is
203 return Determine_Casing
(Source
(Token_Ptr
.. Scan_Ptr
- 1));
204 end Determine_Token_Casing
;
206 -------------------------
207 -- Initialize_Checksum --
208 -------------------------
210 procedure Initialize_Checksum
is
212 System
.CRC32
.Initialize
(System
.CRC32
.CRC32
(Checksum
));
213 end Initialize_Checksum
;
215 ------------------------
216 -- Initialize_Scanner --
217 ------------------------
219 procedure Initialize_Scanner
(Index
: Source_File_Index
) is
221 -- Establish reserved words
223 Scans
.Initialize_Ada_Keywords
;
225 -- Initialize scan control variables
227 Current_Source_File
:= Index
;
228 Source
:= Source_Text
(Current_Source_File
);
229 Scan_Ptr
:= Source_First
(Current_Source_File
);
231 Token_Ptr
:= Scan_Ptr
;
232 Current_Line_Start
:= Scan_Ptr
;
234 Token_Name
:= No_Name
;
235 Start_Column
:= Set_Start_Column
;
236 First_Non_Blank_Location
:= Scan_Ptr
;
239 Wide_Char_Byte_Count
:= 0;
241 -- Do not call Scan, otherwise the License stuff does not work in Scn
243 end Initialize_Scanner
;
245 ------------------------------
246 -- Reset_Special_Characters --
247 ------------------------------
249 procedure Reset_Special_Characters
is
251 Special_Characters
:= (others => False);
252 end Reset_Special_Characters
;
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.
269 -- Used to remember start of last wide character scanned
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-&).
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.
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.
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.
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.
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.
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).
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.
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:
320 -- @article{boucher_trojansource_2021,
321 -- title = {Trojan {Source}: {Invisible} {Vulnerabilities}},
322 -- author = {Nicholas Boucher and Ross Anderson},
324 -- journal = {Preprint},
325 -- eprint = {2111.00169},
326 -- archivePrefix = {arXiv},
327 -- primaryClass = {cs.CR},
328 -- url = {https://arxiv.org/abs/2111.00169}
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
:=
347 -- Above are the bidirectional characters, along with their Unicode code
350 procedure Check_Bidi
(Code
: Char_Code
) is
352 for Bidi_Code
of Bidi_Character_Codes
loop
353 if Code
= Bidi_Code
then
354 Error_Msg
("??bidirectional wide character", Wptr
);
359 -----------------------
360 -- Double_Char_Token --
361 -----------------------
363 function Double_Char_Token
(C
: Character) return Boolean is
365 if Source
(Scan_Ptr
+ 1) = C
then
366 Accumulate_Checksum
(C
);
367 Scan_Ptr
:= Scan_Ptr
+ 2;
370 elsif Source
(Scan_Ptr
+ 1) = ' '
371 and then Source
(Scan_Ptr
+ 2) = C
373 Scan_Ptr
:= Scan_Ptr
+ 1;
374 Error_Msg_S
-- CODEFIX
375 ("no space allowed here");
376 Scan_Ptr
:= Scan_Ptr
+ 2;
382 end Double_Char_Token
;
384 -----------------------------
385 -- Error_Illegal_Character --
386 -----------------------------
388 procedure Error_Illegal_Character
is
390 Error_Msg_S
("illegal character");
391 Scan_Ptr
:= Scan_Ptr
+ 1;
392 end Error_Illegal_Character
;
394 ----------------------------------
395 -- Error_Illegal_Wide_Character --
396 ----------------------------------
398 procedure Error_Illegal_Wide_Character
is
400 Scan_Ptr
:= Scan_Ptr
+ 1;
401 Error_Msg
("illegal wide character", Wptr
);
402 end Error_Illegal_Wide_Character
;
404 -------------------------------
405 -- Error_No_Double_Underline --
406 -------------------------------
408 procedure Error_No_Double_Underline
is
410 Underline_Found
:= False;
412 -- There are four cases, and we special case the messages
414 if Source
(Scan_Ptr
) = '_' then
415 if Source
(Scan_Ptr
- 1) = '_' then
416 Error_Msg_S
-- CODEFIX
417 ("two consecutive underlines not permitted");
419 Error_Msg_S
("underline cannot follow punctuation character");
423 if Source
(Scan_Ptr
- 1) = '_' then
424 Error_Msg_S
("punctuation character cannot follow underline");
427 ("two consecutive punctuation characters not permitted");
430 end Error_No_Double_Underline
;
439 -- Current source program character
441 Base_Char
: Character;
442 -- Either # or : (character at start of based number)
448 -- Value of base in Uint format
451 -- Value of integer scanned by Scan_Integer in Uint format
454 -- Value of integer in numeric value being scanned
457 -- Scale value for real literal
460 -- Scale in Uint format
462 Exponent_Is_Negative
: Boolean;
463 -- Set true for negative exponent
465 Extended_Digit_Value
: Int
;
466 -- Extended digit value
468 Point_Scanned
: Boolean;
469 -- Flag for decimal point scanned in numeric literal
471 -----------------------
472 -- Local Subprograms --
473 -----------------------
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.
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.
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.
487 --------------------------
488 -- Error_Digit_Expected --
489 --------------------------
491 procedure Error_Digit_Expected
is
493 Error_Msg_S
("digit expected");
494 end Error_Digit_Expected
;
500 procedure Scan_Integer
is
502 -- Next character scanned
505 C
:= Source
(Scan_Ptr
);
507 -- Loop through digits (allowing underlines)
510 Accumulate_Checksum
(C
);
512 UI_Int_Value
* 10 + (Character'Pos (C
) - Character'Pos ('0'));
513 Scan_Ptr
:= Scan_Ptr
+ 1;
515 C
:= Source
(Scan_Ptr
);
517 -- Case of underline encountered
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).
526 Scan_Ptr
:= Scan_Ptr
+ 1;
527 C
:= Source
(Scan_Ptr
);
529 Error_No_Double_Underline
;
532 if C
not in '0' .. '9' then
533 Error_Digit_Expected
;
538 exit when C
not in '0' .. '9';
543 -- Start of processing for Nlit
548 UI_Int_Value
:= Uint_0
;
549 Based_Literal_Uses_Colon
:= False;
552 Point_Scanned
:= False;
553 UI_Num_Value
:= UI_Int_Value
;
555 -- Various possibilities now for continuing the literal are period,
556 -- E/e (for exponent), or :/# (for based literal).
559 C
:= Source
(Scan_Ptr
);
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.
566 while C
= '.' and then Source
(Scan_Ptr
+ 1) /= '.' loop
567 Accumulate_Checksum
('.');
569 if Point_Scanned
then
570 Error_Msg_S
("duplicate point ignored");
573 Point_Scanned
:= True;
574 Scan_Ptr
:= Scan_Ptr
+ 1;
575 C
:= Source
(Scan_Ptr
);
577 if C
not in '0' .. '9' then
579 ("real literal cannot end with point", Scan_Ptr
- 1);
582 UI_Num_Value
:= UI_Int_Value
;
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;"
593 or else (C
= ':' and then
594 (Source
(Scan_Ptr
+ 1) = '.'
596 Source
(Scan_Ptr
+ 1) in '0' .. '9'
598 Source
(Scan_Ptr
+ 1) in 'A' .. 'Z'
600 Source
(Scan_Ptr
+ 1) in 'a' .. 'z'))
602 Accumulate_Checksum
(C
);
604 UI_Base
:= UI_Int_Value
;
606 if Base_Char
= ':' then
607 Based_Literal_Uses_Colon
:= True;
610 if UI_Base
< 2 or else UI_Base
> 16 then
611 Error_Msg_SC
("base not 2-16");
615 Base
:= UI_To_Int
(UI_Base
);
616 Scan_Ptr
:= Scan_Ptr
+ 1;
618 -- Scan out extended integer [. integer]
620 C
:= Source
(Scan_Ptr
);
621 UI_Int_Value
:= Uint_0
;
625 if C
in '0' .. '9' then
626 Accumulate_Checksum
(C
);
627 Extended_Digit_Value
:=
628 Int
'(Character'Pos (C)) - Int'(Character'Pos ('0'));
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;
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;
641 Error_Msg_S
("extended digit expected");
645 if Extended_Digit_Value
>= Base
then
646 Error_Msg_S
("digit '>= base");
649 UI_Int_Value
:= UI_Int_Value
* UI_Base
+ Extended_Digit_Value
;
651 Scan_Ptr
:= Scan_Ptr
+ 1;
652 C
:= Source
(Scan_Ptr
);
656 Accumulate_Checksum
('_');
657 Scan_Ptr
:= Scan_Ptr
+ 1;
658 C
:= Source
(Scan_Ptr
);
660 Error_No_Double_Underline
;
664 Accumulate_Checksum
('.');
666 if Point_Scanned
then
667 Error_Msg_S
("duplicate point ignored");
670 Scan_Ptr
:= Scan_Ptr
+ 1;
671 C
:= Source
(Scan_Ptr
);
672 Point_Scanned
:= True;
675 elsif C
= Base_Char
then
676 Accumulate_Checksum
(C
);
677 Scan_Ptr
:= Scan_Ptr
+ 1;
680 elsif C
= '#' or else C
= ':' then
681 Error_Msg_S
("based number delimiters must match");
682 Scan_Ptr
:= Scan_Ptr
+ 1;
685 elsif not Identifier_Char
(C
) then
686 if Base_Char
= '#' then
687 Error_Msg_S
-- CODEFIX
690 Error_Msg_S
-- CODEFIX
699 UI_Num_Value
:= UI_Int_Value
;
704 if not Point_Scanned
then
708 UI_Scale
:= UI_From_Int
(Scale
);
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;
716 if Source
(Scan_Ptr
) = '+' then
717 Accumulate_Checksum
('+');
718 Scan_Ptr
:= Scan_Ptr
+ 1;
720 elsif Source
(Scan_Ptr
) = '-' then
721 Accumulate_Checksum
('-');
723 if not Point_Scanned
then
725 ("negative exponent not allowed for integer literal");
727 Exponent_Is_Negative
:= True;
730 Scan_Ptr
:= Scan_Ptr
+ 1;
733 UI_Int_Value
:= Uint_0
;
735 if Source
(Scan_Ptr
) in '0' .. '9' then
738 Error_Digit_Expected
;
741 if Exponent_Is_Negative
then
742 UI_Scale
:= UI_Scale
- UI_Int_Value
;
744 UI_Scale
:= UI_Scale
+ UI_Int_Value
;
748 -- Case of real literal to be returned
750 if Point_Scanned
then
751 Token
:= Tok_Real_Literal
;
752 Real_Literal_Value
:=
758 -- Case of integer literal to be returned
761 Token
:= Tok_Integer_Literal
;
764 Int_Literal_Value
:= UI_Num_Value
;
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.
771 elsif UI_Scale
>= 800_000
then
772 Error_Msg_SC
("exponent too large");
773 Int_Literal_Value
:= No_Uint
;
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.
779 elsif Operating_Mode
/= Check_Syntax
780 and then (Serious_Errors_Detected
= 0 or else Try_Semantics
)
782 Int_Literal_Value
:= UI_Num_Value
* UI_Base
** UI_Scale
;
785 Int_Literal_Value
:= No_Uint
;
789 Accumulate_Token_Checksum
;
798 Delimiter
: Character;
799 -- Delimiter (first character of string)
802 -- Current source program character
805 -- Current character code value
808 -- Error flag for Scan_Wide call
810 String_Start
: Source_Ptr
;
811 -- Point to first character of string
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.
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
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.
833 ---------------------------
834 -- Error_Bad_String_Char --
835 ---------------------------
837 procedure Error_Bad_String_Char
is
838 C
: constant Character := Source
(Scan_Ptr
);
842 Error_Msg_S
("horizontal tab not allowed in string");
844 elsif C
= VT
or else C
= FF
then
845 Error_Msg_S
("format effector not allowed in string");
847 elsif C
in Upper_Half_Character
then
848 Error_Msg_S
("(Ada 83) upper half character not allowed");
851 Error_Msg_S
("control character not allowed in string");
853 end Error_Bad_String_Char
;
855 -------------------------------
856 -- Error_Unterminated_String --
857 -------------------------------
859 procedure Error_Unterminated_String
is
863 -- An interesting little refinement. Consider the following
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);
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.
878 -- Two more cases that we treat specially are:
880 -- A := "this string uses the wrong terminator'
881 -- A := "this string uses the wrong terminator' &
883 -- In these cases we give a different error message as well
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.
889 while Source
(Scan_Ptr
- 1) = ' '
890 or else Source
(Scan_Ptr
- 1) = '&'
892 Scan_Ptr
:= Scan_Ptr
- 1;
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).
901 and then Source
(Scan_Ptr
- 1) = '''
905 ("incorrect string terminator character", Scan_Ptr
- 1);
909 -- Backup over semicolon or right-paren/semicolon sequence
911 if Source
(Scan_Ptr
- 1) = ';' then
912 Scan_Ptr
:= Scan_Ptr
- 1;
915 if Source
(Scan_Ptr
- 1) = ')' then
916 Scan_Ptr
:= Scan_Ptr
- 1;
921 -- See if there is a comma in the string, if so, guess that
922 -- the first comma terminates the string.
925 while S
< Scan_Ptr
loop
926 if Source
(S
) = ',' then
927 while Scan_Ptr
> S
loop
928 Scan_Ptr
:= Scan_Ptr
- 1;
938 -- Now we have adjusted the scan pointer, give message
940 Error_Msg_S
-- CODEFIX
941 ("missing string quote");
942 end Error_Unterminated_String
;
948 procedure Set_String
is
949 Slen
: constant Int
:= Int
(Scan_Ptr
- Token_Ptr
- 2);
955 -- Skip processing operator symbols if we are scanning an
956 -- interpolated string literal.
958 if Inside_Interpolated_String_Literal
959 and then not Inside_Interpolated_String_Expression
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.
969 C1
:= Source
(Token_Ptr
+ 1);
973 Token_Name
:= Name_Op_Eq
;
976 Token_Name
:= Name_Op_Gt
;
979 Token_Name
:= Name_Op_Lt
;
982 Token_Name
:= Name_Op_Add
;
985 Token_Name
:= Name_Op_Subtract
;
988 Token_Name
:= Name_Op_Concat
;
991 Token_Name
:= Name_Op_Multiply
;
994 Token_Name
:= Name_Op_Divide
;
1001 C1
:= Source
(Token_Ptr
+ 1);
1002 C2
:= Source
(Token_Ptr
+ 2);
1004 if C1
= '*' and then C2
= '*' then
1005 Token_Name
:= Name_Op_Expon
;
1010 Token_Name
:= Name_Op_Ne
;
1012 Token_Name
:= Name_Op_Le
;
1014 Token_Name
:= Name_Op_Ge
;
1017 elsif (C1
= 'O' or else C1
= 'o') and then -- OR
1018 (C2
= 'R' or else C2
= 'r')
1020 Token_Name
:= Name_Op_Or
;
1024 C1
:= Source
(Token_Ptr
+ 1);
1025 C2
:= Source
(Token_Ptr
+ 2);
1026 C3
:= Source
(Token_Ptr
+ 3);
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')
1032 Token_Name
:= Name_Op_And
;
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')
1038 Token_Name
:= Name_Op_Abs
;
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')
1044 Token_Name
:= Name_Op_Mod
;
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')
1050 Token_Name
:= Name_Op_Not
;
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')
1056 Token_Name
:= Name_Op_Rem
;
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')
1062 Token_Name
:= Name_Op_Xor
;
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
1071 if Token_Name
= Error_Name
then
1072 Token
:= Tok_String_Literal
;
1075 Token
:= Tok_Operator_Symbol
;
1079 -- Start of processing for Slit
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
1087 String_Start
:= Scan_Ptr
;
1089 -- Continuation of interpolated string literal
1091 if Inside_Interpolated_String_Literal
1092 and then Prev_Token
= Tok_Right_Curly_Bracket
1094 Scan_Ptr
:= Scan_Ptr
- 1;
1100 Delimiter
:= Source
(Scan_Ptr
);
1101 Accumulate_Checksum
(Delimiter
);
1105 Wide_Character_Found
:= False;
1106 Wide_Wide_Character_Found
:= False;
1107 Scan_Ptr
:= Scan_Ptr
+ 1;
1109 -- Loop to scan out characters of string literal
1112 C
:= Source
(Scan_Ptr
);
1114 if C
= Delimiter
then
1115 Accumulate_Checksum
(C
);
1116 Scan_Ptr
:= Scan_Ptr
+ 1;
1117 exit when Source
(Scan_Ptr
) /= Delimiter
;
1119 -- Unlike normal string literals, doubled delimiter has no
1120 -- special significance in interpolated string literals.
1122 if Inside_Interpolated_String_Literal
then
1124 ("double quotations not allowed in interpolated string");
1127 Code
:= Get_Char_Code
(C
);
1128 Accumulate_Checksum
(C
);
1129 Scan_Ptr
:= Scan_Ptr
+ 1;
1132 if C
= '"' and then Delimiter
= '%' then
1134 ("quote not allowed in percent delimited string");
1135 Code
:= Get_Char_Code
(C
);
1136 Scan_Ptr
:= Scan_Ptr
+ 1;
1138 -- Found interpolated expression
1140 elsif Inside_Interpolated_String_Literal
1143 Accumulate_Checksum
(C
);
1146 -- Escaped character in interpolated string literal
1148 elsif Inside_Interpolated_String_Literal
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;
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
);
1169 Code
:= Get_Char_Code
('?');
1170 Error_Msg_S
("illegal escaped character");
1173 elsif Start_Of_Wide_Character
then
1175 Scan_Wide
(Source
, Scan_Ptr
, Code
, Err
);
1178 Error_Illegal_Wide_Character
;
1179 Code
:= Get_Char_Code
(' ');
1184 Accumulate_Checksum
(Code
);
1186 -- In Ada 95 mode we allow any wide characters in a string
1187 -- but in Ada 2005, the set of characters allowed has been
1188 -- restricted to graphic characters.
1190 if Ada_Version
>= Ada_2005
1191 and then Is_UTF_32_Non_Graphic
(UTF_32
(Code
))
1194 ("(Ada 2005) non-graphic character not permitted " &
1195 "in string literal", Wptr
);
1199 Accumulate_Checksum
(C
);
1201 if C
not in Graphic_Character
then
1202 if C
in Line_Terminator
then
1203 Error_Unterminated_String
;
1206 elsif C
in Upper_Half_Character
then
1207 if Ada_Version
= Ada_83
then
1208 Error_Bad_String_Char
;
1212 Error_Bad_String_Char
;
1216 Code
:= Get_Char_Code
(C
);
1217 Scan_Ptr
:= Scan_Ptr
+ 1;
1221 Store_String_Char
(Code
);
1223 if not In_Character_Range
(Code
) then
1224 if In_Wide_Character_Range
(Code
) then
1225 Wide_Character_Found
:= True;
1227 Wide_Wide_Character_Found
:= True;
1232 String_Literal_Id
:= End_String
;
1237 ----------------------------------
1238 -- Skip_Other_Format_Characters --
1239 ----------------------------------
1241 procedure Skip_Other_Format_Characters
is
1247 while Start_Of_Wide_Character
loop
1249 Scan_Wide
(Source
, Scan_Ptr
, Code
, Err
);
1251 if not Is_UTF_32_Other
(UTF_32
(Code
)) then
1256 end Skip_Other_Format_Characters
;
1258 -----------------------------
1259 -- Start_Of_Wide_Character --
1260 -----------------------------
1262 function Start_Of_Wide_Character
return Boolean is
1263 C
: constant Character := Source
(Scan_Ptr
);
1266 -- ESC encoding method with ESC present
1269 and then Wide_Character_Encoding_Method
in WC_ESC_Encoding_Method
1273 -- Upper half character with upper half encoding
1275 elsif C
in Upper_Half_Character
and then Upper_Half_Encoding
then
1278 -- Brackets encoding
1281 and then Source
(Scan_Ptr
+ 1) = '"'
1282 and then Identifier_Char
(Source
(Scan_Ptr
+ 2))
1286 -- Not the start of a wide character
1291 end Start_Of_Wide_Character
;
1293 Token_Contains_Uppercase
: Boolean;
1295 -- Start of processing for Scan
1298 Prev_Token
:= Token
;
1299 Prev_Token_Ptr
:= Token_Ptr
;
1300 Token_Name
:= Error_Name
;
1302 if Inside_Interpolated_String_Literal
1303 and then Prev_Token
= Tok_Right_Curly_Bracket
1305 -- Consecutive interpolated expressions
1307 if Source
(Scan_Ptr
) = '{' then
1310 -- Ending delimiter placed immediately after interpolated expression
1312 elsif Source
(Scan_Ptr
) = '"' then
1313 Scan_Ptr
:= Scan_Ptr
+ 1;
1314 Prev_Token
:= Tok_String_Literal
;
1316 -- String literal placed after interpolated expression
1325 -- The following loop runs more than once only if a format effector
1326 -- (tab, vertical tab, form feed, line feed, carriage return) is
1327 -- encountered and skipped, or some error situation, such as an
1328 -- illegal character, is encountered.
1330 <<Scan_Next_Character
>>
1333 -- Skip past blanks, loop is opened up for speed
1335 while Source
(Scan_Ptr
) = ' ' loop
1336 if Source
(Scan_Ptr
+ 1) /= ' ' then
1337 Scan_Ptr
:= Scan_Ptr
+ 1;
1341 if Source
(Scan_Ptr
+ 2) /= ' ' then
1342 Scan_Ptr
:= Scan_Ptr
+ 2;
1346 if Source
(Scan_Ptr
+ 3) /= ' ' then
1347 Scan_Ptr
:= Scan_Ptr
+ 3;
1351 if Source
(Scan_Ptr
+ 4) /= ' ' then
1352 Scan_Ptr
:= Scan_Ptr
+ 4;
1356 if Source
(Scan_Ptr
+ 5) /= ' ' then
1357 Scan_Ptr
:= Scan_Ptr
+ 5;
1361 if Source
(Scan_Ptr
+ 6) /= ' ' then
1362 Scan_Ptr
:= Scan_Ptr
+ 6;
1366 if Source
(Scan_Ptr
+ 7) /= ' ' then
1367 Scan_Ptr
:= Scan_Ptr
+ 7;
1371 Scan_Ptr
:= Scan_Ptr
+ 8;
1374 -- We are now at a non-blank character, which is the first character
1375 -- of the token we will scan, and hence the value of Token_Ptr.
1377 Token_Ptr
:= Scan_Ptr
;
1379 Token_Contains_Uppercase
:= False;
1381 -- Here begins the main case statement which transfers control on the
1382 -- basis of the non-blank character we have encountered.
1384 case Source
(Scan_Ptr
) is
1386 -- Line terminator characters
1388 when CR | LF | FF | VT
=>
1389 goto Scan_Line_Terminator
;
1391 -- Horizontal tab, just skip past it
1398 Scan_Ptr
:= Scan_Ptr
+ 1;
1400 -- End of file character, treated as an end of file only if it is
1401 -- the last character in the buffer, otherwise it is ignored.
1404 if Scan_Ptr
= Source_Last
(Current_Source_File
) then
1414 Scan_Ptr
:= Scan_Ptr
+ 1;
1420 Accumulate_Checksum
('&');
1422 if Source
(Scan_Ptr
+ 1) = '&' then
1423 Error_Msg_S
-- CODEFIX
1424 ("'&'& should be `AND THEN`");
1425 Scan_Ptr
:= Scan_Ptr
+ 2;
1430 Scan_Ptr
:= Scan_Ptr
+ 1;
1431 Token
:= Tok_Ampersand
;
1435 -- AI12-0125-03 : @ is target_name
1438 Error_Msg_Ada_2022_Feature
("target name", Token_Ptr
);
1440 Accumulate_Checksum
('@');
1441 Scan_Ptr
:= Scan_Ptr
+ 1;
1442 Token
:= Tok_At_Sign
;
1445 -- Asterisk (can be multiplication operator or double asterisk which
1446 -- is the exponentiation compound delimiter).
1449 Accumulate_Checksum
('*');
1451 if Source
(Scan_Ptr
+ 1) = '*' then
1452 Accumulate_Checksum
('*');
1453 Scan_Ptr
:= Scan_Ptr
+ 2;
1454 Token
:= Tok_Double_Asterisk
;
1458 Scan_Ptr
:= Scan_Ptr
+ 1;
1459 Token
:= Tok_Asterisk
;
1463 -- Colon, which can either be an isolated colon, or part of an
1464 -- assignment compound delimiter.
1467 Accumulate_Checksum
(':');
1469 if Double_Char_Token
('=') then
1470 Token
:= Tok_Colon_Equal
;
1473 Style
.Check_Colon_Equal
;
1478 elsif Source
(Scan_Ptr
+ 1) = '-'
1479 and then Source
(Scan_Ptr
+ 2) /= '-'
1481 Token
:= Tok_Colon_Equal
;
1482 Error_Msg
-- CODEFIX
1483 (":- should be :=", Scan_Ptr
);
1484 Scan_Ptr
:= Scan_Ptr
+ 2;
1488 Scan_Ptr
:= Scan_Ptr
+ 1;
1501 Accumulate_Checksum
('(');
1502 Scan_Ptr
:= Scan_Ptr
+ 1;
1503 Token
:= Tok_Left_Paren
;
1506 Style
.Check_Left_Paren_Square_Bracket
;
1515 -- [] under -gnat2022 is an aggregate notation and the special
1516 -- wide character notation becomes unsupported since the two
1519 if Ada_Version
>= Ada_2022
then
1520 Scan_Ptr
:= Scan_Ptr
+ 1;
1521 Token
:= Tok_Left_Bracket
;
1524 Style
.Check_Left_Paren_Square_Bracket
;
1529 elsif Source
(Scan_Ptr
+ 1) = '"' then
1530 goto Scan_Wide_Character
;
1533 Error_Msg_S
("illegal character, replaced by ""(""");
1534 Scan_Ptr
:= Scan_Ptr
+ 1;
1535 Token
:= Tok_Left_Paren
;
1539 -- Left curly bracket, treated as right paren but proper delimiter
1540 -- of interpolated string literals when core extensions are allowed.
1543 if Core_Extensions_Allowed
then
1544 Scan_Ptr
:= Scan_Ptr
+ 1;
1545 Token
:= Tok_Left_Curly_Bracket
;
1548 Error_Msg_S
("illegal character, replaced by ""(""");
1549 Scan_Ptr
:= Scan_Ptr
+ 1;
1550 Token
:= Tok_Left_Paren
;
1558 Accumulate_Checksum
(',');
1559 Scan_Ptr
:= Scan_Ptr
+ 1;
1568 -- Dot, which is either an isolated period, or part of a double dot
1569 -- compound delimiter sequence. We also check for the case of a
1570 -- digit following the period, to give a better error message.
1573 Accumulate_Checksum
('.');
1575 if Double_Char_Token
('.') then
1576 Token
:= Tok_Dot_Dot
;
1579 Style
.Check_Dot_Dot
;
1584 elsif Source
(Scan_Ptr
+ 1) in '0' .. '9' then
1585 Error_Msg_S
("numeric literal cannot start with point");
1586 Scan_Ptr
:= Scan_Ptr
+ 1;
1589 Scan_Ptr
:= Scan_Ptr
+ 1;
1594 -- Equal, which can either be an equality operator, or part of the
1595 -- arrow (=>) compound delimiter.
1598 Accumulate_Checksum
('=');
1600 if Double_Char_Token
('>') then
1604 Style
.Check_Arrow
(Inside_Depends
);
1609 elsif Source
(Scan_Ptr
+ 1) = '=' then
1610 Error_Msg_S
-- CODEFIX
1612 Scan_Ptr
:= Scan_Ptr
+ 1;
1615 Scan_Ptr
:= Scan_Ptr
+ 1;
1619 -- Greater than, which can be a greater than operator, greater than
1620 -- or equal operator, or first character of a right label bracket.
1623 Accumulate_Checksum
('>');
1625 if Double_Char_Token
('=') then
1626 Token
:= Tok_Greater_Equal
;
1629 elsif Double_Char_Token
('>') then
1630 Token
:= Tok_Greater_Greater
;
1634 Scan_Ptr
:= Scan_Ptr
+ 1;
1635 Token
:= Tok_Greater
;
1639 -- Less than, which can be a less than operator, less than or equal
1640 -- operator, or the first character of a left label bracket, or the
1641 -- first character of a box (<>) compound delimiter.
1644 Accumulate_Checksum
('<');
1646 if Double_Char_Token
('=') then
1647 Token
:= Tok_Less_Equal
;
1650 elsif Double_Char_Token
('>') then
1659 elsif Double_Char_Token
('<') then
1660 Token
:= Tok_Less_Less
;
1664 Scan_Ptr
:= Scan_Ptr
+ 1;
1669 -- Minus, which is either a subtraction operator, or the first
1670 -- character of double minus starting a comment
1672 when '-' => Minus_Case
: begin
1673 if Source
(Scan_Ptr
+ 1) = '>' then
1674 Error_Msg_S
("invalid token");
1675 Scan_Ptr
:= Scan_Ptr
+ 2;
1679 elsif Source
(Scan_Ptr
+ 1) /= '-' then
1680 Accumulate_Checksum
('-');
1681 Scan_Ptr
:= Scan_Ptr
+ 1;
1687 else -- Source (Scan_Ptr + 1) = '-' then
1689 Style
.Check_Comment
;
1692 Scan_Ptr
:= Scan_Ptr
+ 2;
1694 -- If we are in preprocessor mode with Replace_In_Comments set,
1695 -- then we return the "--" as a token on its own.
1697 if Replace_In_Comments
then
1698 Token
:= Tok_Comment
;
1702 -- Loop to scan comment (this loop runs more than once only if
1703 -- a horizontal tab or other non-graphic character is scanned)
1706 -- Scan to non graphic character (opened up for speed)
1708 -- Note that we just eat left brackets, which means that
1709 -- bracket notation cannot be used for end of line
1710 -- characters in comments. This seems a reasonable choice,
1711 -- since no one would ever use brackets notation in a real
1712 -- program in this situation, and if we allow brackets
1713 -- notation, we forbid some valid comments which contain a
1714 -- brackets sequence that happens to match an end of line
1718 exit when Source
(Scan_Ptr
) not in Graphic_Character
;
1719 Scan_Ptr
:= Scan_Ptr
+ 1;
1720 exit when Source
(Scan_Ptr
) not in Graphic_Character
;
1721 Scan_Ptr
:= Scan_Ptr
+ 1;
1722 exit when Source
(Scan_Ptr
) not in Graphic_Character
;
1723 Scan_Ptr
:= Scan_Ptr
+ 1;
1724 exit when Source
(Scan_Ptr
) not in Graphic_Character
;
1725 Scan_Ptr
:= Scan_Ptr
+ 1;
1726 exit when Source
(Scan_Ptr
) not in Graphic_Character
;
1727 Scan_Ptr
:= Scan_Ptr
+ 1;
1730 -- Keep going if horizontal tab
1732 if Source
(Scan_Ptr
) = HT
then
1737 Scan_Ptr
:= Scan_Ptr
+ 1;
1739 -- Terminate scan of comment if line terminator
1741 elsif Source
(Scan_Ptr
) in Line_Terminator
then
1744 -- Terminate scan of comment if end of file encountered
1745 -- (embedded EOF character or real last character in file)
1747 elsif Source
(Scan_Ptr
) = EOF
then
1750 -- If we have a wide character, we have to scan it out,
1751 -- because it might be a legitimate line terminator
1753 elsif Start_Of_Wide_Character
then
1760 Scan_Wide
(Source
, Scan_Ptr
, Code
, Err
);
1762 -- If not well formed wide character, then just skip
1763 -- past it and ignore it.
1766 Scan_Ptr
:= Wptr
+ 1;
1768 -- If UTF_32 terminator, terminate comment scan
1770 elsif Is_UTF_32_Line_Terminator
(UTF_32
(Code
)) then
1778 -- Keep going if character in 80-FF range, or is ESC. These
1779 -- characters are allowed in comments by RM-2.1(1), 2.7(2).
1780 -- They are allowed even in Ada 83 mode according to the
1781 -- approved AI. ESC was added to the AI in June 93.
1783 elsif Source
(Scan_Ptr
) in Upper_Half_Character
1784 or else Source
(Scan_Ptr
) = ESC
1786 Scan_Ptr
:= Scan_Ptr
+ 1;
1788 -- Otherwise we have an illegal comment character, ignore
1789 -- this error in relaxed semantics mode.
1792 if Relaxed_RM_Semantics
then
1793 Scan_Ptr
:= Scan_Ptr
+ 1;
1795 Error_Illegal_Character
;
1800 -- Note that we do not return here; instead we fall through to
1801 -- reexecute the scan loop to look for a token.
1805 -- Double quote or percent starting a string literal
1812 -- Apostrophe. This can either be the start of a character literal,
1813 -- or an isolated apostrophe used in a qualified expression or an
1814 -- attribute. In the following:
1816 -- A := CHARACTER'('A');
1818 -- the first apostrophe is treated as an isolated apostrophe, and the
1819 -- second one is treated as the start of the character literal 'A'.
1820 -- Note that RM-2.2(7) does not require a separator between "'" and
1821 -- "(" in the above, so we cannot use lookahead to distinguish the
1822 -- cases; we use look-back instead. Analysis of the grammar shows
1823 -- that some tokens can be followed by an apostrophe, and some by a
1824 -- character literal, but none by both. Some cannot be followed by
1825 -- either, so it doesn't matter what we do in those cases, except to
1826 -- get good error behavior.
1828 when ''' => Char_Literal_Case
: declare
1833 Accumulate_Checksum
(''');
1834 Scan_Ptr
:= Scan_Ptr
+ 1;
1836 -- Distinguish between apostrophe and character literal. It's an
1837 -- apostrophe if the previous token is one of the following.
1838 -- Reserved words are included for things like A.all'Address and
1839 -- T'Digits'Img. Strings literals are included for things like
1840 -- "abs"'Address. Other literals are included to give better error
1841 -- behavior for illegal cases like 123'Img.
1843 -- In Ada 2022, a target name (i.e. @) is a valid prefix of an
1844 -- attribute, and functions like a name.
1846 if Prev_Token
in Tok_All | Tok_At_Sign | Tok_Delta | Tok_Digits |
1847 Tok_Identifier | Tok_Project | Tok_Right_Paren |
1848 Tok_Right_Bracket | Token_Class_Literal
1850 Token
:= Tok_Apostrophe
;
1853 Style
.Check_Apostrophe
;
1858 -- Otherwise the apostrophe starts a character literal
1861 -- Case of wide character literal
1863 if Start_Of_Wide_Character
then
1865 Scan_Wide
(Source
, Scan_Ptr
, Code
, Err
);
1868 Error_Illegal_Wide_Character
;
1869 Code
:= Character'Pos (' ');
1871 -- In Ada 95 mode we allow any wide character in a character
1872 -- literal, but in later versions, the set of characters
1873 -- allowed is restricted to graphic characters.
1875 elsif Ada_Version
>= Ada_2005
1876 and then Is_UTF_32_Non_Graphic
(UTF_32
(Code
))
1878 Error_Msg
-- CODEFIX
1879 ("(Ada 2005) non-graphic character not permitted " &
1880 "in character literal", Wptr
);
1885 Accumulate_Checksum
(Code
);
1887 if Source
(Scan_Ptr
) /= ''' then
1888 Error_Msg_S
("missing apostrophe");
1890 Scan_Ptr
:= Scan_Ptr
+ 1;
1893 -- If we do not find a closing quote in the expected place then
1894 -- assume that we have a misguided attempt at a string literal.
1896 -- However, if previous token is RANGE, then we return an
1897 -- apostrophe instead since this gives better error recovery
1899 elsif Source
(Scan_Ptr
+ 1) /= ''' then
1900 if Prev_Token
= Tok_Range
then
1901 Token
:= Tok_Apostrophe
;
1905 Scan_Ptr
:= Scan_Ptr
- 1;
1907 ("strings are delimited by double quote character");
1913 -- Otherwise we have a (non-wide) character literal
1916 Accumulate_Checksum
(Source
(Scan_Ptr
));
1918 if Source
(Scan_Ptr
) not in Graphic_Character
then
1919 if Source
(Scan_Ptr
) in Upper_Half_Character
then
1920 if Ada_Version
= Ada_83
then
1921 Error_Illegal_Character
;
1925 Error_Illegal_Character
;
1929 Code
:= Get_Char_Code
(Source
(Scan_Ptr
));
1930 Scan_Ptr
:= Scan_Ptr
+ 2;
1933 -- Fall through here with Scan_Ptr updated past the closing
1934 -- quote, and Code set to the Char_Code value for the literal
1936 Accumulate_Checksum
(''');
1937 Token
:= Tok_Char_Literal
;
1938 Set_Character_Literal_Name
(Code
);
1939 Token_Name
:= Name_Find
;
1940 Character_Code
:= Code
;
1944 end Char_Literal_Case
;
1946 -- Right parenthesis
1949 Accumulate_Checksum
(')');
1950 Scan_Ptr
:= Scan_Ptr
+ 1;
1951 Token
:= Tok_Right_Paren
;
1954 Style
.Check_Right_Paren
;
1959 -- Right bracket or right brace, treated as right paren but proper
1960 -- aggregate delimiter in Ada 2022.
1963 if Ada_Version
>= Ada_2022
then
1964 Token
:= Tok_Right_Bracket
;
1967 Error_Msg_S
("illegal character, replaced by "")""");
1968 Token
:= Tok_Right_Paren
;
1971 Scan_Ptr
:= Scan_Ptr
+ 1;
1974 -- Right curly bracket, treated as right paren but proper delimiter
1975 -- of interpolated string literals when core extensions are allowed.
1978 if Core_Extensions_Allowed
then
1979 Token
:= Tok_Right_Curly_Bracket
;
1982 Error_Msg_S
("illegal character, replaced by "")""");
1983 Token
:= Tok_Right_Paren
;
1986 Scan_Ptr
:= Scan_Ptr
+ 1;
1989 -- Slash (can be division operator or first character of not equal)
1992 Accumulate_Checksum
('/');
1994 if Double_Char_Token
('=') then
1995 Token
:= Tok_Not_Equal
;
1998 Scan_Ptr
:= Scan_Ptr
+ 1;
2006 Accumulate_Checksum
(';');
2007 Scan_Ptr
:= Scan_Ptr
+ 1;
2008 Token
:= Tok_Semicolon
;
2011 Style
.Check_Semicolon
;
2018 when '|' => Vertical_Bar_Case
: begin
2019 Accumulate_Checksum
('|');
2021 -- Special check for || to give nice message
2023 if Source
(Scan_Ptr
+ 1) = '|' then
2024 Error_Msg_S
-- CODEFIX
2025 ("""'|'|"" should be `OR ELSE`");
2026 Scan_Ptr
:= Scan_Ptr
+ 2;
2031 Scan_Ptr
:= Scan_Ptr
+ 1;
2032 Token
:= Tok_Vertical_Bar
;
2035 Style
.Check_Vertical_Bar
;
2041 end Vertical_Bar_Case
;
2043 -- Exclamation, replacement character for vertical bar
2045 when '!' => Exclamation_Case
: begin
2046 Accumulate_Checksum
('!');
2048 if Source
(Scan_Ptr
+ 1) = '=' then
2049 Error_Msg_S
-- CODEFIX
2050 ("'!= should be /=");
2051 Scan_Ptr
:= Scan_Ptr
+ 2;
2052 Token
:= Tok_Not_Equal
;
2056 Scan_Ptr
:= Scan_Ptr
+ 1;
2057 Token
:= Tok_Vertical_Bar
;
2061 end Exclamation_Case
;
2065 when '+' => Plus_Case
: begin
2066 Accumulate_Checksum
('+');
2067 Scan_Ptr
:= Scan_Ptr
+ 1;
2072 -- Digits starting a numeric literal
2076 -- First a bit of a scan ahead to see if we have a case of an
2077 -- identifier starting with a digit (remembering exponent case).
2080 C
: constant Character := Source
(Scan_Ptr
+ 1);
2083 -- OK literal if digit followed by digit or underscore
2085 if C
in '0' .. '9' or else C
= '_' then
2088 -- OK literal if digit not followed by identifier char
2090 elsif not Identifier_Char
(C
) then
2093 -- OK literal if digit followed by e/E followed by digit/sign.
2094 -- We also allow underscore after the E, which is an error, but
2095 -- better handled by Nlit than deciding this is an identifier.
2097 elsif (C
= 'e' or else C
= 'E')
2098 and then (Source
(Scan_Ptr
+ 2) in '0' .. '9'
2099 or else Source
(Scan_Ptr
+ 2) = '+'
2100 or else Source
(Scan_Ptr
+ 2) = '-'
2101 or else Source
(Scan_Ptr
+ 2) = '_')
2105 -- Here we have what really looks like an identifier that
2106 -- starts with a digit, so give error msg.
2109 Error_Msg_S
("identifier may not start with digit");
2111 Underline_Found
:= False;
2112 Name_Buffer
(1) := Source
(Scan_Ptr
);
2113 Accumulate_Checksum
(Name_Buffer
(1));
2114 Scan_Ptr
:= Scan_Ptr
+ 1;
2115 goto Scan_Identifier
;
2119 -- Here we have an OK integer literal
2123 -- Check for proper delimiter, ignoring other format characters
2125 Skip_Other_Format_Characters
;
2127 if Identifier_Char
(Source
(Scan_Ptr
)) then
2129 ("delimiter required between literal and identifier");
2135 -- Lower case letters
2138 if Core_Extensions_Allowed
2139 and then Source
(Scan_Ptr
) = 'f'
2140 and then Source
(Scan_Ptr
+ 1) = '"'
2142 Scan_Ptr
:= Scan_Ptr
+ 1;
2143 Accumulate_Checksum
(Source
(Scan_Ptr
));
2144 Token
:= Tok_Left_Interpolated_String
;
2149 Underline_Found
:= False;
2150 Name_Buffer
(1) := Source
(Scan_Ptr
);
2151 Accumulate_Checksum
(Name_Buffer
(1));
2152 Scan_Ptr
:= Scan_Ptr
+ 1;
2153 goto Scan_Identifier
;
2155 -- Upper case letters
2158 if Core_Extensions_Allowed
2159 and then Source
(Scan_Ptr
) = 'F'
2160 and then Source
(Scan_Ptr
+ 1) = '"'
2163 ("delimiter of interpolated string must be in lowercase");
2164 Scan_Ptr
:= Scan_Ptr
+ 1;
2165 Token
:= Tok_Left_Interpolated_String
;
2169 Token_Contains_Uppercase
:= True;
2171 Underline_Found
:= False;
2173 Character'Val (Character'Pos (Source
(Scan_Ptr
)) + 32);
2174 Accumulate_Checksum
(Name_Buffer
(1));
2175 Scan_Ptr
:= Scan_Ptr
+ 1;
2176 goto Scan_Identifier
;
2178 -- Underline character
2181 -- Identifiers with leading underscores are not allowed in Ada.
2182 -- However, we allow them in the run-time library, so we can
2183 -- create names that are hidden from normal Ada code. For an
2184 -- example, search for "Name_uNext", which is "_Next".
2186 if not In_Internal_Unit
(Scan_Ptr
) then
2187 Error_Msg_S
("identifier cannot start with underline");
2191 Name_Buffer
(1) := '_';
2192 Scan_Ptr
:= Scan_Ptr
+ 1;
2193 Underline_Found
:= False;
2194 goto Scan_Identifier
;
2196 -- Space (not possible, because we scanned past blanks)
2199 raise Program_Error
;
2201 -- Characters in top half of ASCII 8-bit chart
2203 when Upper_Half_Character
=>
2205 -- Wide character case
2207 if Upper_Half_Encoding
then
2208 goto Scan_Wide_Character
;
2210 -- Otherwise we have OK Latin-1 character
2213 -- Upper half characters may possibly be identifier letters
2214 -- but can never be digits, so Identifier_Char can be used to
2215 -- test for a valid start of identifier character.
2217 if Identifier_Char
(Source
(Scan_Ptr
)) then
2219 Underline_Found
:= False;
2220 goto Scan_Identifier
;
2222 Error_Illegal_Character
;
2228 -- ESC character, possible start of identifier if wide characters
2229 -- using ESC encoding are allowed in identifiers, which we can
2230 -- tell by looking at the Identifier_Char flag for ESC, which is
2231 -- only true if these conditions are met. In Ada 2005 mode, may
2232 -- also be valid UTF_32 space or line terminator character.
2234 if Identifier_Char
(ESC
) then
2236 goto Scan_Wide_Character
;
2238 Error_Illegal_Character
;
2241 -- Illegal characters
2243 when ACK | ASCII
.SO | BEL | BS | CAN | DC1 | DC2 | DC3 | DC4 | DEL
2244 | DLE | EM | ENQ | EOT | ETB | ETX | FS | GS | NAK | NUL | RS | SI
2245 | SOH | STX | SYN | US
2246 |
'?' |
'`' |
'\' |
'^' |
'~'
2248 Error_Illegal_Character
;
2250 -- Special preprocessor characters. If Set_Special_Character has been
2251 -- called, return a Special token. Otherwise give an error.
2253 when Special_Preprocessor_Character
=>
2256 function Matches_After_Skipping_White_Space
2257 (S
: String) return Boolean;
2259 -- Return True iff after skipping past white space the
2260 -- next Source characters match the given string.
2262 ----------------------------------------
2263 -- Matches_After_Skipping_White_Space --
2264 ----------------------------------------
2266 function Matches_After_Skipping_White_Space
2267 (S
: String) return Boolean
2269 function To_Lower_Case_String
(Buff
: Text_Buffer
)
2271 -- Convert a text buffer to a lower-case string.
2273 --------------------------
2274 -- To_Lower_Case_String --
2275 --------------------------
2277 function To_Lower_Case_String
(Buff
: Text_Buffer
)
2280 subtype One_Based
is Text_Buffer
(1 .. Buff
'Length);
2281 Result
: String := String (One_Based
(Buff
));
2283 -- The System.Case_Util.To_Lower function (the overload
2284 -- that takes a string parameter) cannot be called
2285 -- here due to bootstrapping problems. That function
2286 -- was added too recently.
2288 System
.Case_Util
.To_Lower
(Result
);
2290 end To_Lower_Case_String
;
2292 pragma Assert
(Source
(Scan_Ptr
) = '#');
2293 Local_Scan_Ptr
: Source_Ptr
:= Scan_Ptr
+ 1;
2295 -- Start of processing for Matches_After_Skipping_White_Space
2298 while Local_Scan_Ptr
in Source
'Range
2299 and then Source
(Local_Scan_Ptr
) in ' ' | HT
2301 Local_Scan_Ptr
:= Local_Scan_Ptr
+ 1;
2304 return Local_Scan_Ptr
in Source
'Range
2305 and then Local_Scan_Ptr
+ (S
'Length - 1) in Source
'Range
2306 and then S
= To_Lower_Case_String
(
2307 Source
(Local_Scan_Ptr
..
2308 Local_Scan_Ptr
+ (S
'Length - 1)));
2309 end Matches_After_Skipping_White_Space
;
2312 -- If Set_Special_Character has been called for this character,
2313 -- set Scans.Special_Character and return a Special token.
2315 if Special_Characters
(Source
(Scan_Ptr
)) then
2316 Token_Ptr
:= Scan_Ptr
;
2317 Token
:= Tok_Special
;
2318 Special_Character
:= Source
(Scan_Ptr
);
2319 Scan_Ptr
:= Scan_Ptr
+ 1;
2322 -- Check for something looking like a preprocessor directive
2324 elsif Source
(Scan_Ptr
) = '#'
2325 and then (Matches_After_Skipping_White_Space
("if")
2327 Matches_After_Skipping_White_Space
("elsif")
2329 Matches_After_Skipping_White_Space
("else")
2331 Matches_After_Skipping_White_Space
("end"))
2334 ("preprocessor directive ignored" &
2335 ", preprocessor not active");
2337 -- Skip to end of line
2340 if Source
(Scan_Ptr
) in Graphic_Character
2342 Source
(Scan_Ptr
) = HT
2344 Scan_Ptr
:= Scan_Ptr
+ 1;
2346 -- Done if line terminator or EOF
2348 elsif Source
(Scan_Ptr
) in Line_Terminator
2350 Source
(Scan_Ptr
) = EOF
2354 -- If we have a wide character, we have to scan it out,
2355 -- because it might be a legitimate line terminator
2357 elsif Start_Of_Wide_Character
then
2359 Wptr
: constant Source_Ptr
:= Scan_Ptr
;
2364 Scan_Wide
(Source
, Scan_Ptr
, Code
, Err
);
2366 -- If not well formed wide character, then just
2367 -- skip past it and ignore it.
2370 Scan_Ptr
:= Wptr
+ 1;
2372 -- If UTF_32 terminator, terminate comment scan
2374 elsif Is_UTF_32_Line_Terminator
(UTF_32
(Code
)) then
2380 -- Else keep going (don't worry about bad comment chars
2381 -- in this context, we just want to find the end of line.
2384 Scan_Ptr
:= Scan_Ptr
+ 1;
2388 -- Otherwise, this is an illegal character
2391 Error_Illegal_Character
;
2396 -- End switch on non-blank character
2400 -- End loop past format effectors. The exit from this loop is by
2401 -- executing a return statement following completion of token scan
2402 -- (control never falls out of this loop to the code that follows).
2406 pragma Assert
(False);
2408 -- Wide_Character scanning routine. On entry we have encountered the
2409 -- initial character of a wide character sequence.
2411 <<Scan_Wide_Character
>>
2419 Scan_Wide
(Source
, Scan_Ptr
, Code
, Err
);
2421 -- If bad wide character, signal error and continue scan
2424 Error_Illegal_Wide_Character
;
2425 goto Scan_Next_Character
;
2428 Cat
:= Get_Category
(UTF_32
(Code
));
2430 -- If OK letter, reset scan ptr and go scan identifier
2432 if Is_UTF_32_Letter
(Cat
) then
2435 Underline_Found
:= False;
2436 goto Scan_Identifier
;
2438 -- If OK wide space, ignore and keep scanning (we do not include
2439 -- any ignored spaces in checksum)
2441 elsif Is_UTF_32_Space
(Cat
) then
2442 goto Scan_Next_Character
;
2444 -- If other format character, ignore and keep scanning (again we
2445 -- do not include in the checksum) (this is for AI-0079).
2447 elsif Is_UTF_32_Other
(Cat
) then
2448 goto Scan_Next_Character
;
2450 -- If OK wide line terminator, terminate current line
2452 elsif Is_UTF_32_Line_Terminator
(UTF_32
(Code
)) then
2454 goto Scan_Line_Terminator
;
2456 -- Punctuation is an error (at start of identifier)
2458 elsif Is_UTF_32_Punctuation
(Cat
) then
2459 Error_Msg
("identifier cannot start with punctuation", Wptr
);
2462 Underline_Found
:= False;
2463 goto Scan_Identifier
;
2465 -- Mark character is an error (at start of identifier)
2467 elsif Is_UTF_32_Mark
(Cat
) then
2468 Error_Msg
("identifier cannot start with mark character", Wptr
);
2471 Underline_Found
:= False;
2472 goto Scan_Identifier
;
2474 -- Extended digit character is an error. Could be bad start of
2475 -- identifier or bad literal. Not worth doing too much to try to
2476 -- distinguish these cases, but we will do a little bit.
2478 elsif Is_UTF_32_Digit
(Cat
) then
2480 ("identifier cannot start with digit character", Wptr
);
2483 Underline_Found
:= False;
2484 goto Scan_Identifier
;
2486 -- All other wide characters are illegal here
2489 Error_Illegal_Wide_Character
;
2490 goto Scan_Next_Character
;
2494 -- Routine to scan line terminator. On entry Scan_Ptr points to a
2495 -- character which is one of FF,LR,CR,VT, or one of the wide characters
2496 -- that is treated as a line terminator.
2498 <<Scan_Line_Terminator
>>
2500 -- Check line too long
2504 -- Set Token_Ptr, if End_Of_Line is a token, for the case when it is
2507 if End_Of_Line_Is_Token
then
2508 Token_Ptr
:= Scan_Ptr
;
2515 Skip_Line_Terminators
(Scan_Ptr
, Physical
);
2517 -- If we are at start of physical line, update scan pointers to
2518 -- reflect the start of the new line.
2521 Current_Line_Start
:= Scan_Ptr
;
2522 Start_Column
:= Set_Start_Column
;
2523 First_Non_Blank_Location
:= Scan_Ptr
;
2525 -- If End_Of_Line is a token, we return it as it is a
2528 if End_Of_Line_Is_Token
then
2529 Token
:= Tok_End_Of_Line
;
2535 goto Scan_Next_Character
;
2537 -- Identifier scanning routine. On entry, some initial characters of
2538 -- the identifier may have already been stored in Name_Buffer. If so,
2539 -- Name_Len has the number of characters stored, otherwise Name_Len is
2540 -- set to zero on entry. Underline_Found is also set False on entry.
2544 -- This loop scans as fast as possible past lower half letters and
2545 -- digits, which we expect to be the most common characters.
2548 if Source
(Scan_Ptr
) in 'a' .. 'z'
2549 or else Source
(Scan_Ptr
) in '0' .. '9'
2551 Name_Buffer
(Name_Len
+ 1) := Source
(Scan_Ptr
);
2552 Accumulate_Checksum
(Source
(Scan_Ptr
));
2554 elsif Source
(Scan_Ptr
) in 'A' .. 'Z' then
2555 Token_Contains_Uppercase
:= True;
2557 Name_Buffer
(Name_Len
+ 1) :=
2558 Character'Val (Character'Pos (Source
(Scan_Ptr
)) + 32);
2559 Accumulate_Checksum
(Name_Buffer
(Name_Len
+ 1));
2565 Underline_Found
:= False;
2566 Scan_Ptr
:= Scan_Ptr
+ 1;
2567 Name_Len
:= Name_Len
+ 1;
2570 -- If we fall through, then we have encountered either an underline
2571 -- character, or an extended identifier character (i.e. one from the
2572 -- upper half), or a wide character, or an identifier terminator. The
2573 -- initial test speeds us up in the most common case where we have
2574 -- an identifier terminator. Note that ESC is an identifier character
2575 -- only if a wide character encoding method that uses ESC encoding
2576 -- is active, so if we find an ESC character we know that we have a
2579 if Identifier_Char
(Source
(Scan_Ptr
))
2580 or else (Source
(Scan_Ptr
) in Upper_Half_Character
2581 and then Upper_Half_Encoding
)
2583 -- Case of underline
2585 if Source
(Scan_Ptr
) = '_' then
2586 Accumulate_Checksum
('_');
2588 if Underline_Found
then
2589 Error_No_Double_Underline
;
2591 Underline_Found
:= True;
2592 Name_Len
:= Name_Len
+ 1;
2593 Name_Buffer
(Name_Len
) := '_';
2596 Scan_Ptr
:= Scan_Ptr
+ 1;
2597 goto Scan_Identifier
;
2599 -- Upper half character
2601 elsif Source
(Scan_Ptr
) in Upper_Half_Character
2602 and then not Upper_Half_Encoding
2604 Accumulate_Checksum
(Source
(Scan_Ptr
));
2605 Store_Encoded_Character
2606 (Get_Char_Code
(Fold_Lower
(Source
(Scan_Ptr
))));
2607 Scan_Ptr
:= Scan_Ptr
+ 1;
2608 Underline_Found
:= False;
2609 goto Scan_Identifier
;
2611 -- Left bracket not followed by a quote terminates an identifier.
2612 -- This is an error, but we don't want to give a junk error msg
2613 -- about wide characters in this case.
2615 elsif Source
(Scan_Ptr
) = '['
2616 and then Source
(Scan_Ptr
+ 1) /= '"'
2620 -- We know we have a wide character encoding here (the current
2621 -- character is either ESC, left bracket, or an upper half
2622 -- character depending on the encoding method).
2625 -- Scan out the wide character and insert the appropriate
2626 -- encoding into the name table entry for the identifier.
2636 Scan_Wide
(Source
, Scan_Ptr
, Code
, Err
);
2638 -- If error, signal error
2641 Error_Illegal_Wide_Character
;
2643 -- If the character scanned is a normal identifier
2644 -- character, then we treat it that way.
2646 elsif In_Character_Range
(Code
)
2647 and then Identifier_Char
(Get_Character
(Code
))
2649 Chr
:= Get_Character
(Code
);
2650 Accumulate_Checksum
(Chr
);
2651 Store_Encoded_Character
2652 (Get_Char_Code
(Fold_Lower
(Chr
)));
2653 Underline_Found
:= False;
2655 -- Here if not a normal identifier character
2658 Cat
:= Get_Category
(UTF_32
(Code
));
2660 -- Wide character in Unicode category "Other, Format"
2661 -- is not accepted in an identifier. This is because it
2662 -- it is considered a security risk (AI-0091).
2664 -- However, it is OK for such a character to appear at
2665 -- the end of an identifier.
2667 if Is_UTF_32_Other
(Cat
) then
2668 if not Identifier_Char
(Source
(Scan_Ptr
)) then
2669 goto Scan_Identifier_Complete
;
2672 ("identifier cannot contain other_format "
2673 & "character", Wptr
);
2674 goto Scan_Identifier
;
2677 -- Wide character in category Separator,Space terminates
2679 elsif Is_UTF_32_Space
(Cat
) then
2680 goto Scan_Identifier_Complete
;
2683 -- Here if wide character is part of the identifier
2685 -- Make sure we are allowing wide characters in
2686 -- identifiers. Note that we allow wide character
2687 -- notation for an OK identifier character. This in
2688 -- particular allows bracket or other notation to be
2689 -- used for upper half letters.
2691 -- Wide characters are always allowed in Ada 2005
2693 if Identifier_Character_Set
/= 'w'
2694 and then Ada_Version
< Ada_2005
2697 ("wide character not allowed in identifier", Wptr
);
2700 -- AI12-0004: An identifier shall only contain characters
2701 -- that may be present in Normalization Form KC.
2703 if not Is_UTF_32_NFKC
(UTF_32
(Code
)) then
2705 ("invalid wide character in identifier", Wptr
);
2707 -- If OK letter, store it folding to upper case. Note
2708 -- that we include the folded letter in the checksum.
2710 elsif Is_UTF_32_Letter
(Cat
) then
2712 Char_Code
(UTF_32_To_Upper_Case
(UTF_32
(Code
)));
2713 Accumulate_Checksum
(Code
);
2714 Store_Encoded_Character
(Code
);
2715 Underline_Found
:= False;
2717 -- If OK extended digit or mark, then store it
2719 elsif Is_UTF_32_Digit
(Cat
)
2720 or else Is_UTF_32_Mark
(Cat
)
2722 Accumulate_Checksum
(Code
);
2723 Store_Encoded_Character
(Code
);
2724 Underline_Found
:= False;
2726 -- Wide punctuation is also stored, but counts as an
2727 -- underline character for error checking purposes.
2729 elsif Is_UTF_32_Punctuation
(Cat
) then
2730 Accumulate_Checksum
(Code
);
2732 if Underline_Found
then
2734 Cend
: constant Source_Ptr
:= Scan_Ptr
;
2737 Error_No_Double_Underline
;
2742 Store_Encoded_Character
(Code
);
2743 Underline_Found
:= True;
2746 -- Any other wide character is not acceptable
2750 ("invalid wide character in identifier", Wptr
);
2754 goto Scan_Identifier
;
2759 -- Scan of identifier is complete. The identifier is stored in
2760 -- Name_Buffer, and Scan_Ptr points past the last character.
2762 <<Scan_Identifier_Complete
>>
2763 Token_Name
:= Name_Find
;
2765 -- Check for identifier ending with underline or punctuation char
2767 if Underline_Found
then
2768 Underline_Found
:= False;
2770 if Source
(Scan_Ptr
- 1) = '_' then
2772 ("identifier cannot end with underline", Scan_Ptr
- 1);
2775 ("identifier cannot end with punctuation character", Wptr
);
2779 -- We will assume it is an identifier, not a keyword, so that the
2780 -- checksum is independent of the Ada version.
2782 Token
:= Tok_Identifier
;
2784 -- Check if it is a keyword
2786 if Is_Keyword_Name
(Token_Name
) then
2787 Accumulate_Token_Checksum
;
2788 Token
:= Token_Type
'Val (Get_Name_Table_Byte
(Token_Name
));
2790 -- See Exp_Put_Image for documentation of Tagged_Seen
2792 if Token
= Tok_Tagged
then
2793 Tagged_Seen
:= True;
2796 -- Keyword style checks
2800 -- Deal with possible style check for non-lower case keyword,
2801 -- but we don't treat ACCESS, DELTA, DIGITS, RANGE as keywords
2802 -- for this purpose if they appear as attribute designators.
2803 -- Actually we only check the first character for speed.
2805 -- Ada 2005 (AI-284): Do not apply the style check in case of
2806 -- "pragma Interface"
2808 -- Ada 2005 (AI-340): Do not apply the style check in case of
2811 if Token_Contains_Uppercase
2812 and then (Prev_Token
/= Tok_Apostrophe
2814 (Token
/= Tok_Access
and then
2815 Token
/= Tok_Delta
and then
2816 Token
/= Tok_Digits
and then
2817 Token
/= Tok_Mod
and then
2818 Token
/= Tok_Range
))
2819 and then (Token
/= Tok_Interface
2821 (Token
= Tok_Interface
2822 and then Prev_Token
/= Tok_Pragma
))
2824 Style
.Non_Lower_Case_Keyword
;
2827 -- Check THEN/ELSE style rules. These do not apply to AND THEN
2828 -- or OR ELSE, and do not apply in if expressions.
2830 if (Token
= Tok_Then
and then Prev_Token
/= Tok_And
)
2832 (Token
= Tok_Else
and then Prev_Token
/= Tok_Or
)
2834 if Inside_If_Expression
= 0 then
2835 Style
.Check_Separate_Stmt_Lines
;
2840 -- We must reset Token_Name since this is not an identifier and
2841 -- if we leave Token_Name set, the parser gets confused because
2842 -- it thinks it is dealing with an identifier instead of the
2843 -- corresponding keyword.
2845 Token_Name
:= No_Name
;
2848 -- It is an identifier after all
2851 Accumulate_Token_Checksum
;
2856 ------------------------------
2857 -- Set_End_Of_Line_As_Token --
2858 ------------------------------
2860 procedure Set_End_Of_Line_As_Token
(Value
: Boolean) is
2862 End_Of_Line_Is_Token
:= Value
;
2863 end Set_End_Of_Line_As_Token
;
2865 ---------------------------
2866 -- Set_Special_Character --
2867 ---------------------------
2869 procedure Set_Special_Character
(C
: Special_Preprocessor_Character
) is
2871 Special_Characters
(C
) := True;
2872 end Set_Special_Character
;
2874 ----------------------
2875 -- Set_Start_Column --
2876 ----------------------
2878 -- Note: it seems at first glance a little expensive to compute this value
2879 -- for every source line (since it is certainly not used for all source
2880 -- lines). On the other hand, it doesn't take much more work to skip past
2881 -- the initial white space on the line counting the columns than it would
2882 -- to scan past the white space using the standard scanning circuits.
2884 function Set_Start_Column
return Column_Number
is
2885 Start_Column
: Column_Number
:= 0;
2888 -- Outer loop scans past horizontal tab characters
2892 -- Inner loop scans past blanks, bumping Scan_Ptr past the blanks and
2893 -- adjusting Start_Column to account for them.
2896 while Source
(Scan_Ptr
) = ' ' loop
2897 Scan_Ptr
:= Scan_Ptr
+ 1;
2898 Start_Column
:= Start_Column
+ 1;
2899 end loop Blanks_Loop
;
2901 -- Outer loop keeps going only if a horizontal tab follows
2903 if Source
(Scan_Ptr
) = HT
then
2908 Scan_Ptr
:= Scan_Ptr
+ 1;
2909 Start_Column
:= (Start_Column
/ 8) * 8 + 8;
2915 return Start_Column
;
2917 -- A constraint error can happen only if we have a compiler with checks on
2918 -- and a line with a ludicrous number of tabs or spaces at the start. In
2919 -- such a case, we really don't care if Start_Column is right or not.
2922 when Constraint_Error
=>
2923 return Column_Number
'Last;
2924 end Set_Start_Column
;