-- --
-- B o d y --
-- --
--- $Revision: 1.1 $
--- --
--- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2010, 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 2, or (at your option) any later ver- --
+-- 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 COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- 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. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
function P_Case_Statement return Node_Id;
function P_Case_Statement_Alternative return Node_Id;
- function P_Condition return Node_Id;
function P_Exit_Statement return Node_Id;
function P_Goto_Statement return Node_Id;
function P_If_Statement return Node_Id;
-- 5.1 Sequence of Statements --
---------------------------------
- -- SEQUENCE_OF_STATEMENTS ::= STATEMENT {STATEMENT}
+ -- SEQUENCE_OF_STATEMENTS ::= STATEMENT {STATEMENT} {LABEL}
+ -- Note: the final label is an Ada 2012 addition.
-- STATEMENT ::=
-- {LABEL} SIMPLE_STATEMENT | {LABEL} COMPOUND_STATEMENT
-- is required. It is initialized from the Sreq flag, and modified as
-- statements are scanned (a statement turns it off, and a label turns
-- it back on again since a statement must follow a label).
+ -- Note : this final requirement is lifted in Ada 2012.
+
+ Statement_Seen : Boolean;
+ -- In Ada 2012, a label can end a sequence of statements, but the
+ -- sequence cannot contain only labels. This flag is set whenever a
+ -- label is encountered, to enforce this rule at the end of a sequence.
Declaration_Found : Boolean := False;
-- This flag is set True if a declaration is encountered, so that the
procedure Test_Statement_Required;
-- Flag error if Statement_Required flag set
+ ----------------------
+ -- Junk_Declaration --
+ ----------------------
+
procedure Junk_Declaration is
begin
if (not Declaration_Found) or All_Errors_Mode then
- Error_Msg_SC ("declarations must come before BEGIN");
+ Error_Msg_SC -- CODEFIX
+ ("declarations must come before BEGIN");
Declaration_Found := True;
end if;
Skip_Declaration (Statement_List);
end Junk_Declaration;
+ -----------------------------
+ -- Test_Statement_Required --
+ -----------------------------
+
procedure Test_Statement_Required is
+ function All_Pragmas return Boolean;
+ -- Return True if statement list is all pragmas
+
+ -----------------
+ -- All_Pragmas --
+ -----------------
+
+ function All_Pragmas return Boolean is
+ S : Node_Id;
+ begin
+ S := First (Statement_List);
+ while Present (S) loop
+ if Nkind (S) /= N_Pragma then
+ return False;
+ else
+ Next (S);
+ end if;
+ end loop;
+
+ return True;
+ end All_Pragmas;
+
+ -- Start of processing for Test_Statement_Required
+
begin
if Statement_Required then
- Error_Msg_BC ("statement expected");
+
+ -- Check no statement required after label in Ada 2012, and that
+ -- it is OK to have nothing but pragmas in a statement sequence.
+
+ if Ada_Version >= Ada_2012
+ and then not Is_Empty_List (Statement_List)
+ and then
+ ((Nkind (Last (Statement_List)) = N_Label
+ and then Statement_Seen)
+ or else All_Pragmas)
+ then
+ declare
+ Null_Stm : constant Node_Id :=
+ Make_Null_Statement (Token_Ptr);
+ begin
+ Set_Comes_From_Source (Null_Stm, False);
+ Append_To (Statement_List, Null_Stm);
+ end;
+
+ -- If not Ada 2012, or not special case above, give error message
+
+ else
+ Error_Msg_BC -- CODEFIX
+ ("statement expected");
+ end if;
end if;
end Test_Statement_Required;
begin
Statement_List := New_List;
Statement_Required := SS_Flags.Sreq;
+ Statement_Seen := False;
loop
- while Token = Tok_Semicolon loop
- Error_Msg_SC ("unexpected semicolon ignored");
- Scan; -- past junk semicolon
- end loop;
+ Ignore (Tok_Semicolon);
begin
- if Style_Check then Style.Check_Indentation; end if;
+ if Style_Check then
+ Style.Check_Indentation;
+ end if;
-- Deal with reserved identifier (in assignment or call)
when Tok_Exception =>
Test_Statement_Required;
- -- If Extm not set and the exception is not to the left
- -- of the expected column of the end for this sequence, then
- -- we assume it belongs to the current sequence, even though
- -- it is not permitted.
+ -- If Extm not set and the exception is not to the left of
+ -- the expected column of the end for this sequence, then we
+ -- assume it belongs to the current sequence, even though it
+ -- is not permitted.
if not SS_Flags.Extm and then
Start_Column >= Scope.Table (Scope.Last).Ecol
-- Always return, in the case where we scanned out handlers
-- that we did not expect, Parse_Exception_Handlers returned
- -- with Token being either end or EOF, so we are OK
+ -- with Token being either end or EOF, so we are OK.
exit;
when Tok_Or =>
- -- Terminate if Ortm set or if the or is to the left
- -- of the expected column of the end for this sequence
+ -- Terminate if Ortm set or if the or is to the left of the
+ -- expected column of the end for this sequence.
if SS_Flags.Ortm
or else Start_Column < Scope.Table (Scope.Last).Ecol
exit when SS_Flags.Tatm and then Token = Tok_Abort;
- -- Otherwise we treat THEN as some kind of mess where we
- -- did not see the associated IF, but we pick up assuming
- -- it had been there!
+ -- Otherwise we treat THEN as some kind of mess where we did
+ -- not see the associated IF, but we pick up assuming it had
+ -- been there!
Restore_Scan_State (Scan_State); -- to THEN
Append_To (Statement_List, P_If_Statement);
when Tok_When | Tok_Others =>
- -- Terminate if Whtm set or if the WHEN is to the left
- -- of the expected column of the end for this sequence
+ -- Terminate if Whtm set or if the WHEN is to the left of
+ -- the expected column of the end for this sequence.
if SS_Flags.Whtm
or else Start_Column < Scope.Table (Scope.Last).Ecol
and then Block_Label = Name_Go
and then Token_Name = Name_To
then
- Error_Msg_SP ("goto is one word");
+ Error_Msg_SP -- CODEFIX
+ ("goto is one word");
Append_To (Statement_List, P_Goto_Statement);
Statement_Required := False;
-- Skip junk right parens in this context
- while Token = Tok_Right_Paren loop
- Error_Msg_SC ("extra right paren");
- Scan; -- past )
- end loop;
+ Ignore (Tok_Right_Paren);
-- Check context following call
Scan; -- past semicolon
Statement_Required := False;
- -- Else we have a missing semicolon
+ -- A slash following an identifier or a selected
+ -- component in this situation is most likely a period
+ -- (see location of keys on keyboard).
+
+ elsif Token = Tok_Slash
+ and then (Nkind (Name_Node) = N_Identifier
+ or else
+ Nkind (Name_Node) = N_Selected_Component)
+ then
+ Error_Msg_SC -- CODEFIX
+ ("""/"" should be "".""");
+ Statement_Required := False;
+ raise Error_Resync;
+
+ -- Else we have a missing semicolon
else
TF_Semicolon;
Statement_Required := False;
-- Label starting with << which must precede real statement
+ -- Note: in Ada 2012, the label may end the sequence.
when Tok_Less_Less =>
+ if Present (Last (Statement_List))
+ and then Nkind (Last (Statement_List)) /= N_Label
+ then
+ Statement_Seen := True;
+ end if;
+
Append_To (Statement_List, P_Label);
Statement_Required := True;
Junk_Declaration;
else
- Error_Msg_BC ("statement expected");
+ Error_Msg_BC -- CODEFIX
+ ("statement expected");
raise Error_Resync;
end if;
end case;
if Nkind (Name_Node) = N_Indexed_Component then
declare
- Prefix_Node : Node_Id := Prefix (Name_Node);
- Exprs_Node : List_Id := Expressions (Name_Node);
+ Prefix_Node : constant Node_Id := Prefix (Name_Node);
+ Exprs_Node : constant List_Id := Expressions (Name_Node);
+
begin
Change_Node (Name_Node, N_Procedure_Call_Statement);
Set_Name (Name_Node, Prefix_Node);
elsif Nkind (Name_Node) = N_Function_Call then
declare
- Fname_Node : Node_Id := Name (Name_Node);
- Params_List : List_Id := Parameter_Associations (Name_Node);
+ Fname_Node : constant Node_Id := Name (Name_Node);
+ Params_List : constant List_Id :=
+ Parameter_Associations (Name_Node);
begin
Change_Node (Name_Node, N_Procedure_Call_Statement);
begin
Label_Node := New_Node (N_Label, Token_Ptr);
Scan; -- past <<
- Set_Identifier (Label_Node, P_Identifier);
+ Set_Identifier (Label_Node, P_Identifier (C_Greater_Greater));
T_Greater_Greater;
Append_Elmt (Label_Node, Label_List);
return Label_Node;
-- scanned out and is in Prev_Token.
procedure Check_If_Column;
- -- An internal procedure used to check that THEN, ELSE ELSE, or ELSIF
+ -- An internal procedure used to check that THEN, ELSE, or ELSIF
-- appear in the right place if column checking is enabled (i.e. if
-- they are the first token on the line, then they must appear in
-- the same column as the opening IF).
procedure Check_If_Column is
begin
- if Style.RM_Column_Check and then Token_Is_At_Start_Of_Line
+ if RM_Column_Check and then Token_Is_At_Start_Of_Line
and then Start_Column /= Scope.Table (Scope.Last).Ecol
then
Error_Msg_Col := Scope.Table (Scope.Last).Ecol;
begin
if Token_Is_At_Start_Of_Line and then Token = Tok_Then then
Check_If_Column;
- if Style_Check then Style.Check_Then (Loc); end if;
+
+ if Style_Check then
+ Style.Check_Then (Loc);
+ end if;
end if;
end Check_Then_Column;
-- of WHEN expression =>
if Token = Tok_Arrow then
- Error_Msg_SC ("THEN expected");
+ Error_Msg_SC -- CODEFIX
+ ("THEN expected");
Scan; -- past the arrow
Pop_Scope_Stack; -- remove unneeded entry
raise Error_Resync;
Scan; -- past ELSE
if Else_Should_Be_Elsif then
- Error_Msg_SP ("ELSE should be ELSIF");
+ Error_Msg_SP -- CODEFIX
+ ("ELSE should be ELSIF");
Add_Elsif_Part;
else
-- Here we have an else that really is an else
if Present (Else_Statements (If_Node)) then
- Error_Msg_SP ("Only one ELSE part allowed");
+ Error_Msg_SP ("only one ELSE part allowed");
Append_List
(P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq),
Else_Statements (If_Node));
-- to reconstruct the tree correctly in this case, but we do at least
-- give an accurate error message.
- while Token = Tok_Colon_Equal loop
- Error_Msg_SC (""":="" should be ""=""");
- Scan; -- past junk :=
- Discard_Junk_Node (P_Expression_No_Right_Paren);
- end loop;
+ if Token = Tok_Colon_Equal then
+ while Token = Tok_Colon_Equal loop
+ Error_Msg_SC -- CODEFIX
+ (""":="" should be ""=""");
+ Scan; -- past junk :=
+ Discard_Junk_Node (P_Expression_No_Right_Paren);
+ end loop;
+
+ return Cond;
+
+ -- Otherwise check for redundant parens
+
+ else
+ if Style_Check
+ and then Paren_Count (Cond) > 0
+ then
+ Style.Check_Xtra_Parens (First_Sloc (Cond));
+ end if;
+
+ -- And return the result
- return Cond;
+ return Cond;
+ end if;
end P_Condition;
-------------------------
Case_Alt_Node : Node_Id;
begin
- if Style_Check then Style.Check_Indentation; end if;
+ if Style_Check then
+ Style.Check_Indentation;
+ end if;
+
Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Token_Ptr);
T_When; -- past WHEN (or give error in OTHERS case)
Set_Discrete_Choices (Case_Alt_Node, P_Discrete_Choice_List);
-- Error recovery : cannot raise Error_Resync
function P_Loop_Statement (Loop_Name : Node_Id := Empty) return Node_Id is
- Loop_Node : Node_Id;
+ Loop_Node : Node_Id;
+ Created_Name : Node_Id;
begin
Push_Scope_Stack;
TF_Loop;
if No (Loop_Name) then
+ Created_Name :=
+ Make_Identifier (Sloc (Loop_Node),
+ Chars => Set_Loop_Block_Name ('L'));
+ Set_Comes_From_Source (Created_Name, False);
Set_Has_Created_Identifier (Loop_Node, True);
- Set_Identifier (Loop_Node,
- Make_Identifier (Sloc (Loop_Node), Set_Loop_Block_Name ('L')));
+ Set_Identifier (Loop_Node, Created_Name);
+ Scope.Table (Scope.Last).Labl := Created_Name;
else
Set_Identifier (Loop_Node, Loop_Name);
end if;
Append_Elmt (Loop_Node, Label_List);
-
Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq));
End_Statements (Loop_Node);
return Loop_Node;
Loop_Node : Node_Id;
Iter_Scheme_Node : Node_Id;
Loop_For_Flag : Boolean;
+ Created_Name : Node_Id;
begin
Push_Scope_Stack;
else
Loop_Node := New_Node (N_Loop_Statement, Token_Ptr);
- TF_Loop;
- Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq));
- End_Statements (Loop_Node);
- Set_Iteration_Scheme (Loop_Node, Iter_Scheme_Node);
if No (Loop_Name) then
+ Created_Name :=
+ Make_Identifier (Sloc (Loop_Node),
+ Chars => Set_Loop_Block_Name ('L'));
+ Set_Comes_From_Source (Created_Name, False);
Set_Has_Created_Identifier (Loop_Node, True);
- Set_Identifier (Loop_Node,
- Make_Identifier (Sloc (Loop_Node), Set_Loop_Block_Name ('L')));
+ Set_Identifier (Loop_Node, Created_Name);
+ Scope.Table (Scope.Last).Labl := Created_Name;
else
Set_Identifier (Loop_Node, Loop_Name);
end if;
+ TF_Loop;
+ Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq));
+ End_Statements (Loop_Node);
+ Set_Iteration_Scheme (Loop_Node, Iter_Scheme_Node);
Append_Elmt (Loop_Node, Label_List);
-
return Loop_Node;
end if;
-
end P_For_Statement;
-- P_While_Statement
Loop_Node : Node_Id;
Iter_Scheme_Node : Node_Id;
Loop_While_Flag : Boolean;
+ Created_Name : Node_Id;
begin
Push_Scope_Stack;
else
Loop_Node := New_Node (N_Loop_Statement, Token_Ptr);
TF_Loop;
- Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq));
- End_Statements (Loop_Node);
- Set_Iteration_Scheme (Loop_Node, Iter_Scheme_Node);
if No (Loop_Name) then
+ Created_Name :=
+ Make_Identifier (Sloc (Loop_Node),
+ Chars => Set_Loop_Block_Name ('L'));
+ Set_Comes_From_Source (Created_Name, False);
Set_Has_Created_Identifier (Loop_Node, True);
- Set_Identifier (Loop_Node,
- Make_Identifier (Sloc (Loop_Node), Set_Loop_Block_Name ('L')));
+ Set_Identifier (Loop_Node, Created_Name);
+ Scope.Table (Scope.Last).Labl := Created_Name;
else
Set_Identifier (Loop_Node, Loop_Name);
end if;
+ Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq));
+ End_Statements (Loop_Node);
+ Set_Iteration_Scheme (Loop_Node, Iter_Scheme_Node);
Append_Elmt (Loop_Node, Label_List);
-
return Loop_Node;
end if;
-
end P_While_Statement;
---------------------------------------
New_Node (N_Loop_Parameter_Specification, Token_Ptr);
Save_Scan_State (Scan_State);
- ID_Node := P_Defining_Identifier;
+ ID_Node := P_Defining_Identifier (C_In);
Set_Defining_Identifier (Loop_Param_Specification_Node, ID_Node);
if Token = Tok_Left_Paren then
-- This function parses a block statement with DECLARE present
- -- The caller has checked that the initial token is DECLARE.
+ -- The caller has checked that the initial token is DECLARE
-- Error recovery: cannot raise Error_Resync
(Block_Name : Node_Id := Empty)
return Node_Id
is
- Block_Node : Node_Id;
+ Block_Node : Node_Id;
+ Created_Name : Node_Id;
begin
Block_Node := New_Node (N_Block_Statement, Token_Ptr);
Scan; -- past DECLARE
if No (Block_Name) then
+ Created_Name :=
+ Make_Identifier (Sloc (Block_Node),
+ Chars => Set_Loop_Block_Name ('B'));
+ Set_Comes_From_Source (Created_Name, False);
Set_Has_Created_Identifier (Block_Node, True);
- Set_Identifier (Block_Node,
- Make_Identifier (Sloc (Block_Node), Set_Loop_Block_Name ('B')));
+ Set_Identifier (Block_Node, Created_Name);
+ Scope.Table (Scope.Last).Labl := Created_Name;
else
Set_Identifier (Block_Node, Block_Name);
end if;
(Block_Name : Node_Id := Empty)
return Node_Id
is
- Block_Node : Node_Id;
+ Block_Node : Node_Id;
+ Created_Name : Node_Id;
begin
Block_Node := New_Node (N_Block_Statement, Token_Ptr);
Scope.Table (Scope.Last).Sloc := Token_Ptr;
if No (Block_Name) then
+ Created_Name :=
+ Make_Identifier (Sloc (Block_Node),
+ Chars => Set_Loop_Block_Name ('B'));
+ Set_Comes_From_Source (Created_Name, False);
Set_Has_Created_Identifier (Block_Node, True);
- Set_Identifier (Block_Node,
- Make_Identifier (Sloc (Block_Node), Set_Loop_Block_Name ('B')));
+ Set_Identifier (Block_Node, Created_Name);
+ Scope.Table (Scope.Last).Labl := Created_Name;
else
Set_Identifier (Block_Node, Block_Name);
end if;
-- WHEN token, and returns True if a semicolon is missing before
-- the WHEN as in the above example.
+ -------------------------------
+ -- Missing_Semicolon_On_Exit --
+ -------------------------------
+
function Missing_Semicolon_On_Exit return Boolean is
State : Saved_Scan_State;
Check_No_Exit_Name :
for J in reverse 1 .. Scope.Last loop
if Scope.Table (J).Etyp = E_Loop then
- if Present (Scope.Table (J).Labl) then
-
+ if Present (Scope.Table (J).Labl)
+ and then Comes_From_Source (Scope.Table (J).Labl)
+ then
-- Innermost loop in fact had a name, style check fails
Style.No_Exit_Name (Scope.Table (J).Labl);
Goto_Node := New_Node (N_Goto_Statement, Token_Ptr);
Scan; -- past GOTO (or TO)
Set_Name (Goto_Node, P_Qualified_Simple_Name_Resync);
+ Append_Elmt (Goto_Node, Goto_List);
No_Constraint;
TF_Semicolon;
return Goto_Node;
-- Check for misplacement of later vs basic declarations in Ada 83
- if Ada_83 then
+ if Ada_Version = Ada_83 then
Decl := First (Decls);
-- Loop through sequence of basic declarative items
if Nkind (Decl) not in N_Later_Decl_Item
and then Nkind (Decl) /= N_Pragma
then
- if Ada_83 then
+ if Ada_Version = Ada_83 then
Error_Msg_Sloc := Body_Sloc;
Error_Msg_N
("(Ada 83) decl cannot appear after body#", Decl);
Set_Declarations (Parent, Decls);
if Token = Tok_Begin then
- if Style_Check then Style.Check_Indentation; end if;
+ if Style_Check then
+ Style.Check_Indentation;
+ end if;
Error_Msg_Col := Scope.Table (Scope.Last).Ecol;
- if Style.RM_Column_Check
+ if RM_Column_Check
and then Token_Is_At_Start_Of_Line
and then Start_Column /= Error_Msg_Col
then
-- What we are interested in is whether it was a case of a bad IS.
if Scope.Table (Scope.Last + 1).Etyp = E_Bad_Is then
- Error_Msg ("IS should be "";""", Scope.Table (Scope.Last + 1).S_Is);
+ Error_Msg -- CODEFIX
+ ("|IS should be "";""", Scope.Table (Scope.Last + 1).S_Is);
Set_Bad_Is_Detected (Parent, True);
end if;
TF_Then;
while Token = Tok_Then loop
- Error_Msg_SC ("redundant THEN");
+ Error_Msg_SC -- CODEFIX
+ ("redundant THEN");
TF_Then;
end loop;
if Token = Tok_And or else Token = Tok_Or then
Error_Msg_SC ("unexpected logical operator");
- Scan;
+ Scan; -- past logical operator
if (Prev_Token = Tok_And and then Token = Tok_Then)
or else
OSDN Git Service
