| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- P R J . P A R T -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 2001-2012, 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 Atree; use Atree; |
| 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.Env; use Prj.Env; |
| with Prj.Err; use Prj.Err; |
| 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.HTable; use GNAT.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 GNAT.HTable.Simple_HTable |
| (Header_Num => Header_Num, |
| Element => Project_Node_Id, |
| No_Element => Project_Node_High_Bound, |
| Key => Project_Node_Id, |
| Hash => Prj.Tree.Hash, |
| Equal => "="); |
| -- Hash table to store the node ids of projects for which a virtual |
| -- extending project need to be created. The corresponding value is the |
| -- head of a list of WITH clauses corresponding to the context of the |
| -- enclosing EXTEND ALL projects. Note: Default_Element is Project_Node_ |
| -- High_Bound because we want Empty_Node to be a possible value. |
| |
| package Processed_Hash is new GNAT.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. |
| |
| function Has_Circular_Dependencies |
| (Flags : Processing_Flags; |
| Normed_Path_Name : Path_Name_Type; |
| Canonical_Path_Name : Path_Name_Type) return Boolean; |
| -- Check for a circular dependency in the loaded project. |
| -- Generates an error message in such a case. |
| |
| procedure Read_Project_Qualifier |
| (Flags : Processing_Flags; |
| In_Tree : Project_Node_Tree_Ref; |
| Is_Config_File : Boolean; |
| Qualifier_Location : out Source_Ptr; |
| Project : Project_Node_Id); |
| -- Check if there is a qualifier before the reserved word "project" |
| |
| -- Hash table to cache project path to avoid looking for them on the path |
| |
| procedure Check_Extending_All_Imports |
| (Flags : Processing_Flags; |
| In_Tree : Project_Node_Tree_Ref; |
| Project : Project_Node_Id); |
| -- Check that a non extending-all project does not import an |
| -- extending-all project. |
| |
| procedure Check_Aggregate_Imports |
| (Flags : Processing_Flags; |
| In_Tree : Project_Node_Tree_Ref; |
| Project : Project_Node_Id); |
| -- Check that an aggregate project only imports abstract projects |
| |
| procedure Create_Virtual_Extending_Project |
| (For_Project : Project_Node_Id; |
| Main_Project : Project_Node_Id; |
| Extension_Withs : Project_Node_Id; |
| In_Tree : Project_Node_Tree_Ref); |
| -- Create a virtual extending project of For_Project. Main_Project is |
| -- the extending all project. Extension_Withs is the head of a WITH clause |
| -- list to be added to the created virtual 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_Id : Path_Name_Type; |
| Extended : Boolean; |
| From_Extended : Extension_Origin; |
| In_Limited : Boolean; |
| Packages_To_Check : String_List_Access; |
| Depth : Natural; |
| Current_Dir : String; |
| Is_Config_File : Boolean; |
| Env : in out Environment); |
| -- 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; |
| In_Limited : Boolean; |
| Limited_Withs : Boolean; |
| Imported_Projects : in out Project_Node_Id; |
| Project_Directory : Path_Name_Type; |
| From_Extended : Extension_Origin; |
| Packages_To_Check : String_List_Access; |
| Depth : Natural; |
| Current_Dir : String; |
| Is_Config_File : Boolean; |
| Env : in out Environment); |
| -- 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_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. |
| |
| function Copy_With_Clause |
| (With_Clause : Project_Node_Id; |
| In_Tree : Project_Node_Tree_Ref; |
| Next_Clause : Project_Node_Id) return Project_Node_Id; |
| -- Return a copy of With_Clause in In_Tree, whose Next_With_Clause is the |
| -- indicated one. |
| |
| ---------------------- |
| -- Copy_With_Clause -- |
| ---------------------- |
| |
| function Copy_With_Clause |
| (With_Clause : Project_Node_Id; |
| In_Tree : Project_Node_Tree_Ref; |
| Next_Clause : Project_Node_Id) return Project_Node_Id |
| is |
| New_With_Clause : constant Project_Node_Id := |
| Default_Project_Node (In_Tree, N_With_Clause); |
| begin |
| Set_Name_Of (New_With_Clause, In_Tree, |
| Name_Of (With_Clause, In_Tree)); |
| Set_Path_Name_Of (New_With_Clause, In_Tree, |
| Path_Name_Of (With_Clause, In_Tree)); |
| Set_Project_Node_Of (New_With_Clause, In_Tree, |
| Project_Node_Of (With_Clause, In_Tree)); |
| Set_Next_With_Clause_Of (New_With_Clause, In_Tree, Next_Clause); |
| |
| return New_With_Clause; |
| end Copy_With_Clause; |
| |
| -------------------------------------- |
| -- Create_Virtual_Extending_Project -- |
| -------------------------------------- |
| |
| procedure Create_Virtual_Extending_Project |
| (For_Project : Project_Node_Id; |
| Main_Project : Project_Node_Id; |
| Extension_Withs : 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); |
| |
| -- Add a WITH clause to the main project to import the newly created |
| -- virtual extending project. |
| |
| 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); |
| |
| -- Copy with clauses for projects imported by the extending-all project |
| |
| declare |
| Org_With_Clause : Project_Node_Id := Extension_Withs; |
| New_With_Clause : Project_Node_Id := Empty_Node; |
| |
| begin |
| while Present (Org_With_Clause) loop |
| New_With_Clause := |
| Copy_With_Clause (Org_With_Clause, In_Tree, New_With_Clause); |
| |
| Org_With_Clause := Next_With_Clause_Of (Org_With_Clause, In_Tree); |
| end loop; |
| |
| Set_First_With_Clause_Of (Virtual_Project, In_Tree, New_With_Clause); |
| end; |
| |
| -- 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 -- |
| ----------------------------------- |
| |
| Extension_Withs : Project_Node_Id; |
| -- Head of the current EXTENDS ALL imports list. When creating virtual |
| -- projects for an EXTENDS ALL, we import in each virtual project all |
| -- of the projects that appear in WITH clauses of the extending projects. |
| -- This ensures that virtual projects share a consistent environment (in |
| -- particular if a project imported by one of the extending projects |
| -- replaces some runtime units). |
| |
| 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 |
| |
| Extends_All : Boolean := False; |
| -- Set True if Proj is an EXTENDS ALL project |
| |
| Saved_Extension_Withs : constant Project_Node_Id := Extension_Withs; |
| |
| begin |
| -- Nothing to do if Proj is undefined or 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); |
| Extends_All := Is_Extending_All (Proj, 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, Extension_Withs); |
| 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; |
| |
| if Extends_All then |
| |
| -- This is an EXTENDS ALL project: prepend each of its WITH |
| -- clauses to the currently active list of extension deps. |
| |
| Extension_Withs := |
| Copy_With_Clause (With_Clause, In_Tree, Extension_Withs); |
| 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); |
| |
| Extension_Withs := Saved_Extension_Withs; |
| 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; |
| Errout_Handling : Errout_Mode := Always_Finalize; |
| Packages_To_Check : String_List_Access; |
| Store_Comments : Boolean := False; |
| Current_Directory : String := ""; |
| Is_Config_File : Boolean; |
| Env : in out Prj.Tree.Environment; |
| Target_Name : String := "") |
| is |
| Dummy : Boolean; |
| pragma Warnings (Off, Dummy); |
| |
| Real_Project_File_Name : String_Access := |
| Osint.To_Canonical_File_Spec |
| (Project_File_Name); |
| Path_Name_Id : Path_Name_Type; |
| |
| begin |
| In_Tree.Incomplete_With := False; |
| |
| if not Is_Initialized (Env.Project_Path) then |
| Prj.Env.Initialize_Default_Project_Path |
| (Env.Project_Path, Target_Name); |
| end if; |
| |
| if Real_Project_File_Name = null then |
| Real_Project_File_Name := new String'(Project_File_Name); |
| end if; |
| |
| Project := Empty_Node; |
| |
| Find_Project (Env.Project_Path, |
| Project_File_Name => Real_Project_File_Name.all, |
| Directory => Current_Directory, |
| Path => Path_Name_Id); |
| Free (Real_Project_File_Name); |
| |
| if Errout_Handling /= Never_Finalize then |
| Prj.Err.Initialize; |
| end if; |
| |
| Prj.Err.Scanner.Set_Comment_As_Token (Store_Comments); |
| Prj.Err.Scanner.Set_End_Of_Line_As_Token (Store_Comments); |
| |
| if Path_Name_Id = No_Path then |
| declare |
| P : String_Access; |
| begin |
| Get_Path (Env.Project_Path, Path => P); |
| |
| Prj.Com.Fail |
| ("project file """ |
| & Project_File_Name |
| & """ not found in " |
| & P.all); |
| Project := Empty_Node; |
| return; |
| end; |
| end if; |
| |
| -- Parse the main project file |
| |
| begin |
| Parse_Single_Project |
| (In_Tree => In_Tree, |
| Project => Project, |
| Extends_All => Dummy, |
| Path_Name_Id => Path_Name_Id, |
| 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, |
| Env => Env); |
| |
| 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 |
| Extension_Withs := First_With_Clause_Of (Project, In_Tree); |
| 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. |
| |
| 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 := Empty_Node; |
| Withs : Project_Node_Id; |
| begin |
| Virtual_Hash.Get_First (Proj, Withs); |
| while Withs /= Project_Node_High_Bound loop |
| Create_Virtual_Extending_Project |
| (Proj, Project, Withs, In_Tree); |
| Virtual_Hash.Get_Next (Proj, Withs); |
| end loop; |
| end; |
| end if; |
| |
| -- If there were any kind of error during the parsing, serious |
| -- or not, then the parsing fails. |
| |
| if Total_Errors_Detected > 0 then |
| Project := Empty_Node; |
| end if; |
| |
| case Errout_Handling is |
| when Always_Finalize => |
| Prj.Err.Finalize; |
| |
| -- Reinitialize to avoid duplicate warnings later on |
| Prj.Err.Initialize; |
| |
| when Finalize_If_Error => |
| if No (Project) then |
| Prj.Err.Finalize; |
| Prj.Err.Initialize; |
| end if; |
| |
| when Never_Finalize => |
| null; |
| end case; |
| |
| 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); -- 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 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; |
| In_Limited : Boolean; |
| Limited_Withs : Boolean; |
| Imported_Projects : in out Project_Node_Id; |
| Project_Directory : Path_Name_Type; |
| From_Extended : Extension_Origin; |
| Packages_To_Check : String_List_Access; |
| Depth : Natural; |
| Current_Dir : String; |
| Is_Config_File : Boolean; |
| Env : in out Environment) |
| 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; |
| Imported_Path_Name_Id : Path_Name_Type; |
| |
| 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 |
| Find_Project |
| (Env.Project_Path, |
| Project_File_Name => Get_Name_String (Current_With.Path), |
| Directory => Project_Directory_Path, |
| Path => Imported_Path_Name_Id); |
| |
| if Imported_Path_Name_Id = No_Path then |
| if Env.Flags.Ignore_Missing_With then |
| In_Tree.Incomplete_With := True; |
| |
| else |
| -- The project file cannot be found |
| |
| Error_Msg_File_1 := File_Name_Type (Current_With.Path); |
| Error_Msg |
| (Env.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 |
| (Env.Flags, "\imported by {", Current_With.Location); |
| end loop; |
| end if; |
| end if; |
| |
| else |
| -- New with clause |
| |
| declare |
| Resolved_Path : constant String := |
| Normalize_Pathname |
| (Get_Name_String (Imported_Path_Name_Id), |
| Directory => Current_Dir, |
| Resolve_Links => |
| Opt.Follow_Links_For_Files, |
| Case_Sensitive => True); |
| |
| Withed_Project : Project_Node_Id := Empty_Node; |
| |
| begin |
| 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 (In_Limited or 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_Id => Imported_Path_Name_Id, |
| Extended => False, |
| From_Extended => From_Extended, |
| In_Limited => In_Limited or Limited_Withs, |
| Packages_To_Check => Packages_To_Check, |
| Depth => Depth, |
| Current_Dir => Current_Dir, |
| Is_Config_File => Is_Config_File, |
| Env => Env); |
| |
| 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; |
| end if; |
| end if; |
| end loop; |
| end Post_Parse_Context_Clause; |
| |
| --------------------------------- |
| -- Check_Extending_All_Imports -- |
| --------------------------------- |
| |
| procedure Check_Extending_All_Imports |
| (Flags : Processing_Flags; |
| In_Tree : Project_Node_Tree_Ref; |
| Project : Project_Node_Id) |
| is |
| With_Clause : Project_Node_Id; |
| Imported : Project_Node_Id; |
| |
| begin |
| if not Is_Extending_All (Project, In_Tree) then |
| With_Clause := First_With_Clause_Of (Project, In_Tree); |
| 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; |
| end if; |
| |
| With_Clause := Next_With_Clause_Of (With_Clause, In_Tree); |
| end loop; |
| end if; |
| end Check_Extending_All_Imports; |
| |
| ----------------------------- |
| -- Check_Aggregate_Imports -- |
| ----------------------------- |
| |
| procedure Check_Aggregate_Imports |
| (Flags : Processing_Flags; |
| In_Tree : Project_Node_Tree_Ref; |
| Project : Project_Node_Id) |
| is |
| With_Clause, Imported : Project_Node_Id; |
| begin |
| if Project_Qualifier_Of (Project, In_Tree) = Aggregate then |
| With_Clause := First_With_Clause_Of (Project, In_Tree); |
| |
| while Present (With_Clause) loop |
| Imported := Project_Node_Of (With_Clause, In_Tree); |
| |
| if Project_Qualifier_Of (Imported, In_Tree) /= Dry then |
| Error_Msg_Name_1 := Name_Id (Path_Name_Of (Imported, In_Tree)); |
| Error_Msg (Flags, "can only import abstract projects, not %%", |
| Token_Ptr); |
| exit; |
| end if; |
| |
| With_Clause := Next_With_Clause_Of (With_Clause, In_Tree); |
| end loop; |
| end if; |
| end Check_Aggregate_Imports; |
| |
| ---------------------------- |
| -- Read_Project_Qualifier -- |
| ---------------------------- |
| |
| procedure Read_Project_Qualifier |
| (Flags : Processing_Flags; |
| In_Tree : Project_Node_Tree_Ref; |
| Is_Config_File : Boolean; |
| Qualifier_Location : out Source_Ptr; |
| Project : Project_Node_Id) |
| is |
| Proj_Qualifier : Project_Qualifier := Unspecified; |
| begin |
| 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; |
| end Read_Project_Qualifier; |
| |
| ------------------------------- |
| -- Has_Circular_Dependencies -- |
| ------------------------------- |
| |
| function Has_Circular_Dependencies |
| (Flags : Processing_Flags; |
| Normed_Path_Name : Path_Name_Type; |
| Canonical_Path_Name : Path_Name_Type) return Boolean is |
| begin |
| 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; |
| |
| return True; |
| end if; |
| end loop; |
| return False; |
| end Has_Circular_Dependencies; |
| |
| -------------------------- |
| -- Parse_Single_Project -- |
| -------------------------- |
| |
| procedure Parse_Single_Project |
| (In_Tree : Project_Node_Tree_Ref; |
| Project : out Project_Node_Id; |
| Extends_All : out Boolean; |
| Path_Name_Id : Path_Name_Type; |
| Extended : Boolean; |
| From_Extended : Extension_Origin; |
| In_Limited : Boolean; |
| Packages_To_Check : String_List_Access; |
| Depth : Natural; |
| Current_Dir : String; |
| Is_Config_File : Boolean; |
| Env : in out Environment) |
| is |
| Path_Name : constant String := Get_Name_String (Path_Name_Id); |
| |
| 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; |
| |
| 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; |
| |
| if Has_Circular_Dependencies |
| (Env.Flags, Normed_Path_Name, Canonical_Path_Name) |
| then |
| Project := Empty_Node; |
| return; |
| end if; |
| |
| -- 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 |
| (Env.Flags, |
| "cannot extend the same project file several times", |
| Token_Ptr); |
| end if; |
| else |
| Error_Msg |
| (Env.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 |
| (Env.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 (Env.Flags, |
| "?{ is not a valid path name for a project file", |
| Token_Ptr); |
| end if; |
| |
| if Current_Verbosity >= Medium then |
| Debug_Increase_Indent ("Parsing """ & Path_Name & '"'); |
| 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 => Env.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); |
| |
| Read_Project_Qualifier |
| (Env.Flags, In_Tree, Is_Config_File, Qualifier_Location, Project); |
| |
| 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 |
| (Env.Flags, |
| "extending configuration project not allowed", Token_Ptr); |
| end if; |
| |
| -- Make sure that gnatmake will use mapping files |
| |
| Opt.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 |
| (Env.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, |
| In_Limited => In_Limited, |
| Limited_Withs => False, |
| Imported_Projects => Imported_Projects, |
| Project_Directory => Project_Directory, |
| From_Extended => From_Ext, |
| Packages_To_Check => Packages_To_Check, |
| Depth => Depth + 1, |
| Current_Dir => Current_Dir, |
| Is_Config_File => Is_Config_File, |
| Env => Env); |
| 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 |
| (Env.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 |
| (Env.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_Id : Path_Name_Type; |
| |
| begin |
| Find_Project |
| (Env.Project_Path, |
| Project_File_Name => Original_Path_Name, |
| Directory => Get_Name_String (Project_Directory), |
| Path => Extended_Project_Path_Name_Id); |
| |
| if Extended_Project_Path_Name_Id = No_Path then |
| |
| -- We could not find the project file to extend |
| |
| Error_Msg_Name_1 := Token_Name; |
| |
| Error_Msg (Env.Flags, "unknown project file: %%", Token_Ptr); |
| |
| -- If 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 (Env.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 (Env.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_Id => Extended_Project_Path_Name_Id, |
| 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, |
| Env => Env); |
| 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 Project_Qualifier_Of (Project, In_Tree) = Dry and then |
| Project_Qualifier_Of (Extended_Project, In_Tree) /= Dry |
| then |
| Error_Msg |
| (Env.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_Extending_All_Imports (Env.Flags, In_Tree, Project); |
| Check_Aggregate_Imports (Env.Flags, In_Tree, Project); |
| |
| -- 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 found, check if 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); |
| Imp_Proj_Name : Name_Id; |
| |
| 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. |
| |
| Imported_Loop : |
| while not Parent_Found and then Present (With_Clause) loop |
| Parent_Node := Project_Node_Of (With_Clause, In_Tree); |
| Extension_Loop : while Present (Parent_Node) loop |
| Imp_Proj_Name := Name_Of (Parent_Node, In_Tree); |
| Parent_Found := Imp_Proj_Name = Parent_Name; |
| exit Imported_Loop when Parent_Found; |
| Parent_Node := |
| Extended_Project_Of |
| (Project_Declaration_Of (Parent_Node, In_Tree), |
| In_Tree); |
| end loop Extension_Loop; |
| |
| With_Clause := Next_With_Clause_Of (With_Clause, In_Tree); |
| end loop Imported_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 (Env.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 => Env.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 (Env.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 |
| (Env.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 => Project_Qualifier_Of (Project, In_Tree))); |
| 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, |
| In_Limited => In_Limited, |
| Limited_Withs => True, |
| Imported_Projects => Imported_Projects, |
| Project_Directory => Project_Directory, |
| From_Extended => From_Ext, |
| Packages_To_Check => Packages_To_Check, |
| Depth => Depth + 1, |
| Current_Dir => Current_Dir, |
| Is_Config_File => Is_Config_File, |
| Env => Env); |
| 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); |
| |
| Debug_Decrease_Indent; |
| 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 |
| Debug_Output ("Project_Name_From (""" & Canonical & """)"); |
| 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; |
| |
| end Prj.Part; |
