OSDN Git Service

2011-08-01 Yannick Moy <moy@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-2010, 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 -- CODEFIX
76            ("PROCEDURE expected");
77          Token := T;
78          return True;
79
80       --  A special check for an illegal abbreviation
81
82       elsif Name_Len < S'Length
83         and then Name_Len >= 4
84         and then Name_Buffer (1 .. Name_Len) = S (1 .. Name_Len)
85       then
86          for J in 1 .. S'Last loop
87             M2 (P2 + J - 1) := Fold_Upper (S (J));
88          end loop;
89
90          Error_Msg_SC (M2 (1 .. P2 - 1 + S'Last));
91          Token := T;
92          return True;
93       end if;
94
95       --  Now we go into the full circuit to check for a misspelling
96
97       --  Never consider something a misspelling if either the actual or
98       --  expected string is less than 3 characters (before this check we
99       --  used to consider i to be a misspelled if in some cases!)
100
101       if SL < 3 or else Name_Len < 3 then
102          return False;
103
104       --  Special case: prefix matches, i.e. the leading characters of the
105       --  token that we have exactly match the required keyword. If there
106       --  are at least two characters left over, assume that we have a case
107       --  of two keywords joined together which should not be joined.
108
109       elsif Name_Len > SL + 1
110         and then S = Name_Buffer (1 .. SL)
111       then
112          Scan_Ptr := Token_Ptr + S'Length;
113          Error_Msg_S ("|missing space");
114          Token := T;
115          return True;
116       end if;
117
118       if Is_Bad_Spelling_Of (Name_Buffer (1 .. Name_Len), S) then
119          for J in 1 .. S'Last loop
120             M1 (P1 + J - 1) := Fold_Upper (S (J));
121          end loop;
122
123          Error_Msg_SC -- CODFIX
124            (M1 (1 .. P1 - 1 + S'Last));
125          Token := T;
126          return True;
127
128       else
129          return False;
130       end if;
131    end Bad_Spelling_Of;
132
133    ----------------------
134    -- Check_95_Keyword --
135    ----------------------
136
137    --  On entry, the caller has checked that current token is an identifier
138    --  whose name matches the name of the 95 keyword New_Tok.
139
140    procedure Check_95_Keyword (Token_95, Next : Token_Type) is
141       Scan_State : Saved_Scan_State;
142
143    begin
144       Save_Scan_State (Scan_State); -- at identifier/keyword
145       Scan; -- past identifier/keyword
146
147       if Token = Next then
148          Restore_Scan_State (Scan_State); -- to identifier
149          Error_Msg_Name_1 := Token_Name;
150          Error_Msg_SC ("(Ada 83) keyword* cannot be used!");
151          Token := Token_95;
152       else
153          Restore_Scan_State (Scan_State); -- to identifier
154       end if;
155    end Check_95_Keyword;
156
157    ----------------------
158    -- Check_Bad_Layout --
159    ----------------------
160
161    procedure Check_Bad_Layout is
162    begin
163       if RM_Column_Check and then Token_Is_At_Start_Of_Line
164         and then Start_Column <= Scope.Table (Scope.Last).Ecol
165       then
166          Error_Msg_BC -- CODEFIX
167            ("(style) incorrect layout");
168       end if;
169    end Check_Bad_Layout;
170
171    --------------------------
172    -- Check_Misspelling_Of --
173    --------------------------
174
175    procedure Check_Misspelling_Of (T : Token_Type) is
176    begin
177       if Bad_Spelling_Of (T) then
178          null;
179       end if;
180    end Check_Misspelling_Of;
181
182    -----------------------------
183    -- Check_Simple_Expression --
184    -----------------------------
185
186    procedure Check_Simple_Expression (E : Node_Id) is
187    begin
188       if Expr_Form = EF_Non_Simple then
189          Error_Msg_N ("this expression must be parenthesized", E);
190       end if;
191    end Check_Simple_Expression;
192
193    ---------------------------------------
194    -- Check_Simple_Expression_In_Ada_83 --
195    ---------------------------------------
196
197    procedure Check_Simple_Expression_In_Ada_83 (E : Node_Id) is
198    begin
199       if Expr_Form = EF_Non_Simple then
200          if Ada_Version = Ada_83 then
201             Error_Msg_N ("(Ada 83) this expression must be parenthesized!", E);
202          end if;
203       end if;
204    end Check_Simple_Expression_In_Ada_83;
205
206    ------------------------
207    -- Check_Subtype_Mark --
208    ------------------------
209
210    function Check_Subtype_Mark (Mark : Node_Id) return Node_Id is
211    begin
212       if Nkind (Mark) = N_Identifier
213         or else Nkind (Mark) = N_Selected_Component
214         or else (Nkind (Mark) = N_Attribute_Reference
215                   and then Is_Type_Attribute_Name (Attribute_Name (Mark)))
216         or else Mark = Error
217       then
218          return Mark;
219       else
220          Error_Msg ("subtype mark expected", Sloc (Mark));
221          return Error;
222       end if;
223    end Check_Subtype_Mark;
224
225    -------------------
226    -- Comma_Present --
227    -------------------
228
229    function Comma_Present return Boolean is
230       Scan_State  : Saved_Scan_State;
231       Paren_Count : Nat;
232
233    begin
234       --  First check, if a comma is present, then a comma is present!
235
236       if Token = Tok_Comma then
237          T_Comma;
238          return True;
239
240       --  If we have a right paren, then that is taken as ending the list
241       --  i.e. no comma is present.
242
243       elsif Token = Tok_Right_Paren then
244          return False;
245
246       --  If pragmas, then get rid of them and make a recursive call
247       --  to process what follows these pragmas.
248
249       elsif Token = Tok_Pragma then
250          P_Pragmas_Misplaced;
251          return Comma_Present;
252
253       --  At this stage we have an error, and the goal is to decide on whether
254       --  or not we should diagnose an error and report a (non-existent)
255       --  comma as being present, or simply to report no comma is present
256
257       --  If we are a semicolon, then the question is whether we have a missing
258       --  right paren, or whether the semicolon should have been a comma. To
259       --  guess the right answer, we scan ahead keeping track of the paren
260       --  level, looking for a clue that helps us make the right decision.
261
262       --  This approach is highly accurate in the single error case, and does
263       --  not make bad mistakes in the multiple error case (indeed we can't
264       --  really make a very bad decision at this point in any case).
265
266       elsif Token = Tok_Semicolon then
267          Save_Scan_State (Scan_State);
268          Scan; -- past semicolon
269
270          --  Check for being followed by identifier => which almost certainly
271          --  means we are still in a parameter list and the comma should have
272          --  been a semicolon (such a sequence could not follow a semicolon)
273
274          if Token = Tok_Identifier then
275             Scan;
276
277             if Token = Tok_Arrow then
278                goto Assume_Comma;
279             end if;
280          end if;
281
282          --  If that test didn't work, loop ahead looking for a comma or
283          --  semicolon at the same parenthesis level. Always remember that
284          --  we can't go badly wrong in an error situation like this!
285
286          Paren_Count := 0;
287
288          --  Here is the look ahead loop, Paren_Count tells us whether the
289          --  token we are looking at is at the same paren level as the
290          --  suspicious semicolon that we are trying to figure out.
291
292          loop
293
294             --  If we hit another semicolon or an end of file, and we have
295             --  not seen a right paren or another comma on the way, then
296             --  probably the semicolon did end the list. Indeed that is
297             --  certainly the only single error correction possible here.
298
299             if Token = Tok_Semicolon or else Token = Tok_EOF then
300                Restore_Scan_State (Scan_State);
301                return False;
302
303             --  A comma at the same paren level as the semicolon is a strong
304             --  indicator that the semicolon should have been a comma, indeed
305             --  again this is the only possible single error correction.
306
307             elsif Token = Tok_Comma then
308                exit when Paren_Count = 0;
309
310             --  A left paren just bumps the paren count
311
312             elsif Token = Tok_Left_Paren then
313                Paren_Count := Paren_Count + 1;
314
315             --  A right paren that is at the same paren level as the semicolon
316             --  also means that the only possible single error correction is
317             --  to assume that the semicolon should have been a comma. If we
318             --  are not at the same paren level, then adjust the paren level.
319
320             elsif Token = Tok_Right_Paren then
321                exit when Paren_Count = 0;
322                Paren_Count := Paren_Count - 1;
323             end if;
324
325             --  Keep going, we haven't made a decision yet
326
327             Scan;
328          end loop;
329
330          --  If we fall through the loop, it means that we found a terminating
331          --  right paren or another comma. In either case it is reasonable to
332          --  assume that the semicolon was really intended to be a comma. Also
333          --  come here for the identifier arrow case.
334
335          <<Assume_Comma>>
336             Restore_Scan_State (Scan_State);
337             Error_Msg_SC -- CODEFIX
338               ("|"";"" should be "",""");
339             Scan; -- past the semicolon
340             return True;
341
342       --  If we are not at semicolon or a right paren, then we base the
343       --  decision on whether or not the next token can be part of an
344       --  expression. If not, then decide that no comma is present (the
345       --  caller will eventually generate a missing right parent message)
346
347       elsif Token in Token_Class_Eterm then
348          return False;
349
350       --  Otherwise we assume a comma is present, even if none is present,
351       --  since the next token must be part of an expression, so if we were
352       --  at the end of the list, then there is more than one error present.
353
354       else
355          T_Comma; -- to give error
356          return True;
357       end if;
358    end Comma_Present;
359
360    -----------------------
361    -- Discard_Junk_List --
362    -----------------------
363
364    procedure Discard_Junk_List (L : List_Id) is
365       pragma Warnings (Off, L);
366    begin
367       null;
368    end Discard_Junk_List;
369
370    -----------------------
371    -- Discard_Junk_Node --
372    -----------------------
373
374    procedure Discard_Junk_Node (N : Node_Id) is
375       pragma Warnings (Off, N);
376    begin
377       null;
378    end Discard_Junk_Node;
379
380    -------------------------
381    -- Formal_Error_Msg_SP --
382    -------------------------
383
384    procedure Formal_Error_Msg_SP (Msg : String) is
385    begin
386       pragma Assert (Formal_Verification_Mode);
387       Error_Msg_SP ("(" & Formal_Language & ") " & Msg);
388    end Formal_Error_Msg_SP;
389
390    ------------
391    -- Ignore --
392    ------------
393
394    procedure Ignore (T : Token_Type) is
395    begin
396       while Token = T loop
397          if T = Tok_Comma then
398             Error_Msg_SC -- CODEFIX
399               ("|extra "","" ignored");
400
401          elsif T = Tok_Left_Paren then
402             Error_Msg_SC -- CODEFIX
403               ("|extra ""("" ignored");
404
405          elsif T = Tok_Right_Paren then
406             Error_Msg_SC -- CODEFIX
407               ("|extra "")"" ignored");
408
409          elsif T = Tok_Semicolon then
410             Error_Msg_SC -- CODEFIX
411               ("|extra "";"" ignored");
412
413          elsif T = Tok_Colon then
414             Error_Msg_SC -- CODEFIX
415               ("|extra "":"" ignored");
416
417          else
418             declare
419                Tname : constant String := Token_Type'Image (Token);
420             begin
421                Error_Msg_SC ("|extra " & Tname (5 .. Tname'Last) & "ignored");
422             end;
423          end if;
424
425          Scan; -- Scan past ignored token
426       end loop;
427    end Ignore;
428
429    ----------------------------
430    -- Is_Reserved_Identifier --
431    ----------------------------
432
433    function Is_Reserved_Identifier (C : Id_Check := None) return Boolean is
434    begin
435       if not Is_Reserved_Keyword (Token) then
436          return False;
437
438       else
439          declare
440             Ident_Casing : constant Casing_Type :=
441                              Identifier_Casing (Current_Source_File);
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 ("unexpected identifier, possibly & was meant here");
586       Scan;
587    end Merge_Identifier;
588
589    -------------------
590    -- Next_Token_Is --
591    -------------------
592
593    function Next_Token_Is (Tok : Token_Type) return Boolean is
594       Scan_State : Saved_Scan_State;
595       Result     : Boolean;
596    begin
597       Save_Scan_State (Scan_State);
598       Scan;
599       Result := (Token = Tok);
600       Restore_Scan_State (Scan_State);
601       return Result;
602    end Next_Token_Is;
603
604    -------------------
605    -- No_Constraint --
606    -------------------
607
608    procedure No_Constraint is
609    begin
610       if Token in Token_Class_Consk then
611          Error_Msg_SC ("constraint not allowed here");
612          Discard_Junk_Node (P_Constraint_Opt);
613       end if;
614    end No_Constraint;
615
616    ---------------------
617    -- Pop_Scope_Stack --
618    ---------------------
619
620    procedure Pop_Scope_Stack is
621    begin
622       pragma Assert (Scope.Last > 0);
623       Scope.Decrement_Last;
624
625       if Debug_Flag_P then
626          Error_Msg_Uint_1 := UI_From_Int (Scope.Last);
627          Error_Msg_SC ("decrement scope stack ptr, new value = ^!");
628       end if;
629    end Pop_Scope_Stack;
630
631    ----------------------
632    -- Push_Scope_Stack --
633    ----------------------
634
635    procedure Push_Scope_Stack is
636    begin
637       Scope.Increment_Last;
638
639       if Style_Check_Max_Nesting_Level
640         and then Scope.Last = Style_Max_Nesting_Level + 1
641       then
642          Error_Msg
643            ("(style) maximum nesting level exceeded",
644             First_Non_Blank_Location);
645       end if;
646
647       Scope.Table (Scope.Last).Junk := False;
648       Scope.Table (Scope.Last).Node := Empty;
649
650       if Debug_Flag_P then
651          Error_Msg_Uint_1 := UI_From_Int (Scope.Last);
652          Error_Msg_SC ("increment scope stack ptr, new value = ^!");
653       end if;
654    end Push_Scope_Stack;
655
656    ----------------------
657    -- Separate_Present --
658    ----------------------
659
660    function Separate_Present return Boolean is
661       Scan_State : Saved_Scan_State;
662
663    begin
664       if Token = Tok_Separate then
665          return True;
666
667       elsif Token /= Tok_Identifier then
668          return False;
669
670       else
671          Save_Scan_State (Scan_State);
672          Scan; -- past identifier
673
674          if Token = Tok_Semicolon then
675             Restore_Scan_State (Scan_State);
676             return Bad_Spelling_Of (Tok_Separate);
677
678          else
679             Restore_Scan_State (Scan_State);
680             return False;
681          end if;
682       end if;
683    end Separate_Present;
684
685    --------------------------
686    -- Signal_Bad_Attribute --
687    --------------------------
688
689    procedure Signal_Bad_Attribute is
690    begin
691       Error_Msg_N ("unrecognized attribute&", Token_Node);
692
693       --  Check for possible misspelling
694
695       Error_Msg_Name_1 := First_Attribute_Name;
696       while Error_Msg_Name_1 <= Last_Attribute_Name loop
697          if Is_Bad_Spelling_Of (Token_Name, Error_Msg_Name_1) then
698             Error_Msg_N -- CODEFIX
699               ("\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;