URL
https://opencores.org/ocsvn/openrisc_2011-10-31/openrisc_2011-10-31/trunk
Subversion Repositories openrisc_2011-10-31
[/] [openrisc/] [tags/] [gnu-src/] [gcc-4.5.1/] [gcc-4.5.1-or32-1.0rc2/] [gcc/] [ada/] [prj-part.adb] - Rev 384
Compare with Previous | Blame | View Log
------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- P R J . P A R T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING3. If not, go to -- -- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ with Err_Vars; use Err_Vars; with Opt; use Opt; with Osint; use Osint; with Output; use Output; with Prj.Com; use Prj.Com; with Prj.Dect; with Prj.Err; use Prj.Err; with Prj.Ext; use Prj.Ext; with Sinput; use Sinput; with Sinput.P; use Sinput.P; with Snames; with Table; with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Exceptions; use Ada.Exceptions; with GNAT.Directory_Operations; use GNAT.Directory_Operations; with System.HTable; use System.HTable; package body Prj.Part is Buffer : String_Access; Buffer_Last : Natural := 0; Dir_Sep : Character renames GNAT.OS_Lib.Directory_Separator; ------------------------------------ -- Local Packages and Subprograms -- ------------------------------------ type With_Id is new Nat; No_With : constant With_Id := 0; type With_Record is record Path : Path_Name_Type; Location : Source_Ptr; Limited_With : Boolean; Node : Project_Node_Id; Next : With_Id; end record; -- Information about an imported project, to be put in table Withs below package Withs is new Table.Table (Table_Component_Type => With_Record, Table_Index_Type => With_Id, Table_Low_Bound => 1, Table_Initial => 10, Table_Increment => 100, Table_Name => "Prj.Part.Withs"); -- Table used to store temporarily paths and locations of imported -- projects. These imported projects will be effectively parsed later: just -- before parsing the current project for the non limited withed projects, -- after getting its name; after complete parsing of the current project -- for the limited withed projects. type Names_And_Id is record Path_Name : Path_Name_Type; Canonical_Path_Name : Path_Name_Type; Id : Project_Node_Id; Limited_With : Boolean; end record; package Project_Stack is new Table.Table (Table_Component_Type => Names_And_Id, Table_Index_Type => Nat, Table_Low_Bound => 1, Table_Initial => 10, Table_Increment => 100, Table_Name => "Prj.Part.Project_Stack"); -- This table is used to detect circular dependencies -- for imported and extended projects and to get the project ids of -- limited imported projects when there is a circularity with at least -- one limited imported project file. package Virtual_Hash is new System.HTable.Simple_HTable (Header_Num => Header_Num, Element => Project_Node_Id, No_Element => Empty_Node, Key => Project_Node_Id, Hash => Prj.Tree.Hash, Equal => "="); -- Hash table to store the node id of the project for which a virtual -- extending project need to be created. package Processed_Hash is new System.HTable.Simple_HTable (Header_Num => Header_Num, Element => Boolean, No_Element => False, Key => Project_Node_Id, Hash => Prj.Tree.Hash, Equal => "="); -- Hash table to store the project process when looking for project that -- need to have a virtual extending project, to avoid processing the same -- project twice. package Projects_Paths is new System.HTable.Simple_HTable (Header_Num => Header_Num, Element => Path_Name_Type, No_Element => No_Path, Key => Name_Id, Hash => Hash, Equal => "="); -- Hash table to cache project path to avoid looking for them on the path procedure Create_Virtual_Extending_Project (For_Project : Project_Node_Id; Main_Project : Project_Node_Id; In_Tree : Project_Node_Tree_Ref); -- Create a virtual extending project of For_Project. Main_Project is -- the extending all project. -- -- The String_Value_Of is not set for the automatically added with -- clause and keeps the default value of No_Name. This enables Prj.PP -- to skip these automatically added with clauses to be processed. procedure Look_For_Virtual_Projects_For (Proj : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; Potentially_Virtual : Boolean); -- Look for projects that need to have a virtual extending project. -- This procedure is recursive. If called with Potentially_Virtual set to -- True, then Proj may need an virtual extending project; otherwise it -- does not (because it is already extended), but other projects that it -- imports may need to be virtually extended. type Extension_Origin is (None, Extending_Simple, Extending_All); -- Type of parameter From_Extended for procedures Parse_Single_Project and -- Post_Parse_Context_Clause. Extending_All means that we are parsing the -- tree rooted at an extending all project. procedure Parse_Single_Project (In_Tree : Project_Node_Tree_Ref; Project : out Project_Node_Id; Extends_All : out Boolean; Path_Name : String; Extended : Boolean; From_Extended : Extension_Origin; In_Limited : Boolean; Packages_To_Check : String_List_Access; Depth : Natural; Current_Dir : String; Is_Config_File : Boolean; Flags : Processing_Flags); -- Parse a project file. This is a recursive procedure: it calls itself for -- imported and extended projects. When From_Extended is not None, if the -- project has already been parsed and is an extended project A, return the -- ultimate (not extended) project that extends A. When In_Limited is True, -- the importing path includes at least one "limited with". When parsing -- configuration projects, do not allow a depth > 1. -- -- Is_Config_File should be set to True if the project represents a config -- file (.cgpr) since some specific checks apply. procedure Pre_Parse_Context_Clause (In_Tree : Project_Node_Tree_Ref; Context_Clause : out With_Id; Is_Config_File : Boolean; Flags : Processing_Flags); -- Parse the context clause of a project. Store the paths and locations of -- the imported projects in table Withs. Does nothing if there is no -- context clause (if the current token is not "with" or "limited" followed -- by "with"). -- Is_Config_File should be set to True if the project represents a config -- file (.cgpr) since some specific checks apply. procedure Post_Parse_Context_Clause (Context_Clause : With_Id; In_Tree : Project_Node_Tree_Ref; Limited_Withs : Boolean; Imported_Projects : in out Project_Node_Id; Project_Directory : Path_Name_Type; From_Extended : Extension_Origin; In_Limited : Boolean; Packages_To_Check : String_List_Access; Depth : Natural; Current_Dir : String; Is_Config_File : Boolean; Flags : Processing_Flags); -- Parse the imported projects that have been stored in table Withs, if -- any. From_Extended is used for the call to Parse_Single_Project below. -- When In_Limited is True, the importing path includes at least one -- "limited with". When Limited_Withs is False, only non limited withed -- projects are parsed. When Limited_Withs is True, only limited withed -- projects are parsed. -- Is_Config_File should be set to True if the project represents a config -- file (.cgpr) since some specific checks apply. function Project_Path_Name_Of (In_Tree : Project_Node_Tree_Ref; Project_File_Name : String; Directory : String) return String; -- Returns the path name of a project file. Returns an empty string -- if project file cannot be found. function Project_Name_From (Path_Name : String; Is_Config_File : Boolean) return Name_Id; -- Returns the name of the project that corresponds to its path name. -- Returns No_Name if the path name is invalid, because the corresponding -- project name does not have the syntax of an ada identifier. -------------------------------------- -- Create_Virtual_Extending_Project -- -------------------------------------- procedure Create_Virtual_Extending_Project (For_Project : Project_Node_Id; Main_Project : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) is Virtual_Name : constant String := Virtual_Prefix & Get_Name_String (Name_Of (For_Project, In_Tree)); -- The name of the virtual extending project Virtual_Name_Id : Name_Id; -- Virtual extending project name id Virtual_Path_Id : Path_Name_Type; -- Fake path name of the virtual extending project. The directory is -- the same directory as the extending all project. -- The source of the virtual extending project is something like: -- project V$<project name> extends <project path> is -- for Source_Dirs use (); -- end V$<project name>; -- The project directory cannot be specified during parsing; it will be -- put directly in the virtual extending project data during processing. -- Nodes that made up the virtual extending project Virtual_Project : Project_Node_Id; With_Clause : constant Project_Node_Id := Default_Project_Node (In_Tree, N_With_Clause); Project_Declaration : Project_Node_Id; Source_Dirs_Declaration : constant Project_Node_Id := Default_Project_Node (In_Tree, N_Declarative_Item); Source_Dirs_Attribute : constant Project_Node_Id := Default_Project_Node (In_Tree, N_Attribute_Declaration, List); Source_Dirs_Expression : constant Project_Node_Id := Default_Project_Node (In_Tree, N_Expression, List); Source_Dirs_Term : constant Project_Node_Id := Default_Project_Node (In_Tree, N_Term, List); Source_Dirs_List : constant Project_Node_Id := Default_Project_Node (In_Tree, N_Literal_String_List, List); begin -- Get the virtual path name Get_Name_String (Path_Name_Of (Main_Project, In_Tree)); while Name_Len > 0 and then Name_Buffer (Name_Len) /= Directory_Separator and then Name_Buffer (Name_Len) /= '/' loop Name_Len := Name_Len - 1; end loop; Name_Buffer (Name_Len + 1 .. Name_Len + Virtual_Name'Length) := Virtual_Name; Name_Len := Name_Len + Virtual_Name'Length; Virtual_Path_Id := Name_Find; -- Get the virtual name id Name_Len := Virtual_Name'Length; Name_Buffer (1 .. Name_Len) := Virtual_Name; Virtual_Name_Id := Name_Find; Virtual_Project := Create_Project (In_Tree => In_Tree, Name => Virtual_Name_Id, Full_Path => Virtual_Path_Id, Is_Config_File => False); Project_Declaration := Project_Declaration_Of (Virtual_Project, In_Tree); -- With clause Set_Name_Of (With_Clause, In_Tree, Virtual_Name_Id); Set_Path_Name_Of (With_Clause, In_Tree, Virtual_Path_Id); Set_Project_Node_Of (With_Clause, In_Tree, Virtual_Project); Set_Next_With_Clause_Of (With_Clause, In_Tree, First_With_Clause_Of (Main_Project, In_Tree)); Set_First_With_Clause_Of (Main_Project, In_Tree, With_Clause); -- Virtual project node Set_Location_Of (Virtual_Project, In_Tree, Location_Of (Main_Project, In_Tree)); Set_Extended_Project_Path_Of (Virtual_Project, In_Tree, Path_Name_Of (For_Project, In_Tree)); -- Project declaration Set_First_Declarative_Item_Of (Project_Declaration, In_Tree, Source_Dirs_Declaration); Set_Extended_Project_Of (Project_Declaration, In_Tree, For_Project); -- Source_Dirs declaration Set_Current_Item_Node (Source_Dirs_Declaration, In_Tree, Source_Dirs_Attribute); -- Source_Dirs attribute Set_Name_Of (Source_Dirs_Attribute, In_Tree, Snames.Name_Source_Dirs); Set_Expression_Of (Source_Dirs_Attribute, In_Tree, Source_Dirs_Expression); -- Source_Dirs expression Set_First_Term (Source_Dirs_Expression, In_Tree, Source_Dirs_Term); -- Source_Dirs term Set_Current_Term (Source_Dirs_Term, In_Tree, Source_Dirs_List); -- Source_Dirs empty list: nothing to do end Create_Virtual_Extending_Project; ----------------------------------- -- Look_For_Virtual_Projects_For -- ----------------------------------- procedure Look_For_Virtual_Projects_For (Proj : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; Potentially_Virtual : Boolean) is Declaration : Project_Node_Id := Empty_Node; -- Node for the project declaration of Proj With_Clause : Project_Node_Id := Empty_Node; -- Node for a with clause of Proj Imported : Project_Node_Id := Empty_Node; -- Node for a project imported by Proj Extended : Project_Node_Id := Empty_Node; -- Node for the eventual project extended by Proj begin -- Nothing to do if Proj is not defined or if it has already been -- processed. if Present (Proj) and then not Processed_Hash.Get (Proj) then -- Make sure the project will not be processed again Processed_Hash.Set (Proj, True); Declaration := Project_Declaration_Of (Proj, In_Tree); if Present (Declaration) then Extended := Extended_Project_Of (Declaration, In_Tree); end if; -- If this is a project that may need a virtual extending project -- and it is not itself an extending project, put it in the list. if Potentially_Virtual and then No (Extended) then Virtual_Hash.Set (Proj, Proj); end if; -- Now check the projects it imports With_Clause := First_With_Clause_Of (Proj, In_Tree); while Present (With_Clause) loop Imported := Project_Node_Of (With_Clause, In_Tree); if Present (Imported) then Look_For_Virtual_Projects_For (Imported, In_Tree, Potentially_Virtual => True); end if; With_Clause := Next_With_Clause_Of (With_Clause, In_Tree); end loop; -- Check also the eventual project extended by Proj. As this project -- is already extended, call recursively with Potentially_Virtual -- being False. Look_For_Virtual_Projects_For (Extended, In_Tree, Potentially_Virtual => False); end if; end Look_For_Virtual_Projects_For; ----------- -- Parse -- ----------- procedure Parse (In_Tree : Project_Node_Tree_Ref; Project : out Project_Node_Id; Project_File_Name : String; Always_Errout_Finalize : Boolean; Packages_To_Check : String_List_Access := All_Packages; Store_Comments : Boolean := False; Current_Directory : String := ""; Is_Config_File : Boolean; Flags : Processing_Flags) is Dummy : Boolean; pragma Warnings (Off, Dummy); Real_Project_File_Name : String_Access := Osint.To_Canonical_File_Spec (Project_File_Name); begin if Real_Project_File_Name = null then Real_Project_File_Name := new String'(Project_File_Name); end if; Project := Empty_Node; Projects_Paths.Reset; if Current_Verbosity >= Medium then Write_Str ("GPR_PROJECT_PATH="""); Write_Str (Project_Path (In_Tree)); Write_Line (""""); end if; declare Path_Name : constant String := Project_Path_Name_Of (In_Tree, Real_Project_File_Name.all, Directory => Current_Directory); begin Free (Real_Project_File_Name); Prj.Err.Initialize; Prj.Err.Scanner.Set_Comment_As_Token (Store_Comments); Prj.Err.Scanner.Set_End_Of_Line_As_Token (Store_Comments); -- Parse the main project file if Path_Name = "" then Prj.Com.Fail ("project file """ & Project_File_Name & """ not found in " & Project_Path (In_Tree)); Project := Empty_Node; return; end if; begin Parse_Single_Project (In_Tree => In_Tree, Project => Project, Extends_All => Dummy, Path_Name => Path_Name, Extended => False, From_Extended => None, In_Limited => False, Packages_To_Check => Packages_To_Check, Depth => 0, Current_Dir => Current_Directory, Is_Config_File => Is_Config_File, Flags => Flags); exception when Types.Unrecoverable_Error => -- Unrecoverable_Error is raised when a line is too long. -- A meaningful error message will be displayed later. Project := Empty_Node; end; -- If Project is an extending-all project, create the eventual -- virtual extending projects and check that there are no illegally -- imported projects. if Present (Project) and then Is_Extending_All (Project, In_Tree) then -- First look for projects that potentially need a virtual -- extending project. Virtual_Hash.Reset; Processed_Hash.Reset; -- Mark the extending all project as processed, to avoid checking -- the imported projects in case of a "limited with" on this -- extending all project. Processed_Hash.Set (Project, True); declare Declaration : constant Project_Node_Id := Project_Declaration_Of (Project, In_Tree); begin Look_For_Virtual_Projects_For (Extended_Project_Of (Declaration, In_Tree), In_Tree, Potentially_Virtual => False); end; -- Now, check the projects directly imported by the main project. -- Remove from the potentially virtual any project extended by one -- of these imported projects. For non extending imported -- projects, check that they do not belong to the project tree of -- the project being "extended-all" by the main project. declare With_Clause : Project_Node_Id; Imported : Project_Node_Id := Empty_Node; Declaration : Project_Node_Id := Empty_Node; begin With_Clause := First_With_Clause_Of (Project, In_Tree); while Present (With_Clause) loop Imported := Project_Node_Of (With_Clause, In_Tree); if Present (Imported) then Declaration := Project_Declaration_Of (Imported, In_Tree); if Extended_Project_Of (Declaration, In_Tree) /= Empty_Node then loop Imported := Extended_Project_Of (Declaration, In_Tree); exit when No (Imported); Virtual_Hash.Remove (Imported); Declaration := Project_Declaration_Of (Imported, In_Tree); end loop; end if; end if; With_Clause := Next_With_Clause_Of (With_Clause, In_Tree); end loop; end; -- Now create all the virtual extending projects declare Proj : Project_Node_Id := Virtual_Hash.Get_First; begin while Present (Proj) loop Create_Virtual_Extending_Project (Proj, Project, In_Tree); Proj := Virtual_Hash.Get_Next; end loop; end; end if; -- If there were any kind of error during the parsing, serious -- or not, then the parsing fails. if Err_Vars.Total_Errors_Detected > 0 then Project := Empty_Node; end if; if No (Project) or else Always_Errout_Finalize then Prj.Err.Finalize; -- Reinitialize to avoid duplicate warnings later on Prj.Err.Initialize; end if; end; exception when X : others => -- Internal error Write_Line (Exception_Information (X)); Write_Str ("Exception "); Write_Str (Exception_Name (X)); Write_Line (" raised, while processing project file"); Project := Empty_Node; end Parse; ------------------------------ -- Pre_Parse_Context_Clause -- ------------------------------ procedure Pre_Parse_Context_Clause (In_Tree : Project_Node_Tree_Ref; Context_Clause : out With_Id; Is_Config_File : Boolean; Flags : Processing_Flags) is Current_With_Clause : With_Id := No_With; Limited_With : Boolean := False; Current_With : With_Record; Current_With_Node : Project_Node_Id := Empty_Node; begin -- Assume no context clause Context_Clause := No_With; With_Loop : -- If Token is not WITH or LIMITED, there is no context clause, or we -- have exhausted the with clauses. while Token = Tok_With or else Token = Tok_Limited loop Current_With_Node := Default_Project_Node (Of_Kind => N_With_Clause, In_Tree => In_Tree); Limited_With := Token = Tok_Limited; if Is_Config_File then Error_Msg (Flags, "configuration project cannot import " & "other configuration projects", Token_Ptr); end if; if Limited_With then Scan (In_Tree); -- scan past LIMITED Expect (Tok_With, "WITH"); exit With_Loop when Token /= Tok_With; end if; Comma_Loop : loop Scan (In_Tree); -- past WITH or "," Expect (Tok_String_Literal, "literal string"); if Token /= Tok_String_Literal then return; end if; -- Store path and location in table Withs Current_With := (Path => Path_Name_Type (Token_Name), Location => Token_Ptr, Limited_With => Limited_With, Node => Current_With_Node, Next => No_With); Withs.Increment_Last; Withs.Table (Withs.Last) := Current_With; if Current_With_Clause = No_With then Context_Clause := Withs.Last; else Withs.Table (Current_With_Clause).Next := Withs.Last; end if; Current_With_Clause := Withs.Last; Scan (In_Tree); if Token = Tok_Semicolon then Set_End_Of_Line (Current_With_Node); Set_Previous_Line_Node (Current_With_Node); -- End of (possibly multiple) with clause; Scan (In_Tree); -- past the semicolon exit Comma_Loop; elsif Token = Tok_Comma then Set_Is_Not_Last_In_List (Current_With_Node, In_Tree); else Error_Msg (Flags, "expected comma or semi colon", Token_Ptr); exit Comma_Loop; end if; Current_With_Node := Default_Project_Node (Of_Kind => N_With_Clause, In_Tree => In_Tree); end loop Comma_Loop; end loop With_Loop; end Pre_Parse_Context_Clause; ------------------------------- -- Post_Parse_Context_Clause -- ------------------------------- procedure Post_Parse_Context_Clause (Context_Clause : With_Id; In_Tree : Project_Node_Tree_Ref; Limited_Withs : Boolean; Imported_Projects : in out Project_Node_Id; Project_Directory : Path_Name_Type; From_Extended : Extension_Origin; In_Limited : Boolean; Packages_To_Check : String_List_Access; Depth : Natural; Current_Dir : String; Is_Config_File : Boolean; Flags : Processing_Flags) is Current_With_Clause : With_Id := Context_Clause; Current_Project : Project_Node_Id := Imported_Projects; Previous_Project : Project_Node_Id := Empty_Node; Next_Project : Project_Node_Id := Empty_Node; Project_Directory_Path : constant String := Get_Name_String (Project_Directory); Current_With : With_Record; Extends_All : Boolean := False; begin -- Set Current_Project to the last project in the current list, if the -- list is not empty. if Present (Current_Project) then while Present (Next_With_Clause_Of (Current_Project, In_Tree)) loop Current_Project := Next_With_Clause_Of (Current_Project, In_Tree); end loop; end if; while Current_With_Clause /= No_With loop Current_With := Withs.Table (Current_With_Clause); Current_With_Clause := Current_With.Next; if Limited_Withs = Current_With.Limited_With then declare Original_Path : constant String := Get_Name_String (Current_With.Path); Imported_Path_Name : constant String := Project_Path_Name_Of (In_Tree, Original_Path, Project_Directory_Path); Resolved_Path : constant String := Normalize_Pathname (Imported_Path_Name, Directory => Current_Dir, Resolve_Links => Opt.Follow_Links_For_Files, Case_Sensitive => True); Withed_Project : Project_Node_Id := Empty_Node; begin if Imported_Path_Name = "" then -- The project file cannot be found Error_Msg_File_1 := File_Name_Type (Current_With.Path); Error_Msg (Flags, "unknown project file: {", Current_With.Location); -- If this is not imported by the main project file, display -- the import path. if Project_Stack.Last > 1 then for Index in reverse 1 .. Project_Stack.Last loop Error_Msg_File_1 := File_Name_Type (Project_Stack.Table (Index).Path_Name); Error_Msg (Flags, "\imported by {", Current_With.Location); end loop; end if; else -- New with clause Previous_Project := Current_Project; if No (Current_Project) then -- First with clause of the context clause Current_Project := Current_With.Node; Imported_Projects := Current_Project; else Next_Project := Current_With.Node; Set_Next_With_Clause_Of (Current_Project, In_Tree, Next_Project); Current_Project := Next_Project; end if; Set_String_Value_Of (Current_Project, In_Tree, Name_Id (Current_With.Path)); Set_Location_Of (Current_Project, In_Tree, Current_With.Location); -- If it is a limited with, check if we have a circularity. -- If we have one, get the project id of the limited -- imported project file, and do not parse it. if Limited_Withs and then Project_Stack.Last > 1 then declare Canonical_Path_Name : Path_Name_Type; begin Name_Len := Resolved_Path'Length; Name_Buffer (1 .. Name_Len) := Resolved_Path; Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); Canonical_Path_Name := Name_Find; for Index in 1 .. Project_Stack.Last loop if Project_Stack.Table (Index).Canonical_Path_Name = Canonical_Path_Name then -- We have found the limited imported project, -- get its project id, and do not parse it. Withed_Project := Project_Stack.Table (Index).Id; exit; end if; end loop; end; end if; -- Parse the imported project, if its project id is unknown if No (Withed_Project) then Parse_Single_Project (In_Tree => In_Tree, Project => Withed_Project, Extends_All => Extends_All, Path_Name => Imported_Path_Name, Extended => False, From_Extended => From_Extended, In_Limited => Limited_Withs, Packages_To_Check => Packages_To_Check, Depth => Depth, Current_Dir => Current_Dir, Is_Config_File => Is_Config_File, Flags => Flags); else Extends_All := Is_Extending_All (Withed_Project, In_Tree); end if; if No (Withed_Project) then -- If parsing unsuccessful, remove the context clause Current_Project := Previous_Project; if No (Current_Project) then Imported_Projects := Empty_Node; else Set_Next_With_Clause_Of (Current_Project, In_Tree, Empty_Node); end if; else -- If parsing was successful, record project name and -- path name in with clause Set_Project_Node_Of (Node => Current_Project, In_Tree => In_Tree, To => Withed_Project, Limited_With => Current_With.Limited_With); Set_Name_Of (Current_Project, In_Tree, Name_Of (Withed_Project, In_Tree)); Name_Len := Resolved_Path'Length; Name_Buffer (1 .. Name_Len) := Resolved_Path; Set_Path_Name_Of (Current_Project, In_Tree, Name_Find); if Extends_All then Set_Is_Extending_All (Current_Project, In_Tree); end if; end if; end if; end; end if; end loop; end Post_Parse_Context_Clause; -------------------------- -- Parse_Single_Project -- -------------------------- procedure Parse_Single_Project (In_Tree : Project_Node_Tree_Ref; Project : out Project_Node_Id; Extends_All : out Boolean; Path_Name : String; Extended : Boolean; From_Extended : Extension_Origin; In_Limited : Boolean; Packages_To_Check : String_List_Access; Depth : Natural; Current_Dir : String; Is_Config_File : Boolean; Flags : Processing_Flags) is Normed_Path_Name : Path_Name_Type; Canonical_Path_Name : Path_Name_Type; Project_Directory : Path_Name_Type; Project_Scan_State : Saved_Project_Scan_State; Source_Index : Source_File_Index; Extending : Boolean := False; Extended_Project : Project_Node_Id := Empty_Node; A_Project_Name_And_Node : Tree_Private_Part.Project_Name_And_Node := Tree_Private_Part.Projects_Htable.Get_First (In_Tree.Projects_HT); Name_From_Path : constant Name_Id := Project_Name_From (Path_Name, Is_Config_File => Is_Config_File); Name_Of_Project : Name_Id := No_Name; Display_Name_Of_Project : Name_Id := No_Name; Duplicated : Boolean := False; First_With : With_Id; Imported_Projects : Project_Node_Id := Empty_Node; use Tree_Private_Part; Project_Comment_State : Tree.Comment_State; Proj_Qualifier : Project_Qualifier := Unspecified; Qualifier_Location : Source_Ptr; begin Extends_All := False; declare Normed_Path : constant String := Normalize_Pathname (Path_Name, Directory => Current_Dir, Resolve_Links => False, Case_Sensitive => True); Canonical_Path : constant String := Normalize_Pathname (Normed_Path, Directory => Current_Dir, Resolve_Links => Opt.Follow_Links_For_Files, Case_Sensitive => False); begin Name_Len := Normed_Path'Length; Name_Buffer (1 .. Name_Len) := Normed_Path; Normed_Path_Name := Name_Find; Name_Len := Canonical_Path'Length; Name_Buffer (1 .. Name_Len) := Canonical_Path; Canonical_Path_Name := Name_Find; end; -- Check for a circular dependency for Index in reverse 1 .. Project_Stack.Last loop exit when Project_Stack.Table (Index).Limited_With; if Canonical_Path_Name = Project_Stack.Table (Index).Canonical_Path_Name then Error_Msg (Flags, "circular dependency detected", Token_Ptr); Error_Msg_Name_1 := Name_Id (Normed_Path_Name); Error_Msg (Flags, "\ %% is imported by", Token_Ptr); for Current in reverse 1 .. Project_Stack.Last loop Error_Msg_Name_1 := Name_Id (Project_Stack.Table (Current).Path_Name); if Project_Stack.Table (Current).Canonical_Path_Name /= Canonical_Path_Name then Error_Msg (Flags, "\ %% which itself is imported by", Token_Ptr); else Error_Msg (Flags, "\ %%", Token_Ptr); exit; end if; end loop; Project := Empty_Node; return; end if; end loop; -- Put the new path name on the stack Project_Stack.Append ((Path_Name => Normed_Path_Name, Canonical_Path_Name => Canonical_Path_Name, Id => Empty_Node, Limited_With => In_Limited)); -- Check if the project file has already been parsed while A_Project_Name_And_Node /= Tree_Private_Part.No_Project_Name_And_Node loop if A_Project_Name_And_Node.Canonical_Path = Canonical_Path_Name then if Extended then if A_Project_Name_And_Node.Extended then if A_Project_Name_And_Node.Proj_Qualifier /= Dry then Error_Msg (Flags, "cannot extend the same project file several times", Token_Ptr); end if; else Error_Msg (Flags, "cannot extend an already imported project file", Token_Ptr); end if; elsif A_Project_Name_And_Node.Extended then Extends_All := Is_Extending_All (A_Project_Name_And_Node.Node, In_Tree); -- If the imported project is an extended project A, and we are -- in an extended project, replace A with the ultimate project -- extending A. if From_Extended /= None then declare Decl : Project_Node_Id := Project_Declaration_Of (A_Project_Name_And_Node.Node, In_Tree); Prj : Project_Node_Id := A_Project_Name_And_Node.Node; begin -- Loop through extending projects to find the ultimate -- extending project, that is the one that is not -- extended. For an abstract project, as it can be -- extended several times, there is no extending project -- registered, so the loop does not execute and the -- resulting project is the abstract project. while Extending_Project_Of (Decl, In_Tree) /= Empty_Node loop Prj := Extending_Project_Of (Decl, In_Tree); Decl := Project_Declaration_Of (Prj, In_Tree); end loop; A_Project_Name_And_Node.Node := Prj; end; else Error_Msg (Flags, "cannot import an already extended project file", Token_Ptr); end if; end if; Project := A_Project_Name_And_Node.Node; Project_Stack.Decrement_Last; return; end if; A_Project_Name_And_Node := Tree_Private_Part.Projects_Htable.Get_Next (In_Tree.Projects_HT); end loop; -- We never encountered this project file. Save the scan state, load the -- project file and start to scan it. Save_Project_Scan_State (Project_Scan_State); Source_Index := Load_Project_File (Path_Name); Tree.Save (Project_Comment_State); -- If we cannot find it, we stop if Source_Index = No_Source_File then Project := Empty_Node; Project_Stack.Decrement_Last; return; end if; Prj.Err.Scanner.Initialize_Scanner (Source_Index); Tree.Reset_State; Scan (In_Tree); if not Is_Config_File and then Name_From_Path = No_Name then -- The project file name is not correct (no or bad extension, or not -- following Ada identifier's syntax). Error_Msg_File_1 := File_Name_Type (Canonical_Path_Name); Error_Msg (Flags, "?{ is not a valid path name for a project file", Token_Ptr); end if; if Current_Verbosity >= Medium then Write_Str ("Parsing """); Write_Str (Path_Name); Write_Char ('"'); Write_Eol; end if; Project_Directory := Path_Name_Type (Get_Directory (File_Name_Type (Normed_Path_Name))); -- Is there any imported project? Pre_Parse_Context_Clause (In_Tree => In_Tree, Is_Config_File => Is_Config_File, Context_Clause => First_With, Flags => Flags); Project := Default_Project_Node (Of_Kind => N_Project, In_Tree => In_Tree); Project_Stack.Table (Project_Stack.Last).Id := Project; Set_Directory_Of (Project, In_Tree, Project_Directory); Set_Path_Name_Of (Project, In_Tree, Normed_Path_Name); -- Check if there is a qualifier before the reserved word "project" Qualifier_Location := Token_Ptr; if Token = Tok_Abstract then Proj_Qualifier := Dry; Scan (In_Tree); elsif Token = Tok_Identifier then case Token_Name is when Snames.Name_Standard => Proj_Qualifier := Standard; Scan (In_Tree); when Snames.Name_Aggregate => Proj_Qualifier := Aggregate; Scan (In_Tree); if Token = Tok_Identifier and then Token_Name = Snames.Name_Library then Proj_Qualifier := Aggregate_Library; Scan (In_Tree); end if; when Snames.Name_Library => Proj_Qualifier := Library; Scan (In_Tree); when Snames.Name_Configuration => if not Is_Config_File then Error_Msg (Flags, "configuration projects cannot belong to a user" & " project tree", Token_Ptr); end if; Proj_Qualifier := Configuration; Scan (In_Tree); when others => null; end case; end if; if Is_Config_File and then Proj_Qualifier = Unspecified then -- Set the qualifier to Configuration, even if the token doesn't -- exist in the source file itself, so that we can differentiate -- project files and configuration files later on. Proj_Qualifier := Configuration; end if; if Proj_Qualifier /= Unspecified then if Is_Config_File and then Proj_Qualifier /= Configuration then Error_Msg (Flags, "a configuration project cannot be qualified except " & "as configuration project", Qualifier_Location); end if; Set_Project_Qualifier_Of (Project, In_Tree, Proj_Qualifier); end if; Set_Location_Of (Project, In_Tree, Token_Ptr); Expect (Tok_Project, "PROJECT"); -- Mark location of PROJECT token if present if Token = Tok_Project then Scan (In_Tree); -- past PROJECT Set_Location_Of (Project, In_Tree, Token_Ptr); end if; -- Clear the Buffer Buffer_Last := 0; loop Expect (Tok_Identifier, "identifier"); -- If the token is not an identifier, clear the buffer before -- exiting to indicate that the name of the project is ill-formed. if Token /= Tok_Identifier then Buffer_Last := 0; exit; end if; -- Add the identifier name to the buffer Get_Name_String (Token_Name); Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last); -- Scan past the identifier Scan (In_Tree); -- If we have a dot, add a dot to the Buffer and look for the next -- identifier. exit when Token /= Tok_Dot; Add_To_Buffer (".", Buffer, Buffer_Last); -- Scan past the dot Scan (In_Tree); end loop; -- See if this is an extending project if Token = Tok_Extends then if Is_Config_File then Error_Msg (Flags, "extending configuration project not allowed", Token_Ptr); end if; -- Make sure that gnatmake will use mapping files Create_Mapping_File := True; -- We are extending another project Extending := True; Scan (In_Tree); -- past EXTENDS if Token = Tok_All then Extends_All := True; Set_Is_Extending_All (Project, In_Tree); Scan (In_Tree); -- scan past ALL end if; end if; -- If the name is well formed, Buffer_Last is > 0 if Buffer_Last > 0 then -- The Buffer contains the name of the project Name_Len := Buffer_Last; Name_Buffer (1 .. Name_Len) := Buffer (1 .. Buffer_Last); Name_Of_Project := Name_Find; Set_Name_Of (Project, In_Tree, Name_Of_Project); -- To get expected name of the project file, replace dots by dashes for Index in 1 .. Name_Len loop if Name_Buffer (Index) = '.' then Name_Buffer (Index) := '-'; end if; end loop; Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); declare Expected_Name : constant Name_Id := Name_Find; Extension : String_Access; begin -- Output a warning if the actual name is not the expected name if not Is_Config_File and then (Name_From_Path /= No_Name) and then Expected_Name /= Name_From_Path then Error_Msg_Name_1 := Expected_Name; if Is_Config_File then Extension := new String'(Config_Project_File_Extension); else Extension := new String'(Project_File_Extension); end if; Error_Msg (Flags, "?file name does not match project name, should be `%%" & Extension.all & "`", Token_Ptr); end if; end; -- Read the original casing of the project name declare Loc : Source_Ptr; begin Loc := Location_Of (Project, In_Tree); for J in 1 .. Name_Len loop Name_Buffer (J) := Sinput.Source (Loc); Loc := Loc + 1; end loop; Display_Name_Of_Project := Name_Find; end; declare From_Ext : Extension_Origin := None; begin -- Extending_All is always propagated if From_Extended = Extending_All or else Extends_All then From_Ext := Extending_All; -- Otherwise, From_Extended is set to Extending_Single if the -- current project is an extending project. elsif Extended then From_Ext := Extending_Simple; end if; Post_Parse_Context_Clause (In_Tree => In_Tree, Context_Clause => First_With, Limited_Withs => False, Imported_Projects => Imported_Projects, Project_Directory => Project_Directory, From_Extended => From_Ext, In_Limited => In_Limited, Packages_To_Check => Packages_To_Check, Depth => Depth + 1, Current_Dir => Current_Dir, Is_Config_File => Is_Config_File, Flags => Flags); Set_First_With_Clause_Of (Project, In_Tree, Imported_Projects); end; if not Is_Config_File then declare Name_And_Node : Tree_Private_Part.Project_Name_And_Node := Tree_Private_Part.Projects_Htable.Get_First (In_Tree.Projects_HT); Project_Name : Name_Id := Name_And_Node.Name; begin -- Check if we already have a project with this name while Project_Name /= No_Name and then Project_Name /= Name_Of_Project loop Name_And_Node := Tree_Private_Part.Projects_Htable.Get_Next (In_Tree.Projects_HT); Project_Name := Name_And_Node.Name; end loop; -- Report an error if we already have a project with this name if Project_Name /= No_Name then Duplicated := True; Error_Msg_Name_1 := Project_Name; Error_Msg (Flags, "duplicate project name %%", Location_Of (Project, In_Tree)); Error_Msg_Name_1 := Name_Id (Path_Name_Of (Name_And_Node.Node, In_Tree)); Error_Msg (Flags, "\already in %%", Location_Of (Project, In_Tree)); end if; end; end if; end if; if Extending then Expect (Tok_String_Literal, "literal string"); if Token = Tok_String_Literal then Set_Extended_Project_Path_Of (Project, In_Tree, Path_Name_Type (Token_Name)); declare Original_Path_Name : constant String := Get_Name_String (Token_Name); Extended_Project_Path_Name : constant String := Project_Path_Name_Of (In_Tree, Original_Path_Name, Get_Name_String (Project_Directory)); begin if Extended_Project_Path_Name = "" then -- We could not find the project file to extend Error_Msg_Name_1 := Token_Name; Error_Msg (Flags, "unknown project file: %%", Token_Ptr); -- If we are not in the main project file, display the -- import path. if Project_Stack.Last > 1 then Error_Msg_Name_1 := Name_Id (Project_Stack.Table (Project_Stack.Last).Path_Name); Error_Msg (Flags, "\extended by %%", Token_Ptr); for Index in reverse 1 .. Project_Stack.Last - 1 loop Error_Msg_Name_1 := Name_Id (Project_Stack.Table (Index).Path_Name); Error_Msg (Flags, "\imported by %%", Token_Ptr); end loop; end if; else declare From_Ext : Extension_Origin := None; begin if From_Extended = Extending_All or else Extends_All then From_Ext := Extending_All; end if; Parse_Single_Project (In_Tree => In_Tree, Project => Extended_Project, Extends_All => Extends_All, Path_Name => Extended_Project_Path_Name, Extended => True, From_Extended => From_Ext, In_Limited => In_Limited, Packages_To_Check => Packages_To_Check, Depth => Depth + 1, Current_Dir => Current_Dir, Is_Config_File => Is_Config_File, Flags => Flags); end; if Present (Extended_Project) then -- A project that extends an extending-all project is -- also an extending-all project. if Is_Extending_All (Extended_Project, In_Tree) then Set_Is_Extending_All (Project, In_Tree); end if; -- An abstract project can only extend an abstract -- project, otherwise we may have an abstract project -- with sources, if it inherits sources from the project -- it extends. if Proj_Qualifier = Dry and then Project_Qualifier_Of (Extended_Project, In_Tree) /= Dry then Error_Msg (Flags, "an abstract project can only extend " & "another abstract project", Qualifier_Location); end if; end if; end if; end; Scan (In_Tree); -- past the extended project path end if; end if; -- Check that a non extending-all project does not import an -- extending-all project. if not Is_Extending_All (Project, In_Tree) then declare With_Clause : Project_Node_Id := First_With_Clause_Of (Project, In_Tree); Imported : Project_Node_Id := Empty_Node; begin With_Clause_Loop : while Present (With_Clause) loop Imported := Project_Node_Of (With_Clause, In_Tree); if Is_Extending_All (With_Clause, In_Tree) then Error_Msg_Name_1 := Name_Of (Imported, In_Tree); Error_Msg (Flags, "cannot import extending-all project %%", Token_Ptr); exit With_Clause_Loop; end if; With_Clause := Next_With_Clause_Of (With_Clause, In_Tree); end loop With_Clause_Loop; end; end if; -- Check that a project with a name including a dot either imports -- or extends the project whose name precedes the last dot. if Name_Of_Project /= No_Name then Get_Name_String (Name_Of_Project); else Name_Len := 0; end if; -- Look for the last dot while Name_Len > 0 and then Name_Buffer (Name_Len) /= '.' loop Name_Len := Name_Len - 1; end loop; -- If a dot was find, check if the parent project is imported -- or extended. if Name_Len > 0 then Name_Len := Name_Len - 1; declare Parent_Name : constant Name_Id := Name_Find; Parent_Found : Boolean := False; Parent_Node : Project_Node_Id := Empty_Node; With_Clause : Project_Node_Id := First_With_Clause_Of (Project, In_Tree); begin -- If there is an extended project, check its name if Present (Extended_Project) then Parent_Node := Extended_Project; Parent_Found := Name_Of (Extended_Project, In_Tree) = Parent_Name; end if; -- If the parent project is not the extended project, -- check each imported project until we find the parent project. while not Parent_Found and then Present (With_Clause) loop Parent_Node := Project_Node_Of (With_Clause, In_Tree); Parent_Found := Name_Of (Parent_Node, In_Tree) = Parent_Name; With_Clause := Next_With_Clause_Of (With_Clause, In_Tree); end loop; if Parent_Found then Set_Parent_Project_Of (Project, In_Tree, To => Parent_Node); else -- If the parent project was not found, report an error Error_Msg_Name_1 := Name_Of_Project; Error_Msg_Name_2 := Parent_Name; Error_Msg (Flags, "project %% does not import or extend project %%", Location_Of (Project, In_Tree)); end if; end; end if; Expect (Tok_Is, "IS"); Set_End_Of_Line (Project); Set_Previous_Line_Node (Project); Set_Next_End_Node (Project); declare Project_Declaration : Project_Node_Id := Empty_Node; begin -- No need to Scan past "is", Prj.Dect.Parse will do it Prj.Dect.Parse (In_Tree => In_Tree, Declarations => Project_Declaration, Current_Project => Project, Extends => Extended_Project, Packages_To_Check => Packages_To_Check, Is_Config_File => Is_Config_File, Flags => Flags); Set_Project_Declaration_Of (Project, In_Tree, Project_Declaration); if Present (Extended_Project) and then Project_Qualifier_Of (Extended_Project, In_Tree) /= Dry then Set_Extending_Project_Of (Project_Declaration_Of (Extended_Project, In_Tree), In_Tree, To => Project); end if; end; Expect (Tok_End, "END"); Remove_Next_End_Node; -- Skip "end" if present if Token = Tok_End then Scan (In_Tree); end if; -- Clear the Buffer Buffer_Last := 0; -- Store the name following "end" in the Buffer. The name may be made of -- several simple names. loop Expect (Tok_Identifier, "identifier"); -- If we don't have an identifier, clear the buffer before exiting to -- avoid checking the name. if Token /= Tok_Identifier then Buffer_Last := 0; exit; end if; -- Add the identifier to the Buffer Get_Name_String (Token_Name); Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last); -- Scan past the identifier Scan (In_Tree); exit when Token /= Tok_Dot; Add_To_Buffer (".", Buffer, Buffer_Last); Scan (In_Tree); end loop; -- If we have a valid name, check if it is the name of the project if Name_Of_Project /= No_Name and then Buffer_Last > 0 then if To_Lower (Buffer (1 .. Buffer_Last)) /= Get_Name_String (Name_Of (Project, In_Tree)) then -- Invalid name: report an error Error_Msg (Flags, "expected """ & Get_Name_String (Name_Of (Project, In_Tree)) & """", Token_Ptr); end if; end if; Expect (Tok_Semicolon, "`;`"); -- Check that there is no more text following the end of the project -- source. if Token = Tok_Semicolon then Set_Previous_End_Node (Project); Scan (In_Tree); if Token /= Tok_EOF then Error_Msg (Flags, "unexpected text following end of project", Token_Ptr); end if; end if; if not Duplicated and then Name_Of_Project /= No_Name then -- Add the name of the project to the hash table, so that we can -- check that no other subsequent project will have the same name. Tree_Private_Part.Projects_Htable.Set (T => In_Tree.Projects_HT, K => Name_Of_Project, E => (Name => Name_Of_Project, Display_Name => Display_Name_Of_Project, Node => Project, Canonical_Path => Canonical_Path_Name, Extended => Extended, Proj_Qualifier => Proj_Qualifier)); end if; declare From_Ext : Extension_Origin := None; begin -- Extending_All is always propagated if From_Extended = Extending_All or else Extends_All then From_Ext := Extending_All; -- Otherwise, From_Extended is set to Extending_Single if the -- current project is an extending project. elsif Extended then From_Ext := Extending_Simple; end if; Post_Parse_Context_Clause (In_Tree => In_Tree, Context_Clause => First_With, Limited_Withs => True, Imported_Projects => Imported_Projects, Project_Directory => Project_Directory, From_Extended => From_Ext, In_Limited => In_Limited, Packages_To_Check => Packages_To_Check, Depth => Depth + 1, Current_Dir => Current_Dir, Is_Config_File => Is_Config_File, Flags => Flags); Set_First_With_Clause_Of (Project, In_Tree, Imported_Projects); end; -- Restore the scan state, in case we are not the main project Restore_Project_Scan_State (Project_Scan_State); -- And remove the project from the project stack Project_Stack.Decrement_Last; -- Indicate if there are unkept comments Tree.Set_Project_File_Includes_Unkept_Comments (Node => Project, In_Tree => In_Tree, To => Tree.There_Are_Unkept_Comments); -- And restore the comment state that was saved Tree.Restore_And_Free (Project_Comment_State); end Parse_Single_Project; ----------------------- -- Project_Name_From -- ----------------------- function Project_Name_From (Path_Name : String; Is_Config_File : Boolean) return Name_Id is Canonical : String (1 .. Path_Name'Length) := Path_Name; First : Natural := Canonical'Last; Last : Natural := First; Index : Positive; begin if Current_Verbosity = High then Write_Str ("Project_Name_From ("""); Write_Str (Canonical); Write_Line (""")"); end if; -- If the path name is empty, return No_Name to indicate failure if First = 0 then return No_Name; end if; Canonical_Case_File_Name (Canonical); -- Look for the last dot in the path name while First > 0 and then Canonical (First) /= '.' loop First := First - 1; end loop; -- If we have a dot, check that it is followed by the correct extension if First > 0 and then Canonical (First) = '.' then if (not Is_Config_File and then Canonical (First .. Last) = Project_File_Extension and then First /= 1) or else (Is_Config_File and then Canonical (First .. Last) = Config_Project_File_Extension and then First /= 1) then -- Look for the last directory separator, if any First := First - 1; Last := First; while First > 0 and then Canonical (First) /= '/' and then Canonical (First) /= Dir_Sep loop First := First - 1; end loop; else -- Not the correct extension, return No_Name to indicate failure return No_Name; end if; -- If no dot in the path name, return No_Name to indicate failure else return No_Name; end if; First := First + 1; -- If the extension is the file name, return No_Name to indicate failure if First > Last then return No_Name; end if; -- Put the name in lower case into Name_Buffer Name_Len := Last - First + 1; Name_Buffer (1 .. Name_Len) := To_Lower (Canonical (First .. Last)); Index := 1; -- Check if it is a well formed project name. Return No_Name if it is -- ill formed. loop if not Is_Letter (Name_Buffer (Index)) then return No_Name; else loop Index := Index + 1; exit when Index >= Name_Len; if Name_Buffer (Index) = '_' then if Name_Buffer (Index + 1) = '_' then return No_Name; end if; end if; exit when Name_Buffer (Index) = '-'; if Name_Buffer (Index) /= '_' and then not Is_Alphanumeric (Name_Buffer (Index)) then return No_Name; end if; end loop; end if; if Index >= Name_Len then if Is_Alphanumeric (Name_Buffer (Name_Len)) then -- All checks have succeeded. Return name in Name_Buffer return Name_Find; else return No_Name; end if; elsif Name_Buffer (Index) = '-' then Index := Index + 1; end if; end loop; end Project_Name_From; -------------------------- -- Project_Path_Name_Of -- -------------------------- function Project_Path_Name_Of (In_Tree : Project_Node_Tree_Ref; Project_File_Name : String; Directory : String) return String is function Try_Path_Name (Path : String) return String_Access; pragma Inline (Try_Path_Name); -- Try the specified Path ------------------- -- Try_Path_Name -- ------------------- function Try_Path_Name (Path : String) return String_Access is Prj_Path : constant String := Project_Path (In_Tree); First : Natural; Last : Natural; Result : String_Access := null; begin if Current_Verbosity = High then Write_Str (" Trying "); Write_Line (Path); end if; if Is_Absolute_Path (Path) then if Is_Regular_File (Path) then Result := new String'(Path); end if; else -- Because we don't want to resolve symbolic links, we cannot use -- Locate_Regular_File. So, we try each possible path -- successively. First := Prj_Path'First; while First <= Prj_Path'Last loop while First <= Prj_Path'Last and then Prj_Path (First) = Path_Separator loop First := First + 1; end loop; exit when First > Prj_Path'Last; Last := First; while Last < Prj_Path'Last and then Prj_Path (Last + 1) /= Path_Separator loop Last := Last + 1; end loop; Name_Len := 0; if not Is_Absolute_Path (Prj_Path (First .. Last)) then Add_Str_To_Name_Buffer (Get_Current_Dir); Add_Char_To_Name_Buffer (Directory_Separator); end if; Add_Str_To_Name_Buffer (Prj_Path (First .. Last)); Add_Char_To_Name_Buffer (Directory_Separator); Add_Str_To_Name_Buffer (Path); if Is_Regular_File (Name_Buffer (1 .. Name_Len)) then Result := new String'(Name_Buffer (1 .. Name_Len)); exit; end if; First := Last + 1; end loop; end if; return Result; end Try_Path_Name; -- Local Declarations Result : String_Access; Result_Id : Path_Name_Type; Has_Dot : Boolean := False; Key : Name_Id; -- Start of processing for Project_Path_Name_Of begin if Current_Verbosity = High then Write_Str ("Project_Path_Name_Of ("""); Write_Str (Project_File_Name); Write_Str (""", """); Write_Str (Directory); Write_Line (""");"); end if; -- Check the project cache Name_Len := Project_File_Name'Length; Name_Buffer (1 .. Name_Len) := Project_File_Name; Key := Name_Find; Result_Id := Projects_Paths.Get (Key); if Result_Id /= No_Path then return Get_Name_String (Result_Id); end if; -- Check if Project_File_Name contains an extension (a dot before a -- directory separator). If it is the case we do not try project file -- with an added extension as it is not possible to have multiple dots -- on a project file name. Check_Dot : for K in reverse Project_File_Name'Range loop if Project_File_Name (K) = '.' then Has_Dot := True; exit Check_Dot; end if; exit Check_Dot when Project_File_Name (K) = Directory_Separator or else Project_File_Name (K) = '/'; end loop Check_Dot; if not Is_Absolute_Path (Project_File_Name) then -- First we try <directory>/<file_name>.<extension> if not Has_Dot then Result := Try_Path_Name (Directory & Directory_Separator & Project_File_Name & Project_File_Extension); end if; -- Then we try <directory>/<file_name> if Result = null then Result := Try_Path_Name (Directory & Directory_Separator & Project_File_Name); end if; end if; -- Then we try <file_name>.<extension> if Result = null and then not Has_Dot then Result := Try_Path_Name (Project_File_Name & Project_File_Extension); end if; -- Then we try <file_name> if Result = null then Result := Try_Path_Name (Project_File_Name); end if; -- If we cannot find the project file, we return an empty string if Result = null then return ""; else declare Final_Result : constant String := GNAT.OS_Lib.Normalize_Pathname (Result.all, Directory => Directory, Resolve_Links => Opt.Follow_Links_For_Files, Case_Sensitive => True); begin Free (Result); Name_Len := Final_Result'Length; Name_Buffer (1 .. Name_Len) := Final_Result; Result_Id := Name_Find; Projects_Paths.Set (Key, Result_Id); return Final_Result; end; end if; end Project_Path_Name_Of; end Prj.Part;