path: root/gcc/ada/gnat1drv.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                             G N A T 1 D R V                              --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2003 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 Rident;
with Sem;
with Sem_Ch8;
with Sem_Ch12;
with Sem_Ch13;
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_Unit_Entity : Node_Id;
   --  Compilation unit entity 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_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;
         R : Restrict.Restriction_Id;
         P : Restrict.Restriction_Parameter_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;

         --  Here if system.ads successfully read. Remember its source index.

         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

         for J in Rident.Partition_Restrictions loop
            R := Restrict.Partition_Restrictions (J);

            if Targparm.Restrictions_On_Target (J) then
               Restrict.Restrictions (R)     := True;
               Restrict.Restrictions_Loc (R) := System_Location;
            end if;
         end loop;

         for K in Rident.Restriction_Parameter_Id loop
            P := Restrict.Restriction_Parameter_Id (K);

            if Targparm.Restriction_Parameters_On_Target (K) /= No_Uint then
               Restrict.Restriction_Parameters (P) :=
                 Targparm.Restriction_Parameters_On_Target (K);
               Restrict.Restriction_Parameters_Loc (P) := System_Location;
            end if;
         end loop;
      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;

      --  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_Str (" Copyright 1992-2003 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_Unit_Entity := Cunit_Entity (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
         declare
            Sname   : Unit_Name_Type := Unit_Name (Main_Unit);
            Src_Ind : Source_File_Index;
            Fname   : File_Name_Type;

            procedure Bad_Body (Msg : String);
            --  Issue message for bad body found

            procedure Bad_Body (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;

         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.

            if Src_Ind /= No_Source_File
              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_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
                       ("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
                       ("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 ("package % does not allow a body!");

                     elsif Main_Kind = N_Generic_Package_Declaration then
                        Bad_Body ("generic package % does not allow a body!");
                     end if;
                  end if;

               end if;
            end if;
         end;
      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 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 Debug_Flag_AA)
                   or else Main_Kind = N_Subunit
                   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;