X-Git-Url: https://git.libre-soc.org/?a=blobdiff_plain;f=gcc%2Fada%2Fpar.adb;h=0e3fa401a773871071a2e995dc43d96e44f0a32e;hb=0bba838d7f4e9b851416d463d077b28aff0b561f;hp=32276c5084b22aa50f9136d4631be56a9532b928;hpb=7ab4d95af734d904c16bf4af815e8810546feff6;p=gcc.git diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index 32276c5084b..0e3fa401a77 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2019, 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- -- @@ -57,18 +57,22 @@ with Tbuild; use Tbuild; function Par (Configuration_Pragmas : Boolean) return List_Id is + Inside_Record_Definition : Boolean := False; + -- True within a record definition. Used to control warning for + -- redefinition of standard entities (not issued for field names). + + Loop_Block_Count : Nat := 0; + -- Counter used for constructing loop/block names (see the routine + -- Par.Ch5.Get_Loop_Block_Name). + Num_Library_Units : Natural := 0; -- Count number of units parsed (relevant only in syntax check only mode, - -- since in semantics check mode only a single unit is permitted anyway) + -- since in semantics check mode only a single unit is permitted anyway). - Save_Config_Switches : Config_Switches_Type; + Save_Config_Attrs : Config_Switches_Type; -- Variable used to save values of config switches while we parse the -- new unit, to be restored on exit for proper recursive behavior. - Loop_Block_Count : Nat := 0; - -- Counter used for constructing loop/block names (see the routine - -- Par.Ch5.Get_Loop_Block_Name) - -------------------- -- Error Recovery -- -------------------- @@ -147,8 +151,17 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is SIS_Entry_Active : Boolean := False; -- Set True to indicate that an entry is active (i.e. that a subprogram - -- declaration has been encountered, and no body for this subprogram has - -- been encountered). The remaining fields are valid only if this is True. + -- declaration has been encountered, and no body for this subprogram + -- has been encountered). The remaining variables other than + -- SIS_Aspect_Import_Seen are valid only if this is True. + + SIS_Aspect_Import_Seen : Boolean := False; + -- If this is True when a subprogram declaration has been encountered, we + -- do not set SIS_Entry_Active, because the Import means there is no body. + -- Set False at the start of P_Subprogram, set True when an Import aspect + -- specification is seen, and used when P_Subprogram finds a subprogram + -- declaration. This is necessary because the aspects are parsed before + -- we know we have a subprogram declaration. SIS_Labl : Node_Id; -- Subprogram designator @@ -356,7 +369,7 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is Pbod : Boolean; -- True if proper body OK Rnam : Boolean; -- True if renaming declaration OK Stub : Boolean; -- True if body stub OK - Pexp : Boolean; -- True if parametrized expression OK + Pexp : Boolean; -- True if parameterized expression OK Fil2 : Boolean; -- Filler to fill to 8 bits end record; pragma Pack (Pf_Rec); @@ -463,17 +476,26 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is -- expected column of the end assuming normal Ada indentation usage. If -- the RM_Column_Check mode is set, this value is used for generating -- error messages about indentation. Otherwise it is used only to - -- control heuristic error recovery actions. + -- control heuristic error recovery actions. This value is zero origin. Labl : Node_Id; - -- This field is used only for the LOOP and BEGIN cases, and is the - -- Node_Id value of the label name. For all cases except child units, - -- this value is an entity whose Chars field contains the name pointer - -- that identifies the label uniquely. For the child unit case the Labl - -- field references an N_Defining_Program_Unit_Name node for the name. - -- For cases other than LOOP or BEGIN, the Label field is set to Error, - -- indicating that it is an error to have a label on the end line. - -- (this is really a misuse of Error since there is no Error ???) + -- This field is used to provide the name of the construct being parsed + -- and indirectly its kind. For loops and blocks, the field contains the + -- source name or the generated one. For package specifications, bodies, + -- subprogram specifications and bodies the field holds the correponding + -- program unit name. For task declarations and bodies, protected types + -- and bodies, and accept statements the field hold the name of the type + -- or operation. For if-statements, case-statements, return statements, + -- and selects, the field is initialized to Error. + + -- Note: this is a bit of an odd (mis)use of Error, since there is no + -- Error, but we use this value as a place holder to indicate that it + -- is an error to have a label on the end line. + + -- Whenever the field is a name, it is attached to the parent node of + -- the construct being parsed. Thus the parent node indicates the kind + -- of construct whose parse tree is being built. This is used in error + -- recovery. Decl : List_Id; -- Points to the list of declarations (i.e. the declarative part) @@ -522,6 +544,86 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is Table_Increment => 100, Table_Name => "Scope"); + type Scope_Table_Entry_Ptr is access all Scope_Table_Entry; + + function Scopes (Index : Int) return Scope_Table_Entry_Ptr; + -- Return the indicated Scope_Table_Entry. We use a pointer for + -- efficiency. Callers should not save the pointer, but should do things + -- like Scopes (Scope.Last).Something. Note that there is one place in + -- Par.Ch5 that indexes the stack out of bounds, and can't call this. + + function Scopes (Index : Int) return Scope_Table_Entry_Ptr is + begin + pragma Assert (Index in Scope.First .. Scope.Last); + return Scope.Table (Index)'Unrestricted_Access; + end Scopes; + + ------------------------------------------ + -- Table for Handling Suspicious Labels -- + ------------------------------------------ + + -- This is a special data structure which is used to deal very spefifically + -- with the following error case + + -- label; + -- loop + -- ... + -- end loop label; + + -- Similar cases apply to FOR, WHILE, DECLARE, or BEGIN + + -- In each case the opening line looks like a procedure call because of + -- the semicolon. And the end line looks illegal because of an unexpected + -- label. If we did nothing special, we would just diagnose the label on + -- the end as unexpected. But that does not help point to the real error + -- which is that the semicolon after label should be a colon. + + -- To deal with this, we build an entry in the Suspicious_Labels table + -- whenever we encounter an identifier followed by a semicolon, followed + -- by one of LOOP, FOR, WHILE, DECLARE, BEGIN. Then this entry is used to + -- issue the right message when we hit the END that confirms that this was + -- a bad label. + + type Suspicious_Label_Entry is record + Proc_Call : Node_Id; + -- Node for the procedure call statement built for the label; construct + + Semicolon_Loc : Source_Ptr; + -- Location of the possibly wrong semicolon + + Start_Token : Source_Ptr; + -- Source location of the LOOP, FOR, WHILE, DECLARE, BEGIN token + end record; + + package Suspicious_Labels is new Table.Table ( + Table_Component_Type => Suspicious_Label_Entry, + Table_Index_Type => Int, + Table_Low_Bound => 1, + Table_Initial => 50, + Table_Increment => 100, + Table_Name => "Suspicious_Labels"); + + -- Now when we are about to issue a message complaining about an END label + -- that should not be there because it appears to end a construct that has + -- no label, we first search the suspicious labels table entry, using the + -- source location stored in the scope table as a key. If we find a match, + -- then we check that the label on the end matches the name in the call, + -- and if so, we issue a message saying the semicolon should be a colon. + + -- Quite a bit of work, but really helpful in the case where it helps, and + -- the need for this is based on actual experience with tracking down this + -- kind of error (the eye often easily mistakes semicolon for colon). + + -- Note: we actually have enough information to patch up the tree, but + -- this may not be worth the effort. Also we could deal with the same + -- situation for EXIT with a label, but for now don't bother with that. + + Current_Assign_Node : Node_Id := Empty; + -- This is the node of the current assignment statement being compiled. + -- It is used to record the presence of target_names on its RHS. This + -- context-dependent trick simplifies the analysis of such nodes, where + -- the RHS must first be analyzed with expansion disabled. + --------------------------------- -- Parsing Routines by Chapter -- --------------------------------- @@ -538,7 +640,12 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is function P_Pragma (Skipping : Boolean := False) return Node_Id; -- Scan out a pragma. If Skipping is True, then the caller is skipping -- the pragma in the context of illegal placement (this is used to avoid - -- some junk cascaded messages). + -- some junk cascaded messages). Some pragmas must be dealt with during + -- the parsing phase (e.g. pragma Page, since we can generate a listing + -- in syntax only mode). It is possible that the parser uses the rescan + -- logic (using Save/Restore_Scan_State) with the effect of calling this + -- procedure more than once for the same pragma. All parse-time pragma + -- handling must be prepared to handle such multiple calls correctly. function P_Identifier (C : Id_Check := None) return Node_Id; -- Scans out an identifier. The parameter C determines the treatment @@ -685,14 +792,12 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is -- keyword, and returns pointing to the terminating right parent, -- semicolon, or comma, but does not consume this terminating token. - function P_Conditional_Expression return Node_Id; - -- Scans out a conditional expression. Called with Token pointing to - -- the IF keyword, and returns pointing to the terminating right paren, - -- semicolon or comma, but does not consume this terminating token. - function P_Expression_If_OK return Node_Id; - -- Scans out an expression in a context where a conditional expression - -- is permitted to appear without surrounding parentheses. + -- Scans out an expression allowing an unparenthesized case expression, + -- if expression, or quantified expression to appear without enclosing + -- parentheses. However, if such an expression is not preceded by a left + -- paren, and followed by a right paren, an error message will be output + -- noting that parenthesization is required. function P_Expression_No_Right_Paren return Node_Id; -- Scans out an expression in contexts where the expression cannot be @@ -702,6 +807,14 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is function P_Expression_Or_Range_Attribute_If_OK return Node_Id; -- Scans out an expression or range attribute where a conditional -- expression is permitted to appear without surrounding parentheses. + -- However, if such an expression is not preceded by a left paren, and + -- followed by a right paren, an error message will be output noting + -- that parenthesization is required. + + function P_If_Expression return Node_Id; + -- Scans out an if expression. Called with Token pointing to the + -- IF keyword, and returns pointing to the terminating right paren, + -- semicolon or comma, but does not consume this terminating token. function P_Qualified_Expression (Subtype_Mark : Node_Id) return Node_Id; -- This routine scans out a qualified expression when the caller has @@ -718,7 +831,13 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is package Ch5 is function P_Condition return Node_Id; - -- Scan out and return a condition + -- Scan out and return a condition. Note that an error is given if + -- the condition is followed by a right parenthesis. + + function P_Condition (Cond : Node_Id) return Node_Id; + -- Similar to the above, but the caller has already scanned out the + -- conditional expression and passes it as an argument. This form of + -- the call does not check for a following right parenthesis. function P_Loop_Parameter_Specification return Node_Id; -- Used in loop constructs and quantified expressions. @@ -771,7 +890,7 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is ------------- package Ch8 is - function P_Use_Clause return Node_Id; + procedure P_Use_Clause (Item_List : List_Id); end Ch8; ------------- @@ -819,6 +938,7 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is package Ch11 is function P_Handled_Sequence_Of_Statements return Node_Id; + function P_Raise_Expression return Node_Id; function P_Raise_Statement return Node_Id; function Parse_Exception_Handlers return List_Id; @@ -858,8 +978,11 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is -- attempt at an aspect specification. The default is more strict for -- Ada versions before Ada 2012 (where aspect specifications are not -- permitted). Note: this routine never checks the terminator token - -- for aspects so it does not matter whether the aspect speficiations - -- are terminated by semicolon or some other character + -- for aspects so it does not matter whether the aspect specifications + -- are terminated by semicolon or some other character. + -- + -- Note: This function also handles the case of WHEN used where WITH + -- was intended, and in that case posts an error and returns True. procedure P_Aspect_Specifications (Decl : Node_Id; @@ -869,15 +992,17 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is -- argument is False, the scan pointer is left pointing past the aspects -- and the caller must check for a proper terminator. -- - -- P_Aspect_Specification is called with the current token pointing to - -- either a WITH keyword starting an aspect specification, or an - -- instance of the terminator token. In the former case, the aspect - -- specifications are scanned out including the terminator token if it - -- it is a semicolon, and the Has_Aspect_Specifications flag is set in - -- the given declaration node. A list of aspects is built and stored for - -- this declaration node using a call to Set_Aspect_Specifications. If - -- no WITH keyword is present, then this call has no effect other than - -- scanning out the terminator if it is a semicolon. + -- P_Aspect_Specifications is called with the current token pointing + -- to either a WITH keyword starting an aspect specification, or an + -- instance of what shpould be a terminator token. In the former case, + -- the aspect specifications are scanned out including the terminator + -- token if it is a semicolon, and the Has_Aspect_Specifications + -- flag is set in the given declaration node. A list of aspects + -- is built and stored for this declaration node using a call to + -- Set_Aspect_Specifications. If no WITH keyword is present, then this + -- call has no effect other than scanning out the terminator if it is a + -- semicolon (with the exception that it detects WHEN used in place of + -- WITH). -- If Decl is Error on entry, any scanned aspect specifications are -- ignored and a message is output saying aspect specifications not @@ -885,6 +1010,13 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is -- are also ignored, but no error message is given (this is used when -- the caller has already taken care of the error message). + function Get_Aspect_Specifications + (Semicolon : Boolean := True) return List_Id; + -- Parse a list of aspects but do not attach them to a declaration node. + -- Subsidiary to P_Aspect_Specifications procedure. Used when parsing + -- a subprogram specification that may be a declaration or a body. + -- Semicolon has the same meaning as for P_Aspect_Specifications above. + function P_Code_Statement (Subtype_Mark : Node_Id) return Node_Id; -- Function to parse a code statement. The caller has scanned out -- the name to be used as the subtype mark (but has not checked that @@ -987,6 +1119,10 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is -- advanced to the next vertical bar, arrow, or semicolon, whichever -- comes first. We also quit if we encounter an end of file. + procedure Resync_Cunit; + -- Synchronize to next token which could be the start of a compilation + -- unit, or to the end of file token. + procedure Resync_Expression; -- Used if an error is detected during the parsing of an expression. -- It skips past tokens until either a token which cannot be part of @@ -995,6 +1131,11 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is -- current parenthesis level (a parenthesis level counter is maintained -- to carry out this test). + procedure Resync_Past_Malformed_Aspect; + -- Used when parsing aspect specifications to skip a malformed aspect. + -- The scan pointer is positioned next to a comma, a semicolon or "is" + -- when the aspect applies to a body. + procedure Resync_Past_Semicolon; -- Used if an error occurs while scanning a sequence of declarations. -- The scan pointer is positioned past the next semicolon and the scan @@ -1002,30 +1143,26 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is -- starts a declaration (but we make sure to skip at least one token -- in this case, to avoid getting stuck in a loop). - procedure Resync_To_Semicolon; - -- Similar to Resync_Past_Semicolon, except that the scan pointer is - -- left pointing to the semicolon rather than past it. - procedure Resync_Past_Semicolon_Or_To_Loop_Or_Then; -- Used if an error occurs while scanning a sequence of statements. The -- scan pointer is positioned past the next semicolon, or to the next -- occurrence of either then or loop, and the scan resumes. - procedure Resync_To_When; - -- Used when an error occurs scanning an entry index specification. The - -- scan pointer is positioned to the next WHEN (or to IS or semicolon if - -- either of these appear before WHEN, indicating another error has - -- occurred). - procedure Resync_Semicolon_List; -- Used if an error occurs while scanning a parenthesized list of items -- separated by semicolons. The scan pointer is advanced to the next -- semicolon or right parenthesis at the outer parenthesis level, or -- to the next is or RETURN keyword occurrence, whichever comes first. - procedure Resync_Cunit; - -- Synchronize to next token which could be the start of a compilation - -- unit, or to the end of file token. + procedure Resync_To_Semicolon; + -- Similar to Resync_Past_Semicolon, except that the scan pointer is + -- left pointing to the semicolon rather than past it. + + procedure Resync_To_When; + -- Used when an error occurs scanning an entry index specification. The + -- scan pointer is positioned to the next WHEN (or to IS or semicolon if + -- either of these appear before WHEN, indicating another error has + -- occurred). end Sync; -------------- @@ -1141,6 +1278,11 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is -- mode. The caller has typically checked that the current token, -- an identifier, matches one of the 95 keywords. + procedure Check_Future_Keyword; + -- Emit a warning if the current token is a valid identifier in the + -- language version in use, but is a reserved word in a later language + -- version (unless the language version in use is Ada 83). + procedure Check_Simple_Expression (E : Node_Id); -- Given an expression E, that has just been scanned, so that Expr_Form -- is still set, outputs an error if E is a non-simple expression. E is @@ -1213,7 +1355,7 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is -- Push a new entry onto the scope stack. Scope.Last (the stack pointer) -- is incremented. The Junk field is preinitialized to False. The caller -- is expected to fill in all remaining entries of the new top stack - -- entry at Scope.Table (Scope.Last). + -- entry at Scopes (Scope.Last). procedure Pop_Scope_Stack; -- Pop an entry off the top of the scope stack. Scope_Last (the scope @@ -1238,6 +1380,11 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is function Token_Is_At_End_Of_Line return Boolean; -- Determines if the current token is the last token on the line + procedure Warn_If_Standard_Redefinition (N : Node_Id); + -- Issues a warning if Warn_On_Standard_Redefinition is set True, and + -- the Node N (which is a Defining_Identifier node with the Chars field + -- set) is a renaming of an entity in package Standard. + end Util; -------------- @@ -1333,6 +1480,8 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is procedure Labl is separate; procedure Load is separate; + Result : List_Id := Empty_List; + -- Start of processing for Par begin @@ -1348,13 +1497,13 @@ begin begin loop if Token = Tok_EOF then - Compiler_State := Analyzing; - return Pragmas; + Result := Pragmas; + exit; elsif Token /= Tok_Pragma then Error_Msg_SC ("only pragmas allowed in configuration file"); - Compiler_State := Analyzing; - return Error_List; + Result := Error_List; + exit; else P_Node := P_Pragma; @@ -1363,10 +1512,12 @@ begin -- Give error if bad pragma - if not Is_Configuration_Pragma_Name (Pragma_Name (P_Node)) - and then Pragma_Name (P_Node) /= Name_Source_Reference + if not Is_Configuration_Pragma_Name + (Pragma_Name_Unmapped (P_Node)) + and then + Pragma_Name_Unmapped (P_Node) /= Name_Source_Reference then - if Is_Pragma_Name (Pragma_Name (P_Node)) then + if Is_Pragma_Name (Pragma_Name_Unmapped (P_Node)) then Error_Msg_N ("only configuration pragmas allowed " & "in configuration file", P_Node); @@ -1389,7 +1540,7 @@ begin -- Normal case of compilation unit else - Save_Opt_Config_Switches (Save_Config_Switches); + Save_Config_Attrs := Save_Config_Switches; -- The following loop runs more than once in syntax check mode -- where we allow multiple compilation units in the same file @@ -1397,16 +1548,16 @@ begin -- we get to the unit we want. for Ucount in Pos loop - Set_Opt_Config_Switches - (Is_Internal_File_Name (File_Name (Current_Source_File)), - Current_Source_Unit = Main_Unit); + Set_Config_Switches + (Is_Internal_Unit (Current_Source_Unit), + Main_Unit => Current_Source_Unit = Main_Unit); -- Initialize scope table and other parser control variables Compiler_State := Parsing; Scope.Init; Scope.Increment_Last; - Scope.Table (0).Etyp := E_Dummy; + Scopes (0).Etyp := E_Dummy; SIS_Entry_Active := False; Last_Resync_Point := No_Location; @@ -1456,16 +1607,17 @@ begin -- mode, check that language-defined units are compiled in GNAT -- mode. For this purpose we do NOT consider renamings in annex -- J as predefined. That allows users to compile their own - -- versions of these files, and in particular, in the VMS - -- implementation, the DEC versions can be substituted for the - -- standard Ada 95 versions. Another exception is System.RPC + -- versions of these files. Another exception is System.RPC -- and its children. This allows a user to supply their own -- communication layer. + -- Similarly, we do not generate an error in CodePeer mode, + -- to allow users to analyze third-party compiler packages. if Comp_Unit_Node /= Error and then Operating_Mode = Generate_Code and then Current_Source_Unit = Main_Unit and then not GNAT_Mode + and then not CodePeer_Mode then declare Uname : constant String := @@ -1492,7 +1644,7 @@ begin Name (Name'First .. Name'First + 3) = "ada." then Error_Msg - ("user-defined descendents of package Ada " & + ("user-defined descendants of package Ada " & "are not allowed", Sloc (Unit (Comp_Unit_Node))); @@ -1501,7 +1653,7 @@ begin Name (Name'First .. Name'First + 10) = "interfaces." then Error_Msg - ("user-defined descendents of package Interfaces " & + ("user-defined descendants of package Interfaces " & "are not allowed", Sloc (Unit (Comp_Unit_Node))); @@ -1514,7 +1666,7 @@ begin "system.rpc.") then Error_Msg - ("user-defined descendents of package System " & + ("user-defined descendants of package System " & "are not allowed", Sloc (Unit (Comp_Unit_Node))); end if; @@ -1532,7 +1684,7 @@ begin end if; - Restore_Opt_Config_Switches (Save_Config_Switches); + Restore_Config_Switches (Save_Config_Attrs); end loop; -- Now that we have completely parsed the source file, we can complete @@ -1547,7 +1699,7 @@ begin -- Here we make the SCO table entries for the main unit if Generate_SCO then - SCO_Record (Main_Unit); + SCO_Record_Raw (Main_Unit); end if; -- Remaining steps are to create implicit label declarations and to load @@ -1561,9 +1713,11 @@ begin -- Restore settings of switches saved on entry - Restore_Opt_Config_Switches (Save_Config_Switches); + Restore_Config_Switches (Save_Config_Attrs); Set_Comes_From_Source_Default (False); - Compiler_State := Analyzing; - return Empty_List; end if; + + Compiler_State := Analyzing; + Current_Source_File := No_Source_File; + return Result; end Par;