+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- P R J . N M S C --
--- --
--- B o d y --
--- --
--- $Revision: 1.7.10.1 $
--- --
--- 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. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-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;
projects / msp430-gcc.git / blobdiff