pragma Style_Checks (All_Checks);
separate (Par)
package body Ch5 is
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;
function P_Label return Node_Id;
function P_Loop_Parameter_Specification return Node_Id;
function P_Null_Statement return Node_Id;
function P_Assignment_Statement (LHS : Node_Id) return Node_Id;
function P_Begin_Statement (Block_Name : Node_Id := Empty) return Node_Id;
function P_Declare_Statement (Block_Name : Node_Id := Empty) return Node_Id;
function P_For_Statement (Loop_Name : Node_Id := Empty) return Node_Id;
function P_Loop_Statement (Loop_Name : Node_Id := Empty) return Node_Id;
function P_While_Statement (Loop_Name : Node_Id := Empty) return Node_Id;
function Set_Loop_Block_Name (L : Character) return Name_Id;
procedure Then_Scan;
function P_Sequence_Of_Statements (SS_Flags : SS_Rec) return List_Id is
Statement_Required : Boolean;
Declaration_Found : Boolean := False;
Scan_State_Label : Saved_Scan_State;
Scan_State : Saved_Scan_State;
Statement_List : List_Id;
Block_Label : Name_Id;
Id_Node : Node_Id;
Name_Node : Node_Id;
procedure Junk_Declaration;
procedure Test_Statement_Required;
procedure Junk_Declaration is
begin
if (not Declaration_Found) or All_Errors_Mode then
Error_Msg_SC ("declarations must come before BEGIN");
Declaration_Found := True;
end if;
Skip_Declaration (Statement_List);
end Junk_Declaration;
procedure Test_Statement_Required is
begin
if Statement_Required then
Error_Msg_BC ("statement expected");
end if;
end Test_Statement_Required;
begin
Statement_List := New_List;
Statement_Required := SS_Flags.Sreq;
loop
while Token = Tok_Semicolon loop
Error_Msg_SC ("unexpected semicolon ignored");
Scan; end loop;
begin
if Style_Check then Style.Check_Indentation; end if;
if Is_Reserved_Identifier then
Save_Scan_State (Scan_State); Scan;
if
(Token = Tok_Semicolon
and then Prev_Token /= Tok_Return
and then Prev_Token /= Tok_Null
and then Prev_Token /= Tok_Raise
and then Prev_Token /= Tok_End
and then Prev_Token /= Tok_Exit)
or else Token = Tok_Colon
or else Token = Tok_Colon_Equal
or else Token = Tok_Dot
or else
(Token = Tok_Left_Paren
and then Prev_Token /= Tok_Case
and then Prev_Token /= Tok_Delay
and then Prev_Token /= Tok_If
and then Prev_Token /= Tok_Elsif
and then Prev_Token /= Tok_Return
and then Prev_Token /= Tok_When
and then Prev_Token /= Tok_While
and then Prev_Token /= Tok_Separate)
then
Restore_Scan_State (Scan_State); Scan_Reserved_Identifier (Force_Msg => False);
else
Restore_Scan_State (Scan_State); end if;
end if;
case Token is
when Tok_End | Tok_EOF =>
Test_Statement_Required;
exit;
when Tok_Elsif =>
if SS_Flags.Eftm
or else Start_Column < Scope.Table (Scope.Last).Ecol
then
Test_Statement_Required;
exit;
else
Error_Msg_SC ("ELSIF not allowed here");
Scan; Discard_Junk_Node (P_Expression_No_Right_Paren);
Then_Scan;
Statement_Required := False;
end if;
when Tok_Else =>
if SS_Flags.Eltm
or else Start_Column < Scope.Table (Scope.Last).Ecol
then
Test_Statement_Required;
exit;
else
Error_Msg_SC ("ELSE not allowed here");
Scan; Statement_Required := False;
end if;
when Tok_Exception =>
Test_Statement_Required;
if not SS_Flags.Extm and then
Start_Column >= Scope.Table (Scope.Last).Ecol
then
Error_Msg_SC ("exception handler not permitted here");
Scan; Discard_Junk_List (Parse_Exception_Handlers);
end if;
exit;
when Tok_Or =>
if SS_Flags.Ortm
or else Start_Column < Scope.Table (Scope.Last).Ecol
then
Test_Statement_Required;
exit;
else
Error_Msg_SC ("OR not allowed here");
Scan; Statement_Required := False;
end if;
when Tok_Then =>
Save_Scan_State (Scan_State); Scan;
exit when SS_Flags.Tatm and then Token = Tok_Abort;
Restore_Scan_State (Scan_State); Append_To (Statement_List, P_If_Statement);
Statement_Required := False;
when Tok_When | Tok_Others =>
if SS_Flags.Whtm
or else Start_Column < Scope.Table (Scope.Last).Ecol
then
Test_Statement_Required;
exit;
else
Error_Msg_SC ("WHEN not allowed here");
Scan; Discard_Junk_List (P_Discrete_Choice_List);
TF_Arrow;
Statement_Required := False;
end if;
when Tok_Identifier =>
Check_Bad_Layout;
Id_Node := Token_Node;
Block_Label := Token_Name;
Save_Scan_State (Scan_State_Label); Scan;
if Token = Tok_Colon_Equal then
Scan; Append_To (Statement_List,
P_Assignment_Statement (Id_Node));
Statement_Required := False;
elsif Token = Tok_Semicolon then
Append_To (Statement_List,
P_Statement_Name (Id_Node));
Scan; Statement_Required := False;
elsif Token = Tok_Identifier
and then Block_Label = Name_Go
and then Token_Name = Name_To
then
Error_Msg_SP ("goto is one word");
Append_To (Statement_List, P_Goto_Statement);
Statement_Required := False;
elsif Token = Tok_Equal then
T_Colon_Equal; Append_To (Statement_List,
P_Assignment_Statement (Id_Node));
Statement_Required := False;
elsif Token = Tok_Colon
or else (Token in Token_Class_Labeled_Stmt
and then not Token_Is_At_Start_Of_Line)
then
T_Colon;
loop
exit when Token /= Tok_Identifier;
Save_Scan_State (Scan_State); Scan;
if Token = Tok_Colon then
Error_Msg_SP
("only one label allowed on block or loop");
Scan;
Scan_State_Label := Scan_State;
Block_Label := Error_Name;
else
Restore_Scan_State (Scan_State); exit;
end if;
end loop;
if Token = Tok_Loop then
Append_To (Statement_List,
P_Loop_Statement (Id_Node));
elsif Token = Tok_While then
Append_To (Statement_List,
P_While_Statement (Id_Node));
elsif Token = Tok_Declare then
Append_To (Statement_List,
P_Declare_Statement (Id_Node));
elsif Token = Tok_Begin then
Append_To (Statement_List,
P_Begin_Statement (Id_Node));
elsif Token = Tok_For then
Append_To (Statement_List,
P_For_Statement (Id_Node));
elsif Token not in Token_Class_Eterm then
Restore_Scan_State (Scan_State_Label);
Junk_Declaration;
else
Error_Msg_AP
("loop or block statement must follow label");
end if;
Statement_Required := False;
elsif Token in Token_Class_Namext then
Restore_Scan_State (Scan_State_Label); Name_Node := P_Name;
while Token = Tok_Right_Paren loop
Error_Msg_SC ("extra right paren");
Scan; end loop;
if Token = Tok_Colon_Equal then
Scan; Append_To (Statement_List,
P_Assignment_Statement (Name_Node));
Statement_Required := False;
elsif Token = Tok_Equal then
T_Colon_Equal; Append_To (Statement_List,
P_Assignment_Statement (Name_Node));
Statement_Required := False;
elsif Token = Tok_Apostrophe then
Append_To (Statement_List,
P_Code_Statement (Name_Node));
Statement_Required := False;
elsif Token = Tok_Semicolon then
Append_To (Statement_List,
P_Statement_Name (Name_Node));
Scan; Statement_Required := False;
elsif Token = Tok_Slash
and then (Nkind (Name_Node) = N_Identifier
or else
Nkind (Name_Node) = N_Selected_Component)
then
Error_Msg_SC ("""/"" should be "".""");
Statement_Required := False;
raise Error_Resync;
else
TF_Semicolon;
Statement_Required := False;
end if;
else
Restore_Scan_State (Scan_State_Label);
if Bad_Spelling_Of (Tok_Abort)
or else Bad_Spelling_Of (Tok_Accept)
or else Bad_Spelling_Of (Tok_Case)
or else Bad_Spelling_Of (Tok_Declare)
or else Bad_Spelling_Of (Tok_Delay)
or else Bad_Spelling_Of (Tok_Elsif)
or else Bad_Spelling_Of (Tok_Else)
or else Bad_Spelling_Of (Tok_End)
or else Bad_Spelling_Of (Tok_Exception)
or else Bad_Spelling_Of (Tok_Exit)
or else Bad_Spelling_Of (Tok_For)
or else Bad_Spelling_Of (Tok_Goto)
or else Bad_Spelling_Of (Tok_If)
or else Bad_Spelling_Of (Tok_Loop)
or else Bad_Spelling_Of (Tok_Or)
or else Bad_Spelling_Of (Tok_Pragma)
or else Bad_Spelling_Of (Tok_Raise)
or else Bad_Spelling_Of (Tok_Requeue)
or else Bad_Spelling_Of (Tok_Return)
or else Bad_Spelling_Of (Tok_Select)
or else Bad_Spelling_Of (Tok_When)
or else Bad_Spelling_Of (Tok_While)
then
null;
else
Scan;
if Token_Is_At_Start_Of_Line then
Append_To (Statement_List,
P_Statement_Name (Id_Node));
T_Semicolon; Statement_Required := False;
else
T_Colon_Equal; raise Error_Resync;
end if;
end if;
end if;
when Tok_Operator_Symbol =>
Check_Bad_Layout;
Name_Node := P_Name;
if Token = Tok_Apostrophe then
Error_Msg_SC ("apostrophe illegal here");
raise Error_Resync;
end if;
if Expr_Form = EF_Name
and then Token = Tok_Colon_Equal
then
Scan; Append_To (Statement_List,
P_Assignment_Statement (Name_Node));
else
Append_To (Statement_List,
P_Statement_Name (Name_Node));
end if;
TF_Semicolon;
Statement_Required := False;
when Tok_Less_Less =>
Append_To (Statement_List, P_Label);
Statement_Required := True;
when Tok_Pragma =>
Check_Bad_Layout;
Append_To (Statement_List, P_Pragma);
when Tok_Abort =>
Check_Bad_Layout;
Append_To (Statement_List, P_Abort_Statement);
Statement_Required := False;
when Tok_Accept =>
Check_Bad_Layout;
Append_To (Statement_List, P_Accept_Statement);
Statement_Required := False;
when Tok_Begin =>
Check_Bad_Layout;
Append_To (Statement_List, P_Begin_Statement);
Statement_Required := False;
when Tok_Case =>
Check_Bad_Layout;
Append_To (Statement_List, P_Case_Statement);
Statement_Required := False;
when Tok_Declare =>
Check_Bad_Layout;
Append_To (Statement_List, P_Declare_Statement);
Statement_Required := False;
when Tok_Delay =>
Check_Bad_Layout;
Append_To (Statement_List, P_Delay_Statement);
Statement_Required := False;
when Tok_Exit =>
Check_Bad_Layout;
Append_To (Statement_List, P_Exit_Statement);
Statement_Required := False;
when Tok_For =>
Check_Bad_Layout;
Append_To (Statement_List, P_For_Statement);
Statement_Required := False;
when Tok_Goto =>
Check_Bad_Layout;
Append_To (Statement_List, P_Goto_Statement);
Statement_Required := False;
when Tok_If =>
Check_Bad_Layout;
Append_To (Statement_List, P_If_Statement);
Statement_Required := False;
when Tok_Loop =>
Check_Bad_Layout;
Append_To (Statement_List, P_Loop_Statement);
Statement_Required := False;
when Tok_Null =>
Check_Bad_Layout;
Append_To (Statement_List, P_Null_Statement);
Statement_Required := False;
when Tok_Raise =>
Check_Bad_Layout;
Append_To (Statement_List, P_Raise_Statement);
Statement_Required := False;
when Tok_Requeue =>
Check_Bad_Layout;
Append_To (Statement_List, P_Requeue_Statement);
Statement_Required := False;
when Tok_Return =>
Check_Bad_Layout;
Append_To (Statement_List, P_Return_Statement);
Statement_Required := False;
when Tok_Select =>
Check_Bad_Layout;
Append_To (Statement_List, P_Select_Statement);
Statement_Required := False;
when Tok_While =>
Check_Bad_Layout;
Append_To (Statement_List, P_While_Statement);
Statement_Required := False;
when others =>
if Token in Token_Class_Declk then
Junk_Declaration;
else
Error_Msg_BC ("statement expected");
raise Error_Resync;
end if;
end case;
exception
when Error_Resync =>
Resync_Past_Semicolon_Or_To_Loop_Or_Then;
Statement_Required := False;
end;
exit when SS_Flags.Unco;
end loop;
return Statement_List;
end P_Sequence_Of_Statements;
function P_Statement_Name (Name_Node : Node_Id) return Node_Id is
Stmt_Node : Node_Id;
begin
if Nkind (Name_Node) = N_Indexed_Component then
declare
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);
Set_Parameter_Associations (Name_Node, Exprs_Node);
return Name_Node;
end;
elsif Nkind (Name_Node) = N_Function_Call then
declare
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);
Set_Name (Name_Node, Fname_Node);
Set_Parameter_Associations (Name_Node, Params_List);
return Name_Node;
end;
elsif Nkind (Name_Node) = N_Attribute_Reference
and then Is_Procedure_Attribute_Name (Attribute_Name (Name_Node))
then
return Name_Node;
else
Stmt_Node :=
New_Node (N_Procedure_Call_Statement, Sloc (Name_Node));
Set_Name (Stmt_Node, Name_Node);
return Stmt_Node;
end if;
end P_Statement_Name;
function P_Null_Statement return Node_Id is
Null_Stmt_Node : Node_Id;
begin
Null_Stmt_Node := New_Node (N_Null_Statement, Token_Ptr);
Scan; TF_Semicolon;
return Null_Stmt_Node;
end P_Null_Statement;
function P_Label return Node_Id is
Label_Node : Node_Id;
begin
Label_Node := New_Node (N_Label, Token_Ptr);
Scan; Set_Identifier (Label_Node, P_Identifier (C_Greater_Greater));
T_Greater_Greater;
Append_Elmt (Label_Node, Label_List);
return Label_Node;
end P_Label;
function P_Assignment_Statement (LHS : Node_Id) return Node_Id is
Assign_Node : Node_Id;
begin
Assign_Node := New_Node (N_Assignment_Statement, Prev_Token_Ptr);
Set_Name (Assign_Node, LHS);
Set_Expression (Assign_Node, P_Expression_No_Right_Paren);
TF_Semicolon;
return Assign_Node;
end P_Assignment_Statement;
function P_If_Statement return Node_Id is
If_Node : Node_Id;
Elsif_Node : Node_Id;
Loc : Source_Ptr;
procedure Add_Elsif_Part;
procedure Check_If_Column;
procedure Check_Then_Column;
function Else_Should_Be_Elsif return Boolean;
procedure Add_Elsif_Part is
begin
if No (Elsif_Parts (If_Node)) then
Set_Elsif_Parts (If_Node, New_List);
end if;
Elsif_Node := New_Node (N_Elsif_Part, Prev_Token_Ptr);
Loc := Prev_Token_Ptr;
Set_Condition (Elsif_Node, P_Condition);
Check_Then_Column;
Then_Scan;
Set_Then_Statements
(Elsif_Node, P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq));
Append (Elsif_Node, Elsif_Parts (If_Node));
end Add_Elsif_Part;
procedure Check_If_Column is
begin
if Style.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;
Error_Msg_SC ("(style) this token should be@");
end if;
end Check_If_Column;
procedure Check_Then_Column is
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;
end if;
end Check_Then_Column;
function Else_Should_Be_Elsif return Boolean is
Scan_State : Saved_Scan_State;
begin
if Token_Is_At_Start_Of_Line then
return False;
else
Save_Scan_State (Scan_State);
loop
if Token in Token_Class_Eterm then
Restore_Scan_State (Scan_State);
return False;
else
Scan;
if Token = Tok_Then then
Restore_Scan_State (Scan_State);
return True;
end if;
end if;
end loop;
end if;
end Else_Should_Be_Elsif;
begin
If_Node := New_Node (N_If_Statement, Token_Ptr);
Push_Scope_Stack;
Scope.Table (Scope.Last).Etyp := E_If;
Scope.Table (Scope.Last).Ecol := Start_Column;
Scope.Table (Scope.Last).Sloc := Token_Ptr;
Scope.Table (Scope.Last).Labl := Error;
Scope.Table (Scope.Last).Node := If_Node;
if Token = Tok_If then
Loc := Token_Ptr;
Scan; Set_Condition (If_Node, P_Condition);
if Token = Tok_Arrow then
Error_Msg_SC ("THEN expected");
Scan; Pop_Scope_Stack; raise Error_Resync;
end if;
Check_Then_Column;
else
Error_Msg_SC ("no IF for this THEN");
Set_Condition (If_Node, Error);
end if;
Then_Scan;
Set_Then_Statements
(If_Node, P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq));
loop
if Token = Tok_Elsif then
Check_If_Column;
if Present (Else_Statements (If_Node)) then
Error_Msg_SP ("ELSIF cannot appear after ELSE");
end if;
Scan; Add_Elsif_Part;
elsif Token = Tok_Else then
Check_If_Column;
Scan;
if Else_Should_Be_Elsif then
Error_Msg_SP ("ELSE should be ELSIF");
Add_Elsif_Part;
else
if Present (Else_Statements (If_Node)) then
Error_Msg_SP ("Only one ELSE part allowed");
Append_List
(P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq),
Else_Statements (If_Node));
else
Set_Else_Statements
(If_Node, P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq));
end if;
end if;
else
exit;
end if;
end loop;
End_Statements;
return If_Node;
end P_If_Statement;
function P_Condition return Node_Id is
Cond : Node_Id;
begin
Cond := P_Expression_No_Right_Paren;
if Token = Tok_Colon_Equal then
while Token = Tok_Colon_Equal loop
Error_Msg_SC (""":="" should be ""=""");
Scan; Discard_Junk_Node (P_Expression_No_Right_Paren);
end loop;
return Cond;
else
if Style_Check
and then Paren_Count (Cond) > 0
then
Style.Check_Xtra_Parens (First_Sloc (Cond));
end if;
return Cond;
end if;
end P_Condition;
function P_Case_Statement return Node_Id is
Case_Node : Node_Id;
Alternatives_List : List_Id;
First_When_Loc : Source_Ptr;
begin
Case_Node := New_Node (N_Case_Statement, Token_Ptr);
Push_Scope_Stack;
Scope.Table (Scope.Last).Etyp := E_Case;
Scope.Table (Scope.Last).Ecol := Start_Column;
Scope.Table (Scope.Last).Sloc := Token_Ptr;
Scope.Table (Scope.Last).Labl := Error;
Scope.Table (Scope.Last).Node := Case_Node;
Scan; Set_Expression (Case_Node, P_Expression_No_Right_Paren);
TF_Is;
Alternatives_List := New_List;
P_Pragmas_Opt (Alternatives_List);
First_When_Loc := Token_Ptr;
loop
if Token = Tok_When or else Token = Tok_Others then
Append (P_Case_Statement_Alternative, Alternatives_List);
elsif Token = Tok_End then
exit when Check_End;
elsif not Token_Is_At_Start_Of_Line
or else Start_Column > Scope.Table (Scope.Last).Ecol
then
Error_Msg_BC ("WHEN (case statement alternative) expected");
declare
Error_Ptr : constant Source_Ptr := Scan_Ptr;
begin
Discard_Junk_List (P_Sequence_Of_Statements (SS_Whtm));
exit when Scan_Ptr = Error_Ptr and then Check_End;
end;
else
exit when Check_End;
end if;
end loop;
if No (First_Non_Pragma (Alternatives_List)) then
Error_Msg
("WHEN expected, must have at least one alternative in case",
First_When_Loc);
return Error;
else
Set_Alternatives (Case_Node, Alternatives_List);
return Case_Node;
end if;
end P_Case_Statement;
function P_Case_Statement_Alternative return Node_Id is
Case_Alt_Node : Node_Id;
begin
if Style_Check then Style.Check_Indentation; end if;
Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Token_Ptr);
T_When; Set_Discrete_Choices (Case_Alt_Node, P_Discrete_Choice_List);
TF_Arrow;
Set_Statements (Case_Alt_Node, P_Sequence_Of_Statements (SS_Sreq_Whtm));
return Case_Alt_Node;
end P_Case_Statement_Alternative;
function P_Loop_Statement (Loop_Name : Node_Id := Empty) return Node_Id is
Loop_Node : Node_Id;
Created_Name : Node_Id;
begin
Push_Scope_Stack;
Scope.Table (Scope.Last).Labl := Loop_Name;
Scope.Table (Scope.Last).Ecol := Start_Column;
Scope.Table (Scope.Last).Sloc := Token_Ptr;
Scope.Table (Scope.Last).Etyp := E_Loop;
Loop_Node := New_Node (N_Loop_Statement, Token_Ptr);
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, 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;
end P_Loop_Statement;
function P_For_Statement (Loop_Name : Node_Id := Empty) return Node_Id is
Loop_Node : Node_Id;
Iter_Scheme_Node : Node_Id;
Loop_For_Flag : Boolean;
Created_Name : Node_Id;
begin
Push_Scope_Stack;
Scope.Table (Scope.Last).Labl := Loop_Name;
Scope.Table (Scope.Last).Ecol := Start_Column;
Scope.Table (Scope.Last).Sloc := Token_Ptr;
Scope.Table (Scope.Last).Etyp := E_Loop;
Loop_For_Flag := (Prev_Token = Tok_Loop);
Scan; Iter_Scheme_Node := New_Node (N_Iteration_Scheme, Token_Ptr);
Set_Loop_Parameter_Specification
(Iter_Scheme_Node, P_Loop_Parameter_Specification);
if Loop_For_Flag and then Token = Tok_Semicolon then
Error_Msg_SC ("LOOP belongs here, not before FOR");
Pop_Scope_Stack;
return Error;
else
Loop_Node := New_Node (N_Loop_Statement, Token_Ptr);
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, 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;
function P_While_Statement (Loop_Name : Node_Id := Empty) return Node_Id is
Loop_Node : Node_Id;
Iter_Scheme_Node : Node_Id;
Loop_While_Flag : Boolean;
Created_Name : Node_Id;
begin
Push_Scope_Stack;
Scope.Table (Scope.Last).Labl := Loop_Name;
Scope.Table (Scope.Last).Ecol := Start_Column;
Scope.Table (Scope.Last).Sloc := Token_Ptr;
Scope.Table (Scope.Last).Etyp := E_Loop;
Loop_While_Flag := (Prev_Token = Tok_Loop);
Iter_Scheme_Node := New_Node (N_Iteration_Scheme, Token_Ptr);
Scan; Set_Condition (Iter_Scheme_Node, P_Condition);
if Loop_While_Flag and then Token = Tok_Semicolon then
Error_Msg_SC ("LOOP belongs here, not before WHILE");
Pop_Scope_Stack;
return Error;
else
Loop_Node := New_Node (N_Loop_Statement, Token_Ptr);
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, 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;
function P_Loop_Parameter_Specification return Node_Id is
Loop_Param_Specification_Node : Node_Id;
ID_Node : Node_Id;
Scan_State : Saved_Scan_State;
begin
Loop_Param_Specification_Node :=
New_Node (N_Loop_Parameter_Specification, Token_Ptr);
Save_Scan_State (Scan_State);
ID_Node := P_Defining_Identifier (C_In);
Set_Defining_Identifier (Loop_Param_Specification_Node, ID_Node);
if Token = Tok_Left_Paren then
Error_Msg_SC ("subscripted loop parameter not allowed");
Restore_Scan_State (Scan_State);
Discard_Junk_Node (P_Name);
elsif Token = Tok_Dot then
Error_Msg_SC ("selected loop parameter not allowed");
Restore_Scan_State (Scan_State);
Discard_Junk_Node (P_Name);
end if;
T_In;
if Token = Tok_Reverse then
Scan; Set_Reverse_Present (Loop_Param_Specification_Node, True);
end if;
Set_Discrete_Subtype_Definition
(Loop_Param_Specification_Node, P_Discrete_Subtype_Definition);
return Loop_Param_Specification_Node;
exception
when Error_Resync =>
return Error;
end P_Loop_Parameter_Specification;
function P_Declare_Statement
(Block_Name : Node_Id := Empty)
return Node_Id
is
Block_Node : Node_Id;
Created_Name : Node_Id;
begin
Block_Node := New_Node (N_Block_Statement, Token_Ptr);
Push_Scope_Stack;
Scope.Table (Scope.Last).Etyp := E_Name;
Scope.Table (Scope.Last).Lreq := Present (Block_Name);
Scope.Table (Scope.Last).Ecol := Start_Column;
Scope.Table (Scope.Last).Labl := Block_Name;
Scope.Table (Scope.Last).Sloc := Token_Ptr;
Scan;
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, Created_Name);
Scope.Table (Scope.Last).Labl := Created_Name;
else
Set_Identifier (Block_Node, Block_Name);
end if;
Append_Elmt (Block_Node, Label_List);
Parse_Decls_Begin_End (Block_Node);
return Block_Node;
end P_Declare_Statement;
function P_Begin_Statement
(Block_Name : Node_Id := Empty)
return Node_Id
is
Block_Node : Node_Id;
Created_Name : Node_Id;
begin
Block_Node := New_Node (N_Block_Statement, Token_Ptr);
Push_Scope_Stack;
Scope.Table (Scope.Last).Etyp := E_Name;
Scope.Table (Scope.Last).Lreq := Present (Block_Name);
Scope.Table (Scope.Last).Ecol := Start_Column;
Scope.Table (Scope.Last).Labl := Block_Name;
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, Created_Name);
Scope.Table (Scope.Last).Labl := Created_Name;
else
Set_Identifier (Block_Node, Block_Name);
end if;
Append_Elmt (Block_Node, Label_List);
Scope.Table (Scope.Last).Ecol := Start_Column;
Scope.Table (Scope.Last).Sloc := Token_Ptr;
Scan; Set_Handled_Statement_Sequence
(Block_Node, P_Handled_Sequence_Of_Statements);
End_Statements (Handled_Statement_Sequence (Block_Node));
return Block_Node;
end P_Begin_Statement;
function P_Exit_Statement return Node_Id is
Exit_Node : Node_Id;
function Missing_Semicolon_On_Exit return Boolean;
function Missing_Semicolon_On_Exit return Boolean is
State : Saved_Scan_State;
begin
if not Token_Is_At_Start_Of_Line then
return False;
elsif Scope.Table (Scope.Last).Etyp /= E_Case then
return False;
else
Save_Scan_State (State);
Scan; Scan;
if Token = Tok_Arrow then
Restore_Scan_State (State);
return True;
else
Restore_Scan_State (State);
return False;
end if;
end if;
end Missing_Semicolon_On_Exit;
begin
Exit_Node := New_Node (N_Exit_Statement, Token_Ptr);
Scan;
if Token = Tok_Identifier then
Set_Name (Exit_Node, P_Qualified_Simple_Name);
elsif Style_Check then
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)
and then Comes_From_Source (Scope.Table (J).Labl)
then
Style.No_Exit_Name (Scope.Table (J).Labl);
end if;
exit Check_No_Exit_Name;
end if;
end loop Check_No_Exit_Name;
end if;
if Token = Tok_When and then not Missing_Semicolon_On_Exit then
Scan; Set_Condition (Exit_Node, P_Condition);
elsif Token = Tok_If then
T_When;
Scan; Set_Condition (Exit_Node, P_Expression_No_Right_Paren);
end if;
TF_Semicolon;
return Exit_Node;
end P_Exit_Statement;
function P_Goto_Statement return Node_Id is
Goto_Node : Node_Id;
begin
Goto_Node := New_Node (N_Goto_Statement, Token_Ptr);
Scan; Set_Name (Goto_Node, P_Qualified_Simple_Name_Resync);
Append_Elmt (Goto_Node, Goto_List);
No_Constraint;
TF_Semicolon;
return Goto_Node;
end P_Goto_Statement;
procedure Parse_Decls_Begin_End (Parent : Node_Id) is
Body_Decl : Node_Id;
Body_Sloc : Source_Ptr;
Decls : List_Id;
Decl : Node_Id;
Parent_Nkind : Node_Kind;
Spec_Node : Node_Id;
HSS : Node_Id;
procedure Missing_Begin (Msg : String);
procedure Set_Null_HSS (Parent : Node_Id);
procedure Missing_Begin (Msg : String) is
begin
if Missing_Begin_Msg = No_Error_Msg then
Error_Msg_BC (Msg);
else
Change_Error_Text (Missing_Begin_Msg, Msg);
Purge_Messages (Get_Location (Missing_Begin_Msg), Prev_Token_Ptr);
end if;
end Missing_Begin;
procedure Set_Null_HSS (Parent : Node_Id) is
Null_Stm : Node_Id;
begin
Null_Stm :=
Make_Null_Statement (Token_Ptr);
Set_Comes_From_Source (Null_Stm, False);
HSS :=
Make_Handled_Sequence_Of_Statements (Token_Ptr,
Statements => New_List (Null_Stm));
Set_Comes_From_Source (HSS, False);
Set_Handled_Statement_Sequence (Parent, HSS);
end Set_Null_HSS;
begin
Decls := P_Declarative_Part;
if Ada_Version = Ada_83 then
Decl := First (Decls);
Outer : while Present (Decl) loop
if Nkind (Decl) /= N_Subprogram_Body
and then Nkind (Decl) /= N_Package_Body
and then Nkind (Decl) /= N_Task_Body
and then Nkind (Decl) not in N_Body_Stub
then
Next (Decl);
else
Body_Sloc := Sloc (Decl);
Inner : while Present (Decl) loop
if Nkind (Decl) not in N_Later_Decl_Item
and then Nkind (Decl) /= N_Pragma
then
if Ada_Version = Ada_83 then
Error_Msg_Sloc := Body_Sloc;
Error_Msg_N
("(Ada 83) decl cannot appear after body#", Decl);
end if;
end if;
Next (Decl);
end loop Inner;
end if;
end loop Outer;
end if;
Body_Decl := Last (Decls);
if Present (Body_Decl)
and then Nkind (Body_Decl) = N_Subprogram_Body
and then Bad_Is_Detected (Body_Decl)
then
Append_List (Declarations (Body_Decl), Decls);
Set_Handled_Statement_Sequence (Parent,
Handled_Statement_Sequence (Body_Decl));
Spec_Node := Specification (Body_Decl);
Change_Node (Body_Decl, N_Subprogram_Declaration);
Set_Specification (Body_Decl, Spec_Node);
Set_Declarations (Parent, Decls);
else
Set_Declarations (Parent, Decls);
if Token = Tok_Begin then
if Style_Check then Style.Check_Indentation; end if;
Error_Msg_Col := Scope.Table (Scope.Last).Ecol;
if Style.RM_Column_Check
and then Token_Is_At_Start_Of_Line
and then Start_Column /= Error_Msg_Col
then
Error_Msg_SC ("(style) BEGIN in wrong column, should be@");
else
Scope.Table (Scope.Last).Ecol := Start_Column;
end if;
Scope.Table (Scope.Last).Sloc := Token_Ptr;
Scan; Set_Handled_Statement_Sequence (Parent,
P_Handled_Sequence_Of_Statements);
else
Parent_Nkind := Nkind (Parent);
if Parent_Nkind = N_Subprogram_Body
and then Token = Tok_End
and then Scope.Table (Scope.Last).Etyp = E_Suspicious_Is
then
Scope.Table (Scope.Last).Etyp := E_Bad_Is;
elsif Parent_Nkind = N_Package_Body
and then (Token = Tok_End
or else Token = Tok_EOF
or else Token in Token_Class_Declk)
then
Set_Null_HSS (Parent);
else
Set_Null_HSS (Parent);
Error_Msg_Sloc := Scope.Table (Scope.Last).Sloc;
Error_Msg_Node_1 := Scope.Table (Scope.Last).Labl;
if Parent_Nkind = N_Block_Statement then
Missing_Begin ("missing BEGIN for DECLARE#!");
elsif Parent_Nkind = N_Entry_Body then
Missing_Begin ("missing BEGIN for ENTRY#!");
elsif Parent_Nkind = N_Subprogram_Body then
if Nkind (Specification (Parent))
= N_Function_Specification
then
Missing_Begin ("missing BEGIN for function&#!");
else
Missing_Begin ("missing BEGIN for procedure&#!");
end if;
elsif Parent_Nkind = N_Package_Body then
Missing_Begin ("missing BEGIN for package body&#!");
else
pragma Assert (Parent_Nkind = N_Task_Body);
Missing_Begin ("missing BEGIN for task body&#!");
end if;
if Missing_Begin_Msg /= No_Error_Msg
and then Token = Tok_End
then
null;
else
Set_Handled_Statement_Sequence (Parent,
P_Handled_Sequence_Of_Statements);
end if;
end if;
end if;
end if;
if Present (Handled_Statement_Sequence (Parent)) then
End_Statements (Handled_Statement_Sequence (Parent));
else
End_Statements;
end if;
if Scope.Table (Scope.Last + 1).Etyp = E_Bad_Is then
Error_Msg ("IS should be "";""", Scope.Table (Scope.Last + 1).S_Is);
Set_Bad_Is_Detected (Parent, True);
end if;
end Parse_Decls_Begin_End;
function Set_Loop_Block_Name (L : Character) return Name_Id is
begin
Name_Buffer (1) := L;
Name_Buffer (2) := '_';
Name_Len := 2;
Loop_Block_Count := Loop_Block_Count + 1;
Add_Nat_To_Name_Buffer (Loop_Block_Count);
return Name_Find;
end Set_Loop_Block_Name;
procedure Then_Scan is
begin
TF_Then;
while Token = Tok_Then loop
Error_Msg_SC ("redundant THEN");
TF_Then;
end loop;
if Token = Tok_And or else Token = Tok_Or then
Error_Msg_SC ("unexpected logical operator");
Scan;
if (Prev_Token = Tok_And and then Token = Tok_Then)
or else
(Prev_Token = Tok_Or and then Token = Tok_Else)
then
Scan;
end if;
Discard_Junk_Node (P_Expression);
end if;
if Token = Tok_Then then
Scan;
end if;
end Then_Scan;
end Ch5;