From e6d50a9e9d71a8b5519de675e94e79e72be3a150 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 3 Jan 2005 16:34:18 +0100 Subject: [PATCH] bld.ads, [...]: Remove gpr2make, replaced by gprmake. * bld.ads, bld.adb, bld-io.ads, bld-io.adb, gprcmd.adb, gpr2make.ads, gpr2make.adb: Remove gpr2make, replaced by gprmake. * Makefile.in: Add support to build shared Ada libraries on solaris x86 Remove gpr2make, replaced by gprmake. Remove references to gnatmem and libaddr2line. Add indepsw.adb>tmp-sdefault.adb $(ECHO) " function Target_Name return String_Ptr is" >>tmp-sdefault.adb $(ECHO) " begin" >>tmp-sdefault.adb - $(ECHO) " return Relocate_Path (S0, S3);" >>tmp-sdefault.adb + $(ECHO) " return new String'(S3);" >>tmp-sdefault.adb $(ECHO) " end Target_Name;" >>tmp-sdefault.adb $(ECHO) " function Search_Dir_Prefix return String_Ptr is" >>tmp-sdefault.adb $(ECHO) " begin" >>tmp-sdefault.adb diff --git a/gcc/ada/Makefile.in b/gcc/ada/Makefile.in index 45490c8..4380918 100644 --- a/gcc/ada/Makefile.in +++ b/gcc/ada/Makefile.in @@ -133,8 +133,6 @@ THREAD_KIND = native THREADSLIB = GMEM_LIB = MISCLIB = -SYMLIB = -ADDR2LINE_SYMLIB = -laddr2line -lbfd -liberty $(LIBINTL) SYMDEPS = $(LIBINTL_DEP) OUTPUT_OPTION = @OUTPUT_OPTION@ @@ -716,7 +714,6 @@ ifeq ($(strip $(filter-out sparc sun solaris%,$(targ))),) THREADSLIB = -lposix4 -lthread MISCLIB = -lposix4 -lnsl -lsocket - SYMLIB = $(ADDR2LINE_SYMLIB) SO_OPTS = -Wl,-h, GNATLIB_SHARED = gnatlib-shared-dual GMEM_LIB = gmemlib @@ -800,10 +797,13 @@ ifeq ($(strip $(filter-out %86 solaris2%,$(arch) $(osys))),) g-soliop.ads= 2.0**HM loop + K := K * M - (K * M - K); + X := (((((X - K * P1) - K * P2) - K * P3) + - K * P4) - K * P5) - K * P6; + K := X * Two_Over_Pi; + end loop; + + if K /= K then + + -- K is not a number, because X was not finite + + raise Constraint_Error; + end if; + + K := Double'Rounding (K); + Q := Integer (K) mod 4; + X := (((((X - K * P1) - K * P2) - K * P3) + - K * P4) - K * P5) - K * P6; + end Reduce; + + --------- + -- Cos -- + --------- + + function Cos (X : Double) return Double is + Reduced_X : Double := abs X; + Quadrant : Natural range 0 .. 3; + + begin + if Reduced_X > Pi / 4.0 then + Reduce (Reduced_X, Quadrant); + + case Quadrant is + when 0 => + return Cosine_Approx (Reduced_X); + + when 1 => + return Sine_Approx (-Reduced_X); + + when 2 => + return -Cosine_Approx (Reduced_X); + + when 3 => + return Sine_Approx (Reduced_X); + end case; + end if; + + return Cosine_Approx (Reduced_X); + end Cos; + + --------- + -- Sin -- + --------- + + function Sin (X : Double) return Double is + Reduced_X : Double := X; + Quadrant : Natural range 0 .. 3; + + begin + if abs X > Pi / 4.0 then + Reduce (Reduced_X, Quadrant); + + case Quadrant is + when 0 => + return Sine_Approx (Reduced_X); + + when 1 => + return Cosine_Approx (Reduced_X); + + when 2 => + return Sine_Approx (-Reduced_X); + + when 3 => + return -Cosine_Approx (Reduced_X); + end case; + end if; + + return Sine_Approx (Reduced_X); + end Sin; + +end Ada.Numerics.Aux; diff --git a/gcc/ada/a-numaux-darwin.ads b/gcc/ada/a-numaux-darwin.ads new file mode 100644 index 0000000..6ca8c3c --- /dev/null +++ b/gcc/ada/a-numaux-darwin.ads @@ -0,0 +1,109 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . A U X -- +-- -- +-- S p e c -- +-- (Apple OS X Version) -- +-- -- +-- Copyright (C) 1992-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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version is for use with normal Unix math functions, except for +-- sine/cosine which have been implemented directly in Ada to get +-- the required accuracy in OS X. Alternative packages are used +-- on OpenVMS (different import names), VxWorks (no need for the +-- -lm Linker_Options), and on the x86 (where we have two +-- versions one using inline ASM, and one importing from the C long +-- routines that take 80-bit arguments). + +package Ada.Numerics.Aux is +pragma Pure (Aux); + + pragma Linker_Options ("-lm"); + + type Double is digits 15; + -- Type Double is the type used to call the C routines + + -- The following functions have been implemented in Ada, since + -- the OS X math library didn't meet accuracy requirements for + -- argument reduction. The implementation here has been tailored + -- to match Ada strict mode Numerics requirements while maintaining + -- maximum efficiency. + function Sin (X : Double) return Double; + pragma Inline (Sin); + + function Cos (X : Double) return Double; + pragma Inline (Cos); + + -- We import these functions directly from C. Note that we label them + -- all as pure functions, because indeed all of them are in fact pure! + + function Tan (X : Double) return Double; + pragma Import (C, Tan, "tan"); + pragma Pure_Function (Tan); + + function Exp (X : Double) return Double; + pragma Import (C, Exp, "exp"); + pragma Pure_Function (Exp); + + function Sqrt (X : Double) return Double; + pragma Import (C, Sqrt, "sqrt"); + pragma Pure_Function (Sqrt); + + function Log (X : Double) return Double; + pragma Import (C, Log, "log"); + pragma Pure_Function (Log); + + function Acos (X : Double) return Double; + pragma Import (C, Acos, "acos"); + pragma Pure_Function (Acos); + + function Asin (X : Double) return Double; + pragma Import (C, Asin, "asin"); + pragma Pure_Function (Asin); + + function Atan (X : Double) return Double; + pragma Import (C, Atan, "atan"); + pragma Pure_Function (Atan); + + function Sinh (X : Double) return Double; + pragma Import (C, Sinh, "sinh"); + pragma Pure_Function (Sinh); + + function Cosh (X : Double) return Double; + pragma Import (C, Cosh, "cosh"); + pragma Pure_Function (Cosh); + + function Tanh (X : Double) return Double; + pragma Import (C, Tanh, "tanh"); + pragma Pure_Function (Tanh); + + function Pow (X, Y : Double) return Double; + pragma Import (C, Pow, "pow"); + pragma Pure_Function (Pow); + +end Ada.Numerics.Aux; diff --git a/gcc/ada/bld-io.adb b/gcc/ada/bld-io.adb deleted file mode 100644 index 7bd01e6..0000000 --- a/gcc/ada/bld-io.adb +++ /dev/null @@ -1,285 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- B L D - I O -- --- -- --- B o d y -- --- -- --- Copyright (C) 2002-2003 Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING. If not, write -- --- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, USA. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Exceptions; -with Ada.Text_IO; -with Ada.Unchecked_Deallocation; - -with GNAT.OS_Lib; use GNAT.OS_Lib; -with Osint; - -package body Bld.IO is - - use Ada; - - Initial_Number_Of_Lines : constant := 100; - Initial_Length_Of_Line : constant := 50; - - type Line is record - Length : Natural := 0; - Value : String_Access; - Suppressed : Boolean := False; - end record; - -- One line of a Makefile. - -- Length is the position of the last column in the line. - -- Suppressed is set to True by procedure Suppress. - - type Line_Array is array (Positive range <>) of Line; - - type Buffer is access Line_Array; - - procedure Free is new Ada.Unchecked_Deallocation (Line_Array, Buffer); - - Lines : Buffer := new Line_Array (1 .. Initial_Number_Of_Lines); - -- The lines of a Makefile - - Current : Positive := 1; - -- Position of the last line in the Makefile - - File : Text_IO.File_Type; - -- The current Makefile - - type File_Name_Data; - type File_Name_Ref is access File_Name_Data; - - type File_Name_Data is record - Value : String_Access; - Next : File_Name_Ref; - end record; - -- Used to record the names of all Makefiles created, so that we may delete - -- them if necessary. - - File_Names : File_Name_Ref; - -- List of all the Makefiles created so far. - - ----------- - -- Close -- - ----------- - - procedure Close is - begin - Flush; - Text_IO.Close (File); - - exception - when X : others => - Text_IO.Put_Line (Exceptions.Exception_Message (X)); - Osint.Fail ("cannot close a Makefile"); - end Close; - - ------------ - -- Create -- - ------------ - - procedure Create (File_Name : String) is - begin - Text_IO.Create (File, Text_IO.Out_File, File_Name); - Current := 1; - Lines (1).Length := 0; - Lines (1).Suppressed := False; - File_Names := - new File_Name_Data'(Value => new String'(File_Name), - Next => File_Names); - exception - when X : others => - Text_IO.Put_Line (Exceptions.Exception_Message (X)); - Osint.Fail ("cannot create """ & File_Name & '"'); - end Create; - - ---------------- - -- Delete_All -- - ---------------- - - procedure Delete_All is - Success : Boolean; - begin - if Text_IO.Is_Open (File) then - Text_IO.Delete (File); - File_Names := File_Names.Next; - end if; - - while File_Names /= null loop - Delete_File (File_Names.Value.all, Success); - File_Names := File_Names.Next; - end loop; - end Delete_All; - - ----------- - -- Flush -- - ----------- - - procedure Flush is - Last : Natural; - begin - if Lines (Current).Length /= 0 then - Osint.Fail ("INTERNAL ERROR: flushing before end of line: """ & - Lines (Current).Value - (1 .. Lines (Current).Length)); - end if; - - for J in 1 .. Current - 1 loop - if not Lines (J).Suppressed then - Last := Lines (J).Length; - - -- The last character of a line cannot be a back slash ('\'), - -- otherwise make has a problem. The only real place were it - -- should happen is for directory names on Windows, and then - -- this terminal back slash is not needed. - - if Last > 0 and then Lines (J).Value (Last) = '\' then - Last := Last - 1; - end if; - - Text_IO.Put_Line (File, Lines (J).Value (1 .. Last)); - end if; - end loop; - - Current := 1; - Lines (1).Length := 0; - Lines (1).Suppressed := False; - end Flush; - - ---------- - -- Mark -- - ---------- - - procedure Mark (Pos : out Position) is - begin - if Lines (Current).Length /= 0 then - Osint.Fail ("INTERNAL ERROR: marking before end of line: """ & - Lines (Current).Value - (1 .. Lines (Current).Length)); - end if; - - Pos := (Value => Current); - end Mark; - - ------------------ - -- Name_Of_File -- - ------------------ - - function Name_Of_File return String is - begin - return Text_IO.Name (File); - end Name_Of_File; - - -------------- - -- New_Line -- - -------------- - - procedure New_Line is - begin - Current := Current + 1; - - if Current > Lines'Last then - declare - New_Lines : constant Buffer := - new Line_Array (1 .. 2 * Lines'Last); - - begin - New_Lines (1 .. Lines'Last) := Lines.all; - Free (Lines); - Lines := New_Lines; - end; - end if; - - Lines (Current).Length := 0; - Lines (Current).Suppressed := False; - - -- Allocate a new line, if necessary - - if Lines (Current).Value = null then - Lines (Current).Value := new String (1 .. Initial_Length_Of_Line); - end if; - end New_Line; - - --------- - -- Put -- - --------- - - procedure Put (S : String) is - Length : constant Natural := Lines (Current).Length; - - begin - if Length + S'Length > Lines (Current).Value'Length then - declare - New_Line : String_Access; - New_Length : Positive := 2 * Lines (Current).Value'Length; - begin - while Length + S'Length > New_Length loop - New_Length := 2 * New_Length; - end loop; - - New_Line := new String (1 .. New_Length); - New_Line (1 .. Length) := Lines (Current).Value (1 .. Length); - Free (Lines (Current).Value); - Lines (Current).Value := New_Line; - end; - end if; - - Lines (Current).Value (Length + 1 .. Length + S'Length) := S; - Lines (Current).Length := Length + S'Length; - end Put; - - ------------- - -- Release -- - ------------- - - procedure Release (Pos : Position) is - begin - if Lines (Current).Length /= 0 then - Osint.Fail ("INTERNAL ERROR: releasing before end of line: """ & - Lines (Current).Value - (1 .. Lines (Current).Length)); - end if; - - if Pos.Value > Current then - Osint.Fail ("INTERNAL ERROR: releasing ahead of current position"); - end if; - - Current := Pos.Value; - Lines (Current).Length := 0; - end Release; - - -------------- - -- Suppress -- - -------------- - - procedure Suppress (Pos : Position) is - begin - if Pos.Value >= Current then - Osint.Fail ("INTERNAL ERROR: suppressing ahead of current position"); - end if; - - Lines (Pos.Value).Suppressed := True; - end Suppress; - -begin - -- Allocate the first line. - -- The other ones are allocated by New_Line. - - Lines (1).Value := new String (1 .. Initial_Length_Of_Line); -end Bld.IO; diff --git a/gcc/ada/bld-io.ads b/gcc/ada/bld-io.ads deleted file mode 100644 index c5df627..0000000 --- a/gcc/ada/bld-io.ads +++ /dev/null @@ -1,73 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- B L D - I O -- --- -- --- S p e c -- --- -- --- Copyright (C) 2002 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. -- --- -- ------------------------------------------------------------------------------- - --- The following private package allows the ouput of text to Makefiles --- though buffers. It is possible to remove some lines from the buffers --- without putting them effectively in the Makefile. - -private package Bld.IO is - - procedure Create (File_Name : String); - -- Create a new Makefile - - procedure Flush; - -- Output all not suppressed lines to the Makefile - - procedure Close; - -- Close the current Makefile - - procedure Delete_All; - -- Delete all the Makefiles that have been created - - function Name_Of_File return String; - -- Return the path name of the current Makefile - - type Position is private; - -- Identification of a line in the Makefile - - procedure Mark (Pos : out Position); - -- Record the current line. - -- No characters should have been already put on this line. - - procedure Release (Pos : Position); - -- Suppress all line after this one, including this one. - - procedure Suppress (Pos : Position); - -- Suppress a particular line - - procedure Put (S : String); - -- Append a string to the current line - - procedure New_Line; - -- End a line. Go to the next one (initially empty). - -private - - type Position is record - Value : Positive := 1; - end record; - -end Bld.IO; diff --git a/gcc/ada/bld.adb b/gcc/ada/bld.adb deleted file mode 100644 index e8b5c89..0000000 --- a/gcc/ada/bld.adb +++ /dev/null @@ -1,3622 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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