(Switches_Of): New function (Test_If_Relative_Path): New procedure (Add_Switches): Use new function Switches_Of (Collect_Arguments_And_Compile): Use new function Switches_Of. When using a project file, test if there are any relative search path. Fail if there are any. (Gnatmake): Only add switches for the primary directory when not using a project file. When using a project file, change directory to the object directory of the main project file. When using a project file, test if there are any relative search path. Fail if there are any. When using a project file, fail if specified executable is relative path with directory information, and prepend executable, if not specified as an absolute path, with the exec directory. Make sure that only one -o switch is transmitted to the linker. * prj-attr.adb (Initialization_Data): Add project attribute Exec_Dir * prj-nmsc.adb: (Ada_Check): Get Spec_Suffix_Loc and Impl_Suffix_Loc, when using a non standard naming scheme. (Check_Ada_Naming_Scheme): Make sure that error messages do not raise exceptions. (Is_Illegal_Append): Return True if there is no dot in the suffix. (Language_Independent_Check): Check the exec directory. * prj.adb (Project_Empty): Add new component Exec_Directory * prj.ads: (Default_Ada_Spec_Suffix, Default_Ada_Impl_Suffix): Add defaults. (Project_Data): Add component Exec_Directory * snames.adb: Updated to match snames.ads revision 1.215 * snames.ads: Added Exec_Dir * make.adb: Minor reformatting * prj-nmsc.adb: Minor reformatting * snames.adb: Updated to match snames.ads * snames.ads: Alphebetize entries for project file * trans.c (process_freeze_entity): Do nothing if the entity is a subprogram that was already elaborated. * decl.c (gnat_to_gnu_entity, object): Do not back-annotate Alignment and Esize if object is referenced via pointer. From-SVN: r48127
2426 lines
78 KiB
Ada
2426 lines
78 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT COMPILER COMPONENTS --
|
|
-- --
|
|
-- P R J . N M S C --
|
|
-- --
|
|
-- B o d y --
|
|
-- --
|
|
-- $Revision$
|
|
-- --
|
|
-- Copyright (C) 2000-2001 Free Software Foundation, Inc. --
|
|
-- --
|
|
-- GNAT is free software; you can redistribute it and/or modify it under --
|
|
-- terms of the GNU General Public License as published by the Free Soft- --
|
|
-- ware Foundation; either version 2, or (at your option) any later ver- --
|
|
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
|
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
|
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
|
|
-- for more details. You should have received a copy of the GNU General --
|
|
-- Public License distributed with GNAT; see file COPYING. If not, write --
|
|
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
|
-- MA 02111-1307, USA. --
|
|
-- --
|
|
-- GNAT was originally developed by the GNAT team at New York University. --
|
|
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
|
-- --
|
|
------------------------------------------------------------------------------
|
|
|
|
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 Errout; use Errout;
|
|
with GNAT.Case_Util; use GNAT.Case_Util;
|
|
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
|
|
with GNAT.OS_Lib; use GNAT.OS_Lib;
|
|
with MLib.Tgt;
|
|
with Namet; use Namet;
|
|
with Osint; use Osint;
|
|
with Output; use Output;
|
|
with Prj.Com; use Prj.Com;
|
|
with Prj.Util; use Prj.Util;
|
|
with Snames; use Snames;
|
|
with Stringt; use Stringt;
|
|
with Types; use Types;
|
|
|
|
package body Prj.Nmsc is
|
|
|
|
Dir_Sep : Character renames GNAT.OS_Lib.Directory_Separator;
|
|
|
|
Error_Report : Put_Line_Access := null;
|
|
|
|
procedure Check_Ada_Naming_Scheme (Naming : Naming_Data);
|
|
-- Check that the package Naming is correct.
|
|
|
|
procedure Check_Ada_Name
|
|
(Name : Name_Id;
|
|
Unit : out Name_Id);
|
|
-- Check that a name is a valid Ada unit name.
|
|
|
|
procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr);
|
|
-- Output an error message. If Error_Report is null, simply call
|
|
-- Errout.Error_Msg. Otherwise, disregard Flag_Location and use
|
|
-- Error_Report.
|
|
|
|
function Get_Name_String (S : String_Id) return String;
|
|
-- Get the string from a String_Id
|
|
|
|
procedure Get_Unit
|
|
(File_Name : Name_Id;
|
|
Naming : Naming_Data;
|
|
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.
|
|
|
|
function Is_Illegal_Append (This : String) return Boolean;
|
|
-- Returns True if the string This cannot be used as
|
|
-- a Specification_Append, a Body_Append or a Separate_Append.
|
|
|
|
procedure Record_Source
|
|
(File_Name : Name_Id;
|
|
Path_Name : Name_Id;
|
|
Project : Project_Id;
|
|
Data : in out Project_Data;
|
|
Location : Source_Ptr;
|
|
Current_Source : in out String_List_Id);
|
|
-- Put a unit in the list of units of a project, if the file name
|
|
-- corresponds to a valid unit name.
|
|
|
|
procedure Show_Source_Dirs (Project : Project_Id);
|
|
-- List all the source directories of a project.
|
|
|
|
function Locate_Directory
|
|
(Name : Name_Id;
|
|
Parent : Name_Id)
|
|
return Name_Id;
|
|
-- Locate a directory.
|
|
-- Returns No_Name if directory does not exist.
|
|
|
|
function Path_Name_Of
|
|
(File_Name : String_Id;
|
|
Directory : Name_Id)
|
|
return String;
|
|
-- Returns the path name of a (non project) file.
|
|
-- Returns an empty string if file cannot be found.
|
|
|
|
function Path_Name_Of
|
|
(File_Name : String_Id;
|
|
Directory : String_Id)
|
|
return String;
|
|
-- Same as above except that Directory is a String_Id instead
|
|
-- of a Name_Id.
|
|
|
|
---------------
|
|
-- Ada_Check --
|
|
---------------
|
|
|
|
procedure Ada_Check
|
|
(Project : Project_Id;
|
|
Report_Error : Put_Line_Access)
|
|
is
|
|
Data : Project_Data;
|
|
Languages : Variable_Value := Nil_Variable_Value;
|
|
|
|
procedure Check_Unit_Names (List : Array_Element_Id);
|
|
-- Check that a list of unit names contains only valid names.
|
|
|
|
procedure Find_Sources;
|
|
-- Find all the sources in all of the source directories
|
|
-- of a project.
|
|
|
|
procedure Get_Path_Name_And_Record_Source
|
|
(File_Name : String;
|
|
Location : Source_Ptr;
|
|
Current_Source : in out String_List_Id);
|
|
-- Find the path name of a source in the source directories and
|
|
-- record the source, if found.
|
|
|
|
procedure Get_Sources_From_File
|
|
(Path : String;
|
|
Location : Source_Ptr);
|
|
-- Get the sources of a project from a text file
|
|
|
|
----------------------
|
|
-- 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 := Array_Elements.Table (Current);
|
|
|
|
-- Check that it contains a valid unit name
|
|
|
|
Check_Ada_Name (Element.Index, Unit_Name);
|
|
|
|
if Unit_Name = No_Name then
|
|
Error_Msg_Name_1 := Element.Index;
|
|
Error_Msg
|
|
("{ is not a valid unit name.",
|
|
Element.Value.Location);
|
|
|
|
else
|
|
if Current_Verbosity = High then
|
|
Write_Str (" Body_Part (""");
|
|
Write_Str (Get_Name_String (Unit_Name));
|
|
Write_Line (""")");
|
|
end if;
|
|
|
|
Element.Index := Unit_Name;
|
|
Array_Elements.Table (Current) := Element;
|
|
end if;
|
|
|
|
Current := Element.Next;
|
|
end loop;
|
|
end Check_Unit_Names;
|
|
|
|
------------------
|
|
-- Find_Sources --
|
|
------------------
|
|
|
|
procedure Find_Sources is
|
|
Source_Dir : String_List_Id := Data.Source_Dirs;
|
|
Element : String_Element;
|
|
Dir : Dir_Type;
|
|
Current_Source : String_List_Id := Nil_String;
|
|
|
|
begin
|
|
if Current_Verbosity = High then
|
|
Write_Line ("Looking for sources:");
|
|
end if;
|
|
|
|
-- For each subdirectory
|
|
|
|
while Source_Dir /= Nil_String loop
|
|
begin
|
|
Element := String_Elements.Table (Source_Dir);
|
|
if Element.Value /= No_String then
|
|
declare
|
|
Source_Directory : String
|
|
(1 .. Integer (String_Length (Element.Value)));
|
|
begin
|
|
String_To_Name_Buffer (Element.Value);
|
|
Source_Directory := Name_Buffer (1 .. Name_Len);
|
|
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);
|
|
|
|
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
|
|
Path_Access : constant GNAT.OS_Lib.String_Access :=
|
|
Locate_Regular_File
|
|
(Name_Buffer (1 .. Name_Len),
|
|
Source_Directory);
|
|
|
|
File_Name : Name_Id;
|
|
Path_Name : Name_Id;
|
|
|
|
begin
|
|
-- If it is a regular file
|
|
|
|
if Path_Access /= null then
|
|
File_Name := Name_Find;
|
|
Name_Len := Path_Access'Length;
|
|
Name_Buffer (1 .. Name_Len) := Path_Access.all;
|
|
Path_Name := Name_Find;
|
|
|
|
-- 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_Source
|
|
(File_Name => File_Name,
|
|
Path_Name => Path_Name,
|
|
Project => Project,
|
|
Data => Data,
|
|
Location => No_Location,
|
|
Current_Source => Current_Source);
|
|
|
|
else
|
|
if Current_Verbosity = High then
|
|
Write_Line
|
|
(" Not a regular file.");
|
|
end if;
|
|
end if;
|
|
end;
|
|
end loop;
|
|
|
|
Close (Dir);
|
|
end;
|
|
end if;
|
|
|
|
exception
|
|
when Directory_Error =>
|
|
null;
|
|
end;
|
|
|
|
Source_Dir := Element.Next;
|
|
end loop;
|
|
|
|
if Current_Verbosity = High then
|
|
Write_Line ("end Looking for sources.");
|
|
end if;
|
|
|
|
-- If we have looked for sources and found none, then
|
|
-- it is an error. If a project is not supposed to contain
|
|
-- any source, then we never call Find_Sources.
|
|
|
|
if Current_Source = Nil_String then
|
|
Error_Msg ("there are no sources in this project",
|
|
Data.Location);
|
|
end if;
|
|
end Find_Sources;
|
|
|
|
-------------------------------------
|
|
-- Get_Path_Name_And_Record_Source --
|
|
-------------------------------------
|
|
|
|
procedure Get_Path_Name_And_Record_Source
|
|
(File_Name : String;
|
|
Location : Source_Ptr;
|
|
Current_Source : in out String_List_Id)
|
|
is
|
|
Source_Dir : String_List_Id := Data.Source_Dirs;
|
|
Element : String_Element;
|
|
Path_Name : GNAT.OS_Lib.String_Access;
|
|
Found : Boolean := False;
|
|
File : Name_Id;
|
|
|
|
begin
|
|
if Current_Verbosity = High then
|
|
Write_Str (" Checking """);
|
|
Write_Str (File_Name);
|
|
Write_Line (""".");
|
|
end if;
|
|
|
|
-- We look in all source directories for this file name
|
|
|
|
while Source_Dir /= Nil_String loop
|
|
Element := String_Elements.Table (Source_Dir);
|
|
|
|
if Current_Verbosity = High then
|
|
Write_Str (" """);
|
|
Write_Str (Get_Name_String (Element.Value));
|
|
Write_Str (""": ");
|
|
end if;
|
|
|
|
Path_Name :=
|
|
Locate_Regular_File
|
|
(File_Name,
|
|
Get_Name_String (Element.Value));
|
|
|
|
if Path_Name /= null then
|
|
if Current_Verbosity = High then
|
|
Write_Line ("OK");
|
|
end if;
|
|
|
|
Name_Len := File_Name'Length;
|
|
Name_Buffer (1 .. Name_Len) := File_Name;
|
|
File := Name_Find;
|
|
Name_Len := Path_Name'Length;
|
|
Name_Buffer (1 .. Name_Len) := Path_Name.all;
|
|
|
|
-- Register the source. Report an error if the file does not
|
|
-- correspond to a source.
|
|
|
|
Record_Source
|
|
(File_Name => File,
|
|
Path_Name => Name_Find,
|
|
Project => Project,
|
|
Data => Data,
|
|
Location => Location,
|
|
Current_Source => Current_Source);
|
|
Found := True;
|
|
exit;
|
|
|
|
else
|
|
if Current_Verbosity = High then
|
|
Write_Line ("No");
|
|
end if;
|
|
|
|
Source_Dir := Element.Next;
|
|
end if;
|
|
end loop;
|
|
|
|
end Get_Path_Name_And_Record_Source;
|
|
|
|
---------------------------
|
|
-- Get_Sources_From_File --
|
|
---------------------------
|
|
|
|
procedure Get_Sources_From_File
|
|
(Path : String;
|
|
Location : Source_Ptr)
|
|
is
|
|
File : Prj.Util.Text_File;
|
|
Line : String (1 .. 250);
|
|
Last : Natural;
|
|
Current_Source : String_List_Id := Nil_String;
|
|
|
|
Nmb_Errors : constant Nat := Errors_Detected;
|
|
|
|
begin
|
|
if Current_Verbosity = High then
|
|
Write_Str ("Opening """);
|
|
Write_Str (Path);
|
|
Write_Line (""".");
|
|
end if;
|
|
|
|
-- We open the file
|
|
|
|
Prj.Util.Open (File, Path);
|
|
|
|
if not Prj.Util.Is_Valid (File) then
|
|
Error_Msg ("file does not exist", Location);
|
|
else
|
|
while not Prj.Util.End_Of_File (File) loop
|
|
Prj.Util.Get_Line (File, Line, Last);
|
|
|
|
-- If the line is not empty and does not start with "--",
|
|
-- then it must contains a file name.
|
|
|
|
if Last /= 0
|
|
and then (Last = 1 or else Line (1 .. 2) /= "--")
|
|
then
|
|
Get_Path_Name_And_Record_Source
|
|
(File_Name => Line (1 .. Last),
|
|
Location => Location,
|
|
Current_Source => Current_Source);
|
|
exit when Nmb_Errors /= Errors_Detected;
|
|
end if;
|
|
end loop;
|
|
|
|
Prj.Util.Close (File);
|
|
|
|
end if;
|
|
|
|
-- We should have found at least one source.
|
|
-- If not, report an error.
|
|
|
|
if Current_Source = Nil_String then
|
|
Error_Msg ("this project has no source", Location);
|
|
end if;
|
|
end Get_Sources_From_File;
|
|
|
|
-- Start of processing for Ada_Check
|
|
|
|
begin
|
|
Language_Independent_Check (Project, Report_Error);
|
|
|
|
Error_Report := Report_Error;
|
|
|
|
Data := Projects.Table (Project);
|
|
Languages := Prj.Util.Value_Of (Name_Languages, Data.Decl.Attributes);
|
|
|
|
Data.Naming.Current_Language := Name_Ada;
|
|
Data.Sources_Present := Data.Source_Dirs /= Nil_String;
|
|
|
|
if not Languages.Default then
|
|
declare
|
|
Current : String_List_Id := Languages.Values;
|
|
Element : String_Element;
|
|
Ada_Found : Boolean := False;
|
|
|
|
begin
|
|
Look_For_Ada : while Current /= Nil_String loop
|
|
Element := String_Elements.Table (Current);
|
|
String_To_Name_Buffer (Element.Value);
|
|
To_Lower (Name_Buffer (1 .. Name_Len));
|
|
|
|
if Name_Buffer (1 .. Name_Len) = "ada" then
|
|
Ada_Found := True;
|
|
exit Look_For_Ada;
|
|
end if;
|
|
|
|
Current := Element.Next;
|
|
end loop Look_For_Ada;
|
|
|
|
if not Ada_Found then
|
|
|
|
-- Mark the project file as having no sources for Ada
|
|
|
|
Data.Sources_Present := False;
|
|
end if;
|
|
end;
|
|
end if;
|
|
|
|
declare
|
|
Naming_Id : constant Package_Id :=
|
|
Util.Value_Of (Name_Naming, Data.Decl.Packages);
|
|
|
|
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 := 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_Implementation, Naming.Decl.Arrays);
|
|
|
|
Specifications : constant Array_Element_Id :=
|
|
Util.Value_Of
|
|
(Name_Specification, Naming.Decl.Arrays);
|
|
|
|
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 Specifications /= No_Array_Element then
|
|
|
|
-- We have elements in the array Specification
|
|
|
|
if Current_Verbosity = High then
|
|
Write_Line ("Found Specifications.");
|
|
end if;
|
|
|
|
Data.Naming.Specifications := Specifications;
|
|
Check_Unit_Names (Specifications);
|
|
|
|
else
|
|
if Current_Verbosity = High then
|
|
Write_Line ("No Specifications.");
|
|
end if;
|
|
end if;
|
|
end;
|
|
|
|
-- We are now checking if variables Dot_Replacement, Casing,
|
|
-- Specification_Append, Body_Append and/or Separate_Append
|
|
-- 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);
|
|
|
|
begin
|
|
pragma Assert (Dot_Replacement.Kind = Single,
|
|
"Dot_Replacement is not a single string");
|
|
|
|
if not Dot_Replacement.Default then
|
|
|
|
String_To_Name_Buffer (Dot_Replacement.Value);
|
|
|
|
if Name_Len = 0 then
|
|
Error_Msg ("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);
|
|
|
|
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 : constant Casing_Type :=
|
|
Value (Casing_Image);
|
|
|
|
begin
|
|
Data.Naming.Casing := Casing;
|
|
end;
|
|
|
|
exception
|
|
when Constraint_Error =>
|
|
if Casing_Image'Length = 0 then
|
|
Error_Msg ("Casing cannot be an empty string",
|
|
Casing_String.Location);
|
|
|
|
else
|
|
Name_Len := Casing_Image'Length;
|
|
Name_Buffer (1 .. Name_Len) := Casing_Image;
|
|
Error_Msg_Name_1 := Name_Find;
|
|
Error_Msg
|
|
("{ 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 Specification_Suffix
|
|
|
|
declare
|
|
Ada_Spec_Suffix : constant Variable_Value :=
|
|
Prj.Util.Value_Of
|
|
(Index => Name_Ada,
|
|
In_Array => Data.Naming.Specification_Suffix);
|
|
|
|
begin
|
|
if Ada_Spec_Suffix.Kind = Single
|
|
and then String_Length (Ada_Spec_Suffix.Value) /= 0
|
|
then
|
|
String_To_Name_Buffer (Ada_Spec_Suffix.Value);
|
|
Data.Naming.Current_Spec_Suffix := Name_Find;
|
|
Data.Naming.Spec_Suffix_Loc := Ada_Spec_Suffix.Location;
|
|
|
|
else
|
|
Data.Naming.Current_Spec_Suffix := Default_Ada_Spec_Suffix;
|
|
end if;
|
|
end;
|
|
|
|
if Current_Verbosity = High then
|
|
Write_Str (" Specification_Suffix = """);
|
|
Write_Str (Get_Name_String (Data.Naming.Current_Spec_Suffix));
|
|
Write_Char ('"');
|
|
Write_Eol;
|
|
end if;
|
|
|
|
-- Check Implementation_Suffix
|
|
|
|
declare
|
|
Ada_Impl_Suffix : constant Variable_Value :=
|
|
Prj.Util.Value_Of
|
|
(Index => Name_Ada,
|
|
In_Array => Data.Naming.Implementation_Suffix);
|
|
|
|
begin
|
|
if Ada_Impl_Suffix.Kind = Single
|
|
and then String_Length (Ada_Impl_Suffix.Value) /= 0
|
|
then
|
|
String_To_Name_Buffer (Ada_Impl_Suffix.Value);
|
|
Data.Naming.Current_Impl_Suffix := Name_Find;
|
|
Data.Naming.Impl_Suffix_Loc := Ada_Impl_Suffix.Location;
|
|
|
|
else
|
|
Data.Naming.Current_Impl_Suffix := Default_Ada_Impl_Suffix;
|
|
end if;
|
|
end;
|
|
|
|
if Current_Verbosity = High then
|
|
Write_Str (" Implementation_Suffix = """);
|
|
Write_Str (Get_Name_String (Data.Naming.Current_Impl_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);
|
|
begin
|
|
if Ada_Sep_Suffix.Default then
|
|
Data.Naming.Separate_Suffix :=
|
|
Data.Naming.Current_Impl_Suffix;
|
|
|
|
else
|
|
String_To_Name_Buffer (Ada_Sep_Suffix.Value);
|
|
|
|
if Name_Len = 0 then
|
|
Error_Msg ("Separate_Suffix cannot be empty",
|
|
Ada_Sep_Suffix.Location);
|
|
|
|
else
|
|
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 (Data.Naming);
|
|
|
|
else
|
|
Data.Naming.Current_Spec_Suffix := Default_Ada_Spec_Suffix;
|
|
Data.Naming.Current_Impl_Suffix := Default_Ada_Impl_Suffix;
|
|
Data.Naming.Separate_Suffix := Default_Ada_Impl_Suffix;
|
|
end if;
|
|
end;
|
|
|
|
-- If we have source directories, then find the sources
|
|
|
|
if Data.Sources_Present then
|
|
if Data.Source_Dirs = Nil_String then
|
|
Data.Sources_Present := False;
|
|
|
|
else
|
|
declare
|
|
Sources : constant Variable_Value :=
|
|
Util.Value_Of
|
|
(Name_Source_Files,
|
|
Data.Decl.Attributes);
|
|
|
|
Source_List_File : constant Variable_Value :=
|
|
Util.Value_Of
|
|
(Name_Source_List_File,
|
|
Data.Decl.Attributes);
|
|
|
|
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
|
|
("?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_Source : String_List_Id := Nil_String;
|
|
Current : String_List_Id := Sources.Values;
|
|
Element : String_Element;
|
|
|
|
begin
|
|
Data.Sources_Present := Current /= Nil_String;
|
|
|
|
while Current /= Nil_String loop
|
|
Element := String_Elements.Table (Current);
|
|
String_To_Name_Buffer (Element.Value);
|
|
|
|
declare
|
|
File_Name : constant String :=
|
|
Name_Buffer (1 .. Name_Len);
|
|
|
|
begin
|
|
Get_Path_Name_And_Record_Source
|
|
(File_Name => File_Name,
|
|
Location => Element.Location,
|
|
Current_Source => Current_Source);
|
|
Current := Element.Next;
|
|
end;
|
|
end loop;
|
|
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
|
|
String_To_Name_Buffer (Source_List_File.Value);
|
|
Error_Msg_Name_1 := Name_Find;
|
|
Error_Msg
|
|
("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;
|
|
end if;
|
|
end;
|
|
end if;
|
|
end if;
|
|
|
|
Projects.Table (Project) := Data;
|
|
end Ada_Check;
|
|
|
|
--------------------
|
|
-- Check_Ada_Name --
|
|
--------------------
|
|
|
|
procedure Check_Ada_Name
|
|
(Name : Name_Id;
|
|
Unit : out Name_Id)
|
|
is
|
|
The_Name : String := Get_Name_String (Name);
|
|
Need_Letter : Boolean := True;
|
|
Last_Underscore : Boolean := False;
|
|
OK : Boolean := The_Name'Length > 0;
|
|
|
|
begin
|
|
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 := Name;
|
|
else
|
|
-- Signal a problem with No_Name
|
|
|
|
Unit := No_Name;
|
|
end if;
|
|
end Check_Ada_Name;
|
|
|
|
-----------------------------
|
|
-- Check_Ada_Naming_Scheme --
|
|
-----------------------------
|
|
|
|
procedure Check_Ada_Naming_Scheme (Naming : Naming_Data) is
|
|
begin
|
|
-- Only check if we are not using the standard naming scheme
|
|
|
|
if Naming /= Standard_Naming_Data then
|
|
declare
|
|
Dot_Replacement : constant String :=
|
|
Get_Name_String
|
|
(Naming.Dot_Replacement);
|
|
|
|
Specification_Suffix : constant String :=
|
|
Get_Name_String
|
|
(Naming.Current_Spec_Suffix);
|
|
|
|
Implementation_Suffix : constant String :=
|
|
Get_Name_String
|
|
(Naming.Current_Impl_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
|
|
('"' & Dot_Replacement &
|
|
""" is illegal for Dot_Replacement.",
|
|
Naming.Dot_Repl_Loc);
|
|
end if;
|
|
|
|
-- Suffixes cannot
|
|
-- - be empty
|
|
-- - start with an alphanumeric
|
|
-- - start with an '_' followed by an alphanumeric
|
|
|
|
if Is_Illegal_Append (Specification_Suffix) then
|
|
Error_Msg_Name_1 := Naming.Current_Spec_Suffix;
|
|
Error_Msg
|
|
("{ is illegal for Specification_Suffix",
|
|
Naming.Spec_Suffix_Loc);
|
|
end if;
|
|
|
|
if Is_Illegal_Append (Implementation_Suffix) then
|
|
Error_Msg_Name_1 := Naming.Current_Impl_Suffix;
|
|
Error_Msg
|
|
("% is illegal for Implementation_Suffix",
|
|
Naming.Impl_Suffix_Loc);
|
|
end if;
|
|
|
|
if Implementation_Suffix /= Separate_Suffix then
|
|
if Is_Illegal_Append (Separate_Suffix) then
|
|
Error_Msg_Name_1 := Naming.Separate_Suffix;
|
|
Error_Msg
|
|
("{ is illegal for Separate_Append",
|
|
Naming.Sep_Suffix_Loc);
|
|
end if;
|
|
end if;
|
|
|
|
-- Specification_Suffix cannot have the same termination as
|
|
-- Implementation_Suffix or Separate_Suffix
|
|
|
|
if Specification_Suffix'Length <= Implementation_Suffix'Length
|
|
and then
|
|
Implementation_Suffix (Implementation_Suffix'Last -
|
|
Specification_Suffix'Length + 1 ..
|
|
Implementation_Suffix'Last) = Specification_Suffix
|
|
then
|
|
Error_Msg
|
|
("Implementation_Suffix (""" &
|
|
Implementation_Suffix &
|
|
""") cannot end with" &
|
|
"Specification_Suffix (""" &
|
|
Specification_Suffix & """).",
|
|
Naming.Impl_Suffix_Loc);
|
|
end if;
|
|
|
|
if Specification_Suffix'Length <= Separate_Suffix'Length
|
|
and then
|
|
Separate_Suffix
|
|
(Separate_Suffix'Last - Specification_Suffix'Length + 1
|
|
..
|
|
Separate_Suffix'Last) = Specification_Suffix
|
|
then
|
|
Error_Msg
|
|
("Separate_Suffix (""" &
|
|
Separate_Suffix &
|
|
""") cannot end with" &
|
|
" Specification_Suffix (""" &
|
|
Specification_Suffix & """).",
|
|
Naming.Sep_Suffix_Loc);
|
|
end if;
|
|
end;
|
|
end if;
|
|
|
|
end Check_Ada_Naming_Scheme;
|
|
|
|
---------------
|
|
-- Error_Msg --
|
|
---------------
|
|
|
|
procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) is
|
|
|
|
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 Error_Report = null then
|
|
Errout.Error_Msg (Msg, Flag_Location);
|
|
return;
|
|
end if;
|
|
|
|
if Msg (First) = '\' then
|
|
|
|
-- Continuation character, ignore.
|
|
|
|
First := First + 1;
|
|
|
|
elsif Msg (First) = '?' then
|
|
|
|
-- Warning character. It is always the first one,
|
|
-- in this package.
|
|
|
|
First := First + 1;
|
|
Add ("Warning: ");
|
|
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 (Error_Msg_Name_1);
|
|
|
|
when 2 => Add (Error_Msg_Name_2);
|
|
|
|
when 3 => Add (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));
|
|
end Error_Msg;
|
|
|
|
---------------------
|
|
-- Get_Name_String --
|
|
---------------------
|
|
|
|
function Get_Name_String (S : String_Id) return String is
|
|
begin
|
|
if S = No_String then
|
|
return "";
|
|
else
|
|
String_To_Name_Buffer (S);
|
|
return Name_Buffer (1 .. Name_Len);
|
|
end if;
|
|
end Get_Name_String;
|
|
|
|
--------------
|
|
-- Get_Unit --
|
|
--------------
|
|
|
|
procedure Get_Unit
|
|
(File_Name : Name_Id;
|
|
Naming : Naming_Data;
|
|
Unit_Name : out Name_Id;
|
|
Unit_Kind : out Spec_Or_Body;
|
|
Needs_Pragma : out Boolean)
|
|
is
|
|
Canonical_Case_Name : Name_Id;
|
|
|
|
begin
|
|
Needs_Pragma := False;
|
|
Get_Name_String (File_Name);
|
|
Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
|
|
Canonical_Case_Name := Name_Find;
|
|
|
|
if Naming.Bodies /= No_Array_Element then
|
|
|
|
-- There are some specified file names for some bodies
|
|
-- of this project. Find out if File_Name is one of these bodies.
|
|
|
|
declare
|
|
Current : Array_Element_Id := Naming.Bodies;
|
|
Element : Array_Element;
|
|
|
|
begin
|
|
while Current /= No_Array_Element loop
|
|
Element := Array_Elements.Table (Current);
|
|
|
|
if Element.Index /= No_Name then
|
|
String_To_Name_Buffer (Element.Value.Value);
|
|
Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
|
|
|
|
if Canonical_Case_Name = Name_Find then
|
|
|
|
-- File_Name corresponds to one body.
|
|
-- So, we know it is a body, and we know the unit name.
|
|
|
|
Unit_Kind := Body_Part;
|
|
Unit_Name := Element.Index;
|
|
Needs_Pragma := True;
|
|
return;
|
|
end if;
|
|
end if;
|
|
|
|
Current := Element.Next;
|
|
end loop;
|
|
end;
|
|
end if;
|
|
|
|
if Naming.Specifications /= No_Array_Element then
|
|
|
|
-- There are some specified file names for some bodiesspecifications
|
|
-- of this project. Find out if File_Name is one of these
|
|
-- specifications.
|
|
|
|
declare
|
|
Current : Array_Element_Id := Naming.Specifications;
|
|
Element : Array_Element;
|
|
|
|
begin
|
|
while Current /= No_Array_Element loop
|
|
Element := Array_Elements.Table (Current);
|
|
|
|
if Element.Index /= No_Name then
|
|
String_To_Name_Buffer (Element.Value.Value);
|
|
Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
|
|
|
|
if Canonical_Case_Name = Name_Find then
|
|
|
|
-- File_Name corresponds to one specification.
|
|
-- So, we know it is a spec, and we know the unit name.
|
|
|
|
Unit_Kind := Specification;
|
|
Unit_Name := Element.Index;
|
|
Needs_Pragma := True;
|
|
return;
|
|
end if;
|
|
|
|
end if;
|
|
|
|
Current := Element.Next;
|
|
end loop;
|
|
end;
|
|
end if;
|
|
|
|
declare
|
|
File : String := Get_Name_String (Canonical_Case_Name);
|
|
First : Positive := File'First;
|
|
Last : Natural := File'Last;
|
|
|
|
begin
|
|
-- Check if the end of the file name is Specification_Append
|
|
|
|
Get_Name_String (Naming.Current_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.Current_Impl_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.Current_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);
|
|
|
|
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);
|
|
|
|
if Current_Verbosity = High then
|
|
Write_Str (" ");
|
|
Write_Line (Src);
|
|
end if;
|
|
|
|
Name_Len := Src'Length;
|
|
Name_Buffer (1 .. Name_Len) := Src;
|
|
|
|
-- Now, we check if this name is a valid unit name
|
|
|
|
Check_Ada_Name (Name => Name_Find, Unit => Unit_Name);
|
|
end;
|
|
|
|
end;
|
|
|
|
end Get_Unit;
|
|
|
|
-----------------------
|
|
-- Is_Illegal_Append --
|
|
-----------------------
|
|
|
|
function Is_Illegal_Append (This : String) return Boolean is
|
|
begin
|
|
return This'Length = 0
|
|
or else Is_Alphanumeric (This (This'First))
|
|
or else Index (This, ".") = 0
|
|
or else (This'Length >= 2
|
|
and then This (This'First) = '_'
|
|
and then Is_Alphanumeric (This (This'First + 1)));
|
|
end Is_Illegal_Append;
|
|
|
|
--------------------------------
|
|
-- Language_Independent_Check --
|
|
--------------------------------
|
|
|
|
procedure Language_Independent_Check
|
|
(Project : Project_Id;
|
|
Report_Error : Put_Line_Access)
|
|
is
|
|
Last_Source_Dir : String_List_Id := Nil_String;
|
|
Data : Project_Data := Projects.Table (Project);
|
|
|
|
procedure Find_Source_Dirs (From : String_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 : String_Id; Location : Source_Ptr) is
|
|
|
|
Directory : String (1 .. Integer (String_Length (From)));
|
|
Directory_Id : Name_Id;
|
|
Element : String_Element;
|
|
|
|
procedure Recursive_Find_Dirs (Path : String_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 : String_Id) is
|
|
Dir : Dir_Type;
|
|
Name : String (1 .. 250);
|
|
Last : Natural;
|
|
The_Path : String := Get_Name_String (Path) & Dir_Sep;
|
|
|
|
The_Path_Last : Positive := The_Path'Last;
|
|
|
|
begin
|
|
if The_Path'Length > 1
|
|
and then
|
|
(The_Path (The_Path_Last - 1) = Dir_Sep
|
|
or else The_Path (The_Path_Last - 1) = '/')
|
|
then
|
|
The_Path_Last := The_Path_Last - 1;
|
|
end if;
|
|
|
|
if Current_Verbosity = High then
|
|
Write_Str (" ");
|
|
Write_Line (The_Path (The_Path'First .. The_Path_Last));
|
|
end if;
|
|
|
|
String_Elements.Increment_Last;
|
|
Element :=
|
|
(Value => Path,
|
|
Location => No_Location,
|
|
Next => Nil_String);
|
|
|
|
-- Case of first source directory
|
|
|
|
if Last_Source_Dir = Nil_String then
|
|
Data.Source_Dirs := String_Elements.Last;
|
|
|
|
-- Here we already have source directories.
|
|
|
|
else
|
|
-- Link the previous last to the new one
|
|
|
|
String_Elements.Table (Last_Source_Dir).Next :=
|
|
String_Elements.Last;
|
|
end if;
|
|
|
|
-- And register this source directory as the new last
|
|
|
|
Last_Source_Dir := String_Elements.Last;
|
|
String_Elements.Table (Last_Source_Dir) := Element;
|
|
|
|
-- Now look for subdirectories
|
|
|
|
Open (Dir, The_Path (The_Path'First .. The_Path_Last));
|
|
|
|
loop
|
|
Read (Dir, Name, Last);
|
|
exit when Last = 0;
|
|
|
|
if Current_Verbosity = High then
|
|
Write_Str (" Checking ");
|
|
Write_Line (Name (1 .. Last));
|
|
end if;
|
|
|
|
if Name (1 .. Last) /= "."
|
|
and then Name (1 .. Last) /= ".."
|
|
then
|
|
-- Avoid . and ..
|
|
|
|
declare
|
|
Path_Name : constant String :=
|
|
The_Path (The_Path'First .. The_Path_Last) &
|
|
Name (1 .. Last);
|
|
|
|
begin
|
|
if Is_Directory (Path_Name) then
|
|
|
|
-- We have found a new subdirectory,
|
|
-- register it and find its own subdirectories.
|
|
|
|
Start_String;
|
|
Store_String_Chars (Path_Name);
|
|
Recursive_Find_Dirs (End_String);
|
|
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 (""");
|
|
end if;
|
|
|
|
String_To_Name_Buffer (From);
|
|
Directory := Name_Buffer (1 .. Name_Len);
|
|
Directory_Id := Name_Find;
|
|
|
|
if Current_Verbosity = High then
|
|
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) = Dir_Sep)
|
|
then
|
|
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 : constant Name_Id :=
|
|
Locate_Directory (Base_Dir, Data.Directory);
|
|
|
|
begin
|
|
if Root = No_Name then
|
|
Error_Msg_Name_1 := Base_Dir;
|
|
if Location = No_Location then
|
|
Error_Msg ("{ is not a valid directory.", Data.Location);
|
|
else
|
|
Error_Msg ("{ 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;
|
|
|
|
Start_String;
|
|
Store_String_Chars (Get_Name_String (Root));
|
|
Recursive_Find_Dirs (End_String);
|
|
|
|
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 : constant Name_Id :=
|
|
Locate_Directory (Directory_Id, Data.Directory);
|
|
|
|
begin
|
|
if Path_Name = No_Name then
|
|
Error_Msg_Name_1 := Directory_Id;
|
|
if Location = No_Location then
|
|
Error_Msg ("{ is not a valid directory", Data.Location);
|
|
else
|
|
Error_Msg ("{ is not a valid directory", Location);
|
|
end if;
|
|
else
|
|
|
|
-- As it is an existing directory, we add it to
|
|
-- the list of directories.
|
|
|
|
String_Elements.Increment_Last;
|
|
Start_String;
|
|
Store_String_Chars (Get_Name_String (Path_Name));
|
|
Element.Value := End_String;
|
|
|
|
if Last_Source_Dir = Nil_String then
|
|
|
|
-- This is the first source directory
|
|
|
|
Data.Source_Dirs := String_Elements.Last;
|
|
|
|
else
|
|
-- We already have source directories,
|
|
-- link the previous last to the new one.
|
|
|
|
String_Elements.Table (Last_Source_Dir).Next :=
|
|
String_Elements.Last;
|
|
end if;
|
|
|
|
-- And register this source directory as the new last
|
|
|
|
Last_Source_Dir := String_Elements.Last;
|
|
String_Elements.Table (Last_Source_Dir) := Element;
|
|
end if;
|
|
end;
|
|
end if;
|
|
end Find_Source_Dirs;
|
|
|
|
-- Start of processing for Language_Independent_Check
|
|
|
|
begin
|
|
|
|
if Data.Language_Independent_Checked then
|
|
return;
|
|
end if;
|
|
|
|
Data.Language_Independent_Checked := True;
|
|
|
|
Error_Report := Report_Error;
|
|
|
|
if Current_Verbosity = High then
|
|
Write_Line ("Starting to look for directories");
|
|
end if;
|
|
|
|
-- Check the object directory
|
|
|
|
declare
|
|
Object_Dir : Variable_Value :=
|
|
Util.Value_Of (Name_Object_Dir, Data.Decl.Attributes);
|
|
|
|
begin
|
|
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;
|
|
|
|
if not String_Equal (Object_Dir.Value, Empty_String) then
|
|
|
|
String_To_Name_Buffer (Object_Dir.Value);
|
|
|
|
if Name_Len = 0 then
|
|
Error_Msg ("Object_Dir cannot be empty",
|
|
Object_Dir.Location);
|
|
|
|
else
|
|
-- We check that the specified object directory
|
|
-- does exist.
|
|
|
|
Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
|
|
|
|
declare
|
|
Dir_Id : constant Name_Id := Name_Find;
|
|
|
|
begin
|
|
Data.Object_Directory :=
|
|
Locate_Directory (Dir_Id, Data.Directory);
|
|
|
|
if Data.Object_Directory = No_Name then
|
|
Error_Msg_Name_1 := Dir_Id;
|
|
Error_Msg
|
|
("the object directory { cannot be found",
|
|
Data.Location);
|
|
end if;
|
|
end;
|
|
end if;
|
|
end if;
|
|
end;
|
|
|
|
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.Object_Directory));
|
|
Write_Line ("""");
|
|
end if;
|
|
end if;
|
|
|
|
-- Check the exec directory
|
|
|
|
declare
|
|
Exec_Dir : Variable_Value :=
|
|
Util.Value_Of (Name_Exec_Dir, Data.Decl.Attributes);
|
|
|
|
begin
|
|
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;
|
|
|
|
if not String_Equal (Exec_Dir.Value, Empty_String) then
|
|
|
|
String_To_Name_Buffer (Exec_Dir.Value);
|
|
|
|
if Name_Len = 0 then
|
|
Error_Msg ("Exec_Dir cannot be empty",
|
|
Exec_Dir.Location);
|
|
|
|
else
|
|
-- We check that the specified object directory
|
|
-- does exist.
|
|
|
|
Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
|
|
|
|
declare
|
|
Dir_Id : constant Name_Id := Name_Find;
|
|
|
|
begin
|
|
Data.Exec_Directory :=
|
|
Locate_Directory (Dir_Id, Data.Directory);
|
|
|
|
if Data.Exec_Directory = No_Name then
|
|
Error_Msg_Name_1 := Dir_Id;
|
|
Error_Msg
|
|
("the exec directory { cannot be found",
|
|
Data.Location);
|
|
end if;
|
|
end;
|
|
end if;
|
|
end if;
|
|
end;
|
|
|
|
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.Exec_Directory));
|
|
Write_Line ("""");
|
|
end if;
|
|
end if;
|
|
|
|
-- Look for the source directories
|
|
|
|
declare
|
|
Source_Dirs : Variable_Value :=
|
|
Util.Value_Of (Name_Source_Dirs, Data.Decl.Attributes);
|
|
|
|
begin
|
|
|
|
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_Elements.Increment_Last;
|
|
Data.Source_Dirs := String_Elements.Last;
|
|
Start_String;
|
|
Store_String_Chars (Get_Name_String (Data.Directory));
|
|
String_Elements.Table (Data.Source_Dirs) :=
|
|
(Value => End_String,
|
|
Location => No_Location,
|
|
Next => Nil_String);
|
|
|
|
if Current_Verbosity = High then
|
|
Write_Line ("(Undefined) Single object directory:");
|
|
Write_Str (" """);
|
|
Write_Str (Get_Name_String (Data.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.
|
|
|
|
if Data.Object_Directory = Data.Directory then
|
|
Data.Object_Directory := No_Name;
|
|
end if;
|
|
|
|
Data.Source_Dirs := Nil_String;
|
|
Data.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 := 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 ("Puting 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 := String_Elements.Table (Current);
|
|
if Element.Value /= No_String then
|
|
String_To_Name_Buffer (Element.Value);
|
|
Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
|
|
Start_String;
|
|
Store_String_Chars (Name_Buffer (1 .. Name_Len));
|
|
Element.Value := End_String;
|
|
String_Elements.Table (Current) := Element;
|
|
end if;
|
|
|
|
Current := Element.Next;
|
|
end loop;
|
|
end;
|
|
end;
|
|
|
|
-- Library Dir, Name, Version and Kind
|
|
|
|
declare
|
|
Attributes : constant Prj.Variable_Id := Data.Decl.Attributes;
|
|
|
|
Lib_Dir : Prj.Variable_Value :=
|
|
Prj.Util.Value_Of (Snames.Name_Library_Dir, Attributes);
|
|
|
|
Lib_Name : Prj.Variable_Value :=
|
|
Prj.Util.Value_Of (Snames.Name_Library_Name, Attributes);
|
|
|
|
Lib_Version : Prj.Variable_Value :=
|
|
Prj.Util.Value_Of
|
|
(Snames.Name_Library_Version, Attributes);
|
|
|
|
The_Lib_Kind : Prj.Variable_Value :=
|
|
Prj.Util.Value_Of
|
|
(Snames.Name_Library_Kind, Attributes);
|
|
|
|
begin
|
|
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
|
|
|
|
Stringt.String_To_Name_Buffer (Lib_Dir.Value);
|
|
|
|
declare
|
|
Dir_Id : constant Name_Id := Name_Find;
|
|
|
|
begin
|
|
Data.Library_Dir :=
|
|
Locate_Directory (Dir_Id, Data.Directory);
|
|
|
|
if Data.Library_Dir = No_Name then
|
|
Error_Msg ("not an existing directory",
|
|
Lib_Dir.Location);
|
|
|
|
elsif Data.Library_Dir = Data.Object_Directory then
|
|
Error_Msg
|
|
("library directory cannot be the same " &
|
|
"as object directory",
|
|
Lib_Dir.Location);
|
|
Data.Library_Dir := No_Name;
|
|
|
|
else
|
|
if Current_Verbosity = High then
|
|
Write_Str ("Library directory =""");
|
|
Write_Str (Get_Name_String (Data.Library_Dir));
|
|
Write_Line ("""");
|
|
end if;
|
|
end if;
|
|
end;
|
|
end if;
|
|
|
|
pragma Assert (Lib_Name.Kind = Single);
|
|
|
|
if Lib_Name.Value = Empty_String then
|
|
if Current_Verbosity = High then
|
|
Write_Line ("No library name");
|
|
end if;
|
|
|
|
else
|
|
Stringt.String_To_Name_Buffer (Lib_Name.Value);
|
|
|
|
if not Is_Letter (Name_Buffer (1)) then
|
|
Error_Msg ("must start with a letter",
|
|
Lib_Name.Location);
|
|
|
|
else
|
|
Data.Library_Name := Name_Find;
|
|
|
|
for Index in 2 .. Name_Len loop
|
|
if not Is_Alphanumeric (Name_Buffer (Index)) then
|
|
Data.Library_Name := No_Name;
|
|
Error_Msg ("only letters and digits are allowed",
|
|
Lib_Name.Location);
|
|
exit;
|
|
end if;
|
|
end loop;
|
|
|
|
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;
|
|
end if;
|
|
end if;
|
|
|
|
Data.Library :=
|
|
Data.Library_Dir /= No_Name
|
|
and then
|
|
Data.Library_Name /= No_Name;
|
|
|
|
if Data.Library then
|
|
|
|
if not MLib.Tgt.Libraries_Are_Supported then
|
|
Error_Msg ("?libraries are not supported on this platform",
|
|
Lib_Name.Location);
|
|
Data.Library := False;
|
|
|
|
else
|
|
if Current_Verbosity = High then
|
|
Write_Line ("This is a library project file");
|
|
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
|
|
Stringt.String_To_Name_Buffer (Lib_Version.Value);
|
|
Data.Lib_Internal_Name := Name_Find;
|
|
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
|
|
Stringt.String_To_Name_Buffer (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
|
|
("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;
|
|
end;
|
|
end if;
|
|
end if;
|
|
end if;
|
|
end;
|
|
|
|
if Current_Verbosity = High then
|
|
Show_Source_Dirs (Project);
|
|
end if;
|
|
|
|
declare
|
|
Naming_Id : constant Package_Id :=
|
|
Util.Value_Of (Name_Naming, Data.Decl.Packages);
|
|
|
|
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 := Packages.Table (Naming_Id);
|
|
|
|
if Current_Verbosity = High then
|
|
Write_Line ("Checking ""Naming"".");
|
|
end if;
|
|
|
|
-- Check Specification_Suffix
|
|
|
|
Data.Naming.Specification_Suffix := Util.Value_Of
|
|
(Name_Specification_Suffix,
|
|
Naming.Decl.Arrays);
|
|
|
|
declare
|
|
Current : Array_Element_Id := Data.Naming.Specification_Suffix;
|
|
Element : Array_Element;
|
|
|
|
begin
|
|
while Current /= No_Array_Element loop
|
|
Element := Array_Elements.Table (Current);
|
|
String_To_Name_Buffer (Element.Value.Value);
|
|
|
|
if Name_Len = 0 then
|
|
Error_Msg
|
|
("Specification_Suffix cannot be empty",
|
|
Element.Value.Location);
|
|
end if;
|
|
|
|
Array_Elements.Table (Current) := Element;
|
|
Current := Element.Next;
|
|
end loop;
|
|
end;
|
|
|
|
-- Check Implementation_Suffix
|
|
|
|
Data.Naming.Implementation_Suffix := Util.Value_Of
|
|
(Name_Implementation_Suffix,
|
|
Naming.Decl.Arrays);
|
|
|
|
declare
|
|
Current : Array_Element_Id := Data.Naming.Implementation_Suffix;
|
|
Element : Array_Element;
|
|
|
|
begin
|
|
while Current /= No_Array_Element loop
|
|
Element := Array_Elements.Table (Current);
|
|
String_To_Name_Buffer (Element.Value.Value);
|
|
|
|
if Name_Len = 0 then
|
|
Error_Msg
|
|
("Implementation_Suffix cannot be empty",
|
|
Element.Value.Location);
|
|
end if;
|
|
|
|
Array_Elements.Table (Current) := Element;
|
|
Current := Element.Next;
|
|
end loop;
|
|
end;
|
|
|
|
end if;
|
|
end;
|
|
|
|
Projects.Table (Project) := Data;
|
|
end Language_Independent_Check;
|
|
|
|
----------------------
|
|
-- Locate_Directory --
|
|
----------------------
|
|
|
|
function Locate_Directory
|
|
(Name : Name_Id;
|
|
Parent : Name_Id)
|
|
return Name_Id
|
|
is
|
|
The_Name : constant String := Get_Name_String (Name);
|
|
The_Parent : constant String :=
|
|
Get_Name_String (Parent) & Dir_Sep;
|
|
|
|
The_Parent_Last : Positive := The_Parent'Last;
|
|
|
|
begin
|
|
if The_Parent'Length > 1
|
|
and then (The_Parent (The_Parent_Last - 1) = Dir_Sep
|
|
or else The_Parent (The_Parent_Last - 1) = '/')
|
|
then
|
|
The_Parent_Last := The_Parent_Last - 1;
|
|
end if;
|
|
|
|
if Current_Verbosity = High then
|
|
Write_Str ("Locate_Directory (""");
|
|
Write_Str (The_Name);
|
|
Write_Str (""", """);
|
|
Write_Str (The_Parent);
|
|
Write_Line (""")");
|
|
end if;
|
|
|
|
if Is_Absolute_Path (The_Name) then
|
|
if Is_Directory (The_Name) then
|
|
return Name;
|
|
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
|
|
Name_Len := Full_Path'Length;
|
|
Name_Buffer (1 .. Name_Len) := Full_Path;
|
|
return Name_Find;
|
|
end if;
|
|
end;
|
|
|
|
end if;
|
|
|
|
return No_Name;
|
|
end Locate_Directory;
|
|
|
|
------------------
|
|
-- Path_Name_Of --
|
|
------------------
|
|
|
|
function Path_Name_Of
|
|
(File_Name : String_Id;
|
|
Directory : String_Id)
|
|
return String
|
|
is
|
|
Result : String_Access;
|
|
|
|
begin
|
|
String_To_Name_Buffer (File_Name);
|
|
|
|
declare
|
|
The_File_Name : constant String := Name_Buffer (1 .. Name_Len);
|
|
|
|
begin
|
|
String_To_Name_Buffer (Directory);
|
|
Result := Locate_Regular_File
|
|
(File_Name => The_File_Name,
|
|
Path => Name_Buffer (1 .. Name_Len));
|
|
end;
|
|
|
|
if Result = null then
|
|
return "";
|
|
else
|
|
Canonical_Case_File_Name (Result.all);
|
|
return Result.all;
|
|
end if;
|
|
end Path_Name_Of;
|
|
|
|
function Path_Name_Of
|
|
(File_Name : String_Id;
|
|
Directory : Name_Id)
|
|
return String
|
|
is
|
|
Result : String_Access;
|
|
The_Directory : constant String := Get_Name_String (Directory);
|
|
|
|
begin
|
|
String_To_Name_Buffer (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;
|
|
|
|
-------------------
|
|
-- Record_Source --
|
|
-------------------
|
|
|
|
procedure Record_Source
|
|
(File_Name : Name_Id;
|
|
Path_Name : Name_Id;
|
|
Project : Project_Id;
|
|
Data : in out Project_Data;
|
|
Location : Source_Ptr;
|
|
Current_Source : in out String_List_Id)
|
|
is
|
|
Unit_Name : Name_Id;
|
|
Unit_Kind : Spec_Or_Body;
|
|
Needs_Pragma : Boolean;
|
|
The_Location : Source_Ptr := Location;
|
|
|
|
begin
|
|
-- Find out the unit name, the unit kind and if it needs
|
|
-- a specific SFN pragma.
|
|
|
|
Get_Unit
|
|
(File_Name => File_Name,
|
|
Naming => Data.Naming,
|
|
Unit_Name => Unit_Name,
|
|
Unit_Kind => Unit_Kind,
|
|
Needs_Pragma => Needs_Pragma);
|
|
|
|
if Unit_Name = No_Name then
|
|
if Current_Verbosity = High then
|
|
Write_Str (" """);
|
|
Write_Str (Get_Name_String (File_Name));
|
|
Write_Line (""" is not a valid source file name (ignored).");
|
|
end if;
|
|
|
|
else
|
|
-- Put the file name in the list of sources of the project
|
|
|
|
String_Elements.Increment_Last;
|
|
Get_Name_String (File_Name);
|
|
Start_String;
|
|
Store_String_Chars (Name_Buffer (1 .. Name_Len));
|
|
String_Elements.Table (String_Elements.Last) :=
|
|
(Value => End_String,
|
|
Location => No_Location,
|
|
Next => Nil_String);
|
|
|
|
if Current_Source = Nil_String then
|
|
Data.Sources := String_Elements.Last;
|
|
|
|
else
|
|
String_Elements.Table (Current_Source).Next :=
|
|
String_Elements.Last;
|
|
end if;
|
|
|
|
Current_Source := String_Elements.Last;
|
|
|
|
-- Put the unit in unit list
|
|
|
|
declare
|
|
The_Unit : Unit_Id := Units_Htable.Get (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 /= Prj.Com.No_Unit then
|
|
The_Unit_Data := Units.Table (The_Unit);
|
|
|
|
if The_Unit_Data.File_Names (Unit_Kind).Name = No_Name
|
|
or else (Data.Modifies /= No_Project
|
|
and then
|
|
The_Unit_Data.File_Names (Unit_Kind).Project =
|
|
Data.Modifies)
|
|
then
|
|
The_Unit_Data.File_Names (Unit_Kind) :=
|
|
(Name => File_Name,
|
|
Path => Path_Name,
|
|
Project => Project,
|
|
Needs_Pragma => Needs_Pragma);
|
|
Units.Table (The_Unit) := The_Unit_Data;
|
|
|
|
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 := Projects.Table (Project).Location;
|
|
end if;
|
|
|
|
Error_Msg_Name_1 := Unit_Name;
|
|
Error_Msg ("duplicate source {", The_Location);
|
|
|
|
Error_Msg_Name_1 :=
|
|
Projects.Table
|
|
(The_Unit_Data.File_Names (Unit_Kind).Project).Name;
|
|
Error_Msg_Name_2 :=
|
|
The_Unit_Data.File_Names (Unit_Kind).Path;
|
|
Error_Msg ("\ project file {, {", The_Location);
|
|
|
|
Error_Msg_Name_1 := Projects.Table (Project).Name;
|
|
Error_Msg_Name_2 := Path_Name;
|
|
Error_Msg ("\ project file {, {", The_Location);
|
|
|
|
end if;
|
|
|
|
-- It is a new unit, create a new record
|
|
|
|
else
|
|
Units.Increment_Last;
|
|
The_Unit := Units.Last;
|
|
Units_Htable.Set (Unit_Name, The_Unit);
|
|
The_Unit_Data.Name := Unit_Name;
|
|
The_Unit_Data.File_Names (Unit_Kind) :=
|
|
(Name => File_Name,
|
|
Path => Path_Name,
|
|
Project => Project,
|
|
Needs_Pragma => Needs_Pragma);
|
|
Units.Table (The_Unit) := The_Unit_Data;
|
|
end if;
|
|
end;
|
|
end if;
|
|
end Record_Source;
|
|
|
|
----------------------
|
|
-- Show_Source_Dirs --
|
|
----------------------
|
|
|
|
procedure Show_Source_Dirs (Project : Project_Id) is
|
|
Current : String_List_Id := Projects.Table (Project).Source_Dirs;
|
|
Element : String_Element;
|
|
|
|
begin
|
|
Write_Line ("Source_Dirs:");
|
|
|
|
while Current /= Nil_String loop
|
|
Element := 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;
|
|
|
|
end Prj.Nmsc;
|