]> git.ipfire.org Git - thirdparty/gcc.git/blame - gcc/ada/scng.adb
projects / thirdparty / gcc.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
s-tpopde-vms.adb: Add pragma Warnings (Off) for Task_Id conversions.
[thirdparty/gcc.git] / gcc / ada / scng.adb
CommitLineData
fbf5a39b
AC		 1------------------------------------------------------------------------------
2-- --
3-- GNAT COMPILER COMPONENTS --
4-- --
5-- S C N G --
6-- --
7-- B o d y --
8-- --
555360a5 9-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
fbf5a39b
AC		 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 2, 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 COPYING. If not, write --
19-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20-- MA 02111-1307, USA. --
21-- --
22-- GNAT was originally developed by the GNAT team at New York University. --
23-- Extensive contributions were provided by Ada Core Technologies Inc. --
24-- --
25------------------------------------------------------------------------------
26
27with Csets; use Csets;
28with Err_Vars; use Err_Vars;
fbf5a39b
AC		 29with Namet; use Namet;
30with Opt; use Opt;
31with Scans; use Scans;
32with Sinput; use Sinput;
33with Snames; use Snames;
34with Stringt; use Stringt;
35with Stylesw; use Stylesw;
36with Uintp; use Uintp;
37with Urealp; use Urealp;
38with Widechar; use Widechar;
39
40with System.CRC32;
41with System.WCh_Con; use System.WCh_Con;
42
43package body Scng is
44
45 use ASCII;
46 -- Make control characters visible
47
48 Special_Characters : array (Character) of Boolean := (others => False);
49 -- For characters that are Special token, the value is True
50
c45b6ae0
AC		 51 Comment_Is_Token : Boolean := False;
52 -- True if comments are tokens
53
fbf5a39b
AC		 54 End_Of_Line_Is_Token : Boolean := False;
55 -- True if End_Of_Line is a token
56
57 -----------------------
58 -- Local Subprograms --
59 -----------------------
60
6b6fcd3e
AC		 61 procedure Accumulate_Token_Checksum;
62 pragma Inline (Accumulate_Token_Checksum);
63
fbf5a39b
AC		 64 procedure Accumulate_Checksum (C : Character);
65 pragma Inline (Accumulate_Checksum);
66 -- This routine accumulates the checksum given character C. During the
67 -- scanning of a source file, this routine is called with every character
68 -- in the source, excluding blanks, and all control characters (except
69 -- that ESC is included in the checksum). Upper case letters not in string
70 -- literals are folded by the caller. See Sinput spec for the documentation
71 -- of the checksum algorithm. Note: checksum values are only used if we
72 -- generate code, so it is not necessary to worry about making the right
73 -- sequence of calls in any error situation.
74
75 procedure Accumulate_Checksum (C : Char_Code);
76 pragma Inline (Accumulate_Checksum);
77 -- This version is identical, except that the argument, C, is a character
78 -- code value instead of a character. This is used when wide characters
79 -- are scanned. We use the character code rather than the ASCII characters
80 -- so that the checksum is independent of wide character encoding method.
81
82 procedure Initialize_Checksum;
83 pragma Inline (Initialize_Checksum);
84 -- Initialize checksum value
85
86 -------------------------
87 -- Accumulate_Checksum --
88 -------------------------
89
90 procedure Accumulate_Checksum (C : Character) is
91 begin
92 System.CRC32.Update (System.CRC32.CRC32 (Checksum), C);
93 end Accumulate_Checksum;
94
95 procedure Accumulate_Checksum (C : Char_Code) is
96 begin
97 Accumulate_Checksum (Character'Val (C / 256));
98 Accumulate_Checksum (Character'Val (C mod 256));
99 end Accumulate_Checksum;
100
6b6fcd3e
AC		 101 -------------------------------
102 -- Accumulate_Token_Checksum --
103 -------------------------------
104
105 procedure Accumulate_Token_Checksum is
106 begin
107 System.CRC32.Update
108 (System.CRC32.CRC32 (Checksum),
109 Character'Val (Token_Type'Pos (Token)));
110 end Accumulate_Token_Checksum;
111
fbf5a39b
AC		 112 ----------------------------
113 -- Determine_Token_Casing --
114 ----------------------------
115
116 function Determine_Token_Casing return Casing_Type is
117 begin
118 return Determine_Casing (Source (Token_Ptr .. Scan_Ptr - 1));
119 end Determine_Token_Casing;
120
121 -------------------------
122 -- Initialize_Checksum --
123 -------------------------
124
125 procedure Initialize_Checksum is
126 begin
127 System.CRC32.Initialize (System.CRC32.CRC32 (Checksum));
128 end Initialize_Checksum;
129
130 ------------------------
131 -- Initialize_Scanner --
132 ------------------------
133
134 procedure Initialize_Scanner
135 (Unit : Unit_Number_Type;
136 Index : Source_File_Index)
137 is
138 begin
139 -- Set up Token_Type values in Names Table entries for reserved keywords
140 -- We use the Pos value of the Token_Type value. Note we are relying on
141 -- the fact that Token_Type'Val (0) is not a reserved word!
142
143 Set_Name_Table_Byte (Name_Abort, Token_Type'Pos (Tok_Abort));
144 Set_Name_Table_Byte (Name_Abs, Token_Type'Pos (Tok_Abs));
145 Set_Name_Table_Byte (Name_Abstract, Token_Type'Pos (Tok_Abstract));
146 Set_Name_Table_Byte (Name_Accept, Token_Type'Pos (Tok_Accept));
147 Set_Name_Table_Byte (Name_Access, Token_Type'Pos (Tok_Access));
148 Set_Name_Table_Byte (Name_And, Token_Type'Pos (Tok_And));
149 Set_Name_Table_Byte (Name_Aliased, Token_Type'Pos (Tok_Aliased));
150 Set_Name_Table_Byte (Name_All, Token_Type'Pos (Tok_All));
151 Set_Name_Table_Byte (Name_Array, Token_Type'Pos (Tok_Array));
152 Set_Name_Table_Byte (Name_At, Token_Type'Pos (Tok_At));
153 Set_Name_Table_Byte (Name_Begin, Token_Type'Pos (Tok_Begin));
154 Set_Name_Table_Byte (Name_Body, Token_Type'Pos (Tok_Body));
155 Set_Name_Table_Byte (Name_Case, Token_Type'Pos (Tok_Case));
156 Set_Name_Table_Byte (Name_Constant, Token_Type'Pos (Tok_Constant));
157 Set_Name_Table_Byte (Name_Declare, Token_Type'Pos (Tok_Declare));
158 Set_Name_Table_Byte (Name_Delay, Token_Type'Pos (Tok_Delay));
159 Set_Name_Table_Byte (Name_Delta, Token_Type'Pos (Tok_Delta));
160 Set_Name_Table_Byte (Name_Digits, Token_Type'Pos (Tok_Digits));
161 Set_Name_Table_Byte (Name_Do, Token_Type'Pos (Tok_Do));
162 Set_Name_Table_Byte (Name_Else, Token_Type'Pos (Tok_Else));
163 Set_Name_Table_Byte (Name_Elsif, Token_Type'Pos (Tok_Elsif));
164 Set_Name_Table_Byte (Name_End, Token_Type'Pos (Tok_End));
165 Set_Name_Table_Byte (Name_Entry, Token_Type'Pos (Tok_Entry));
166 Set_Name_Table_Byte (Name_Exception, Token_Type'Pos (Tok_Exception));
167 Set_Name_Table_Byte (Name_Exit, Token_Type'Pos (Tok_Exit));
168 Set_Name_Table_Byte (Name_For, Token_Type'Pos (Tok_For));
169 Set_Name_Table_Byte (Name_Function, Token_Type'Pos (Tok_Function));
170 Set_Name_Table_Byte (Name_Generic, Token_Type'Pos (Tok_Generic));
171 Set_Name_Table_Byte (Name_Goto, Token_Type'Pos (Tok_Goto));
172 Set_Name_Table_Byte (Name_If, Token_Type'Pos (Tok_If));
173 Set_Name_Table_Byte (Name_In, Token_Type'Pos (Tok_In));
174 Set_Name_Table_Byte (Name_Is, Token_Type'Pos (Tok_Is));
175 Set_Name_Table_Byte (Name_Limited, Token_Type'Pos (Tok_Limited));
176 Set_Name_Table_Byte (Name_Loop, Token_Type'Pos (Tok_Loop));
177 Set_Name_Table_Byte (Name_Mod, Token_Type'Pos (Tok_Mod));
178 Set_Name_Table_Byte (Name_New, Token_Type'Pos (Tok_New));
179 Set_Name_Table_Byte (Name_Not, Token_Type'Pos (Tok_Not));
180 Set_Name_Table_Byte (Name_Null, Token_Type'Pos (Tok_Null));
181 Set_Name_Table_Byte (Name_Of, Token_Type'Pos (Tok_Of));
182 Set_Name_Table_Byte (Name_Or, Token_Type'Pos (Tok_Or));
183 Set_Name_Table_Byte (Name_Others, Token_Type'Pos (Tok_Others));
184 Set_Name_Table_Byte (Name_Out, Token_Type'Pos (Tok_Out));
185 Set_Name_Table_Byte (Name_Package, Token_Type'Pos (Tok_Package));
186 Set_Name_Table_Byte (Name_Pragma, Token_Type'Pos (Tok_Pragma));
187 Set_Name_Table_Byte (Name_Private, Token_Type'Pos (Tok_Private));
188 Set_Name_Table_Byte (Name_Procedure, Token_Type'Pos (Tok_Procedure));
189 Set_Name_Table_Byte (Name_Protected, Token_Type'Pos (Tok_Protected));
190 Set_Name_Table_Byte (Name_Raise, Token_Type'Pos (Tok_Raise));
191 Set_Name_Table_Byte (Name_Range, Token_Type'Pos (Tok_Range));
192 Set_Name_Table_Byte (Name_Record, Token_Type'Pos (Tok_Record));
193 Set_Name_Table_Byte (Name_Rem, Token_Type'Pos (Tok_Rem));
194 Set_Name_Table_Byte (Name_Renames, Token_Type'Pos (Tok_Renames));
195 Set_Name_Table_Byte (Name_Requeue, Token_Type'Pos (Tok_Requeue));
196 Set_Name_Table_Byte (Name_Return, Token_Type'Pos (Tok_Return));
197 Set_Name_Table_Byte (Name_Reverse, Token_Type'Pos (Tok_Reverse));
198 Set_Name_Table_Byte (Name_Select, Token_Type'Pos (Tok_Select));
199 Set_Name_Table_Byte (Name_Separate, Token_Type'Pos (Tok_Separate));
200 Set_Name_Table_Byte (Name_Subtype, Token_Type'Pos (Tok_Subtype));
201 Set_Name_Table_Byte (Name_Tagged, Token_Type'Pos (Tok_Tagged));
202 Set_Name_Table_Byte (Name_Task, Token_Type'Pos (Tok_Task));
203 Set_Name_Table_Byte (Name_Terminate, Token_Type'Pos (Tok_Terminate));
204 Set_Name_Table_Byte (Name_Then, Token_Type'Pos (Tok_Then));
205 Set_Name_Table_Byte (Name_Type, Token_Type'Pos (Tok_Type));
206 Set_Name_Table_Byte (Name_Until, Token_Type'Pos (Tok_Until));
207 Set_Name_Table_Byte (Name_Use, Token_Type'Pos (Tok_Use));
208 Set_Name_Table_Byte (Name_When, Token_Type'Pos (Tok_When));
209 Set_Name_Table_Byte (Name_While, Token_Type'Pos (Tok_While));
210 Set_Name_Table_Byte (Name_With, Token_Type'Pos (Tok_With));
211 Set_Name_Table_Byte (Name_Xor, Token_Type'Pos (Tok_Xor));
212
213 -- Initialize scan control variables
214
215 Current_Source_File := Index;
216 Source := Source_Text (Current_Source_File);
217 Current_Source_Unit := Unit;
218 Scan_Ptr := Source_First (Current_Source_File);
219 Token := No_Token;
220 Token_Ptr := Scan_Ptr;
221 Current_Line_Start := Scan_Ptr;
222 Token_Node := Empty;
223 Token_Name := No_Name;
224 Start_Column := Set_Start_Column;
225 First_Non_Blank_Location := Scan_Ptr;
226
227 Initialize_Checksum;
228
5f3ab6fb 229 -- Do not call Scan, otherwise the License stuff does not work in Scn
fbf5a39b
AC		 230
231 end Initialize_Scanner;
232
233 ------------------------------
234 -- Reset_Special_Characters --
235 ------------------------------
236
237 procedure Reset_Special_Characters is
238 begin
239 Special_Characters := (others => False);
240 end Reset_Special_Characters;
241
242 ----------
243 -- Scan --
244 ----------
245
246 procedure Scan is
247
c45b6ae0
AC		 248 Start_Of_Comment : Source_Ptr;
249
fbf5a39b
AC		 250 procedure Check_End_Of_Line;
251 -- Called when end of line encountered. Checks that line is not
252 -- too long, and that other style checks for the end of line are met.
253
254 function Double_Char_Token (C : Character) return Boolean;
255 -- This function is used for double character tokens like := or <>. It
256 -- checks if the character following Source (Scan_Ptr) is C, and if so
257 -- bumps Scan_Ptr past the pair of characters and returns True. A space
258 -- between the two characters is also recognized with an appropriate
259 -- error message being issued. If C is not present, False is returned.
260 -- Note that Double_Char_Token can only be used for tokens defined in
261 -- the Ada syntax (it's use for error cases like && is not appropriate
262 -- since we do not want a junk message for a case like &-space-&).
263
264 procedure Error_Illegal_Character;
265 -- Give illegal character error, Scan_Ptr points to character.
266 -- On return, Scan_Ptr is bumped past the illegal character.
267
268 procedure Error_Illegal_Wide_Character;
269 -- Give illegal wide character message. On return, Scan_Ptr is bumped
270 -- past the illegal character, which may still leave us pointing to
271 -- junk, not much we can do if the escape sequence is messed up!
272
273 procedure Error_Long_Line;
274 -- Signal error of excessively long line
275
276 procedure Error_No_Double_Underline;
277 -- Signal error of double underline character
278
279 procedure Nlit;
280 -- This is the procedure for scanning out numeric literals. On entry,
281 -- Scan_Ptr points to the digit that starts the numeric literal (the
282 -- checksum for this character has not been accumulated yet). On return
283 -- Scan_Ptr points past the last character of the numeric literal, Token
284 -- and Token_Node are set appropriately, and the checksum is updated.
285
286 procedure Slit;
287 -- This is the procedure for scanning out string literals. On entry,
288 -- Scan_Ptr points to the opening string quote (the checksum for this
289 -- character has not been accumulated yet). On return Scan_Ptr points
290 -- past the closing quote of the string literal, Token and Token_Node
291 -- are set appropriately, and the checksum is upated.
292
293 -----------------------
294 -- Check_End_Of_Line --
295 -----------------------
296
297 procedure Check_End_Of_Line is
298 Len : constant Int := Int (Scan_Ptr) - Int (Current_Line_Start);
299
300 begin
301 if Style_Check and Style_Check_Max_Line_Length then
302 Style.Check_Line_Terminator (Len);
303
5950a3ac
AC		 304 -- If style checking is inactive, check maximum line length against
305 -- standard value. Note that we take this from Opt.Max_Line_Length
306 -- rather than Hostparm.Max_Line_Length because we do not want to
307 -- impose any limit during scanning of configuration pragma files,
308 -- and Opt.Max_Line_Length (normally set to Hostparm.Max_Line_Length)
309 -- is reset to Column_Number'Max during scanning of such files.
310
311 elsif Len > Opt.Max_Line_Length then
fbf5a39b
AC		 312 Error_Long_Line;
313 end if;
314 end Check_End_Of_Line;
315
316 -----------------------
317 -- Double_Char_Token --
318 -----------------------
319
320 function Double_Char_Token (C : Character) return Boolean is
321 begin
322 if Source (Scan_Ptr + 1) = C then
323 Accumulate_Checksum (C);
324 Scan_Ptr := Scan_Ptr + 2;
325 return True;
326
327 elsif Source (Scan_Ptr + 1) = ' '
328 and then Source (Scan_Ptr + 2) = C
329 then
330 Scan_Ptr := Scan_Ptr + 1;
331 Error_Msg_S ("no space allowed here");
332 Scan_Ptr := Scan_Ptr + 2;
333 return True;
334
335 else
336 return False;
337 end if;
338 end Double_Char_Token;
339
340 -----------------------------
341 -- Error_Illegal_Character --
342 -----------------------------
343
344 procedure Error_Illegal_Character is
345 begin
346 Error_Msg_S ("illegal character");
347 Scan_Ptr := Scan_Ptr + 1;
348 end Error_Illegal_Character;
349
350 ----------------------------------
351 -- Error_Illegal_Wide_Character --
352 ----------------------------------
353
354 procedure Error_Illegal_Wide_Character is
355 begin
555360a5 356 Error_Msg_S ("illegal wide character, check -gnatW switch");
fbf5a39b
AC		 357 Scan_Ptr := Scan_Ptr + 1;
358 end Error_Illegal_Wide_Character;
359
360 ---------------------
361 -- Error_Long_Line --
362 ---------------------
363
364 procedure Error_Long_Line is
365 begin
366 Error_Msg
367 ("this line is too long",
5950a3ac 368 Current_Line_Start + Source_Ptr (Opt.Max_Line_Length));
fbf5a39b
AC		 369 end Error_Long_Line;
370
371 -------------------------------
372 -- Error_No_Double_Underline --
373 -------------------------------
374
375 procedure Error_No_Double_Underline is
376 begin
377 Error_Msg_S ("two consecutive underlines not permitted");
378 end Error_No_Double_Underline;
379
380 ----------
381 -- Nlit --
382 ----------
383
384 procedure Nlit is
385
386 C : Character;
387 -- Current source program character
388
389 Base_Char : Character;
390 -- Either # or : (character at start of based number)
391
392 Base : Int;
393 -- Value of base
394
395 UI_Base : Uint;
396 -- Value of base in Uint format
397
398 UI_Int_Value : Uint;
399 -- Value of integer scanned by Scan_Integer in Uint format
400
401 UI_Num_Value : Uint;
402 -- Value of integer in numeric value being scanned
403
404 Scale : Int;
405 -- Scale value for real literal
406
407 UI_Scale : Uint;
408 -- Scale in Uint format
409
410 Exponent_Is_Negative : Boolean;
411 -- Set true for negative exponent
412
413 Extended_Digit_Value : Int;
414 -- Extended digit value
415
416 Point_Scanned : Boolean;
417 -- Flag for decimal point scanned in numeric literal
418
419 -----------------------
420 -- Local Subprograms --
421 -----------------------
422
423 procedure Error_Digit_Expected;
424 -- Signal error of bad digit, Scan_Ptr points to the location at
425 -- which the digit was expected on input, and is unchanged on return.
426
427 procedure Scan_Integer;
428 -- Procedure to scan integer literal. On entry, Scan_Ptr points to
429 -- a digit, on exit Scan_Ptr points past the last character of
430 -- the integer.
6b6fcd3e 431 --
fbf5a39b
AC		 432 -- For each digit encountered, UI_Int_Value is multiplied by 10,
433 -- and the value of the digit added to the result. In addition,
434 -- the value in Scale is decremented by one for each actual digit
435 -- scanned.
436
437 --------------------------
438 -- Error_Digit_Expected --
439 --------------------------
440
441 procedure Error_Digit_Expected is
442 begin
443 Error_Msg_S ("digit expected");
444 end Error_Digit_Expected;
445
15ce9ca2
AC		 446 ------------------
447 -- Scan_Integer --
448 ------------------
fbf5a39b
AC		 449
450 procedure Scan_Integer is
451 C : Character;
452 -- Next character scanned
453
454 begin
455 C := Source (Scan_Ptr);
456
457 -- Loop through digits (allowing underlines)
458
459 loop
460 Accumulate_Checksum (C);
461 UI_Int_Value :=
462 UI_Int_Value * 10 + (Character'Pos (C) - Character'Pos ('0'));
463 Scan_Ptr := Scan_Ptr + 1;
464 Scale := Scale - 1;
465 C := Source (Scan_Ptr);
466
467 if C = '_' then
30c20106
AC		 468
469 -- We do not accumulate the '_' in the checksum, so that
470 -- 1_234 is equivalent to 1234, and does not trigger
471 -- compilation for "minimal recompilation" (gnatmake -m).
fbf5a39b
AC		 472
473 loop
474 Scan_Ptr := Scan_Ptr + 1;
475 C := Source (Scan_Ptr);
476 exit when C /= '_';
477 Error_No_Double_Underline;
478 end loop;
479
480 if C not in '0' .. '9' then
481 Error_Digit_Expected;
482 exit;
483 end if;
484
485 else
486 exit when C not in '0' .. '9';
487 end if;
488 end loop;
489
490 end Scan_Integer;
491
492 ----------------------------------
493 -- Start of Processing for Nlit --
494 ----------------------------------
495
496 begin
497 Base := 10;
498 UI_Base := Uint_10;
499 UI_Int_Value := Uint_0;
500 Scale := 0;
501 Scan_Integer;
502 Scale := 0;
503 Point_Scanned := False;
504 UI_Num_Value := UI_Int_Value;
505
506 -- Various possibilities now for continuing the literal are
507 -- period, E/e (for exponent), or :/# (for based literal).
508
509 Scale := 0;
510 C := Source (Scan_Ptr);
511
512 if C = '.' then
513
514 -- Scan out point, but do not scan past .. which is a range
515 -- sequence, and must not be eaten up scanning a numeric literal.
516
517 while C = '.' and then Source (Scan_Ptr + 1) /= '.' loop
518 Accumulate_Checksum ('.');
519
520 if Point_Scanned then
521 Error_Msg_S ("duplicate point ignored");
522 end if;
523
524 Point_Scanned := True;
525 Scan_Ptr := Scan_Ptr + 1;
526 C := Source (Scan_Ptr);
527
528 if C not in '0' .. '9' then
529 Error_Msg
530 ("real literal cannot end with point", Scan_Ptr - 1);
531 else
532 Scan_Integer;
533 UI_Num_Value := UI_Int_Value;
534 end if;
535 end loop;
536
537 -- Based literal case. The base is the value we already scanned.
538 -- In the case of colon, we insist that the following character
539 -- is indeed an extended digit or a period. This catches a number
540 -- of common errors, as well as catching the well known tricky
541 -- bug otherwise arising from "x : integer range 1 .. 10:= 6;"
542
543 elsif C = '#'
544 or else (C = ':' and then
545 (Source (Scan_Ptr + 1) = '.'
546 or else
547 Source (Scan_Ptr + 1) in '0' .. '9'
548 or else
549 Source (Scan_Ptr + 1) in 'A' .. 'Z'
550 or else
551 Source (Scan_Ptr + 1) in 'a' .. 'z'))
552 then
5f3ab6fb
AC		 553 if C = ':' then
554 Obsolescent_Check (Scan_Ptr);
555
556 if Warn_On_Obsolescent_Feature then
557 Error_Msg_S
558 ("use of "":"" is an obsolescent feature ('R'M 'J.2(3))?");
559 Error_Msg_S
560 ("\use ""'#"" instead?");
561 end if;
fbf5a39b
AC		 562 end if;
563
5f3ab6fb 564
fbf5a39b
AC		 565 Accumulate_Checksum (C);
566 Base_Char := C;
567 UI_Base := UI_Int_Value;
568
569 if UI_Base < 2 or else UI_Base > 16 then
570 Error_Msg_SC ("base not 2-16");
571 UI_Base := Uint_16;
572 end if;
573
574 Base := UI_To_Int (UI_Base);
575 Scan_Ptr := Scan_Ptr + 1;
576
577 -- Scan out extended integer [. integer]
578
579 C := Source (Scan_Ptr);
580 UI_Int_Value := Uint_0;
581 Scale := 0;
582
583 loop
584 if C in '0' .. '9' then
585 Accumulate_Checksum (C);
586 Extended_Digit_Value :=
587 Int'(Character'Pos (C)) - Int'(Character'Pos ('0'));
588
589 elsif C in 'A' .. 'F' then
590 Accumulate_Checksum (Character'Val (Character'Pos (C) + 32));
591 Extended_Digit_Value :=
592 Int'(Character'Pos (C)) - Int'(Character'Pos ('A')) + 10;
593
594 elsif C in 'a' .. 'f' then
595 Accumulate_Checksum (C);
596 Extended_Digit_Value :=
597 Int'(Character'Pos (C)) - Int'(Character'Pos ('a')) + 10;
598
599 else
600 Error_Msg_S ("extended digit expected");
601 exit;
602 end if;
603
604 if Extended_Digit_Value >= Base then
605 Error_Msg_S ("digit '>= base");
606 end if;
607
608 UI_Int_Value := UI_Int_Value * UI_Base + Extended_Digit_Value;
609 Scale := Scale - 1;
610 Scan_Ptr := Scan_Ptr + 1;
611 C := Source (Scan_Ptr);
612
613 if C = '_' then
614 loop
615 Accumulate_Checksum ('_');
616 Scan_Ptr := Scan_Ptr + 1;
617 C := Source (Scan_Ptr);
618 exit when C /= '_';
619 Error_No_Double_Underline;
620 end loop;
621
622 elsif C = '.' then
623 Accumulate_Checksum ('.');
624
625 if Point_Scanned then
626 Error_Msg_S ("duplicate point ignored");
627 end if;
628
629 Scan_Ptr := Scan_Ptr + 1;
630 C := Source (Scan_Ptr);
631 Point_Scanned := True;
632 Scale := 0;
633
634 elsif C = Base_Char then
635 Accumulate_Checksum (C);
636 Scan_Ptr := Scan_Ptr + 1;
637 exit;
638
639 elsif C = '#' or else C = ':' then
640 Error_Msg_S ("based number delimiters must match");
641 Scan_Ptr := Scan_Ptr + 1;
642 exit;
643
644 elsif not Identifier_Char (C) then
645 if Base_Char = '#' then
646 Error_Msg_S ("missing '#");
647 else
648 Error_Msg_S ("missing ':");
649 end if;
650
651 exit;
652 end if;
653
654 end loop;
655
656 UI_Num_Value := UI_Int_Value;
657 end if;
658
659 -- Scan out exponent
660
661 if not Point_Scanned then
662 Scale := 0;
663 UI_Scale := Uint_0;
664 else
665 UI_Scale := UI_From_Int (Scale);
666 end if;
667
668 if Source (Scan_Ptr) = 'e' or else Source (Scan_Ptr) = 'E' then
669 Accumulate_Checksum ('e');
670 Scan_Ptr := Scan_Ptr + 1;
671 Exponent_Is_Negative := False;
672
673 if Source (Scan_Ptr) = '+' then
674 Accumulate_Checksum ('+');
675 Scan_Ptr := Scan_Ptr + 1;
676
677 elsif Source (Scan_Ptr) = '-' then
678 Accumulate_Checksum ('-');
679
680 if not Point_Scanned then
681 Error_Msg_S
682 ("negative exponent not allowed for integer literal");
683 else
684 Exponent_Is_Negative := True;
685 end if;
686
687 Scan_Ptr := Scan_Ptr + 1;
688 end if;
689
690 UI_Int_Value := Uint_0;
691
692 if Source (Scan_Ptr) in '0' .. '9' then
693 Scan_Integer;
694 else
695 Error_Digit_Expected;
696 end if;
697
698 if Exponent_Is_Negative then
699 UI_Scale := UI_Scale - UI_Int_Value;
700 else
701 UI_Scale := UI_Scale + UI_Int_Value;
702 end if;
703 end if;
704
705 -- Case of real literal to be returned
706
707 if Point_Scanned then
708 Token := Tok_Real_Literal;
709 Real_Literal_Value :=
710 UR_From_Components (
711 Num => UI_Num_Value,
712 Den => -UI_Scale,
713 Rbase => Base);
714
715 -- Case of integer literal to be returned
716
717 else
718 Token := Tok_Integer_Literal;
719
720 if UI_Scale = 0 then
721 Int_Literal_Value := UI_Num_Value;
722
723 -- Avoid doing possibly expensive calculations in cases like
724 -- parsing 163E800_000# when semantics will not be done anyway.
725 -- This is especially useful when parsing garbled input.
726
727 elsif Operating_Mode /= Check_Syntax
728 and then (Serious_Errors_Detected = 0 or else Try_Semantics)
729 then
730 Int_Literal_Value := UI_Num_Value * UI_Base ** UI_Scale;
731
732 else
733 Int_Literal_Value := No_Uint;
734
735 end if;
736
737 end if;
738
6b6fcd3e
AC		 739 Accumulate_Token_Checksum;
740
fbf5a39b
AC		 741 return;
742
743 end Nlit;
744
745 ----------
746 -- Slit --
747 ----------
748
749 procedure Slit is
750
751 Delimiter : Character;
752 -- Delimiter (first character of string)
753
754 C : Character;
755 -- Current source program character
756
757 Code : Char_Code;
758 -- Current character code value
759
760 Err : Boolean;
761 -- Error flag for Scan_Wide call
762
763 procedure Error_Bad_String_Char;
764 -- Signal bad character in string/character literal. On entry
765 -- Scan_Ptr points to the improper character encountered during
766 -- the scan. Scan_Ptr is not modified, so it still points to the bad
767 -- character on return.
768
769 procedure Error_Unterminated_String;
770 -- Procedure called if a line terminator character is encountered
771 -- during scanning a string, meaning that the string is not properly
772 -- terminated.
773
774 procedure Set_String;
775 -- Procedure used to distinguish between string and operator symbol.
776 -- On entry the string has been scanned out, and its characters start
777 -- at Token_Ptr and end one character before Scan_Ptr. On exit Token
778 -- is set to Tok_String_Literal or Tok_Operator_Symbol as
779 -- appropriate, and Token_Node is appropriately initialized.
780 -- In addition, in the operator symbol case, Token_Name is
781 -- appropriately set.
782
783 ---------------------------
784 -- Error_Bad_String_Char --
785 ---------------------------
786
787 procedure Error_Bad_String_Char is
788 C : constant Character := Source (Scan_Ptr);
789
790 begin
791 if C = HT then
792 Error_Msg_S ("horizontal tab not allowed in string");
793
794 elsif C = VT or else C = FF then
795 Error_Msg_S ("format effector not allowed in string");
796
797 elsif C in Upper_Half_Character then
798 Error_Msg_S ("(Ada 83) upper half character not allowed");
799
800 else
801 Error_Msg_S ("control character not allowed in string");
802 end if;
803 end Error_Bad_String_Char;
804
805 -------------------------------
806 -- Error_Unterminated_String --
807 -------------------------------
808
809 procedure Error_Unterminated_String is
810 begin
811 -- An interesting little refinement. Consider the following
812 -- examples:
813
814 -- A := "this is an unterminated string;
815 -- A := "this is an unterminated string &
816 -- P(A, "this is a parameter that didn't get terminated);
817
818 -- We fiddle a little to do slightly better placement in these
819 -- cases also if there is white space at the end of the line we
820 -- place the flag at the start of this white space, not at the
821 -- end. Note that we only have to test for blanks, since tabs
822 -- aren't allowed in strings in the first place and would have
823 -- caused an error message.
824
825 -- Two more cases that we treat specially are:
826
827 -- A := "this string uses the wrong terminator'
828 -- A := "this string uses the wrong terminator' &
829
830 -- In these cases we give a different error message as well
831
832 -- We actually reposition the scan pointer to the point where we
833 -- place the flag in these cases, since it seems a better bet on
834 -- the original intention.
835
836 while Source (Scan_Ptr - 1) = ' '
837 or else Source (Scan_Ptr - 1) = '&'
838 loop
839 Scan_Ptr := Scan_Ptr - 1;
840 Unstore_String_Char;
841 end loop;
842
843 -- Check for case of incorrect string terminator, but single quote
844 -- is not considered incorrect if the opening terminator misused
845 -- a single quote (error message already given).
846
847 if Delimiter /= '''
848 and then Source (Scan_Ptr - 1) = '''
849 then
850 Unstore_String_Char;
851 Error_Msg
852 ("incorrect string terminator character", Scan_Ptr - 1);
853 return;
854 end if;
855
856 if Source (Scan_Ptr - 1) = ';' then
857 Scan_Ptr := Scan_Ptr - 1;
858 Unstore_String_Char;
859
860 if Source (Scan_Ptr - 1) = ')' then
861 Scan_Ptr := Scan_Ptr - 1;
862 Unstore_String_Char;
863 end if;
864 end if;
865
866 Error_Msg_S ("missing string quote");
867 end Error_Unterminated_String;
868
869 ----------------
870 -- Set_String --
871 ----------------
872
873 procedure Set_String is
874 Slen : constant Int := Int (Scan_Ptr - Token_Ptr - 2);
875 C1 : Character;
876 C2 : Character;
877 C3 : Character;
878
879 begin
880 -- Token_Name is currently set to Error_Name. The following
881 -- section of code resets Token_Name to the proper Name_Op_xx
882 -- value if the string is a valid operator symbol, otherwise it is
883 -- left set to Error_Name.
884
885 if Slen = 1 then
886 C1 := Source (Token_Ptr + 1);
887
888 case C1 is
889 when '=' =>
890 Token_Name := Name_Op_Eq;
891
892 when '>' =>
893 Token_Name := Name_Op_Gt;
894
895 when '<' =>
896 Token_Name := Name_Op_Lt;
897
898 when '+' =>
899 Token_Name := Name_Op_Add;
900
901 when '-' =>
902 Token_Name := Name_Op_Subtract;
903
904 when '&' =>
905 Token_Name := Name_Op_Concat;
906
907 when '*' =>
908 Token_Name := Name_Op_Multiply;
909
910 when '/' =>
911 Token_Name := Name_Op_Divide;
912
913 when others =>
914 null;
915 end case;
916
917 elsif Slen = 2 then
918 C1 := Source (Token_Ptr + 1);
919 C2 := Source (Token_Ptr + 2);
920
921 if C1 = '*' and then C2 = '*' then
922 Token_Name := Name_Op_Expon;
923
924 elsif C2 = '=' then
925
926 if C1 = '/' then
927 Token_Name := Name_Op_Ne;
928 elsif C1 = '<' then
929 Token_Name := Name_Op_Le;
930 elsif C1 = '>' then
931 Token_Name := Name_Op_Ge;
932 end if;
933
934 elsif (C1 = 'O' or else C1 = 'o') and then -- OR
935 (C2 = 'R' or else C2 = 'r')
936 then
937 Token_Name := Name_Op_Or;
938 end if;
939
940 elsif Slen = 3 then
941 C1 := Source (Token_Ptr + 1);
942 C2 := Source (Token_Ptr + 2);
943 C3 := Source (Token_Ptr + 3);
944
945 if (C1 = 'A' or else C1 = 'a') and then -- AND
946 (C2 = 'N' or else C2 = 'n') and then
947 (C3 = 'D' or else C3 = 'd')
948 then
949 Token_Name := Name_Op_And;
950
951 elsif (C1 = 'A' or else C1 = 'a') and then -- ABS
952 (C2 = 'B' or else C2 = 'b') and then
953 (C3 = 'S' or else C3 = 's')
954 then
955 Token_Name := Name_Op_Abs;
956
957 elsif (C1 = 'M' or else C1 = 'm') and then -- MOD
958 (C2 = 'O' or else C2 = 'o') and then
959 (C3 = 'D' or else C3 = 'd')
960 then
961 Token_Name := Name_Op_Mod;
962
963 elsif (C1 = 'N' or else C1 = 'n') and then -- NOT
964 (C2 = 'O' or else C2 = 'o') and then
965 (C3 = 'T' or else C3 = 't')
966 then
967 Token_Name := Name_Op_Not;
968
969 elsif (C1 = 'R' or else C1 = 'r') and then -- REM
970 (C2 = 'E' or else C2 = 'e') and then
971 (C3 = 'M' or else C3 = 'm')
972 then
973 Token_Name := Name_Op_Rem;
974
975 elsif (C1 = 'X' or else C1 = 'x') and then -- XOR
976 (C2 = 'O' or else C2 = 'o') and then
977 (C3 = 'R' or else C3 = 'r')
978 then
979 Token_Name := Name_Op_Xor;
980 end if;
981
982 end if;
983
984 -- If it is an operator symbol, then Token_Name is set.
985 -- If it is some other string value, then Token_Name still
986 -- contains Error_Name.
987
988 if Token_Name = Error_Name then
989 Token := Tok_String_Literal;
990
991 else
992 Token := Tok_Operator_Symbol;
993 end if;
994
995 end Set_String;
996
997 ----------
998 -- Slit --
999 ----------
1000
1001 begin
1002 -- On entry, Scan_Ptr points to the opening character of the string
1003 -- which is either a percent, double quote, or apostrophe
1004 -- (single quote). The latter case is an error detected by
1005 -- the character literal circuit.
1006
1007 Delimiter := Source (Scan_Ptr);
1008 Accumulate_Checksum (Delimiter);
1009 Start_String;
1010 Scan_Ptr := Scan_Ptr + 1;
1011
1012 -- Loop to scan out characters of string literal
1013
1014 loop
1015 C := Source (Scan_Ptr);
1016
1017 if C = Delimiter then
1018 Accumulate_Checksum (C);
1019 Scan_Ptr := Scan_Ptr + 1;
1020 exit when Source (Scan_Ptr) /= Delimiter;
1021 Code := Get_Char_Code (C);
1022 Accumulate_Checksum (C);
1023 Scan_Ptr := Scan_Ptr + 1;
1024
1025 else
1026 if C = '"' and then Delimiter = '%' then
1027 Error_Msg_S
1028 ("quote not allowed in percent delimited string");
1029 Code := Get_Char_Code (C);
1030 Scan_Ptr := Scan_Ptr + 1;
1031
1032 elsif (C = ESC
1033 and then
1034 Wide_Character_Encoding_Method
1035 in WC_ESC_Encoding_Method)
1036 or else
1037 (C in Upper_Half_Character
1038 and then
1039 Upper_Half_Encoding)
1040 or else
1041 (C = '['
1042 and then
1043 Source (Scan_Ptr + 1) = '"'
1044 and then
1045 Identifier_Char (Source (Scan_Ptr + 2)))
1046 then
1047 Scan_Wide (Source, Scan_Ptr, Code, Err);
1048 Accumulate_Checksum (Code);
1049
1050 if Err then
1051 Error_Illegal_Wide_Character;
1052 Code := Get_Char_Code (' ');
1053 end if;
1054
1055 else
1056 Accumulate_Checksum (C);
1057
1058 if C not in Graphic_Character then
1059 if C in Line_Terminator then
1060 Error_Unterminated_String;
1061 exit;
1062
1063 elsif C in Upper_Half_Character then
0ab80019 1064 if Ada_Version = Ada_83 then
fbf5a39b
AC		 1065 Error_Bad_String_Char;
1066 end if;
1067
1068 else
1069 Error_Bad_String_Char;
1070 end if;
1071 end if;
1072
1073 Code := Get_Char_Code (C);
1074 Scan_Ptr := Scan_Ptr + 1;
1075 end if;
1076 end if;
1077
1078 Store_String_Char (Code);
1079
1080 if not In_Character_Range (Code) then
1081 Wide_Character_Found := True;
1082 end if;
1083 end loop;
1084
1085 String_Literal_Id := End_String;
1086 Set_String;
1087 return;
1088
1089 end Slit;
1090
1091 -- Start of body of Scan
1092
1093 begin
1094 Prev_Token := Token;
1095 Prev_Token_Ptr := Token_Ptr;
1096 Token_Name := Error_Name;
1097
1098 -- The following loop runs more than once only if a format effector
1099 -- (tab, vertical tab, form feed, line feed, carriage return) is
1100 -- encountered and skipped, or some error situation, such as an
1101 -- illegal character, is encountered.
1102
1103 loop
1104 -- Skip past blanks, loop is opened up for speed
1105
1106 while Source (Scan_Ptr) = ' ' loop
1107
1108 if Source (Scan_Ptr + 1) /= ' ' then
1109 Scan_Ptr := Scan_Ptr + 1;
1110 exit;
1111 end if;
1112
1113 if Source (Scan_Ptr + 2) /= ' ' then
1114 Scan_Ptr := Scan_Ptr + 2;
1115 exit;
1116 end if;
1117
1118 if Source (Scan_Ptr + 3) /= ' ' then
1119 Scan_Ptr := Scan_Ptr + 3;
1120 exit;
1121 end if;
1122
1123 if Source (Scan_Ptr + 4) /= ' ' then
1124 Scan_Ptr := Scan_Ptr + 4;
1125 exit;
1126 end if;
1127
1128 if Source (Scan_Ptr + 5) /= ' ' then
1129 Scan_Ptr := Scan_Ptr + 5;
1130 exit;
1131 end if;
1132
1133 if Source (Scan_Ptr + 6) /= ' ' then
1134 Scan_Ptr := Scan_Ptr + 6;
1135 exit;
1136 end if;
1137
1138 if Source (Scan_Ptr + 7) /= ' ' then
1139 Scan_Ptr := Scan_Ptr + 7;
1140 exit;
1141 end if;
1142
1143 Scan_Ptr := Scan_Ptr + 8;
1144 end loop;
1145
1146 -- We are now at a non-blank character, which is the first character
1147 -- of the token we will scan, and hence the value of Token_Ptr.
1148
1149 Token_Ptr := Scan_Ptr;
1150
1151 -- Here begins the main case statement which transfers control on
1152 -- the basis of the non-blank character we have encountered.
1153
1154 case Source (Scan_Ptr) is
1155
1156 -- Line terminator characters
1157
1158 when CR | LF | FF | VT => Line_Terminator_Case : begin
1159
1160 -- Check line too long
1161
1162 Check_End_Of_Line;
1163
1164 -- Set Token_Ptr, if End_Of_Line is a token, for the case when
1165 -- it is a physical line.
1166
1167 if End_Of_Line_Is_Token then
1168 Token_Ptr := Scan_Ptr;
1169 end if;
1170
1171 declare
1172 Physical : Boolean;
1173
1174 begin
1175 Skip_Line_Terminators (Scan_Ptr, Physical);
1176
1177 -- If we are at start of physical line, update scan pointers
1178 -- to reflect the start of the new line.
1179
1180 if Physical then
1181 Current_Line_Start := Scan_Ptr;
1182 Start_Column := Set_Start_Column;
1183 First_Non_Blank_Location := Scan_Ptr;
1184
1185 -- If End_Of_Line is a token, we return it as it is
1186 -- a physical line.
1187
1188 if End_Of_Line_Is_Token then
1189 Token := Tok_End_Of_Line;
1190 return;
1191 end if;
1192 end if;
1193 end;
1194 end Line_Terminator_Case;
1195
1196 -- Horizontal tab, just skip past it
1197
1198 when HT =>
1199 if Style_Check then Style.Check_HT; end if;
1200 Scan_Ptr := Scan_Ptr + 1;
1201
1202 -- End of file character, treated as an end of file only if it
1203 -- is the last character in the buffer, otherwise it is ignored.
1204
1205 when EOF =>
1206 if Scan_Ptr = Source_Last (Current_Source_File) then
1207 Check_End_Of_Line;
1208 Token := Tok_EOF;
1209 return;
1210
1211 else
1212 Scan_Ptr := Scan_Ptr + 1;
1213 end if;
1214
1215 -- Ampersand
1216
1217 when '&' =>
1218 Accumulate_Checksum ('&');
1219
1220 if Source (Scan_Ptr + 1) = '&' then
1221 Error_Msg_S ("'&'& should be `AND THEN`");
1222 Scan_Ptr := Scan_Ptr + 2;
1223 Token := Tok_And;
1224 return;
1225
1226 else
1227 Scan_Ptr := Scan_Ptr + 1;
1228 Token := Tok_Ampersand;
1229 return;
1230 end if;
1231
1232 -- Asterisk (can be multiplication operator or double asterisk
1233 -- which is the exponentiation compound delimiter).
1234
1235 when '*' =>
1236 Accumulate_Checksum ('*');
1237
1238 if Source (Scan_Ptr + 1) = '*' then
1239 Accumulate_Checksum ('*');
1240 Scan_Ptr := Scan_Ptr + 2;
1241 Token := Tok_Double_Asterisk;
1242 return;
1243
1244 else
1245 Scan_Ptr := Scan_Ptr + 1;
1246 Token := Tok_Asterisk;
1247 return;
1248 end if;
1249
1250 -- Colon, which can either be an isolated colon, or part of an
1251 -- assignment compound delimiter.
1252
1253 when ':' =>
1254 Accumulate_Checksum (':');
1255
1256 if Double_Char_Token ('=') then
1257 Token := Tok_Colon_Equal;
1258 if Style_Check then Style.Check_Colon_Equal; end if;
1259 return;
1260
1261 elsif Source (Scan_Ptr + 1) = '-'
1262 and then Source (Scan_Ptr + 2) /= '-'
1263 then
1264 Token := Tok_Colon_Equal;
1265 Error_Msg (":- should be :=", Scan_Ptr);
1266 Scan_Ptr := Scan_Ptr + 2;
1267 return;
1268
1269 else
1270 Scan_Ptr := Scan_Ptr + 1;
1271 Token := Tok_Colon;
1272 if Style_Check then Style.Check_Colon; end if;
1273 return;
1274 end if;
1275
1276 -- Left parenthesis
1277
1278 when '(' =>
1279 Accumulate_Checksum ('(');
1280 Scan_Ptr := Scan_Ptr + 1;
1281 Token := Tok_Left_Paren;
1282 if Style_Check then Style.Check_Left_Paren; end if;
1283 return;
1284
1285 -- Left bracket
1286
1287 when '[' =>
1288 if Source (Scan_Ptr + 1) = '"' then
1289 Name_Len := 0;
1290 goto Scan_Identifier;
1291
1292 else
1293 Error_Msg_S ("illegal character, replaced by ""(""");
1294 Scan_Ptr := Scan_Ptr + 1;
1295 Token := Tok_Left_Paren;
1296 return;
1297 end if;
1298
1299 -- Left brace
1300
1301 when '{' =>
1302 Error_Msg_S ("illegal character, replaced by ""(""");
1303 Scan_Ptr := Scan_Ptr + 1;
1304 Token := Tok_Left_Paren;
1305 return;
1306
1307 -- Comma
1308
1309 when ',' =>
1310 Accumulate_Checksum (',');
1311 Scan_Ptr := Scan_Ptr + 1;
1312 Token := Tok_Comma;
1313 if Style_Check then Style.Check_Comma; end if;
1314 return;
1315
1316 -- Dot, which is either an isolated period, or part of a double
1317 -- dot compound delimiter sequence. We also check for the case of
1318 -- a digit following the period, to give a better error message.
1319
1320 when '.' =>
1321 Accumulate_Checksum ('.');
1322
1323 if Double_Char_Token ('.') then
1324 Token := Tok_Dot_Dot;
1325 if Style_Check then Style.Check_Dot_Dot; end if;
1326 return;
1327
1328 elsif Source (Scan_Ptr + 1) in '0' .. '9' then
1329 Error_Msg_S ("numeric literal cannot start with point");
1330 Scan_Ptr := Scan_Ptr + 1;
1331
1332 else
1333 Scan_Ptr := Scan_Ptr + 1;
1334 Token := Tok_Dot;
1335 return;
1336 end if;
1337
1338 -- Equal, which can either be an equality operator, or part of the
1339 -- arrow (=>) compound delimiter.
1340
1341 when '=' =>
1342 Accumulate_Checksum ('=');
1343
1344 if Double_Char_Token ('>') then
1345 Token := Tok_Arrow;
1346 if Style_Check then Style.Check_Arrow; end if;
1347 return;
1348
1349 elsif Source (Scan_Ptr + 1) = '=' then
1350 Error_Msg_S ("== should be =");
1351 Scan_Ptr := Scan_Ptr + 1;
1352 end if;
1353
1354 Scan_Ptr := Scan_Ptr + 1;
1355 Token := Tok_Equal;
1356 return;
1357
1358 -- Greater than, which can be a greater than operator, greater than
1359 -- or equal operator, or first character of a right label bracket.
1360
1361 when '>' =>
1362 Accumulate_Checksum ('>');
1363
1364 if Double_Char_Token ('=') then
1365 Token := Tok_Greater_Equal;
1366 return;
1367
1368 elsif Double_Char_Token ('>') then
1369 Token := Tok_Greater_Greater;
1370 return;
1371
1372 else
1373 Scan_Ptr := Scan_Ptr + 1;
1374 Token := Tok_Greater;
1375 return;
1376 end if;
1377
1378 -- Less than, which can be a less than operator, less than or equal
1379 -- operator, or the first character of a left label bracket, or the
1380 -- first character of a box (<>) compound delimiter.
1381
1382 when '<' =>
1383 Accumulate_Checksum ('<');
1384
1385 if Double_Char_Token ('=') then
1386 Token := Tok_Less_Equal;
1387 return;
1388
1389 elsif Double_Char_Token ('>') then
1390 Token := Tok_Box;
1391 if Style_Check then Style.Check_Box; end if;
1392 return;
1393
1394 elsif Double_Char_Token ('<') then
1395 Token := Tok_Less_Less;
1396 return;
1397
1398 else
1399 Scan_Ptr := Scan_Ptr + 1;
1400 Token := Tok_Less;
1401 return;
1402 end if;
1403
1404 -- Minus, which is either a subtraction operator, or the first
1405 -- character of double minus starting a comment
1406
1407 when '-' => Minus_Case : begin
1408 if Source (Scan_Ptr + 1) = '>' then
1409 Error_Msg_S ("invalid token");
1410 Scan_Ptr := Scan_Ptr + 2;
1411 Token := Tok_Arrow;
1412 return;
1413
1414 elsif Source (Scan_Ptr + 1) /= '-' then
1415 Accumulate_Checksum ('-');
1416 Scan_Ptr := Scan_Ptr + 1;
1417 Token := Tok_Minus;
1418 return;
1419
1420 -- Comment
1421
1422 else -- Source (Scan_Ptr + 1) = '-' then
1423 if Style_Check then Style.Check_Comment; end if;
1424 Scan_Ptr := Scan_Ptr + 2;
c45b6ae0 1425 Start_Of_Comment := Scan_Ptr;
fbf5a39b
AC		 1426
1427 -- Loop to scan comment (this loop runs more than once only if
1428 -- a horizontal tab or other non-graphic character is scanned)
1429
1430 loop
1431 -- Scan to non graphic character (opened up for speed)
1432
1433 loop
1434 exit when Source (Scan_Ptr) not in Graphic_Character;
1435 Scan_Ptr := Scan_Ptr + 1;
1436 exit when Source (Scan_Ptr) not in Graphic_Character;
1437 Scan_Ptr := Scan_Ptr + 1;
1438 exit when Source (Scan_Ptr) not in Graphic_Character;
1439 Scan_Ptr := Scan_Ptr + 1;
1440 exit when Source (Scan_Ptr) not in Graphic_Character;
1441 Scan_Ptr := Scan_Ptr + 1;
1442 exit when Source (Scan_Ptr) not in Graphic_Character;
1443 Scan_Ptr := Scan_Ptr + 1;
1444 end loop;
1445
1446 -- Keep going if horizontal tab
1447
1448 if Source (Scan_Ptr) = HT then
1449 if Style_Check then Style.Check_HT; end if;
1450 Scan_Ptr := Scan_Ptr + 1;
1451
1452 -- Terminate scan of comment if line terminator
1453
1454 elsif Source (Scan_Ptr) in Line_Terminator then
1455 exit;
1456
1457 -- Terminate scan of comment if end of file encountered
1458 -- (embedded EOF character or real last character in file)
1459
1460 elsif Source (Scan_Ptr) = EOF then
1461 exit;
1462
1463 -- Keep going if character in 80-FF range, or is ESC. These
1464 -- characters are allowed in comments by RM-2.1(1), 2.7(2).
1465 -- They are allowed even in Ada 83 mode according to the
1466 -- approved AI. ESC was added to the AI in June 93.
1467
1468 elsif Source (Scan_Ptr) in Upper_Half_Character
1469 or else Source (Scan_Ptr) = ESC
1470 then
1471 Scan_Ptr := Scan_Ptr + 1;
1472
1473 -- Otherwise we have an illegal comment character
1474
1475 else
1476 Error_Illegal_Character;
1477 end if;
1478
1479 end loop;
1480
c45b6ae0
AC		 1481 -- Note that, except when comments are tokens, we do NOT
1482 -- execute a return here, instead we fall through to reexecute
1483 -- the scan loop to look for a token.
1484
1485 if Comment_Is_Token then
1486 Name_Len := Integer (Scan_Ptr - Start_Of_Comment);
1487 Name_Buffer (1 .. Name_Len) :=
1488 String (Source (Start_Of_Comment .. Scan_Ptr - 1));
1489 Comment_Id := Name_Find;
1490 Token := Tok_Comment;
1491 return;
1492 end if;
fbf5a39b
AC		 1493 end if;
1494 end Minus_Case;
1495
1496 -- Double quote starting a string literal
1497
1498 when '"' =>
1499 Slit;
1500 Post_Scan;
1501 return;
1502
1503 -- Percent starting a string literal
1504
1505 when '%' =>
5f3ab6fb
AC		 1506 Obsolescent_Check (Token_Ptr);
1507
fbf5a39b
AC		 1508 if Warn_On_Obsolescent_Feature then
1509 Error_Msg_S
1510 ("use of ""'%"" is an obsolescent feature ('R'M 'J.2(4))?");
1511 Error_Msg_S
1512 ("\use """""" instead?");
1513 end if;
1514
1515 Slit;
1516 Post_Scan;
1517 return;
1518
1519 -- Apostrophe. This can either be the start of a character literal,
1520 -- or an isolated apostrophe used in a qualified expression or an
1521 -- attribute. We treat it as a character literal if it does not
1522 -- follow a right parenthesis, identifier, the keyword ALL or
1523 -- a literal. This means that we correctly treat constructs like:
1524
1525 -- A := CHARACTER'('A');
1526
1527 -- Note that RM-2.2(7) does not require a separator between
1528 -- "CHARACTER" and "'" in the above.
1529
1530 when ''' => Char_Literal_Case : declare
1531 Code : Char_Code;
1532 Err : Boolean;
1533
1534 begin
1535 Accumulate_Checksum (''');
1536 Scan_Ptr := Scan_Ptr + 1;
1537
1538 -- Here is where we make the test to distinguish the cases. Treat
1539 -- as apostrophe if previous token is an identifier, right paren
1540 -- or the reserved word "all" (latter case as in A.all'Address)
1541 -- (or the reserved word "project" in project files).
1542 -- Also treat it as apostrophe after a literal (this catches
1543 -- some legitimate cases, like A."abs"'Address, and also gives
1544 -- better error behavior for impossible cases like 123'xxx).
1545
1546 if Prev_Token = Tok_Identifier
1547 or else Prev_Token = Tok_Right_Paren
1548 or else Prev_Token = Tok_All
1549 or else Prev_Token = Tok_Project
1550 or else Prev_Token in Token_Class_Literal
1551 then
1552 Token := Tok_Apostrophe;
1553 if Style_Check then Style.Check_Apostrophe; end if;
1554 return;
1555
1556 -- Otherwise the apostrophe starts a character literal
1557
1558 else
1559 -- Case of wide character literal with ESC or [ encoding
1560
1561 if (Source (Scan_Ptr) = ESC
1562 and then
1563 Wide_Character_Encoding_Method in WC_ESC_Encoding_Method)
1564 or else
1565 (Source (Scan_Ptr) in Upper_Half_Character
1566 and then
1567 Upper_Half_Encoding)
1568 or else
1569 (Source (Scan_Ptr) = '['
1570 and then
1571 Source (Scan_Ptr + 1) = '"')
1572 then
1573 Scan_Wide (Source, Scan_Ptr, Code, Err);
1574 Accumulate_Checksum (Code);
1575
1576 if Err then
1577 Error_Illegal_Wide_Character;
1578 end if;
1579
1580 if Source (Scan_Ptr) /= ''' then
1581 Error_Msg_S ("missing apostrophe");
1582 else
1583 Scan_Ptr := Scan_Ptr + 1;
1584 end if;
1585
1586 -- If we do not find a closing quote in the expected place then
1587 -- assume that we have a misguided attempt at a string literal.
1588
1589 -- However, if previous token is RANGE, then we return an
1590 -- apostrophe instead since this gives better error recovery
1591
1592 elsif Source (Scan_Ptr + 1) /= ''' then
1593
1594 if Prev_Token = Tok_Range then
1595 Token := Tok_Apostrophe;
1596 return;
1597
1598 else
1599 Scan_Ptr := Scan_Ptr - 1;
1600 Error_Msg_S
1601 ("strings are delimited by double quote character");
1602 Slit;
1603 Post_Scan;
1604 return;
1605 end if;
1606
1607 -- Otherwise we have a (non-wide) character literal
1608
1609 else
1610 Accumulate_Checksum (Source (Scan_Ptr));
1611
1612 if Source (Scan_Ptr) not in Graphic_Character then
1613 if Source (Scan_Ptr) in Upper_Half_Character then
0ab80019 1614 if Ada_Version = Ada_83 then
fbf5a39b
AC		 1615 Error_Illegal_Character;
1616 end if;
1617
1618 else
1619 Error_Illegal_Character;
1620 end if;
1621 end if;
1622
1623 Code := Get_Char_Code (Source (Scan_Ptr));
1624 Scan_Ptr := Scan_Ptr + 2;
1625 end if;
1626
1627 -- Fall through here with Scan_Ptr updated past the closing
1628 -- quote, and Code set to the Char_Code value for the literal
1629
1630 Accumulate_Checksum (''');
1631 Token := Tok_Char_Literal;
1632 Set_Character_Literal_Name (Code);
1633 Token_Name := Name_Find;
1634 Character_Code := Code;
1635 Post_Scan;
1636 return;
1637 end if;
1638 end Char_Literal_Case;
1639
1640 -- Right parenthesis
1641
1642 when ')' =>
1643 Accumulate_Checksum (')');
1644 Scan_Ptr := Scan_Ptr + 1;
1645 Token := Tok_Right_Paren;
1646 if Style_Check then Style.Check_Right_Paren; end if;
1647 return;
1648
1649 -- Right bracket or right brace, treated as right paren
1650
1651 when ']' | '}' =>
1652 Error_Msg_S ("illegal character, replaced by "")""");
1653 Scan_Ptr := Scan_Ptr + 1;
1654 Token := Tok_Right_Paren;
1655 return;
1656
1657 -- Slash (can be division operator or first character of not equal)
1658
1659 when '/' =>
1660 Accumulate_Checksum ('/');
1661
1662 if Double_Char_Token ('=') then
1663 Token := Tok_Not_Equal;
1664 return;
1665 else
1666 Scan_Ptr := Scan_Ptr + 1;
1667 Token := Tok_Slash;
1668 return;
1669 end if;
1670
1671 -- Semicolon
1672
1673 when ';' =>
1674 Accumulate_Checksum (';');
1675 Scan_Ptr := Scan_Ptr + 1;
1676 Token := Tok_Semicolon;
1677 if Style_Check then Style.Check_Semicolon; end if;
1678 return;
1679
1680 -- Vertical bar
1681
1682 when '|' => Vertical_Bar_Case : begin
1683 Accumulate_Checksum ('|');
1684
1685 -- Special check for || to give nice message
1686
1687 if Source (Scan_Ptr + 1) = '|' then
1688 Error_Msg_S ("""'|'|"" should be `OR ELSE`");
1689 Scan_Ptr := Scan_Ptr + 2;
1690 Token := Tok_Or;
1691 return;
1692
1693 else
1694 Scan_Ptr := Scan_Ptr + 1;
1695 Token := Tok_Vertical_Bar;
1696 if Style_Check then Style.Check_Vertical_Bar; end if;
1697 return;
1698 end if;
1699 end Vertical_Bar_Case;
1700
1701 -- Exclamation, replacement character for vertical bar
1702
1703 when '!' => Exclamation_Case : begin
1704 Accumulate_Checksum ('!');
5f3ab6fb 1705 Obsolescent_Check (Token_Ptr);
fbf5a39b
AC		 1706
1707 if Warn_On_Obsolescent_Feature then
1708 Error_Msg_S
1709 ("use of ""'!"" is an obsolescent feature ('R'M 'J.2(2))?");
1710 Error_Msg_S
1711 ("\use ""'|"" instead?");
1712 end if;
1713
1714 if Source (Scan_Ptr + 1) = '=' then
1715 Error_Msg_S ("'!= should be /=");
1716 Scan_Ptr := Scan_Ptr + 2;
1717 Token := Tok_Not_Equal;
1718 return;
1719
1720 else
1721 Scan_Ptr := Scan_Ptr + 1;
1722 Token := Tok_Vertical_Bar;
1723 return;
1724 end if;
1725
1726 end Exclamation_Case;
1727
1728 -- Plus
1729
1730 when '+' => Plus_Case : begin
1731 Accumulate_Checksum ('+');
1732 Scan_Ptr := Scan_Ptr + 1;
1733 Token := Tok_Plus;
1734 return;
1735 end Plus_Case;
1736
1737 -- Digits starting a numeric literal
1738
1739 when '0' .. '9' =>
1740 Nlit;
1741
1742 if Identifier_Char (Source (Scan_Ptr)) then
1743 Error_Msg_S
1744 ("delimiter required between literal and identifier");
1745 end if;
1746 Post_Scan;
1747 return;
1748
1749 -- Lower case letters
1750
1751 when 'a' .. 'z' =>
1752 Name_Len := 1;
1753 Name_Buffer (1) := Source (Scan_Ptr);
1754 Accumulate_Checksum (Name_Buffer (1));
1755 Scan_Ptr := Scan_Ptr + 1;
1756 goto Scan_Identifier;
1757
1758 -- Upper case letters
1759
1760 when 'A' .. 'Z' =>
1761 Name_Len := 1;
1762 Name_Buffer (1) :=
1763 Character'Val (Character'Pos (Source (Scan_Ptr)) + 32);
1764 Accumulate_Checksum (Name_Buffer (1));
1765 Scan_Ptr := Scan_Ptr + 1;
1766 goto Scan_Identifier;
1767
1768 -- Underline character
1769
1770 when '_' =>
1771 if Special_Characters ('_') then
1772 Token_Ptr := Scan_Ptr;
1773 Scan_Ptr := Scan_Ptr + 1;
1774 Token := Tok_Special;
1775 Special_Character := '_';
1776 return;
1777 end if;
1778
1779 Error_Msg_S ("identifier cannot start with underline");
1780 Name_Len := 1;
1781 Name_Buffer (1) := '_';
1782 Scan_Ptr := Scan_Ptr + 1;
1783 goto Scan_Identifier;
1784
1785 -- Space (not possible, because we scanned past blanks)
1786
1787 when ' ' =>
1788 raise Program_Error;
1789
1790 -- Characters in top half of ASCII 8-bit chart
1791
1792 when Upper_Half_Character =>
1793
1794 -- Wide character case. Note that Scan_Identifier will issue
1795 -- an appropriate message if wide characters are not allowed
1796 -- in identifiers.
1797
1798 if Upper_Half_Encoding then
1799 Name_Len := 0;
1800 goto Scan_Identifier;
1801
1802 -- Otherwise we have OK Latin-1 character
1803
1804 else
1805 -- Upper half characters may possibly be identifier letters
1806 -- but can never be digits, so Identifier_Char can be used
1807 -- to test for a valid start of identifier character.
1808
1809 if Identifier_Char (Source (Scan_Ptr)) then
1810 Name_Len := 0;
1811 goto Scan_Identifier;
1812 else
1813 Error_Illegal_Character;
1814 end if;
1815 end if;
1816
1817 when ESC =>
1818
1819 -- ESC character, possible start of identifier if wide characters
1820 -- using ESC encoding are allowed in identifiers, which we can
1821 -- tell by looking at the Identifier_Char flag for ESC, which is
1822 -- only true if these conditions are met.
1823
1824 if Identifier_Char (ESC) then
1825 Name_Len := 0;
1826 goto Scan_Identifier;
1827 else
1828 Error_Illegal_Wide_Character;
1829 end if;
1830
1831 -- Invalid control characters
1832
1833 when NUL | SOH | STX | ETX | EOT | ENQ | ACK | BEL | BS | SO |
1834 SI | DLE | DC1 | DC2 | DC3 | DC4 | NAK | SYN | ETB | CAN |
1835 EM | FS | GS | RS | US | DEL
1836 =>
1837 Error_Illegal_Character;
1838
1839 -- Invalid graphic characters
1840
1841 when '#' | '$' | '?' | '@' | '`' | '\' | '^' | '~' =>
1842 -- If Set_Special_Character has been called for this character,
1843 -- set Scans.Special_Character and return a Special token.
1844
1845 if Special_Characters (Source (Scan_Ptr)) then
1846 Token_Ptr := Scan_Ptr;
1847 Token := Tok_Special;
1848 Special_Character := Source (Scan_Ptr);
1849 Scan_Ptr := Scan_Ptr + 1;
1850 return;
1851
1852 -- otherwise, this is an illegal character
1853
1854 else
1855 Error_Illegal_Character;
1856 end if;
1857
1858 -- End switch on non-blank character
1859
1860 end case;
1861
1862 -- End loop past format effectors. The exit from this loop is by
1863 -- executing a return statement following completion of token scan
1864 -- (control never falls out of this loop to the code which follows)
1865
1866 end loop;
1867
1868 -- Identifier scanning routine. On entry, some initial characters
1869 -- of the identifier may have already been stored in Name_Buffer.
1870 -- If so, Name_Len has the number of characters stored. otherwise
1871 -- Name_Len is set to zero on entry.
1872
1873 <<Scan_Identifier>>
1874
1875 -- This loop scans as fast as possible past lower half letters
1876 -- and digits, which we expect to be the most common characters.
1877
1878 loop
1879 if Source (Scan_Ptr) in 'a' .. 'z'
1880 or else Source (Scan_Ptr) in '0' .. '9'
1881 then
1882 Name_Buffer (Name_Len + 1) := Source (Scan_Ptr);
1883 Accumulate_Checksum (Source (Scan_Ptr));
1884
1885 elsif Source (Scan_Ptr) in 'A' .. 'Z' then
1886 Name_Buffer (Name_Len + 1) :=
1887 Character'Val (Character'Pos (Source (Scan_Ptr)) + 32);
1888 Accumulate_Checksum (Name_Buffer (Name_Len + 1));
1889 else
1890 exit;
1891 end if;
1892
1893 -- Open out the loop a couple of times for speed
1894
1895 if Source (Scan_Ptr + 1) in 'a' .. 'z'
1896 or else Source (Scan_Ptr + 1) in '0' .. '9'
1897 then
1898 Name_Buffer (Name_Len + 2) := Source (Scan_Ptr + 1);
1899 Accumulate_Checksum (Source (Scan_Ptr + 1));
1900
1901 elsif Source (Scan_Ptr + 1) in 'A' .. 'Z' then
1902 Name_Buffer (Name_Len + 2) :=
1903 Character'Val (Character'Pos (Source (Scan_Ptr + 1)) + 32);
1904 Accumulate_Checksum (Name_Buffer (Name_Len + 2));
1905
1906 else
1907 Scan_Ptr := Scan_Ptr + 1;
1908 Name_Len := Name_Len + 1;
1909 exit;
1910 end if;
1911
1912 if Source (Scan_Ptr + 2) in 'a' .. 'z'
1913 or else Source (Scan_Ptr + 2) in '0' .. '9'
1914 then
1915 Name_Buffer (Name_Len + 3) := Source (Scan_Ptr + 2);
1916 Accumulate_Checksum (Source (Scan_Ptr + 2));
1917
1918 elsif Source (Scan_Ptr + 2) in 'A' .. 'Z' then
1919 Name_Buffer (Name_Len + 3) :=
1920 Character'Val (Character'Pos (Source (Scan_Ptr + 2)) + 32);
1921 Accumulate_Checksum (Name_Buffer (Name_Len + 3));
1922 else
1923 Scan_Ptr := Scan_Ptr + 2;
1924 Name_Len := Name_Len + 2;
1925 exit;
1926 end if;
1927
1928 if Source (Scan_Ptr + 3) in 'a' .. 'z'
1929 or else Source (Scan_Ptr + 3) in '0' .. '9'
1930 then
1931 Name_Buffer (Name_Len + 4) := Source (Scan_Ptr + 3);
1932 Accumulate_Checksum (Source (Scan_Ptr + 3));
1933
1934 elsif Source (Scan_Ptr + 3) in 'A' .. 'Z' then
1935 Name_Buffer (Name_Len + 4) :=
1936 Character'Val (Character'Pos (Source (Scan_Ptr + 3)) + 32);
1937 Accumulate_Checksum (Name_Buffer (Name_Len + 4));
1938
1939 else
1940 Scan_Ptr := Scan_Ptr + 3;
1941 Name_Len := Name_Len + 3;
1942 exit;
1943 end if;
1944
1945 Scan_Ptr := Scan_Ptr + 4;
1946 Name_Len := Name_Len + 4;
1947 end loop;
1948
1949 -- If we fall through, then we have encountered either an underline
1950 -- character, or an extended identifier character (i.e. one from the
1951 -- upper half), or a wide character, or an identifier terminator.
1952 -- The initial test speeds us up in the most common case where we
1953 -- have an identifier terminator. Note that ESC is an identifier
1954 -- character only if a wide character encoding method that uses
1955 -- ESC encoding is active, so if we find an ESC character we know
1956 -- that we have a wide character.
1957
1958 if Identifier_Char (Source (Scan_Ptr)) then
1959
1960 -- Case of underline
1961
1962 if Source (Scan_Ptr) = '_' then
1963 Accumulate_Checksum ('_');
1964
1965 -- Check error case of identifier ending with underscore
1966 -- In this case we ignore the underscore and do not store it.
1967
1968 if not Identifier_Char (Source (Scan_Ptr + 1)) then
1969 Error_Msg_S ("identifier cannot end with underline");
1970 Scan_Ptr := Scan_Ptr + 1;
1971
1972 -- Check error case of two underscores. In this case we do
1973 -- not store the first underscore (we will store the second)
1974
1975 elsif Source (Scan_Ptr + 1) = '_' then
1976 Error_No_Double_Underline;
1977
1978 -- Normal case of legal underscore
1979
1980 else
1981 Name_Len := Name_Len + 1;
1982 Name_Buffer (Name_Len) := '_';
1983 end if;
1984
1985 Scan_Ptr := Scan_Ptr + 1;
1986 goto Scan_Identifier;
1987
1988 -- Upper half character
1989
1990 elsif Source (Scan_Ptr) in Upper_Half_Character
1991 and then not Upper_Half_Encoding
1992 then
1993 Accumulate_Checksum (Source (Scan_Ptr));
1994 Store_Encoded_Character
1995 (Get_Char_Code (Fold_Lower (Source (Scan_Ptr))));
1996 Scan_Ptr := Scan_Ptr + 1;
1997 goto Scan_Identifier;
1998
1999 -- Left bracket not followed by a quote terminates an identifier.
2000 -- This is an error, but we don't want to give a junk error msg
2001 -- about wide characters in this case!
2002
2003 elsif Source (Scan_Ptr) = '['
2004 and then Source (Scan_Ptr + 1) /= '"'
2005 then
2006 null;
2007
2008 -- We know we have a wide character encoding here (the current
2009 -- character is either ESC, left bracket, or an upper half
2010 -- character depending on the encoding method).
2011
2012 else
2013 -- Scan out the wide character and insert the appropriate
2014 -- encoding into the name table entry for the identifier.
2015
2016 declare
2017 Sptr : constant Source_Ptr := Scan_Ptr;
2018 Code : Char_Code;
2019 Err : Boolean;
2020 Chr : Character;
2021
2022 begin
2023 Scan_Wide (Source, Scan_Ptr, Code, Err);
2024
2025 -- If error, signal error
2026
2027 if Err then
2028 Error_Illegal_Wide_Character;
2029
2030 -- If the character scanned is a normal identifier
2031 -- character, then we treat it that way.
2032
2033 elsif In_Character_Range (Code)
2034 and then Identifier_Char (Get_Character (Code))
2035 then
2036 Chr := Get_Character (Code);
2037 Accumulate_Checksum (Chr);
2038 Store_Encoded_Character
2039 (Get_Char_Code (Fold_Lower (Chr)));
2040
2041 -- Character is not normal identifier character, store
2042 -- it in encoded form.
2043
2044 else
2045 Accumulate_Checksum (Code);
2046 Store_Encoded_Character (Code);
2047
2048 -- Make sure we are allowing wide characters in
2049 -- identifiers. Note that we allow wide character
2050 -- notation for an OK identifier character. This
2051 -- in particular allows bracket or other notation
2052 -- to be used for upper half letters.
2053
5f3ab6fb
AC		 2054 -- Wide characters are always allowed in Ada 2005
2055
2056 if Identifier_Character_Set /= 'w'
2057 and then Ada_Version < Ada_05
2058 then
fbf5a39b
AC		 2059 Error_Msg
2060 ("wide character not allowed in identifier", Sptr);
2061 end if;
2062 end if;
2063 end;
2064
2065 goto Scan_Identifier;
2066 end if;
2067 end if;
2068
2069 -- Scan of identifier is complete. The identifier is stored in
2070 -- Name_Buffer, and Scan_Ptr points past the last character.
2071
2072 Token_Name := Name_Find;
2073
2074 -- Here is where we check if it was a keyword
2075
2076 if Get_Name_Table_Byte (Token_Name) /= 0
0ab80019
AC		 2077 and then (Ada_Version >= Ada_95
2078 or else Token_Name not in Ada_95_Reserved_Words)
fbf5a39b
AC		 2079 then
2080 Token := Token_Type'Val (Get_Name_Table_Byte (Token_Name));
2081
2082 -- Deal with possible style check for non-lower case keyword,
2083 -- but we don't treat ACCESS, DELTA, DIGITS, RANGE as keywords
2084 -- for this purpose if they appear as attribute designators.
2085 -- Actually we only check the first character for speed.
2086
2087 if Style_Check
2088 and then Source (Token_Ptr) <= 'Z'
2089 and then (Prev_Token /= Tok_Apostrophe
2090 or else
2091 (Token /= Tok_Access
2092 and then Token /= Tok_Delta
2093 and then Token /= Tok_Digits
2094 and then Token /= Tok_Range))
2095 then
2096 Style.Non_Lower_Case_Keyword;
2097 end if;
2098
2099 -- We must reset Token_Name since this is not an identifier
2100 -- and if we leave Token_Name set, the parser gets confused
2101 -- because it thinks it is dealing with an identifier instead
2102 -- of the corresponding keyword.
2103
2104 Token_Name := No_Name;
6b6fcd3e 2105 Accumulate_Token_Checksum;
fbf5a39b
AC		 2106 return;
2107
2108 -- It is an identifier after all
2109
2110 else
2111 Token := Tok_Identifier;
6b6fcd3e 2112 Accumulate_Token_Checksum;
fbf5a39b
AC		 2113 Post_Scan;
2114 return;
2115 end if;
2116 end Scan;
6b6fcd3e 2117
c45b6ae0
AC		 2118 --------------------------
2119 -- Set_Comment_As_Token --
2120 --------------------------
2121
2122 procedure Set_Comment_As_Token (Value : Boolean) is
2123 begin
2124 Comment_Is_Token := Value;
2125 end Set_Comment_As_Token;
fbf5a39b
AC		 2126
2127 ------------------------------
2128 -- Set_End_Of_Line_As_Token --
2129 ------------------------------
2130
2131 procedure Set_End_Of_Line_As_Token (Value : Boolean) is
2132 begin
2133 End_Of_Line_Is_Token := Value;
2134 end Set_End_Of_Line_As_Token;
2135
2136 ---------------------------
2137 -- Set_Special_Character --
2138 ---------------------------
2139
2140 procedure Set_Special_Character (C : Character) is
2141 begin
2142 case C is
2143 when '#' | '$' | '_' | '?' | '@' | '`' | '\' | '^' | '~' =>
2144 Special_Characters (C) := True;
2145
2146 when others =>
2147 null;
2148 end case;
2149 end Set_Special_Character;
2150
2151 ----------------------
2152 -- Set_Start_Column --
2153 ----------------------
2154
2155 -- Note: it seems at first glance a little expensive to compute this value
2156 -- for every source line (since it is certainly not used for all source
2157 -- lines). On the other hand, it doesn't take much more work to skip past
2158 -- the initial white space on the line counting the columns than it would
2159 -- to scan past the white space using the standard scanning circuits.
2160
2161 function Set_Start_Column return Column_Number is
2162 Start_Column : Column_Number := 0;
2163
2164 begin
2165 -- Outer loop scans past horizontal tab characters
2166
2167 Tabs_Loop : loop
2168
2169 -- Inner loop scans past blanks as fast as possible, bumping Scan_Ptr
2170 -- past the blanks and adjusting Start_Column to account for them.
2171
2172 Blanks_Loop : loop
2173 if Source (Scan_Ptr) = ' ' then
2174 if Source (Scan_Ptr + 1) = ' ' then
2175 if Source (Scan_Ptr + 2) = ' ' then
2176 if Source (Scan_Ptr + 3) = ' ' then
2177 if Source (Scan_Ptr + 4) = ' ' then
2178 if Source (Scan_Ptr + 5) = ' ' then
2179 if Source (Scan_Ptr + 6) = ' ' then
2180 Scan_Ptr := Scan_Ptr + 7;
2181 Start_Column := Start_Column + 7;
2182 else
2183 Scan_Ptr := Scan_Ptr + 6;
2184 Start_Column := Start_Column + 6;
2185 exit Blanks_Loop;
2186 end if;
2187 else
2188 Scan_Ptr := Scan_Ptr + 5;
2189 Start_Column := Start_Column + 5;
2190 exit Blanks_Loop;
2191 end if;
2192 else
2193 Scan_Ptr := Scan_Ptr + 4;
2194 Start_Column := Start_Column + 4;
2195 exit Blanks_Loop;
2196 end if;
2197 else
2198 Scan_Ptr := Scan_Ptr + 3;
2199 Start_Column := Start_Column + 3;
2200 exit Blanks_Loop;
2201 end if;
2202 else
2203 Scan_Ptr := Scan_Ptr + 2;
2204 Start_Column := Start_Column + 2;
2205 exit Blanks_Loop;
2206 end if;
2207 else
2208 Scan_Ptr := Scan_Ptr + 1;
2209 Start_Column := Start_Column + 1;
2210 exit Blanks_Loop;
2211 end if;
2212 else
2213 exit Blanks_Loop;
2214 end if;
2215 end loop Blanks_Loop;
2216
2217 -- Outer loop keeps going only if a horizontal tab follows
2218
2219 if Source (Scan_Ptr) = HT then
2220 if Style_Check then Style.Check_HT; end if;
2221 Scan_Ptr := Scan_Ptr + 1;
2222 Start_Column := (Start_Column / 8) * 8 + 8;
2223 else
2224 exit Tabs_Loop;
2225 end if;
2226
2227 end loop Tabs_Loop;
2228
2229 return Start_Column;
2230 end Set_Start_Column;
2231
2232end Scng;
Mirror of https://gcc.gnu.org/git/gcc.git