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