| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- P R J -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 2001-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. -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| with Ada.Characters.Handling; use Ada.Characters.Handling; |
| |
| with Namet; use Namet; |
| with Output; use Output; |
| with Osint; use Osint; |
| with Prj.Attr; |
| with Prj.Com; |
| with Prj.Env; |
| with Prj.Err; use Prj.Err; |
| with Scans; use Scans; |
| with Snames; use Snames; |
| with Uintp; use Uintp; |
| |
| with GNAT.Case_Util; use GNAT.Case_Util; |
| with GNAT.OS_Lib; use GNAT.OS_Lib; |
| |
| package body Prj is |
| |
| The_Empty_String : Name_Id; |
| |
| Name_C_Plus_Plus : Name_Id; |
| |
| subtype Known_Casing is Casing_Type range All_Upper_Case .. Mixed_Case; |
| |
| The_Casing_Images : constant array (Known_Casing) of String_Access := |
| (All_Lower_Case => new String'("lowercase"), |
| All_Upper_Case => new String'("UPPERCASE"), |
| Mixed_Case => new String'("MixedCase")); |
| |
| Initialized : Boolean := False; |
| |
| Standard_Dot_Replacement : constant Name_Id := |
| First_Name_Id + Character'Pos ('-'); |
| |
| Std_Naming_Data : Naming_Data := |
| (Dot_Replacement => Standard_Dot_Replacement, |
| Dot_Repl_Loc => No_Location, |
| Casing => All_Lower_Case, |
| Spec_Suffix => No_Array_Element, |
| Ada_Spec_Suffix => No_Name, |
| Spec_Suffix_Loc => No_Location, |
| Impl_Suffixes => No_Impl_Suffixes, |
| Supp_Suffixes => No_Supp_Language_Index, |
| Body_Suffix => No_Array_Element, |
| Ada_Body_Suffix => No_Name, |
| Body_Suffix_Loc => No_Location, |
| Separate_Suffix => No_Name, |
| Sep_Suffix_Loc => No_Location, |
| Specs => No_Array_Element, |
| Bodies => No_Array_Element, |
| Specification_Exceptions => No_Array_Element, |
| Implementation_Exceptions => No_Array_Element); |
| |
| Project_Empty : constant Project_Data := |
| (Externally_Built => False, |
| Languages => No_Languages, |
| Supp_Languages => No_Supp_Language_Index, |
| First_Referred_By => No_Project, |
| Name => No_Name, |
| Path_Name => No_Name, |
| Display_Path_Name => No_Name, |
| Virtual => False, |
| Location => No_Location, |
| Mains => Nil_String, |
| Directory => No_Name, |
| Display_Directory => No_Name, |
| Dir_Path => null, |
| Library => False, |
| Library_Dir => No_Name, |
| Display_Library_Dir => No_Name, |
| Library_Src_Dir => No_Name, |
| Display_Library_Src_Dir => No_Name, |
| Library_Name => No_Name, |
| Library_Kind => Static, |
| Lib_Internal_Name => No_Name, |
| Standalone_Library => False, |
| Lib_Interface_ALIs => Nil_String, |
| Lib_Auto_Init => False, |
| Symbol_Data => No_Symbols, |
| Ada_Sources_Present => True, |
| Other_Sources_Present => True, |
| Sources => Nil_String, |
| First_Other_Source => No_Other_Source, |
| Last_Other_Source => No_Other_Source, |
| Imported_Directories_Switches => null, |
| Include_Path => null, |
| Include_Data_Set => False, |
| Source_Dirs => Nil_String, |
| Known_Order_Of_Source_Dirs => True, |
| Object_Directory => No_Name, |
| Display_Object_Dir => No_Name, |
| Exec_Directory => No_Name, |
| Display_Exec_Dir => No_Name, |
| Extends => No_Project, |
| Extended_By => No_Project, |
| Naming => Std_Naming_Data, |
| First_Language_Processing => Default_First_Language_Processing_Data, |
| Supp_Language_Processing => No_Supp_Language_Index, |
| Default_Linker => No_Name, |
| Default_Linker_Path => No_Name, |
| Decl => No_Declarations, |
| Imported_Projects => Empty_Project_List, |
| Ada_Include_Path => null, |
| Ada_Objects_Path => null, |
| Include_Path_File => No_Name, |
| Objects_Path_File_With_Libs => No_Name, |
| Objects_Path_File_Without_Libs => No_Name, |
| Config_File_Name => No_Name, |
| Config_File_Temp => False, |
| Config_Checked => False, |
| Language_Independent_Checked => False, |
| Checked => False, |
| Seen => False, |
| Need_To_Build_Lib => False, |
| Depth => 0, |
| Unkept_Comments => False); |
| |
| ----------------------- |
| -- Add_Language_Name -- |
| ----------------------- |
| |
| procedure Add_Language_Name (Name : Name_Id) is |
| begin |
| Last_Language_Index := Last_Language_Index + 1; |
| Language_Indexes.Set (Name, Last_Language_Index); |
| Language_Names.Increment_Last; |
| Language_Names.Table (Last_Language_Index) := Name; |
| end Add_Language_Name; |
| |
| ------------------- |
| -- Add_To_Buffer -- |
| ------------------- |
| |
| procedure Add_To_Buffer (S : String) is |
| begin |
| -- If Buffer is too small, double its size |
| |
| if Buffer_Last + S'Length > Buffer'Last then |
| declare |
| New_Buffer : constant String_Access := |
| new String (1 .. 2 * Buffer'Last); |
| |
| begin |
| New_Buffer (1 .. Buffer_Last) := Buffer (1 .. Buffer_Last); |
| Free (Buffer); |
| Buffer := New_Buffer; |
| end; |
| end if; |
| |
| Buffer (Buffer_Last + 1 .. Buffer_Last + S'Length) := S; |
| Buffer_Last := Buffer_Last + S'Length; |
| end Add_To_Buffer; |
| |
| --------------------------- |
| -- Display_Language_Name -- |
| --------------------------- |
| |
| procedure Display_Language_Name (Language : Language_Index) is |
| begin |
| Get_Name_String (Language_Names.Table (Language)); |
| To_Upper (Name_Buffer (1 .. 1)); |
| Write_Str (Name_Buffer (1 .. Name_Len)); |
| end Display_Language_Name; |
| |
| ------------------- |
| -- Empty_Project -- |
| ------------------- |
| |
| function Empty_Project return Project_Data is |
| begin |
| Prj.Initialize; |
| return Project_Empty; |
| end Empty_Project; |
| |
| ------------------ |
| -- Empty_String -- |
| ------------------ |
| |
| function Empty_String return Name_Id is |
| begin |
| return The_Empty_String; |
| end Empty_String; |
| |
| ------------ |
| -- Expect -- |
| ------------ |
| |
| procedure Expect (The_Token : Token_Type; Token_Image : String) is |
| begin |
| if Token /= The_Token then |
| Error_Msg (Token_Image & " expected", Token_Ptr); |
| end if; |
| end Expect; |
| |
| -------------------------------- |
| -- For_Every_Project_Imported -- |
| -------------------------------- |
| |
| procedure For_Every_Project_Imported |
| (By : Project_Id; |
| With_State : in out State) |
| is |
| |
| procedure Check (Project : Project_Id); |
| -- Check if a project has already been seen. If not seen, mark it as |
| -- Seen, Call Action, and check all its imported projects. |
| |
| ----------- |
| -- Check -- |
| ----------- |
| |
| procedure Check (Project : Project_Id) is |
| List : Project_List; |
| |
| begin |
| if not Projects.Table (Project).Seen then |
| Projects.Table (Project).Seen := True; |
| Action (Project, With_State); |
| |
| List := Projects.Table (Project).Imported_Projects; |
| while List /= Empty_Project_List loop |
| Check (Project_Lists.Table (List).Project); |
| List := Project_Lists.Table (List).Next; |
| end loop; |
| end if; |
| end Check; |
| |
| -- Start of procecessing for For_Every_Project_Imported |
| |
| begin |
| for Project in Projects.First .. Projects.Last loop |
| Projects.Table (Project).Seen := False; |
| end loop; |
| |
| Check (Project => By); |
| end For_Every_Project_Imported; |
| |
| ---------- |
| -- Hash -- |
| ---------- |
| |
| function Hash (Name : Name_Id) return Header_Num is |
| begin |
| return Hash (Get_Name_String (Name)); |
| end Hash; |
| |
| ----------- |
| -- Image -- |
| ----------- |
| |
| function Image (Casing : Casing_Type) return String is |
| begin |
| return The_Casing_Images (Casing).all; |
| end Image; |
| |
| ---------------- |
| -- Initialize -- |
| ---------------- |
| |
| procedure Initialize is |
| begin |
| if not Initialized then |
| Initialized := True; |
| Uintp.Initialize; |
| Name_Len := 0; |
| The_Empty_String := Name_Find; |
| Empty_Name := The_Empty_String; |
| Name_Len := 4; |
| Name_Buffer (1 .. 4) := ".ads"; |
| Default_Ada_Spec_Suffix := Name_Find; |
| Name_Len := 4; |
| Name_Buffer (1 .. 4) := ".adb"; |
| Default_Ada_Body_Suffix := Name_Find; |
| Name_Len := 1; |
| Name_Buffer (1) := '/'; |
| Slash := Name_Find; |
| Name_Len := 3; |
| Name_Buffer (1 .. 3) := "c++"; |
| Name_C_Plus_Plus := Name_Find; |
| |
| Std_Naming_Data.Ada_Spec_Suffix := Default_Ada_Spec_Suffix; |
| Std_Naming_Data.Ada_Body_Suffix := Default_Ada_Body_Suffix; |
| Std_Naming_Data.Separate_Suffix := Default_Ada_Body_Suffix; |
| Register_Default_Naming_Scheme |
| (Language => Name_Ada, |
| Default_Spec_Suffix => Default_Ada_Spec_Suffix, |
| Default_Body_Suffix => Default_Ada_Body_Suffix); |
| Prj.Env.Initialize; |
| Prj.Attr.Initialize; |
| Set_Name_Table_Byte (Name_Project, Token_Type'Pos (Tok_Project)); |
| Set_Name_Table_Byte (Name_Extends, Token_Type'Pos (Tok_Extends)); |
| Set_Name_Table_Byte (Name_External, Token_Type'Pos (Tok_External)); |
| |
| Language_Indexes.Reset; |
| Last_Language_Index := No_Language_Index; |
| Language_Names.Init; |
| Add_Language_Name (Name_Ada); |
| Add_Language_Name (Name_C); |
| Add_Language_Name (Name_C_Plus_Plus); |
| end if; |
| end Initialize; |
| |
| ---------------- |
| -- Is_Present -- |
| ---------------- |
| |
| function Is_Present |
| (Language : Language_Index; |
| In_Project : Project_Data) return Boolean |
| is |
| begin |
| case Language is |
| when No_Language_Index => |
| return False; |
| |
| when First_Language_Indexes => |
| return In_Project.Languages (Language); |
| |
| when others => |
| declare |
| Supp : Supp_Language; |
| Supp_Index : Supp_Language_Index := In_Project.Supp_Languages; |
| |
| begin |
| while Supp_Index /= No_Supp_Language_Index loop |
| Supp := Present_Languages.Table (Supp_Index); |
| |
| if Supp.Index = Language then |
| return Supp.Present; |
| end if; |
| |
| Supp_Index := Supp.Next; |
| end loop; |
| |
| return False; |
| end; |
| end case; |
| end Is_Present; |
| |
| --------------------------------- |
| -- Language_Processing_Data_Of -- |
| --------------------------------- |
| |
| function Language_Processing_Data_Of |
| (Language : Language_Index; |
| In_Project : Project_Data) return Language_Processing_Data |
| is |
| begin |
| case Language is |
| when No_Language_Index => |
| return Default_Language_Processing_Data; |
| |
| when First_Language_Indexes => |
| return In_Project.First_Language_Processing (Language); |
| |
| when others => |
| declare |
| Supp : Supp_Language_Data; |
| Supp_Index : Supp_Language_Index := |
| In_Project.Supp_Language_Processing; |
| |
| begin |
| while Supp_Index /= No_Supp_Language_Index loop |
| Supp := Supp_Languages.Table (Supp_Index); |
| |
| if Supp.Index = Language then |
| return Supp.Data; |
| end if; |
| |
| Supp_Index := Supp.Next; |
| end loop; |
| |
| return Default_Language_Processing_Data; |
| end; |
| end case; |
| end Language_Processing_Data_Of; |
| |
| ------------------------------------ |
| -- Register_Default_Naming_Scheme -- |
| ------------------------------------ |
| |
| procedure Register_Default_Naming_Scheme |
| (Language : Name_Id; |
| Default_Spec_Suffix : Name_Id; |
| Default_Body_Suffix : Name_Id) |
| is |
| Lang : Name_Id; |
| Suffix : Array_Element_Id; |
| Found : Boolean := False; |
| Element : Array_Element; |
| |
| begin |
| -- Get the language name in small letters |
| |
| Get_Name_String (Language); |
| Name_Buffer (1 .. Name_Len) := To_Lower (Name_Buffer (1 .. Name_Len)); |
| Lang := Name_Find; |
| |
| Suffix := Std_Naming_Data.Spec_Suffix; |
| Found := False; |
| |
| -- Look for an element of the spec sufix array indexed by the language |
| -- name. If one is found, put the default value. |
| |
| while Suffix /= No_Array_Element and then not Found loop |
| Element := Array_Elements.Table (Suffix); |
| |
| if Element.Index = Lang then |
| Found := True; |
| Element.Value.Value := Default_Spec_Suffix; |
| Array_Elements.Table (Suffix) := Element; |
| |
| else |
| Suffix := Element.Next; |
| end if; |
| end loop; |
| |
| -- If none can be found, create a new one. |
| |
| if not Found then |
| Element := |
| (Index => Lang, |
| Src_Index => 0, |
| Index_Case_Sensitive => False, |
| Value => (Project => No_Project, |
| Kind => Single, |
| Location => No_Location, |
| Default => False, |
| Value => Default_Spec_Suffix, |
| Index => 0), |
| Next => Std_Naming_Data.Spec_Suffix); |
| Array_Elements.Increment_Last; |
| Array_Elements.Table (Array_Elements.Last) := Element; |
| Std_Naming_Data.Spec_Suffix := Array_Elements.Last; |
| end if; |
| |
| Suffix := Std_Naming_Data.Body_Suffix; |
| Found := False; |
| |
| -- Look for an element of the body sufix array indexed by the language |
| -- name. If one is found, put the default value. |
| |
| while Suffix /= No_Array_Element and then not Found loop |
| Element := Array_Elements.Table (Suffix); |
| |
| if Element.Index = Lang then |
| Found := True; |
| Element.Value.Value := Default_Body_Suffix; |
| Array_Elements.Table (Suffix) := Element; |
| |
| else |
| Suffix := Element.Next; |
| end if; |
| end loop; |
| |
| -- If none can be found, create a new one. |
| |
| if not Found then |
| Element := |
| (Index => Lang, |
| Src_Index => 0, |
| Index_Case_Sensitive => False, |
| Value => (Project => No_Project, |
| Kind => Single, |
| Location => No_Location, |
| Default => False, |
| Value => Default_Body_Suffix, |
| Index => 0), |
| Next => Std_Naming_Data.Body_Suffix); |
| Array_Elements.Increment_Last; |
| Array_Elements.Table (Array_Elements.Last) := Element; |
| Std_Naming_Data.Body_Suffix := Array_Elements.Last; |
| end if; |
| end Register_Default_Naming_Scheme; |
| |
| ----------- |
| -- Reset -- |
| ----------- |
| |
| procedure Reset is |
| begin |
| Projects.Init; |
| Project_Lists.Init; |
| Packages.Init; |
| Arrays.Init; |
| Variable_Elements.Init; |
| String_Elements.Init; |
| Prj.Com.Units.Init; |
| Prj.Com.Units_Htable.Reset; |
| Prj.Com.Files_Htable.Reset; |
| end Reset; |
| |
| ------------------------ |
| -- Same_Naming_Scheme -- |
| ------------------------ |
| |
| function Same_Naming_Scheme |
| (Left, Right : Naming_Data) return Boolean |
| is |
| begin |
| return Left.Dot_Replacement = Right.Dot_Replacement |
| and then Left.Casing = Right.Casing |
| and then Left.Ada_Spec_Suffix = Right.Ada_Spec_Suffix |
| and then Left.Ada_Body_Suffix = Right.Ada_Body_Suffix |
| and then Left.Separate_Suffix = Right.Separate_Suffix; |
| end Same_Naming_Scheme; |
| |
| --------- |
| -- Set -- |
| --------- |
| |
| procedure Set |
| (Language : Language_Index; |
| Present : Boolean; |
| In_Project : in out Project_Data) |
| is |
| begin |
| case Language is |
| when No_Language_Index => |
| null; |
| |
| when First_Language_Indexes => |
| In_Project.Languages (Language) := Present; |
| |
| when others => |
| declare |
| Supp : Supp_Language; |
| Supp_Index : Supp_Language_Index := In_Project.Supp_Languages; |
| |
| begin |
| while Supp_Index /= No_Supp_Language_Index loop |
| Supp := Present_Languages.Table (Supp_Index); |
| |
| if Supp.Index = Language then |
| Present_Languages.Table (Supp_Index).Present := Present; |
| return; |
| end if; |
| |
| Supp_Index := Supp.Next; |
| end loop; |
| |
| Supp := (Index => Language, Present => Present, |
| Next => In_Project.Supp_Languages); |
| Present_Languages.Increment_Last; |
| Supp_Index := Present_Languages.Last; |
| Present_Languages.Table (Supp_Index) := Supp; |
| In_Project.Supp_Languages := Supp_Index; |
| end; |
| end case; |
| end Set; |
| |
| procedure Set |
| (Language_Processing : in Language_Processing_Data; |
| For_Language : Language_Index; |
| In_Project : in out Project_Data) |
| is |
| begin |
| case For_Language is |
| when No_Language_Index => |
| null; |
| |
| when First_Language_Indexes => |
| In_Project.First_Language_Processing (For_Language) := |
| Language_Processing; |
| |
| when others => |
| declare |
| Supp : Supp_Language_Data; |
| Supp_Index : Supp_Language_Index := |
| In_Project.Supp_Language_Processing; |
| |
| begin |
| while Supp_Index /= No_Supp_Language_Index loop |
| Supp := Supp_Languages.Table (Supp_Index); |
| |
| if Supp.Index = For_Language then |
| Supp_Languages.Table (Supp_Index).Data := |
| Language_Processing; |
| return; |
| end if; |
| |
| Supp_Index := Supp.Next; |
| end loop; |
| |
| Supp := (Index => For_Language, Data => Language_Processing, |
| Next => In_Project.Supp_Language_Processing); |
| Supp_Languages.Increment_Last; |
| Supp_Index := Supp_Languages.Last; |
| Supp_Languages.Table (Supp_Index) := Supp; |
| In_Project.Supp_Language_Processing := Supp_Index; |
| end; |
| end case; |
| end Set; |
| |
| procedure Set |
| (Suffix : Name_Id; |
| For_Language : Language_Index; |
| In_Project : in out Project_Data) |
| is |
| begin |
| case For_Language is |
| when No_Language_Index => |
| null; |
| |
| when First_Language_Indexes => |
| In_Project.Naming.Impl_Suffixes (For_Language) := Suffix; |
| |
| when others => |
| declare |
| Supp : Supp_Suffix; |
| Supp_Index : Supp_Language_Index := |
| In_Project.Naming.Supp_Suffixes; |
| |
| begin |
| while Supp_Index /= No_Supp_Language_Index loop |
| Supp := Supp_Suffix_Table.Table (Supp_Index); |
| |
| if Supp.Index = For_Language then |
| Supp_Suffix_Table.Table (Supp_Index).Suffix := Suffix; |
| return; |
| end if; |
| |
| Supp_Index := Supp.Next; |
| end loop; |
| |
| Supp := (Index => For_Language, Suffix => Suffix, |
| Next => In_Project.Naming.Supp_Suffixes); |
| Supp_Suffix_Table.Increment_Last; |
| Supp_Index := Supp_Suffix_Table.Last; |
| Supp_Suffix_Table.Table (Supp_Index) := Supp; |
| In_Project.Naming.Supp_Suffixes := Supp_Index; |
| end; |
| end case; |
| end Set; |
| |
| |
| -------------------------- |
| -- Standard_Naming_Data -- |
| -------------------------- |
| |
| function Standard_Naming_Data return Naming_Data is |
| begin |
| Prj.Initialize; |
| return Std_Naming_Data; |
| end Standard_Naming_Data; |
| |
| --------------- |
| -- Suffix_Of -- |
| --------------- |
| |
| function Suffix_Of |
| (Language : Language_Index; |
| In_Project : Project_Data) return Name_Id |
| is |
| begin |
| case Language is |
| when No_Language_Index => |
| return No_Name; |
| |
| when First_Language_Indexes => |
| return In_Project.Naming.Impl_Suffixes (Language); |
| |
| when others => |
| declare |
| Supp : Supp_Suffix; |
| Supp_Index : Supp_Language_Index := |
| In_Project.Naming.Supp_Suffixes; |
| |
| begin |
| while Supp_Index /= No_Supp_Language_Index loop |
| Supp := Supp_Suffix_Table.Table (Supp_Index); |
| |
| if Supp.Index = Language then |
| return Supp.Suffix; |
| end if; |
| |
| Supp_Index := Supp.Next; |
| end loop; |
| |
| return No_Name; |
| end; |
| end case; |
| end Suffix_Of; |
| |
| ----------- |
| -- Value -- |
| ----------- |
| |
| function Value (Image : String) return Casing_Type is |
| begin |
| for Casing in The_Casing_Images'Range loop |
| if To_Lower (Image) = To_Lower (The_Casing_Images (Casing).all) then |
| return Casing; |
| end if; |
| end loop; |
| |
| raise Constraint_Error; |
| end Value; |
| |
| begin |
| -- Make sure that the standard project file extension is compatible |
| -- with canonical case file naming. |
| |
| Canonical_Case_File_Name (Project_File_Extension); |
| end Prj; |
