| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- P R J . N M S C -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 2000-2006, Free Software Foundation, Inc. -- |
| -- -- |
| -- GNAT is free software; you can redistribute it and/or modify it under -- |
| -- terms of the GNU General Public License as published by the Free Soft- -- |
| -- ware Foundation; either version 2, or (at your option) any later ver- -- |
| -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
| -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
| -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- |
| -- for more details. You should have received a copy of the GNU General -- |
| -- Public License distributed with GNAT; see file COPYING. If not, write -- |
| -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- |
| -- Boston, MA 02110-1301, USA. -- |
| -- -- |
| -- 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 Fmap; use Fmap; |
| with Hostparm; |
| with MLib.Tgt; use MLib.Tgt; |
| with Namet; use Namet; |
| with Osint; use Osint; |
| with Output; use Output; |
| with Prj.Env; use Prj.Env; |
| with Prj.Err; |
| with Prj.Util; use Prj.Util; |
| with Sinput.P; |
| with Snames; use Snames; |
| with Table; use Table; |
| with Targparm; use Targparm; |
| |
| with Ada.Characters.Handling; use Ada.Characters.Handling; |
| with Ada.Strings; use Ada.Strings; |
| with Ada.Strings.Fixed; use Ada.Strings.Fixed; |
| with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants; |
| |
| with GNAT.Case_Util; use GNAT.Case_Util; |
| with GNAT.Directory_Operations; use GNAT.Directory_Operations; |
| with GNAT.HTable; |
| |
| package body Prj.Nmsc is |
| |
| Error_Report : Put_Line_Access := null; |
| -- Set to point to error reporting procedure |
| |
| When_No_Sources : Error_Warning := Error; |
| -- Indicates what should be done when there is no Ada sources in a non |
| -- extending Ada project. |
| |
| ALI_Suffix : constant String := ".ali"; |
| -- File suffix for ali files |
| |
| Object_Suffix : constant String := Get_Target_Object_Suffix.all; |
| -- File suffix for object files |
| |
| type Name_Location is record |
| Name : Name_Id; |
| Location : Source_Ptr; |
| Found : Boolean := False; |
| end record; |
| -- Information about file names found in string list attribute |
| -- Source_Files or in a source list file, stored in hash table |
| -- Source_Names, used by procedure Get_Path_Names_And_Record_Sources. |
| |
| No_Name_Location : constant Name_Location := |
| (Name => No_Name, Location => No_Location, Found => False); |
| |
| package Source_Names is new GNAT.HTable.Simple_HTable |
| (Header_Num => Header_Num, |
| Element => Name_Location, |
| No_Element => No_Name_Location, |
| Key => Name_Id, |
| Hash => Hash, |
| Equal => "="); |
| -- Hash table to store file names found in string list attribute |
| -- Source_Files or in a source list file, stored in hash table |
| -- Source_Names, used by procedure Get_Path_Names_And_Record_Sources. |
| |
| package Recursive_Dirs is new GNAT.HTable.Simple_HTable |
| (Header_Num => Header_Num, |
| Element => Boolean, |
| No_Element => False, |
| Key => Name_Id, |
| Hash => Hash, |
| Equal => "="); |
| -- Hash table to store recursive source directories, to avoid looking |
| -- several times, and to avoid cycles that may be introduced by symbolic |
| -- links. |
| |
| type Ada_Naming_Exception_Id is new Nat; |
| No_Ada_Naming_Exception : constant Ada_Naming_Exception_Id := 0; |
| |
| type Unit_Info is record |
| Kind : Spec_Or_Body; |
| Unit : Name_Id; |
| Next : Ada_Naming_Exception_Id := No_Ada_Naming_Exception; |
| end record; |
| -- No_Unit : constant Unit_Info := |
| -- (Specification, No_Name, No_Ada_Naming_Exception); |
| |
| package Ada_Naming_Exception_Table is new Table.Table |
| (Table_Component_Type => Unit_Info, |
| Table_Index_Type => Ada_Naming_Exception_Id, |
| Table_Low_Bound => 1, |
| Table_Initial => 20, |
| Table_Increment => 100, |
| Table_Name => "Prj.Nmsc.Ada_Naming_Exception_Table"); |
| |
| package Ada_Naming_Exceptions is new GNAT.HTable.Simple_HTable |
| (Header_Num => Header_Num, |
| Element => Ada_Naming_Exception_Id, |
| No_Element => No_Ada_Naming_Exception, |
| Key => Name_Id, |
| Hash => Hash, |
| Equal => "="); |
| -- A hash table to store naming exceptions for Ada. For each file name |
| -- there is one or several unit in table Ada_Naming_Exception_Table. |
| |
| function Hash (Unit : Unit_Info) return Header_Num; |
| |
| type Name_And_Index is record |
| Name : Name_Id := No_Name; |
| Index : Int := 0; |
| end record; |
| No_Name_And_Index : constant Name_And_Index := |
| (Name => No_Name, Index => 0); |
| |
| package Reverse_Ada_Naming_Exceptions is new GNAT.HTable.Simple_HTable |
| (Header_Num => Header_Num, |
| Element => Name_And_Index, |
| No_Element => No_Name_And_Index, |
| Key => Unit_Info, |
| Hash => Hash, |
| Equal => "="); |
| -- A table to check if a unit with an exceptional name will hide |
| -- a source with a file name following the naming convention. |
| |
| function ALI_File_Name (Source : String) return String; |
| -- Return the ALI file name corresponding to a source |
| |
| procedure Check_Ada_Name (Name : String; Unit : out Name_Id); |
| -- Check that a name is a valid Ada unit name |
| |
| procedure Check_Naming_Scheme |
| (Data : in out Project_Data; |
| Project : Project_Id; |
| In_Tree : Project_Tree_Ref); |
| -- Check the naming scheme part of Data |
| |
| procedure Check_Ada_Naming_Scheme_Validity |
| (Project : Project_Id; |
| In_Tree : Project_Tree_Ref; |
| Naming : Naming_Data); |
| -- Check that the package Naming is correct |
| |
| procedure Check_For_Source |
| (File_Name : Name_Id; |
| Path_Name : Name_Id; |
| Project : Project_Id; |
| In_Tree : Project_Tree_Ref; |
| Data : in out Project_Data; |
| Location : Source_Ptr; |
| Language : Language_Index; |
| Suffix : String; |
| Naming_Exception : Boolean); |
| -- Check if a file, with name File_Name and path Path_Name, in a source |
| -- directory is a source for language Language in project Project of |
| -- project tree In_Tree. ??? |
| |
| procedure Check_If_Externally_Built |
| (Project : Project_Id; |
| In_Tree : Project_Tree_Ref; |
| Data : in out Project_Data); |
| -- Check attribute Externally_Built of project Project in project tree |
| -- In_Tree and modify its data Data if it has the value "true". |
| |
| procedure Check_Library_Attributes |
| (Project : Project_Id; |
| In_Tree : Project_Tree_Ref; |
| Data : in out Project_Data); |
| -- Check the library attributes of project Project in project tree In_Tree |
| -- and modify its data Data accordingly. |
| |
| procedure Check_Package_Naming |
| (Project : Project_Id; |
| In_Tree : Project_Tree_Ref; |
| Data : in out Project_Data); |
| -- Check package Naming of project Project in project tree In_Tree and |
| -- modify its data Data accordingly. |
| |
| procedure Check_Programming_Languages |
| (In_Tree : Project_Tree_Ref; Data : in out Project_Data); |
| -- Check attribute Languages for the project with data Data in project |
| -- tree In_Tree and set the components of Data for all the programming |
| -- languages indicated in attribute Languages, if any. |
| |
| function Check_Project |
| (P : Project_Id; |
| Root_Project : Project_Id; |
| In_Tree : Project_Tree_Ref; |
| Extending : Boolean) return Boolean; |
| -- Returns True if P is Root_Project or, if Extending is True, a project |
| -- extended by Root_Project. |
| |
| procedure Check_Stand_Alone_Library |
| (Project : Project_Id; |
| In_Tree : Project_Tree_Ref; |
| Data : in out Project_Data; |
| Extending : Boolean); |
| -- Check if project Project in project tree In_Tree is a Stand-Alone |
| -- Library project, and modify its data Data accordingly if it is one. |
| |
| function Compute_Directory_Last (Dir : String) return Natural; |
| -- Return the index of the last significant character in Dir. This is used |
| -- to avoid duplicates '/' at the end of directory names |
| |
| function Body_Suffix_Of |
| (Language : Language_Index; |
| In_Project : Project_Data; |
| In_Tree : Project_Tree_Ref) |
| return String; |
| -- Returns the suffix of sources of language Language in project In_Project |
| -- in project tree In_Tree. |
| |
| procedure Error_Msg |
| (Project : Project_Id; |
| In_Tree : Project_Tree_Ref; |
| Msg : String; |
| Flag_Location : Source_Ptr); |
| -- Output an error message. If Error_Report is null, simply call |
| -- Prj.Err.Error_Msg. Otherwise, disregard Flag_Location and use |
| -- Error_Report. |
| |
| procedure Find_Sources |
| (Project : Project_Id; |
| In_Tree : Project_Tree_Ref; |
| Data : in out Project_Data; |
| For_Language : Language_Index; |
| Follow_Links : Boolean := False); |
| -- Find all the sources in all of the source directories of a project for |
| -- a specified language. |
| |
| procedure Free_Ada_Naming_Exceptions; |
| -- Free the internal hash tables used for checking naming exceptions |
| |
| procedure Get_Directories |
| (Project : Project_Id; |
| In_Tree : Project_Tree_Ref; |
| Data : in out Project_Data); |
| -- Get the object directory, the exec directory and the source directories |
| -- of a project. |
| |
| procedure Get_Mains |
| (Project : Project_Id; |
| In_Tree : Project_Tree_Ref; |
| Data : in out Project_Data); |
| -- Get the mains of a project from attribute Main, if it exists, and put |
| -- them in the project data. |
| |
| procedure Get_Sources_From_File |
| (Path : String; |
| Location : Source_Ptr; |
| Project : Project_Id; |
| In_Tree : Project_Tree_Ref); |
| -- Get the list of sources from a text file and put them in hash table |
| -- Source_Names. |
| |
| procedure Get_Unit |
| (Canonical_File_Name : Name_Id; |
| Naming : Naming_Data; |
| Exception_Id : out Ada_Naming_Exception_Id; |
| Unit_Name : out Name_Id; |
| Unit_Kind : out Spec_Or_Body; |
| Needs_Pragma : out Boolean); |
| -- Find out, from a file name, the unit name, the unit kind and if a |
| -- specific SFN pragma is needed. If the file name corresponds to no |
| -- unit, then Unit_Name will be No_Name. If the file is a multi-unit source |
| -- or an exception to the naming scheme, then Exception_Id is set to |
| -- the unit or units that the source contains. |
| |
| function Is_Illegal_Suffix |
| (Suffix : String; |
| Dot_Replacement_Is_A_Single_Dot : Boolean) return Boolean; |
| -- Returns True if the string Suffix cannot be used as |
| -- a spec suffix, a body suffix or a separate suffix. |
| |
| procedure Locate_Directory |
| (Name : Name_Id; |
| Parent : Name_Id; |
| Dir : out Name_Id; |
| Display : out Name_Id); |
| -- Locate a directory (returns No_Name for Dir and Display if directory |
| -- does not exist). Name is the directory name. Parent is the root |
| -- directory, if Name is a relative path name. Dir is the canonical case |
| -- path name of the directory, Display is the directory path name for |
| -- display purposes. |
| |
| procedure Look_For_Sources |
| (Project : Project_Id; |
| In_Tree : Project_Tree_Ref; |
| Data : in out Project_Data; |
| Follow_Links : Boolean); |
| -- Find all the sources of a project |
| |
| function Path_Name_Of |
| (File_Name : Name_Id; |
| Directory : Name_Id) return String; |
| -- Returns the path name of a (non project) file. |
| -- Returns an empty string if file cannot be found. |
| |
| procedure Prepare_Ada_Naming_Exceptions |
| (List : Array_Element_Id; |
| In_Tree : Project_Tree_Ref; |
| Kind : Spec_Or_Body); |
| -- Prepare the internal hash tables used for checking naming exceptions |
| -- for Ada. Insert all elements of List in the tables. |
| |
| function Project_Extends |
| (Extending : Project_Id; |
| Extended : Project_Id; |
| In_Tree : Project_Tree_Ref) return Boolean; |
| -- Returns True if Extending is extending Extended either directly or |
| -- indirectly. |
| |
| procedure Record_Ada_Source |
| (File_Name : Name_Id; |
| Path_Name : Name_Id; |
| Project : Project_Id; |
| In_Tree : Project_Tree_Ref; |
| Data : in out Project_Data; |
| Location : Source_Ptr; |
| Current_Source : in out String_List_Id; |
| Source_Recorded : in out Boolean; |
| Follow_Links : Boolean); |
| -- Put a unit in the list of units of a project, if the file name |
| -- corresponds to a valid unit name. |
| |
| procedure Record_Other_Sources |
| (Project : Project_Id; |
| In_Tree : Project_Tree_Ref; |
| Data : in out Project_Data; |
| Language : Language_Index; |
| Naming_Exceptions : Boolean); |
| -- Record the sources of a language in a project. |
| -- When Naming_Exceptions is True, mark the found sources as such, to |
| -- later remove those that are not named in a list of sources. |
| |
| procedure Report_No_Ada_Sources |
| (Project : Project_Id; |
| In_Tree : Project_Tree_Ref; |
| Location : Source_Ptr); |
| -- Report an error or a warning depending on the value of When_No_Sources |
| |
| procedure Show_Source_Dirs |
| (Project : Project_Id; In_Tree : Project_Tree_Ref); |
| -- List all the source directories of a project |
| |
| function Suffix_For |
| (Language : Language_Index; |
| Naming : Naming_Data; |
| In_Tree : Project_Tree_Ref) return Name_Id; |
| -- Get the suffix for the source of a language from a package naming. |
| -- If not specified, return the default for the language. |
| |
| procedure Warn_If_Not_Sources |
| (Project : Project_Id; |
| In_Tree : Project_Tree_Ref; |
| Conventions : Array_Element_Id; |
| Specs : Boolean; |
| Extending : Boolean); |
| -- Check that individual naming conventions apply to immediate |
| -- sources of the project; if not, issue a warning. |
| |
| ------------------- |
| -- ALI_File_Name -- |
| ------------------- |
| |
| function ALI_File_Name (Source : String) return String is |
| begin |
| -- If the source name has an extension, then replace it with |
| -- the ALI suffix. |
| |
| for Index in reverse Source'First + 1 .. Source'Last loop |
| if Source (Index) = '.' then |
| return Source (Source'First .. Index - 1) & ALI_Suffix; |
| end if; |
| end loop; |
| |
| -- If there is no dot, or if it is the first character, just add the |
| -- ALI suffix. |
| |
| return Source & ALI_Suffix; |
| end ALI_File_Name; |
| |
| ----------- |
| -- Check -- |
| ----------- |
| |
| procedure Check |
| (Project : Project_Id; |
| In_Tree : Project_Tree_Ref; |
| Report_Error : Put_Line_Access; |
| Follow_Links : Boolean; |
| When_No_Sources : Error_Warning) |
| is |
| Data : Project_Data := In_Tree.Projects.Table (Project); |
| Extending : Boolean := False; |
| |
| begin |
| Nmsc.When_No_Sources := When_No_Sources; |
| Error_Report := Report_Error; |
| |
| Recursive_Dirs.Reset; |
| |
| -- Object, exec and source directories |
| |
| Get_Directories (Project, In_Tree, Data); |
| |
| -- Get the programming languages |
| |
| Check_Programming_Languages (In_Tree, Data); |
| |
| -- Library attributes |
| |
| Check_Library_Attributes (Project, In_Tree, Data); |
| |
| Check_If_Externally_Built (Project, In_Tree, Data); |
| |
| if Current_Verbosity = High then |
| Show_Source_Dirs (Project, In_Tree); |
| end if; |
| |
| Check_Package_Naming (Project, In_Tree, Data); |
| |
| Extending := Data.Extends /= No_Project; |
| |
| Check_Naming_Scheme (Data, Project, In_Tree); |
| |
| Prepare_Ada_Naming_Exceptions |
| (Data.Naming.Bodies, In_Tree, Body_Part); |
| Prepare_Ada_Naming_Exceptions |
| (Data.Naming.Specs, In_Tree, Specification); |
| |
| -- Find the sources |
| |
| if Data.Source_Dirs /= Nil_String then |
| Look_For_Sources (Project, In_Tree, Data, Follow_Links); |
| end if; |
| |
| if Data.Ada_Sources_Present then |
| |
| -- Check that all individual naming conventions apply to sources of |
| -- this project file. |
| |
| Warn_If_Not_Sources |
| (Project, In_Tree, Data.Naming.Bodies, |
| Specs => False, |
| Extending => Extending); |
| Warn_If_Not_Sources |
| (Project, In_Tree, Data.Naming.Specs, |
| Specs => True, |
| Extending => Extending); |
| end if; |
| |
| -- If it is a library project file, check if it is a standalone library |
| |
| if Data.Library then |
| Check_Stand_Alone_Library (Project, In_Tree, Data, Extending); |
| end if; |
| |
| -- Put the list of Mains, if any, in the project data |
| |
| Get_Mains (Project, In_Tree, Data); |
| |
| -- Update the project data in the Projects table |
| |
| In_Tree.Projects.Table (Project) := Data; |
| |
| Free_Ada_Naming_Exceptions; |
| end Check; |
| |
| -------------------- |
| -- Check_Ada_Name -- |
| -------------------- |
| |
| procedure Check_Ada_Name (Name : String; Unit : out Name_Id) is |
| The_Name : String := Name; |
| Real_Name : Name_Id; |
| Need_Letter : Boolean := True; |
| Last_Underscore : Boolean := False; |
| OK : Boolean := The_Name'Length > 0; |
| |
| begin |
| To_Lower (The_Name); |
| |
| Name_Len := The_Name'Length; |
| Name_Buffer (1 .. Name_Len) := The_Name; |
| Real_Name := Name_Find; |
| |
| -- Check first that the given name is not an Ada reserved word |
| |
| if Get_Name_Table_Byte (Real_Name) /= 0 |
| and then Real_Name /= Name_Project |
| and then Real_Name /= Name_Extends |
| and then Real_Name /= Name_External |
| then |
| Unit := No_Name; |
| |
| if Current_Verbosity = High then |
| Write_Str (The_Name); |
| Write_Line (" is an Ada reserved word."); |
| end if; |
| |
| return; |
| end if; |
| |
| for Index in The_Name'Range loop |
| if Need_Letter then |
| |
| -- We need a letter (at the beginning, and following a dot), |
| -- but we don't have one. |
| |
| if Is_Letter (The_Name (Index)) then |
| Need_Letter := False; |
| |
| else |
| OK := False; |
| |
| if Current_Verbosity = High then |
| Write_Int (Types.Int (Index)); |
| Write_Str (": '"); |
| Write_Char (The_Name (Index)); |
| Write_Line ("' is not a letter."); |
| end if; |
| |
| exit; |
| end if; |
| |
| elsif Last_Underscore |
| and then (The_Name (Index) = '_' or else The_Name (Index) = '.') |
| then |
| -- Two underscores are illegal, and a dot cannot follow |
| -- an underscore. |
| |
| OK := False; |
| |
| if Current_Verbosity = High then |
| Write_Int (Types.Int (Index)); |
| Write_Str (": '"); |
| Write_Char (The_Name (Index)); |
| Write_Line ("' is illegal here."); |
| end if; |
| |
| exit; |
| |
| elsif The_Name (Index) = '.' then |
| |
| -- We need a letter after a dot |
| |
| Need_Letter := True; |
| |
| elsif The_Name (Index) = '_' then |
| Last_Underscore := True; |
| |
| else |
| -- We need an letter or a digit |
| |
| Last_Underscore := False; |
| |
| if not Is_Alphanumeric (The_Name (Index)) then |
| OK := False; |
| |
| if Current_Verbosity = High then |
| Write_Int (Types.Int (Index)); |
| Write_Str (": '"); |
| Write_Char (The_Name (Index)); |
| Write_Line ("' is not alphanumeric."); |
| end if; |
| |
| exit; |
| end if; |
| end if; |
| end loop; |
| |
| -- Cannot end with an underscore or a dot |
| |
| OK := OK and then not Need_Letter and then not Last_Underscore; |
| |
| if OK then |
| Unit := Real_Name; |
| |
| else |
| -- Signal a problem with No_Name |
| |
| Unit := No_Name; |
| end if; |
| end Check_Ada_Name; |
| |
| -------------------------------------- |
| -- Check_Ada_Naming_Scheme_Validity -- |
| -------------------------------------- |
| |
| procedure Check_Ada_Naming_Scheme_Validity |
| (Project : Project_Id; |
| In_Tree : Project_Tree_Ref; |
| Naming : Naming_Data) |
| is |
| begin |
| -- Only check if we are not using the Default naming scheme |
| |
| if Naming /= In_Tree.Private_Part.Default_Naming then |
| declare |
| Dot_Replacement : constant String := |
| Get_Name_String |
| (Naming.Dot_Replacement); |
| |
| Spec_Suffix : constant String := |
| Get_Name_String |
| (Naming.Ada_Spec_Suffix); |
| |
| Body_Suffix : constant String := |
| Get_Name_String |
| (Naming.Ada_Body_Suffix); |
| |
| Separate_Suffix : constant String := |
| Get_Name_String |
| (Naming.Separate_Suffix); |
| |
| begin |
| -- Dot_Replacement cannot |
| -- - be empty |
| -- - start or end with an alphanumeric |
| -- - be a single '_' |
| -- - start with an '_' followed by an alphanumeric |
| -- - contain a '.' except if it is "." |
| |
| if Dot_Replacement'Length = 0 |
| or else Is_Alphanumeric |
| (Dot_Replacement (Dot_Replacement'First)) |
| or else Is_Alphanumeric |
| (Dot_Replacement (Dot_Replacement'Last)) |
| or else (Dot_Replacement (Dot_Replacement'First) = '_' |
| and then |
| (Dot_Replacement'Length = 1 |
| or else |
| Is_Alphanumeric |
| (Dot_Replacement (Dot_Replacement'First + 1)))) |
| or else (Dot_Replacement'Length > 1 |
| and then |
| Index (Source => Dot_Replacement, |
| Pattern => ".") /= 0) |
| then |
| Error_Msg |
| (Project, In_Tree, |
| '"' & Dot_Replacement & |
| """ is illegal for Dot_Replacement.", |
| Naming.Dot_Repl_Loc); |
| end if; |
| |
| -- Suffixes cannot |
| -- - be empty |
| |
| if Is_Illegal_Suffix |
| (Spec_Suffix, Dot_Replacement = ".") |
| then |
| Err_Vars.Error_Msg_Name_1 := Naming.Ada_Spec_Suffix; |
| Error_Msg |
| (Project, In_Tree, |
| "{ is illegal for Spec_Suffix", |
| Naming.Spec_Suffix_Loc); |
| end if; |
| |
| if Is_Illegal_Suffix |
| (Body_Suffix, Dot_Replacement = ".") |
| then |
| Err_Vars.Error_Msg_Name_1 := Naming.Ada_Body_Suffix; |
| Error_Msg |
| (Project, In_Tree, |
| "{ is illegal for Body_Suffix", |
| Naming.Body_Suffix_Loc); |
| end if; |
| |
| if Body_Suffix /= Separate_Suffix then |
| if Is_Illegal_Suffix |
| (Separate_Suffix, Dot_Replacement = ".") |
| then |
| Err_Vars.Error_Msg_Name_1 := Naming.Separate_Suffix; |
| Error_Msg |
| (Project, In_Tree, |
| "{ is illegal for Separate_Suffix", |
| Naming.Sep_Suffix_Loc); |
| end if; |
| end if; |
| |
| -- Spec_Suffix cannot have the same termination as |
| -- Body_Suffix or Separate_Suffix |
| |
| if Spec_Suffix'Length <= Body_Suffix'Length |
| and then |
| Body_Suffix (Body_Suffix'Last - |
| Spec_Suffix'Length + 1 .. |
| Body_Suffix'Last) = Spec_Suffix |
| then |
| Error_Msg |
| (Project, In_Tree, |
| "Body_Suffix (""" & |
| Body_Suffix & |
| """) cannot end with" & |
| " Spec_Suffix (""" & |
| Spec_Suffix & """).", |
| Naming.Body_Suffix_Loc); |
| end if; |
| |
| if Body_Suffix /= Separate_Suffix |
| and then Spec_Suffix'Length <= Separate_Suffix'Length |
| and then |
| Separate_Suffix |
| (Separate_Suffix'Last - Spec_Suffix'Length + 1 |
| .. |
| Separate_Suffix'Last) = Spec_Suffix |
| then |
| Error_Msg |
| (Project, In_Tree, |
| "Separate_Suffix (""" & |
| Separate_Suffix & |
| """) cannot end with" & |
| " Spec_Suffix (""" & |
| Spec_Suffix & """).", |
| Naming.Sep_Suffix_Loc); |
| end if; |
| end; |
| end if; |
| end Check_Ada_Naming_Scheme_Validity; |
| |
| ---------------------- |
| -- Check_For_Source -- |
| ---------------------- |
| |
| procedure Check_For_Source |
| (File_Name : Name_Id; |
| Path_Name : Name_Id; |
| Project : Project_Id; |
| In_Tree : Project_Tree_Ref; |
| Data : in out Project_Data; |
| Location : Source_Ptr; |
| Language : Language_Index; |
| Suffix : String; |
| Naming_Exception : Boolean) |
| is |
| Name : String := Get_Name_String (File_Name); |
| Real_Location : Source_Ptr := Location; |
| |
| begin |
| Canonical_Case_File_Name (Name); |
| |
| -- A file is a source of a language if Naming_Exception is True (case |
| -- of naming exceptions) or if its file name ends with the suffix. |
| |
| if Naming_Exception or else |
| (Name'Length > Suffix'Length and then |
| Name (Name'Last - Suffix'Length + 1 .. Name'Last) = Suffix) |
| then |
| if Real_Location = No_Location then |
| Real_Location := Data.Location; |
| end if; |
| |
| declare |
| Path : String := Get_Name_String (Path_Name); |
| |
| Path_Id : Name_Id; |
| -- The path name id (in canonical case) |
| |
| File_Id : Name_Id; |
| -- The file name id (in canonical case) |
| |
| Obj_Id : Name_Id; |
| -- The object file name |
| |
| Obj_Path_Id : Name_Id; |
| -- The object path name |
| |
| Dep_Id : Name_Id; |
| -- The dependency file name |
| |
| Dep_Path_Id : Name_Id; |
| -- The dependency path name |
| |
| Dot_Pos : Natural := 0; |
| -- Position of the last dot in Name |
| |
| Source : Other_Source; |
| Source_Id : Other_Source_Id := Data.First_Other_Source; |
| |
| begin |
| Canonical_Case_File_Name (Path); |
| |
| -- Get the file name id |
| |
| Name_Len := Name'Length; |
| Name_Buffer (1 .. Name_Len) := Name; |
| File_Id := Name_Find; |
| |
| -- Get the path name id |
| |
| Name_Len := Path'Length; |
| Name_Buffer (1 .. Name_Len) := Path; |
| Path_Id := Name_Find; |
| |
| -- Find the position of the last dot |
| |
| for J in reverse Name'Range loop |
| if Name (J) = '.' then |
| Dot_Pos := J; |
| exit; |
| end if; |
| end loop; |
| |
| if Dot_Pos <= Name'First then |
| Dot_Pos := Name'Last + 1; |
| end if; |
| |
| -- Compute the object file name |
| |
| Get_Name_String (File_Id); |
| Name_Len := Dot_Pos - Name'First; |
| |
| for J in Object_Suffix'Range loop |
| Name_Len := Name_Len + 1; |
| Name_Buffer (Name_Len) := Object_Suffix (J); |
| end loop; |
| |
| Obj_Id := Name_Find; |
| |
| -- Compute the object path name |
| |
| Get_Name_String (Data.Object_Directory); |
| |
| if Name_Buffer (Name_Len) /= Directory_Separator and then |
| Name_Buffer (Name_Len) /= '/' |
| then |
| Name_Len := Name_Len + 1; |
| Name_Buffer (Name_Len) := Directory_Separator; |
| end if; |
| |
| Add_Str_To_Name_Buffer (Get_Name_String (Obj_Id)); |
| Obj_Path_Id := Name_Find; |
| |
| -- Compute the dependency file name |
| |
| Get_Name_String (File_Id); |
| Name_Len := Dot_Pos - Name'First + 1; |
| Name_Buffer (Name_Len) := '.'; |
| Name_Len := Name_Len + 1; |
| Name_Buffer (Name_Len) := 'd'; |
| Dep_Id := Name_Find; |
| |
| -- Compute the dependency path name |
| |
| Get_Name_String (Data.Object_Directory); |
| |
| if Name_Buffer (Name_Len) /= Directory_Separator and then |
| Name_Buffer (Name_Len) /= '/' |
| then |
| Name_Len := Name_Len + 1; |
| Name_Buffer (Name_Len) := Directory_Separator; |
| end if; |
| |
| Add_Str_To_Name_Buffer (Get_Name_String (Dep_Id)); |
| Dep_Path_Id := Name_Find; |
| |
| -- Check if source is already in the list of source for this |
| -- project: it may have already been specified as a naming |
| -- exception for the same language or an other language, or |
| -- they may be two identical file names in different source |
| -- directories. |
| |
| while Source_Id /= No_Other_Source loop |
| Source := In_Tree.Other_Sources.Table (Source_Id); |
| |
| if Source.File_Name = File_Id then |
| |
| -- Two sources of different languages cannot have the same |
| -- file name. |
| |
| if Source.Language /= Language then |
| Error_Msg_Name_1 := File_Name; |
| Error_Msg |
| (Project, In_Tree, |
| "{ cannot be a source of several languages", |
| Real_Location); |
| return; |
| |
| -- No problem if a file has already been specified as |
| -- a naming exception of this language. |
| |
| elsif Source.Path_Name = Path_Id then |
| |
| -- Reset the naming exception flag, if this is not a |
| -- naming exception. |
| |
| if not Naming_Exception then |
| In_Tree.Other_Sources.Table |
| (Source_Id).Naming_Exception := False; |
| end if; |
| |
| return; |
| |
| -- There are several files with the same names, but the |
| -- order of the source directories is known (no /**): |
| -- only the first one encountered is kept, the other ones |
| -- are ignored. |
| |
| elsif Data.Known_Order_Of_Source_Dirs then |
| return; |
| |
| -- But it is an error if the order of the source directories |
| -- is not known. |
| |
| else |
| Error_Msg_Name_1 := File_Name; |
| Error_Msg |
| (Project, In_Tree, |
| "{ is found in several source directories", |
| Real_Location); |
| return; |
| end if; |
| |
| -- Two sources with different file names cannot have the same |
| -- object file name. |
| |
| elsif Source.Object_Name = Obj_Id then |
| Error_Msg_Name_1 := File_Id; |
| Error_Msg_Name_2 := Source.File_Name; |
| Error_Msg_Name_3 := Obj_Id; |
| Error_Msg |
| (Project, In_Tree, |
| "{ and { have the same object file {", |
| Real_Location); |
| return; |
| end if; |
| |
| Source_Id := Source.Next; |
| end loop; |
| |
| if Current_Verbosity = High then |
| Write_Str (" found "); |
| Display_Language_Name (Language); |
| Write_Str (" source """); |
| Write_Str (Get_Name_String (File_Name)); |
| Write_Line (""""); |
| Write_Str (" object path = "); |
| Write_Line (Get_Name_String (Obj_Path_Id)); |
| end if; |
| |
| -- Create the Other_Source record |
| |
| Source := |
| (Language => Language, |
| File_Name => File_Id, |
| Path_Name => Path_Id, |
| Source_TS => File_Stamp (Path_Id), |
| Object_Name => Obj_Id, |
| Object_Path => Obj_Path_Id, |
| Object_TS => File_Stamp (Obj_Path_Id), |
| Dep_Name => Dep_Id, |
| Dep_Path => Dep_Path_Id, |
| Dep_TS => File_Stamp (Dep_Path_Id), |
| Naming_Exception => Naming_Exception, |
| Next => No_Other_Source); |
| |
| -- And add it to the Other_Sources table |
| |
| Other_Source_Table.Increment_Last |
| (In_Tree.Other_Sources); |
| In_Tree.Other_Sources.Table |
| (Other_Source_Table.Last (In_Tree.Other_Sources)) := |
| Source; |
| |
| -- There are sources of languages other than Ada in this project |
| |
| Data.Other_Sources_Present := True; |
| |
| -- And there are sources of this language in this project |
| |
| Set (Language, True, Data, In_Tree); |
| |
| -- Add this source to the list of sources of languages other than |
| -- Ada of the project. |
| |
| if Data.First_Other_Source = No_Other_Source then |
| Data.First_Other_Source := |
| Other_Source_Table.Last (In_Tree.Other_Sources); |
| |
| else |
| In_Tree.Other_Sources.Table (Data.Last_Other_Source).Next := |
| Other_Source_Table.Last (In_Tree.Other_Sources); |
| end if; |
| |
| Data.Last_Other_Source := |
| Other_Source_Table.Last (In_Tree.Other_Sources); |
| end; |
| end if; |
| end Check_For_Source; |
| |
| ------------------------------- |
| -- Check_If_Externally_Built -- |
| ------------------------------- |
| |
| procedure Check_If_Externally_Built |
| (Project : Project_Id; |
| In_Tree : Project_Tree_Ref; |
| Data : in out Project_Data) |
| is |
| Externally_Built : constant Variable_Value := |
| Util.Value_Of |
| (Name_Externally_Built, |
| Data.Decl.Attributes, In_Tree); |
| |
| begin |
| if not Externally_Built.Default then |
| Get_Name_String (Externally_Built.Value); |
| To_Lower (Name_Buffer (1 .. Name_Len)); |
| |
| if Name_Buffer (1 .. Name_Len) = "true" then |
| Data.Externally_Built := True; |
| |
| elsif Name_Buffer (1 .. Name_Len) /= "false" then |
| Error_Msg (Project, In_Tree, |
| "Externally_Built may only be true or false", |
| Externally_Built.Location); |
| end if; |
| end if; |
| |
| if Current_Verbosity = High then |
| Write_Str ("Project is "); |
| |
| if not Data.Externally_Built then |
| Write_Str ("not "); |
| end if; |
| |
| Write_Line ("externally built."); |
| end if; |
| end Check_If_Externally_Built; |
| |
| ----------------------------- |
| -- Check_Naming_Scheme -- |
| ----------------------------- |
| |
| procedure Check_Naming_Scheme |
| (Data : in out Project_Data; |
| Project : Project_Id; |
| In_Tree : Project_Tree_Ref) |
| is |
| Naming_Id : constant Package_Id := |
| Util.Value_Of (Name_Naming, Data.Decl.Packages, In_Tree); |
| |
| Naming : Package_Element; |
| |
| procedure Check_Unit_Names (List : Array_Element_Id); |
| -- Check that a list of unit names contains only valid names |
| |
| ---------------------- |
| -- Check_Unit_Names -- |
| ---------------------- |
| |
| procedure Check_Unit_Names (List : Array_Element_Id) is |
| Current : Array_Element_Id := List; |
| Element : Array_Element; |
| Unit_Name : Name_Id; |
| |
| begin |
| -- Loop through elements of the string list |
| |
| while Current /= No_Array_Element loop |
| Element := In_Tree.Array_Elements.Table (Current); |
| |
| -- Put file name in canonical case |
| |
| Get_Name_String (Element.Value.Value); |
| Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); |
| Element.Value.Value := Name_Find; |
| |
| -- Check that it contains a valid unit name |
| |
| Get_Name_String (Element.Index); |
| Check_Ada_Name (Name_Buffer (1 .. Name_Len), Unit_Name); |
| |
| if Unit_Name = No_Name then |
| Err_Vars.Error_Msg_Name_1 := Element.Index; |
| Error_Msg |
| (Project, In_Tree, |
| "{ is not a valid unit name.", |
| Element.Value.Location); |
| |
| else |
| if Current_Verbosity = High then |
| Write_Str (" Unit ("""); |
| Write_Str (Get_Name_String (Unit_Name)); |
| Write_Line (""")"); |
| end if; |
| |
| Element.Index := Unit_Name; |
| In_Tree.Array_Elements.Table (Current) := Element; |
| end if; |
| |
| Current := Element.Next; |
| end loop; |
| end Check_Unit_Names; |
| |
| -- Start of processing for Check_Naming_Scheme |
| |
| begin |
| -- If there is a package Naming, we will put in Data.Naming what is in |
| -- this package Naming. |
| |
| if Naming_Id /= No_Package then |
| Naming := In_Tree.Packages.Table (Naming_Id); |
| |
| if Current_Verbosity = High then |
| Write_Line ("Checking ""Naming"" for Ada."); |
| end if; |
| |
| declare |
| Bodies : constant Array_Element_Id := |
| Util.Value_Of (Name_Body, Naming.Decl.Arrays, In_Tree); |
| |
| Specs : constant Array_Element_Id := |
| Util.Value_Of (Name_Spec, Naming.Decl.Arrays, In_Tree); |
| |
| begin |
| if Bodies /= No_Array_Element then |
| |
| -- We have elements in the array Body_Part |
| |
| if Current_Verbosity = High then |
| Write_Line ("Found Bodies."); |
| end if; |
| |
| Data.Naming.Bodies := Bodies; |
| Check_Unit_Names (Bodies); |
| |
| else |
| if Current_Verbosity = High then |
| Write_Line ("No Bodies."); |
| end if; |
| end if; |
| |
| if Specs /= No_Array_Element then |
| |
| -- We have elements in the array Specs |
| |
| if Current_Verbosity = High then |
| Write_Line ("Found Specs."); |
| end if; |
| |
| Data.Naming.Specs := Specs; |
| Check_Unit_Names (Specs); |
| |
| else |
| if Current_Verbosity = High then |
| Write_Line ("No Specs."); |
| end if; |
| end if; |
| end; |
| |
| -- We are now checking if variables Dot_Replacement, Casing, |
| -- Spec_Suffix, Body_Suffix and/or Separate_Suffix |
| -- exist. |
| |
| -- For each variable, if it does not exist, we do nothing, |
| -- because we already have the default. |
| |
| -- Check Dot_Replacement |
| |
| declare |
| Dot_Replacement : constant Variable_Value := |
| Util.Value_Of |
| (Name_Dot_Replacement, |
| Naming.Decl.Attributes, In_Tree); |
| |
| begin |
| pragma Assert (Dot_Replacement.Kind = Single, |
| "Dot_Replacement is not a single string"); |
| |
| if not Dot_Replacement.Default then |
| Get_Name_String (Dot_Replacement.Value); |
| |
| if Name_Len = 0 then |
| Error_Msg |
| (Project, In_Tree, |
| "Dot_Replacement cannot be empty", |
| Dot_Replacement.Location); |
| |
| else |
| Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); |
| Data.Naming.Dot_Replacement := Name_Find; |
| Data.Naming.Dot_Repl_Loc := Dot_Replacement.Location; |
| end if; |
| end if; |
| end; |
| |
| if Current_Verbosity = High then |
| Write_Str (" Dot_Replacement = """); |
| Write_Str (Get_Name_String (Data.Naming.Dot_Replacement)); |
| Write_Char ('"'); |
| Write_Eol; |
| end if; |
| |
| -- Check Casing |
| |
| declare |
| Casing_String : constant Variable_Value := |
| Util.Value_Of |
| (Name_Casing, Naming.Decl.Attributes, In_Tree); |
| |
| begin |
| pragma Assert (Casing_String.Kind = Single, |
| "Casing is not a single string"); |
| |
| if not Casing_String.Default then |
| declare |
| Casing_Image : constant String := |
| Get_Name_String (Casing_String.Value); |
| begin |
| declare |
| Casing_Value : constant Casing_Type := |
| Value (Casing_Image); |
| begin |
| Data.Naming.Casing := Casing_Value; |
| end; |
| |
| exception |
| when Constraint_Error => |
| if Casing_Image'Length = 0 then |
| Error_Msg |
| (Project, In_Tree, |
| "Casing cannot be an empty string", |
| Casing_String.Location); |
| |
| else |
| Name_Len := Casing_Image'Length; |
| Name_Buffer (1 .. Name_Len) := Casing_Image; |
| Err_Vars.Error_Msg_Name_1 := Name_Find; |
| Error_Msg |
| (Project, In_Tree, |
| "{ is not a correct Casing", |
| Casing_String.Location); |
| end if; |
| end; |
| end if; |
| end; |
| |
| if Current_Verbosity = High then |
| Write_Str (" Casing = "); |
| Write_Str (Image (Data.Naming.Casing)); |
| Write_Char ('.'); |
| Write_Eol; |
| end if; |
| |
| -- Check Spec_Suffix |
| |
| declare |
| Ada_Spec_Suffix : constant Variable_Value := |
| Prj.Util.Value_Of |
| (Index => Name_Ada, |
| Src_Index => 0, |
| In_Array => Data.Naming.Spec_Suffix, |
| In_Tree => In_Tree); |
| |
| begin |
| if Ada_Spec_Suffix.Kind = Single |
| and then Get_Name_String (Ada_Spec_Suffix.Value) /= "" |
| then |
| Get_Name_String (Ada_Spec_Suffix.Value); |
| Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); |
| Data.Naming.Ada_Spec_Suffix := Name_Find; |
| Data.Naming.Spec_Suffix_Loc := Ada_Spec_Suffix.Location; |
| |
| else |
| Data.Naming.Ada_Spec_Suffix := Default_Ada_Spec_Suffix; |
| end if; |
| end; |
| |
| if Current_Verbosity = High then |
| Write_Str (" Spec_Suffix = """); |
| Write_Str (Get_Name_String (Data.Naming.Ada_Spec_Suffix)); |
| Write_Char ('"'); |
| Write_Eol; |
| end if; |
| |
| -- Check Body_Suffix |
| |
| declare |
| Ada_Body_Suffix : constant Variable_Value := |
| Prj.Util.Value_Of |
| (Index => Name_Ada, |
| Src_Index => 0, |
| In_Array => Data.Naming.Body_Suffix, |
| In_Tree => In_Tree); |
| |
| begin |
| if Ada_Body_Suffix.Kind = Single |
| and then Get_Name_String (Ada_Body_Suffix.Value) /= "" |
| then |
| Get_Name_String (Ada_Body_Suffix.Value); |
| Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); |
| Data.Naming.Ada_Body_Suffix := Name_Find; |
| Data.Naming.Body_Suffix_Loc := Ada_Body_Suffix.Location; |
| |
| else |
| Data.Naming.Ada_Body_Suffix := Default_Ada_Body_Suffix; |
| end if; |
| end; |
| |
| if Current_Verbosity = High then |
| Write_Str (" Body_Suffix = """); |
| Write_Str (Get_Name_String (Data.Naming.Ada_Body_Suffix)); |
| Write_Char ('"'); |
| Write_Eol; |
| end if; |
| |
| -- Check Separate_Suffix |
| |
| declare |
| Ada_Sep_Suffix : constant Variable_Value := |
| Prj.Util.Value_Of |
| (Variable_Name => Name_Separate_Suffix, |
| In_Variables => Naming.Decl.Attributes, |
| In_Tree => In_Tree); |
| |
| begin |
| if Ada_Sep_Suffix.Default then |
| Data.Naming.Separate_Suffix := |
| Data.Naming.Ada_Body_Suffix; |
| |
| else |
| Get_Name_String (Ada_Sep_Suffix.Value); |
| |
| if Name_Len = 0 then |
| Error_Msg |
| (Project, In_Tree, |
| "Separate_Suffix cannot be empty", |
| Ada_Sep_Suffix.Location); |
| |
| else |
| Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); |
| Data.Naming.Separate_Suffix := Name_Find; |
| Data.Naming.Sep_Suffix_Loc := Ada_Sep_Suffix.Location; |
| end if; |
| end if; |
| end; |
| |
| if Current_Verbosity = High then |
| Write_Str (" Separate_Suffix = """); |
| Write_Str (Get_Name_String (Data.Naming.Separate_Suffix)); |
| Write_Char ('"'); |
| Write_Eol; |
| end if; |
| |
| -- Check if Data.Naming is valid |
| |
| Check_Ada_Naming_Scheme_Validity (Project, In_Tree, Data.Naming); |
| |
| else |
| Data.Naming.Ada_Spec_Suffix := Default_Ada_Spec_Suffix; |
| Data.Naming.Ada_Body_Suffix := Default_Ada_Body_Suffix; |
| Data.Naming.Separate_Suffix := Default_Ada_Body_Suffix; |
| end if; |
| end Check_Naming_Scheme; |
| |
| ------------------------------ |
| -- Check_Library_Attributes -- |
| ------------------------------ |
| |
| procedure Check_Library_Attributes |
| (Project : Project_Id; |
| In_Tree : Project_Tree_Ref; |
| Data : in out Project_Data) |
| is |
| Attributes : constant Prj.Variable_Id := Data.Decl.Attributes; |
| |
| Lib_Dir : constant Prj.Variable_Value := |
| Prj.Util.Value_Of |
| (Snames.Name_Library_Dir, Attributes, In_Tree); |
| |
| Lib_Name : constant Prj.Variable_Value := |
| Prj.Util.Value_Of |
| (Snames.Name_Library_Name, Attributes, In_Tree); |
| |
| Lib_Version : constant Prj.Variable_Value := |
| Prj.Util.Value_Of |
| (Snames.Name_Library_Version, Attributes, In_Tree); |
| |
| Lib_ALI_Dir : constant Prj.Variable_Value := |
| Prj.Util.Value_Of |
| (Snames.Name_Library_Ali_Dir, Attributes, In_Tree); |
| |
| The_Lib_Kind : constant Prj.Variable_Value := |
| Prj.Util.Value_Of |
| (Snames.Name_Library_Kind, Attributes, In_Tree); |
| |
| begin |
| -- Special case of extending project |
| |
| if Data.Extends /= No_Project then |
| declare |
| Extended_Data : constant Project_Data := |
| In_Tree.Projects.Table (Data.Extends); |
| |
| begin |
| -- If the project extended is a library project, we inherit |
| -- the library name, if it is not redefined; we check that |
| -- the library directory is specified; and we reset the |
| -- library flag for the extended project. |
| |
| if Extended_Data.Library then |
| if Lib_Name.Default then |
| Data.Library_Name := Extended_Data.Library_Name; |
| end if; |
| |
| if Lib_Dir.Default then |
| if not Data.Virtual then |
| Error_Msg |
| (Project, In_Tree, |
| "a project extending a library project must " & |
| "specify an attribute Library_Dir", |
| Data.Location); |
| end if; |
| end if; |
| |
| In_Tree.Projects.Table (Data.Extends).Library := |
| False; |
| end if; |
| end; |
| end if; |
| |
| pragma Assert (Lib_Dir.Kind = Single); |
| |
| if Lib_Dir.Value = Empty_String then |
| if Current_Verbosity = High then |
| Write_Line ("No library directory"); |
| end if; |
| |
| else |
| -- Find path name, check that it is a directory |
| |
| Locate_Directory |
| (Lib_Dir.Value, Data.Display_Directory, |
| Data.Library_Dir, Data.Display_Library_Dir); |
| |
| if Data.Library_Dir = No_Name then |
| |
| -- Get the absolute name of the library directory that |
| -- does not exist, to report an error. |
| |
| declare |
| Dir_Name : constant String := Get_Name_String (Lib_Dir.Value); |
| |
| begin |
| if Is_Absolute_Path (Dir_Name) then |
| Err_Vars.Error_Msg_Name_1 := Lib_Dir.Value; |
| |
| else |
| Get_Name_String (Data.Display_Directory); |
| |
| if Name_Buffer (Name_Len) /= Directory_Separator then |
| Name_Len := Name_Len + 1; |
| Name_Buffer (Name_Len) := Directory_Separator; |
| end if; |
| |
| Name_Buffer |
| (Name_Len + 1 .. Name_Len + Dir_Name'Length) := |
| Dir_Name; |
| Name_Len := Name_Len + Dir_Name'Length; |
| Err_Vars.Error_Msg_Name_1 := Name_Find; |
| end if; |
| |
| -- Report the error |
| |
| Error_Msg |
| (Project, In_Tree, |
| "library directory { does not exist", |
| Lib_Dir.Location); |
| end; |
| |
| -- The library directory cannot be the same as the Object directory |
| |
| elsif Data.Library_Dir = Data.Object_Directory then |
| Error_Msg |
| (Project, In_Tree, |
| "library directory cannot be the same " & |
| "as object directory", |
| Lib_Dir.Location); |
| Data.Library_Dir := No_Name; |
| Data.Display_Library_Dir := No_Name; |
| |
| else |
| declare |
| OK : Boolean := True; |
| Dirs_Id : String_List_Id; |
| Dir_Elem : String_Element; |
| |
| begin |
| -- The library directory cannot be the same as a source |
| -- directory of the current project. |
| |
| Dirs_Id := Data.Source_Dirs; |
| while Dirs_Id /= Nil_String loop |
| Dir_Elem := In_Tree.String_Elements.Table (Dirs_Id); |
| Dirs_Id := Dir_Elem.Next; |
| |
| if Data.Library_Dir = Dir_Elem.Value then |
| Err_Vars.Error_Msg_Name_1 := Dir_Elem.Value; |
| Error_Msg |
| (Project, In_Tree, |
| "library directory cannot be the same " & |
| "as source directory {", |
| Lib_Dir.Location); |
| OK := False; |
| exit; |
| end if; |
| end loop; |
| |
| if OK then |
| |
| -- The library directory cannot be the same as a source |
| -- directory of another project either. |
| |
| Project_Loop : |
| for Pid in 1 .. Project_Table.Last (In_Tree.Projects) loop |
| if Pid /= Project then |
| Dirs_Id := In_Tree.Projects.Table (Pid).Source_Dirs; |
| |
| Dir_Loop : while Dirs_Id /= Nil_String loop |
| Dir_Elem := In_Tree.String_Elements.Table (Dirs_Id); |
| Dirs_Id := Dir_Elem.Next; |
| |
| if Data.Library_Dir = Dir_Elem.Value then |
| Err_Vars.Error_Msg_Name_1 := Dir_Elem.Value; |
| Err_Vars.Error_Msg_Name_2 := |
| In_Tree.Projects.Table (Pid).Name; |
| |
| Error_Msg |
| (Project, In_Tree, |
| "library directory cannot be the same " & |
| "as source directory { of project {", |
| Lib_Dir.Location); |
| OK := False; |
| exit Project_Loop; |
| end if; |
| end loop Dir_Loop; |
| end if; |
| end loop Project_Loop; |
| end if; |
| |
| if not OK then |
| Data.Library_Dir := No_Name; |
| Data.Display_Library_Dir := No_Name; |
| |
| elsif Current_Verbosity = High then |
| |
| -- Display the Library directory in high verbosity |
| |
| Write_Str ("Library directory ="""); |
| Write_Str (Get_Name_String (Data.Display_Library_Dir)); |
| Write_Line (""""); |
| end if; |
| end; |
| end if; |
| end if; |
| |
| pragma Assert (Lib_Name.Kind = Single); |
| |
| if Lib_Name.Value = Empty_String then |
| if Current_Verbosity = High |
| and then Data.Library_Name = No_Name |
| then |
| Write_Line ("No library name"); |
| end if; |
| |
| else |
| -- There is no restriction on the syntax of library names |
| |
| Data.Library_Name := Lib_Name.Value; |
| end if; |
| |
| if Data.Library_Name /= No_Name |
| and then Current_Verbosity = High |
| then |
| Write_Str ("Library name = """); |
| Write_Str (Get_Name_String (Data.Library_Name)); |
| Write_Line (""""); |
| end if; |
| |
| Data.Library := |
| Data.Library_Dir /= No_Name |
| and then |
| Data.Library_Name /= No_Name; |
| |
| if Data.Library then |
| if MLib.Tgt.Support_For_Libraries = MLib.Tgt.None then |
| Error_Msg |
| (Project, In_Tree, |
| "?libraries are not supported on this platform", |
| Lib_Name.Location); |
| Data.Library := False; |
| |
| else |
| if Lib_ALI_Dir.Value = Empty_String then |
| if Current_Verbosity = High then |
| Write_Line ("No library 'A'L'I directory specified"); |
| end if; |
| Data.Library_ALI_Dir := Data.Library_Dir; |
| Data.Display_Library_ALI_Dir := Data.Display_Library_Dir; |
| |
| else |
| -- Find path name, check that it is a directory |
| |
| Locate_Directory |
| (Lib_ALI_Dir.Value, Data.Display_Directory, |
| Data.Library_ALI_Dir, Data.Display_Library_ALI_Dir); |
| |
| if Data.Library_ALI_Dir = No_Name then |
| |
| -- Get the absolute name of the library ALI directory that |
| -- does not exist, to report an error. |
| |
| declare |
| Dir_Name : constant String := |
| Get_Name_String (Lib_ALI_Dir.Value); |
| |
| begin |
| if Is_Absolute_Path (Dir_Name) then |
| Err_Vars.Error_Msg_Name_1 := Lib_Dir.Value; |
| |
| else |
| Get_Name_String (Data.Display_Directory); |
| |
| if Name_Buffer (Name_Len) /= Directory_Separator then |
| Name_Len := Name_Len + 1; |
| Name_Buffer (Name_Len) := Directory_Separator; |
| end if; |
| |
| Name_Buffer |
| (Name_Len + 1 .. Name_Len + Dir_Name'Length) := |
| Dir_Name; |
| Name_Len := Name_Len + Dir_Name'Length; |
| Err_Vars.Error_Msg_Name_1 := Name_Find; |
| end if; |
| |
| -- Report the error |
| |
| Error_Msg |
| (Project, In_Tree, |
| "library 'A'L'I directory { does not exist", |
| Lib_ALI_Dir.Location); |
| end; |
| end if; |
| |
| if Data.Library_ALI_Dir /= Data.Library_Dir then |
| |
| -- The library ALI directory cannot be the same as the |
| -- Object directory. |
| |
| if Data.Library_ALI_Dir = Data.Object_Directory then |
| Error_Msg |
| (Project, In_Tree, |
| "library 'A'L'I directory cannot be the same " & |
| "as object directory", |
| Lib_ALI_Dir.Location); |
| Data.Library_ALI_Dir := No_Name; |
| Data.Display_Library_ALI_Dir := No_Name; |
| |
| else |
| declare |
| OK : Boolean := True; |
| Dirs_Id : String_List_Id; |
| Dir_Elem : String_Element; |
| |
| begin |
| -- The library ALI directory cannot be the same as |
| -- a source directory of the current project. |
| |
| Dirs_Id := Data.Source_Dirs; |
| while Dirs_Id /= Nil_String loop |
| Dir_Elem := In_Tree.String_Elements.Table (Dirs_Id); |
| Dirs_Id := Dir_Elem.Next; |
| |
| if Data.Library_ALI_Dir = Dir_Elem.Value then |
| Err_Vars.Error_Msg_Name_1 := Dir_Elem.Value; |
| Error_Msg |
| (Project, In_Tree, |
| "library 'A'L'I directory cannot be " & |
| "the same as source directory {", |
| Lib_ALI_Dir.Location); |
| OK := False; |
| exit; |
| end if; |
| end loop; |
| |
| if OK then |
| |
| -- The library ALI directory cannot be the same as |
| -- a source directory of another project either. |
| |
| ALI_Project_Loop : |
| for |
| Pid in 1 .. Project_Table.Last (In_Tree.Projects) |
| loop |
| if Pid /= Project then |
| Dirs_Id := |
| In_Tree.Projects.Table (Pid).Source_Dirs; |
| |
| ALI_Dir_Loop : |
| while Dirs_Id /= Nil_String loop |
| Dir_Elem := |
| In_Tree.String_Elements.Table (Dirs_Id); |
| Dirs_Id := Dir_Elem.Next; |
| |
| if |
| Data.Library_ALI_Dir = Dir_Elem.Value |
| then |
| Err_Vars.Error_Msg_Name_1 := |
| Dir_Elem.Value; |
| Err_Vars.Error_Msg_Name_2 := |
| In_Tree.Projects.Table (Pid).Name; |
| |
| Error_Msg |
| (Project, In_Tree, |
| "library 'A'L'I directory cannot " & |
| "be the same as source directory " & |
| "{ of project {", |
| Lib_ALI_Dir.Location); |
| OK := False; |
| exit ALI_Project_Loop; |
| end if; |
| end loop ALI_Dir_Loop; |
| end if; |
| end loop ALI_Project_Loop; |
| end if; |
| |
| if not OK then |
| Data.Library_ALI_Dir := No_Name; |
| Data.Display_Library_ALI_Dir := No_Name; |
| |
| elsif Current_Verbosity = High then |
| |
| -- Display the Library ALI directory in high |
| -- verbosity. |
| |
| Write_Str ("Library ALI directory ="""); |
| Write_Str |
| (Get_Name_String (Data.Display_Library_ALI_Dir)); |
| Write_Line (""""); |
| end if; |
| end; |
| end if; |
| end if; |
| end if; |
| |
| pragma Assert (Lib_Version.Kind = Single); |
| |
| if Lib_Version.Value = Empty_String then |
| if Current_Verbosity = High then |
| Write_Line ("No library version specified"); |
| end if; |
| |
| else |
| Data.Lib_Internal_Name := Lib_Version.Value; |
| end if; |
| |
| pragma Assert (The_Lib_Kind.Kind = Single); |
| |
| if The_Lib_Kind.Value = Empty_String then |
| if Current_Verbosity = High then |
| Write_Line ("No library kind specified"); |
| end if; |
| |
| else |
| Get_Name_String (The_Lib_Kind.Value); |
| |
| declare |
| Kind_Name : constant String := |
| To_Lower (Name_Buffer (1 .. Name_Len)); |
| |
| OK : Boolean := True; |
| |
| begin |
| if Kind_Name = "static" then |
| Data.Library_Kind := Static; |
| |
| elsif Kind_Name = "dynamic" then |
| Data.Library_Kind := Dynamic; |
| |
| elsif Kind_Name = "relocatable" then |
| Data.Library_Kind := Relocatable; |
| |
| else |
| Error_Msg |
| (Project, In_Tree, |
| "illegal value for Library_Kind", |
| The_Lib_Kind.Location); |
| OK := False; |
| end if; |
| |
| if Current_Verbosity = High and then OK then |
| Write_Str ("Library kind = "); |
| Write_Line (Kind_Name); |
| end if; |
| |
| if Data.Library_Kind /= Static and then |
| MLib.Tgt.Support_For_Libraries = MLib.Tgt.Static_Only |
| then |
| Error_Msg |
| (Project, In_Tree, |
| "only static libraries are supported " & |
| "on this platform", |
| The_Lib_Kind.Location); |
| Data.Library := False; |
| end if; |
| end; |
| end if; |
| |
| if Data.Library and then Current_Verbosity = High then |
| Write_Line ("This is a library project file"); |
| end if; |
| |
| end if; |
| end if; |
| end Check_Library_Attributes; |
| |
| -------------------------- |
| -- Check_Package_Naming -- |
| -------------------------- |
| |
| procedure Check_Package_Naming |
| (Project : Project_Id; |
| In_Tree : Project_Tree_Ref; |
| Data : in out Project_Data) |
| is |
| Naming_Id : constant Package_Id := |
| Util.Value_Of (Name_Naming, Data.Decl.Packages, In_Tree); |
| |
| Naming : Package_Element; |
| |
| begin |
| -- If there is a package Naming, we will put in Data.Naming |
| -- what is in this package Naming. |
| |
| if Naming_Id /= No_Package then |
| Naming := In_Tree.Packages.Table (Naming_Id); |
| |
| if Current_Verbosity = High then |
| Write_Line ("Checking ""Naming""."); |
| end if; |
| |
| -- Check Spec_Suffix |
| |
| declare |
| Spec_Suffixs : Array_Element_Id := |
| Util.Value_Of |
| (Name_Spec_Suffix, |
| Naming.Decl.Arrays, |
| In_Tree); |
| |
| Suffix : Array_Element_Id; |
| Element : Array_Element; |
| Suffix2 : Array_Element_Id; |
| |
| begin |
| -- If some suffixs have been specified, we make sure that |
| -- for each language for which a default suffix has been |
| -- specified, there is a suffix specified, either the one |
| -- in the project file or if there were none, the default. |
| |
| if Spec_Suffixs /= No_Array_Element then |
| Suffix := Data.Naming.Spec_Suffix; |
| |
| while Suffix /= No_Array_Element loop |
| Element := |
| In_Tree.Array_Elements.Table (Suffix); |
| Suffix2 := Spec_Suffixs; |
| |
| while Suffix2 /= No_Array_Element loop |
| exit when In_Tree.Array_Elements.Table |
| (Suffix2).Index = Element.Index; |
| Suffix2 := In_Tree.Array_Elements.Table |
| (Suffix2).Next; |
| end loop; |
| |
| -- There is a registered default suffix, but no |
| -- suffix specified in the project file. |
| -- Add the default to the array. |
| |
| if Suffix2 = No_Array_Element then |
| Array_Element_Table.Increment_Last |
| (In_Tree.Array_Elements); |
| In_Tree.Array_Elements.Table |
| (Array_Element_Table.Last |
| (In_Tree.Array_Elements)) := |
| (Index => Element.Index, |
| Src_Index => Element.Src_Index, |
| Index_Case_Sensitive => False, |
| Value => Element.Value, |
| Next => Spec_Suffixs); |
| Spec_Suffixs := Array_Element_Table.Last |
| (In_Tree.Array_Elements); |
| end if; |
| |
| Suffix := Element.Next; |
| end loop; |
| |
| -- Put the resulting array as the specification suffixs |
| |
| Data.Naming.Spec_Suffix := Spec_Suffixs; |
| end if; |
| end; |
| |
| declare |
| Current : Array_Element_Id := Data.Naming.Spec_Suffix; |
| Element : Array_Element; |
| |
| begin |
| while Current /= No_Array_Element loop |
| Element := In_Tree.Array_Elements.Table (Current); |
| Get_Name_String (Element.Value.Value); |
| |
| if Name_Len = 0 then |
| Error_Msg |
| (Project, In_Tree, |
| "Spec_Suffix cannot be empty", |
| Element.Value.Location); |
| end if; |
| |
| In_Tree.Array_Elements.Table (Current) := Element; |
| Current := Element.Next; |
| end loop; |
| end; |
| |
| -- Check Body_Suffix |
| |
| declare |
| Impl_Suffixs : Array_Element_Id := |
| Util.Value_Of |
| (Name_Body_Suffix, |
| Naming.Decl.Arrays, |
| In_Tree); |
| |
| Suffix : Array_Element_Id; |
| Element : Array_Element; |
| Suffix2 : Array_Element_Id; |
| |
| begin |
| -- If some suffixes have been specified, we make sure that |
| -- for each language for which a default suffix has been |
| -- specified, there is a suffix specified, either the one |
| -- in the project file or if there were noe, the default. |
| |
| if Impl_Suffixs /= No_Array_Element then |
| Suffix := Data.Naming.Body_Suffix; |
| |
| while Suffix /= No_Array_Element loop |
| Element := |
| In_Tree.Array_Elements.Table (Suffix); |
| Suffix2 := Impl_Suffixs; |
| |
| while Suffix2 /= No_Array_Element loop |
| exit when In_Tree.Array_Elements.Table |
| (Suffix2).Index = Element.Index; |
| Suffix2 := In_Tree.Array_Elements.Table |
| (Suffix2).Next; |
| end loop; |
| |
| -- There is a registered default suffix, but no suffix was |
| -- specified in the project file. Add the default to the |
| -- array. |
| |
| if Suffix2 = No_Array_Element then |
| Array_Element_Table.Increment_Last |
| (In_Tree.Array_Elements); |
| In_Tree.Array_Elements.Table |
| (Array_Element_Table.Last |
| (In_Tree.Array_Elements)) := |
| (Index => Element.Index, |
| Src_Index => Element.Src_Index, |
| Index_Case_Sensitive => False, |
| Value => Element.Value, |
| Next => Impl_Suffixs); |
| Impl_Suffixs := Array_Element_Table.Last |
| (In_Tree.Array_Elements); |
| end if; |
| |
| Suffix := Element.Next; |
| end loop; |
| |
| -- Put the resulting array as the implementation suffixs |
| |
| Data.Naming.Body_Suffix := Impl_Suffixs; |
| end if; |
| end; |
| |
| declare |
| Current : Array_Element_Id := Data.Naming.Body_Suffix; |
| Element : Array_Element; |
| |
| begin |
| while Current /= No_Array_Element loop |
| Element := In_Tree.Array_Elements.Table (Current); |
| Get_Name_String (Element.Value.Value); |
| |
| if Name_Len = 0 then |
| Error_Msg |
| (Project, In_Tree, |
| "Body_Suffix cannot be empty", |
| Element.Value.Location); |
| end if; |
| |
| In_Tree.Array_Elements.Table (Current) := Element; |
| Current := Element.Next; |
| end loop; |
| end; |
| |
| -- Get the exceptions, if any |
| |
| Data.Naming.Specification_Exceptions := |
| Util.Value_Of |
| (Name_Specification_Exceptions, |
| In_Arrays => Naming.Decl.Arrays, |
| In_Tree => In_Tree); |
| |
| Data.Naming.Implementation_Exceptions := |
| Util.Value_Of |
| (Name_Implementation_Exceptions, |
| In_Arrays => Naming.Decl.Arrays, |
| In_Tree => In_Tree); |
| end if; |
| end Check_Package_Naming; |
| |
| --------------------------------- |
| -- Check_Programming_Languages -- |
| --------------------------------- |
| |
| procedure Check_Programming_Languages |
| (In_Tree : Project_Tree_Ref; |
| Data : in out Project_Data) |
| is |
| Languages : Variable_Value := Nil_Variable_Value; |
| |
| begin |
| Languages := |
| Prj.Util.Value_Of (Name_Languages, Data.Decl.Attributes, In_Tree); |
| Data.Ada_Sources_Present := Data.Source_Dirs /= Nil_String; |
| Data.Other_Sources_Present := Data.Source_Dirs /= Nil_String; |
| |
| if Data.Source_Dirs /= Nil_String then |
| |
| -- Check if languages are specified in this project |
| |
| if Languages.Default then |
| |
| -- Attribute Languages is not specified. So, it defaults to |
| -- a project of language Ada only. |
| |
| Data.Languages (Ada_Language_Index) := True; |
| |
| -- No sources of languages other than Ada |
| |
| Data.Other_Sources_Present := False; |
| |
| else |
| declare |
| Current : String_List_Id := Languages.Values; |
| Element : String_Element; |
| Lang_Name : Name_Id; |
| Index : Language_Index; |
| |
| begin |
| -- Assume that there is no language specified yet |
| |
| Data.Other_Sources_Present := False; |
| Data.Ada_Sources_Present := False; |
| |
| -- Look through all the languages specified in attribute |
| -- Languages, if any |
| |
| while Current /= Nil_String loop |
| Element := |
| In_Tree.String_Elements.Table (Current); |
| Get_Name_String (Element.Value); |
| To_Lower (Name_Buffer (1 .. Name_Len)); |
| Lang_Name := Name_Find; |
| Index := Language_Indexes.Get (Lang_Name); |
| |
| if Index = No_Language_Index then |
| Add_Language_Name (Lang_Name); |
| Index := Last_Language_Index; |
| end if; |
| |
| Set (Index, True, Data, In_Tree); |
| Set (Language_Processing => Default_Language_Processing_Data, |
| For_Language => Index, |
| In_Project => Data, |
| In_Tree => In_Tree); |
| |
| if Index = Ada_Language_Index then |
| Data.Ada_Sources_Present := True; |
| |
| else |
| Data.Other_Sources_Present := True; |
| end if; |
| |
| Current := Element.Next; |
| end loop; |
| end; |
| end if; |
| end if; |
| end Check_Programming_Languages; |
| |
| ------------------- |
| -- Check_Project -- |
| ------------------- |
| |
| function Check_Project |
| (P : Project_Id; |
| Root_Project : Project_Id; |
| In_Tree : Project_Tree_Ref; |
| Extending : Boolean) return Boolean |
| is |
| begin |
| if P = Root_Project then |
| return True; |
| |
| elsif Extending then |
| declare |
| Data : Project_Data := In_Tree.Projects.Table (Root_Project); |
| |
| begin |
| while Data.Extends /= No_Project loop |
| if P = Data.Extends then |
| return True; |
| end if; |
| |
| Data := In_Tree.Projects.Table (Data.Extends); |
| end loop; |
| end; |
| end if; |
| |
| return False; |
| end Check_Project; |
| |
| ------------------------------- |
| -- Check_Stand_Alone_Library -- |
| ------------------------------- |
| |
| procedure Check_Stand_Alone_Library |
| (Project : Project_Id; |
| In_Tree : Project_Tree_Ref; |
| Data : in out Project_Data; |
| Extending : Boolean) |
| is |
| Lib_Interfaces : constant Prj.Variable_Value := |
| Prj.Util.Value_Of |
| (Snames.Name_Library_Interface, |
| Data.Decl.Attributes, |
| In_Tree); |
| |
| Lib_Auto_Init : constant Prj.Variable_Value := |
| Prj.Util.Value_Of |
| (Snames.Name_Library_Auto_Init, |
| Data.Decl.Attributes, |
| In_Tree); |
| |
| Lib_Src_Dir : constant Prj.Variable_Value := |
| Prj.Util.Value_Of |
| (Snames.Name_Library_Src_Dir, |
| Data.Decl.Attributes, |
| In_Tree); |
| |
| Lib_Symbol_File : constant Prj.Variable_Value := |
| Prj.Util.Value_Of |
| (Snames.Name_Library_Symbol_File, |
| Data.Decl.Attributes, |
| In_Tree); |
| |
| Lib_Symbol_Policy : constant Prj.Variable_Value := |
| Prj.Util.Value_Of |
| (Snames.Name_Library_Symbol_Policy, |
| Data.Decl.Attributes, |
| In_Tree); |
| |
| Lib_Ref_Symbol_File : constant Prj.Variable_Value := |
| Prj.Util.Value_Of |
| (Snames.Name_Library_Reference_Symbol_File, |
| Data.Decl.Attributes, |
| In_Tree); |
| |
| Auto_Init_Supported : constant Boolean := |
| MLib.Tgt. |
| Standalone_Library_Auto_Init_Is_Supported; |
| |
| OK : Boolean := True; |
| |
| begin |
| pragma Assert (Lib_Interfaces.Kind = List); |
| |
| -- It is a stand-alone library project file if attribute |
| -- Library_Interface is defined. |
| |
| if not Lib_Interfaces.Default then |
| SAL_Library : declare |
| Interfaces : String_List_Id := Lib_Interfaces.Values; |
| Interface_ALIs : String_List_Id := Nil_String; |
| Unit : Name_Id; |
| The_Unit_Id : Unit_Id; |
| The_Unit_Data : Unit_Data; |
| |
| procedure Add_ALI_For (Source : Name_Id); |
| -- Add an ALI file name to the list of Interface ALIs |
| |
| ----------------- |
| -- Add_ALI_For -- |
| ----------------- |
| |
| procedure Add_ALI_For (Source : Name_Id) is |
| begin |
| Get_Name_String (Source); |
| |
| declare |
| ALI : constant String := |
| ALI_File_Name (Name_Buffer (1 .. Name_Len)); |
| ALI_Name_Id : Name_Id; |
| begin |
| Name_Len := ALI'Length; |
| Name_Buffer (1 .. Name_Len) := ALI; |
| ALI_Name_Id := Name_Find; |
| |
| String_Element_Table.Increment_Last |
| (In_Tree.String_Elements); |
| In_Tree.String_Elements.Table |
| (String_Element_Table.Last |
| (In_Tree.String_Elements)) := |
| (Value => ALI_Name_Id, |
| Index => 0, |
| Display_Value => ALI_Name_Id, |
| Location => |
| In_Tree.String_Elements.Table |
| (Interfaces).Location, |
| Flag => False, |
| Next => Interface_ALIs); |
| Interface_ALIs := String_Element_Table.Last |
| (In_Tree.String_Elements); |
| end; |
| end Add_ALI_For; |
| |
| -- Start of processing for SAL_Library |
| |
| begin |
| Data.Standalone_Library := True; |
| |
| -- Library_Interface cannot be an empty list |
| |
| if Interfaces = Nil_String then |
| Error_Msg |
| (Project, In_Tree, |
| "Library_Interface cannot be an empty list", |
| Lib_Interfaces.Location); |
| end if; |
| |
| -- Process each unit name specified in the attribute |
| -- Library_Interface. |
| |
| while Interfaces /= Nil_String loop |
| Get_Name_String |
| (In_Tree.String_Elements.Table |
| (Interfaces).Value); |
| To_Lower (Name_Buffer (1 .. Name_Len)); |
| |
| if Name_Len = 0 then |
| Error_Msg |
| (Project, In_Tree, |
| "an interface cannot be an empty string", |
| In_Tree.String_Elements.Table |
| (Interfaces).Location); |
| |
| else |
| Unit := Name_Find; |
| Error_Msg_Name_1 := Unit; |
| The_Unit_Id := |
| Units_Htable.Get (In_Tree.Units_HT, Unit); |
| |
| if The_Unit_Id = No_Unit then |
| Error_Msg |
| (Project, In_Tree, |
| "unknown unit {", |
| In_Tree.String_Elements.Table |
| (Interfaces).Location); |
| |
| else |
| -- Check that the unit is part of the project |
| |
| The_Unit_Data := |
| In_Tree.Units.Table (The_Unit_Id); |
| |
| if The_Unit_Data.File_Names (Body_Part).Name /= No_Name |
| and then The_Unit_Data.File_Names (Body_Part).Path /= |
| Slash |
| then |
| if Check_Project |
| (The_Unit_Data.File_Names (Body_Part).Project, |
| Project, In_Tree, Extending) |
| then |
| -- There is a body for this unit. |
| -- If there is no spec, we need to check |
| -- that it is not a subunit. |
| |
| if The_Unit_Data.File_Names |
| (Specification).Name = No_Name |
| then |
| declare |
| Src_Ind : Source_File_Index; |
| |
| begin |
| Src_Ind := Sinput.P.Load_Project_File |
| (Get_Name_String |
| (The_Unit_Data.File_Names |
| (Body_Part).Path)); |
| |
| if Sinput.P.Source_File_Is_Subunit |
| (Src_Ind) |
| then |
| Error_Msg |
| (Project, In_Tree, |
| "{ is a subunit; " & |
| "it cannot be an interface", |
| In_Tree. |
| String_Elements.Table |
| (Interfaces).Location); |
| end if; |
| end; |
| end if; |
| |
| -- The unit is not a subunit, so we add |
| -- to the Interface ALIs the ALI file |
| -- corresponding to the body. |
| |
| Add_ALI_For |
| (The_Unit_Data.File_Names (Body_Part).Name); |
| |
| else |
| Error_Msg |
| (Project, In_Tree, |
| "{ is not an unit of this project", |
| In_Tree.String_Elements.Table |
| (Interfaces).Location); |
| end if; |
| |
| elsif The_Unit_Data.File_Names |
| (Specification).Name /= No_Name |
| and then The_Unit_Data.File_Names |
| (Specification).Path /= Slash |
| and then Check_Project |
| (The_Unit_Data.File_Names |
| (Specification).Project, |
| Project, In_Tree, Extending) |
| |
| then |
| -- The unit is part of the project, it has |
| -- a spec, but no body. We add to the Interface |
| -- ALIs the ALI file corresponding to the spec. |
| |
| Add_ALI_For |
| (The_Unit_Data.File_Names (Specification).Name); |
| |
| else |
| Error_Msg |
| (Project, In_Tree, |
| "{ is not an unit of this project", |
| In_Tree.String_Elements.Table |
| (Interfaces).Location); |
| end if; |
| end if; |
| |
| end if; |
| |
| Interfaces := |
| In_Tree.String_Elements.Table (Interfaces).Next; |
| end loop; |
| |
| -- Put the list of Interface ALIs in the project data |
| |
| Data.Lib_Interface_ALIs := Interface_ALIs; |
| |
| -- Check value of attribute Library_Auto_Init and set |
| -- Lib_Auto_Init accordingly. |
| |
| if Lib_Auto_Init.Default then |
| |
| -- If no attribute Library_Auto_Init is declared, then |
| -- set auto init only if it is supported. |
| |
| Data.Lib_Auto_Init := Auto_Init_Supported; |
| |
| else |
| Get_Name_String (Lib_Auto_Init.Value); |
| To_Lower (Name_Buffer (1 .. Name_Len)); |
| |
| if Name_Buffer (1 .. Name_Len) = "false" then |
| Data.Lib_Auto_Init := False; |
| |
| elsif Name_Buffer (1 .. Name_Len) = "true" then |
| if Auto_Init_Supported then |
| Data.Lib_Auto_Init := True; |
| |
| else |
| -- Library_Auto_Init cannot be "true" if auto init |
| -- is not supported |
| |
| Error_Msg |
| (Project, In_Tree, |
| "library auto init not supported " & |
| "on this platform", |
| Lib_Auto_Init.Location); |
| end if; |
| |
| else |
| Error_Msg |
| (Project, In_Tree, |
| "invalid value for attribute Library_Auto_Init", |
| Lib_Auto_Init.Location); |
| end if; |
| end if; |
| end SAL_Library; |
| |
| -- If attribute Library_Src_Dir is defined and not the |
| -- empty string, check if the directory exist and is not |
| -- the object directory or one of the source directories. |
| -- This is the directory where copies of the interface |
| -- sources will be copied. Note that this directory may be |
| -- the library directory. |
| |
| if Lib_Src_Dir.Value /= Empty_String then |
| declare |
| Dir_Id : constant Name_Id := Lib_Src_Dir.Value; |
| |
| begin |
| Locate_Directory |
| (Dir_Id, Data.Display_Directory, |
| Data.Library_Src_Dir, |
| Data.Display_Library_Src_Dir); |
| |
| -- If directory does not exist, report an error |
| |
| if Data.Library_Src_Dir = No_Name then |
| |
| -- Get the absolute name of the library directory |
| -- that does not exist, to report an error. |
| |
| declare |
| Dir_Name : constant String := |
| Get_Name_String (Dir_Id); |
| |
| begin |
| if Is_Absolute_Path (Dir_Name) then |
| Err_Vars.Error_Msg_Name_1 := Dir_Id; |
| |
| else |
| Get_Name_String (Data.Directory); |
| |
| if Name_Buffer (Name_Len) /= |
| Directory_Separator |
| then |
| Name_Len := Name_Len + 1; |
| Name_Buffer (Name_Len) := |
| Directory_Separator; |
| end if; |
| |
| Name_Buffer |
| (Name_Len + 1 .. |
| Name_Len + Dir_Name'Length) := |
| Dir_Name; |
| Name_Len := Name_Len + Dir_Name'Length; |
| Err_Vars.Error_Msg_Name_1 := Name_Find; |
| end if; |
| |
| -- Report the error |
| |
| Error_Msg |
| (Project, In_Tree, |
| "Directory { does not exist", |
| Lib_Src_Dir.Location); |
| end; |
| |
| -- Report an error if it is the same as the object |
| -- directory. |
| |
| elsif Data.Library_Src_Dir = Data.Object_Directory then |
| Error_Msg |
| (Project, In_Tree, |
| "directory to copy interfaces cannot be " & |
| "the object directory", |
| Lib_Src_Dir.Location); |
| Data.Library_Src_Dir := No_Name; |
| |
| else |
| declare |
| Src_Dirs : String_List_Id; |
| Src_Dir : String_Element; |
| |
| begin |
| -- Interface copy directory cannot be one of the source |
| -- directory of the current project. |
| |
| Src_Dirs := Data.Source_Dirs; |
| while Src_Dirs /= Nil_String loop |
| Src_Dir := In_Tree.String_Elements.Table |
| (Src_Dirs); |
| |
| -- Report error if it is one of the source directories |
| |
| if Data.Library_Src_Dir = Src_Dir.Value then |
| Error_Msg |
| (Project, In_Tree, |
| "directory to copy interfaces cannot " & |
| "be one of the source directories", |
| Lib_Src_Dir.Location); |
| Data.Library_Src_Dir := No_Name; |
| exit; |
| end if; |
| |
| Src_Dirs := Src_Dir.Next; |
| end loop; |
| |
| if Data.Library_Src_Dir /= No_Name then |
| |
| -- It cannot be a source directory of any other |
| -- project either. |
| |
| Project_Loop : for Pid in 1 .. |
| Project_Table.Last (In_Tree.Projects) |
| loop |
| Src_Dirs := |
| In_Tree.Projects.Table (Pid).Source_Dirs; |
| Dir_Loop : while Src_Dirs /= Nil_String loop |
| Src_Dir := |
| In_Tree.String_Elements.Table (Src_Dirs); |
| |
| -- Report error if it is one of the source |
| -- directories |
| |
| if Data.Library_Src_Dir = Src_Dir.Value then |
| Error_Msg_Name_1 := Src_Dir.Value; |
| Error_Msg_Name_2 := |
| In_Tree.Projects.Table (Pid).Name; |
| Error_Msg |
| (Project, In_Tree, |
| "directory to copy interfaces cannot " & |
| "be the same as source directory { of " & |
| "project {", |
| Lib_Src_Dir.Location); |
| Data.Library_Src_Dir := No_Name; |
| exit Project_Loop; |
| end if; |
| |
| Src_Dirs := Src_Dir.Next; |
| end loop Dir_Loop; |
| end loop Project_Loop; |
| end if; |
| end; |
| |
| -- In high verbosity, if there is a valid Library_Src_Dir, |
| -- display its path name. |
| |
| if Data.Library_Src_Dir /= No_Name |
| and then Current_Verbosity = High |
| then |
| Write_Str ("Directory to copy interfaces ="""); |
| Write_Str (Get_Name_String (Data.Library_Src_Dir)); |
| Write_Line (""""); |
| end if; |
| end if; |
| end; |
| end if; |
| |
| -- Check the symbol related attributes |
| |
| -- First, the symbol policy |
| |
| if not Lib_Symbol_Policy.Default then |
| declare |
| Value : constant String := |
| To_Lower |
| (Get_Name_String (Lib_Symbol_Policy.Value)); |
| |
| begin |
| -- Symbol policy must hove one of a limited number of values |
| |
| if Value = "autonomous" or else Value = "default" then |
| Data.Symbol_Data.Symbol_Policy := Autonomous; |
| |
| elsif Value = "compliant" then |
| Data.Symbol_Data.Symbol_Policy := Compliant; |
| |
| elsif Value = "controlled" then |
| Data.Symbol_Data.Symbol_Policy := Controlled; |
| |
| elsif Value = "restricted" then |
| Data.Symbol_Data.Symbol_Policy := Restricted; |
| |
| else |
| Error_Msg |
| (Project, In_Tree, |
| "illegal value for Library_Symbol_Policy", |
| Lib_Symbol_Policy.Location); |
| end if; |
| end; |
| end if; |
| |
| -- If attribute Library_Symbol_File is not specified, symbol policy |
| -- cannot be Restricted. |
| |
| if Lib_Symbol_File.Default then |
| if Data.Symbol_Data.Symbol_Policy = Restricted then |
| Error_Msg |
| (Project, In_Tree, |
| "Library_Symbol_File needs to be defined when " & |
| "symbol policy is Restricted", |
| Lib_Symbol_Policy.Location); |
| end if; |
| |
| else |
| -- Library_Symbol_File is defined. Check that the file exists |
| |
| Data.Symbol_Data.Symbol_File := Lib_Symbol_File.Value; |
| |
| Get_Name_String (Lib_Symbol_File.Value); |
| |
| if Name_Len = 0 then |
| Error_Msg |
| (Project, In_Tree, |
| "symbol file name cannot be an empty string", |
| Lib_Symbol_File.Location); |
| |
| else |
| OK := not Is_Absolute_Path (Name_Buffer (1 .. Name_Len)); |
| |
| if OK then |
| for J in 1 .. Name_Len loop |
| if Name_Buffer (J) = '/' |
| or else Name_Buffer (J) = Directory_Separator |
| then |
| OK := False; |
| exit; |
| end if; |
| end loop; |
| end if; |
| |
| if not OK then |
| Error_Msg_Name_1 := Lib_Symbol_File.Value; |
| Error_Msg |
| (Project, In_Tree, |
| "symbol file name { is illegal. " & |
| "Name canot include directory info.", |
| Lib_Symbol_File.Location); |
| end if; |
| end if; |
| end if; |
| |
| -- If attribute Library_Reference_Symbol_File is not defined, |
| -- symbol policy cannot be Compilant or Controlled. |
| |
| if Lib_Ref_Symbol_File.Default then |
| if Data.Symbol_Data.Symbol_Policy = Compliant |
| or else Data.Symbol_Data.Symbol_Policy = Controlled |
| then |
| Error_Msg |
| (Project, In_Tree, |
| "a reference symbol file need to be defined", |
| Lib_Symbol_Policy.Location); |
| end if; |
| |
| else |
| -- Library_Reference_Symbol_File is defined, check file exists |
| |
| Data.Symbol_Data.Reference := Lib_Ref_Symbol_File.Value; |
| |
| Get_Name_String (Lib_Ref_Symbol_File.Value); |
| |
| if Name_Len = 0 then |
| Error_Msg |
| (Project, In_Tree, |
| "reference symbol file name cannot be an empty string", |
| Lib_Symbol_File.Location); |
| |
| else |
| OK := not Is_Absolute_Path (Name_Buffer (1 .. Name_Len)); |
| |
| if OK then |
| for J in 1 .. Name_Len loop |
| if Name_Buffer (J) = '/' |
| or else Name_Buffer (J) = Directory_Separator |
| then |
| OK := False; |
| exit; |
| end if; |
| end loop; |
| end if; |
| |
| if not OK then |
| Error_Msg_Name_1 := Lib_Ref_Symbol_File.Value; |
| Error_Msg |
| (Project, In_Tree, |
| "reference symbol file { name is illegal. " & |
| "Name canot include directory info.", |
| Lib_Ref_Symbol_File.Location); |
| end if; |
| |
| if not Is_Regular_File |
| (Get_Name_String (Data.Object_Directory) & |
| Directory_Separator & |
| Get_Name_String (Lib_Ref_Symbol_File.Value)) |
| then |
| Error_Msg_Name_1 := Lib_Ref_Symbol_File.Value; |
| |
| -- For controlled symbol policy, it is an error if the |
| -- reference symbol file does not exist. For other symbol |
| -- policies, this is just a warning |
| |
| Error_Msg_Warn := |
| Data.Symbol_Data.Symbol_Policy /= Controlled; |
| |
| Error_Msg |
| (Project, In_Tree, |
| "<library reference symbol file { does not exist", |
| Lib_Ref_Symbol_File.Location); |
| |
| -- In addition in the non-controlled case, if symbol policy |
| -- is Compliant, it is changed to Autonomous, because there |
| -- is no reference to check against, and we don't want to |
| -- fail in this case. |
| |
| if Data.Symbol_Data.Symbol_Policy /= Controlled then |
| if Data.Symbol_Data.Symbol_Policy = Compliant then |
| Data.Symbol_Data.Symbol_Policy := Autonomous; |
| end if; |
| end if; |
| end if; |
| end if; |
| end if; |
| end if; |
| end Check_Stand_Alone_Library; |
| |
| ---------------------------- |
| -- Compute_Directory_Last -- |
| ---------------------------- |
| |
| function Compute_Directory_Last (Dir : String) return Natural is |
| begin |
| if Dir'Length > 1 |
| and then (Dir (Dir'Last - 1) = Directory_Separator |
| or else Dir (Dir'Last - 1) = '/') |
| then |
| return Dir'Last - 1; |
| else |
| return Dir'Last; |
| end if; |
| end Compute_Directory_Last; |
| |
| -------------------- |
| -- Body_Suffix_Of -- |
| -------------------- |
| |
| function Body_Suffix_Of |
| (Language : Language_Index; |
| In_Project : Project_Data; |
| In_Tree : Project_Tree_Ref) return String |
| is |
| Suffix_Id : constant Name_Id := |
| Suffix_Of (Language, In_Project, In_Tree); |
| begin |
| if Suffix_Id /= No_Name then |
| return Get_Name_String (Suffix_Id); |
| else |
| return "." & Get_Name_String (Language_Names.Table (Language)); |
| end if; |
| end Body_Suffix_Of; |
| |
| --------------- |
| -- Error_Msg -- |
| --------------- |
| |
| procedure Error_Msg |
| (Project : Project_Id; |
| In_Tree : Project_Tree_Ref; |
| Msg : String; |
| Flag_Location : Source_Ptr) |
| is |
| Real_Location : Source_Ptr := Flag_Location; |
| Error_Buffer : String (1 .. 5_000); |
| Error_Last : Natural := 0; |
| Msg_Name : Natural := 0; |
| First : Positive := Msg'First; |
| |
| procedure Add (C : Character); |
| -- Add a character to the buffer |
| |
| procedure Add (S : String); |
| -- Add a string to the buffer |
| |
| procedure Add (Id : Name_Id); |
| -- Add a name to the buffer |
| |
| --------- |
| -- Add -- |
| --------- |
| |
| procedure Add (C : Character) is |
| begin |
| Error_Last := Error_Last + 1; |
| Error_Buffer (Error_Last) := C; |
| end Add; |
| |
| procedure Add (S : String) is |
| begin |
| Error_Buffer (Error_Last + 1 .. Error_Last + S'Length) := S; |
| Error_Last := Error_Last + S'Length; |
| end Add; |
| |
| procedure Add (Id : Name_Id) is |
| begin |
| Get_Name_String (Id); |
| Add (Name_Buffer (1 .. Name_Len)); |
| end Add; |
| |
| -- Start of processing for Error_Msg |
| |
| begin |
| -- If location of error is unknown, use the location of the project |
| |
| if Real_Location = No_Location then |
| Real_Location := In_Tree.Projects.Table (Project).Location; |
| end if; |
| |
| if Error_Report = null then |
| Prj.Err.Error_Msg (Msg, Real_Location); |
| return; |
| end if; |
| |
| -- Ignore continuation character |
| |
| if Msg (First) = '\' then |
| First := First + 1; |
| |
| -- Warniung character is always the first one in this package |
| -- this is an undoocumented kludge!!! |
| |
| elsif Msg (First) = '?' then |
| First := First + 1; |
| Add ("Warning: "); |
| |
| elsif Msg (First) = '<' then |
| First := First + 1; |
| |
| if Err_Vars.Error_Msg_Warn then |
| Add ("Warning: "); |
| end if; |
| end if; |
| |
| for Index in First .. Msg'Last loop |
| if Msg (Index) = '{' or else Msg (Index) = '%' then |
| |
| -- Include a name between double quotes |
| |
| Msg_Name := Msg_Name + 1; |
| Add ('"'); |
| |
| case Msg_Name is |
| when 1 => Add (Err_Vars.Error_Msg_Name_1); |
| when 2 => Add (Err_Vars.Error_Msg_Name_2); |
| when 3 => Add (Err_Vars.Error_Msg_Name_3); |
| |
| when others => null; |
| end case; |
| |
| Add ('"'); |
| |
| else |
| Add (Msg (Index)); |
| end if; |
| |
| end loop; |
| |
| Error_Report (Error_Buffer (1 .. Error_Last), Project, In_Tree); |
| end Error_Msg; |
| |
| ------------------ |
| -- Find_Sources -- |
| ------------------ |
| |
| procedure Find_Sources |
| (Project : Project_Id; |
| In_Tree : Project_Tree_Ref; |
| Data : in out Project_Data; |
| For_Language : Language_Index; |
| Follow_Links : Boolean := False) |
| is |
| Source_Dir : String_List_Id := Data.Source_Dirs; |
| Element : String_Element; |
| Dir : Dir_Type; |
| Current_Source : String_List_Id := Nil_String; |
| Source_Recorded : Boolean := False; |
| |
| begin |
| if Current_Verbosity = High then |
| Write_Line ("Looking for sources:"); |
| end if; |
| |
| -- For each subdirectory |
| |
| while Source_Dir /= Nil_String loop |
| begin |
| Source_Recorded := False; |
| Element := In_Tree.String_Elements.Table (Source_Dir); |
| if Element.Value /= No_Name then |
| Get_Name_String (Element.Display_Value); |
| |
| declare |
| Source_Directory : constant String := |
| Name_Buffer (1 .. Name_Len) & Directory_Separator; |
| Dir_Last : constant Natural := |
| Compute_Directory_Last (Source_Directory); |
| |
| begin |
| if Current_Verbosity = High then |
| Write_Str ("Source_Dir = "); |
| Write_Line (Source_Directory); |
| end if; |
| |
| -- We look to every entry in the source directory |
| |
| Open (Dir, Source_Directory |
| (Source_Directory'First .. Dir_Last)); |
| |
| loop |
| Read (Dir, Name_Buffer, Name_Len); |
| |
| if Current_Verbosity = High then |
| Write_Str (" Checking "); |
| Write_Line (Name_Buffer (1 .. Name_Len)); |
| end if; |
| |
| exit when Name_Len = 0; |
| |
| declare |
| File_Name : constant Name_Id := Name_Find; |
| Path : constant String := |
| Normalize_Pathname |
| (Name => Name_Buffer (1 .. Name_Len), |
| Directory => Source_Directory |
| (Source_Directory'First .. Dir_Last), |
| Resolve_Links => Follow_Links, |
| Case_Sensitive => True); |
| Path_Name : Name_Id; |
| |
| begin |
| Name_Len := Path'Length; |
| Name_Buffer (1 .. Name_Len) := Path; |
| Path_Name := Name_Find; |
| |
| if For_Language = Ada_Language_Index then |
| |
| -- We attempt to register it as a source. However, |
| -- there is no error if the file does not contain |
| -- a valid source. But there is an error if we have |
| -- a duplicate unit name. |
| |
| Record_Ada_Source |
| (File_Name => File_Name, |
| Path_Name => Path_Name, |
| Project => Project, |
| In_Tree => In_Tree, |
| Data => Data, |
| Location => No_Location, |
| Current_Source => Current_Source, |
| Source_Recorded => Source_Recorded, |
| Follow_Links => Follow_Links); |
| |
| else |
| Check_For_Source |
| (File_Name => File_Name, |
| Path_Name => Path_Name, |
| Project => Project, |
| In_Tree => In_Tree, |
| Data => Data, |
| Location => No_Location, |
| Language => For_Language, |
| Suffix => |
| Body_Suffix_Of (For_Language, Data, In_Tree), |
| Naming_Exception => False); |
| end if; |
| end; |
| end loop; |
| |
| Close (Dir); |
| end; |
| end if; |
| |
| exception |
| when Directory_Error => |
| null; |
| end; |
| |
| if Source_Recorded then |
| In_Tree.String_Elements.Table (Source_Dir).Flag := |
| True; |
| end if; |
| |
| Source_Dir := Element.Next; |
| end loop; |
| |
| if Current_Verbosity = High then |
| Write_Line ("end Looking for sources."); |
| end if; |
| |
| if For_Language = Ada_Language_Index then |
| |
| -- If we have looked for sources and found none, then |
| -- it is an error, except if it is an extending project. |
| -- If a non extending project is not supposed to contain |
| -- any source, then we never call Find_Sources. |
| |
| if Current_Source /= Nil_String then |
| Data.Ada_Sources_Present := True; |
| |
| elsif Data.Extends = No_Project then |
| Report_No_Ada_Sources (Project, In_Tree, Data.Location); |
| end if; |
| end if; |
| end Find_Sources; |
| |
| -------------------------------- |
| -- Free_Ada_Naming_Exceptions -- |
| -------------------------------- |
| |
| procedure Free_Ada_Naming_Exceptions is |
| begin |
| Ada_Naming_Exception_Table.Set_Last (0); |
| Ada_Naming_Exceptions.Reset; |
| Reverse_Ada_Naming_Exceptions.Reset; |
| end Free_Ada_Naming_Exceptions; |
| |
| --------------------- |
| -- Get_Directories -- |
| --------------------- |
| |
| procedure Get_Directories |
| (Project : Project_Id; |
| In_Tree : Project_Tree_Ref; |
| Data : in out Project_Data) |
| is |
| Object_Dir : constant Variable_Value := |
| Util.Value_Of |
| (Name_Object_Dir, Data.Decl.Attributes, In_Tree); |
| |
| Exec_Dir : constant Variable_Value := |
| Util.Value_Of |
| (Name_Exec_Dir, Data.Decl.Attributes, In_Tree); |
| |
| Source_Dirs : constant Variable_Value := |
| Util.Value_Of |
| (Name_Source_Dirs, Data.Decl.Attributes, In_Tree); |
| |
| Last_Source_Dir : String_List_Id := Nil_String; |
| |
| procedure Find_Source_Dirs (From : Name_Id; Location : Source_Ptr); |
| -- Find one or several source directories, and add them |
| -- to the list of source directories of the project. |
| |
| ---------------------- |
| -- Find_Source_Dirs -- |
| ---------------------- |
| |
| procedure Find_Source_Dirs (From : Name_Id; Location : Source_Ptr) is |
| Directory : constant String := Get_Name_String (From); |
| Element : String_Element; |
| |
| procedure Recursive_Find_Dirs (Path : Name_Id); |
| -- Find all the subdirectories (recursively) of Path and add them |
| -- to the list of source directories of the project. |
| |
| ------------------------- |
| -- Recursive_Find_Dirs -- |
| ------------------------- |
| |
| procedure Recursive_Find_Dirs (Path : Name_Id) is |
| Dir : Dir_Type; |
| Name : String (1 .. 250); |
| Last : Natural; |
| List : String_List_Id := Data.Source_Dirs; |
| Element : String_Element; |
| Found : Boolean := False; |
| |
| Non_Canonical_Path : Name_Id := No_Name; |
| Canonical_Path : Name_Id := No_Name; |
| |
| The_Path : constant String := |
| Normalize_Pathname (Get_Name_String (Path)) & |
| Directory_Separator; |
| |
| The_Path_Last : constant Natural := |
| Compute_Directory_Last (The_Path); |
| |
| begin |
| Name_Len := The_Path_Last - The_Path'First + 1; |
| Name_Buffer (1 .. Name_Len) := |
| The_Path (The_Path'First .. The_Path_Last); |
| Non_Canonical_Path := Name_Find; |
| Get_Name_String (Non_Canonical_Path); |
| Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); |
| Canonical_Path := Name_Find; |
| |
| -- To avoid processing the same directory several times, check |
| -- if the directory is already in Recursive_Dirs. If it is, |
| -- then there is nothing to do, just return. If it is not, put |
| -- it there and continue recursive processing. |
| |
| if Recursive_Dirs.Get (Canonical_Path) then |
| return; |
| |
| else |
| Recursive_Dirs.Set (Canonical_Path, True); |
| end if; |
| |
| -- Check if directory is already in list |
| |
| while List /= Nil_String loop |
| Element := In_Tree.String_Elements.Table (List); |
| |
| if Element.Value /= No_Name then |
| Found := Element.Value = Canonical_Path; |
| exit when Found; |
| end if; |
| |
| List := Element.Next; |
| end loop; |
| |
| -- If directory is not already in list, put it there |
| |
| if not Found then |
| if Current_Verbosity = High then |
| Write_Str (" "); |
| Write_Line (The_Path (The_Path'First .. The_Path_Last)); |
| end if; |
| |
| String_Element_Table.Increment_Last |
| (In_Tree.String_Elements); |
| Element := |
| (Value => Canonical_Path, |
| Display_Value => Non_Canonical_Path, |
| Location => No_Location, |
| Flag => False, |
| Next => Nil_String, |
| Index => 0); |
| |
| -- Case of first source directory |
| |
| if Last_Source_Dir = Nil_String then |
| Data.Source_Dirs := String_Element_Table.Last |
| (In_Tree.String_Elements); |
| |
| -- Here we already have source directories |
| |
| else |
| -- Link the previous last to the new one |
| |
| In_Tree.String_Elements.Table |
| (Last_Source_Dir).Next := |
| String_Element_Table.Last |
| (In_Tree.String_Elements); |
| end if; |
| |
| -- And register this source directory as the new last |
| |
| Last_Source_Dir := String_Element_Table.Last |
| (In_Tree.String_Elements); |
| In_Tree.String_Elements.Table (Last_Source_Dir) := |
| Element; |
| end if; |
| |
| -- Now look for subdirectories. We do that even when this |
| -- directory is already in the list, because some of its |
| -- subdirectories may not be in the list yet. |
| |
| Open (Dir, The_Path (The_Path'First .. The_Path_Last)); |
| |
| loop |
| Read (Dir, Name, Last); |
| exit when Last = 0; |
| |
| if Name (1 .. Last) /= "." |
| and then Name (1 .. Last) /= ".." |
| then |
| -- Avoid . and .. directories |
| |
| if Current_Verbosity = High then |
| Write_Str (" Checking "); |
| Write_Line (Name (1 .. Last)); |
| end if; |
| |
| declare |
| Path_Name : constant String := |
| Normalize_Pathname |
| (Name => Name (1 .. Last), |
| Directory => |
| The_Path |
| (The_Path'First .. The_Path_Last), |
| Resolve_Links => False, |
| Case_Sensitive => True); |
| |
| begin |
| if Is_Directory (Path_Name) then |
| |
| -- We have found a new subdirectory, call self |
| |
| Name_Len := Path_Name'Length; |
| Name_Buffer (1 .. Name_Len) := Path_Name; |
| Recursive_Find_Dirs (Name_Find); |
| end if; |
| end; |
| end if; |
| end loop; |
| |
| Close (Dir); |
| |
| exception |
| when Directory_Error => |
| null; |
| end Recursive_Find_Dirs; |
| |
| -- Start of processing for Find_Source_Dirs |
| |
| begin |
| if Current_Verbosity = High then |
| Write_Str ("Find_Source_Dirs ("""); |
| Write_Str (Directory); |
| Write_Line (""")"); |
| end if; |
| |
| -- First, check if we are looking for a directory tree, |
| -- indicated by "/**" at the end. |
| |
| if Directory'Length >= 3 |
| and then Directory (Directory'Last - 1 .. Directory'Last) = "**" |
| and then (Directory (Directory'Last - 2) = '/' |
| or else |
| Directory (Directory'Last - 2) = Directory_Separator) |
| then |
| Data.Known_Order_Of_Source_Dirs := False; |
| |
| Name_Len := Directory'Length - 3; |
| |
| if Name_Len = 0 then |
| |
| -- This is the case of "/**": all directories |
| -- in the file system. |
| |
| Name_Len := 1; |
| Name_Buffer (1) := Directory (Directory'First); |
| |
| else |
| Name_Buffer (1 .. Name_Len) := |
| Directory (Directory'First .. Directory'Last - 3); |
| end if; |
| |
| if Current_Verbosity = High then |
| Write_Str ("Looking for all subdirectories of """); |
| Write_Str (Name_Buffer (1 .. Name_Len)); |
| Write_Line (""""); |
| end if; |
| |
| declare |
| Base_Dir : constant Name_Id := Name_Find; |
| Root_Dir : constant String := |
| Normalize_Pathname |
| (Name => Get_Name_String (Base_Dir), |
| Directory => |
| Get_Name_String (Data.Display_Directory), |
| Resolve_Links => False, |
| Case_Sensitive => True); |
| |
| begin |
| if Root_Dir'Length = 0 then |
| Err_Vars.Error_Msg_Name_1 := Base_Dir; |
| |
| if Location = No_Location then |
| Error_Msg |
| (Project, In_Tree, |
| "{ is not a valid directory.", |
| Data.Location); |
| else |
| Error_Msg |
| (Project, In_Tree, |
| "{ is not a valid directory.", |
| Location); |
| end if; |
| |
| else |
| -- We have an existing directory, we register it and all |
| -- of its subdirectories. |
| |
| if Current_Verbosity = High then |
| Write_Line ("Looking for source directories:"); |
| end if; |
| |
| Name_Len := Root_Dir'Length; |
| Name_Buffer (1 .. Name_Len) := Root_Dir; |
| Recursive_Find_Dirs (Name_Find); |
| |
| if Current_Verbosity = High then |
| Write_Line ("End of looking for source directories."); |
| end if; |
| end if; |
| end; |
| |
| -- We have a single directory |
| |
| else |
| declare |
| Path_Name : Name_Id; |
| Display_Path_Name : Name_Id; |
| |
| begin |
| Locate_Directory |
| (From, Data.Display_Directory, Path_Name, Display_Path_Name); |
| |
| if Path_Name = No_Name then |
| Err_Vars.Error_Msg_Name_1 := From; |
| |
| if Location = No_Location then |
| Error_Msg |
| (Project, In_Tree, |
| "{ is not a valid directory", |
| Data.Location); |
| else |
| Error_Msg |
| (Project, In_Tree, |
| "{ is not a valid directory", |
| Location); |
| end if; |
| |
| else |
| -- As it is an existing directory, we add it to |
| -- the list of directories. |
| |
| String_Element_Table.Increment_Last |
| (In_Tree.String_Elements); |
| Element.Value := Path_Name; |
| Element.Display_Value := Display_Path_Name; |
| |
| if Last_Source_Dir = Nil_String then |
| |
| -- This is the first source directory |
| |
| Data.Source_Dirs := String_Element_Table.Last |
| (In_Tree.String_Elements); |
| |
| else |
| -- We already have source directories, |
| -- link the previous last to the new one. |
| |
| In_Tree.String_Elements.Table |
| (Last_Source_Dir).Next := |
| String_Element_Table.Last |
| (In_Tree.String_Elements); |
| end if; |
| |
| -- And register this source directory as the new last |
| |
| Last_Source_Dir := String_Element_Table.Last |
| (In_Tree.String_Elements); |
| In_Tree.String_Elements.Table |
| (Last_Source_Dir) := Element; |
| end if; |
| end; |
| end if; |
| end Find_Source_Dirs; |
| |
| -- Start of processing for Get_Directories |
| |
| begin |
| if Current_Verbosity = High then |
| Write_Line ("Starting to look for directories"); |
| end if; |
| |
| -- Check the object directory |
| |
| pragma Assert (Object_Dir.Kind = Single, |
| "Object_Dir is not a single string"); |
| |
| -- We set the object directory to its default |
| |
| Data.Object_Directory := Data.Directory; |
| Data.Display_Object_Dir := Data.Display_Directory; |
| |
| if Object_Dir.Value /= Empty_String then |
| Get_Name_String (Object_Dir.Value); |
| |
| if Name_Len = 0 then |
| Error_Msg |
| (Project, In_Tree, |
| "Object_Dir cannot be empty", |
| Object_Dir.Location); |
| |
| else |
| -- We check that the specified object directory does exist |
| |
| Locate_Directory |
| (Object_Dir.Value, Data.Display_Directory, |
| Data.Object_Directory, Data.Display_Object_Dir); |
| |
| if Data.Object_Directory = No_Name then |
| |
| -- The object directory does not exist, report an error |
| |
| Err_Vars.Error_Msg_Name_1 := Object_Dir.Value; |
| Error_Msg |
| (Project, In_Tree, |
| "the object directory { cannot be found", |
| Data.Location); |
| |
| -- Do not keep a nil Object_Directory. Set it to the specified |
| -- (relative or absolute) path. This is for the benefit of |
| -- tools that recover from errors; for example, these tools |
| -- could create the non existent directory. |
| |
| Data.Display_Object_Dir := Object_Dir.Value; |
| Get_Name_String (Object_Dir.Value); |
| Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); |
| Data.Object_Directory := Name_Find; |
| end if; |
| end if; |
| end if; |
| |
| if Current_Verbosity = High then |
| if Data.Object_Directory = No_Name then |
| Write_Line ("No object directory"); |
| else |
| Write_Str ("Object directory: """); |
| Write_Str (Get_Name_String (Data.Display_Object_Dir)); |
| Write_Line (""""); |
| end if; |
| end if; |
| |
| -- Check the exec directory |
| |
| pragma Assert (Exec_Dir.Kind = Single, |
| "Exec_Dir is not a single string"); |
| |
| -- We set the object directory to its default |
| |
| Data.Exec_Directory := Data.Object_Directory; |
| Data.Display_Exec_Dir := Data.Display_Object_Dir; |
| |
| if Exec_Dir.Value /= Empty_String then |
| Get_Name_String (Exec_Dir.Value); |
| |
| if Name_Len = 0 then |
| Error_Msg |
| (Project, In_Tree, |
| "Exec_Dir cannot be empty", |
| Exec_Dir.Location); |
| |
| else |
| -- We check that the specified object directory |
| -- does exist. |
| |
| Locate_Directory |
| (Exec_Dir.Value, Data.Directory, |
| Data.Exec_Directory, Data.Display_Exec_Dir); |
| |
| if Data.Exec_Directory = No_Name then |
| Err_Vars.Error_Msg_Name_1 := Exec_Dir.Value; |
| Error_Msg |
| (Project, In_Tree, |
| "the exec directory { cannot be found", |
| Data.Location); |
| end if; |
| end if; |
| end if; |
| |
| if Current_Verbosity = High then |
| if Data.Exec_Directory = No_Name then |
| Write_Line ("No exec directory"); |
| else |
| Write_Str ("Exec directory: """); |
| Write_Str (Get_Name_String (Data.Display_Exec_Dir)); |
| Write_Line (""""); |
| end if; |
| end if; |
| |
| -- Look for the source directories |
| |
| if Current_Verbosity = High then |
| Write_Line ("Starting to look for source directories"); |
| end if; |
| |
| pragma Assert (Source_Dirs.Kind = List, "Source_Dirs is not a list"); |
| |
| if Source_Dirs.Default then |
| |
| -- No Source_Dirs specified: the single source directory |
| -- is the one containing the project file |
| |
| String_Element_Table.Increment_Last |
| (In_Tree.String_Elements); |
| Data.Source_Dirs := String_Element_Table.Last |
| (In_Tree.String_Elements); |
| In_Tree.String_Elements.Table (Data.Source_Dirs) := |
| (Value => Data.Directory, |
| Display_Value => Data.Display_Directory, |
| Location => No_Location, |
| Flag => False, |
| Next => Nil_String, |
| Index => 0); |
| |
| if Current_Verbosity = High then |
| Write_Line ("Single source directory:"); |
| Write_Str (" """); |
| Write_Str (Get_Name_String (Data.Display_Directory)); |
| Write_Line (""""); |
| end if; |
| |
| elsif Source_Dirs.Values = Nil_String then |
| |
| -- If Source_Dirs is an empty string list, this means |
| -- that this project contains no source. For projects that |
| -- don't extend other projects, this also means that there is no |
| -- need for an object directory, if not specified. |
| |
| if Data.Extends = No_Project |
| and then Data.Object_Directory = Data.Directory |
| then |
| Data.Object_Directory := No_Name; |
| end if; |
| |
| Data.Source_Dirs := Nil_String; |
| Data.Ada_Sources_Present := False; |
| Data.Other_Sources_Present := False; |
| |
| else |
| declare |
| Source_Dir : String_List_Id := Source_Dirs.Values; |
| Element : String_Element; |
| |
| begin |
| -- We will find the source directories for each |
| -- element of the list |
| |
| while Source_Dir /= Nil_String loop |
| Element := |
| In_Tree.String_Elements.Table (Source_Dir); |
| Find_Source_Dirs (Element.Value, Element.Location); |
| Source_Dir := Element.Next; |
| end loop; |
| end; |
| end if; |
| |
| if Current_Verbosity = High then |
| Write_Line ("Putting source directories in canonical cases"); |
| end if; |
| |
| declare |
| Current : String_List_Id := Data.Source_Dirs; |
| Element : String_Element; |
| |
| begin |
| while Current /= Nil_String loop |
| Element := In_Tree.String_Elements.Table (Current); |
| if Element.Value /= No_Name then |
| Get_Name_String (Element.Value); |
| Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); |
| Element.Value := Name_Find; |
| In_Tree.String_Elements.Table (Current) := Element; |
| end if; |
| |
| Current := Element.Next; |
| end loop; |
| end; |
| |
| end Get_Directories; |
| |
| --------------- |
| -- Get_Mains -- |
| --------------- |
| |
| procedure Get_Mains |
| (Project : Project_Id; |
| In_Tree : Project_Tree_Ref; |
| Data : in out Project_Data) is |
| Mains : constant Variable_Value := |
| Prj.Util.Value_Of (Name_Main, Data.Decl.Attributes, In_Tree); |
| |
| begin |
| Data.Mains := Mains.Values; |
| |
| -- If no Mains were specified, and if we are an extending |
| -- project, inherit the Mains from the project we are extending. |
| |
| if Mains.Default then |
| if Data.Extends /= No_Project then |
| Data.Mains := |
| In_Tree.Projects.Table (Data.Extends).Mains; |
| end if; |
| |
| -- In a library project file, Main cannot be specified |
| |
| elsif Data.Library then |
| Error_Msg |
| (Project, In_Tree, |
| "a library project file cannot have Main specified", |
| Mains.Location); |
| end if; |
| end Get_Mains; |
| |
| --------------------------- |
| -- Get_Sources_From_File -- |
| --------------------------- |
| |
| procedure Get_Sources_From_File |
| (Path : String; |
| Location : Source_Ptr; |
| Project : Project_Id; |
| In_Tree : Project_Tree_Ref) |
| is |
| File : Prj.Util.Text_File; |
| Line : String (1 .. 250); |
| Last : Natural; |
| Source_Name : Name_Id; |
| |
| begin |
| Source_Names.Reset; |
| |
| if Current_Verbosity = High then |
| Write_Str ("Opening """); |
| Write_Str (Path); |
| Write_Line ("""."); |
| end if; |
| |
| -- Open the file |
| |
| Prj.Util.Open (File, Path); |
| |
| if not Prj.Util.Is_Valid (File) then |
| Error_Msg (Project, In_Tree, "file does not exist", Location); |
| else |
| -- Read the lines one by one |
| |
| while not Prj.Util.End_Of_File (File) loop |
| Prj.Util.Get_Line (File, Line, Last); |
| |
| -- A non empty, non comment line should contain a file name |
| |
| if Last /= 0 |
| and then (Last = 1 or else Line (1 .. 2) /= "--") |
| then |
| -- ??? we should check that there is no directory information |
| |
| Name_Len := Last; |
| Name_Buffer (1 .. Name_Len) := Line (1 .. Last); |
| Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); |
| Source_Name := Name_Find; |
| Source_Names.Set |
| (K => Source_Name, |
| E => |
| (Name => Source_Name, |
| Location => Location, |
| Found => False)); |
| end if; |
| end loop; |
| |
| Prj.Util.Close (File); |
| |
| end if; |
| end Get_Sources_From_File; |
| |
| -------------- |
| -- Get_Unit -- |
| -------------- |
| |
| procedure Get_Unit |
| (Canonical_File_Name : Name_Id; |
| Naming : Naming_Data; |
| Exception_Id : out Ada_Naming_Exception_Id; |
| Unit_Name : out Name_Id; |
| Unit_Kind : out Spec_Or_Body; |
| Needs_Pragma : out Boolean) |
| is |
| Info_Id : Ada_Naming_Exception_Id |
| := Ada_Naming_Exceptions.Get (Canonical_File_Name); |
| VMS_Name : Name_Id; |
| |
| begin |
| if Info_Id = No_Ada_Naming_Exception then |
| if Hostparm.OpenVMS then |
| VMS_Name := Canonical_File_Name; |
| Get_Name_String (VMS_Name); |
| |
| if Name_Buffer (Name_Len) = '.' then |
| Name_Len := Name_Len - 1; |
| VMS_Name := Name_Find; |
| end if; |
| |
| Info_Id := Ada_Naming_Exceptions.Get (VMS_Name); |
| end if; |
| |
| end if; |
| |
| if Info_Id /= No_Ada_Naming_Exception then |
| Exception_Id := Info_Id; |
| Unit_Name := No_Name; |
| Unit_Kind := Specification; |
| Needs_Pragma := True; |
| return; |
| end if; |
| |
| Needs_Pragma := False; |
| Exception_Id := No_Ada_Naming_Exception; |
| |
| Get_Name_String (Canonical_File_Name); |
| |
| declare |
| File : String := Name_Buffer (1 .. Name_Len); |
| First : constant Positive := File'First; |
| Last : Natural := File'Last; |
| Standard_GNAT : Boolean; |
| |
| begin |
| Standard_GNAT := |
| Naming.Ada_Spec_Suffix = Default_Ada_Spec_Suffix |
| and then Naming.Ada_Body_Suffix = Default_Ada_Body_Suffix; |
| |
| -- Check if the end of the file name is Specification_Append |
| |
| Get_Name_String (Naming.Ada_Spec_Suffix); |
| |
| if File'Length > Name_Len |
| and then File (Last - Name_Len + 1 .. Last) = |
| Name_Buffer (1 .. Name_Len) |
| then |
| -- We have a spec |
| |
| Unit_Kind := Specification; |
| Last := Last - Name_Len; |
| |
| if Current_Verbosity = High then |
| Write_Str (" Specification: "); |
| Write_Line (File (First .. Last)); |
| end if; |
| |
| else |
| Get_Name_String (Naming.Ada_Body_Suffix); |
| |
| -- Check if the end of the file name is Body_Append |
| |
| if File'Length > Name_Len |
| and then File (Last - Name_Len + 1 .. Last) = |
| Name_Buffer (1 .. Name_Len) |
| then |
| -- We have a body |
| |
| Unit_Kind := Body_Part; |
| Last := Last - Name_Len; |
| |
| if Current_Verbosity = High then |
| Write_Str (" Body: "); |
| Write_Line (File (First .. Last)); |
| end if; |
| |
| elsif Naming.Separate_Suffix /= Naming.Ada_Spec_Suffix then |
| Get_Name_String (Naming.Separate_Suffix); |
| |
| -- Check if the end of the file name is Separate_Append |
| |
| if File'Length > Name_Len |
| and then File (Last - Name_Len + 1 .. Last) = |
| Name_Buffer (1 .. Name_Len) |
| then |
| -- We have a separate (a body) |
| |
| Unit_Kind := Body_Part; |
| Last := Last - Name_Len; |
| |
| if Current_Verbosity = High then |
| Write_Str (" Separate: "); |
| Write_Line (File (First .. Last)); |
| end if; |
| |
| else |
| Last := 0; |
| end if; |
| |
| else |
| Last := 0; |
| end if; |
| end if; |
| |
| if Last = 0 then |
| |
| -- This is not a source file |
| |
| Unit_Name := No_Name; |
| Unit_Kind := Specification; |
| |
| if Current_Verbosity = High then |
| Write_Line (" Not a valid file name."); |
| end if; |
| |
| return; |
| end if; |
| |
| Get_Name_String (Naming.Dot_Replacement); |
| Standard_GNAT := |
| Standard_GNAT and then Name_Buffer (1 .. Name_Len) = "-"; |
| |
| if Name_Buffer (1 .. Name_Len) /= "." then |
| |
| -- If Dot_Replacement is not a single dot, then there should |
| -- not be any dot in the name. |
| |
| for Index in First .. Last loop |
| if File (Index) = '.' then |
| if Current_Verbosity = High then |
| Write_Line |
| (" Not a valid file name (some dot not replaced)."); |
| end if; |
| |
| Unit_Name := No_Name; |
| return; |
| |
| end if; |
| end loop; |
| |
| -- Replace the substring Dot_Replacement with dots |
| |
| declare |
| Index : Positive := First; |
| |
| begin |
| while Index <= Last - Name_Len + 1 loop |
| |
| if File (Index .. Index + Name_Len - 1) = |
| Name_Buffer (1 .. Name_Len) |
| then |
| File (Index) := '.'; |
| |
| if Name_Len > 1 and then Index < Last then |
| File (Index + 1 .. Last - Name_Len + 1) := |
| File (Index + Name_Len .. Last); |
| end if; |
| |
| Last := Last - Name_Len + 1; |
| end if; |
| |
| Index := Index + 1; |
| end loop; |
| end; |
| end if; |
| |
| -- Check if the casing is right |
| |
| declare |
| Src : String := File (First .. Last); |
| |
| begin |
| case Naming.Casing is |
| when All_Lower_Case => |
| Fixed.Translate |
| (Source => Src, |
| Mapping => Lower_Case_Map); |
| |
| when All_Upper_Case => |
| Fixed.Translate |
| (Source => Src, |
| Mapping => Upper_Case_Map); |
| |
| when Mixed_Case | Unknown => |
| null; |
| end case; |
| |
| if Src /= File (First .. Last) then |
| if Current_Verbosity = High then |
| Write_Line (" Not a valid file name (casing)."); |
| end if; |
| |
| Unit_Name := No_Name; |
| return; |
| end if; |
| |
| -- We put the name in lower case |
| |
| Fixed.Translate |
| (Source => Src, |
| Mapping => Lower_Case_Map); |
| |
| -- In the standard GNAT naming scheme, check for special cases: |
| -- children or separates of A, G, I or S, and run time sources. |
| |
| if Standard_GNAT and then Src'Length >= 3 then |
| declare |
| S1 : constant Character := Src (Src'First); |
| S2 : constant Character := Src (Src'First + 1); |
| S3 : constant Character := Src (Src'First + 2); |
| |
| begin |
| if S1 = 'a' or else S1 = 'g' |
| or else S1 = 'i' or else S1 = 's' |
| then |
| -- Children or separates of packages A, G, I or S |
| |
| if (OpenVMS_On_Target |
| and then S2 = '_' |
| and then S3 = '_') |
| or else |
| S2 = '~' |
| then |
| Src (Src'First + 1) := '.'; |
| |
| -- If it is potentially a run time source, disable |
| -- filling of the mapping file to avoid warnings. |
| |
| elsif S2 = '.' then |
| Set_Mapping_File_Initial_State_To_Empty; |
| end if; |
| |
| end if; |
| end; |
| end if; |
| |
| if Current_Verbosity = High then |
| Write_Str (" "); |
| Write_Line (Src); |
| end if; |
| |
| -- Now, we check if this name is a valid unit name |
| |
| Check_Ada_Name (Name => Src, Unit => Unit_Name); |
| end; |
| |
| end; |
| end Get_Unit; |
| |
| ---------- |
| -- Hash -- |
| ---------- |
| |
| function Hash (Unit : Unit_Info) return Header_Num is |
| begin |
| return Header_Num (Unit.Unit mod 2048); |
| end Hash; |
| |
| ----------------------- |
| -- Is_Illegal_Suffix -- |
| ----------------------- |
| |
| function Is_Illegal_Suffix |
| (Suffix : String; |
| Dot_Replacement_Is_A_Single_Dot : Boolean) return Boolean |
| is |
| begin |
| if Suffix'Length = 0 or else Index (Suffix, ".") = 0 then |
| return True; |
| end if; |
| |
| -- If dot replacement is a single dot, and first character of |
| -- suffix is also a dot |
| |
| if Dot_Replacement_Is_A_Single_Dot |
| and then Suffix (Suffix'First) = '.' |
| then |
| for Index in Suffix'First + 1 .. Suffix'Last loop |
| |
| -- If there is another dot |
| |
| if Suffix (Index) = '.' then |
| |
| -- It is illegal to have a letter following the initial dot |
| |
| return Is_Letter (Suffix (Suffix'First + 1)); |
| end if; |
| end loop; |
| end if; |
| |
| -- Everything is OK |
| |
| return False; |
| end Is_Illegal_Suffix; |
| |
| ---------------------- |
| -- Locate_Directory -- |
| ---------------------- |
| |
| procedure Locate_Directory |
| (Name : Name_Id; |
| Parent : Name_Id; |
| Dir : out Name_Id; |
| Display : out Name_Id) |
| is |
| The_Name : constant String := Get_Name_String (Name); |
| |
| The_Parent : constant String := |
| Get_Name_String (Parent) & Directory_Separator; |
| |
| The_Parent_Last : constant Natural := |
| Compute_Directory_Last (The_Parent); |
| |
| begin |
| if Current_Verbosity = High then |
| Write_Str ("Locate_Directory ("""); |
| Write_Str (The_Name); |
| Write_Str (""", """); |
| Write_Str (The_Parent); |
| Write_Line (""")"); |
| end if; |
| |
| Dir := No_Name; |
| Display := No_Name; |
| |
| if Is_Absolute_Path (The_Name) then |
| if Is_Directory (The_Name) then |
| declare |
| Normed : constant String := |
| Normalize_Pathname |
| (The_Name, |
| Resolve_Links => False, |
| Case_Sensitive => True); |
| |
| Canonical_Path : constant String := |
| Normalize_Pathname |
| (Normed, |
| Resolve_Links => True, |
| Case_Sensitive => False); |
| |
| begin |
| Name_Len := Normed'Length; |
| Name_Buffer (1 .. Name_Len) := Normed; |
| Display := Name_Find; |
| |
| Name_Len := Canonical_Path'Length; |
| Name_Buffer (1 .. Name_Len) := Canonical_Path; |
| Dir := Name_Find; |
| end; |
| end if; |
| |
| else |
| declare |
| Full_Path : constant String := |
| The_Parent (The_Parent'First .. The_Parent_Last) & |
| The_Name; |
| |
| begin |
| if Is_Directory (Full_Path) then |
| declare |
| Normed : constant String := |
| Normalize_Pathname |
| (Full_Path, |
| Resolve_Links => False, |
| Case_Sensitive => True); |
| |
| Canonical_Path : constant String := |
| Normalize_Pathname |
| (Normed, |
| Resolve_Links => True, |
| Case_Sensitive => False); |
| |
| begin |
| Name_Len := Normed'Length; |
| Name_Buffer (1 .. Name_Len) := Normed; |
| Display := Name_Find; |
| |
| Name_Len := Canonical_Path'Length; |
| Name_Buffer (1 .. Name_Len) := Canonical_Path; |
| Dir := Name_Find; |
| end; |
| end if; |
| end; |
| end if; |
| end Locate_Directory; |
| |
| ---------------------- |
| -- Look_For_Sources -- |
| ---------------------- |
| |
| procedure Look_For_Sources |
| (Project : Project_Id; |
| In_Tree : Project_Tree_Ref; |
| Data : in out Project_Data; |
| Follow_Links : Boolean) |
| is |
| procedure Get_Path_Names_And_Record_Sources (Follow_Links : Boolean); |
| -- Find the path names of the source files in the Source_Names table |
| -- in the source directories and record those that are Ada sources. |
| |
| procedure Get_Sources_From_File |
| (Path : String; |
| Location : Source_Ptr); |
| -- Get the sources of a project from a text file |
| |
| --------------------------------------- |
| -- Get_Path_Names_And_Record_Sources -- |
| --------------------------------------- |
| |
| procedure Get_Path_Names_And_Record_Sources (Follow_Links : Boolean) is |
| Source_Dir : String_List_Id := Data.Source_Dirs; |
| Element : String_Element; |
| Path : Name_Id; |
| |
| Dir : Dir_Type; |
| Name : Name_Id; |
| Canonical_Name : Name_Id; |
| Name_Str : String (1 .. 1_024); |
| Last : Natural := 0; |
| NL : Name_Location; |
| |
| Current_Source : String_List_Id := Nil_String; |
| |
| First_Error : Boolean := True; |
| |
| Source_Recorded : Boolean := False; |
| |
| begin |
| -- We look in all source directories for the file names in the |
| -- hash table Source_Names |
| |
| while Source_Dir /= Nil_String loop |
| Source_Recorded := False; |
| Element := In_Tree.String_Elements.Table (Source_Dir); |
| |
| declare |
| Dir_Path : constant String := Get_Name_String (Element.Value); |
| begin |
| if Current_Verbosity = High then |
| Write_Str ("checking directory """); |
| Write_Str (Dir_Path); |
| Write_Line (""""); |
| end if; |
| |
| Open (Dir, Dir_Path); |
| |
| loop |
| Read (Dir, Name_Str, Last); |
| exit when Last = 0; |
| Name_Len := Last; |
| Name_Buffer (1 .. Name_Len) := Name_Str (1 .. Last); |
| Name := Name_Find; |
| Canonical_Case_File_Name (Name_Str (1 .. Last)); |
| Name_Len := Last; |
| Name_Buffer (1 .. Name_Len) := Name_Str (1 .. Last); |
| Canonical_Name := Name_Find; |
| NL := Source_Names.Get (Canonical_Name); |
| |
| if NL /= No_Name_Location and then not NL.Found then |
| NL.Found := True; |
| Source_Names.Set (Canonical_Name, NL); |
| Name_Len := Dir_Path'Length; |
| Name_Buffer (1 .. Name_Len) := Dir_Path; |
| |
| if Name_Buffer (Name_Len) /= Directory_Separator then |
| Add_Char_To_Name_Buffer (Directory_Separator); |
| end if; |
| |
| Add_Str_To_Name_Buffer (Name_Str (1 .. Last)); |
| Path := Name_Find; |
| |
| if Current_Verbosity = High then |
| Write_Str (" found "); |
| Write_Line (Get_Name_String (Name)); |
| end if; |
| |
| -- Register the source if it is an Ada compilation unit |
| |
| Record_Ada_Source |
| (File_Name => Name, |
| Path_Name => Path, |
| Project => Project, |
| In_Tree => In_Tree, |
| Data => Data, |
| Location => NL.Location, |
| Current_Source => Current_Source, |
| Source_Recorded => Source_Recorded, |
| Follow_Links => Follow_Links); |
| end if; |
| end loop; |
| |
| Close (Dir); |
| end; |
| |
| if Source_Recorded then |
| In_Tree.String_Elements.Table (Source_Dir).Flag := |
| True; |
| end if; |
| |
| Source_Dir := Element.Next; |
| end loop; |
| |
| -- It is an error if a source file name in a source list or |
| -- in a source list file is not found. |
| |
| NL := Source_Names.Get_First; |
| |
| while NL /= No_Name_Location loop |
| if not NL.Found then |
| Err_Vars.Error_Msg_Name_1 := NL.Name; |
| |
| if First_Error then |
| Error_Msg |
| (Project, In_Tree, |
| "source file { cannot be found", |
| NL.Location); |
| First_Error := False; |
| |
| else |
| Error_Msg |
| (Project, In_Tree, |
| "\source file { cannot be found", |
| NL.Location); |
| end if; |
| end if; |
| |
| NL := Source_Names.Get_Next; |
| end loop; |
| end Get_Path_Names_And_Record_Sources; |
| |
| --------------------------- |
| -- Get_Sources_From_File -- |
| --------------------------- |
| |
| procedure Get_Sources_From_File |
| (Path : String; |
| Location : Source_Ptr) |
| is |
| begin |
| -- Get the list of sources from the file and put them in hash table |
| -- Source_Names. |
| |
| Get_Sources_From_File (Path, Location, Project, In_Tree); |
| |
| -- Look in the source directories to find those sources |
| |
| Get_Path_Names_And_Record_Sources (Follow_Links); |
| |
| -- We should have found at least one source. |
| -- If not, report an error/warning. |
| |
| if Data.Sources = Nil_String then |
| Report_No_Ada_Sources (Project, In_Tree, Location); |
| end if; |
| end Get_Sources_From_File; |
| |
| begin |
| if Data.Ada_Sources_Present then |
| declare |
| Sources : constant Variable_Value := |
| Util.Value_Of |
| (Name_Source_Files, |
| Data.Decl.Attributes, |
| In_Tree); |
| |
| Source_List_File : constant Variable_Value := |
| Util.Value_Of |
| (Name_Source_List_File, |
| Data.Decl.Attributes, |
| In_Tree); |
| |
| Locally_Removed : constant Variable_Value := |
| Util.Value_Of |
| (Name_Locally_Removed_Files, |
| Data.Decl.Attributes, |
| In_Tree); |
| |
| begin |
| pragma Assert |
| (Sources.Kind = List, |
| "Source_Files is not a list"); |
| |
| pragma Assert |
| (Source_List_File.Kind = Single, |
| "Source_List_File is not a single string"); |
| |
| if not Sources.Default then |
| if not Source_List_File.Default then |
| Error_Msg |
| (Project, In_Tree, |
| "?both variables source_files and " & |
| "source_list_file are present", |
| Source_List_File.Location); |
| end if; |
| |
| -- Sources is a list of file names |
| |
| declare |
| Current : String_List_Id := Sources.Values; |
| Element : String_Element; |
| Location : Source_Ptr; |
| Name : Name_Id; |
| |
| begin |
| Source_Names.Reset; |
| |
| Data.Ada_Sources_Present := Current /= Nil_String; |
| |
| while Current /= Nil_String loop |
| Element := |
| In_Tree.String_Elements.Table (Current); |
| Get_Name_String (Element.Value); |
| Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); |
| Name := Name_Find; |
| |
| -- If the element has no location, then use the |
| -- location of Sources to report possible errors. |
| |
| if Element.Location = No_Location then |
| Location := Sources.Location; |
| else |
| Location := Element.Location; |
| end if; |
| |
| Source_Names.Set |
| (K => Name, |
| E => |
| (Name => Name, |
| Location => Location, |
| Found => False)); |
| |
| Current := Element.Next; |
| end loop; |
| |
| Get_Path_Names_And_Record_Sources (Follow_Links); |
| end; |
| |
| -- No source_files specified |
| |
| -- We check Source_List_File has been specified |
| |
| elsif not Source_List_File.Default then |
| |
| -- Source_List_File is the name of the file |
| -- that contains the source file names |
| |
| declare |
| Source_File_Path_Name : constant String := |
| Path_Name_Of |
| (Source_List_File.Value, |
| Data.Directory); |
| |
| begin |
| if Source_File_Path_Name'Length = 0 then |
| Err_Vars.Error_Msg_Name_1 := Source_List_File.Value; |
| Error_Msg |
| (Project, In_Tree, |
| "file with sources { does not exist", |
| Source_List_File.Location); |
| |
| else |
| Get_Sources_From_File |
| (Source_File_Path_Name, |
| Source_List_File.Location); |
| end if; |
| end; |
| |
| else |
| -- Neither Source_Files nor Source_List_File has been |
| -- specified. Find all the files that satisfy the naming |
| -- scheme in all the source directories. |
| |
| Find_Sources |
| (Project, In_Tree, Data, Ada_Language_Index, Follow_Links); |
| end if; |
| |
| -- If there are sources that are locally removed, mark them as |
| -- such in the Units table. |
| |
| if not Locally_Removed.Default then |
| |
| -- Sources can be locally removed only in extending |
| -- project files. |
| |
| if Data.Extends = No_Project then |
| Error_Msg |
| (Project, In_Tree, |
| "Locally_Removed_Files can only be used " & |
| "in an extending project file", |
| Locally_Removed.Location); |
| |
| else |
| declare |
| Current : String_List_Id := Locally_Removed.Values; |
| Element : String_Element; |
| Location : Source_Ptr; |
| OK : Boolean; |
| Unit : Unit_Data; |
| Name : Name_Id; |
| Extended : Project_Id; |
| |
| begin |
| while Current /= Nil_String loop |
| Element := |
| In_Tree.String_Elements.Table (Current); |
| Get_Name_String (Element.Value); |
| Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); |
| Name := Name_Find; |
| |
| -- If the element has no location, then use the |
| -- location of Locally_Removed to report |
| -- possible errors. |
| |
| if Element.Location = No_Location then |
| Location := Locally_Removed.Location; |
| else |
| Location := Element.Location; |
| end if; |
| |
| OK := False; |
| |
| for Index in Unit_Table.First .. |
| Unit_Table.Last (In_Tree.Units) |
| loop |
| Unit := In_Tree.Units.Table (Index); |
| |
| if Unit.File_Names (Specification).Name = Name then |
| OK := True; |
| |
| -- Check that this is from a project that |
| -- the current project extends, but not the |
| -- current project. |
| |
| Extended := Unit.File_Names |
| (Specification).Project; |
| |
| if Extended = Project then |
| Error_Msg |
| (Project, In_Tree, |
| "cannot remove a source " & |
| "of the same project", |
| Location); |
| |
| elsif |
| Project_Extends (Project, Extended, In_Tree) |
| then |
| Unit.File_Names |
| (Specification).Path := Slash; |
| Unit.File_Names |
| (Specification).Needs_Pragma := False; |
| In_Tree.Units.Table (Index) := |
| Unit; |
| Add_Forbidden_File_Name |
| (Unit.File_Names (Specification).Name); |
| exit; |
| |
| else |
| Error_Msg |
| (Project, In_Tree, |
| "cannot remove a source from " & |
| "another project", |
| Location); |
| end if; |
| |
| elsif |
| Unit.File_Names (Body_Part).Name = Name |
| then |
| OK := True; |
| |
| -- Check that this is from a project that |
| -- the current project extends, but not the |
| -- current project. |
| |
| Extended := Unit.File_Names |
| (Body_Part).Project; |
| |
| if Extended = Project then |
| Error_Msg |
| (Project, In_Tree, |
| "cannot remove a source " & |
| "of the same project", |
| Location); |
| |
| elsif |
| Project_Extends (Project, Extended, In_Tree) |
| then |
| Unit.File_Names (Body_Part).Path := Slash; |
| Unit.File_Names (Body_Part).Needs_Pragma |
| := False; |
| In_Tree.Units.Table (Index) := |
| Unit; |
| Add_Forbidden_File_Name |
| (Unit.File_Names (Body_Part).Name); |
| exit; |
| end if; |
| |
| end if; |
| end loop; |
| |
| if not OK then |
| Err_Vars.Error_Msg_Name_1 := Name; |
| Error_Msg |
| (Project, In_Tree, "unknown file {", Location); |
| end if; |
| |
| Current := Element.Next; |
| end loop; |
| end; |
| end if; |
| end if; |
| end; |
| end if; |
| |
| if Data.Other_Sources_Present then |
| |
| -- Set Source_Present to False. It will be set back to True |
| -- whenever a source is found. |
| |
| Data.Other_Sources_Present := False; |
| for Lang in Ada_Language_Index + 1 .. Last_Language_Index loop |
| |
| -- For each language (other than Ada) in the project file |
| |
| if Is_Present (Lang, Data, In_Tree) then |
| |
| -- Reset the indication that there are sources of this |
| -- language. It will be set back to True whenever we find a |
| -- source of the language. |
| |
| Set (Lang, False, Data, In_Tree); |
| |
| -- First, get the source suffix for the language |
| |
| Set (Suffix => Suffix_For (Lang, Data.Naming, In_Tree), |
| For_Language => Lang, |
| In_Project => Data, |
| In_Tree => In_Tree); |
| |
| -- Then, deal with the naming exceptions, if any |
| |
| Source_Names.Reset; |
| |
| declare |
| Naming_Exceptions : constant Variable_Value := |
| Value_Of |
| (Index => Language_Names.Table (Lang), |
| Src_Index => 0, |
| In_Array => Data.Naming.Implementation_Exceptions, |
| In_Tree => In_Tree); |
| Element_Id : String_List_Id; |
| Element : String_Element; |
| File_Id : Name_Id; |
| Source_Found : Boolean := False; |
| |
| begin |
| -- If there are naming exceptions, look through them one |
| -- by one. |
| |
| if Naming_Exceptions /= Nil_Variable_Value then |
| Element_Id := Naming_Exceptions.Values; |
| |
| while Element_Id /= Nil_String loop |
| Element := In_Tree.String_Elements.Table |
| (Element_Id); |
| Get_Name_String (Element.Value); |
| Canonical_Case_File_Name |
| (Name_Buffer (1 .. Name_Len)); |
| File_Id := Name_Find; |
| |
| -- Put each naming exception in the Source_Names |
| -- hash table, but if there are repetition, don't |
| -- bother after the first instance. |
| |
| if |
| Source_Names.Get (File_Id) = No_Name_Location |
| then |
| Source_Found := True; |
| Source_Names.Set |
| (File_Id, |
| (Name => File_Id, |
| Location => Element.Location, |
| Found => False)); |
| end if; |
| |
| Element_Id := Element.Next; |
| end loop; |
| |
| -- If there is at least one naming exception, record |
| -- those that are found in the source directories. |
| |
| if Source_Found then |
| Record_Other_Sources |
| (Project => Project, |
| In_Tree => In_Tree, |
| Data => Data, |
| Language => Lang, |
| Naming_Exceptions => True); |
| end if; |
| |
| end if; |
| end; |
| |
| -- Now, check if a list of sources is declared either through |
| -- a string list (attribute Source_Files) or a text file |
| -- (attribute Source_List_File). If a source list is declared, |
| -- we will consider only those naming exceptions that are |
| -- on the list. |
| |
| declare |
| Sources : constant Variable_Value := |
| Util.Value_Of |
| (Name_Source_Files, |
| Data.Decl.Attributes, |
| In_Tree); |
| |
| Source_List_File : constant Variable_Value := |
| Util.Value_Of |
| (Name_Source_List_File, |
| Data.Decl.Attributes, |
| In_Tree); |
| |
| begin |
| pragma Assert |
| (Sources.Kind = List, |
| "Source_Files is not a list"); |
| |
| pragma Assert |
| (Source_List_File.Kind = Single, |
| "Source_List_File is not a single string"); |
| |
| if not Sources.Default then |
| if not Source_List_File.Default then |
| Error_Msg |
| (Project, In_Tree, |
| "?both variables source_files and " & |
| "source_list_file are present", |
| Source_List_File.Location); |
| end if; |
| |
| -- Sources is a list of file names |
| |
| declare |
| Current : String_List_Id := Sources.Values; |
| Element : String_Element; |
| Location : Source_Ptr; |
| Name : Name_Id; |
| |
| begin |
| Source_Names.Reset; |
| |
| -- Put all the sources in the Source_Names hash table |
| |
| while Current /= Nil_String loop |
| Element := |
| In_Tree.String_Elements.Table |
| (Current); |
| Get_Name_String (Element.Value); |
| Canonical_Case_File_Name |
| (Name_Buffer (1 .. Name_Len)); |
| Name := Name_Find; |
| |
| -- If the element has no location, then use the |
| -- location of Sources to report possible errors. |
| |
| if Element.Location = No_Location then |
| Location := Sources.Location; |
| else |
| Location := Element.Location; |
| end if; |
| |
| Source_Names.Set |
| (K => Name, |
| E => |
| (Name => Name, |
| Location => Location, |
| Found => False)); |
| |
| Current := Element.Next; |
| end loop; |
| |
| -- And look for their directories |
| |
| Record_Other_Sources |
| (Project => Project, |
| In_Tree => In_Tree, |
| Data => Data, |
| Language => Lang, |
| Naming_Exceptions => False); |
| end; |
| |
| -- No source_files specified |
| |
| -- We check if Source_List_File has been specified |
| |
| elsif not Source_List_File.Default then |
| |
| -- Source_List_File is the name of the file |
| -- that contains the source file names |
| |
| declare |
| Source_File_Path_Name : constant String := |
| Path_Name_Of |
| (Source_List_File.Value, |
| Data.Directory); |
| |
| begin |
| if Source_File_Path_Name'Length = 0 then |
| Err_Vars.Error_Msg_Name_1 := |
| Source_List_File.Value; |
| Error_Msg |
| (Project, In_Tree, |
| "file with sources { does not exist", |
| Source_List_File.Location); |
| |
| else |
| -- Read the file, putting each source in the |
| -- Source_Names hash table. |
| |
| Get_Sources_From_File |
| (Source_File_Path_Name, |
| Source_List_File.Location, |
| Project, In_Tree); |
| |
| -- And look for their directories |
| |
| Record_Other_Sources |
| (Project => Project, |
| In_Tree => In_Tree, |
| Data => Data, |
| Language => Lang, |
| Naming_Exceptions => False); |
| end if; |
| end; |
| |
| -- Neither Source_Files nor Source_List_File was specified |
| |
| else |
| -- Find all the files that satisfy the naming scheme in |
| -- all the source directories. All the naming exceptions |
| -- that effectively exist are also part of the source |
| -- of this language. |
| |
| Find_Sources (Project, In_Tree, Data, Lang); |
| end if; |
| end; |
| end if; |
| end loop; |
| end if; |
| end Look_For_Sources; |
| |
| ------------------ |
| -- Path_Name_Of -- |
| ------------------ |
| |
| function Path_Name_Of |
| (File_Name : Name_Id; |
| Directory : Name_Id) return String |
| is |
| Result : String_Access; |
| |
| The_Directory : constant String := Get_Name_String (Directory); |
| |
| begin |
| Get_Name_String (File_Name); |
| Result := Locate_Regular_File |
| (File_Name => Name_Buffer (1 .. Name_Len), |
| Path => The_Directory); |
| |
| if Result = null then |
| return ""; |
| else |
| Canonical_Case_File_Name (Result.all); |
| return Result.all; |
| end if; |
| end Path_Name_Of; |
| |
| ------------------------------- |
| -- Prepare_Ada_Naming_Exceptions -- |
| ------------------------------- |
| |
| procedure Prepare_Ada_Naming_Exceptions |
| (List : Array_Element_Id; |
| In_Tree : Project_Tree_Ref; |
| Kind : Spec_Or_Body) |
| is |
| Current : Array_Element_Id := List; |
| Element : Array_Element; |
| |
| Unit : Unit_Info; |
| |
| begin |
| -- Traverse the list |
| |
| while Current /= No_Array_Element loop |
| Element := In_Tree.Array_Elements.Table (Current); |
| |
| if Element.Index /= No_Name then |
| Unit := |
| (Kind => Kind, |
| Unit => Element.Index, |
| Next => No_Ada_Naming_Exception); |
| Reverse_Ada_Naming_Exceptions.Set |
| (Unit, (Element.Value.Value, Element.Value.Index)); |
| Unit.Next := Ada_Naming_Exceptions.Get (Element.Value.Value); |
| Ada_Naming_Exception_Table.Increment_Last; |
| Ada_Naming_Exception_Table.Table |
| (Ada_Naming_Exception_Table.Last) := Unit; |
| Ada_Naming_Exceptions.Set |
| (Element.Value.Value, Ada_Naming_Exception_Table.Last); |
| end if; |
| |
| Current := Element.Next; |
| end loop; |
| end Prepare_Ada_Naming_Exceptions; |
| |
| --------------------- |
| -- Project_Extends -- |
| --------------------- |
| |
| function Project_Extends |
| (Extending : Project_Id; |
| Extended : Project_Id; |
| In_Tree : Project_Tree_Ref) return Boolean |
| is |
| Current : Project_Id := Extending; |
| begin |
| loop |
| if Current = No_Project then |
| return False; |
| |
| elsif Current = Extended then |
| return True; |
| end if; |
| |
| Current := In_Tree.Projects.Table (Current).Extends; |
| end loop; |
| end Project_Extends; |
| |
| ----------------------- |
| -- Record_Ada_Source -- |
| ----------------------- |
| |
| procedure Record_Ada_Source |
| (File_Name : Name_Id; |
| Path_Name : Name_Id; |
| Project : Project_Id; |
| In_Tree : Project_Tree_Ref; |
| Data : in out Project_Data; |
| Location : Source_Ptr; |
| Current_Source : in out String_List_Id; |
| Source_Recorded : in out Boolean; |
| Follow_Links : Boolean) |
| is |
| Canonical_File_Name : Name_Id; |
| Canonical_Path_Name : Name_Id; |
| |
| Exception_Id : Ada_Naming_Exception_Id; |
| Unit_Name : Name_Id; |
| Unit_Kind : Spec_Or_Body; |
| Unit_Index : Int := 0; |
| Info : Unit_Info; |
| Name_Index : Name_And_Index; |
| Needs_Pragma : Boolean; |
| |
| The_Location : Source_Ptr := Location; |
| Previous_Source : constant String_List_Id := Current_Source; |
| Except_Name : Name_And_Index := No_Name_And_Index; |
| |
| Unit_Prj : Unit_Project; |
| |
| File_Name_Recorded : Boolean := False; |
| |
| begin |
| Get_Name_String (File_Name); |
| Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); |
| Canonical_File_Name := Name_Find; |
| |
| declare |
| Canonical_Path : constant String := |
| Normalize_Pathname |
| (Get_Name_String (Path_Name), |
| Resolve_Links => Follow_Links, |
| Case_Sensitive => False); |
| begin |
| Name_Len := 0; |
| Add_Str_To_Name_Buffer (Canonical_Path); |
| Canonical_Path_Name := Name_Find; |
| end; |
| |
| -- Find out the unit name, the unit kind and if it needs |
| -- a specific SFN pragma. |
| |
| Get_Unit |
| (Canonical_File_Name => Canonical_File_Name, |
| Naming => Data.Naming, |
| Exception_Id => Exception_Id, |
| Unit_Name => Unit_Name, |
| Unit_Kind => Unit_Kind, |
| Needs_Pragma => Needs_Pragma); |
| |
| if Exception_Id = No_Ada_Naming_Exception and then |
| Unit_Name = No_Name |
| then |
| if Current_Verbosity = High then |
| Write_Str (" """); |
| Write_Str (Get_Name_String (Canonical_File_Name)); |
| Write_Line (""" is not a valid source file name (ignored)."); |
| end if; |
| |
| else |
| -- Check to see if the source has been hidden by an exception, |
| -- but only if it is not an exception. |
| |
| if not Needs_Pragma then |
| Except_Name := |
| Reverse_Ada_Naming_Exceptions.Get |
| ((Unit_Kind, Unit_Name, No_Ada_Naming_Exception)); |
| |
| if Except_Name /= No_Name_And_Index then |
| if Current_Verbosity = High then |
| Write_Str (" """); |
| Write_Str (Get_Name_String (Canonical_File_Name)); |
| Write_Str (""" contains a unit that is found in """); |
| Write_Str (Get_Name_String (Except_Name.Name)); |
| Write_Line (""" (ignored)."); |
| end if; |
| |
| -- The file is not included in the source of the project, |
| -- because it is hidden by the exception. |
| -- So, there is nothing else to do. |
| |
| return; |
| end if; |
| end if; |
| |
| loop |
| if Exception_Id /= No_Ada_Naming_Exception then |
| Info := Ada_Naming_Exception_Table.Table (Exception_Id); |
| Exception_Id := Info.Next; |
| Info.Next := No_Ada_Naming_Exception; |
| Name_Index := Reverse_Ada_Naming_Exceptions.Get (Info); |
| |
| Unit_Name := Info.Unit; |
| Unit_Index := Name_Index.Index; |
| Unit_Kind := Info.Kind; |
| end if; |
| |
| -- Put the file name in the list of sources of the project |
| |
| if not File_Name_Recorded then |
| String_Element_Table.Increment_Last |
| (In_Tree.String_Elements); |
| In_Tree.String_Elements.Table |
| (String_Element_Table.Last |
| (In_Tree.String_Elements)) := |
| (Value => Canonical_File_Name, |
| Display_Value => File_Name, |
| Location => No_Location, |
| Flag => False, |
| Next => Nil_String, |
| Index => Unit_Index); |
| end if; |
| |
| if Current_Source = Nil_String then |
| Data.Sources := String_Element_Table.Last |
| (In_Tree.String_Elements); |
| else |
| In_Tree.String_Elements.Table |
| (Current_Source).Next := |
| String_Element_Table.Last |
| (In_Tree.String_Elements); |
| end if; |
| |
| Current_Source := String_Element_Table.Last |
| (In_Tree.String_Elements); |
| |
| -- Put the unit in unit list |
| |
| declare |
| The_Unit : Unit_Id := |
| Units_Htable.Get (In_Tree.Units_HT, Unit_Name); |
| The_Unit_Data : Unit_Data; |
| |
| begin |
| if Current_Verbosity = High then |
| Write_Str ("Putting "); |
| Write_Str (Get_Name_String (Unit_Name)); |
| Write_Line (" in the unit list."); |
| end if; |
| |
| -- The unit is already in the list, but may be it is |
| -- only the other unit kind (spec or body), or what is |
| -- in the unit list is a unit of a project we are extending. |
| |
| if The_Unit /= No_Unit then |
| The_Unit_Data := In_Tree.Units.Table (The_Unit); |
| |
| if The_Unit_Data.File_Names (Unit_Kind).Name = No_Name |
| or else Project_Extends |
| (Data.Extends, |
| The_Unit_Data.File_Names (Unit_Kind).Project, |
| In_Tree) |
| then |
| if The_Unit_Data.File_Names (Unit_Kind).Path = Slash then |
| Remove_Forbidden_File_Name |
| (The_Unit_Data.File_Names (Unit_Kind).Name); |
| end if; |
| |
| -- Record the file name in the hash table Files_Htable |
| |
| Unit_Prj := (Unit => The_Unit, Project => Project); |
| Files_Htable.Set |
| (In_Tree.Files_HT, |
| Canonical_File_Name, |
| Unit_Prj); |
| |
| The_Unit_Data.File_Names (Unit_Kind) := |
| (Name => Canonical_File_Name, |
| Index => Unit_Index, |
| Display_Name => File_Name, |
| Path => Canonical_Path_Name, |
| Display_Path => Path_Name, |
| Project => Project, |
| Needs_Pragma => Needs_Pragma); |
| In_Tree.Units.Table (The_Unit) := |
| The_Unit_Data; |
| Source_Recorded := True; |
| |
| elsif The_Unit_Data.File_Names (Unit_Kind).Project = Project |
| and then (Data.Known_Order_Of_Source_Dirs or else |
| The_Unit_Data.File_Names (Unit_Kind).Path = |
| Canonical_Path_Name) |
| then |
| if Previous_Source = Nil_String then |
| Data.Sources := Nil_String; |
| else |
| In_Tree.String_Elements.Table |
| (Previous_Source).Next := Nil_String; |
| String_Element_Table.Decrement_Last |
| (In_Tree.String_Elements); |
| end if; |
| |
| Current_Source := Previous_Source; |
| |
| else |
| -- It is an error to have two units with the same name |
| -- and the same kind (spec or body). |
| |
| if The_Location = No_Location then |
| The_Location := |
| In_Tree.Projects.Table |
| (Project).Location; |
| end if; |
| |
| Err_Vars.Error_Msg_Name_1 := Unit_Name; |
| Error_Msg |
| (Project, In_Tree, "duplicate source {", The_Location); |
| |
| Err_Vars.Error_Msg_Name_1 := |
| In_Tree.Projects.Table |
| (The_Unit_Data.File_Names (Unit_Kind).Project).Name; |
| Err_Vars.Error_Msg_Name_2 := |
| The_Unit_Data.File_Names (Unit_Kind).Path; |
| Error_Msg |
| (Project, In_Tree, |
| "\ project file {, {", The_Location); |
| |
| Err_Vars.Error_Msg_Name_1 := |
| In_Tree.Projects.Table (Project).Name; |
| Err_Vars.Error_Msg_Name_2 := Canonical_Path_Name; |
| Error_Msg |
| (Project, In_Tree, |
| "\ project file {, {", The_Location); |
| end if; |
| |
| -- It is a new unit, create a new record |
| |
| else |
| -- First, check if there is no other unit with this file |
| -- name in another project. If it is, report an error. |
| -- Of course, we do that only for the first unit in the |
| -- source file. |
| |
| Unit_Prj := Files_Htable.Get |
| (In_Tree.Files_HT, Canonical_File_Name); |
| |
| if not File_Name_Recorded and then |
| Unit_Prj /= No_Unit_Project |
| then |
| Error_Msg_Name_1 := File_Name; |
| Error_Msg_Name_2 := |
| In_Tree.Projects.Table |
| (Unit_Prj.Project).Name; |
| Error_Msg |
| (Project, In_Tree, |
| "{ is already a source of project {", |
| Location); |
| |
| else |
| Unit_Table.Increment_Last (In_Tree.Units); |
| The_Unit := Unit_Table.Last (In_Tree.Units); |
| Units_Htable.Set |
| (In_Tree.Units_HT, Unit_Name, The_Unit); |
| Unit_Prj := (Unit => The_Unit, Project => Project); |
| Files_Htable.Set |
| (In_Tree.Files_HT, |
| Canonical_File_Name, |
| Unit_Prj); |
| The_Unit_Data.Name := Unit_Name; |
| The_Unit_Data.File_Names (Unit_Kind) := |
| (Name => Canonical_File_Name, |
| Index => Unit_Index, |
| Display_Name => File_Name, |
| Path => Canonical_Path_Name, |
| Display_Path => Path_Name, |
| Project => Project, |
| Needs_Pragma => Needs_Pragma); |
| In_Tree.Units.Table (The_Unit) := |
| The_Unit_Data; |
| Source_Recorded := True; |
| end if; |
| end if; |
| end; |
| |
| exit when Exception_Id = No_Ada_Naming_Exception; |
| File_Name_Recorded := True; |
| end loop; |
| end if; |
| end Record_Ada_Source; |
| |
| -------------------------- |
| -- Record_Other_Sources -- |
| -------------------------- |
| |
| procedure Record_Other_Sources |
| (Project : Project_Id; |
| In_Tree : Project_Tree_Ref; |
| Data : in out Project_Data; |
| Language : Language_Index; |
| Naming_Exceptions : Boolean) |
| is |
| Source_Dir : String_List_Id := Data.Source_Dirs; |
| Element : String_Element; |
| Path : Name_Id; |
| |
| Dir : Dir_Type; |
| Canonical_Name : Name_Id; |
| |
| Name_Str : String (1 .. 1_024); |
| Last : Natural := 0; |
| NL : Name_Location; |
| |
| First_Error : Boolean := True; |
| |
| Suffix : constant String := Body_Suffix_Of (Language, Data, In_Tree); |
| |
| begin |
| while Source_Dir /= Nil_String loop |
| Element := In_Tree.String_Elements.Table (Source_Dir); |
| |
| declare |
| Dir_Path : constant String := Get_Name_String (Element.Value); |
| |
| begin |
| if Current_Verbosity = High then |
| Write_Str ("checking directory """); |
| Write_Str (Dir_Path); |
| Write_Str (""" for "); |
| |
| if Naming_Exceptions then |
| Write_Str ("naming exceptions"); |
| |
| else |
| Write_Str ("sources"); |
| end if; |
| |
| Write_Str (" of Language "); |
| Display_Language_Name (Language); |
| end if; |
| |
| Open (Dir, Dir_Path); |
| |
| loop |
| Read (Dir, Name_Str, Last); |
| exit when Last = 0; |
| |
| if Is_Regular_File |
| (Dir_Path & Directory_Separator & Name_Str (1 .. Last)) |
| then |
| Name_Len := Last; |
| Name_Buffer (1 .. Name_Len) := Name_Str (1 .. Last); |
| Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); |
| Canonical_Name := Name_Find; |
| NL := Source_Names.Get (Canonical_Name); |
| |
| if NL /= No_Name_Location then |
| if NL.Found then |
| if not Data.Known_Order_Of_Source_Dirs then |
| Error_Msg_Name_1 := Canonical_Name; |
| Error_Msg |
| (Project, In_Tree, |
| "{ is found in several source directories", |
| NL.Location); |
| end if; |
| |
| else |
| NL.Found := True; |
| Source_Names.Set (Canonical_Name, NL); |
| Name_Len := Dir_Path'Length; |
| Name_Buffer (1 .. Name_Len) := Dir_Path; |
| Add_Char_To_Name_Buffer (Directory_Separator); |
| Add_Str_To_Name_Buffer (Name_Str (1 .. Last)); |
| Path := Name_Find; |
| |
| Check_For_Source |
| (File_Name => Canonical_Name, |
| Path_Name => Path, |
| Project => Project, |
| In_Tree => In_Tree, |
| Data => Data, |
| Location => NL.Location, |
| Language => Language, |
| Suffix => Suffix, |
| Naming_Exception => Naming_Exceptions); |
| end if; |
| end if; |
| end if; |
| end loop; |
| |
| Close (Dir); |
| end; |
| |
| Source_Dir := Element.Next; |
| end loop; |
| |
| if not Naming_Exceptions then |
| NL := Source_Names.Get_First; |
| |
| -- It is an error if a source file name in a source list or |
| -- in a source list file is not found. |
| |
| while NL /= No_Name_Location loop |
| if not NL.Found then |
| Err_Vars.Error_Msg_Name_1 := NL.Name; |
| |
| if First_Error then |
| Error_Msg |
| (Project, In_Tree, |
| "source file { cannot be found", |
| NL.Location); |
| First_Error := False; |
| |
| else |
| Error_Msg |
| (Project, In_Tree, |
| "\source file { cannot be found", |
| NL.Location); |
| end if; |
| end if; |
| |
| NL := Source_Names.Get_Next; |
| end loop; |
| |
| -- Any naming exception of this language that is not in a list |
| -- of sources must be removed. |
| |
| declare |
| Source_Id : Other_Source_Id := Data.First_Other_Source; |
| Prev_Id : Other_Source_Id := No_Other_Source; |
| Source : Other_Source; |
| |
| begin |
| while Source_Id /= No_Other_Source loop |
| Source := In_Tree.Other_Sources.Table (Source_Id); |
| |
| if Source.Language = Language |
| and then Source.Naming_Exception |
| then |
| if Current_Verbosity = High then |
| Write_Str ("Naming exception """); |
| Write_Str (Get_Name_String (Source.File_Name)); |
| Write_Str (""" is not in the list of sources,"); |
| Write_Line (" so it is removed."); |
| end if; |
| |
| if Prev_Id = No_Other_Source then |
| Data.First_Other_Source := Source.Next; |
| |
| else |
| In_Tree.Other_Sources.Table |
| (Prev_Id).Next := Source.Next; |
| end if; |
| |
| Source_Id := Source.Next; |
| |
| if Source_Id = No_Other_Source then |
| Data.Last_Other_Source := Prev_Id; |
| end if; |
| |
| else |
| Prev_Id := Source_Id; |
| Source_Id := Source.Next; |
| end if; |
| end loop; |
| end; |
| end if; |
| end Record_Other_Sources; |
| |
| --------------------------- |
| -- Report_No_Ada_Sources -- |
| --------------------------- |
| |
| procedure Report_No_Ada_Sources |
| (Project : Project_Id; |
| In_Tree : Project_Tree_Ref; |
| Location : Source_Ptr) |
| is |
| begin |
| case When_No_Sources is |
| when Silent => |
| null; |
| |
| when Warning | Error => |
| Error_Msg_Warn := When_No_Sources = Warning; |
| |
| Error_Msg |
| (Project, In_Tree, |
| "<there are no Ada sources in this project", |
| Location); |
| end case; |
| end Report_No_Ada_Sources; |
| |
| ---------------------- |
| -- Show_Source_Dirs -- |
| ---------------------- |
| |
| procedure Show_Source_Dirs |
| (Project : Project_Id; |
| In_Tree : Project_Tree_Ref) |
| is |
| Current : String_List_Id; |
| Element : String_Element; |
| |
| begin |
| Write_Line ("Source_Dirs:"); |
| |
| Current := In_Tree.Projects.Table (Project).Source_Dirs; |
| while Current /= Nil_String loop |
| Element := In_Tree.String_Elements.Table (Current); |
| Write_Str (" "); |
| Write_Line (Get_Name_String (Element.Value)); |
| Current := Element.Next; |
| end loop; |
| |
| Write_Line ("end Source_Dirs."); |
| end Show_Source_Dirs; |
| |
| ---------------- |
| -- Suffix_For -- |
| ---------------- |
| |
| function Suffix_For |
| (Language : Language_Index; |
| Naming : Naming_Data; |
| In_Tree : Project_Tree_Ref) return Name_Id |
| is |
| Suffix : constant Variable_Value := |
| Value_Of |
| (Index => Language_Names.Table (Language), |
| Src_Index => 0, |
| In_Array => Naming.Body_Suffix, |
| In_Tree => In_Tree); |
| begin |
| -- If no suffix for this language in package Naming, use the default |
| |
| if Suffix = Nil_Variable_Value then |
| Name_Len := 0; |
| |
| case Language is |
| when Ada_Language_Index => |
| Add_Str_To_Name_Buffer (".adb"); |
| |
| when C_Language_Index => |
| Add_Str_To_Name_Buffer (".c"); |
| |
| when C_Plus_Plus_Language_Index => |
| Add_Str_To_Name_Buffer (".cpp"); |
| |
| when others => |
| return No_Name; |
| end case; |
| |
| -- Otherwise use the one specified |
| |
| else |
| Get_Name_String (Suffix.Value); |
| end if; |
| |
| Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); |
| return Name_Find; |
| end Suffix_For; |
| |
| ------------------------- |
| -- Warn_If_Not_Sources -- |
| ------------------------- |
| |
| -- comments needed in this body ??? |
| |
| procedure Warn_If_Not_Sources |
| (Project : Project_Id; |
| In_Tree : Project_Tree_Ref; |
| Conventions : Array_Element_Id; |
| Specs : Boolean; |
| Extending : Boolean) |
| is |
| Conv : Array_Element_Id := Conventions; |
| Unit : Name_Id; |
| The_Unit_Id : Unit_Id; |
| The_Unit_Data : Unit_Data; |
| Location : Source_Ptr; |
| |
| begin |
| while Conv /= No_Array_Element loop |
| Unit := In_Tree.Array_Elements.Table (Conv).Index; |
| Error_Msg_Name_1 := Unit; |
| Get_Name_String (Unit); |
| To_Lower (Name_Buffer (1 .. Name_Len)); |
| Unit := Name_Find; |
| The_Unit_Id := Units_Htable.Get |
| (In_Tree.Units_HT, Unit); |
| Location := In_Tree.Array_Elements.Table |
| (Conv).Value.Location; |
| |
| if The_Unit_Id = No_Unit then |
| Error_Msg |
| (Project, In_Tree, |
| "?unknown unit {", |
| Location); |
| |
| else |
| The_Unit_Data := In_Tree.Units.Table (The_Unit_Id); |
| Error_Msg_Name_2 := |
| In_Tree.Array_Elements.Table (Conv).Value.Value; |
| |
| if Specs then |
| if not Check_Project |
| (The_Unit_Data.File_Names (Specification).Project, |
| Project, In_Tree, Extending) |
| then |
| Error_Msg |
| (Project, In_Tree, |
| "?source of spec of unit { ({)" & |
| " cannot be found in this project", |
| Location); |
| end if; |
| |
| else |
| if not Check_Project |
| (The_Unit_Data.File_Names (Body_Part).Project, |
| Project, In_Tree, Extending) |
| then |
| Error_Msg |
| (Project, In_Tree, |
| "?source of body of unit { ({)" & |
| " cannot be found in this project", |
| Location); |
| end if; |
| end if; |
| end if; |
| |
| Conv := In_Tree.Array_Elements.Table (Conv).Next; |
| end loop; |
| end Warn_If_Not_Sources; |
| |
| end Prj.Nmsc; |