From 804f7040cfeac59248f90852a80531f069e859c8 Mon Sep 17 00:00:00 2001 From: Vincent Celier Date: Wed, 6 Jun 2007 12:28:20 +0200 Subject: [PATCH] frontend.adb (Frontend): Return immediately if the main source could not be parsed... 2007-04-20 Vincent Celier Robert Dewar * 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 --- gcc/ada/frontend.adb | 22 ++- gcc/ada/gnat1drv.adb | 352 +++++++++++++++++++++++++------------------ 2 files changed, 224 insertions(+), 150 deletions(-) diff --git a/gcc/ada/frontend.adb b/gcc/ada/frontend.adb index 361f45a9eaa..cc5c2cb849f 100644 --- a/gcc/ada/frontend.adb +++ b/gcc/ada/frontend.adb @@ -6,7 +6,7 @@ -- -- -- 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 -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -24,7 +24,7 @@ -- -- ------------------------------------------------------------------------------ -with GNAT.Strings; use GNAT.Strings; +with System.Strings; use System.Strings; with Atree; use Atree; with Checks; @@ -34,7 +34,6 @@ with Elists; with Exp_Dbug; with Fmap; with Fname.UF; -with Hostparm; use Hostparm; with Inline; use Inline; with Lib; use Lib; with Lib.Load; use Lib.Load; @@ -56,6 +55,7 @@ with Sem_Warn; use Sem_Warn; with Sinfo; use Sinfo; with Sinput; use Sinput; with Sinput.L; use Sinput.L; +with Targparm; use Targparm; with Tbuild; use Tbuild; with Types; use Types; @@ -107,6 +107,12 @@ begin 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 declare @@ -208,6 +214,12 @@ begin 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 -- Create_Standard, which uses the scanner in its processing of -- floating-point bounds. @@ -318,11 +330,11 @@ begin end if; -- 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 -- generation of qualified names when needed. - if not Java_VM then + if VM_Target = No_VM then Exp_Dbug.Qualify_All_Entity_Names; end if; diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index e1e53daa2f9..a08d8fcb4eb 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -6,7 +6,7 @@ -- -- -- 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 -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -49,6 +49,7 @@ with Output; use Output; with Prepcomp; with Repinfo; use Repinfo; with Restrict; +with Rtsfind; with Sem; with Sem_Ch8; with Sem_Ch12; @@ -61,7 +62,7 @@ with Sinput.L; use Sinput.L; with Snames; with Sprint; use Sprint; with Stringt; -with Targparm; +with Targparm; use Targparm; with Tree_Gen; with Treepr; use Treepr; with Ttypes; @@ -83,6 +84,174 @@ procedure Gnat1drv is Back_End_Mode : Back_End.Back_End_Mode_Type; -- 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 -- This inner block is set up to catch assertion errors and constraint -- errors. Since the code for handling these errors can cause another @@ -91,8 +260,7 @@ begin begin -- Lib.Initialize need to be called before Scan_Compiler_Arguments, - -- because it initialize a table that is filled by - -- Scan_Compiler_Arguments. + -- because it initializes a table filled by Scan_Compiler_Arguments. Osint.Initialize; Fmap.Reset_Tables; @@ -125,7 +293,7 @@ begin use Sinput; S : Source_File_Index; - N : Name_Id; + N : File_Name_Type; begin Name_Buffer (1 .. 10) := "system.ads"; @@ -147,9 +315,9 @@ begin end if; Targparm.Get_Target_Parameters - (System_Text => Source_Text (S), + (System_Text => Source_Text (S), Source_First => Source_First (S), - Source_Last => Source_Last (S)); + Source_Last => Source_Last (S)); -- Acquire configuration pragma information from Targparm @@ -173,7 +341,7 @@ begin -- 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 - 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 then Write_Eol; @@ -230,9 +398,9 @@ begin Suppress_Options (Overflow_Check) := True; end if; - -- Check we have exactly one source file, this happens only in the case - -- where the driver is called directly, it cannot happen when gnat1 is - -- invoked from gcc in the normal case. + -- Check we do not have more than one source file, this happens only in + -- the case where the driver is called directly, it cannot happen when + -- gnat1 is invoked from gcc in the normal case. if Osint.Number_Of_Files /= 1 then Usage; @@ -245,145 +413,27 @@ begin Original_Operating_Mode := Operating_Mode; 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 - Sname := Unit_Name (Main_Unit); + -- Exit with errors if the main source could not be parsed - -- 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. - - 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; + if Sinput.Main_Source_File = No_Source_File then + Errout.Finalize; + Errout.Output_Messages; + Exit_Program (E_Errors); end if; + Main_Unit_Node := Cunit (Main_Unit); + Main_Kind := Nkind (Unit (Main_Unit_Node)); + Check_Bad_Body; + -- Exit if compilation errors detected + Errout.Finalize; + if Compilation_Errors then Treepr.Tree_Dump; Sem_Ch13.Validate_Unchecked_Conversions; - Errout.Finalize; + Errout.Output_Messages; Namet.Finalize; -- Generate ALI file if specially requested @@ -417,8 +467,10 @@ begin if Original_Operating_Mode = Check_Syntax then Treepr.Tree_Dump; Errout.Finalize; + Errout.Output_Messages; Tree_Gen; Namet.Finalize; + Check_Rep_Info; -- Use a goto instead of calling Exit_Program so that finalization -- occurs normally. @@ -561,10 +613,12 @@ begin Sem_Ch13.Validate_Unchecked_Conversions; Errout.Finalize; + Errout.Output_Messages; Treepr.Tree_Dump; Tree_Gen; Write_ALI (Object => False); Namet.Finalize; + Check_Rep_Info; -- Exit program with error indication, to kill object file @@ -581,20 +635,22 @@ begin -- enabled, because the front end determines representations. -- 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 and then (not Back_Annotate_Rep_Info - or else Main_Kind = N_Subunit - or else Targparm.Frontend_Layout_On_Target - or else Hostparm.Java_VM) + or else Main_Kind = N_Subunit + or else Targparm.Frontend_Layout_On_Target + or else Targparm.VM_Target /= No_VM) then Sem_Ch13.Validate_Unchecked_Conversions; Errout.Finalize; + Errout.Output_Messages; Write_ALI (Object => False); Tree_Dump; Tree_Gen; Namet.Finalize; + Check_Rep_Info; return; end if; @@ -624,6 +680,7 @@ begin -- Here we call the back end to generate the output code + Generating_Code := True; Back_End.Call_Back_End (Back_End_Mode); -- Once the backend is complete, we unlock the names table. This call @@ -644,6 +701,7 @@ begin -- representation information for List_Rep_Info. Errout.Finalize; + Errout.Output_Messages; List_Rep_Info; -- Only write the library if the backend did not generate any error @@ -673,6 +731,9 @@ begin exception -- Handle fatal internal compiler errors + when Rtsfind.RE_Not_Available => + Comperr.Compiler_Abort ("RE_Not_Available"); + when System.Assertions.Assert_Failure => Comperr.Compiler_Abort ("Assert_Failure"); @@ -698,6 +759,7 @@ begin exception when Unrecoverable_Error => Errout.Finalize; + Errout.Output_Messages; Set_Standard_Error; Write_Str ("compilation abandoned"); -- 2.30.2