------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- B L D -- -- -- -- B o d y -- -- -- -- Copyright (C) 2002-2004 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. -- -- -- ------------------------------------------------------------------------------ -- This package is still a work in progress. with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Strings.Fixed; use Ada.Strings.Fixed; with Bld.IO; with Csets; with GNAT.HTable; with GNAT.Case_Util; use GNAT.Case_Util; with GNAT.Command_Line; use GNAT.Command_Line; with GNAT.Directory_Operations; use GNAT.Directory_Operations; with GNAT.OS_Lib; use GNAT.OS_Lib; with Erroutc; use Erroutc; with Err_Vars; use Err_Vars; with Gnatvsn; with Namet; use Namet; with Opt; use Opt; with Output; use Output; with Prj; use Prj; with Prj.Com; use Prj.Com; with Prj.Err; use Prj.Err; with Prj.Part; with Prj.Tree; use Prj.Tree; with Snames; with Table; with Types; use Types; package body Bld is function "=" (Left, Right : IO.Position) return Boolean renames IO."="; MAKE_ROOT : constant String := "MAKE_ROOT"; Process_All_Project_Files : Boolean := True; -- Set to False by command line switch -R Copyright_Displayed : Boolean := False; -- To avoid displaying the Copyright line several times Usage_Displayed : Boolean := False; -- To avoid displaying the usage several times type Expression_Kind_Type is (Undecided, Static_String, Other); Expression_Kind : Expression_Kind_Type := Undecided; -- After procedure Expression has been called, this global variable -- indicates if the expression is a static string or not. -- If it is a static string, then Expression_Value (1 .. Expression_Last) -- is the static value of the expression. Expression_Value : String_Access := new String (1 .. 10); Expression_Last : Natural := 0; -- The following variables indicates if the suffixes and the languages -- are statically specified and, if they are, their values. C_Suffix : String_Access := new String (1 .. 10); C_Suffix_Last : Natural := 0; C_Suffix_Static : Boolean := True; Cxx_Suffix : String_Access := new String (1 .. 10); Cxx_Suffix_Last : Natural := 0; Cxx_Suffix_Static : Boolean := True; Ada_Spec_Suffix : String_Access := new String (1 .. 10); Ada_Spec_Suffix_Last : Natural := 0; Ada_Spec_Suffix_Static : Boolean := True; Ada_Body_Suffix : String_Access := new String (1 .. 10); Ada_Body_Suffix_Last : Natural := 0; Ada_Body_Suffix_Static : Boolean := True; Languages : String_Access := new String (1 .. 50); Languages_Last : Natural := 0; Languages_Static : Boolean := True; type Source_Kind_Type is (Unknown, Ada_Spec, Ada_Body, C, Cxx, None); -- Used when post-processing Compiler'Switches to indicate the language -- of a source. -- The following variables are used to controlled what attributes -- Default_Switches and Switches are allowed in expressions. Default_Switches_Package : Name_Id := No_Name; Default_Switches_Language : Name_Id := No_Name; Switches_Package : Name_Id := No_Name; Switches_Language : Source_Kind_Type := Unknown; -- Other attribute references are only allowed in attribute declarations -- of the same package and of the same name. -- Other_Attribute is True only during attribute declarations other than -- Switches or Default_Switches. Other_Attribute : Boolean := False; Other_Attribute_Package : Name_Id := No_Name; Other_Attribute_Name : Name_Id := No_Name; type Declaration_Type is (False, May_Be, True); Source_Files_Declaration : Declaration_Type := False; Source_List_File_Declaration : Declaration_Type := False; -- Names that are not in Snames Name_Ide : Name_Id := No_Name; Name_Compiler_Command : Name_Id := No_Name; Name_Main_Language : Name_Id := No_Name; Name_C_Plus_Plus : Name_Id := No_Name; package Processed_Projects is new GNAT.HTable.Simple_HTable (Header_Num => Header_Num, Element => Project_Node_Id, No_Element => Empty_Node, Key => Name_Id, Hash => Hash, Equal => "="); -- This hash table contains all processed projects. -- It is used to avoid processing the same project file several times. package Externals is new GNAT.HTable.Simple_HTable (Header_Num => Header_Num, Element => Natural, No_Element => 0, Key => Project_Node_Id, Hash => Hash, Equal => "="); -- This hash table is used to store all the external references. -- For each project file, the tree is first traversed and all -- external references are put in variables. Each of these variables -- are identified by a number, so that the can be referred to -- later during the second traversal of the tree. package Variable_Names is new Table.Table (Table_Component_Type => Name_Id, Table_Index_Type => Natural, Table_Low_Bound => 1, Table_Initial => 10, Table_Increment => 10, Table_Name => "Bld.Variable_Names"); -- This table stores all the variables declared in a package. -- It is used to distinguish project level and package level -- variables identified by simple names. -- This table is reset for each package. package Switches is new Table.Table (Table_Component_Type => Name_Id, Table_Index_Type => Natural, Table_Low_Bound => 1, Table_Initial => 10, Table_Increment => 10, Table_Name => "Bld.Switches"); -- This table stores all the indexs of associative array attribute -- Compiler'Switches specified in a project file. It is reset for -- each project file. At the end of processing of a project file -- this table is traversed to output targets for those files -- that may be C or C++ source files. Last_External : Natural := 0; -- For each external reference, this variable in incremented by 1, -- and a Makefile variable __EXTERNAL__ is -- declared. See procedure Process_Externals. Last_Case_Construction : Natural := 0; -- For each case construction, this variable is incremented by 1, -- and a Makefile variable __CASE__ is -- declared. See procedure Process_Declarative_Items. Saved_Suffix : constant String := ".saved"; -- Prefix to be added to the name of reserved variables (see below) when -- used in external references. -- A number of environment variables, whose names are used in the -- Makefiles are saved at the beginning of the main Makefile. -- Each reference to any such environment variable is replaced -- in the Makefiles with the name of the saved variable. Ada_Body_String : aliased String := "ADA_BODY"; Ada_Flags_String : aliased String := "ADA_FLAGS"; Ada_Mains_String : aliased String := "ADA_MAINS"; Ada_Sources_String : aliased String := "ADA_SOURCES"; Ada_Spec_String : aliased String := "ADA_SPEC"; Ar_Cmd_String : aliased String := "AR_CMD"; Ar_Ext_String : aliased String := "AR_EXT"; Base_Dir_String : aliased String := "BASE_DIR"; Cc_String : aliased String := "CC"; C_Ext_String : aliased String := "C_EXT"; Cflags_String : aliased String := "CFLAGS"; Cxx_String : aliased String := "CXX"; Cxx_Ext_String : aliased String := "CXX_EXT"; Cxxflags_String : aliased String := "CXXFLAGS"; Deps_Projects_String : aliased String := "DEPS_PROJECT"; Exec_String : aliased String := "EXEC"; Exec_Dir_String : aliased String := "EXEC_DIR"; Fldflags_String : aliased String := "FLDFLAGS"; Gnatmake_String : aliased String := "GNATMAKE"; Languages_String : aliased String := "LANGUAGES"; Ld_Flags_String : aliased String := "LD_FLAGS"; Libs_String : aliased String := "LIBS"; Main_String : aliased String := "MAIN"; Obj_Ext_String : aliased String := "OBJ_EXT"; Obj_Dir_String : aliased String := "OBJ_DIR"; Project_File_String : aliased String := "PROJECT_FILE"; Src_Dirs_String : aliased String := "SRC_DIRS"; type Reserved_Variable_Array is array (Positive range <>) of String_Access; Reserved_Variables : constant Reserved_Variable_Array := (Ada_Body_String 'Access, Ada_Flags_String 'Access, Ada_Mains_String 'Access, Ada_Sources_String 'Access, Ada_Spec_String 'Access, Ar_Cmd_String 'Access, Ar_Ext_String 'Access, Base_Dir_String 'Access, Cc_String 'Access, C_Ext_String 'Access, Cflags_String 'Access, Cxx_String 'Access, Cxx_Ext_String 'Access, Cxxflags_String 'Access, Deps_Projects_String'Access, Exec_String 'Access, Exec_Dir_String 'Access, Fldflags_String 'Access, Gnatmake_String 'Access, Languages_String 'Access, Ld_Flags_String 'Access, Libs_String 'Access, Main_String 'Access, Obj_Ext_String 'Access, Obj_Dir_String 'Access, Project_File_String 'Access, Src_Dirs_String 'Access); Main_Project_File_Name : String_Access; -- The name of the main project file, given as argument. Project_Tree : Project_Node_Id; -- The result of the parsing of the main project file. procedure Add_To_Expression_Value (S : String); procedure Add_To_Expression_Value (S : Name_Id); -- Add a string to variable Expression_Value procedure Display_Copyright; -- Display name of the tool and the copyright function Equal_String (Left, Right : Name_Id) return Boolean; -- Return True if Left and Right are the same string, without considering -- the case. procedure Expression (Project : Project_Node_Id; First_Term : Project_Node_Id; Kind : Variable_Kind; In_Case : Boolean; Reset : Boolean := False); -- Process an expression. -- If In_Case is True, all expressions are not static. procedure New_Line; -- Add a line terminator in the Makefile procedure Process (Project : Project_Node_Id); -- Process the project tree, result of the parsing. procedure Process_Case_Construction (Current_Project : Project_Node_Id; Current_Pkg : Name_Id; Case_Project : Project_Node_Id; Case_Pkg : Name_Id; Name : Name_Id; Node : Project_Node_Id); -- Process a case construction. -- The Makefile declations may be suppressed if no declarative -- items in the case items are to be put in the Makefile. procedure Process_Declarative_Items (Project : Project_Node_Id; Pkg : Name_Id; In_Case : Boolean; Item : Project_Node_Id); -- Process the declarative items for a project, a package -- or a case item. -- If In_Case is True, all expressions are not static procedure Process_Externals (Project : Project_Node_Id); -- Look for all external references in one project file, populate the -- table Externals, and output the necessary declarations, if any. procedure Put (S : String; With_Substitution : Boolean := False); -- Add a string to the Makefile. -- When With_Substitution is True, if the string is one of the reserved -- variables, replace it with the name of the corresponding saved -- variable. procedure Put (S : Name_Id); -- Add a string to the Makefile. procedure Put (P : Positive); -- Add the image of a number to the Makefile, without leading space procedure Put_Attribute (Project : Project_Node_Id; Pkg : Name_Id; Name : Name_Id; Index : Name_Id); -- Put the full name of an attribute in the Makefile procedure Put_Directory_Separator; -- Add a directory separator to the Makefile procedure Put_Include_Project (Included_Project_Path : Name_Id; Included_Project : Project_Node_Id; Including_Project_Name : String); -- Output an include directive for a project procedure Put_Line (S : String); -- Add a string and a line terminator to the Makefile procedure Put_L_Name (N : Name_Id); -- Put a name in lower case in the Makefile procedure Put_M_Name (N : Name_Id); -- Put a name in mixed case in the Makefile procedure Put_U_Name (N : Name_Id); -- Put a name in upper case in the Makefile procedure Special_Put_U_Name (S : Name_Id); -- Put a name in upper case in the Makefile. -- If "C++" change it to "CXX". procedure Put_Variable (Project : Project_Node_Id; Pkg : Name_Id; Name : Name_Id); -- Put the full name of a variable in the Makefile procedure Recursive_Process (Project : Project_Node_Id); -- Process a project file and the project files it depends on iteratively -- without processing twice the same project file. procedure Reset_Suffixes_And_Languages; -- Indicate that all suffixes and languages have the default values function Source_Kind_Of (File_Name : Name_Id) return Source_Kind_Type; -- From a source file name, returns the source kind of the file function Suffix_Of (Static : Boolean; Value : String_Access; Last : Natural; Default : String) return String; -- Returns the current suffix, if it is statically known, or "" -- if it is not statically known. Used on C_Suffix, Cxx_Suffix, -- Ada_Body_Suffix and Ada_Spec_Suffix. procedure Usage; -- Display the usage of gnatbuild ----------------------------- -- Add_To_Expression_Value -- ----------------------------- procedure Add_To_Expression_Value (S : String) is begin -- Check that the buffer is large enough. -- If it is not, double it until it is large enough. while Expression_Last + S'Length > Expression_Value'Last loop declare New_Value : constant String_Access := new String (1 .. 2 * Expression_Value'Last); begin New_Value (1 .. Expression_Last) := Expression_Value (1 .. Expression_Last); Free (Expression_Value); Expression_Value := New_Value; end; end loop; Expression_Value (Expression_Last + 1 .. Expression_Last + S'Length) := S; Expression_Last := Expression_Last + S'Length; end Add_To_Expression_Value; procedure Add_To_Expression_Value (S : Name_Id) is begin Get_Name_String (S); Add_To_Expression_Value (S => Name_Buffer (1 .. Name_Len)); end Add_To_Expression_Value; ----------------------- -- Display_Copyright -- ----------------------- procedure Display_Copyright is begin if not Copyright_Displayed then Copyright_Displayed := True; Write_Str ("GPR2MAKE "); Write_Str (Gnatvsn.Gnat_Version_String); Write_Str (" Copyright 2002-2004 Free Software Foundation, Inc."); Write_Eol; Write_Eol; end if; end Display_Copyright; ------------------ -- Equal_String -- ------------------ function Equal_String (Left, Right : Name_Id) return Boolean is begin Get_Name_String (Left); declare Left_Value : constant String := To_Lower (Name_Buffer (1 .. Name_Len)); begin Get_Name_String (Right); return Left_Value = To_Lower (Name_Buffer (1 .. Name_Len)); end; end Equal_String; ---------------- -- Expression -- ---------------- procedure Expression (Project : Project_Node_Id; First_Term : Project_Node_Id; Kind : Variable_Kind; In_Case : Boolean; Reset : Boolean := False) is Term : Project_Node_Id := First_Term; -- The term in the expression list Current_Term : Project_Node_Id := Empty_Node; -- The current term node id begin if In_Case then Expression_Kind := Other; elsif Reset then Expression_Kind := Undecided; Expression_Last := 0; end if; while Term /= Empty_Node loop Current_Term := Tree.Current_Term (Term); case Kind_Of (Current_Term) is when N_Literal_String => -- If we are in a string list, we precede this literal string -- with a space; it does not matter if the output list -- has a leading space. -- Otherwise we just output the literal string: -- if it is not the first term of the expression, it will -- concatenate with was previously output. if Kind = List then Put (" "); end if; -- If in a static string expression, add to expression value if Expression_Kind = Undecided or else Expression_Kind = Static_String then Expression_Kind := Static_String; if Kind = List then Add_To_Expression_Value (" "); end if; Add_To_Expression_Value (String_Value_Of (Current_Term)); end if; Put (String_Value_Of (Current_Term)); when N_Literal_String_List => -- For string list, we repetedly call Expression with each -- element of the list. declare String_Node : Project_Node_Id := First_Expression_In_List (Current_Term); begin if String_Node = Empty_Node then -- If String_Node is nil, it is an empty list, -- set Expression_Kind if it is still Undecided if Expression_Kind = Undecided then Expression_Kind := Static_String; end if; else Expression (Project => Project, First_Term => Tree.First_Term (String_Node), Kind => Single, In_Case => In_Case); loop -- Add the other element of the literal string list -- one after the other String_Node := Next_Expression_In_List (String_Node); exit when String_Node = Empty_Node; Put (" "); Add_To_Expression_Value (" "); Expression (Project => Project, First_Term => Tree.First_Term (String_Node), Kind => Single, In_Case => In_Case); end loop; end if; end; when N_Variable_Reference | N_Attribute_Reference => -- A variable or attribute reference is never static Expression_Kind := Other; -- A variable or an attribute is identified by: -- - its project name, -- - its package name, if any, -- - its name, and -- - its index (if an associative array attribute). declare Term_Project : Project_Node_Id := Project_Node_Of (Current_Term); Term_Package : constant Project_Node_Id := Package_Node_Of (Current_Term); Name : constant Name_Id := Name_Of (Current_Term); Term_Package_Name : Name_Id := No_Name; begin if Term_Project = Empty_Node then Term_Project := Project; end if; if Term_Package /= Empty_Node then Term_Package_Name := Name_Of (Term_Package); end if; -- If we are in a string list, we precede this variable or -- attribute reference with a space; it does not matter if -- the output list has a leading space. if Kind = List then Put (" "); end if; Put ("$("); if Kind_Of (Current_Term) = N_Variable_Reference then Put_Variable (Project => Term_Project, Pkg => Term_Package_Name, Name => Name); else -- Attribute reference. -- If it is a Default_Switches attribute, check if it -- is allowed in this expression (same package and same -- language). if Name = Snames.Name_Default_Switches then if Default_Switches_Package /= Term_Package_Name or else not Equal_String (Default_Switches_Language, Associative_Array_Index_Of (Current_Term)) then -- This Default_Switches attribute is not allowed -- here; report an error and continue. -- The Makefiles created will be deleted at the -- end. Error_Msg_Name_1 := Term_Package_Name; Error_Msg ("reference to `%''Default_Switches` " & "not allowed here", Location_Of (Current_Term)); end if; -- If it is a Switches attribute, check if it is allowed -- in this expression (same package and same source -- kind). elsif Name = Snames.Name_Switches then if Switches_Package /= Term_Package_Name or else Source_Kind_Of (Associative_Array_Index_Of (Current_Term)) /= Switches_Language then -- This Switches attribute is not allowed here; -- report an error and continue. The Makefiles -- created will be deleted at the end. Error_Msg_Name_1 := Term_Package_Name; Error_Msg ("reference to `%''Switches` " & "not allowed here", Location_Of (Current_Term)); end if; else -- Other attribute references are only allowed in -- the declaration of an atribute of the same -- package and of the same name. if not Other_Attribute or else Other_Attribute_Package /= Term_Package_Name or else Other_Attribute_Name /= Name then if Term_Package_Name = No_Name then Error_Msg_Name_1 := Name; Error_Msg ("reference to % not allowed here", Location_Of (Current_Term)); else Error_Msg_Name_1 := Term_Package_Name; Error_Msg_Name_2 := Name; Error_Msg ("reference to `%''%` not allowed here", Location_Of (Current_Term)); end if; end if; end if; Put_Attribute (Project => Term_Project, Pkg => Term_Package_Name, Name => Name, Index => Associative_Array_Index_Of (Current_Term)); end if; Put (")"); end; when N_External_Value => -- An external reference is never static Expression_Kind := Other; -- As the external references have already been processed, -- we just output the name of the variable that corresponds -- to this external reference node. Put ("$("); Put_U_Name (Name_Of (Project)); Put (".external."); Put (Externals.Get (Current_Term)); Put (")"); when others => -- Should never happen pragma Assert (False, "illegal node kind in an expression"); raise Program_Error; end case; Term := Next_Term (Term); end loop; end Expression; -------------- -- Gpr2make -- -------------- procedure Gpr2make is begin -- First, get the switches, if any loop case Getopt ("h q v R") is when ASCII.NUL => exit; -- -h: Help when 'h' => Usage; -- -q: Quiet when 'q' => Opt.Quiet_Output := True; -- -v: Verbose when 'v' => Opt.Verbose_Mode := True; Display_Copyright; -- -R: no Recursivity when 'R' => Process_All_Project_Files := False; when others => raise Program_Error; end case; end loop; -- Now, get the project file (maximum one) loop declare S : constant String := Get_Argument (Do_Expansion => True); begin exit when S'Length = 0; if Main_Project_File_Name /= null then Fail ("only one project file may be specified"); else Main_Project_File_Name := new String'(S); end if; end; end loop; -- If no project file specified, display the usage and exit if Main_Project_File_Name = null then Usage; return; end if; -- Do the necessary initializations Csets.Initialize; Namet.Initialize; Snames.Initialize; Prj.Initialize; -- Parse the project file(s) Prj.Part.Parse (Project_Tree, Main_Project_File_Name.all, False); -- If parsing was successful, process the project tree if Project_Tree /= Empty_Node then -- Create some Name_Ids that are not in Snames Name_Len := 3; Name_Buffer (1 .. Name_Len) := "ide"; Name_Ide := Name_Find; Name_Len := 16; Name_Buffer (1 .. Name_Len) := "compiler_command"; Name_Compiler_Command := Name_Find; Name_Len := 13; Name_Buffer (1 .. Name_Len) := "main_language"; Name_Main_Language := Name_Find; Name_Len := 3; Name_Buffer (1 .. Name_Len) := "c++"; Name_C_Plus_Plus := Name_Find; Process (Project_Tree); if Compilation_Errors then if not Verbose_Mode then Write_Eol; end if; Prj.Err.Finalize; Write_Eol; IO.Delete_All; Fail ("no Makefile created"); end if; end if; end Gpr2make; -------------- -- New_Line -- -------------- procedure New_Line is begin IO.New_Line; end New_Line; ------------- -- Process -- ------------- procedure Process (Project : Project_Node_Id) is begin Processed_Projects.Reset; Recursive_Process (Project); end Process; ------------------------------- -- Process_Case_Construction -- ------------------------------- procedure Process_Case_Construction (Current_Project : Project_Node_Id; Current_Pkg : Name_Id; Case_Project : Project_Node_Id; Case_Pkg : Name_Id; Name : Name_Id; Node : Project_Node_Id) is Case_Project_Name : constant Name_Id := Name_Of (Case_Project); Before : IO.Position; Start : IO.Position; After : IO.Position; procedure Put_Case_Construction; -- Output the variable $__CASE__#, specific to -- this case construction. It contains the number of the -- branch to follow. procedure Recursive_Process (Case_Item : Project_Node_Id; Branch_Number : Positive); -- A recursive procedure. Calls itself for each branch, increasing -- Branch_Number by 1 each time. procedure Put_Variable_Name; -- Output the case variable --------------------------- -- Put_Case_Construction -- --------------------------- procedure Put_Case_Construction is begin Put_U_Name (Case_Project_Name); Put (".case."); Put (Last_Case_Construction); end Put_Case_Construction; ----------------------- -- Recursive_Process -- ----------------------- procedure Recursive_Process (Case_Item : Project_Node_Id; Branch_Number : Positive) is Choice_String : Project_Node_Id := First_Choice_Of (Case_Item); Before : IO.Position; Start : IO.Position; After : IO.Position; No_Lines : Boolean := False; begin -- Nothing to do if Case_Item is empty. -- That should happen only if the case construvtion is totally empty. -- case Var is -- end case; if Case_Item /= Empty_Node then -- Remember where we are, to be able to come back here if this -- case item is empty. IO.Mark (Before); if Choice_String = Empty_Node then -- when others => -- Output a comment "# when others => ..." Put_Line ("# when others => ..."); -- Remember where we are, to detect if there is anything -- put in the Makefile for this branch. IO.Mark (Start); -- Process the declarative items of this branch Process_Declarative_Items (Project => Current_Project, Pkg => Current_Pkg, In_Case => True, Item => First_Declarative_Item_Of (Case_Item)); -- Where are we now? IO.Mark (After); -- If we are at the same place, the branch is totally empty: -- suppress it completely. if Start = After then IO.Release (Before); end if; else -- Case Item with one or several case labels -- Output a comment -- # case