OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [scng.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.