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

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [scng.adb] - Blame information for rev 281

Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

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