diff options
Diffstat (limited to 'gcc-4.8/gcc/ada/par-util.adb')
| -rw-r--r-- | gcc-4.8/gcc/ada/par-util.adb | 774 |
1 files changed, 0 insertions, 774 deletions
diff --git a/gcc-4.8/gcc/ada/par-util.adb b/gcc-4.8/gcc/ada/par-util.adb deleted file mode 100644 index 3b59287b7..000000000 --- a/gcc-4.8/gcc/ada/par-util.adb +++ /dev/null @@ -1,774 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- P A R . U T I L -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the license. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Csets; use Csets; -with Namet.Sp; use Namet.Sp; -with Stylesw; use Stylesw; -with Uintp; use Uintp; -with Warnsw; use Warnsw; - -with GNAT.Spelling_Checker; use GNAT.Spelling_Checker; - -separate (Par) -package body Util is - - --------------------- - -- Bad_Spelling_Of -- - --------------------- - - function Bad_Spelling_Of (T : Token_Type) return Boolean is - Tname : constant String := Token_Type'Image (T); - -- Characters of token name - - S : String (1 .. Tname'Last - 4); - -- Characters of token name folded to lower case, omitting TOK_ at start - - M1 : String (1 .. 42) := "incorrect spelling of keyword ************"; - M2 : String (1 .. 44) := "illegal abbreviation of keyword ************"; - -- Buffers used to construct error message - - P1 : constant := 30; - P2 : constant := 32; - -- Starting subscripts in M1, M2 for keyword name - - SL : constant Natural := S'Length; - -- Length of expected token name excluding TOK_ at start - - begin - if Token /= Tok_Identifier then - return False; - end if; - - for J in S'Range loop - S (J) := Fold_Lower (Tname (J + 4)); - end loop; - - Get_Name_String (Token_Name); - - -- A special check for case of PROGRAM used for PROCEDURE - - if T = Tok_Procedure - and then Name_Len = 7 - and then Name_Buffer (1 .. 7) = "program" - then - Error_Msg_SC -- CODEFIX - ("PROCEDURE expected"); - Token := T; - return True; - - -- A special check for an illegal abbreviation - - elsif Name_Len < S'Length - and then Name_Len >= 4 - and then Name_Buffer (1 .. Name_Len) = S (1 .. Name_Len) - then - for J in 1 .. S'Last loop - M2 (P2 + J - 1) := Fold_Upper (S (J)); - end loop; - - Error_Msg_SC (M2 (1 .. P2 - 1 + S'Last)); - Token := T; - return True; - end if; - - -- Now we go into the full circuit to check for a misspelling - - -- Never consider something a misspelling if either the actual or - -- expected string is less than 3 characters (before this check we - -- used to consider i to be a misspelled if in some cases!) - - if SL < 3 or else Name_Len < 3 then - return False; - - -- Special case: prefix matches, i.e. the leading characters of the - -- token that we have exactly match the required keyword. If there - -- are at least two characters left over, assume that we have a case - -- of two keywords joined together which should not be joined. - - elsif Name_Len > SL + 1 - and then S = Name_Buffer (1 .. SL) - then - Scan_Ptr := Token_Ptr + S'Length; - Error_Msg_S ("|missing space"); - Token := T; - return True; - end if; - - if Is_Bad_Spelling_Of (Name_Buffer (1 .. Name_Len), S) then - for J in 1 .. S'Last loop - M1 (P1 + J - 1) := Fold_Upper (S (J)); - end loop; - - Error_Msg_SC -- CODFIX - (M1 (1 .. P1 - 1 + S'Last)); - Token := T; - return True; - - else - return False; - end if; - end Bad_Spelling_Of; - - ---------------------- - -- Check_95_Keyword -- - ---------------------- - - -- On entry, the caller has checked that current token is an identifier - -- whose name matches the name of the 95 keyword New_Tok. - - procedure Check_95_Keyword (Token_95, Next : Token_Type) is - Scan_State : Saved_Scan_State; - - begin - Save_Scan_State (Scan_State); -- at identifier/keyword - Scan; -- past identifier/keyword - - if Token = Next then - Restore_Scan_State (Scan_State); -- to identifier - Error_Msg_Name_1 := Token_Name; - Error_Msg_SC ("(Ada 83) keyword* cannot be used!"); - Token := Token_95; - else - Restore_Scan_State (Scan_State); -- to identifier - end if; - end Check_95_Keyword; - - ---------------------- - -- Check_Bad_Layout -- - ---------------------- - - procedure Check_Bad_Layout is - begin - if RM_Column_Check and then Token_Is_At_Start_Of_Line - and then Start_Column <= Scope.Table (Scope.Last).Ecol - then - Error_Msg_BC -- CODEFIX - ("(style) incorrect layout"); - end if; - end Check_Bad_Layout; - - -------------------------- - -- Check_Future_Keyword -- - -------------------------- - - procedure Check_Future_Keyword is - begin - -- Ada 2005 (AI-284): Compiling in Ada 95 mode we warn that INTERFACE, - -- OVERRIDING, and SYNCHRONIZED are new reserved words. - - if Ada_Version = Ada_95 - and then Warn_On_Ada_2005_Compatibility - then - if Token_Name = Name_Overriding - or else Token_Name = Name_Synchronized - or else (Token_Name = Name_Interface - and then Prev_Token /= Tok_Pragma) - then - Error_Msg_N ("& is a reserved word in Ada 2005?y?", Token_Node); - end if; - end if; - - -- Similarly, warn about Ada 2012 reserved words - - if Ada_Version in Ada_95 .. Ada_2005 - and then Warn_On_Ada_2012_Compatibility - then - if Token_Name = Name_Some then - Error_Msg_N ("& is a reserved word in Ada 2012?y?", Token_Node); - end if; - end if; - - -- Note: we deliberately do not emit these warnings when operating in - -- Ada 83 mode because in that case we assume the user is building - -- legacy code anyway and is not interested in updating Ada versions. - - end Check_Future_Keyword; - - -------------------------- - -- Check_Misspelling_Of -- - -------------------------- - - procedure Check_Misspelling_Of (T : Token_Type) is - begin - if Bad_Spelling_Of (T) then - null; - end if; - end Check_Misspelling_Of; - - ----------------------------- - -- Check_Simple_Expression -- - ----------------------------- - - procedure Check_Simple_Expression (E : Node_Id) is - begin - if Expr_Form = EF_Non_Simple then - Error_Msg_N ("this expression must be parenthesized", E); - end if; - end Check_Simple_Expression; - - --------------------------------------- - -- Check_Simple_Expression_In_Ada_83 -- - --------------------------------------- - - procedure Check_Simple_Expression_In_Ada_83 (E : Node_Id) is - begin - if Expr_Form = EF_Non_Simple then - if Ada_Version = Ada_83 then - Error_Msg_N ("(Ada 83) this expression must be parenthesized!", E); - end if; - end if; - end Check_Simple_Expression_In_Ada_83; - - ------------------------ - -- Check_Subtype_Mark -- - ------------------------ - - function Check_Subtype_Mark (Mark : Node_Id) return Node_Id is - begin - if Nkind (Mark) = N_Identifier - or else Nkind (Mark) = N_Selected_Component - or else (Nkind (Mark) = N_Attribute_Reference - and then Is_Type_Attribute_Name (Attribute_Name (Mark))) - or else Mark = Error - then - return Mark; - else - Error_Msg ("subtype mark expected", Sloc (Mark)); - return Error; - end if; - end Check_Subtype_Mark; - - ------------------- - -- Comma_Present -- - ------------------- - - function Comma_Present return Boolean is - Scan_State : Saved_Scan_State; - Paren_Count : Nat; - - begin - -- First check, if a comma is present, then a comma is present! - - if Token = Tok_Comma then - T_Comma; - return True; - - -- If we have a right paren, then that is taken as ending the list - -- i.e. no comma is present. - - elsif Token = Tok_Right_Paren then - return False; - - -- If pragmas, then get rid of them and make a recursive call - -- to process what follows these pragmas. - - elsif Token = Tok_Pragma then - P_Pragmas_Misplaced; - return Comma_Present; - - -- At this stage we have an error, and the goal is to decide on whether - -- or not we should diagnose an error and report a (non-existent) - -- comma as being present, or simply to report no comma is present - - -- If we are a semicolon, then the question is whether we have a missing - -- right paren, or whether the semicolon should have been a comma. To - -- guess the right answer, we scan ahead keeping track of the paren - -- level, looking for a clue that helps us make the right decision. - - -- This approach is highly accurate in the single error case, and does - -- not make bad mistakes in the multiple error case (indeed we can't - -- really make a very bad decision at this point in any case). - - elsif Token = Tok_Semicolon then - Save_Scan_State (Scan_State); - Scan; -- past semicolon - - -- Check for being followed by identifier => which almost certainly - -- means we are still in a parameter list and the comma should have - -- been a semicolon (such a sequence could not follow a semicolon) - - if Token = Tok_Identifier then - Scan; - - if Token = Tok_Arrow then - goto Assume_Comma; - end if; - end if; - - -- If that test didn't work, loop ahead looking for a comma or - -- semicolon at the same parenthesis level. Always remember that - -- we can't go badly wrong in an error situation like this! - - Paren_Count := 0; - - -- Here is the look ahead loop, Paren_Count tells us whether the - -- token we are looking at is at the same paren level as the - -- suspicious semicolon that we are trying to figure out. - - loop - - -- If we hit another semicolon or an end of file, and we have - -- not seen a right paren or another comma on the way, then - -- probably the semicolon did end the list. Indeed that is - -- certainly the only single error correction possible here. - - if Token = Tok_Semicolon or else Token = Tok_EOF then - Restore_Scan_State (Scan_State); - return False; - - -- A comma at the same paren level as the semicolon is a strong - -- indicator that the semicolon should have been a comma, indeed - -- again this is the only possible single error correction. - - elsif Token = Tok_Comma then - exit when Paren_Count = 0; - - -- A left paren just bumps the paren count - - elsif Token = Tok_Left_Paren then - Paren_Count := Paren_Count + 1; - - -- A right paren that is at the same paren level as the semicolon - -- also means that the only possible single error correction is - -- to assume that the semicolon should have been a comma. If we - -- are not at the same paren level, then adjust the paren level. - - elsif Token = Tok_Right_Paren then - exit when Paren_Count = 0; - Paren_Count := Paren_Count - 1; - end if; - - -- Keep going, we haven't made a decision yet - - Scan; - end loop; - - -- If we fall through the loop, it means that we found a terminating - -- right paren or another comma. In either case it is reasonable to - -- assume that the semicolon was really intended to be a comma. Also - -- come here for the identifier arrow case. - - <<Assume_Comma>> - Restore_Scan_State (Scan_State); - Error_Msg_SC -- CODEFIX - ("|"";"" should be "","""); - Scan; -- past the semicolon - return True; - - -- If we are not at semicolon or a right paren, then we base the - -- decision on whether or not the next token can be part of an - -- expression. If not, then decide that no comma is present (the - -- caller will eventually generate a missing right parent message) - - elsif Token in Token_Class_Eterm then - return False; - - -- Otherwise we assume a comma is present, even if none is present, - -- since the next token must be part of an expression, so if we were - -- at the end of the list, then there is more than one error present. - - else - T_Comma; -- to give error - return True; - end if; - end Comma_Present; - - ----------------------- - -- Discard_Junk_List -- - ----------------------- - - procedure Discard_Junk_List (L : List_Id) is - pragma Warnings (Off, L); - begin - null; - end Discard_Junk_List; - - ----------------------- - -- Discard_Junk_Node -- - ----------------------- - - procedure Discard_Junk_Node (N : Node_Id) is - pragma Warnings (Off, N); - begin - null; - end Discard_Junk_Node; - - ------------ - -- Ignore -- - ------------ - - procedure Ignore (T : Token_Type) is - begin - while Token = T loop - if T = Tok_Comma then - Error_Msg_SC -- CODEFIX - ("|extra "","" ignored"); - - elsif T = Tok_Left_Paren then - Error_Msg_SC -- CODEFIX - ("|extra ""("" ignored"); - - elsif T = Tok_Right_Paren then - Error_Msg_SC -- CODEFIX - ("|extra "")"" ignored"); - - elsif T = Tok_Semicolon then - Error_Msg_SC -- CODEFIX - ("|extra "";"" ignored"); - - elsif T = Tok_Colon then - Error_Msg_SC -- CODEFIX - ("|extra "":"" ignored"); - - else - declare - Tname : constant String := Token_Type'Image (Token); - begin - Error_Msg_SC ("|extra " & Tname (5 .. Tname'Last) & "ignored"); - end; - end if; - - Scan; -- Scan past ignored token - end loop; - end Ignore; - - ---------------------------- - -- Is_Reserved_Identifier -- - ---------------------------- - - function Is_Reserved_Identifier (C : Id_Check := None) return Boolean is - begin - if not Is_Reserved_Keyword (Token) then - return False; - - else - declare - Ident_Casing : constant Casing_Type := - Identifier_Casing (Current_Source_File); - Key_Casing : constant Casing_Type := - Keyword_Casing (Current_Source_File); - - begin - -- If the casing of identifiers and keywords is different in - -- this source file, and the casing of this token matches the - -- keyword casing, then we return False, since it is pretty - -- clearly intended to be a keyword. - - if Ident_Casing = Unknown - or else Key_Casing = Unknown - or else Ident_Casing = Key_Casing - or else Determine_Token_Casing /= Key_Casing - then - return True; - - -- Here we have a keyword written clearly with keyword casing. - -- In default mode, we would not be willing to consider this as - -- a reserved identifier, but if C is set, we may still accept it - - elsif C /= None then - declare - Scan_State : Saved_Scan_State; - OK_Next_Tok : Boolean; - - begin - Save_Scan_State (Scan_State); - Scan; - - if Token_Is_At_Start_Of_Line then - return False; - end if; - - case C is - when None => - raise Program_Error; - - when C_Comma_Right_Paren => - OK_Next_Tok := - Token = Tok_Comma or else Token = Tok_Right_Paren; - - when C_Comma_Colon => - OK_Next_Tok := - Token = Tok_Comma or else Token = Tok_Colon; - - when C_Do => - OK_Next_Tok := - Token = Tok_Do; - - when C_Dot => - OK_Next_Tok := - Token = Tok_Dot; - - when C_Greater_Greater => - OK_Next_Tok := - Token = Tok_Greater_Greater; - - when C_In => - OK_Next_Tok := - Token = Tok_In; - - when C_Is => - OK_Next_Tok := - Token = Tok_Is; - - when C_Left_Paren_Semicolon => - OK_Next_Tok := - Token = Tok_Left_Paren or else Token = Tok_Semicolon; - - when C_Use => - OK_Next_Tok := - Token = Tok_Use; - - when C_Vertical_Bar_Arrow => - OK_Next_Tok := - Token = Tok_Vertical_Bar or else Token = Tok_Arrow; - end case; - - Restore_Scan_State (Scan_State); - - if OK_Next_Tok then - return True; - end if; - end; - end if; - end; - end if; - - -- If we fall through it is not a reserved identifier - - return False; - end Is_Reserved_Identifier; - - ---------------------- - -- Merge_Identifier -- - ---------------------- - - procedure Merge_Identifier (Prev : Node_Id; Nxt : Token_Type) is - begin - if Token /= Tok_Identifier then - return; - end if; - - declare - S : Saved_Scan_State; - T : Token_Type; - - begin - Save_Scan_State (S); - Scan; - T := Token; - Restore_Scan_State (S); - - if T /= Nxt then - return; - end if; - end; - - -- Check exactly one space between identifiers - - if Source (Token_Ptr - 1) /= ' ' - or else Int (Token_Ptr) /= - Int (Prev_Token_Ptr) + Length_Of_Name (Chars (Prev)) + 1 - then - return; - end if; - - -- Do the merge - - Get_Name_String (Chars (Token_Node)); - - declare - Buf : constant String (1 .. Name_Len) := - Name_Buffer (1 .. Name_Len); - - begin - Get_Name_String (Chars (Prev)); - Add_Char_To_Name_Buffer ('_'); - Add_Str_To_Name_Buffer (Buf); - Set_Chars (Prev, Name_Find); - end; - - Error_Msg_Node_1 := Prev; - Error_Msg_SC ("unexpected identifier, possibly & was meant here"); - Scan; - end Merge_Identifier; - - ------------------- - -- Next_Token_Is -- - ------------------- - - function Next_Token_Is (Tok : Token_Type) return Boolean is - Scan_State : Saved_Scan_State; - Result : Boolean; - begin - Save_Scan_State (Scan_State); - Scan; - Result := (Token = Tok); - Restore_Scan_State (Scan_State); - return Result; - end Next_Token_Is; - - ------------------- - -- No_Constraint -- - ------------------- - - procedure No_Constraint is - begin - -- If we have a token that could start a constraint on the same line - -- then cnsider this an illegal constraint. It seems unlikely it could - -- be anything else if it is on the same line. - - if Token in Token_Class_Consk then - Error_Msg_SC ("constraint not allowed here"); - Discard_Junk_Node (P_Constraint_Opt); - end if; - end No_Constraint; - - --------------------- - -- Pop_Scope_Stack -- - --------------------- - - procedure Pop_Scope_Stack is - begin - pragma Assert (Scope.Last > 0); - Scope.Decrement_Last; - - if Debug_Flag_P then - Error_Msg_Uint_1 := UI_From_Int (Scope.Last); - Error_Msg_SC ("decrement scope stack ptr, new value = ^!"); - end if; - end Pop_Scope_Stack; - - ---------------------- - -- Push_Scope_Stack -- - ---------------------- - - procedure Push_Scope_Stack is - begin - Scope.Increment_Last; - - if Style_Check_Max_Nesting_Level - and then Scope.Last = Style_Max_Nesting_Level + 1 - then - Error_Msg - ("(style) maximum nesting level exceeded", - First_Non_Blank_Location); - end if; - - Scope.Table (Scope.Last).Junk := False; - Scope.Table (Scope.Last).Node := Empty; - - if Debug_Flag_P then - Error_Msg_Uint_1 := UI_From_Int (Scope.Last); - Error_Msg_SC ("increment scope stack ptr, new value = ^!"); - end if; - end Push_Scope_Stack; - - ---------------------- - -- Separate_Present -- - ---------------------- - - function Separate_Present return Boolean is - Scan_State : Saved_Scan_State; - - begin - if Token = Tok_Separate then - return True; - - elsif Token /= Tok_Identifier then - return False; - - else - Save_Scan_State (Scan_State); - Scan; -- past identifier - - if Token = Tok_Semicolon then - Restore_Scan_State (Scan_State); - return Bad_Spelling_Of (Tok_Separate); - - else - Restore_Scan_State (Scan_State); - return False; - end if; - end if; - end Separate_Present; - - -------------------------- - -- Signal_Bad_Attribute -- - -------------------------- - - procedure Signal_Bad_Attribute is - begin - Bad_Attribute (Token_Node, Token_Name, Warn => False); - end Signal_Bad_Attribute; - - ----------------------------- - -- Token_Is_At_End_Of_Line -- - ----------------------------- - - function Token_Is_At_End_Of_Line return Boolean is - S : Source_Ptr; - - begin - -- Skip past blanks and horizontal tabs - - S := Scan_Ptr; - while Source (S) = ' ' or else Source (S) = ASCII.HT loop - S := S + 1; - end loop; - - -- We are at end of line if at a control character (CR/LF/VT/FF/EOF) - -- or if we are at the start of an end of line comment sequence. - - return Source (S) < ' ' - or else (Source (S) = '-' and then Source (S + 1) = '-'); - end Token_Is_At_End_Of_Line; - - ------------------------------- - -- Token_Is_At_Start_Of_Line -- - ------------------------------- - - function Token_Is_At_Start_Of_Line return Boolean is - begin - return (Token_Ptr = First_Non_Blank_Location or else Token = Tok_EOF); - end Token_Is_At_Start_Of_Line; - - ----------------------------------- - -- Warn_If_Standard_Redefinition -- - ----------------------------------- - - procedure Warn_If_Standard_Redefinition (N : Node_Id) is - begin - if Warn_On_Standard_Redefinition then - declare - C : constant Entity_Id := Current_Entity (N); - begin - if Present (C) and then Sloc (C) = Standard_Location then - Error_Msg_N ("redefinition of entity& in Standard?K?", N); - end if; - end; - end if; - end Warn_If_Standard_Redefinition; - -end Util; |