------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- G N A T 1 D R V -- -- -- -- B o d y -- -- -- -- Copyright (C) 1992-2005 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 2, 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 COPYING. If not, write -- -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- -- MA 02111-1307, USA. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Back_End; use Back_End; with Comperr; with Csets; use Csets; with Debug; use Debug; with Elists; with Errout; use Errout; with Fmap; with Fname; use Fname; with Fname.UF; use Fname.UF; with Frontend; with Gnatvsn; use Gnatvsn; with Hostparm; with Inline; with Lib; use Lib; with Lib.Writ; use Lib.Writ; with Lib.Xref; with Namet; use Namet; with Nlists; with Opt; use Opt; with Osint; use Osint; with Output; use Output; with Prepcomp; with Repinfo; use Repinfo; with Restrict; with Sem; with Sem_Ch8; with Sem_Ch12; with Sem_Ch13; with Sem_Elim; with Sem_Eval; with Sem_Type; with Sinfo; use Sinfo; with Sinput.L; use Sinput.L; with Snames; with Sprint; use Sprint; with Stringt; with Targparm; with Tree_Gen; with Treepr; use Treepr; with Ttypes; with Types; use Types; with Uintp; use Uintp; with Uname; use Uname; with Urealp; with Usage; with System.Assertions; procedure Gnat1drv is Main_Unit_Node : Node_Id; -- Compilation unit node for main unit Main_Kind : Node_Kind; -- Kind of main compilation unit node Back_End_Mode : Back_End.Back_End_Mode_Type; -- Record back end mode begin -- This inner block is set up to catch assertion errors and constraint -- errors. Since the code for handling these errors can cause another -- exception to be raised (namely Unrecoverable_Error), we need two -- nested blocks, so that the outer one handles unrecoverable error. begin -- Lib.Initialize need to be called before Scan_Compiler_Arguments, -- because it initialize a table that is filled by -- Scan_Compiler_Arguments. Osint.Initialize; Fmap.Reset_Tables; Lib.Initialize; Lib.Xref.Initialize; Scan_Compiler_Arguments; Osint.Add_Default_Search_Dirs; Nlists.Initialize; Sinput.Initialize; Sem.Initialize; Csets.Initialize; Uintp.Initialize; Urealp.Initialize; Errout.Initialize; Namet.Initialize; Snames.Initialize; Stringt.Initialize; Inline.Initialize; Sem_Ch8.Initialize; Sem_Ch12.Initialize; Sem_Ch13.Initialize; Sem_Elim.Initialize; Sem_Eval.Initialize; Sem_Type.Init_Interp_Tables; -- Acquire target parameters from system.ads (source of package System) declare use Sinput; S : Source_File_Index; N : Name_Id; begin Name_Buffer (1 .. 10) := "system.ads"; Name_Len := 10; N := Name_Find; S := Load_Source_File (N); if S = No_Source_File then Write_Line ("fatal error, run-time library not installed correctly"); Write_Line ("cannot locate file system.ads"); raise Unrecoverable_Error; -- Remember source index of system.ads (which was read successfully) else System_Source_File_Index := S; end if; Targparm.Get_Target_Parameters (System_Text => Source_Text (S), Source_First => Source_First (S), Source_Last => Source_Last (S)); -- Acquire configuration pragma information from Targparm Restrict.Restrictions := Targparm.Restrictions_On_Target; end; -- Set Configurable_Run_Time mode if system.ads flag set if Targparm.Configurable_Run_Time_On_Target or Debug_Flag_YY then Configurable_Run_Time_Mode := True; end if; -- Set -gnatR3m mode if debug flag A set if Debug_Flag_AA then Back_Annotate_Rep_Info := True; List_Representation_Info := 1; List_Representation_Info_Mechanisms := True; end if; -- Output copyright notice if full list mode if (Verbose_Mode or Full_List) and then (not Debug_Flag_7) then Write_Eol; Write_Str ("GNAT "); Write_Str (Gnat_Version_String); Write_Eol; Write_Str ("Copyright 1992-2005 Free Software Foundation, Inc."); Write_Eol; end if; -- Before we do anything else, adjust certain global values for -- debug switches which modify their normal natural settings. if Debug_Flag_8 then Ttypes.Bytes_Big_Endian := not Ttypes.Bytes_Big_Endian; end if; if Debug_Flag_M then Targparm.OpenVMS_On_Target := True; Hostparm.OpenVMS := True; end if; if Debug_Flag_FF then Targparm.Frontend_Layout_On_Target := True; end if; -- We take the default exception mechanism into account if Targparm.ZCX_By_Default_On_Target then if Targparm.GCC_ZCX_Support_On_Target then Exception_Mechanism := Back_End_ZCX_Exceptions; else Exception_Mechanism := Front_End_ZCX_Exceptions; end if; end if; -- We take the command line exception mechanism into account if Opt.Zero_Cost_Exceptions_Set then if Opt.Zero_Cost_Exceptions_Val = False then Exception_Mechanism := Front_End_Setjmp_Longjmp_Exceptions; elsif Debug_Flag_XX then Exception_Mechanism := Front_End_ZCX_Exceptions; elsif Targparm.GCC_ZCX_Support_On_Target then Exception_Mechanism := Back_End_ZCX_Exceptions; elsif Targparm.Front_End_ZCX_Support_On_Target then Exception_Mechanism := Front_End_ZCX_Exceptions; else Osint.Fail ("Zero Cost Exceptions not supported on this target"); end if; end if; -- Set proper status for overflow checks. We turn on overflow checks -- if -gnatp was not specified, and either -gnato is set or the back -- end takes care of overflow checks. Otherwise we suppress overflow -- checks by default (since front end checks are expensive). if not Opt.Suppress_Checks and then (Opt.Enable_Overflow_Checks or else (Targparm.Backend_Divide_Checks_On_Target and Targparm.Backend_Overflow_Checks_On_Target)) then Suppress_Options (Overflow_Check) := False; else 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. if Osint.Number_Of_Files /= 1 then Usage; Write_Eol; Osint.Fail ("you must provide one source file"); elsif Usage_Requested then Usage; end if; 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); -- 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; end if; -- Exit if compilation errors detected if Compilation_Errors then Treepr.Tree_Dump; Sem_Ch13.Validate_Unchecked_Conversions; Errout.Finalize; Namet.Finalize; -- Generate ALI file if specially requested if Opt.Force_ALI_Tree_File then Write_ALI (Object => False); Tree_Gen; end if; Exit_Program (E_Errors); end if; -- Set Generate_Code on main unit and its spec. We do this even if are -- not generating code, since Lib-Writ uses this to determine which -- units get written in the ali file. Set_Generate_Code (Main_Unit); -- If we have a corresponding spec, then we need object -- code for the spec unit as well if Nkind (Unit (Main_Unit_Node)) in N_Unit_Body and then not Acts_As_Spec (Main_Unit_Node) then Set_Generate_Code (Get_Cunit_Unit_Number (Library_Unit (Main_Unit_Node))); end if; -- Case of no code required to be generated, exit indicating no error if Original_Operating_Mode = Check_Syntax then Treepr.Tree_Dump; Errout.Finalize; Tree_Gen; Namet.Finalize; Exit_Program (E_Success); elsif Original_Operating_Mode = Check_Semantics then Back_End_Mode := Declarations_Only; -- All remaining cases are cases in which the user requested that code -- be generated (i.e. no -gnatc or -gnats switch was used). Check if -- we can in fact satisfy this request. -- Cannot generate code if someone has turned off code generation for -- any reason at all. We will try to figure out a reason below. elsif Operating_Mode /= Generate_Code then Back_End_Mode := Skip; -- We can generate code for a subprogram body unless there were missing -- subunits. Note that we always generate code for all generic units (a -- change from some previous versions of GNAT). elsif Main_Kind = N_Subprogram_Body and then not Subunits_Missing then Back_End_Mode := Generate_Object; -- We can generate code for a package body unless there are subunits -- missing (note that we always generate code for generic units, which -- is a change from some earlier versions of GNAT). elsif Main_Kind = N_Package_Body and then not Subunits_Missing then Back_End_Mode := Generate_Object; -- We can generate code for a package declaration or a subprogram -- declaration only if it does not required a body. elsif (Main_Kind = N_Package_Declaration or else Main_Kind = N_Subprogram_Declaration) and then (not Body_Required (Main_Unit_Node) or else Distribution_Stub_Mode = Generate_Caller_Stub_Body) then Back_End_Mode := Generate_Object; -- We can generate code for a generic package declaration of a generic -- subprogram declaration only if does not require a body. elsif (Main_Kind = N_Generic_Package_Declaration or else Main_Kind = N_Generic_Subprogram_Declaration) and then not Body_Required (Main_Unit_Node) then Back_End_Mode := Generate_Object; -- Compilation units that are renamings do not require bodies, -- so we can generate code for them. elsif Main_Kind = N_Package_Renaming_Declaration or else Main_Kind = N_Subprogram_Renaming_Declaration then Back_End_Mode := Generate_Object; -- Compilation units that are generic renamings do not require bodies -- so we can generate code for them. elsif Main_Kind in N_Generic_Renaming_Declaration then Back_End_Mode := Generate_Object; -- In all other cases (specs which have bodies, generics, and bodies -- where subunits are missing), we cannot generate code and we generate -- a warning message. Note that generic instantiations are gone at this -- stage since they have been replaced by their instances. else Back_End_Mode := Skip; end if; -- At this stage Call_Back_End is set to indicate if the backend should -- be called to generate code. If it is not set, then code generation -- has been turned off, even though code was requested by the original -- command. This is not an error from the user point of view, but it is -- an error from the point of view of the gcc driver, so we must exit -- with an error status. -- We generate an informative message (from the gcc point of view, it -- is an error message, but from the users point of view this is not an -- error, just a consequence of compiling something that cannot -- generate code). if Back_End_Mode = Skip then Write_Str ("cannot generate code for "); Write_Str ("file "); Write_Name (Unit_File_Name (Main_Unit)); if Subunits_Missing then Write_Str (" (missing subunits)"); Write_Eol; Write_Str ("to check parent unit"); elsif Main_Kind = N_Subunit then Write_Str (" (subunit)"); Write_Eol; Write_Str ("to check subunit"); elsif Main_Kind = N_Subprogram_Declaration then Write_Str (" (subprogram spec)"); Write_Eol; Write_Str ("to check subprogram spec"); -- Generic package body in GNAT implementation mode elsif Main_Kind = N_Package_Body and then GNAT_Mode then Write_Str (" (predefined generic)"); Write_Eol; Write_Str ("to check predefined generic"); -- Only other case is a package spec else Write_Str (" (package spec)"); Write_Eol; Write_Str ("to check package spec"); end if; Write_Str (" for errors, use "); if Hostparm.OpenVMS then Write_Str ("/NOLOAD"); else Write_Str ("-gnatc"); end if; Write_Eol; Sem_Ch13.Validate_Unchecked_Conversions; Errout.Finalize; Treepr.Tree_Dump; Tree_Gen; Write_ALI (Object => False); Namet.Finalize; -- Exit program with error indication, to kill object file Exit_Program (E_No_Code); end if; -- In -gnatc mode, we only do annotation if -gnatt or -gnatR is also -- set as indicated by Back_Annotate_Rep_Info being set to True. -- We don't call for annotations on a subunit, because to process those -- the back-end requires that the parent(s) be properly compiled. -- Annotation is suppressed for targets where front-end layout is -- 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. 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) then Sem_Ch13.Validate_Unchecked_Conversions; Errout.Finalize; Write_ALI (Object => False); Tree_Dump; Tree_Gen; Namet.Finalize; return; end if; -- Ensure that we properly register a dependency on system.ads, since -- even if we do not semantically depend on this, Targparm has read -- system parameters from the system.ads file. Lib.Writ.Ensure_System_Dependency; -- Add dependencies, if any, on preprocessing data file and on -- preprocessing definition file(s). Prepcomp.Add_Dependencies; -- Back end needs to explicitly unlock tables it needs to touch Atree.Lock; Elists.Lock; Fname.UF.Lock; Inline.Lock; Lib.Lock; Nlists.Lock; Sem.Lock; Sinput.Lock; Namet.Lock; Stringt.Lock; -- Here we call the back end to generate the output code Back_End.Call_Back_End (Back_End_Mode); -- Once the backend is complete, we unlock the names table. This call -- allows a few extra entries, needed for example for the file name for -- the library file output. Namet.Unlock; -- Validate unchecked conversions (using the values for size and -- alignment annotated by the backend where possible). Sem_Ch13.Validate_Unchecked_Conversions; -- Now we complete output of errors, rep info and the tree info. These -- are delayed till now, since it is perfectly possible for gigi to -- generate errors, modify the tree (in particular by setting flags -- indicating that elaboration is required, and also to back annotate -- representation information for List_Rep_Info. Errout.Finalize; List_Rep_Info; -- Only write the library if the backend did not generate any error -- messages. Otherwise signal errors to the driver program so that -- there will be no attempt to generate an object file. if Compilation_Errors then Treepr.Tree_Dump; Exit_Program (E_Errors); end if; Write_ALI (Object => (Back_End_Mode = Generate_Object)); -- Generate the ASIS tree after writing the ALI file, since in ASIS -- mode, Write_ALI may in fact result in further tree decoration from -- the original tree file. Note that we dump the tree just before -- generating it, so that the dump will exactly reflect what is written -- out. Treepr.Tree_Dump; Tree_Gen; -- Finalize name table and we are all done Namet.Finalize; exception -- Handle fatal internal compiler errors when System.Assertions.Assert_Failure => Comperr.Compiler_Abort ("Assert_Failure"); when Constraint_Error => Comperr.Compiler_Abort ("Constraint_Error"); when Program_Error => Comperr.Compiler_Abort ("Program_Error"); when Storage_Error => -- Assume this is a bug. If it is real, the message will in any case -- say Storage_Error, giving a strong hint! Comperr.Compiler_Abort ("Storage_Error"); end; -- The outer exception handles an unrecoverable error exception when Unrecoverable_Error => Errout.Finalize; Set_Standard_Error; Write_Str ("compilation abandoned"); Write_Eol; Set_Standard_Output; Source_Dump; Tree_Dump; Exit_Program (E_Errors); end Gnat1drv;