-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2012, 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- --
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 --
--------------------
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
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);
-- 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 to provide the name of the construct being parsed
-- 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, and selects, the
- -- field is initialized to Error.
+ -- 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
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 --
---------------------------------
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
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.
-------------
package Ch8 is
- function P_Use_Clause return Node_Id;
+ procedure P_Use_Clause (Item_List : List_Id);
end Ch8;
-------------
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;
-- permitted). Note: this routine never checks the terminator token
-- for aspects so it does not matter whether the aspect specifications
-- are terminated by semicolon or some other character.
-
- 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 the following procedure. Used when parsing a subprogram
- -- specification that may be a declaration or a body.
+ --
+ -- 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;
-- argument is False, the scan pointer is left pointing past the aspects
-- and the caller must check for a proper terminator.
--
- -- P_Aspect_Specifications 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
-- 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
-- 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
-- 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
-- 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;
--------------
-- 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
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;
--------------
procedure Labl is separate;
procedure Load is separate;
+ Result : List_Id := Empty_List;
+
-- Start of processing for Par
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;
-- 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);
-- 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
-- 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;
-- 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 :=
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)));
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)));
"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;
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
-- 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
-- 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;
projects / gcc.git / blobdiff