------------------------------------------------------------------------------ -- -- -- 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 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.OS_Lib; use GNAT.OS_Lib; package body Prj is The_Empty_String : 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 := (Current_Language => No_Name, Dot_Replacement => Standard_Dot_Replacement, Dot_Repl_Loc => No_Location, Casing => All_Lower_Case, Spec_Suffix => No_Array_Element, Current_Spec_Suffix => No_Name, Spec_Suffix_Loc => No_Location, Body_Suffix => No_Array_Element, Current_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 := (Languages => No_Languages, Impl_Suffixes => No_Impl_Suffixes, 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, 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_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; ------------------- -- 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. 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; begin for Project in Projects.First .. Projects.Last loop Projects.Table (Project).Seen := False; end loop; Check (Project => By); end For_Every_Project_Imported; ----------- -- 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; for Lang in Programming_Language loop Name_Len := Lang_Names (Lang)'Length; Name_Buffer (1 .. Name_Len) := Lang_Names (Lang).all; Lang_Name_Ids (Lang) := Name_Find; Name_Len := Lang_Suffixes (Lang)'Length; Name_Buffer (1 .. Name_Len) := Lang_Suffixes (Lang).all; Lang_Suffix_Ids (Lang) := Name_Find; end loop; Std_Naming_Data.Current_Spec_Suffix := Default_Ada_Spec_Suffix; Std_Naming_Data.Current_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)); end if; end Initialize; ------------------------------------ -- 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.Current_Spec_Suffix = Right.Current_Spec_Suffix and then Left.Current_Body_Suffix = Right.Current_Body_Suffix and then Left.Separate_Suffix = Right.Separate_Suffix; end Same_Naming_Scheme; -------------------------- -- Standard_Naming_Data -- -------------------------- function Standard_Naming_Data return Naming_Data is begin Prj.Initialize; return Std_Naming_Data; end Standard_Naming_Data; ----------- -- 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;