Subversion Repositories scarts

------------------------------------------------------------------------------

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                             L I B . W R I T                              --

--                                                                          --

--                                 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,  51  Franklin  Street,  Fifth  Floor, --

-- Boston, MA 02110-1301, USA.                                              --

--                                                                          --

-- GNAT was originally developed  by the GNAT team at  New York University. --

-- Extensive contributions were provided by Ada Core Technologies Inc.      --

--                                                                          --

------------------------------------------------------------------------------

with ALI;      use ALI;

with Atree;    use Atree;

with Casing;   use Casing;

with Einfo;    use Einfo;

with Errout;   use Errout;

with Fname;    use Fname;

with Fname.UF; use Fname.UF;

with Lib.Util; use Lib.Util;

with Lib.Xref; use Lib.Xref;

with Namet;    use Namet;

with Nlists;   use Nlists;

with Gnatvsn;  use Gnatvsn;

with Opt;      use Opt;

with Osint;    use Osint;

with Osint.C;  use Osint.C;

with Par;

with Restrict; use Restrict;

with Rident;   use Rident;

with Scn;      use Scn;

with Sinfo;    use Sinfo;

with Sinput;   use Sinput;

with Stringt;  use Stringt;

with Tbuild;   use Tbuild;

with Uname;    use Uname;

with System.Case_Util; use System.Case_Util;

with System.WCh_Con;   use System.WCh_Con;

package body Lib.Writ is

   -----------------------

   -- Local Subprograms --

   -----------------------

   procedure Write_Unit_Name (N : Node_Id);

   --  Used to write out the unit name for R (pragma Restriction) lines

   --  for uses of Restriction (No_Dependence => unit-name).

   ----------------------------------

   -- Add_Preprocessing_Dependency --

   ----------------------------------

   procedure Add_Preprocessing_Dependency (S : Source_File_Index) is

   begin

      Units.Increment_Last;

      Units.Table (Units.Last) :=

        (Unit_File_Name  => File_Name (S),

         Unit_Name       => No_Name,

         Expected_Unit   => No_Name,

         Source_Index    => S,

         Cunit           => Empty,

         Cunit_Entity    => Empty,

         Dependency_Num  => 0,

         Dynamic_Elab    => False,

         Fatal_Error     => False,

         Generate_Code   => False,

         Has_RACW        => False,

         Ident_String    => Empty,

         Loading         => False,

         Main_Priority   => -1,

         Munit_Index     => 0,

         Serial_Number   => 0,

         Version         => 0,

         Error_Location  => No_Location);

   end Add_Preprocessing_Dependency;

   ------------------------------

   -- Ensure_System_Dependency --

   ------------------------------

   procedure Ensure_System_Dependency is

      System_Uname : Unit_Name_Type;

      --  Unit name for system spec if needed for dummy entry

      System_Fname : File_Name_Type;

      --  File name for system spec if needed for dummy entry

   begin

      --  Nothing to do if we already compiled System

      for Unum in Units.First .. Last_Unit loop

         if Units.Table (Unum).Source_Index = System_Source_File_Index then

            return;

         end if;

      end loop;

      --  If no entry for system.ads in the units table, then add a entry

      --  to the units table for system.ads, which will be referenced when

      --  the ali file is generated. We need this because every unit depends

      --  on system as a result of Targparm scanning the system.ads file to

      --  determine the target dependent parameters for the compilation.

      Name_Len := 6;

      Name_Buffer (1 .. 6) := "system";

      System_Uname := Name_To_Unit_Name (Name_Enter);

      System_Fname := File_Name (System_Source_File_Index);

      Units.Increment_Last;

      Units.Table (Units.Last) := (

        Unit_File_Name  => System_Fname,

        Unit_Name       => System_Uname,

        Expected_Unit   => System_Uname,

        Source_Index    => System_Source_File_Index,

        Cunit           => Empty,

        Cunit_Entity    => Empty,

        Dependency_Num  => 0,

        Dynamic_Elab    => False,

        Fatal_Error     => False,

        Generate_Code   => False,

        Has_RACW        => False,

        Ident_String    => Empty,

        Loading         => False,

        Main_Priority   => -1,

        Munit_Index     => 0,

        Serial_Number   => 0,

        Version         => 0,

        Error_Location  => No_Location);

      --  Parse system.ads so that the checksum is set right

      --  Style checks are not applied.

      declare

         Save_Mindex : constant Nat := Multiple_Unit_Index;

         Save_Style  : constant Boolean := Style_Check;

      begin

         Multiple_Unit_Index := 0;

         Style_Check := False;

         Initialize_Scanner (Units.Last, System_Source_File_Index);

         Discard_List (Par (Configuration_Pragmas => False));

         Style_Check := Save_Style;

         Multiple_Unit_Index := Save_Mindex;

      end;

   end Ensure_System_Dependency;

   ---------------

   -- Write_ALI --

   ---------------

   procedure Write_ALI (Object : Boolean) is

      ----------------

      -- Local Data --

      ----------------

      Last_Unit : constant Unit_Number_Type := Units.Last;

      --  Record unit number of last unit. We capture this in case we

      --  have to add a dummy entry to the unit table for package System.

      With_Flags : array (Units.First .. Last_Unit) of Boolean;

      --  Array of flags to show which units are with'ed

      Elab_Flags : array (Units.First .. Last_Unit) of Boolean;

      --  Array of flags to show which units have pragma Elaborate set

      Elab_All_Flags : array (Units.First .. Last_Unit) of Boolean;

      --  Array of flags to show which units have pragma Elaborate All set

      Elab_Des_Flags : array (Units.First .. Last_Unit) of Boolean;

      --  Array of flags to show which units have Elaborate_Desirable set

      Elab_All_Des_Flags : array (Units.First .. Last_Unit) of Boolean;

      --  Array of flags to show which units have Elaborate_All_Desirable set

      Sdep_Table : Unit_Ref_Table (1 .. Pos (Last_Unit - Units.First + 2));

      --  Sorted table of source dependencies. One extra entry in case we

      --  have to add a dummy entry for System.

      Num_Sdep : Nat := 0;

      --  Number of active entries in Sdep_Table

      -----------------------

      -- Local Subprograms --

      -----------------------

      procedure Collect_Withs (Cunit : Node_Id);

      --  Collect with lines for entries in the context clause of the

      --  given compilation unit, Cunit.

      procedure Update_Tables_From_ALI_File;

      --  Given an up to date ALI file (see Up_To_Date_ALI_file_Exists

      --  function), update tables from the ALI information, including

      --  specifically the Compilation_Switches table.

      function Up_To_Date_ALI_File_Exists return Boolean;

      --  If there exists an ALI file that is up to date, then this function

      --  initializes the tables in the ALI spec to contain information on

      --  this file (using Scan_ALI) and returns True. If no file exists,

      --  or the file is not up to date, then False is returned.

      procedure Write_Unit_Information (Unit_Num : Unit_Number_Type);

      --  Write out the library information for one unit for which code is

      --  generated (includes unit line and with lines).

      procedure Write_With_Lines;

      --  Write out with lines collected by calls to Collect_Withs

      -------------------

      -- Collect_Withs --

      -------------------

      procedure Collect_Withs (Cunit : Node_Id) is

         Item : Node_Id;

         Unum : Unit_Number_Type;

      begin

         Item := First (Context_Items (Cunit));

         while Present (Item) loop

            --  Process with clause

            --  Ada 2005 (AI-50217): limited with_clauses do not create

            --  dependencies

            if Nkind (Item) = N_With_Clause

              and then not (Limited_Present (Item))

            then

               Unum := Get_Cunit_Unit_Number (Library_Unit (Item));

               With_Flags (Unum) := True;

               if Elaborate_Present (Item) then

                  Elab_Flags (Unum) := True;

               end if;

               if Elaborate_All_Present (Item) then

                  Elab_All_Flags (Unum) := True;

               end if;

               if Elaborate_All_Desirable (Item) then

                  Elab_All_Des_Flags (Unum) := True;

               end if;

               if Elaborate_Desirable (Item) then

                  Elab_Des_Flags (Unum) := True;

               end if;

            end if;

            Next (Item);

         end loop;

      end Collect_Withs;

      --------------------------------

      -- Up_To_Date_ALI_File_Exists --

      --------------------------------

      function Up_To_Date_ALI_File_Exists return Boolean is

         Name : File_Name_Type;

         Text : Text_Buffer_Ptr;

         Id   : Sdep_Id;

         Sind : Source_File_Index;

      begin

         Opt.Check_Object_Consistency := True;

         Read_Library_Info (Name, Text);

         --  Return if we could not find an ALI file

         if Text = null then

            return False;

         end if;

         --  Return if ALI file has bad format

         Initialize_ALI;

         if Scan_ALI (Name, Text, False, Err => True) = No_ALI_Id then

            return False;

         end if;

         --  If we have an OK ALI file, check if it is up to date

         --  Note that we assume that the ALI read has all the entries

         --  we have in our table, plus some additional ones (that can

         --  come from expansion).

         Id := First_Sdep_Entry;

         for J in 1 .. Num_Sdep loop

            Sind := Units.Table (Sdep_Table (J)).Source_Index;

            while Sdep.Table (Id).Sfile /= File_Name (Sind) loop

               if Id = Sdep.Last then

                  return False;

               else

                  Id := Id + 1;

               end if;

            end loop;

            if Sdep.Table (Id).Stamp /= Time_Stamp (Sind) then

               return False;

            end if;

         end loop;

         return True;

      end Up_To_Date_ALI_File_Exists;

      ---------------------------------

      -- Update_Tables_From_ALI_File --

      ---------------------------------

      procedure Update_Tables_From_ALI_File is

      begin

         --  Build Compilation_Switches table

         Compilation_Switches.Init;

         for J in First_Arg_Entry .. Args.Last loop

            Compilation_Switches.Increment_Last;

            Compilation_Switches.Table (Compilation_Switches.Last) :=

              Args.Table (J);

         end loop;

      end Update_Tables_From_ALI_File;

      ----------------------------

      -- Write_Unit_Information --

      ----------------------------

      procedure Write_Unit_Information (Unit_Num : Unit_Number_Type) is

         Unode : constant Node_Id   := Cunit (Unit_Num);

         Ukind : constant Node_Kind := Nkind (Unit (Unode));

         Uent  : constant Entity_Id := Cunit_Entity (Unit_Num);

         Pnode : Node_Id;

      begin

         Write_Info_Initiate ('U');

         Write_Info_Char (' ');

         Write_Info_Name (Unit_Name (Unit_Num));

         Write_Info_Tab (25);

         Write_Info_Name (Unit_File_Name (Unit_Num));

         Write_Info_Tab (49);

         Write_Info_Str (Version_Get (Unit_Num));

         if (Is_Subprogram (Uent)

              or else Ekind (Uent) = E_Package

              or else Is_Generic_Unit (Uent))

           and then Body_Needed_For_SAL (Uent)

         then

            Write_Info_Str (" BN");

         end if;

         if Dynamic_Elab (Unit_Num) then

            Write_Info_Str (" DE");

         end if;

         --  We set the Elaborate_Body indication if either an explicit pragma

         --  was present, or if this is an instantiation. RM 12.3(20) requires

         --  that the body be immediately elaborated after the spec. We would

         --  normally do that anyway, but the EB we generate here ensures that

         --  this gets done even when we use the -p gnatbind switch.

         if Has_Pragma_Elaborate_Body (Uent)

           or else (Ukind = N_Package_Declaration

                     and then Is_Generic_Instance (Uent)

                     and then Present (Corresponding_Body (Unit (Unode))))

         then

            Write_Info_Str (" EB");

         end if;

         --  Now see if we should tell the binder that an elaboration entity

         --  is present, which must be reset to true during elaboration. We

         --  generate the indication if the following condition is met:

         --  If this is a spec ...

         if (Is_Subprogram (Uent)

               or else

             Ekind (Uent) = E_Package

               or else

             Is_Generic_Unit (Uent))

            --  and an elaboration entity was declared ...

            and then Present (Elaboration_Entity (Uent))

            --  and either the elaboration flag is required ...

            and then

              (Elaboration_Entity_Required (Uent)

               --  or this unit has elaboration code ...

               or else not Has_No_Elaboration_Code (Unode)

               --  or this unit has a separate body and this

               --  body has elaboration code.

               or else

                 (Ekind (Uent) = E_Package

                   and then Present (Body_Entity (Uent))

                   and then

                     not Has_No_Elaboration_Code

                           (Parent

                             (Declaration_Node

                               (Body_Entity (Uent))))))

         then

            Write_Info_Str (" EE");

         end if;

         if Has_No_Elaboration_Code (Unode) then

            Write_Info_Str (" NE");

         end if;

         if Is_Preelaborated (Uent) then

            Write_Info_Str (" PR");

         end if;

         if Is_Pure (Uent) then

            Write_Info_Str (" PU");

         end if;

         if Has_RACW (Unit_Num) then

            Write_Info_Str (" RA");

         end if;

         if Is_Remote_Call_Interface (Uent) then

            Write_Info_Str (" RC");

         end if;

         if Is_Remote_Types (Uent) then

            Write_Info_Str (" RT");

         end if;

         if Is_Shared_Passive (Uent) then

            Write_Info_Str (" SP");

         end if;

         if Ukind = N_Subprogram_Declaration

           or else Ukind = N_Subprogram_Body

         then

            Write_Info_Str (" SU");

         elsif Ukind = N_Package_Declaration

                 or else

               Ukind = N_Package_Body

         then

            --  If this is a wrapper package for a subprogram instantiation,

            --  the user view is the subprogram. Note that in this case the

            --  ali file contains both the spec and body of the instance.

            if Is_Wrapper_Package (Uent) then

               Write_Info_Str (" SU");

            else

               Write_Info_Str (" PK");

            end if;

         elsif Ukind = N_Generic_Package_Declaration then

            Write_Info_Str (" PK");

         end if;

         if Ukind in N_Generic_Declaration

           or else

             (Present (Library_Unit (Unode))

                and then

              Nkind (Unit (Library_Unit (Unode))) in N_Generic_Declaration)

         then

            Write_Info_Str (" GE");

         end if;

         if not Is_Internal_File_Name (Unit_File_Name (Unit_Num), True) then

            case Identifier_Casing (Source_Index (Unit_Num)) is

               when All_Lower_Case => Write_Info_Str (" IL");

               when All_Upper_Case => Write_Info_Str (" IU");

               when others         => null;

            end case;

            case Keyword_Casing (Source_Index (Unit_Num)) is

               when Mixed_Case     => Write_Info_Str (" KM");

               when All_Upper_Case => Write_Info_Str (" KU");

               when others         => null;

            end case;

         end if;

         if Initialize_Scalars then

            Write_Info_Str (" IS");

         end if;

         Write_Info_EOL;

         --  Generate with lines, first those that are directly with'ed

         for J in With_Flags'Range loop

            With_Flags         (J) := False;

            Elab_Flags         (J) := False;

            Elab_All_Flags     (J) := False;

            Elab_Des_Flags     (J) := False;

            Elab_All_Des_Flags (J) := False;

         end loop;

         Collect_Withs (Unode);

         --  For a body, we must also check for any subunits which belong to

         --  it and which have context clauses of their own, since these

         --  with'ed units are part of its own elaboration dependencies.

         if Nkind (Unit (Unode)) in N_Unit_Body then

            for S in Units.First .. Last_Unit loop

               --  We are only interested in subunits.

               --  For preproc. data and def. files, Cunit is Empty, so

               --  we need to test that first.

               if Cunit (S) /= Empty

                 and then Nkind (Unit (Cunit (S))) = N_Subunit

               then

                  Pnode := Library_Unit (Cunit (S));

                  --  In gnatc mode, the errors in the subunits will not

                  --  have been recorded, but the analysis of the subunit

                  --  may have failed. There is no information to add to

                  --  ALI file in this case.

                  if No (Pnode) then

                     exit;

                  end if;

                  --  Find ultimate parent of the subunit

                  while Nkind (Unit (Pnode)) = N_Subunit loop

                     Pnode := Library_Unit (Pnode);

                  end loop;

                  --  See if it belongs to current unit, and if so, include

                  --  its with_clauses.

                  if Pnode = Unode then

                     Collect_Withs (Cunit (S));

                  end if;

               end if;

            end loop;

         end if;

         Write_With_Lines;

         --  Output linker option lines

         for J in 1 .. Linker_Option_Lines.Last loop

            declare

               S : constant Linker_Option_Entry :=

                     Linker_Option_Lines.Table (J);

               C : Character;

            begin

               if S.Unit = Unit_Num then

                  Write_Info_Initiate ('L');

                  Write_Info_Str (" """);

                  for J in 1 .. String_Length (S.Option) loop

                     C := Get_Character (Get_String_Char (S.Option, J));

                     if C in Character'Val (16#20#) .. Character'Val (16#7E#)

                       and then C /= '{'

                     then

                        Write_Info_Char (C);

                        if C = '"' then

                           Write_Info_Char (C);

                        end if;

                     else

                        declare

                           Hex : constant array (0 .. 15) of Character :=

                                   "0123456789ABCDEF";

                        begin

                           Write_Info_Char ('{');

                           Write_Info_Char (Hex (Character'Pos (C) / 16));

                           Write_Info_Char (Hex (Character'Pos (C) mod 16));

                           Write_Info_Char ('}');

                        end;

                     end if;

                  end loop;

                  Write_Info_Char ('"');

                  Write_Info_EOL;

               end if;

            end;

         end loop;

      end Write_Unit_Information;

      ----------------------

      -- Write_With_Lines --

      ----------------------

      procedure Write_With_Lines is

         With_Table : Unit_Ref_Table (1 .. Pos (Last_Unit - Units.First + 1));

         Num_Withs  : Int := 0;

         Unum       : Unit_Number_Type;

         Cunit      : Node_Id;

         Cunite     : Entity_Id;

         Uname      : Unit_Name_Type;

         Fname      : File_Name_Type;

         Pname      : constant Unit_Name_Type :=

                        Get_Parent_Spec_Name (Unit_Name (Main_Unit));

         Body_Fname : File_Name_Type;

         Body_Index : Nat;

      begin

         --  Loop to build the with table. A with on the main unit itself

         --  is ignored (AARM 10.2(14a)). Such a with-clause can occur if

         --  the main unit is a subprogram with no spec, and a subunit of

         --  it unecessarily withs the parent.

         for J in Units.First + 1 .. Last_Unit loop

            --  Add element to with table if it is with'ed or if it is the

            --  parent spec of the main unit (case of main unit is a child

            --  unit). The latter with is not needed for semantic purposes,

            --  but is required by the binder for elaboration purposes.

            --  For preproc. data and def. files, there is no Unit_Name,

            --  check for that first.

            if Unit_Name (J) /= No_Name

              and then (With_Flags (J) or else Unit_Name (J) = Pname)

            then

               Num_Withs := Num_Withs + 1;

               With_Table (Num_Withs) := J;

            end if;

         end loop;

         --  Sort and output the table

         Sort (With_Table (1 .. Num_Withs));

         for J in 1 .. Num_Withs loop

            Unum   := With_Table (J);

            Cunit  := Units.Table (Unum).Cunit;

            Cunite := Units.Table (Unum).Cunit_Entity;

            Uname  := Units.Table (Unum).Unit_Name;

            Fname  := Units.Table (Unum).Unit_File_Name;

            Write_Info_Initiate ('W');

            Write_Info_Char (' ');

            Write_Info_Name (Uname);

            --  Now we need to figure out the names of the files that contain

            --  the with'ed unit. These will usually be the files for the body,

            --  except in the case of a package that has no body.

            if (Nkind (Unit (Cunit)) not in N_Generic_Declaration

                  and then

                Nkind (Unit (Cunit)) not in N_Generic_Renaming_Declaration)

              or else Generic_Separately_Compiled (Cunite)

            then

               Write_Info_Tab (25);

               if Is_Spec_Name (Uname) then

                  Body_Fname :=

                    Get_File_Name

                      (Get_Body_Name (Uname),

                       Subunit => False, May_Fail => True);

                  Body_Index :=

                    Get_Unit_Index

                      (Get_Body_Name (Uname));

                  if Body_Fname = No_File then

                     Body_Fname := Get_File_Name (Uname, Subunit => False);

                     Body_Index := Get_Unit_Index (Uname);

                  end if;

               else

                  Body_Fname := Get_File_Name (Uname, Subunit => False);

                  Body_Index := Get_Unit_Index (Uname);

               end if;

               --  A package is considered to have a body if it requires

               --  a body or if a body is present in Ada 83 mode.

               if Body_Required (Cunit)

                 or else (Ada_Version = Ada_83

                           and then Full_Source_Name (Body_Fname) /= No_File)

               then

                  --  Ensure that on platforms where the file names are not

                  --  case sensitive, the recorded file name is in lower case.

                  if not File_Names_Case_Sensitive then

                     Get_Name_String (Body_Fname);

                     To_Lower (Name_Buffer (1 .. Name_Len));

                     Body_Fname := Name_Find;

                  end if;

                  Write_Info_Name (Body_Fname);

                  Write_Info_Tab (49);

                  Write_Info_Name

                    (Lib_File_Name (Body_Fname, Body_Index));

               else

                  --  Ensure that on platforms where the file names are not

                  --  case sensitive, the recorded file name is in lower case.

                  if not File_Names_Case_Sensitive then

                     Get_Name_String (Fname);

                     To_Lower (Name_Buffer (1 .. Name_Len));

                     Fname := Name_Find;

                  end if;

                  Write_Info_Name (Fname);

                  Write_Info_Tab (49);

                  Write_Info_Name

                    (Lib_File_Name (Fname, Munit_Index (Unum)));

               end if;

               if Elab_Flags (Unum) then

                  Write_Info_Str ("  E");

               end if;

               if Elab_All_Flags (Unum) then

                  Write_Info_Str ("  EA");

               end if;

               if Elab_Des_Flags (Unum) then

                  Write_Info_Str ("  ED");

               end if;

               if Elab_All_Des_Flags (Unum) then

                  Write_Info_Str ("  AD");

               end if;

            end if;

            Write_Info_EOL;

         end loop;

      end Write_With_Lines;

   --  Start of processing for Write_ALI

   begin

      --  We never write an ALI file if the original operating mode was

      --  syntax-only (-gnats switch used in compiler invocation line)

      if Original_Operating_Mode = Check_Syntax then

         return;

      end if;

      --  Build sorted source dependency table. We do this right away,

      --  because it is referenced by Up_To_Date_ALI_File_Exists.

      for Unum in Units.First .. Last_Unit loop

         if Cunit_Entity (Unum) = Empty

           or else not From_With_Type (Cunit_Entity (Unum))