pragma Style_Checks (All_Checks);
with Sinfo.CN; use Sinfo.CN;
separate (Par)
package body Ch6 is
function P_Defining_Designator return Node_Id;
function P_Defining_Operator_Symbol return Node_Id;
procedure Check_Junk_Semicolon_Before_Return;
procedure Check_Junk_Semicolon_Before_Return is
Scan_State : Saved_Scan_State;
begin
if Token = Tok_Semicolon then
Save_Scan_State (Scan_State);
Scan;
if Token = Tok_Return then
Restore_Scan_State (Scan_State);
Error_Msg_SC ("Unexpected semicolon ignored");
Scan;
else
Restore_Scan_State (Scan_State);
end if;
elsif Bad_Spelling_Of (Tok_Return) then
null;
end if;
end Check_Junk_Semicolon_Before_Return;
function P_Subprogram (Pf_Flags : Pf_Rec) return Node_Id is
Specification_Node : Node_Id;
Name_Node : Node_Id;
Fpart_List : List_Id;
Fpart_Sloc : Source_Ptr;
Return_Node : Node_Id;
Inst_Node : Node_Id;
Body_Node : Node_Id;
Decl_Node : Node_Id;
Rename_Node : Node_Id;
Absdec_Node : Node_Id;
Stub_Node : Node_Id;
Fproc_Sloc : Source_Ptr;
Func : Boolean;
Scan_State : Saved_Scan_State;
begin
SIS_Entry_Active := False;
SIS_Missing_Semicolon_Message := No_Error_Msg;
Push_Scope_Stack;
Scope.Table (Scope.Last).Sloc := Token_Ptr;
Scope.Table (Scope.Last).Etyp := E_Name;
Scope.Table (Scope.Last).Ecol := Start_Column;
Scope.Table (Scope.Last).Lreq := False;
Func := (Token = Tok_Function);
Fproc_Sloc := Token_Ptr;
Scan; Ignore (Tok_Type);
Ignore (Tok_Body);
if Func then
Name_Node := P_Defining_Designator;
if Nkind (Name_Node) = N_Defining_Operator_Symbol
and then Scope.Last = 1
then
Error_Msg_SP ("operator symbol not allowed at library level");
Name_Node := New_Entity (N_Defining_Identifier, Sloc (Name_Node));
Get_Name_String (File_Name (Current_Source_File));
for J in 1 .. Name_Len loop
if Name_Buffer (J) = '.' then
Name_Len := J - 1;
exit;
end if;
end loop;
Set_Chars (Name_Node, Name_Find);
Set_Error_Posted (Name_Node);
end if;
else
Name_Node := P_Defining_Program_Unit_Name;
end if;
Scope.Table (Scope.Last).Labl := Name_Node;
if Token = Tok_Colon then
Error_Msg_SC ("redundant colon ignored");
Scan; end if;
if Token = Tok_Is then
Save_Scan_State (Scan_State); T_Is;
if Token = Tok_New then
if not Pf_Flags.Gins then
Error_Msg_SC ("generic instantation not allowed here!");
end if;
Scan;
if Func then
Inst_Node := New_Node (N_Function_Instantiation, Fproc_Sloc);
Set_Name (Inst_Node, P_Function_Name);
else
Inst_Node := New_Node (N_Procedure_Instantiation, Fproc_Sloc);
Set_Name (Inst_Node, P_Qualified_Simple_Name);
end if;
Set_Defining_Unit_Name (Inst_Node, Name_Node);
Set_Generic_Associations (Inst_Node, P_Generic_Actual_Part_Opt);
TF_Semicolon;
Pop_Scope_Stack; return Inst_Node;
else
Restore_Scan_State (Scan_State); end if;
end if;
Fpart_Sloc := Token_Ptr;
Check_Misspelling_Of (Tok_Return);
if Token = Tok_Identifier
and then not Token_Is_At_Start_Of_Line
then
T_Left_Paren; Fpart_List := P_Formal_Part;
else
Fpart_List := P_Parameter_Profile;
end if;
Check_Junk_Semicolon_Before_Return;
Return_Node := Error;
if Token = Tok_Return then
if not Func then
Error_Msg ("PROCEDURE should be FUNCTION", Fproc_Sloc);
Func := True;
end if;
Scan; Return_Node := P_Subtype_Mark;
No_Constraint;
else
if Func then
Ignore (Tok_Right_Paren);
TF_Return;
end if;
end if;
if Func then
Specification_Node :=
New_Node (N_Function_Specification, Fproc_Sloc);
Set_Subtype_Mark (Specification_Node, Return_Node);
else
Specification_Node :=
New_Node (N_Procedure_Specification, Fproc_Sloc);
end if;
Set_Defining_Unit_Name (Specification_Node, Name_Node);
Set_Parameter_Specifications (Specification_Node, Fpart_List);
if Token = Tok_When then
if Func then
Error_Msg_SC ("barrier not allowed on function, only on entry");
else
Error_Msg_SC ("barrier not allowed on procedure, only on entry");
end if;
Scan; Discard_Junk_Node (P_Expression);
end if;
if Token = Tok_Semicolon then
if not Pf_Flags.Decl then
T_Is;
end if;
Scan;
if Token = Tok_Is then
Error_Msg_SP ("unexpected semicolon ignored");
T_Is; goto Subprogram_Body;
elsif Token = Tok_Begin
and then Start_Column >= Scope.Table (Scope.Last).Ecol
then
Error_Msg_SP (""";"" should be IS!");
goto Subprogram_Body;
else
goto Subprogram_Declaration;
end if;
else
Check_Misspelling_Of (Tok_Renames);
if Token = Tok_Renames then
if not Pf_Flags.Rnam then
Error_Msg_SC ("renaming declaration not allowed here!");
end if;
Rename_Node :=
New_Node (N_Subprogram_Renaming_Declaration, Token_Ptr);
Scan; Set_Name (Rename_Node, P_Name);
Set_Specification (Rename_Node, Specification_Node);
TF_Semicolon;
Pop_Scope_Stack;
return Rename_Node;
elsif Token = Tok_Is then
T_Is;
if Token_Name = Name_Abstract then
Check_95_Keyword (Tok_Abstract, Tok_Semicolon);
end if;
if Token = Tok_Box then
Error_Msg_SC ("ABSTRACT expected");
Token := Tok_Abstract;
end if;
if Token = Tok_Abstract then
Absdec_Node :=
New_Node (N_Abstract_Subprogram_Declaration, Token_Ptr);
Set_Specification (Absdec_Node, Specification_Node);
Pop_Scope_Stack; Scan; TF_Semicolon;
return Absdec_Node;
elsif Token = Tok_New then
Error_Msg
("formal part not allowed in instantiation", Fpart_Sloc);
Scan;
if Func then
Inst_Node := New_Node (N_Function_Instantiation, Fproc_Sloc);
else
Inst_Node :=
New_Node (N_Procedure_Instantiation, Fproc_Sloc);
end if;
Set_Defining_Unit_Name (Inst_Node, Name_Node);
Set_Name (Inst_Node, P_Name);
Set_Generic_Associations (Inst_Node, P_Generic_Actual_Part_Opt);
TF_Semicolon;
Pop_Scope_Stack; return Inst_Node;
else
goto Subprogram_Body;
end if;
else
Error_Msg_AP ("missing "";""");
SIS_Missing_Semicolon_Message := Get_Msg_Id;
goto Subprogram_Declaration;
end if;
end if;
<<Subprogram_Body>>
if not Pf_Flags.Pbod then
Error_Msg_SP ("subprogram body not allowed here!");
end if;
if Separate_Present then
if not Pf_Flags.Stub then
Error_Msg_SC ("body stub not allowed here!");
end if;
if Nkind (Name_Node) = N_Defining_Operator_Symbol then
Error_Msg
("operator symbol cannot be used as subunit name",
Sloc (Name_Node));
end if;
Stub_Node :=
New_Node (N_Subprogram_Body_Stub, Sloc (Specification_Node));
Set_Specification (Stub_Node, Specification_Node);
Scan; Pop_Scope_Stack;
TF_Semicolon;
return Stub_Node;
else
if (Token in Token_Class_Declk
or else
Token = Tok_Identifier)
and then Start_Column <= Scope.Table (Scope.Last).Ecol
and then Scope.Last /= 1
then
Scope.Table (Scope.Last).Etyp := E_Suspicious_Is;
Scope.Table (Scope.Last).S_Is := Prev_Token_Ptr;
end if;
Body_Node :=
New_Node (N_Subprogram_Body, Sloc (Specification_Node));
Set_Specification (Body_Node, Specification_Node);
Parse_Decls_Begin_End (Body_Node);
return Body_Node;
end if;
<<Subprogram_Declaration>>
Decl_Node :=
New_Node (N_Subprogram_Declaration, Sloc (Specification_Node));
Set_Specification (Decl_Node, Specification_Node);
if Pf_Flags.Pbod then
SIS_Labl := Scope.Table (Scope.Last).Labl;
SIS_Sloc := Scope.Table (Scope.Last).Sloc;
SIS_Ecol := Scope.Table (Scope.Last).Ecol;
SIS_Declaration_Node := Decl_Node;
SIS_Semicolon_Sloc := Prev_Token_Ptr;
SIS_Entry_Active := True;
end if;
Pop_Scope_Stack;
return Decl_Node;
end P_Subprogram;
function P_Subprogram_Specification return Node_Id is
Specification_Node : Node_Id;
begin
if Token = Tok_Function then
Specification_Node := New_Node (N_Function_Specification, Token_Ptr);
Scan; Ignore (Tok_Body);
Set_Defining_Unit_Name (Specification_Node, P_Defining_Designator);
Set_Parameter_Specifications
(Specification_Node, P_Parameter_Profile);
Check_Junk_Semicolon_Before_Return;
TF_Return;
Set_Subtype_Mark (Specification_Node, P_Subtype_Mark);
No_Constraint;
return Specification_Node;
elsif Token = Tok_Procedure then
Specification_Node := New_Node (N_Procedure_Specification, Token_Ptr);
Scan; Ignore (Tok_Body);
Set_Defining_Unit_Name
(Specification_Node, P_Defining_Program_Unit_Name);
Set_Parameter_Specifications
(Specification_Node, P_Parameter_Profile);
return Specification_Node;
else
Error_Msg_SC ("subprogram specification expected");
raise Error_Resync;
end if;
end P_Subprogram_Specification;
function P_Designator return Node_Id is
Ident_Node : Node_Id;
Name_Node : Node_Id;
Prefix_Node : Node_Id;
function Real_Dot return Boolean;
function Real_Dot return Boolean is
Scan_State : Saved_Scan_State;
begin
if Token /= Tok_Dot then
return False;
else
Save_Scan_State (Scan_State);
Scan;
if Token = Tok_Identifier
or else Token = Tok_Operator_Symbol
or else Token = Tok_String_Literal
then
return True;
else
Restore_Scan_State (Scan_State);
return False;
end if;
end if;
end Real_Dot;
begin
Ident_Node := Token_Node;
Scan;
if Prev_Token = Tok_Operator_Symbol
or else Prev_Token = Tok_String_Literal
or else not Real_Dot
then
return Ident_Node;
else
Prefix_Node := Ident_Node;
loop
Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr);
Set_Prefix (Name_Node, Prefix_Node);
Ident_Node := P_Identifier;
Set_Selector_Name (Name_Node, Ident_Node);
Prefix_Node := Name_Node;
exit when not Real_Dot;
end loop;
Name_Node := Prefix (Prefix_Node);
Change_Node (Prefix_Node, N_Designator);
Set_Name (Prefix_Node, Name_Node);
Set_Identifier (Prefix_Node, Ident_Node);
return Prefix_Node;
end if;
exception
when Error_Resync =>
while Token = Tok_Dot or else Token = Tok_Identifier loop
Scan;
end loop;
return Error;
end P_Designator;
function P_Defining_Designator return Node_Id is
begin
if Token = Tok_Operator_Symbol then
return P_Defining_Operator_Symbol;
elsif Token = Tok_String_Literal then
Error_Msg_SC ("invalid operator name");
Scan; return Error;
else
return P_Defining_Program_Unit_Name;
end if;
end P_Defining_Designator;
function P_Defining_Program_Unit_Name return Node_Id is
Ident_Node : Node_Id;
Name_Node : Node_Id;
Prefix_Node : Node_Id;
begin
if Token = Tok_Identifier
and then Identifier_Casing (Current_Source_File) = Unknown
then
Set_Identifier_Casing (Current_Source_File, Determine_Token_Casing);
end if;
Ident_Node := P_Identifier (C_Dot);
Merge_Identifier (Ident_Node, Tok_Return);
if Token /= Tok_Dot then
Change_Identifier_To_Defining_Identifier (Ident_Node);
return Ident_Node;
else
if Scope.Last > 1 then
Error_Msg_SP ("child unit allowed only at library level");
raise Error_Resync;
elsif Ada_Version = Ada_83 then
Error_Msg_SP ("(Ada 83) child unit not allowed!");
end if;
Prefix_Node := Ident_Node;
loop
exit when Token /= Tok_Dot;
Name_Node := New_Node (N_Selected_Component, Token_Ptr);
Scan; Set_Prefix (Name_Node, Prefix_Node);
Ident_Node := P_Identifier (C_Dot);
Set_Selector_Name (Name_Node, Ident_Node);
Prefix_Node := Name_Node;
end loop;
Name_Node := Prefix (Prefix_Node);
Change_Node (Prefix_Node, N_Defining_Program_Unit_Name);
Set_Name (Prefix_Node, Name_Node);
Change_Identifier_To_Defining_Identifier (Ident_Node);
Set_Defining_Identifier (Prefix_Node, Ident_Node);
return Prefix_Node;
end if;
exception
when Error_Resync =>
while Token = Tok_Dot or else Token = Tok_Identifier loop
Scan;
end loop;
return Error;
end P_Defining_Program_Unit_Name;
function P_Defining_Operator_Symbol return Node_Id is
Op_Node : Node_Id;
begin
Op_Node := Token_Node;
Change_Operator_Symbol_To_Defining_Operator_Symbol (Op_Node);
Scan; return Op_Node;
end P_Defining_Operator_Symbol;
function P_Parameter_Profile return List_Id is
begin
if Token = Tok_Left_Paren then
Scan; return P_Formal_Part;
else
return No_List;
end if;
end P_Parameter_Profile;
function P_Formal_Part return List_Id is
Specification_List : List_Id;
Specification_Node : Node_Id;
Scan_State : Saved_Scan_State;
Num_Idents : Nat;
Ident : Nat;
Ident_Sloc : Source_Ptr;
Not_Null_Present : Boolean := False;
Idents : array (Int range 1 .. 4096) of Entity_Id;
begin
Specification_List := New_List;
Specification_Loop : loop
begin
if Token = Tok_Pragma then
P_Pragmas_Misplaced;
end if;
Ignore (Tok_Left_Paren);
Ident_Sloc := Token_Ptr;
Idents (1) := P_Defining_Identifier (C_Comma_Colon);
Num_Idents := 1;
Ident_Loop : loop
exit Ident_Loop when Token = Tok_Colon;
if Token /= Tok_Comma then
exit Ident_Loop when Token = Tok_In or else Token = Tok_Out;
Save_Scan_State (Scan_State);
Look_Ahead : loop
if Token = Tok_Semicolon
or else Token = Tok_Right_Paren
or else Token = Tok_EOF
or else Token = Tok_Colon_Equal
then
Restore_Scan_State (Scan_State);
exit Ident_Loop;
elsif Token = Tok_Colon
or else Token = Tok_Comma
then
Restore_Scan_State (Scan_State);
exit Look_Ahead;
end if;
Scan;
end loop Look_Ahead;
end if;
T_Comma;
Num_Idents := Num_Idents + 1;
Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon);
end loop Ident_Loop;
T_Colon;
if Num_Idents > 1 then
Save_Scan_State (Scan_State);
end if;
Ident := 1;
Ident_List_Loop : loop
Specification_Node :=
New_Node (N_Parameter_Specification, Ident_Sloc);
Set_Defining_Identifier (Specification_Node, Idents (Ident));
Not_Null_Present := P_Null_Exclusion;
if Token = Tok_Access then
Set_Null_Exclusion_Present
(Specification_Node, Not_Null_Present);
if Ada_Version = Ada_83 then
Error_Msg_SC ("(Ada 83) access parameters not allowed");
end if;
Set_Parameter_Type (Specification_Node,
P_Access_Definition (Not_Null_Present));
else
if Token = Tok_In or else Token = Tok_Out then
if Not_Null_Present then
Error_Msg_SC
("ACCESS must be placed after the parameter mode");
end if;
P_Mode (Specification_Node);
Not_Null_Present := P_Null_Exclusion; end if;
Set_Null_Exclusion_Present
(Specification_Node, Not_Null_Present);
if Token = Tok_Procedure
or else
Token = Tok_Function
then
Error_Msg_SC ("formal subprogram parameter not allowed");
Scan;
if Token = Tok_Left_Paren then
Discard_Junk_List (P_Formal_Part);
end if;
if Token = Tok_Return then
Scan;
Discard_Junk_Node (P_Subtype_Mark);
end if;
Set_Parameter_Type (Specification_Node, Error);
else
Set_Parameter_Type (Specification_Node, P_Subtype_Mark);
No_Constraint;
end if;
end if;
Set_Expression (Specification_Node, Init_Expr_Opt (True));
if Ident > 1 then
Set_Prev_Ids (Specification_Node, True);
end if;
if Ident < Num_Idents then
Set_More_Ids (Specification_Node, True);
end if;
Append (Specification_Node, Specification_List);
exit Ident_List_Loop when Ident = Num_Idents;
Ident := Ident + 1;
Restore_Scan_State (Scan_State);
end loop Ident_List_Loop;
exception
when Error_Resync =>
Resync_Semicolon_List;
end;
if Token = Tok_Semicolon then
Save_Scan_State (Scan_State);
Scan;
if Token = Tok_Is or else Token = Tok_Return then
Error_Msg_SP ("expected "")"" in place of "";""");
exit Specification_Loop;
end if;
if Token in Token_Class_Declk then
Error_Msg_AP ("missing "")""");
Restore_Scan_State (Scan_State);
exit Specification_Loop;
end if;
elsif Token = Tok_Right_Paren then
Scan; exit Specification_Loop;
elsif Token = Tok_Comma then
T_Semicolon;
Scan;
elsif Token = Tok_Identifier then
T_Semicolon;
else
T_Semicolon;
Resync_Semicolon_List;
if Token = Tok_Semicolon then
Scan; else
T_Right_Paren;
exit Specification_Loop;
end if;
end if;
end loop Specification_Loop;
return Specification_List;
end P_Formal_Part;
procedure P_Mode (Node : Node_Id) is
begin
if Token = Tok_In then
Scan; Set_In_Present (Node, True);
end if;
if Token = Tok_Out then
Scan; Set_Out_Present (Node, True);
end if;
if Token = Tok_In then
Error_Msg_SC ("IN must preceed OUT in parameter mode");
Scan; Set_In_Present (Node, True);
end if;
end P_Mode;
function P_Return_Statement return Node_Id is
Return_Node : Node_Id;
begin
Return_Node := New_Node (N_Return_Statement, Token_Ptr);
Scan;
if Token /= Tok_Semicolon then
if Token not in Token_Class_Eterm then
Set_Expression (Return_Node, P_Expression_No_Right_Paren);
end if;
end if;
TF_Semicolon;
return Return_Node;
end P_Return_Statement;
end Ch6;