-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2003 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- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
+-- ware Foundation; either version 3, 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. --
+-- Public License distributed with GNAT; see file COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
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.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 Snames; use Snames;
with Stringt; use Stringt;
with Tbuild; use Tbuild;
with Uname; use Uname;
-with System.WCh_Con; use System.WCh_Con;
+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 --
----------------------------------
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,
- Dependent_Unit => True,
- Dynamic_Elab => False,
- Fatal_Error => False,
- Generate_Code => False,
- Has_RACW => False,
- Ident_String => Empty,
- Loading => False,
- Main_Priority => -1,
- Serial_Number => 0,
- Version => 0,
- Error_Location => No_Location);
+ (Unit_File_Name => File_Name (S),
+ Unit_Name => No_Unit_Name,
+ Expected_Unit => No_Unit_Name,
+ Source_Index => S,
+ Cunit => Empty,
+ Cunit_Entity => Empty,
+ Dependency_Num => 0,
+ Dynamic_Elab => False,
+ Fatal_Error => False,
+ Generate_Code => False,
+ Has_RACW => False,
+ Is_Compiler_Unit => 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;
------------------------------
System_Fname : File_Name_Type;
-- File name for system spec if needed for dummy entry
- Save_Style : constant Boolean := Style_Check;
-
begin
-- Nothing to do if we already compiled System
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,
- Dependent_Unit => True,
- Dynamic_Elab => False,
- Fatal_Error => False,
- Generate_Code => False,
- Has_RACW => False,
- Ident_String => Empty,
- Loading => False,
- Main_Priority => -1,
- Serial_Number => 0,
- Version => 0,
- Error_Location => No_Location);
+ 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,
+ Is_Compiler_Unit => 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.
- Style_Check := False;
- Initialize_Scanner (Units.Last, System_Source_File_Index);
- Discard_List (Par (Configuration_Pragmas => False));
- Style_Check := Save_Style;
+ 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;
---------------
-- 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));
Item := First (Context_Items (Cunit));
while Present (Item) loop
- -- Ada0Y (AI-50217): limited with_clauses do not create
+ -- 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))
+ and then not (Limited_Present (Item))
then
Unum := Get_Cunit_Unit_Number (Library_Unit (Item));
With_Flags (Unum) := True;
Elab_All_Flags (Unum) := True;
end if;
- if Elaborate_All_Desirable (Cunit_Entity (Unum)) then
+ 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;
Write_Info_Tab (49);
Write_Info_Str (Version_Get (Unit_Num));
+ -- Add BD parameter if Elaborate_Body pragma desirable
+
+ if Ekind (Uent) = E_Package
+ and then Elaborate_Body_Desirable (Uent)
+ then
+ Write_Info_Str (" BD");
+ end if;
+
+ -- Add BN parameter if body needed for SAL
+
if (Is_Subprogram (Uent)
or else Ekind (Uent) = E_Package
or else Is_Generic_Unit (Uent))
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.
+ -- Set the Elaborate_Body indication if either an explicit pragma
+ -- was present, or if this is an instantiation.
if Has_Pragma_Elaborate_Body (Uent)
or else (Ukind = N_Package_Declaration
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:
+ -- is present, which must be set to true during elaboration.
+ -- We generate the indication if the following condition is met:
-- If this is a spec ...
(Declaration_Node
(Body_Entity (Uent))))))
then
- Write_Info_Str (" EE");
+ if Convention (Uent) = Convention_CIL then
+
+ -- Special case for generic CIL packages which never have
+ -- elaboration code
+
+ Write_Info_Str (" NE");
+
+ else
+ Write_Info_Str (" EE");
+ end if;
end if;
if Has_No_Elaboration_Code (Unode) then
-- 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;
+ 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);
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;
+
+ procedure Write_With_File_Names
+ (Nam : in out File_Name_Type;
+ Idx : Nat);
+ -- Write source file name Nam and ALI file name for unit index Idx.
+ -- Possibly change Nam to lowercase (generating a new file name).
+
+ --------------------------
+ -- Write_With_File_Name --
+ --------------------------
+
+ procedure Write_With_File_Names
+ (Nam : in out File_Name_Type;
+ Idx : Nat)
+ is
+ begin
+ if not File_Names_Case_Sensitive then
+ Get_Name_String (Nam);
+ To_Lower (Name_Buffer (1 .. Name_Len));
+ Nam := Name_Find;
+ end if;
+
+ Write_Info_Name (Nam);
+ Write_Info_Tab (49);
+ Write_Info_Name (Lib_File_Name (Nam, Idx));
+ end Write_With_File_Names;
+
+ -- Start of processing for Write_With_Lines
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.
+ -- it unnecessarily withs the parent.
for J in Units.First + 1 .. Last_Unit loop
-- For preproc. data and def. files, there is no Unit_Name,
-- check for that first.
- if Unit_Name (J) /= No_Name
+ if Unit_Name (J) /= No_Unit_Name
and then (With_Flags (J) or else Unit_Name (J) = Pname)
- and then Units.Table (J).Dependent_Unit
then
Num_Withs := Num_Withs + 1;
With_Table (Num_Withs) := J;
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;
-- 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)
+ -- except in the case of a package that has no body. Note that we
+ -- have a specific exemption here for predefined library generics
+ -- (see comments for Generic_May_Lack_ALI). We do not generate
+ -- dependency upon the ALI file for such units. Older compilers
+ -- used to not support generating code (and ALI) for generics, and
+ -- we want to avoid having different processing (namely, different
+ -- lists of files to be compiled) for different stages of the
+ -- bootstrap.
+
+ if not ((Nkind (Unit (Cunit)) in N_Generic_Declaration
+ or else
+ Nkind (Unit (Cunit)) in N_Generic_Renaming_Declaration)
+ and then Generic_May_Lack_ALI (Fname))
then
Write_Info_Tab (25);
if Is_Spec_Name (Uname) then
Body_Fname :=
- Get_File_Name (Get_Body_Name (Uname), Subunit => False);
+ 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_83
+ or else (Ada_Version = Ada_83
and then Full_Source_Name (Body_Fname) /= No_File)
then
- Write_Info_Name (Body_Fname);
- Write_Info_Tab (49);
- Write_Info_Name (Lib_File_Name (Body_Fname));
+ Write_With_File_Names (Body_Fname, Body_Index);
else
- Write_Info_Name (Fname);
- Write_Info_Tab (49);
- Write_Info_Name (Lib_File_Name (Fname));
+ Write_With_File_Names (Fname, Munit_Index (Unum));
end if;
if Elab_Flags (Unum) then
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 Writ_ALI
+ -- Start of processing for Write_ALI
begin
-- We never write an ALI file if the original operating mode was
Write_Info_Initiate ('V');
Write_Info_Str (" """);
- Write_Info_Str (Library_Version);
+ Write_Info_Str (Verbose_Library_Version);
Write_Info_Char ('"');
Write_Info_EOL;
begin
if Nkind (U) = N_Subprogram_Body
- or else (Nkind (U) = N_Package_Body
- and then
- (Nkind (Original_Node (U)) = N_Function_Instantiation
- or else
- Nkind (Original_Node (U)) =
- N_Procedure_Instantiation))
+ or else
+ (Nkind (U) = N_Package_Body
+ and then
+ Nkind (Original_Node (U)) in N_Subprogram_Instantiation)
then
-- If the unit is a subprogram instance, the entity for the
-- subprogram is the alias of the visible entity, which is the
S := Specification (U);
- if not Present (Parameter_Specifications (S)) then
+ if No (Parameter_Specifications (S)) then
if Nkind (S) = N_Procedure_Specification then
Write_Info_Initiate ('M');
Write_Info_Str (" P");
Nam : Node_Id := Defining_Unit_Name (S);
begin
- -- If it is a child unit, get its simple name.
+ -- If it is a child unit, get its simple name
if Nkind (Nam) = N_Defining_Program_Unit_Name then
Nam := Defining_Identifier (Nam);
end if;
end Output_Main_Program_Line;
- -- Write command argmument ('A') lines
+ -- Write command argument ('A') lines
for A in 1 .. Compilation_Switches.Last loop
Write_Info_Initiate ('A');
Write_Info_Str (" CE");
end if;
+ if Opt.Detect_Blocking then
+ Write_Info_Str (" DB");
+ end if;
+
if Opt.Float_Format /= ' ' then
Write_Info_Str (" F");
Write_Info_Str (" NS");
end if;
+ if Optimize_Alignment /= 'O' then
+ Write_Info_Str (" O");
+ Write_Info_Char (Optimize_Alignment);
+ end if;
+
+ if Sec_Stack_Used then
+ Write_Info_Str (" SS");
+ end if;
+
if Unreserve_All_Interrupts then
Write_Info_Str (" UA");
end if;
- if Exception_Mechanism /= Front_End_Setjmp_Longjmp_Exceptions then
- if Unit_Exception_Table_Present then
- Write_Info_Str (" UX");
- end if;
-
+ if Exception_Mechanism = Back_End_Exceptions then
Write_Info_Str (" ZX");
end if;
or else Unit = Main_Unit
then
if not Has_No_Elaboration_Code (Cunit (Unit)) then
- Violations (No_ELaboration_Code) := True;
+ Main_Restrictions.Violated (No_Elaboration_Code) := True;
end if;
end if;
end loop;
- -- Output restrictions line
+ -- Output first restrictions line
Write_Info_Initiate ('R');
Write_Info_Char (' ');
- for J in All_Restrictions loop
- if Main_Restrictions (J) then
+ -- First the information for the boolean restrictions
+
+ for R in All_Boolean_Restrictions loop
+ if Main_Restrictions.Set (R)
+ and then not Restriction_Warnings (R)
+ then
Write_Info_Char ('r');
- elsif Violations (J) then
+ elsif Main_Restrictions.Violated (R) then
Write_Info_Char ('v');
else
Write_Info_Char ('n');
end if;
end loop;
+ -- And now the information for the parameter restrictions
+
+ for RP in All_Parameter_Restrictions loop
+ if Main_Restrictions.Set (RP)
+ and then not Restriction_Warnings (RP)
+ then
+ Write_Info_Char ('r');
+ Write_Info_Nat (Nat (Main_Restrictions.Value (RP)));
+ else
+ Write_Info_Char ('n');
+ end if;
+
+ if not Main_Restrictions.Violated (RP)
+ or else RP not in Checked_Parameter_Restrictions
+ then
+ Write_Info_Char ('n');
+ else
+ Write_Info_Char ('v');
+ Write_Info_Nat (Nat (Main_Restrictions.Count (RP)));
+
+ if Main_Restrictions.Unknown (RP) then
+ Write_Info_Char ('+');
+ end if;
+ end if;
+ end loop;
+
Write_Info_EOL;
+ -- Output R lines for No_Dependence entries
+
+ for J in No_Dependence.First .. No_Dependence.Last loop
+ if In_Extended_Main_Source_Unit (No_Dependence.Table (J).Unit)
+ and then not No_Dependence.Table (J).Warn
+ then
+ Write_Info_Initiate ('R');
+ Write_Info_Char (' ');
+ Write_Unit_Name (No_Dependence.Table (J).Unit);
+ Write_Info_EOL;
+ end if;
+ end loop;
+
-- Output interrupt state lines
for J in Interrupt_States.First .. Interrupt_States.Last loop
Write_Info_EOL;
end loop;
+ -- Output priority specific dispatching lines
+
+ for J in Specific_Dispatching.First .. Specific_Dispatching.Last loop
+ Write_Info_Initiate ('S');
+ Write_Info_Char (' ');
+ Write_Info_Char (Specific_Dispatching.Table (J).Dispatching_Policy);
+ Write_Info_Char (' ');
+ Write_Info_Nat (Specific_Dispatching.Table (J).First_Priority);
+ Write_Info_Char (' ');
+ Write_Info_Nat (Specific_Dispatching.Table (J).Last_Priority);
+ Write_Info_Char (' ');
+ Write_Info_Nat
+ (Nat (Get_Logical_Line_Number
+ (Specific_Dispatching.Table (J).Pragma_Loc)));
+ Write_Info_EOL;
+ end loop;
+
-- Loop through file table to output information for all units for which
-- we have generated code, as marked by the Generate_Code flag.
Sind : Source_File_Index;
-- Index of corresponding source file
+ Fname : File_Name_Type;
+
begin
for J in 1 .. Num_Sdep loop
Unum := Sdep_Table (J);
Write_Info_Initiate ('D');
Write_Info_Char (' ');
- -- Normal case of a dependent unit entry with a source index
+ -- Normal case of a unit entry with a source index
- if Sind /= No_Source_File
- and then Units.Table (Unum).Dependent_Unit
- then
- Write_Info_Name (File_Name (Sind));
+ if Sind /= No_Source_File then
+ Fname := File_Name (Sind);
+
+ -- 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 (25);
Write_Info_Str (String (Time_Stamp (Sind)));
Write_Info_Char (' ');
Write_Info_Name (Reference_Name (Sind));
end if;
- -- Case where there is no source index (happens for missing files)
- -- Also come here for non-dependent units.
+ -- Case where there is no source index (happens for missing
+ -- files). In this case we write a dummy time stamp.
else
Write_Info_Name (Unit_File_Name (Unum));
Output_References;
Write_Info_Terminate;
Close_Output_Library_Info;
-
end Write_ALI;
+ ---------------------
+ -- Write_Unit_Name --
+ ---------------------
+
+ procedure Write_Unit_Name (N : Node_Id) is
+ begin
+ if Nkind (N) = N_Identifier then
+ Write_Info_Name (Chars (N));
+
+ else
+ pragma Assert (Nkind (N) = N_Selected_Component);
+ Write_Unit_Name (Prefix (N));
+ Write_Info_Char ('.');
+ Write_Unit_Name (Selector_Name (N));
+ end if;
+ end Write_Unit_Name;
+
end Lib.Writ;
projects / platform / upstream / gcc.git / blobdiff