X-Git-Url: https://oss.titaniummirror.com/gitweb?a=blobdiff_plain;f=gcc%2Fada%2Fprj-nmsc.adb;fp=gcc%2Fada%2Fprj-nmsc.adb;h=0000000000000000000000000000000000000000;hb=6fed43773c9b0ce596dca5686f37ac3fc0fa11c0;hp=0ad72ffff84ba56829fd9351d8b95bfce09e6d6e;hpb=27b11d56b743098deb193d510b337ba22dc52e5c;p=msp430-gcc.git diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb deleted file mode 100644 index 0ad72fff..00000000 --- a/gcc/ada/prj-nmsc.adb +++ /dev/null @@ -1,2425 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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;