OSDN Git Service

2007-12-06 Robert Dewar <dewar@adacore.com>
[pf3gnuchains/gcc-fork.git] / gcc / ada / par-util.adb
1 ------------------------------------------------------------------------------
2 --                                                                          --
3 --                         GNAT COMPILER COMPONENTS                         --
4 --                                                                          --
5 --                             P A R . U T I L                              --
6 --                                                                          --
7 --                                 B o d y                                  --
8 --                                                                          --
9 --          Copyright (C) 1992-2007, 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 Namet.Sp; use Namet.Sp;
28 with Stylesw;  use Stylesw;
29 with Uintp;    use Uintp;
30
31 with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;
32
33 separate (Par)
34 package body Util is
35
36    ---------------------
37    -- Bad_Spelling_Of --
38    ---------------------
39
40    function Bad_Spelling_Of (T : Token_Type) return Boolean is
41       Tname : constant String := Token_Type'Image (T);
42       --  Characters of token name
43
44       S : String (1 .. Tname'Last - 4);
45       --  Characters of token name folded to lower case, omitting TOK_ at start
46
47       M1 : String (1 .. 42) := "incorrect spelling of keyword ************";
48       M2 : String (1 .. 44) := "illegal abbreviation of keyword ************";
49       --  Buffers used to construct error message
50
51       P1 : constant := 30;
52       P2 : constant := 32;
53       --  Starting subscripts in M1, M2 for keyword name
54
55       SL : constant Natural := S'Length;
56       --  Length of expected token name excluding TOK_ at start
57
58    begin
59       if Token /= Tok_Identifier then
60          return False;
61       end if;
62
63       for J in S'Range loop
64          S (J) := Fold_Lower (Tname (J + 4));
65       end loop;
66
67       Get_Name_String (Token_Name);
68
69       --  A special check for case of PROGRAM used for PROCEDURE
70
71       if T = Tok_Procedure
72         and then Name_Len = 7
73         and then Name_Buffer (1 .. 7) = "program"
74       then
75          Error_Msg_SC ("PROCEDURE expected");
76          Token := T;
77          return True;
78
79       --  A special check for an illegal abbrevation
80
81       elsif Name_Len < S'Length
82         and then Name_Len >= 4
83         and then Name_Buffer (1 .. Name_Len) = S (1 .. Name_Len)
84       then
85          for J in 1 .. S'Last loop
86             M2 (P2 + J - 1) := Fold_Upper (S (J));
87          end loop;
88
89          Error_Msg_SC (M2 (1 .. P2 - 1 + S'Last));
90          Token := T;
91          return True;
92       end if;
93
94       --  Now we go into the full circuit to check for a misspelling
95
96       --  Never consider something a misspelling if either the actual or
97       --  expected string is less than 3 characters (before this check we
98       --  used to consider i to be a misspelled if in some cases!)
99
100       if SL < 3 or else Name_Len < 3 then
101          return False;
102
103       --  Special case: prefix matches, i.e. the leading characters of the
104       --  token that we have exactly match the required keyword. If there
105       --  are at least two characters left over, assume that we have a case
106       --  of two keywords joined together which should not be joined.
107
108       elsif Name_Len > SL + 1
109         and then S = Name_Buffer (1 .. SL)
110       then
111          Scan_Ptr := Token_Ptr + S'Length;
112          Error_Msg_S ("missing space");
113          Token := T;
114          return True;
115       end if;
116
117       if Is_Bad_Spelling_Of (Name_Buffer (1 .. Name_Len), S) then
118          for J in 1 .. S'Last loop
119             M1 (P1 + J - 1) := Fold_Upper (S (J));
120          end loop;
121
122          Error_Msg_SC (M1 (1 .. P1 - 1 + S'Last));
123          Token := T;
124          return True;
125
126       else
127          return False;
128       end if;
129    end Bad_Spelling_Of;
130
131    ----------------------
132    -- Check_95_Keyword --
133    ----------------------
134
135    --  On entry, the caller has checked that current token is an identifier
136    --  whose name matches the name of the 95 keyword New_Tok.
137
138    procedure Check_95_Keyword (Token_95, Next : Token_Type) is
139       Scan_State : Saved_Scan_State;
140
141    begin
142       Save_Scan_State (Scan_State); -- at identifier/keyword
143       Scan; -- past identifier/keyword
144
145       if Token = Next then
146          Restore_Scan_State (Scan_State); -- to identifier
147          Error_Msg_Name_1 := Token_Name;
148          Error_Msg_SC ("(Ada 83) keyword* cannot be used!");
149          Token := Token_95;
150       else
151          Restore_Scan_State (Scan_State); -- to identifier
152       end if;
153    end Check_95_Keyword;
154
155    ----------------------
156    -- Check_Bad_Layout --
157    ----------------------
158
159    procedure Check_Bad_Layout is
160    begin
161       if Style.RM_Column_Check and then Token_Is_At_Start_Of_Line
162         and then Start_Column <= Scope.Table (Scope.Last).Ecol
163       then
164          Error_Msg_BC ("(style) incorrect layout");
165       end if;
166    end Check_Bad_Layout;
167
168    --------------------------
169    -- Check_Misspelling_Of --
170    --------------------------
171
172    procedure Check_Misspelling_Of (T : Token_Type) is
173    begin
174       if Bad_Spelling_Of (T) then
175          null;
176       end if;
177    end Check_Misspelling_Of;
178
179    --------------------------
180    -- Check_No_Right_Paren --
181    --------------------------
182
183    procedure Check_No_Right_Paren is
184    begin
185       if Token = Tok_Right_Paren then
186          Error_Msg_SC ("unexpected right parenthesis");
187          Scan; -- past unexpected right paren
188       end if;
189    end Check_No_Right_Paren;
190
191    -----------------------------
192    -- Check_Simple_Expression --
193    -----------------------------
194
195    procedure Check_Simple_Expression (E : Node_Id) is
196    begin
197       if Expr_Form = EF_Non_Simple then
198          Error_Msg_N ("this expression must be parenthesized", E);
199       end if;
200    end Check_Simple_Expression;
201
202    ---------------------------------------
203    -- Check_Simple_Expression_In_Ada_83 --
204    ---------------------------------------
205
206    procedure Check_Simple_Expression_In_Ada_83 (E : Node_Id) is
207    begin
208       if Expr_Form = EF_Non_Simple then
209          if Ada_Version = Ada_83 then
210             Error_Msg_N ("(Ada 83) this expression must be parenthesized!", E);
211          end if;
212       end if;
213    end Check_Simple_Expression_In_Ada_83;
214
215    ------------------------
216    -- Check_Subtype_Mark --
217    ------------------------
218
219    function Check_Subtype_Mark (Mark : Node_Id) return Node_Id is
220    begin
221       if Nkind (Mark) = N_Identifier
222         or else Nkind (Mark) = N_Selected_Component
223         or else (Nkind (Mark) = N_Attribute_Reference
224                   and then Is_Type_Attribute_Name (Attribute_Name (Mark)))
225         or else Mark = Error
226       then
227          return Mark;
228       else
229          Error_Msg ("subtype mark expected", Sloc (Mark));
230          return Error;
231       end if;
232    end Check_Subtype_Mark;
233
234    -------------------
235    -- Comma_Present --
236    -------------------
237
238    function Comma_Present return Boolean is
239       Scan_State  : Saved_Scan_State;
240       Paren_Count : Nat;
241
242    begin
243       --  First check, if a comma is present, then a comma is present!
244
245       if Token = Tok_Comma then
246          T_Comma;
247          return True;
248
249       --  If we have a right paren, then that is taken as ending the list
250       --  i.e. no comma is present.
251
252       elsif Token = Tok_Right_Paren then
253          return False;
254
255       --  If pragmas, then get rid of them and make a recursive call
256       --  to process what follows these pragmas.
257
258       elsif Token = Tok_Pragma then
259          P_Pragmas_Misplaced;
260          return Comma_Present;
261
262       --  At this stage we have an error, and the goal is to decide on whether
263       --  or not we should diagnose an error and report a (non-existent)
264       --  comma as being present, or simply to report no comma is present
265
266       --  If we are a semicolon, then the question is whether we have a missing
267       --  right paren, or whether the semicolon should have been a comma. To
268       --  guess the right answer, we scan ahead keeping track of the paren
269       --  level, looking for a clue that helps us make the right decision.
270
271       --  This approach is highly accurate in the single error case, and does
272       --  not make bad mistakes in the multiple error case (indeed we can't
273       --  really make a very bad decision at this point in any case).
274
275       elsif Token = Tok_Semicolon then
276          Save_Scan_State (Scan_State);
277          Scan; -- past semicolon
278
279          --  Check for being followed by identifier => which almost certainly
280          --  means we are still in a parameter list and the comma should have
281          --  been a semicolon (such a sequence could not follow a semicolon)
282
283          if Token = Tok_Identifier then
284             Scan;
285
286             if Token = Tok_Arrow then
287                goto Assume_Comma;
288             end if;
289          end if;
290
291          --  If that test didn't work, loop ahead looking for a comma or
292          --  semicolon at the same parenthesis level. Always remember that
293          --  we can't go badly wrong in an error situation like this!
294
295          Paren_Count := 0;
296
297          --  Here is the look ahead loop, Paren_Count tells us whether the
298          --  token we are looking at is at the same paren level as the
299          --  suspicious semicolon that we are trying to figure out.
300
301          loop
302
303             --  If we hit another semicolon or an end of file, and we have
304             --  not seen a right paren or another comma on the way, then
305             --  probably the semicolon did end the list. Indeed that is
306             --  certainly the only single error correction possible here.
307
308             if Token = Tok_Semicolon or else Token = Tok_EOF then
309                Restore_Scan_State (Scan_State);
310                return False;
311
312             --  A comma at the same paren level as the semicolon is a strong
313             --  indicator that the semicolon should have been a comma, indeed
314             --  again this is the only possible single error correction.
315
316             elsif Token = Tok_Comma then
317                exit when Paren_Count = 0;
318
319             --  A left paren just bumps the paren count
320
321             elsif Token = Tok_Left_Paren then
322                Paren_Count := Paren_Count + 1;
323
324             --  A right paren that is at the same paren level as the semicolon
325             --  also means that the only possible single error correction is
326             --  to assume that the semicolon should have been a comma. If we
327             --  are not at the same paren level, then adjust the paren level.
328
329             elsif Token = Tok_Right_Paren then
330                exit when Paren_Count = 0;
331                Paren_Count := Paren_Count - 1;
332             end if;
333
334             --  Keep going, we haven't made a decision yet
335
336             Scan;
337          end loop;
338
339          --  If we fall through the loop, it means that we found a terminating
340          --  right paren or another comma. In either case it is reasonable to
341          --  assume that the semicolon was really intended to be a comma. Also
342          --  come here for the identifier arrow case.
343
344          <<Assume_Comma>>
345             Restore_Scan_State (Scan_State);
346             Error_Msg_SC (""";"" illegal here, replaced by "",""");
347             Scan; -- past the semicolon
348             return True;
349
350       --  If we are not at semicolon or a right paren, then we base the
351       --  decision on whether or not the next token can be part of an
352       --  expression. If not, then decide that no comma is present (the
353       --  caller will eventually generate a missing right parent message)
354
355       elsif Token in Token_Class_Eterm then
356          return False;
357
358       --  Otherwise we assume a comma is present, even if none is present,
359       --  since the next token must be part of an expression, so if we were
360       --  at the end of the list, then there is more than one error present.
361
362       else
363          T_Comma; -- to give error
364          return True;
365       end if;
366    end Comma_Present;
367
368    -----------------------
369    -- Discard_Junk_List --
370    -----------------------
371
372    procedure Discard_Junk_List (L : List_Id) is
373       pragma Warnings (Off, L);
374    begin
375       null;
376    end Discard_Junk_List;
377
378    -----------------------
379    -- Discard_Junk_Node --
380    -----------------------
381
382    procedure Discard_Junk_Node (N : Node_Id) is
383       pragma Warnings (Off, N);
384    begin
385       null;
386    end Discard_Junk_Node;
387
388    ------------
389    -- Ignore --
390    ------------
391
392    procedure Ignore (T : Token_Type) is
393    begin
394       if Token = T then
395          if T = Tok_Comma then
396             Error_Msg_SC ("unexpected "","" ignored");
397
398          elsif T = Tok_Left_Paren then
399             Error_Msg_SC ("unexpected ""("" ignored");
400
401          elsif T = Tok_Right_Paren then
402             Error_Msg_SC ("unexpected "")"" ignored");
403
404          elsif T = Tok_Semicolon then
405             Error_Msg_SC ("unexpected "";"" ignored");
406
407          else
408             declare
409                Tname : constant String := Token_Type'Image (Token);
410                Msg   : String := "unexpected keyword ????????????????????????";
411
412             begin
413                --  Loop to copy characters of keyword name (ignoring Tok_)
414
415                for J in 5 .. Tname'Last loop
416                   Msg (J + 14) := Fold_Upper (Tname (J));
417                end loop;
418
419                Msg (Tname'Last + 15 .. Tname'Last + 22) := " ignored";
420                Error_Msg_SC (Msg (1 .. Tname'Last + 22));
421             end;
422          end if;
423
424          Scan; -- Scan past ignored token
425       end if;
426    end Ignore;
427
428    ----------------------------
429    -- Is_Reserved_Identifier --
430    ----------------------------
431
432    function Is_Reserved_Identifier (C : Id_Check := None) return Boolean is
433    begin
434       if not Is_Reserved_Keyword (Token) then
435          return False;
436
437       else
438          declare
439             Ident_Casing : constant Casing_Type :=
440                              Identifier_Casing (Current_Source_File);
441
442             Key_Casing   : constant Casing_Type :=
443                              Keyword_Casing (Current_Source_File);
444
445          begin
446             --  If the casing of identifiers and keywords is different in
447             --  this source file, and the casing of this token matches the
448             --  keyword casing, then we return False, since it is pretty
449             --  clearly intended to be a keyword.
450
451             if Ident_Casing = Unknown
452               or else Key_Casing = Unknown
453               or else Ident_Casing = Key_Casing
454               or else Determine_Token_Casing /= Key_Casing
455             then
456                return True;
457
458             --  Here we have a keyword written clearly with keyword casing.
459             --  In default mode, we would not be willing to consider this as
460             --  a reserved identifier, but if C is set, we may still accept it
461
462             elsif C /= None then
463                declare
464                   Scan_State  : Saved_Scan_State;
465                   OK_Next_Tok : Boolean;
466
467                begin
468                   Save_Scan_State (Scan_State);
469                   Scan;
470
471                   if Token_Is_At_Start_Of_Line then
472                      return False;
473                   end if;
474
475                   case C is
476                      when None =>
477                         raise Program_Error;
478
479                      when C_Comma_Right_Paren =>
480                         OK_Next_Tok :=
481                           Token = Tok_Comma or else Token = Tok_Right_Paren;
482
483                      when C_Comma_Colon =>
484                         OK_Next_Tok :=
485                           Token = Tok_Comma or else Token = Tok_Colon;
486
487                      when C_Do =>
488                         OK_Next_Tok :=
489                           Token = Tok_Do;
490
491                      when C_Dot =>
492                         OK_Next_Tok :=
493                           Token = Tok_Dot;
494
495                      when C_Greater_Greater =>
496                         OK_Next_Tok :=
497                           Token = Tok_Greater_Greater;
498
499                      when C_In =>
500                         OK_Next_Tok :=
501                           Token = Tok_In;
502
503                      when C_Is =>
504                         OK_Next_Tok :=
505                           Token = Tok_Is;
506
507                      when C_Left_Paren_Semicolon =>
508                         OK_Next_Tok :=
509                           Token = Tok_Left_Paren or else Token = Tok_Semicolon;
510
511                      when C_Use =>
512                         OK_Next_Tok :=
513                           Token = Tok_Use;
514
515                      when C_Vertical_Bar_Arrow =>
516                         OK_Next_Tok :=
517                           Token = Tok_Vertical_Bar or else Token = Tok_Arrow;
518                   end case;
519
520                   Restore_Scan_State (Scan_State);
521
522                   if OK_Next_Tok then
523                      return True;
524                   end if;
525                end;
526             end if;
527          end;
528       end if;
529
530       --  If we fall through it is not a reserved identifier
531
532       return False;
533    end Is_Reserved_Identifier;
534
535    ----------------------
536    -- Merge_Identifier --
537    ----------------------
538
539    procedure Merge_Identifier (Prev : Node_Id; Nxt : Token_Type) is
540    begin
541       if Token /= Tok_Identifier then
542          return;
543       end if;
544
545       declare
546          S : Saved_Scan_State;
547          T : Token_Type;
548
549       begin
550          Save_Scan_State (S);
551          Scan;
552          T := Token;
553          Restore_Scan_State (S);
554
555          if T /= Nxt then
556             return;
557          end if;
558       end;
559
560       --  Check exactly one space between identifiers
561
562       if Source (Token_Ptr - 1) /= ' '
563         or else Int (Token_Ptr) /=
564                   Int (Prev_Token_Ptr) + Length_Of_Name (Chars (Prev)) + 1
565       then
566          return;
567       end if;
568
569       --  Do the merge
570
571       Get_Name_String (Chars (Token_Node));
572
573       declare
574          Buf : constant String (1 .. Name_Len) :=
575                  Name_Buffer (1 .. Name_Len);
576
577       begin
578          Get_Name_String (Chars (Prev));
579          Add_Char_To_Name_Buffer ('_');
580          Add_Str_To_Name_Buffer (Buf);
581          Set_Chars (Prev, Name_Find);
582       end;
583
584       Error_Msg_Node_1 := Prev;
585       Error_Msg_SC
586         ("unexpected identifier, possibly & was meant here");
587       Scan;
588    end Merge_Identifier;
589
590    -------------------
591    -- Next_Token_Is --
592    -------------------
593
594    function Next_Token_Is (Tok : Token_Type) return Boolean is
595       Scan_State : Saved_Scan_State;
596       Result     : Boolean;
597    begin
598       Save_Scan_State (Scan_State);
599       Scan;
600       Result := (Token = Tok);
601       Restore_Scan_State (Scan_State);
602       return Result;
603    end Next_Token_Is;
604
605    -------------------
606    -- No_Constraint --
607    -------------------
608
609    procedure No_Constraint is
610    begin
611       if Token in Token_Class_Consk then
612          Error_Msg_SC ("constraint not allowed here");
613          Discard_Junk_Node (P_Constraint_Opt);
614       end if;
615    end No_Constraint;
616
617    ---------------------
618    -- Pop_Scope_Stack --
619    ---------------------
620
621    procedure Pop_Scope_Stack is
622    begin
623       pragma Assert (Scope.Last > 0);
624       Scope.Decrement_Last;
625
626       if Debug_Flag_P then
627          Error_Msg_Uint_1 := UI_From_Int (Scope.Last);
628          Error_Msg_SC ("decrement scope stack ptr, new value = ^!");
629       end if;
630    end Pop_Scope_Stack;
631
632    ----------------------
633    -- Push_Scope_Stack --
634    ----------------------
635
636    procedure Push_Scope_Stack is
637    begin
638       Scope.Increment_Last;
639
640       if Style_Check_Max_Nesting_Level
641         and then Scope.Last = Style_Max_Nesting_Level + 1
642       then
643          Error_Msg
644            ("(style) maximum nesting level exceeded",
645             First_Non_Blank_Location);
646       end if;
647
648       Scope.Table (Scope.Last).Junk := False;
649       Scope.Table (Scope.Last).Node := Empty;
650
651       if Debug_Flag_P then
652          Error_Msg_Uint_1 := UI_From_Int (Scope.Last);
653          Error_Msg_SC ("increment scope stack ptr, new value = ^!");
654       end if;
655    end Push_Scope_Stack;
656
657    ----------------------
658    -- Separate_Present --
659    ----------------------
660
661    function Separate_Present return Boolean is
662       Scan_State : Saved_Scan_State;
663
664    begin
665       if Token = Tok_Separate then
666          return True;
667
668       elsif Token /= Tok_Identifier then
669          return False;
670
671       else
672          Save_Scan_State (Scan_State);
673          Scan; -- past identifier
674
675          if Token = Tok_Semicolon then
676             Restore_Scan_State (Scan_State);
677             return Bad_Spelling_Of (Tok_Separate);
678
679          else
680             Restore_Scan_State (Scan_State);
681             return False;
682          end if;
683       end if;
684    end Separate_Present;
685
686    --------------------------
687    -- Signal_Bad_Attribute --
688    --------------------------
689
690    procedure Signal_Bad_Attribute is
691    begin
692       Error_Msg_N ("unrecognized attribute&", Token_Node);
693
694       --  Check for possible misspelling
695
696       Error_Msg_Name_1 := First_Attribute_Name;
697       while Error_Msg_Name_1 <= Last_Attribute_Name loop
698          if Is_Bad_Spelling_Of (Token_Name, Error_Msg_Name_1) then
699             Error_Msg_N ("\possible misspelling of %", Token_Node);
700             exit;
701          end if;
702
703          Error_Msg_Name_1 := Error_Msg_Name_1 + 1;
704       end loop;
705    end Signal_Bad_Attribute;
706
707    -----------------------------
708    -- Token_Is_At_End_Of_Line --
709    -----------------------------
710
711    function Token_Is_At_End_Of_Line return Boolean is
712       S : Source_Ptr;
713
714    begin
715       --  Skip past blanks and horizontal tabs
716
717       S := Scan_Ptr;
718       while Source (S) = ' ' or else Source (S) = ASCII.HT loop
719          S := S + 1;
720       end loop;
721
722       --  We are at end of line if at a control character (CR/LF/VT/FF/EOF)
723       --  or if we are at the start of an end of line comment sequence.
724
725       return Source (S) < ' '
726         or else (Source (S) = '-' and then Source (S + 1) = '-');
727    end Token_Is_At_End_Of_Line;
728
729    -------------------------------
730    -- Token_Is_At_Start_Of_Line --
731    -------------------------------
732
733    function Token_Is_At_Start_Of_Line return Boolean is
734    begin
735       return (Token_Ptr = First_Non_Blank_Location or else Token = Tok_EOF);
736    end Token_Is_At_Start_Of_Line;
737
738 end Util;