From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001 From: upstream source tree Date: Sun, 15 Mar 2015 20:14:05 -0400 Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream tarball. downloading a git-generated archive based on the 'upstream' tag should provide you with a source tree that is binary identical to the one extracted from the above tarball. if you have obtained the source via the command 'git clone', however, do note that line-endings of files in your working directory might differ from line-endings of the respective files in the upstream repository. --- gcc/ada/lib-writ.adb | 1328 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 1328 insertions(+) create mode 100644 gcc/ada/lib-writ.adb (limited to 'gcc/ada/lib-writ.adb') diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb new file mode 100644 index 000000000..d1e442a32 --- /dev/null +++ b/gcc/ada/lib-writ.adb @@ -0,0 +1,1328 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- L I B . W R I T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2010, 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 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 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 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 Nlists; use Nlists; +with Gnatvsn; use Gnatvsn; +with Opt; use Opt; +with Osint; use Osint; +with Osint.C; use Osint.C; +with Par; +with Par_SCO; use Par_SCO; +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.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_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_Allocator => False, + Has_RACW => False, + Is_Compiler_Unit => False, + Ident_String => Empty, + Loading => False, + Main_Priority => -1, + Main_CPU => -1, + Munit_Index => 0, + Serial_Number => 0, + Version => 0, + Error_Location => No_Location, + OA_Setting => 'O'); + 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_Allocator => False, + Has_RACW => False, + Is_Compiler_Unit => False, + Ident_String => Empty, + Loading => False, + Main_Priority => -1, + Main_CPU => -1, + Munit_Index => 0, + Serial_Number => 0, + Version => 0, + Error_Location => No_Location, + OA_Setting => 'O'); + + -- 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 + + flag_compare_debug : Int; + pragma Import (C, flag_compare_debug); + -- Import from toplev.c + + ----------------------- + -- 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, but must be recorded as components of the + -- partition, in case there is no regular with_clause for + -- the unit anywhere else. + + if Nkind (Item) = N_With_Clause then + Unum := Get_Cunit_Unit_Number (Library_Unit (Item)); + With_Flags (Unum) := True; + + if not Limited_Present (Item) then + 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; + + else + Set_From_With_Type (Cunit_Entity (Unum)); + 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)); + + -- 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)) + 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; + + -- 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 + 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 set 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 + 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 + Write_Info_Str (" NE"); + end if; + + Write_Info_Str (" O"); + Write_Info_Char (OA_Setting (Unit_Num)); + + 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 or else Invalid_Value_Used 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 : Linker_Option_Entry renames Linker_Option_Lines.Table (J); + begin + if S.Unit = Unit_Num then + Write_Info_Initiate ('L'); + Write_Info_Char (' '); + Write_Info_Slit (S.Option); + Write_Info_EOL; + end if; + end; + end loop; + + -- Output notes + + for J in 1 .. Notes.Last loop + declare + N : constant Node_Id := Notes.Table (J).Pragma_Node; + L : constant Source_Ptr := Sloc (N); + U : constant Unit_Number_Type := Notes.Table (J).Unit; + C : Character; + + begin + if U = Unit_Num then + Write_Info_Initiate ('N'); + Write_Info_Char (' '); + + case Chars (Pragma_Identifier (N)) is + when Name_Annotate => + C := 'A'; + when Name_Comment => + C := 'C'; + when Name_Ident => + C := 'I'; + when Name_Title => + C := 'T'; + when Name_Subtitle => + C := 'S'; + when others => + raise Program_Error; + end case; + + Write_Info_Char (C); + Write_Info_Int (Int (Get_Logical_Line_Number (L))); + Write_Info_Char (':'); + Write_Info_Int (Int (Get_Column_Number (L))); + + declare + A : Node_Id; + + begin + A := First (Pragma_Argument_Associations (N)); + while Present (A) loop + Write_Info_Char (' '); + + if Chars (A) /= No_Name then + Write_Info_Name (Chars (A)); + Write_Info_Char (':'); + end if; + + declare + Expr : constant Node_Id := Expression (A); + + begin + if Nkind (Expr) = N_Identifier then + Write_Info_Name (Chars (Expr)); + + elsif Nkind (Expr) = N_Integer_Literal + and then Is_Static_Expression (Expr) + then + Write_Info_Uint (Intval (Expr)); + + elsif Nkind (Expr) = N_String_Literal + and then Is_Static_Expression (Expr) + then + Write_Info_Slit (Strval (Expr)); + + else + Write_Info_Str (""); + end if; + end; + + Next (A); + end loop; + end; + + 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; + 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 unnecessarily 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_Unit_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; + Uname := Units.Table (Unum).Unit_Name; + Fname := Units.Table (Unum).Unit_File_Name; + + if Ekind (Cunit_Entity (Unum)) = E_Package + and then From_With_Type (Cunit_Entity (Unum)) + then + Write_Info_Initiate ('Y'); + else + Write_Info_Initiate ('W'); + end if; + + 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. 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, 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 + Write_With_File_Names (Body_Fname, Body_Index); + else + Write_With_File_Names (Fname, Munit_Index (Unum)); + end if; + + if Ekind (Cunit_Entity (Unum)) = E_Package + and then From_With_Type (Cunit_Entity (Unum)) + then + null; + else + 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; + 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 + or flag_compare_debug /= 0 + 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)) + then + Num_Sdep := Num_Sdep + 1; + Sdep_Table (Num_Sdep) := Unum; + end if; + end loop; + + -- Sort the table so that the D lines are in order + + Lib.Sort (Sdep_Table (1 .. Num_Sdep)); + + -- If we are not generating code, and there is an up to date ALI file + -- file accessible, read it, and acquire the compilation arguments from + -- this file. + + if Operating_Mode /= Generate_Code then + if Up_To_Date_ALI_File_Exists then + Update_Tables_From_ALI_File; + return; + end if; + end if; + + -- Otherwise acquire compilation arguments and prepare to write + -- out a new ali file. + + Create_Output_Library_Info; + + -- Output version line + + Write_Info_Initiate ('V'); + Write_Info_Str (" """); + Write_Info_Str (Verbose_Library_Version); + Write_Info_Char ('"'); + + Write_Info_EOL; + + -- Output main program line if this is acceptable main program + + Output_Main_Program_Line : declare + U : Node_Id := Unit (Units.Table (Main_Unit).Cunit); + S : Node_Id; + + procedure M_Parameters; + -- Output parameters for main program line + + ------------------ + -- M_Parameters -- + ------------------ + + procedure M_Parameters is + begin + if Main_Priority (Main_Unit) /= Default_Main_Priority then + Write_Info_Char (' '); + Write_Info_Nat (Main_Priority (Main_Unit)); + end if; + + if Opt.Time_Slice_Set then + Write_Info_Str (" T="); + Write_Info_Nat (Opt.Time_Slice_Value); + end if; + + if Has_Allocator (Main_Unit) then + Write_Info_Str (" AB"); + end if; + + if Main_CPU (Main_Unit) /= Default_Main_CPU then + Write_Info_Str (" C="); + Write_Info_Nat (Main_CPU (Main_Unit)); + end if; + + Write_Info_Str (" W="); + Write_Info_Char + (WC_Encoding_Letters (Wide_Character_Encoding_Method)); + + Write_Info_EOL; + end M_Parameters; + + -- Start of processing for Output_Main_Program_Line + + begin + if Nkind (U) = N_Subprogram_Body + 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 + -- related instance of the wrapper package. We retrieve the + -- subprogram declaration of the desired entity. + + if Nkind (U) = N_Package_Body then + U := Parent (Parent ( + Alias (Related_Instance (Defining_Unit_Name + (Specification (Unit (Library_Unit (Parent (U))))))))); + end if; + + S := Specification (U); + + if No (Parameter_Specifications (S)) then + if Nkind (S) = N_Procedure_Specification then + Write_Info_Initiate ('M'); + Write_Info_Str (" P"); + M_Parameters; + + else + declare + Nam : Node_Id := Defining_Unit_Name (S); + + begin + -- 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; + + if Is_Integer_Type (Etype (Nam)) then + Write_Info_Initiate ('M'); + Write_Info_Str (" F"); + M_Parameters; + end if; + end; + end if; + end if; + end if; + end Output_Main_Program_Line; + + -- Write command argument ('A') lines + + for A in 1 .. Compilation_Switches.Last loop + Write_Info_Initiate ('A'); + Write_Info_Char (' '); + Write_Info_Str (Compilation_Switches.Table (A).all); + Write_Info_Terminate; + end loop; + + -- Output parameters ('P') line + + Write_Info_Initiate ('P'); + + if Compilation_Errors then + 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"); + + if Opt.Float_Format = 'I' then + Write_Info_Char ('I'); + + elsif Opt.Float_Format_Long = 'D' then + Write_Info_Char ('D'); + + else + Write_Info_Char ('G'); + end if; + end if; + + if Tasking_Used + and then not Is_Predefined_File_Name (Unit_File_Name (Main_Unit)) + then + if Locking_Policy /= ' ' then + Write_Info_Str (" L"); + Write_Info_Char (Locking_Policy); + end if; + + if Queuing_Policy /= ' ' then + Write_Info_Str (" Q"); + Write_Info_Char (Queuing_Policy); + end if; + + if Task_Dispatching_Policy /= ' ' then + Write_Info_Str (" T"); + Write_Info_Char (Task_Dispatching_Policy); + Write_Info_Char (' '); + end if; + end if; + + if not Object then + Write_Info_Str (" NO"); + end if; + + if No_Run_Time_Mode then + Write_Info_Str (" NR"); + end if; + + if Normalize_Scalars then + Write_Info_Str (" NS"); + 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 = Back_End_Exceptions then + Write_Info_Str (" ZX"); + end if; + + Write_Info_EOL; + + -- Before outputting the restrictions line, update the setting of + -- the No_Elaboration_Code flag. Violations of this restriction + -- cannot be detected until after the backend has been called since + -- it is the backend that sets this flag. We have to check all units + -- for which we have generated code + + for Unit in Units.First .. Last_Unit loop + if Units.Table (Unit).Generate_Code + or else Unit = Main_Unit + then + if not Has_No_Elaboration_Code (Cunit (Unit)) then + Main_Restrictions.Violated (No_Elaboration_Code) := True; + end if; + end if; + end loop; + + -- Output first restrictions line + + Write_Info_Initiate ('R'); + Write_Info_Char (' '); + + -- 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 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_Initiate ('I'); + Write_Info_Char (' '); + Write_Info_Nat (Interrupt_States.Table (J).Interrupt_Number); + Write_Info_Char (' '); + Write_Info_Char (Interrupt_States.Table (J).Interrupt_State); + Write_Info_Char (' '); + Write_Info_Nat + (Nat (Get_Logical_Line_Number + (Interrupt_States.Table (J).Pragma_Loc))); + 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. + + for Unit in Units.First .. Last_Unit loop + if Units.Table (Unit).Generate_Code + or else Unit = Main_Unit + then + Write_Info_EOL; -- blank line + Write_Unit_Information (Unit); + end if; + end loop; + + Write_Info_EOL; -- blank line + + -- Output external version reference lines + + for J in 1 .. Version_Ref.Last loop + Write_Info_Initiate ('E'); + Write_Info_Char (' '); + + for K in 1 .. String_Length (Version_Ref.Table (J)) loop + Write_Info_Char_Code (Get_String_Char (Version_Ref.Table (J), K)); + end loop; + + Write_Info_EOL; + end loop; + + -- Prepare to output the source dependency lines + + declare + Unum : Unit_Number_Type; + -- Number of unit being output + + 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); + Units.Table (Unum).Dependency_Num := J; + Sind := Units.Table (Unum).Source_Index; + + Write_Info_Initiate ('D'); + Write_Info_Char (' '); + + -- Normal case of a unit entry with a source index + + 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_Str (Get_Hex_String (Source_Checksum (Sind))); + + -- If subunit, add unit name, omitting the %b at the end + + if Present (Cunit (Unum)) + and then Nkind (Unit (Cunit (Unum))) = N_Subunit + then + Get_Decoded_Name_String (Unit_Name (Unum)); + Write_Info_Char (' '); + Write_Info_Str (Name_Buffer (1 .. Name_Len - 2)); + end if; + + -- If Source_Reference pragma used output information + + if Num_SRef_Pragmas (Sind) > 0 then + Write_Info_Char (' '); + + if Num_SRef_Pragmas (Sind) = 1 then + Write_Info_Nat (Int (First_Mapped_Line (Sind))); + else + Write_Info_Nat (0); + end if; + + Write_Info_Char (':'); + Write_Info_Name (Reference_Name (Sind)); + end if; + + -- 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)); + Write_Info_Tab (25); + Write_Info_Str (String (Dummy_Time_Stamp)); + Write_Info_Char (' '); + Write_Info_Str (Get_Hex_String (0)); + end if; + + Write_Info_EOL; + end loop; + end; + + -- Output cross-references + + Output_References; + + -- Output SCO information if present + + if Generate_SCO then + SCO_Output; + end if; + + -- Output final blank line and we are done. This final blank line is + -- probably junk, but we don't feel like making an incompatible change! + + 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; -- cgit v1.2.3