pragma Style_Checks (All_Checks);
with Fname; use Fname;
with Fname.UF; use Fname.UF;
with Uname; use Uname;
separate (Par)
package body Ch10 is
function P_Context_Clause return List_Id;
function P_Subunit return Node_Id;
function Set_Location return Source_Ptr;
procedure Unit_Display
(Cunit : Node_Id;
Loc : Source_Ptr;
SR_Present : Boolean);
procedure Unit_Location (Sind : Source_File_Index; Loc : Source_Ptr);
function P_Compilation_Unit return Node_Id is
Scan_State : Saved_Scan_State;
Body_Node : Node_Id;
Specification_Node : Node_Id;
Unit_Node : Node_Id;
Comp_Unit_Node : Node_Id;
Name_Node : Node_Id;
Item : Node_Id;
Private_Sloc : Source_Ptr := No_Location;
Config_Pragmas : List_Id;
P : Node_Id;
SR_Present : Boolean;
Cunit_Error_Flag : Boolean := False;
Cunit_Location : Source_Ptr;
begin
Num_Library_Units := Num_Library_Units + 1;
if List_Units and then Operating_Mode = Check_Syntax then
Cunit_Location := Set_Location;
else
Cunit_Location := No_Location;
end if;
Config_Pragmas := No_List;
SR_Present := False;
if Token = Tok_Pragma then
Save_Scan_State (Scan_State);
Item := P_Pragma;
if Item = Error
or else Chars (Item) /= Name_Source_Reference
then
Restore_Scan_State (Scan_State);
else
SR_Present := True;
if Operating_Mode = Check_Syntax
and then List_Units
and then Num_Library_Units = 1
then
Write_Str ("Source_Reference pragma for file """);
Write_Name (Full_Ref_Name (Current_Source_File));
Write_Char ('"');
Write_Eol;
end if;
Config_Pragmas := New_List (Item);
end if;
end if;
while Token = Tok_Pragma loop
Save_Scan_State (Scan_State);
Item := P_Pragma;
if Item = Error
or else Chars (Item) > Last_Configuration_Pragma_Name
then
Restore_Scan_State (Scan_State);
exit;
end if;
if Config_Pragmas = No_List then
Config_Pragmas := Empty_List;
if Operating_Mode = Check_Syntax and then List_Units then
Write_Str ("Configuration pragmas at");
Unit_Location (Current_Source_File, Cunit_Location);
Write_Eol;
end if;
end if;
Append (Item, Config_Pragmas);
Cunit_Location := Set_Location;
end loop;
Comp_Unit_Node := New_Node (N_Compilation_Unit, No_Location);
Set_Cunit (Current_Source_Unit, Comp_Unit_Node);
Set_Context_Items (Comp_Unit_Node, P_Context_Clause);
Set_Aux_Decls_Node
(Comp_Unit_Node, New_Node (N_Compilation_Unit_Aux, No_Location));
if Present (Config_Pragmas) then
if Token = Tok_EOF
and then Is_Empty_List (Context_Items (Comp_Unit_Node))
then
if Operating_Mode = Check_Syntax then
return Empty;
else
Item := First (Config_Pragmas);
Error_Msg_N
("cannot compile configuration pragmas with gcc", Item);
Error_Msg_N
("use gnatchop -c to process configuration pragmas!", Item);
raise Unrecoverable_Error;
end if;
else
Append_List (Context_Items (Comp_Unit_Node), Config_Pragmas);
Set_Context_Items (Comp_Unit_Node, Config_Pragmas);
end if;
end if;
if Token = Tok_Private then
Private_Sloc := Token_Ptr;
Set_Keyword_Casing (Current_Source_File, Determine_Token_Casing);
if Style_Check then Style.Check_Indentation; end if;
Save_Scan_State (Scan_State); Scan;
if Token = Tok_Separate then
Error_Msg_SP ("cannot have private subunits!");
elsif Token = Tok_Package then
Scan;
if Token = Tok_Body then
Restore_Scan_State (Scan_State); Error_Msg_SC ("cannot have private package body!");
Scan;
else
Restore_Scan_State (Scan_State); Scan; Set_Private_Present (Comp_Unit_Node, True);
end if;
elsif Token = Tok_Procedure
or else Token = Tok_Function
or else Token = Tok_Generic
then
Set_Private_Present (Comp_Unit_Node, True);
end if;
end if;
loop
exit when Token in Token_Class_Cunit and then Token /= Tok_With;
exit when Bad_Spelling_Of (Tok_Package)
or else Bad_Spelling_Of (Tok_Function)
or else Bad_Spelling_Of (Tok_Generic)
or else Bad_Spelling_Of (Tok_Separate)
or else Bad_Spelling_Of (Tok_Procedure);
exit when Token = Tok_Task
or else Token = Tok_Protected;
if Token = Tok_With then
Error_Msg_SC ("misplaced WITH");
Append_List (P_Context_Clause, Context_Items (Comp_Unit_Node));
elsif Bad_Spelling_Of (Tok_With) then
Append_List (P_Context_Clause, Context_Items (Comp_Unit_Node));
else
if Operating_Mode = Check_Syntax and then Token = Tok_EOF then
Error_Msg_SC ("?file contains no compilation units");
else
Error_Msg_SC ("compilation unit expected");
Cunit_Error_Flag := True;
Resync_Cunit;
end if;
if Token = Tok_EOF then
return Error;
end if;
end if;
end loop;
Set_Keyword_Casing (Current_Source_File, Determine_Token_Casing);
if Style_Check then Style.Check_Indentation; end if;
if Token = Tok_Package then
Save_Scan_State (Scan_State);
Scan;
if Token /= Tok_Body
and then
Get_Expected_Unit_Type
(File_Name (Current_Source_File)) = Expect_Body
then
Error_Msg_BC ("keyword BODY expected here [see file name]");
Restore_Scan_State (Scan_State);
Set_Unit (Comp_Unit_Node, P_Package (Pf_Pbod));
else
Restore_Scan_State (Scan_State);
Set_Unit (Comp_Unit_Node, P_Package (Pf_Decl_Gins_Pbod_Rnam));
end if;
elsif Token = Tok_Generic then
Set_Unit (Comp_Unit_Node, P_Generic);
elsif Token = Tok_Separate then
Set_Unit (Comp_Unit_Node, P_Subunit);
elsif Token = Tok_Procedure
or else Token = Tok_Function
then
Set_Unit (Comp_Unit_Node, P_Subprogram (Pf_Decl_Gins_Pbod_Rnam));
if SIS_Entry_Active then
if Token = Tok_Begin
or else Token = Tok_Identifier
or else Token in Token_Class_Deckn
then
Push_Scope_Stack;
Scope.Table (Scope.Last).Etyp := E_Name;
Scope.Table (Scope.Last).Sloc := SIS_Sloc;
Scope.Table (Scope.Last).Ecol := SIS_Ecol;
Scope.Table (Scope.Last).Lreq := False;
SIS_Entry_Active := False;
if SIS_Missing_Semicolon_Message /= No_Error_Msg then
Change_Error_Text (SIS_Missing_Semicolon_Message, "missing IS");
else
Error_Msg (""";"" should be IS", SIS_Semicolon_Sloc);
end if;
Body_Node := Unit (Comp_Unit_Node);
Specification_Node := Specification (Body_Node);
Change_Node (Body_Node, N_Subprogram_Body);
Set_Specification (Body_Node, Specification_Node);
Parse_Decls_Begin_End (Body_Node);
Set_Unit (Comp_Unit_Node, Body_Node);
end if;
elsif Private_Sloc /= No_Location
and then
Nkind (Unit (Comp_Unit_Node)) /= N_Function_Instantiation
and then
Nkind (Unit (Comp_Unit_Node)) /= N_Procedure_Instantiation
and then
Nkind (Unit (Comp_Unit_Node)) /= N_Subprogram_Renaming_Declaration
then
Error_Msg ("cannot have private subprogram body", Private_Sloc);
elsif
Nkind (Unit (Comp_Unit_Node)) = N_Abstract_Subprogram_Declaration
then
Error_Msg_N
("compilation unit cannot be abstract subprogram",
Unit (Comp_Unit_Node));
Unit_Node :=
New_Node (N_Subprogram_Declaration, Sloc (Comp_Unit_Node));
Set_Specification (Unit_Node,
Specification (Unit (Comp_Unit_Node)));
Set_Unit (Comp_Unit_Node, Unit_Node);
end if;
elsif Token = Tok_Task then
Scan;
if Token = Tok_Type then
Error_Msg_SP
("task type cannot be used as compilation unit");
else
Error_Msg_SP
("task declaration cannot be used as compilation unit");
end if;
if Operating_Mode = Check_Syntax then
Set_Unit (Comp_Unit_Node, P_Task);
else
Cunit_Error_Flag := True;
return Error;
end if;
else pragma Assert (Token = Tok_Protected);
Scan;
if Token = Tok_Type then
Error_Msg_SP
("protected type cannot be used as compilation unit");
else
Error_Msg_SP
("protected declaration cannot be used as compilation unit");
end if;
if Operating_Mode = Check_Syntax then
Set_Unit (Comp_Unit_Node, P_Protected);
else
Cunit_Error_Flag := True;
return Error;
end if;
end if;
Unit_Node := Unit (Comp_Unit_Node);
if Nkind (Unit_Node) = N_Subprogram_Body_Stub
or else Nkind (Unit_Node) = N_Package_Body_Stub
then
Cunit_Error_Flag := True;
return Error;
end if;
if Unit_Node /= Error then
if Nkind (Unit_Node) = N_Subunit then
Unit_Node := Proper_Body (Unit_Node);
end if;
if Nkind (Unit_Node) in N_Generic_Declaration then
Unit_Node := Specification (Unit_Node);
end if;
if Nkind (Unit_Node) = N_Package_Declaration
or else Nkind (Unit_Node) = N_Subprogram_Declaration
or else Nkind (Unit_Node) = N_Subprogram_Body
or else Nkind (Unit_Node) = N_Subprogram_Renaming_Declaration
then
Unit_Node := Specification (Unit_Node);
elsif Nkind (Unit_Node) = N_Subprogram_Renaming_Declaration then
if Ada_Version = Ada_83 then
Error_Msg_N
("(Ada 83) library unit renaming not allowed", Unit_Node);
end if;
end if;
if Nkind (Unit_Node) = N_Task_Body
or else Nkind (Unit_Node) = N_Protected_Body
or else Nkind (Unit_Node) = N_Task_Type_Declaration
or else Nkind (Unit_Node) = N_Protected_Type_Declaration
or else Nkind (Unit_Node) = N_Single_Task_Declaration
or else Nkind (Unit_Node) = N_Single_Protected_Declaration
then
Name_Node := Defining_Identifier (Unit_Node);
else
Name_Node := Defining_Unit_Name (Unit_Node);
end if;
Set_Sloc (Comp_Unit_Node, Sloc (Name_Node));
Set_Sloc (Aux_Decls_Node (Comp_Unit_Node), Sloc (Name_Node));
if Nkind (Name_Node) = N_Defining_Program_Unit_Name then
Set_Cunit_Entity
(Current_Source_Unit, Defining_Identifier (Name_Node));
else
Set_Cunit_Entity (Current_Source_Unit, Name_Node);
end if;
Set_Unit_Name
(Current_Source_Unit, Get_Unit_Name (Unit (Comp_Unit_Node)));
else
Cunit_Error_Flag := True;
Set_Fatal_Error (Current_Source_Unit);
end if;
SIS_Entry_Active := False;
while Token = Tok_Pragma loop
Save_Scan_State (Scan_State);
if Operating_Mode = Check_Syntax then
Scan;
if Token = Tok_Identifier
and then
(Token_Name in
First_Pragma_Name .. Last_Configuration_Pragma_Name
or else Token_Name = Name_Source_Reference)
then
Restore_Scan_State (Scan_State); exit;
end if;
end if;
Restore_Scan_State (Scan_State); P := P_Pragma;
if No (Pragmas_After (Aux_Decls_Node (Comp_Unit_Node))) then
Set_Pragmas_After
(Aux_Decls_Node (Comp_Unit_Node), New_List);
end if;
Append (P, Pragmas_After (Aux_Decls_Node (Comp_Unit_Node)));
end loop;
Set_Warnings_Mode_On (Scan_Ptr);
if Ada_Version = Ada_83 then
Item := First (Context_Items (Comp_Unit_Node));
while Present (Item) loop
if Nkind (Item) = N_With_Clause
and then Nkind (Name (Item)) /= N_Identifier
then
Error_Msg_N ("(Ada 83) child units not allowed", Item);
end if;
Next (Item);
end loop;
if Private_Present (Comp_Unit_Node) then
Error_Msg
("(Ada 83) private units not allowed", Private_Sloc);
end if;
end if;
if not Cunit_Error_Flag
and then List_Units
and then Operating_Mode = Check_Syntax
then
Unit_Display (Comp_Unit_Node, Cunit_Location, SR_Present);
end if;
if Token /= Tok_EOF then
if Cunit_Error_Flag then
null;
elsif Operating_Mode = Check_Syntax then
return Comp_Unit_Node;
elsif Multiple_Unit_Index /= 0 then
declare
Save_Style_Check : constant Boolean := Style_Check;
begin
Style_Check := False;
while Token /= Tok_EOF loop
Scan;
end loop;
Style_Check := Save_Style_Check;
end;
return Comp_Unit_Node;
else
if not Fatal_Error (Current_Source_Unit) then
if Token in Token_Class_Cunit then
Error_Msg_SC
("end of file expected, " &
"file can have only one compilation unit");
else
Error_Msg_SC ("end of file expected");
end if;
end if;
end if;
while Token /= Tok_EOF loop
Scan;
end loop;
return Error;
else
return Comp_Unit_Node;
end if;
exception
when Error_Resync =>
Set_Fatal_Error (Current_Source_Unit);
return Error;
end P_Compilation_Unit;
function P_Context_Clause return List_Id is
Item_List : List_Id;
Has_Limited : Boolean := False;
Has_Private : Boolean := False;
Scan_State : Saved_Scan_State;
With_Node : Node_Id;
First_Flag : Boolean;
begin
Item_List := New_List;
if Token = Tok_With then
Set_Keyword_Casing (Current_Source_File, Determine_Token_Casing);
end if;
loop
if Style_Check then Style.Check_Indentation; end if;
P_Pragmas_Opt (Item_List);
if Token = Tok_Limited then
Has_Limited := True;
Has_Private := False;
Scan;
if Token = Tok_Private then
Has_Private := True;
Scan; end if;
if Token /= Tok_With then
Error_Msg_SC ("unexpected LIMITED ignored");
end if;
if Ada_Version < Ada_05 then
Error_Msg_SP ("LIMITED WITH is an Ada 2005 extension");
Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
end if;
elsif Token = Tok_Private then
Has_Limited := False;
Has_Private := True;
Save_Scan_State (Scan_State);
Scan;
if Token /= Tok_With then
Restore_Scan_State (Scan_State); return Item_List;
elsif Ada_Version < Ada_05 then
Error_Msg_SP ("PRIVATE WITH is an Ada 2005 extension");
Error_Msg_SP
("\unit must be compiled with -gnat05 switch");
end if;
else
Has_Limited := False;
Has_Private := False;
end if;
if Token = Tok_With then
Scan;
if Token = Tok_Type then
if not Extensions_Allowed then
Error_Msg_SP ("`WITH TYPE` is a 'G'N'A'T extension");
Error_Msg_SP ("\unit must be compiled with -gnatX switch");
end if;
Scan; With_Node := New_Node (N_With_Type_Clause, Token_Ptr);
Append (With_Node, Item_List);
Set_Name (With_Node, P_Qualified_Simple_Name);
T_Is;
if Token = Tok_Tagged then
Set_Tagged_Present (With_Node);
Scan;
elsif Token = Tok_Access then
Scan;
else
Error_Msg_SC ("expect tagged or access qualifier");
end if;
TF_Semicolon;
else
First_Flag := True;
loop
With_Node := New_Node (N_With_Clause, Token_Ptr);
Append (With_Node, Item_List);
Set_Name (With_Node, P_Qualified_Simple_Name);
Set_First_Name (With_Node, First_Flag);
Set_Limited_Present (With_Node, Has_Limited);
Set_Private_Present (With_Node, Has_Private);
First_Flag := False;
exit when Token /= Tok_Comma;
Save_Scan_State (Scan_State);
Scan;
if Token in Token_Class_Cunit
or else Token = Tok_Use
or else Token = Tok_Pragma
then
Restore_Scan_State (Scan_State);
exit;
end if;
end loop;
Set_Last_Name (With_Node, True);
TF_Semicolon;
end if;
elsif Token = Tok_Use then
Append (P_Use_Clause, Item_List);
else
exit;
end if;
end loop;
return Item_List;
end P_Context_Clause;
function P_Subunit return Node_Id is
Subunit_Node : Node_Id;
Body_Node : Node_Id;
begin
Subunit_Node := New_Node (N_Subunit, Token_Ptr);
Body_Node := Error; Scan;
T_Left_Paren;
Set_Name (Subunit_Node, P_Qualified_Simple_Name);
T_Right_Paren;
if Token = Tok_Semicolon then
Error_Msg_SC ("unexpected semicolon ignored");
Scan;
end if;
if Token = Tok_Function or else Token = Tok_Procedure then
Body_Node := P_Subprogram (Pf_Pbod);
elsif Token = Tok_Package then
Body_Node := P_Package (Pf_Pbod);
elsif Token = Tok_Protected then
Scan;
if Token = Tok_Body then
Body_Node := P_Protected;
else
Error_Msg_AP ("BODY expected");
return Error;
end if;
elsif Token = Tok_Task then
Scan;
if Token = Tok_Body then
Body_Node := P_Task;
else
Error_Msg_AP ("BODY expected");
return Error;
end if;
else
Error_Msg_SC ("proper body expected");
return Error;
end if;
Set_Proper_Body (Subunit_Node, Body_Node);
return Subunit_Node;
end P_Subunit;
function Set_Location return Source_Ptr is
Physical : Boolean;
Loc : Source_Ptr;
Scan_State : Saved_Scan_State;
begin
if Token = Tok_Pragma then
Save_Scan_State (Scan_State);
Scan;
if Token = Tok_Identifier
and then Token_Name = Name_Source_Reference
then
Restore_Scan_State (Scan_State);
return Token_Ptr;
end if;
Restore_Scan_State (Scan_State);
end if;
if Prev_Token = No_Token then
return Source_First (Current_Source_File);
else
Loc := Prev_Token_Ptr;
loop
exit when Loc = Token_Ptr;
if Source (Loc) in Line_Terminator then
Skip_Line_Terminators (Loc, Physical);
exit when Physical;
end if;
Loc := Loc + 1;
end loop;
return Loc;
end if;
end Set_Location;
procedure Unit_Display
(Cunit : Node_Id;
Loc : Source_Ptr;
SR_Present : Boolean)
is
Unum : constant Unit_Number_Type := Get_Cunit_Unit_Number (Cunit);
Sind : constant Source_File_Index := Source_Index (Unum);
Unam : constant Unit_Name_Type := Unit_Name (Unum);
begin
if List_Units then
Write_Str ("Unit ");
Write_Unit_Name (Unit_Name (Unum));
Unit_Location (Sind, Loc);
if SR_Present then
Write_Str (", SR");
end if;
Write_Str (", file name ");
Write_Name (Get_File_Name (Unam, Nkind (Unit (Cunit)) = N_Subunit));
Write_Eol;
end if;
end Unit_Display;
procedure Unit_Location (Sind : Source_File_Index; Loc : Source_Ptr) is
Line : constant Logical_Line_Number := Get_Logical_Line_Number (Loc);
begin
Write_Str (" line ");
Write_Int (Int (Line));
Write_Str (", file offset ");
Write_Int (Int (Loc) - Int (Source_First (Sind)));
end Unit_Location;
end Ch10;