Skip to content

R
riscv-gcc-1
Commit 804f7040 by Vincent Celier Committed by Arnaud Charlet
Options

frontend.adb (Frontend): Return immediately if the main source could not be parsed... 

2007-04-20  Vincent Celier  <celier@adacore.com>
	    Robert Dewar  <dewar@adacore.com>

	* frontend.adb (Frontend): Return immediately if the main source could
	not be parsed, because of preprocessing errors.

	* gnat1drv.adb (gnat1drv): Handle RE_Not_Available gracefully.
	(Gnat1drv): Exit with errors if the main source could not be parsed,
	because of preprocessing errors.
	(Check_Rep_Info): New procedure

From-SVN: r125411
parent 0712790c
Showing with 224 additions and 150 deletions
gcc/ada/frontend.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -24,7 +24,7 @@ ...@@ -24,7 +24,7 @@
-- -- -- --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
with GNAT.Strings; use GNAT.Strings; with System.Strings; use System.Strings;
with Atree; use Atree; with Atree; use Atree;
with Checks; with Checks;
...@@ -34,7 +34,6 @@ with Elists; ...@@ -34,7 +34,6 @@ with Elists;
with Exp_Dbug; with Exp_Dbug;
with Fmap; with Fmap;
with Fname.UF; with Fname.UF;
with Hostparm; use Hostparm;
with Inline; use Inline; with Inline; use Inline;
with Lib; use Lib; with Lib; use Lib;
with Lib.Load; use Lib.Load; with Lib.Load; use Lib.Load;
...@@ -56,6 +55,7 @@ with Sem_Warn; use Sem_Warn; ...@@ -56,6 +55,7 @@ with Sem_Warn; use Sem_Warn;
with Sinfo; use Sinfo; with Sinfo; use Sinfo;
with Sinput; use Sinput; with Sinput; use Sinput;
with Sinput.L; use Sinput.L; with Sinput.L; use Sinput.L;
with Targparm; use Targparm;
with Tbuild; use Tbuild; with Tbuild; use Tbuild;
with Types; use Types; with Types; use Types;
...@@ -107,6 +107,12 @@ begin ...@@ -107,6 +107,12 @@ begin
Lib.Load.Load_Main_Source; Lib.Load.Load_Main_Source;
-- Return immediately if the main source could not be parsed
if Sinput.Main_Source_File = No_Source_File then
return;
end if;
-- Read and process configuration pragma files if present -- Read and process configuration pragma files if present
declare declare
...@@ -208,6 +214,12 @@ begin ...@@ -208,6 +214,12 @@ begin
Opt.Register_Opt_Config_Switches; Opt.Register_Opt_Config_Switches;
-- Check for file which contains No_Body pragma
if Source_File_Is_No_Body (Source_Index (Main_Unit)) then
Change_Main_Unit_To_Spec;
end if;
-- Initialize the scanner. Note that we do this after the call to -- Initialize the scanner. Note that we do this after the call to
-- Create_Standard, which uses the scanner in its processing of -- Create_Standard, which uses the scanner in its processing of
-- floating-point bounds. -- floating-point bounds.
...@@ -318,11 +330,11 @@ begin ...@@ -318,11 +330,11 @@ begin
end if; end if;
-- Qualify all entity names in inner packages, package bodies, etc., -- Qualify all entity names in inner packages, package bodies, etc.,
-- except when compiling for the JVM back end, which depends on -- except when compiling for the VM back-ends, which depend on
-- having unqualified names in certain cases and handles the -- having unqualified names in certain cases and handles the
-- generation of qualified names when needed. -- generation of qualified names when needed.
if not Java_VM then if VM_Target = No_VM then
Exp_Dbug.Qualify_All_Entity_Names; Exp_Dbug.Qualify_All_Entity_Names;
end if; end if;
......
gcc/ada/gnat1drv.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2006 Free Software Foundation, Inc. -- -- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -49,6 +49,7 @@ with Output; use Output; ...@@ -49,6 +49,7 @@ with Output; use Output;
with Prepcomp; with Prepcomp;
with Repinfo; use Repinfo; with Repinfo; use Repinfo;
with Restrict; with Restrict;
with Rtsfind;
with Sem; with Sem;
with Sem_Ch8; with Sem_Ch8;
with Sem_Ch12; with Sem_Ch12;
...@@ -61,7 +62,7 @@ with Sinput.L; use Sinput.L; ...@@ -61,7 +62,7 @@ with Sinput.L; use Sinput.L;
with Snames; with Snames;
with Sprint; use Sprint; with Sprint; use Sprint;
with Stringt; with Stringt;
with Targparm; with Targparm; use Targparm;
with Tree_Gen; with Tree_Gen;
with Treepr; use Treepr; with Treepr; use Treepr;
with Ttypes; with Ttypes;
...@@ -83,6 +84,174 @@ procedure Gnat1drv is ...@@ -83,6 +84,174 @@ procedure Gnat1drv is
Back_End_Mode : Back_End.Back_End_Mode_Type; Back_End_Mode : Back_End.Back_End_Mode_Type;
-- Record back end mode -- Record back end mode
procedure Check_Bad_Body;
-- Called to check if the unit we are compiling has a bad body
procedure Check_Rep_Info;
-- Called when we are not generating code, to check if -gnatR was requested
-- and if so, explain that we will not be honoring the request.
--------------------
-- Check_Bad_Body --
--------------------
procedure Check_Bad_Body is
Sname : Unit_Name_Type;
Src_Ind : Source_File_Index;
Fname : File_Name_Type;
procedure Bad_Body_Error (Msg : String);
-- Issue message for bad body found
--------------------
-- Bad_Body_Error --
--------------------
procedure Bad_Body_Error (Msg : String) is
begin
Error_Msg_N (Msg, Main_Unit_Node);
Error_Msg_File_1 := Fname;
Error_Msg_N ("remove incorrect body in file{!", Main_Unit_Node);
end Bad_Body_Error;
-- Start of processing for Check_Bad_Body
begin
-- Nothing to do if we are only checking syntax, because we don't know
-- enough to know if we require or forbid a body in this case.
if Operating_Mode = Check_Syntax then
return;
end if;
-- Check for body not allowed
if (Main_Kind = N_Package_Declaration
and then not Body_Required (Main_Unit_Node))
or else (Main_Kind = N_Generic_Package_Declaration
and then not Body_Required (Main_Unit_Node))
or else Main_Kind = N_Package_Renaming_Declaration
or else Main_Kind = N_Subprogram_Renaming_Declaration
or else Nkind (Original_Node (Unit (Main_Unit_Node)))
in N_Generic_Instantiation
then
Sname := Unit_Name (Main_Unit);
-- If we do not already have a body name, then get the body name
-- (but how can we have a body name here ???)
if not Is_Body_Name (Sname) then
Sname := Get_Body_Name (Sname);
end if;
Fname := Get_File_Name (Sname, Subunit => False);
Src_Ind := Load_Source_File (Fname);
-- Case where body is present and it is not a subunit. Exclude
-- the subunit case, because it has nothing to do with the
-- package we are compiling. It is illegal for a child unit and a
-- subunit with the same expanded name (RM 10.2(9)) to appear
-- together in a partition, but there is nothing to stop a
-- compilation environment from having both, and the test here
-- simply allows that. If there is an attempt to include both in
-- a partition, this is diagnosed at bind time. In Ada 83 mode
-- this is not a warning case.
-- Note: if weird file names are being used, we can have
-- situation where the file name that supposedly contains body,
-- in fact contains a spec, or we can't tell what it contains.
-- Skip the error message in these cases.
-- Also ignore body that is nothing but pragma No_Body; (that's the
-- whole point of this pragma, to be used this way and to cause the
-- body file to be ignored in this context).
if Src_Ind /= No_Source_File
and then Get_Expected_Unit_Type (Fname) = Expect_Body
and then not Source_File_Is_Subunit (Src_Ind)
and then not Source_File_Is_No_Body (Src_Ind)
then
Errout.Finalize;
Error_Msg_Unit_1 := Sname;
-- Ada 83 case of a package body being ignored. This is not an
-- error as far as the Ada 83 RM is concerned, but it is almost
-- certainly not what is wanted so output a warning. Give this
-- message only if there were no errors, since otherwise it may
-- be incorrect (we may have misinterpreted a junk spec as not
-- needing a body when it really does).
if Main_Kind = N_Package_Declaration
and then Ada_Version = Ada_83
and then Operating_Mode = Generate_Code
and then Distribution_Stub_Mode /= Generate_Caller_Stub_Body
and then not Compilation_Errors
then
Error_Msg_N
("package $$ does not require a body?", Main_Unit_Node);
Error_Msg_File_1 := Fname;
Error_Msg_N ("body in file{? will be ignored", Main_Unit_Node);
-- Ada 95 cases of a body file present when no body is
-- permitted. This we consider to be an error.
else
-- For generic instantiations, we never allow a body
if Nkind (Original_Node (Unit (Main_Unit_Node)))
in N_Generic_Instantiation
then
Bad_Body_Error
("generic instantiation for $$ does not allow a body");
-- A library unit that is a renaming never allows a body
elsif Main_Kind in N_Renaming_Declaration then
Bad_Body_Error
("renaming declaration for $$ does not allow a body!");
-- Remaining cases are packages and generic packages. Here
-- we only do the test if there are no previous errors,
-- because if there are errors, they may lead us to
-- incorrectly believe that a package does not allow a body
-- when in fact it does.
elsif not Compilation_Errors then
if Main_Kind = N_Package_Declaration then
Bad_Body_Error
("package $$ does not allow a body!");
elsif Main_Kind = N_Generic_Package_Declaration then
Bad_Body_Error
("generic package $$ does not allow a body!");
end if;
end if;
end if;
end if;
end if;
end Check_Bad_Body;
--------------------
-- Check_Rep_Info --
--------------------
procedure Check_Rep_Info is
begin
if List_Representation_Info /= 0
or else List_Representation_Info_Mechanisms
then
Write_Eol;
Write_Str
("cannot generate representation information, no code generated");
Write_Eol;
Write_Eol;
end if;
end Check_Rep_Info;
-- Start of processing for Gnat1drv
begin begin
-- This inner block is set up to catch assertion errors and constraint -- This inner block is set up to catch assertion errors and constraint
-- errors. Since the code for handling these errors can cause another -- errors. Since the code for handling these errors can cause another
...@@ -91,8 +260,7 @@ begin ...@@ -91,8 +260,7 @@ begin
begin begin
-- Lib.Initialize need to be called before Scan_Compiler_Arguments, -- Lib.Initialize need to be called before Scan_Compiler_Arguments,
-- because it initialize a table that is filled by -- because it initializes a table filled by Scan_Compiler_Arguments.
-- Scan_Compiler_Arguments.
Osint.Initialize; Osint.Initialize;
Fmap.Reset_Tables; Fmap.Reset_Tables;
...@@ -125,7 +293,7 @@ begin ...@@ -125,7 +293,7 @@ begin
use Sinput; use Sinput;
S : Source_File_Index; S : Source_File_Index;
N : Name_Id; N : File_Name_Type;
begin begin
Name_Buffer (1 .. 10) := "system.ads"; Name_Buffer (1 .. 10) := "system.ads";
...@@ -147,9 +315,9 @@ begin ...@@ -147,9 +315,9 @@ begin
end if; end if;
Targparm.Get_Target_Parameters Targparm.Get_Target_Parameters
(System_Text => Source_Text (S), (System_Text => Source_Text (S),
Source_First => Source_First (S), Source_First => Source_First (S),
Source_Last => Source_Last (S)); Source_Last => Source_Last (S));
-- Acquire configuration pragma information from Targparm -- Acquire configuration pragma information from Targparm
...@@ -173,7 +341,7 @@ begin ...@@ -173,7 +341,7 @@ begin
-- Output copyright notice if full list mode unless we have a list -- Output copyright notice if full list mode unless we have a list
-- file, in which case we defer this so that it is output in the file -- file, in which case we defer this so that it is output in the file
if (Verbose_Mode or else (Full_List and Full_List_File_Name = null)) if (Verbose_Mode or else (Full_List and then Full_List_File_Name = null))
and then not Debug_Flag_7 and then not Debug_Flag_7
then then
Write_Eol; Write_Eol;
...@@ -230,9 +398,9 @@ begin ...@@ -230,9 +398,9 @@ begin
Suppress_Options (Overflow_Check) := True; Suppress_Options (Overflow_Check) := True;
end if; end if;
-- Check we have exactly one source file, this happens only in the case -- Check we do not have more than one source file, this happens only in
-- where the driver is called directly, it cannot happen when gnat1 is -- the case where the driver is called directly, it cannot happen when
-- invoked from gcc in the normal case. -- gnat1 is invoked from gcc in the normal case.
if Osint.Number_Of_Files /= 1 then if Osint.Number_Of_Files /= 1 then
Usage; Usage;
...@@ -245,145 +413,27 @@ begin ...@@ -245,145 +413,27 @@ begin
Original_Operating_Mode := Operating_Mode; Original_Operating_Mode := Operating_Mode;
Frontend; Frontend;
Main_Unit_Node := Cunit (Main_Unit);
Main_Kind := Nkind (Unit (Main_Unit_Node));
-- Check for suspicious or incorrect body present if we are doing
-- semantic checking. We omit this check in syntax only mode, because
-- in that case we do not know if we need a body or not.
if Operating_Mode /= Check_Syntax
and then
((Main_Kind = N_Package_Declaration
and then not Body_Required (Main_Unit_Node))
or else (Main_Kind = N_Generic_Package_Declaration
and then not Body_Required (Main_Unit_Node))
or else Main_Kind = N_Package_Renaming_Declaration
or else Main_Kind = N_Subprogram_Renaming_Declaration
or else Nkind (Original_Node (Unit (Main_Unit_Node)))
in N_Generic_Instantiation)
then
Bad_Body : declare
Sname : Unit_Name_Type := Unit_Name (Main_Unit);
Src_Ind : Source_File_Index;
Fname : File_Name_Type;
procedure Bad_Body_Error (Msg : String);
-- Issue message for bad body found
--------------------
-- Bad_Body_Error --
--------------------
procedure Bad_Body_Error (Msg : String) is
begin
Error_Msg_N (Msg, Main_Unit_Node);
Error_Msg_Name_1 := Fname;
Error_Msg_N
("remove incorrect body in file{!", Main_Unit_Node);
end Bad_Body_Error;
-- Start of processing for Bad_Body
begin -- Exit with errors if the main source could not be parsed
Sname := Unit_Name (Main_Unit);
-- If we do not already have a body name, then get the body name if Sinput.Main_Source_File = No_Source_File then
-- (but how can we have a body name here ???) Errout.Finalize;
Errout.Output_Messages;
if not Is_Body_Name (Sname) then Exit_Program (E_Errors);
Sname := Get_Body_Name (Sname);
end if;
Fname := Get_File_Name (Sname, Subunit => False);
Src_Ind := Load_Source_File (Fname);
-- Case where body is present and it is not a subunit. Exclude
-- the subunit case, because it has nothing to do with the
-- package we are compiling. It is illegal for a child unit and a
-- subunit with the same expanded name (RM 10.2(9)) to appear
-- together in a partition, but there is nothing to stop a
-- compilation environment from having both, and the test here
-- simply allows that. If there is an attempt to include both in
-- a partition, this is diagnosed at bind time. In Ada 83 mode
-- this is not a warning case.
-- Note: if weird file names are being used, we can have
-- situation where the file name that supposedly contains body,
-- in fact contains a spec, or we can't tell what it contains.
-- Skip the error message in these cases.
if Src_Ind /= No_Source_File
and then Get_Expected_Unit_Type (Fname) = Expect_Body
and then not Source_File_Is_Subunit (Src_Ind)
then
Error_Msg_Name_1 := Sname;
-- Ada 83 case of a package body being ignored. This is not an
-- error as far as the Ada 83 RM is concerned, but it is
-- almost certainly not what is wanted so output a warning.
-- Give this message only if there were no errors, since
-- otherwise it may be incorrect (we may have misinterpreted a
-- junk spec as not needing a body when it really does).
if Main_Kind = N_Package_Declaration
and then Ada_Version = Ada_83
and then Operating_Mode = Generate_Code
and then Distribution_Stub_Mode /= Generate_Caller_Stub_Body
and then not Compilation_Errors
then
Error_Msg_N
("package % does not require a body?", Main_Unit_Node);
Error_Msg_Name_1 := Fname;
Error_Msg_N
("body in file{? will be ignored", Main_Unit_Node);
-- Ada 95 cases of a body file present when no body is
-- permitted. This we consider to be an error.
else
-- For generic instantiations, we never allow a body
if Nkind (Original_Node (Unit (Main_Unit_Node)))
in N_Generic_Instantiation
then
Bad_Body_Error
("generic instantiation for % does not allow a body");
-- A library unit that is a renaming never allows a body
elsif Main_Kind in N_Renaming_Declaration then
Bad_Body_Error
("renaming declaration for % does not allow a body!");
-- Remaining cases are packages and generic packages. Here
-- we only do the test if there are no previous errors,
-- because if there are errors, they may lead us to
-- incorrectly believe that a package does not allow a body
-- when in fact it does.
elsif not Compilation_Errors then
if Main_Kind = N_Package_Declaration then
Bad_Body_Error
("package % does not allow a body!");
elsif Main_Kind = N_Generic_Package_Declaration then
Bad_Body_Error
("generic package % does not allow a body!");
end if;
end if;
end if;
end if;
end Bad_Body;
end if; end if;
Main_Unit_Node := Cunit (Main_Unit);
Main_Kind := Nkind (Unit (Main_Unit_Node));
Check_Bad_Body;
-- Exit if compilation errors detected -- Exit if compilation errors detected
Errout.Finalize;
if Compilation_Errors then if Compilation_Errors then
Treepr.Tree_Dump; Treepr.Tree_Dump;
Sem_Ch13.Validate_Unchecked_Conversions; Sem_Ch13.Validate_Unchecked_Conversions;
Errout.Finalize; Errout.Output_Messages;
Namet.Finalize; Namet.Finalize;
-- Generate ALI file if specially requested -- Generate ALI file if specially requested
...@@ -417,8 +467,10 @@ begin ...@@ -417,8 +467,10 @@ begin
if Original_Operating_Mode = Check_Syntax then if Original_Operating_Mode = Check_Syntax then
Treepr.Tree_Dump; Treepr.Tree_Dump;
Errout.Finalize; Errout.Finalize;
Errout.Output_Messages;
Tree_Gen; Tree_Gen;
Namet.Finalize; Namet.Finalize;
Check_Rep_Info;
-- Use a goto instead of calling Exit_Program so that finalization -- Use a goto instead of calling Exit_Program so that finalization
-- occurs normally. -- occurs normally.
...@@ -561,10 +613,12 @@ begin ...@@ -561,10 +613,12 @@ begin
Sem_Ch13.Validate_Unchecked_Conversions; Sem_Ch13.Validate_Unchecked_Conversions;
Errout.Finalize; Errout.Finalize;
Errout.Output_Messages;
Treepr.Tree_Dump; Treepr.Tree_Dump;
Tree_Gen; Tree_Gen;
Write_ALI (Object => False); Write_ALI (Object => False);
Namet.Finalize; Namet.Finalize;
Check_Rep_Info;
-- Exit program with error indication, to kill object file -- Exit program with error indication, to kill object file
...@@ -581,20 +635,22 @@ begin ...@@ -581,20 +635,22 @@ begin
-- enabled, because the front end determines representations. -- enabled, because the front end determines representations.
-- Annotation is also suppressed in the case of compiling for -- Annotation is also suppressed in the case of compiling for
-- the Java VM, since representations are largely symbolic there. -- a VM, since representations are largely symbolic there.
if Back_End_Mode = Declarations_Only if Back_End_Mode = Declarations_Only
and then (not Back_Annotate_Rep_Info and then (not Back_Annotate_Rep_Info
or else Main_Kind = N_Subunit or else Main_Kind = N_Subunit
or else Targparm.Frontend_Layout_On_Target or else Targparm.Frontend_Layout_On_Target
or else Hostparm.Java_VM) or else Targparm.VM_Target /= No_VM)
then then
Sem_Ch13.Validate_Unchecked_Conversions; Sem_Ch13.Validate_Unchecked_Conversions;
Errout.Finalize; Errout.Finalize;
Errout.Output_Messages;
Write_ALI (Object => False); Write_ALI (Object => False);
Tree_Dump; Tree_Dump;
Tree_Gen; Tree_Gen;
Namet.Finalize; Namet.Finalize;
Check_Rep_Info;
return; return;
end if; end if;
...@@ -624,6 +680,7 @@ begin ...@@ -624,6 +680,7 @@ begin
-- Here we call the back end to generate the output code -- Here we call the back end to generate the output code
Generating_Code := True;
Back_End.Call_Back_End (Back_End_Mode); Back_End.Call_Back_End (Back_End_Mode);
-- Once the backend is complete, we unlock the names table. This call -- Once the backend is complete, we unlock the names table. This call
...@@ -644,6 +701,7 @@ begin ...@@ -644,6 +701,7 @@ begin
-- representation information for List_Rep_Info. -- representation information for List_Rep_Info.
Errout.Finalize; Errout.Finalize;
Errout.Output_Messages;
List_Rep_Info; List_Rep_Info;
-- Only write the library if the backend did not generate any error -- Only write the library if the backend did not generate any error
...@@ -673,6 +731,9 @@ begin ...@@ -673,6 +731,9 @@ begin
exception exception
-- Handle fatal internal compiler errors -- Handle fatal internal compiler errors
when Rtsfind.RE_Not_Available =>
Comperr.Compiler_Abort ("RE_Not_Available");
when System.Assertions.Assert_Failure => when System.Assertions.Assert_Failure =>
Comperr.Compiler_Abort ("Assert_Failure"); Comperr.Compiler_Abort ("Assert_Failure");
...@@ -698,6 +759,7 @@ begin ...@@ -698,6 +759,7 @@ begin
exception exception
when Unrecoverable_Error => when Unrecoverable_Error =>
Errout.Finalize; Errout.Finalize;
Errout.Output_Messages;
Set_Standard_Error; Set_Standard_Error;
Write_Str ("compilation abandoned"); Write_Str ("compilation abandoned");
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment