1202 lines
39 KiB
Ada
1202 lines
39 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT COMPILER COMPONENTS --
|
|
-- --
|
|
-- P A R . C H 1 0 --
|
|
-- --
|
|
-- B o d y --
|
|
-- --
|
|
-- Copyright (C) 1992-2020, 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 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 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. --
|
|
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
-- --
|
|
------------------------------------------------------------------------------
|
|
|
|
pragma Style_Checks (All_Checks);
|
|
-- Turn off subprogram body ordering check. Subprograms are in order
|
|
-- by RM section rather than alphabetical
|
|
|
|
with Fname.UF; use Fname.UF;
|
|
with Uname; use Uname;
|
|
|
|
separate (Par)
|
|
package body Ch10 is
|
|
|
|
-- Local functions, used only in this chapter
|
|
|
|
function P_Context_Clause return List_Id;
|
|
function P_Subunit return Node_Id;
|
|
|
|
function Set_Location return Source_Ptr;
|
|
-- The current compilation unit starts with Token at Token_Ptr. This
|
|
-- function determines the corresponding source location for the start
|
|
-- of the unit, including any preceding comment lines.
|
|
|
|
procedure Unit_Display
|
|
(Cunit : Node_Id;
|
|
Loc : Source_Ptr;
|
|
SR_Present : Boolean);
|
|
-- This procedure is used to generate a line of output for a unit in
|
|
-- the source program. Cunit is the node for the compilation unit, and
|
|
-- Loc is the source location for the start of the unit in the source
|
|
-- file (which is not necessarily the Sloc of the Cunit node). This
|
|
-- output is written to the standard output file for use by gnatchop.
|
|
|
|
procedure Unit_Location (Sind : Source_File_Index; Loc : Source_Ptr);
|
|
-- This routine has the same calling sequence as Unit_Display, but
|
|
-- it outputs only the line number and offset of the location, Loc,
|
|
-- using Cunit to obtain the proper source file index.
|
|
|
|
-------------------------
|
|
-- 10.1.1 Compilation --
|
|
-------------------------
|
|
|
|
-- COMPILATION ::= {COMPILATION_UNIT}
|
|
|
|
-- There is no specific parsing routine for a compilation, since we only
|
|
-- permit a single compilation in a source file, so there is no explicit
|
|
-- occurrence of compilations as such (our representation of a compilation
|
|
-- is a series of separate source files).
|
|
|
|
------------------------------
|
|
-- 10.1.1 Compilation unit --
|
|
------------------------------
|
|
|
|
-- COMPILATION_UNIT ::=
|
|
-- CONTEXT_CLAUSE LIBRARY_ITEM
|
|
-- | CONTEXT_CLAUSE SUBUNIT
|
|
|
|
-- LIBRARY_ITEM ::=
|
|
-- private LIBRARY_UNIT_DECLARATION
|
|
-- | LIBRARY_UNIT_BODY
|
|
-- | [private] LIBRARY_UNIT_RENAMING_DECLARATION
|
|
|
|
-- LIBRARY_UNIT_DECLARATION ::=
|
|
-- SUBPROGRAM_DECLARATION | PACKAGE_DECLARATION
|
|
-- | GENERIC_DECLARATION | GENERIC_INSTANTIATION
|
|
|
|
-- LIBRARY_UNIT_RENAMING_DECLARATION ::=
|
|
-- PACKAGE_RENAMING_DECLARATION
|
|
-- | GENERIC_RENAMING_DECLARATION
|
|
-- | SUBPROGRAM_RENAMING_DECLARATION
|
|
|
|
-- LIBRARY_UNIT_BODY ::= SUBPROGRAM_BODY | PACKAGE_BODY
|
|
|
|
-- Error recovery: cannot raise Error_Resync. If an error occurs, tokens
|
|
-- are skipped up to the next possible beginning of a compilation unit.
|
|
|
|
-- Note: if only configuration pragmas are found, Empty is returned
|
|
|
|
-- Note: in syntax-only mode, it is possible for P_Compilation_Unit
|
|
-- to return strange things that are not really compilation units.
|
|
-- This is done to help out gnatchop when it is faced with nonsense.
|
|
|
|
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;
|
|
No_Body : Boolean;
|
|
|
|
Cunit_Error_Flag : Boolean := False;
|
|
-- This flag is set True if we have to scan for a compilation unit
|
|
-- token. It is used to ensure clean termination in such cases by
|
|
-- not insisting on being at the end of file, and, in the syntax only
|
|
-- case by not scanning for additional compilation units.
|
|
|
|
Cunit_Location : Source_Ptr;
|
|
-- Location of unit for unit identification output (List_Unit option)
|
|
|
|
begin
|
|
Num_Library_Units := Num_Library_Units + 1;
|
|
|
|
-- Set location of the compilation unit if unit list option set
|
|
-- and we are in syntax check only mode
|
|
|
|
if List_Units and then Operating_Mode = Check_Syntax then
|
|
Cunit_Location := Set_Location;
|
|
else
|
|
Cunit_Location := No_Location;
|
|
end if;
|
|
|
|
-- Deal with initial pragmas
|
|
|
|
Config_Pragmas := No_List;
|
|
|
|
-- If we have an initial Source_Reference pragma, then remember the fact
|
|
-- to generate an NR parameter in the output line.
|
|
|
|
SR_Present := False;
|
|
|
|
-- If we see a pragma No_Body, remember not to complain about no body
|
|
|
|
No_Body := False;
|
|
|
|
if Token = Tok_Pragma then
|
|
Save_Scan_State (Scan_State);
|
|
Item := P_Pragma;
|
|
|
|
if Item = Error
|
|
or else Pragma_Name_Unmapped (Item) /= Name_Source_Reference
|
|
then
|
|
Restore_Scan_State (Scan_State);
|
|
|
|
else
|
|
SR_Present := True;
|
|
|
|
-- If first unit, record the file name for gnatchop use
|
|
|
|
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;
|
|
|
|
-- Scan out any configuration pragmas
|
|
|
|
while Token = Tok_Pragma loop
|
|
Save_Scan_State (Scan_State);
|
|
Item := P_Pragma;
|
|
|
|
if Item /= Error and then Pragma_Name_Unmapped (Item) = Name_No_Body
|
|
then
|
|
No_Body := True;
|
|
end if;
|
|
|
|
if Item = Error
|
|
or else
|
|
not Is_Configuration_Pragma_Name (Pragma_Name_Unmapped (Item))
|
|
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;
|
|
|
|
-- Establish compilation unit node and scan context items
|
|
|
|
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
|
|
|
|
-- Check for case of only configuration pragmas present
|
|
|
|
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;
|
|
|
|
-- Otherwise configuration pragmas are simply prepended to the
|
|
-- context of the current unit.
|
|
|
|
else
|
|
Append_List (Context_Items (Comp_Unit_Node), Config_Pragmas);
|
|
Set_Context_Items (Comp_Unit_Node, Config_Pragmas);
|
|
end if;
|
|
end if;
|
|
|
|
-- Check for PRIVATE. Note that for the moment we allow this in
|
|
-- Ada_83 mode, since we do not yet know if we are compiling a
|
|
-- predefined unit, and if we are then it would be allowed anyway.
|
|
|
|
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); -- at PRIVATE
|
|
Scan; -- past PRIVATE
|
|
|
|
if Token = Tok_Separate then
|
|
Error_Msg_SP ("cannot have private subunits!");
|
|
|
|
elsif Token = Tok_Package then
|
|
Scan; -- past PACKAGE
|
|
|
|
if Token = Tok_Body then
|
|
Restore_Scan_State (Scan_State); -- to PRIVATE
|
|
Error_Msg_SC ("cannot have private package body!");
|
|
Scan; -- ignore PRIVATE
|
|
|
|
else
|
|
Restore_Scan_State (Scan_State); -- to PRIVATE
|
|
Scan; -- past PRIVATE
|
|
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 to find our way to a compilation unit token
|
|
|
|
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);
|
|
|
|
-- Allow task and protected for nice error recovery purposes
|
|
|
|
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
|
|
|
|
-- Do not complain if there is a pragma No_Body
|
|
|
|
if not No_Body then
|
|
Error_Msg_SC ("??file contains no compilation units");
|
|
end if;
|
|
|
|
else
|
|
Error_Msg_SC ("compilation unit expected");
|
|
Cunit_Error_Flag := True;
|
|
Resync_Cunit;
|
|
end if;
|
|
|
|
-- If we are at an end of file, then just quit, the above error
|
|
-- message was complaint enough.
|
|
|
|
if Token = Tok_EOF then
|
|
return Error;
|
|
end if;
|
|
end if;
|
|
end loop;
|
|
|
|
-- We have a compilation unit token, so that's a reasonable choice for
|
|
-- determining the standard casing convention used for keywords in case
|
|
-- it hasn't already been done on seeing a WITH or PRIVATE.
|
|
|
|
Set_Keyword_Casing (Current_Source_File, Determine_Token_Casing);
|
|
|
|
if Style_Check then
|
|
Style.Check_Indentation;
|
|
end if;
|
|
|
|
-- Remaining processing depends on particular type of compilation unit
|
|
|
|
if Token = Tok_Package then
|
|
|
|
-- A common error is to omit the body keyword after package. We can
|
|
-- often diagnose this early on (before getting loads of errors from
|
|
-- contained subprogram bodies), by knowing that the file we
|
|
-- are compiling has a name that requires a body to be found.
|
|
|
|
Save_Scan_State (Scan_State);
|
|
Scan; -- past Package keyword
|
|
|
|
if Token /= Tok_Body
|
|
and then
|
|
Get_Expected_Unit_Type
|
|
(File_Name (Current_Source_File)) = Expect_Body
|
|
then
|
|
Error_Msg_BC -- CODEFIX
|
|
("keyword BODY expected here '[see file name']");
|
|
Restore_Scan_State (Scan_State);
|
|
Set_Unit (Comp_Unit_Node, P_Package (Pf_Pbod_Pexp));
|
|
else
|
|
Restore_Scan_State (Scan_State);
|
|
Set_Unit (Comp_Unit_Node, P_Package (Pf_Decl_Gins_Pbod_Rnam_Pexp));
|
|
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_Function
|
|
or else Token = Tok_Not
|
|
or else Token = Tok_Overriding
|
|
or else Token = Tok_Procedure
|
|
then
|
|
Set_Unit (Comp_Unit_Node, P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Pexp));
|
|
|
|
-- A little bit of an error recovery check here. If we just scanned
|
|
-- a subprogram declaration (as indicated by an SIS entry being
|
|
-- active), then if the following token is BEGIN or an identifier,
|
|
-- or a token which can reasonably start a declaration but cannot
|
|
-- start a compilation unit, then we assume that the semicolon in
|
|
-- the declaration should have been IS.
|
|
|
|
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;
|
|
Scopes (Scope.Last).Etyp := E_Name;
|
|
Scopes (Scope.Last).Sloc := SIS_Sloc;
|
|
Scopes (Scope.Last).Ecol := SIS_Ecol;
|
|
Scopes (Scope.Last).Lreq := False;
|
|
SIS_Entry_Active := False;
|
|
|
|
-- If we had a missing semicolon in the declaration, then
|
|
-- change the message to from <missing ";"> to <missing "is">
|
|
|
|
if SIS_Missing_Semicolon_Message /= No_Error_Msg then
|
|
Change_Error_Text -- Replace: "missing "";"" "
|
|
(SIS_Missing_Semicolon_Message, "missing IS");
|
|
|
|
-- Otherwise we saved the semicolon position, so complain
|
|
|
|
else
|
|
Error_Msg -- CODEFIX
|
|
(""";"" 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;
|
|
|
|
-- If we scanned a subprogram body, make sure we did not have private
|
|
|
|
elsif Private_Sloc /= No_Location
|
|
and then
|
|
Nkind (Unit (Comp_Unit_Node)) not in N_Subprogram_Instantiation
|
|
and then
|
|
Nkind (Unit (Comp_Unit_Node)) /= N_Subprogram_Renaming_Declaration
|
|
then
|
|
Error_Msg ("cannot have private subprogram body", Private_Sloc);
|
|
|
|
-- P_Subprogram can yield an abstract subprogram, but this cannot
|
|
-- be a compilation unit. Treat as a subprogram declaration.
|
|
|
|
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;
|
|
|
|
-- Otherwise we have TASK. This is not really an acceptable token,
|
|
-- but we accept it to improve error recovery.
|
|
|
|
elsif Token = Tok_Task then
|
|
Scan; -- Past TASK
|
|
|
|
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 in check syntax mode, accept the task anyway. This is done
|
|
-- particularly to improve the behavior of GNATCHOP in this case.
|
|
|
|
if Operating_Mode = Check_Syntax then
|
|
Set_Unit (Comp_Unit_Node, P_Task);
|
|
|
|
-- If not in syntax only mode, treat this as horrible error
|
|
|
|
else
|
|
Cunit_Error_Flag := True;
|
|
return Error;
|
|
end if;
|
|
|
|
else pragma Assert (Token = Tok_Protected);
|
|
Scan; -- Past PROTECTED
|
|
|
|
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 in check syntax mode, accept protected anyway. This is done
|
|
-- particularly to improve the behavior of GNATCHOP in this case.
|
|
|
|
if Operating_Mode = Check_Syntax then
|
|
Set_Unit (Comp_Unit_Node, P_Protected);
|
|
|
|
-- If not in syntax only mode, treat this as horrible error
|
|
|
|
else
|
|
Cunit_Error_Flag := True;
|
|
return Error;
|
|
end if;
|
|
end if;
|
|
|
|
-- Here is where locate the compilation unit entity. This is a little
|
|
-- tricky, since it is buried in various places.
|
|
|
|
Unit_Node := Unit (Comp_Unit_Node);
|
|
|
|
-- Another error from which it is hard to recover
|
|
|
|
if Nkind (Unit_Node) in N_Subprogram_Body_Stub | N_Package_Body_Stub then
|
|
Cunit_Error_Flag := True;
|
|
return Error;
|
|
end if;
|
|
|
|
-- Only try this if we got an OK unit
|
|
|
|
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) in N_Package_Declaration
|
|
| N_Subprogram_Declaration
|
|
| N_Subprogram_Body
|
|
| 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) in N_Task_Body
|
|
| N_Protected_Body
|
|
| N_Task_Type_Declaration
|
|
| N_Protected_Type_Declaration
|
|
| N_Single_Task_Declaration
|
|
| N_Single_Protected_Declaration
|
|
then
|
|
Name_Node := Defining_Identifier (Unit_Node);
|
|
|
|
elsif Nkind (Unit_Node) in N_Function_Instantiation
|
|
| N_Function_Specification
|
|
| N_Generic_Function_Renaming_Declaration
|
|
| N_Generic_Package_Renaming_Declaration
|
|
| N_Generic_Procedure_Renaming_Declaration
|
|
or else Nkind (Unit_Node) in N_Package_Body
|
|
| N_Package_Instantiation
|
|
| N_Package_Renaming_Declaration
|
|
| N_Package_Specification
|
|
| N_Procedure_Instantiation
|
|
| N_Procedure_Specification
|
|
then
|
|
Name_Node := Defining_Unit_Name (Unit_Node);
|
|
|
|
elsif Nkind (Unit_Node) = N_Expression_Function then
|
|
Error_Msg_SP
|
|
("expression function cannot be used as compilation unit");
|
|
return Comp_Unit_Node;
|
|
|
|
-- Anything else is a serious error, abandon scan
|
|
|
|
else
|
|
raise Error_Resync;
|
|
end if;
|
|
|
|
Set_Sloc (Comp_Unit_Node, Sloc (Name_Node));
|
|
Set_Sloc (Aux_Decls_Node (Comp_Unit_Node), Sloc (Name_Node));
|
|
|
|
-- Set Entity field in file table. Easier now that we have name.
|
|
-- Note that this is also skipped if we had a bad unit
|
|
|
|
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)));
|
|
|
|
-- If we had a bad unit, make sure the fatal flag is set in the file
|
|
-- table entry, since this is surely a fatal error and also set our
|
|
-- flag to inhibit the requirement that we be at end of file.
|
|
|
|
else
|
|
Cunit_Error_Flag := True;
|
|
Set_Fatal_Error (Current_Source_Unit, Error_Detected);
|
|
end if;
|
|
|
|
-- Clear away any missing semicolon indication, we are done with that
|
|
-- unit, so what's done is done, and we don't want anything hanging
|
|
-- around from the attempt to parse it.
|
|
|
|
SIS_Entry_Active := False;
|
|
|
|
-- Scan out pragmas after unit
|
|
|
|
while Token = Tok_Pragma loop
|
|
Save_Scan_State (Scan_State);
|
|
|
|
-- If we are in syntax scan mode allowing multiple units, then start
|
|
-- the next unit if we encounter a configuration pragma, or a source
|
|
-- reference pragma. We take care not to actually scan the pragma in
|
|
-- this case (we don't want it to take effect for the current unit).
|
|
|
|
if Operating_Mode = Check_Syntax then
|
|
Scan; -- past Pragma
|
|
|
|
if Token = Tok_Identifier
|
|
and then
|
|
(Is_Configuration_Pragma_Name (Token_Name)
|
|
or else Token_Name = Name_Source_Reference)
|
|
then
|
|
Restore_Scan_State (Scan_State); -- to Pragma
|
|
exit;
|
|
end if;
|
|
end if;
|
|
|
|
-- Otherwise eat the pragma, it definitely belongs with the
|
|
-- current unit, and not with the following unit.
|
|
|
|
Restore_Scan_State (Scan_State); -- to Pragma
|
|
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;
|
|
|
|
-- Cancel effect of any outstanding pragma Warnings (Off)
|
|
|
|
Set_Warnings_Mode_On (Scan_Ptr);
|
|
|
|
-- Ada 83 error checks
|
|
|
|
if Ada_Version = Ada_83 then
|
|
|
|
-- Check we did not with any child units
|
|
|
|
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;
|
|
|
|
-- Check that we did not have a PRIVATE keyword present
|
|
|
|
if Private_Present (Comp_Unit_Node) then
|
|
Error_Msg
|
|
("(Ada 83) private units not allowed", Private_Sloc);
|
|
end if;
|
|
end if;
|
|
|
|
-- If no serious error, then output possible unit information line
|
|
-- for gnatchop if we are in syntax only, list units mode.
|
|
|
|
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;
|
|
|
|
-- And now we should be at the end of file
|
|
|
|
if Token /= Tok_EOF then
|
|
|
|
-- If we already had to scan for a compilation unit, then don't
|
|
-- give any further error message, since it just seems to make
|
|
-- things worse, and we already gave a serious error message.
|
|
|
|
if Cunit_Error_Flag then
|
|
null;
|
|
|
|
-- If we are in check syntax mode, then we allow multiple units
|
|
-- so we just return with Token not set to Tok_EOF and no message.
|
|
|
|
elsif Operating_Mode = Check_Syntax then
|
|
return Comp_Unit_Node;
|
|
|
|
-- We also allow multiple units if we are in multiple unit mode
|
|
|
|
elsif Multiple_Unit_Index /= 0 then
|
|
|
|
-- Skip tokens to end of file, so that the -gnatl listing
|
|
-- will be complete in this situation, but no need to parse
|
|
-- the remaining units; no style checking either.
|
|
|
|
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;
|
|
|
|
-- Otherwise we have an error. We suppress the error message
|
|
-- if we already had a fatal error, since this stops junk
|
|
-- cascaded messages in some situations.
|
|
|
|
else
|
|
if Fatal_Error (Current_Source_Unit) /= Error_Detected 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;
|
|
|
|
-- Skip tokens to end of file, so that the -gnatl listing
|
|
-- will be complete in this situation, but no error checking
|
|
-- other than that provided at the token level.
|
|
|
|
while Token /= Tok_EOF loop
|
|
Scan;
|
|
end loop;
|
|
|
|
return Error;
|
|
|
|
-- Normal return (we were at the end of file as expected)
|
|
|
|
else
|
|
return Comp_Unit_Node;
|
|
end if;
|
|
|
|
exception
|
|
|
|
-- An error resync is a serious bomb, so indicate result unit no good
|
|
|
|
when Error_Resync =>
|
|
Set_Fatal_Error (Current_Source_Unit, Error_Detected);
|
|
return Error;
|
|
end P_Compilation_Unit;
|
|
|
|
--------------------------
|
|
-- 10.1.1 Library Item --
|
|
--------------------------
|
|
|
|
-- Parsed by P_Compilation_Unit (10.1.1)
|
|
|
|
--------------------------------------
|
|
-- 10.1.1 Library Unit Declaration --
|
|
--------------------------------------
|
|
|
|
-- Parsed by P_Compilation_Unit (10.1.1)
|
|
|
|
------------------------------------------------
|
|
-- 10.1.1 Library Unit Renaming Declaration --
|
|
------------------------------------------------
|
|
|
|
-- Parsed by P_Compilation_Unit (10.1.1)
|
|
|
|
-------------------------------
|
|
-- 10.1.1 Library Unit Body --
|
|
-------------------------------
|
|
|
|
-- Parsed by P_Compilation_Unit (10.1.1)
|
|
|
|
------------------------------
|
|
-- 10.1.1 Parent Unit Name --
|
|
------------------------------
|
|
|
|
-- Parsed (as a name) by its parent construct
|
|
|
|
----------------------------
|
|
-- 10.1.2 Context Clause --
|
|
----------------------------
|
|
|
|
-- CONTEXT_CLAUSE ::= {CONTEXT_ITEM}
|
|
|
|
-- CONTEXT_ITEM ::= WITH_CLAUSE | USE_CLAUSE | WITH_TYPE_CLAUSE
|
|
|
|
-- WITH_CLAUSE ::=
|
|
-- [LIMITED] [PRIVATE] with library_unit_NAME {,library_unit_NAME};
|
|
-- Note: the two qualifiers are Ada 2005 extensions.
|
|
|
|
-- WITH_TYPE_CLAUSE ::=
|
|
-- with type type_NAME is access; | with type type_NAME is tagged;
|
|
-- Note: this form is obsolete (old GNAT extension).
|
|
|
|
-- Error recovery: Cannot raise Error_Resync
|
|
|
|
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;
|
|
|
|
-- Get keyword casing from WITH keyword in case not set yet
|
|
|
|
if Token = Tok_With then
|
|
Set_Keyword_Casing (Current_Source_File, Determine_Token_Casing);
|
|
end if;
|
|
|
|
-- Loop through context items
|
|
|
|
loop
|
|
if Style_Check then
|
|
Style.Check_Indentation;
|
|
end if;
|
|
|
|
-- Gather any pragmas appearing in the context clause
|
|
|
|
P_Pragmas_Opt (Item_List);
|
|
|
|
-- Processing for WITH clause
|
|
|
|
-- Ada 2005 (AI-50217, AI-262): First check for LIMITED WITH,
|
|
-- PRIVATE WITH, or both.
|
|
|
|
if Token = Tok_Limited then
|
|
Has_Limited := True;
|
|
Has_Private := False;
|
|
Scan; -- past LIMITED
|
|
|
|
-- In the context, LIMITED can only appear in a with_clause
|
|
|
|
if Token = Tok_Private then
|
|
Has_Private := True;
|
|
Scan; -- past PRIVATE
|
|
end if;
|
|
|
|
if Token /= Tok_With then
|
|
Error_Msg_SC -- CODEFIX
|
|
("unexpected LIMITED ignored");
|
|
end if;
|
|
|
|
Error_Msg_Ada_2005_Extension ("`LIMITED WITH`");
|
|
|
|
elsif Token = Tok_Private then
|
|
Has_Limited := False;
|
|
Has_Private := True;
|
|
Save_Scan_State (Scan_State);
|
|
Scan; -- past PRIVATE
|
|
|
|
if Token /= Tok_With then
|
|
|
|
-- Keyword is beginning of private child unit
|
|
|
|
Restore_Scan_State (Scan_State); -- to PRIVATE
|
|
return Item_List;
|
|
end if;
|
|
|
|
Error_Msg_Ada_2005_Extension ("`PRIVATE WITH`");
|
|
|
|
else
|
|
Has_Limited := False;
|
|
Has_Private := False;
|
|
end if;
|
|
|
|
if Token = Tok_With then
|
|
Scan; -- past WITH
|
|
|
|
if Token = Tok_Type then
|
|
|
|
-- WITH TYPE is an obsolete GNAT specific extension
|
|
|
|
Error_Msg_SP ("`WITH TYPE` is an obsolete 'G'N'A'T extension");
|
|
Error_Msg_SP ("\use Ada 2005 `LIMITED WITH` clause instead");
|
|
|
|
Scan; -- past TYPE
|
|
|
|
T_Is;
|
|
|
|
if Token = Tok_Tagged then
|
|
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 through names in one with clause, generating a separate
|
|
-- N_With_Clause node for each name encountered.
|
|
|
|
loop
|
|
With_Node := New_Node (N_With_Clause, Token_Ptr);
|
|
Append (With_Node, Item_List);
|
|
|
|
-- Note that we allow with'ing of child units, even in
|
|
-- Ada 83 mode, since presumably if this is not desired,
|
|
-- then the compilation of the child unit itself is the
|
|
-- place where such an "error" should be caught.
|
|
|
|
Set_Name (With_Node, P_Qualified_Simple_Name);
|
|
if Name (With_Node) = Error then
|
|
Remove (With_Node);
|
|
end if;
|
|
|
|
Set_First_Name (With_Node, First_Flag);
|
|
Set_Limited_Present (With_Node, Has_Limited);
|
|
Set_Private_Present (With_Node, Has_Private);
|
|
First_Flag := False;
|
|
|
|
-- All done if no comma
|
|
|
|
exit when Token /= Tok_Comma;
|
|
|
|
-- If comma is followed by compilation unit token
|
|
-- or by USE, or PRAGMA, then it should have been a
|
|
-- semicolon after all
|
|
|
|
Save_Scan_State (Scan_State);
|
|
Scan; -- past comma
|
|
|
|
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;
|
|
|
|
-- Processing for USE clause
|
|
|
|
elsif Token = Tok_Use then
|
|
P_Use_Clause (Item_List);
|
|
|
|
-- Anything else is end of context clause
|
|
|
|
else
|
|
exit;
|
|
end if;
|
|
end loop;
|
|
|
|
return Item_List;
|
|
end P_Context_Clause;
|
|
|
|
--------------------------
|
|
-- 10.1.2 Context Item --
|
|
--------------------------
|
|
|
|
-- Parsed by P_Context_Clause (10.1.2)
|
|
|
|
-------------------------
|
|
-- 10.1.2 With Clause --
|
|
-------------------------
|
|
|
|
-- Parsed by P_Context_Clause (10.1.2)
|
|
|
|
-----------------------
|
|
-- 10.1.3 Body Stub --
|
|
-----------------------
|
|
|
|
-- Subprogram stub parsed by P_Subprogram (6.1)
|
|
-- Package stub parsed by P_Package (7.1)
|
|
-- Task stub parsed by P_Task (9.1)
|
|
-- Protected stub parsed by P_Protected (9.4)
|
|
|
|
----------------------------------
|
|
-- 10.1.3 Subprogram Body Stub --
|
|
----------------------------------
|
|
|
|
-- Parsed by P_Subprogram (6.1)
|
|
|
|
-------------------------------
|
|
-- 10.1.3 Package Body Stub --
|
|
-------------------------------
|
|
|
|
-- Parsed by P_Package (7.1)
|
|
|
|
----------------------------
|
|
-- 10.1.3 Task Body Stub --
|
|
----------------------------
|
|
|
|
-- Parsed by P_Task (9.1)
|
|
|
|
---------------------------------
|
|
-- 10.1.3 Protected Body Stub --
|
|
---------------------------------
|
|
|
|
-- Parsed by P_Protected (9.4)
|
|
|
|
---------------------
|
|
-- 10.1.3 Subunit --
|
|
---------------------
|
|
|
|
-- SUBUNIT ::= separate (PARENT_UNIT_NAME) PROPER_BODY
|
|
|
|
-- PARENT_UNIT_NAME ::= NAME
|
|
|
|
-- The caller has checked that the initial token is SEPARATE
|
|
|
|
-- Error recovery: cannot raise Error_Resync
|
|
|
|
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; -- in case no good body found
|
|
Scan; -- past SEPARATE;
|
|
|
|
U_Left_Paren;
|
|
Set_Name (Subunit_Node, P_Qualified_Simple_Name);
|
|
U_Right_Paren;
|
|
|
|
Ignore (Tok_Semicolon);
|
|
|
|
if Token = Tok_Function
|
|
or else Token = Tok_Not
|
|
or else Token = Tok_Overriding
|
|
or else Token = Tok_Procedure
|
|
then
|
|
Body_Node := P_Subprogram (Pf_Pbod_Pexp);
|
|
|
|
elsif Token = Tok_Package then
|
|
Body_Node := P_Package (Pf_Pbod_Pexp);
|
|
|
|
elsif Token = Tok_Protected then
|
|
Scan; -- past PROTECTED
|
|
|
|
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; -- past TASK
|
|
|
|
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;
|
|
|
|
------------------
|
|
-- Set_Location --
|
|
------------------
|
|
|
|
function Set_Location return Source_Ptr is
|
|
Physical : Boolean;
|
|
Loc : Source_Ptr;
|
|
Scan_State : Saved_Scan_State;
|
|
|
|
begin
|
|
-- A special check. If the first token is pragma, and this is a
|
|
-- Source_Reference pragma, then do NOT eat previous comments, since
|
|
-- the Source_Reference pragma is required to be the first line in
|
|
-- the source file.
|
|
|
|
if Token = Tok_Pragma then
|
|
Save_Scan_State (Scan_State);
|
|
Scan; -- past Pragma
|
|
|
|
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;
|
|
|
|
-- Otherwise acquire previous comments and blank lines
|
|
|
|
if Prev_Token = No_Token then
|
|
return Source_First (Current_Source_File);
|
|
|
|
else
|
|
Loc := Prev_Token_Ptr;
|
|
loop
|
|
exit when Loc = Token_Ptr;
|
|
|
|
-- Should we worry about UTF_32 line terminators here
|
|
|
|
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;
|
|
|
|
------------------
|
|
-- Unit_Display --
|
|
------------------
|
|
|
|
-- The format of the generated line, as expected by GNATCHOP is
|
|
|
|
-- Unit {unit} line {line}, file offset {offs} [, SR], file name {file}
|
|
|
|
-- where
|
|
|
|
-- {unit} unit name with terminating (spec) or (body)
|
|
-- {line} starting line number
|
|
-- {offs} offset to start of text in file
|
|
-- {file} source file name
|
|
|
|
-- The SR parameter is present only if a source reference pragma was
|
|
-- scanned for this unit. The significance is that gnatchop should not
|
|
-- attempt to add another one.
|
|
|
|
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;
|
|
|
|
-------------------
|
|
-- Unit_Location --
|
|
-------------------
|
|
|
|
procedure Unit_Location (Sind : Source_File_Index; Loc : Source_Ptr) is
|
|
Line : constant Logical_Line_Number := Get_Logical_Line_Number (Loc);
|
|
-- Should the above be the physical line number ???
|
|
|
|
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;
|