| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- P R J . A T T R -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 2001-2006, Free Software Foundation, Inc. -- |
| -- -- |
| -- GNAT is free software; you can redistribute it and/or modify it under -- |
| -- terms of the GNU General Public License as published by the Free Soft- -- |
| -- ware Foundation; either version 2, or (at your option) any later ver- -- |
| -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
| -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
| -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- |
| -- for more details. You should have received a copy of the GNU General -- |
| -- Public License distributed with GNAT; see file COPYING. If not, write -- |
| -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- |
| -- Boston, MA 02110-1301, USA. -- |
| -- -- |
| -- GNAT was originally developed by the GNAT team at New York University. -- |
| -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| with Namet; use Namet; |
| with Osint; |
| with Prj.Com; use Prj.Com; |
| with System.Case_Util; use System.Case_Util; |
| |
| package body Prj.Attr is |
| |
| -- Data for predefined attributes and packages |
| |
| -- Names end with '#' |
| |
| -- Package names are preceded by 'P' |
| |
| -- Attribute names are preceded by two letters: |
| |
| -- The first letter is one of |
| -- 'S' for Single |
| -- 's' for Single with optional index |
| -- 'L' for List |
| -- 'l' for List of strings with optional indexes |
| |
| -- The second letter is one of |
| -- 'V' for single variable |
| -- 'A' for associative array |
| -- 'a' for case insensitive associative array |
| -- 'b' for associative array, case insensitive if file names are case |
| -- insensitive |
| -- 'c' same as 'b', with optional index |
| |
| -- End is indicated by two consecutive '#' |
| |
| Initialization_Data : constant String := |
| |
| -- project attributes |
| |
| "SVobject_dir#" & |
| "SVexec_dir#" & |
| "LVsource_dirs#" & |
| "LVsource_files#" & |
| "LVlocally_removed_files#" & |
| "SVsource_list_file#" & |
| "SVlibrary_dir#" & |
| "SVlibrary_name#" & |
| "SVlibrary_kind#" & |
| "SVlibrary_version#" & |
| "LVlibrary_interface#" & |
| "SVlibrary_auto_init#" & |
| "LVlibrary_options#" & |
| "SVlibrary_src_dir#" & |
| "SVlibrary_ali_dir#" & |
| "SVlibrary_gcc#" & |
| "SVlibrary_symbol_file#" & |
| "SVlibrary_symbol_policy#" & |
| "SVlibrary_reference_symbol_file#" & |
| "lVmain#" & |
| "LVlanguages#" & |
| "SVmain_language#" & |
| "LVada_roots#" & |
| "SVexternally_built#" & |
| |
| -- package Naming |
| |
| "Pnaming#" & |
| "Saspecification_suffix#" & |
| "Saspec_suffix#" & |
| "Saimplementation_suffix#" & |
| "Sabody_suffix#" & |
| "SVseparate_suffix#" & |
| "SVcasing#" & |
| "SVdot_replacement#" & |
| "sAspecification#" & |
| "sAspec#" & |
| "sAimplementation#" & |
| "sAbody#" & |
| "Laspecification_exceptions#" & |
| "Laimplementation_exceptions#" & |
| |
| -- package Compiler |
| |
| "Pcompiler#" & |
| "Ladefault_switches#" & |
| "Lcswitches#" & |
| "SVlocal_configuration_pragmas#" & |
| |
| -- package Builder |
| |
| "Pbuilder#" & |
| "Ladefault_switches#" & |
| "Lcswitches#" & |
| "Scexecutable#" & |
| "SVexecutable_suffix#" & |
| "SVglobal_configuration_pragmas#" & |
| |
| -- package gnatls |
| |
| "Pgnatls#" & |
| "LVswitches#" & |
| |
| -- package Binder |
| |
| "Pbinder#" & |
| "Ladefault_switches#" & |
| "Lcswitches#" & |
| |
| -- package Linker |
| |
| "Plinker#" & |
| "Ladefault_switches#" & |
| "Lcswitches#" & |
| "LVlinker_options#" & |
| |
| -- package Cross_Reference |
| |
| "Pcross_reference#" & |
| "Ladefault_switches#" & |
| "Lbswitches#" & |
| |
| -- package Finder |
| |
| "Pfinder#" & |
| "Ladefault_switches#" & |
| "Lbswitches#" & |
| |
| -- package Pretty_Printer |
| |
| "Ppretty_printer#" & |
| "Ladefault_switches#" & |
| "Lbswitches#" & |
| |
| -- package gnatstub |
| |
| "Pgnatstub#" & |
| "Ladefault_switches#" & |
| "Lbswitches#" & |
| |
| -- package Check |
| |
| "Pcheck#" & |
| "Ladefault_switches#" & |
| "Lbswitches#" & |
| |
| -- package Eliminate |
| |
| "Peliminate#" & |
| "Ladefault_switches#" & |
| "Lbswitches#" & |
| |
| -- package Metrics |
| |
| "Pmetrics#" & |
| "Ladefault_switches#" & |
| "Lbswitches#" & |
| |
| -- package Ide |
| |
| "Pide#" & |
| "Ladefault_switches#" & |
| "SVremote_host#" & |
| "SVprogram_host#" & |
| "SVcommunication_protocol#" & |
| "Sacompiler_command#" & |
| "SVdebugger_command#" & |
| "SVgnatlist#" & |
| "SVvcs_kind#" & |
| "SVvcs_file_check#" & |
| "SVvcs_log_check#" & |
| |
| -- package Language_Processing |
| |
| "Planguage_processing#" & |
| "Lacompiler_driver#" & |
| "Sacompiler_kind#" & |
| "Ladependency_option#" & |
| "Lacompute_dependency#" & |
| "Lainclude_option#" & |
| "Sabinder_driver#" & |
| "SVdefault_linker#" & |
| |
| "#"; |
| |
| Initialized : Boolean := False; |
| -- A flag to avoid multiple initialization |
| |
| function Name_Id_Of (Name : String) return Name_Id; |
| -- Returns the Name_Id for Name in lower case |
| |
| ----------------------- |
| -- Attribute_Kind_Of -- |
| ----------------------- |
| |
| function Attribute_Kind_Of |
| (Attribute : Attribute_Node_Id) return Attribute_Kind |
| is |
| begin |
| if Attribute = Empty_Attribute then |
| return Unknown; |
| else |
| return Attrs.Table (Attribute.Value).Attr_Kind; |
| end if; |
| end Attribute_Kind_Of; |
| |
| ----------------------- |
| -- Attribute_Name_Of -- |
| ----------------------- |
| |
| function Attribute_Name_Of (Attribute : Attribute_Node_Id) return Name_Id is |
| begin |
| if Attribute = Empty_Attribute then |
| return No_Name; |
| else |
| return Attrs.Table (Attribute.Value).Name; |
| end if; |
| end Attribute_Name_Of; |
| |
| -------------------------- |
| -- Attribute_Node_Id_Of -- |
| -------------------------- |
| |
| function Attribute_Node_Id_Of |
| (Name : Name_Id; |
| Starting_At : Attribute_Node_Id) return Attribute_Node_Id |
| is |
| Id : Attr_Node_Id := Starting_At.Value; |
| |
| begin |
| while Id /= Empty_Attr |
| and then Attrs.Table (Id).Name /= Name |
| loop |
| Id := Attrs.Table (Id).Next; |
| end loop; |
| |
| return (Value => Id); |
| end Attribute_Node_Id_Of; |
| |
| ---------------- |
| -- Initialize -- |
| ---------------- |
| |
| procedure Initialize is |
| Start : Positive := Initialization_Data'First; |
| Finish : Positive := Start; |
| Current_Package : Pkg_Node_Id := Empty_Pkg; |
| Current_Attribute : Attr_Node_Id := Empty_Attr; |
| Is_An_Attribute : Boolean := False; |
| Var_Kind : Variable_Kind := Undefined; |
| Optional_Index : Boolean := False; |
| Attr_Kind : Attribute_Kind := Single; |
| Package_Name : Name_Id := No_Name; |
| Attribute_Name : Name_Id := No_Name; |
| First_Attribute : Attr_Node_Id := Attr.First_Attribute; |
| |
| function Attribute_Location return String; |
| -- Returns a string depending if we are in the project level attributes |
| -- or in the attributes of a package. |
| |
| ------------------------ |
| -- Attribute_Location -- |
| ------------------------ |
| |
| function Attribute_Location return String is |
| begin |
| if Package_Name = No_Name then |
| return "project level attributes"; |
| |
| else |
| return "attribute of package """ & |
| Get_Name_String (Package_Name) & """"; |
| end if; |
| end Attribute_Location; |
| |
| -- Start of processing for Initialize |
| |
| begin |
| -- Don't allow Initialize action to be repeated |
| |
| if Initialized then |
| return; |
| end if; |
| |
| -- Make sure the two tables are empty |
| |
| Attrs.Init; |
| Package_Attributes.Init; |
| |
| while Initialization_Data (Start) /= '#' loop |
| Is_An_Attribute := True; |
| case Initialization_Data (Start) is |
| when 'P' => |
| |
| -- New allowed package |
| |
| Start := Start + 1; |
| |
| Finish := Start; |
| while Initialization_Data (Finish) /= '#' loop |
| Finish := Finish + 1; |
| end loop; |
| |
| Package_Name := |
| Name_Id_Of (Initialization_Data (Start .. Finish - 1)); |
| |
| for Index in First_Package .. Package_Attributes.Last loop |
| if Package_Name = Package_Attributes.Table (Index).Name then |
| Osint.Fail ("duplicate name """, |
| Initialization_Data (Start .. Finish - 1), |
| """ in predefined packages."); |
| end if; |
| end loop; |
| |
| Is_An_Attribute := False; |
| Current_Attribute := Empty_Attr; |
| Package_Attributes.Increment_Last; |
| Current_Package := Package_Attributes.Last; |
| Package_Attributes.Table (Current_Package) := |
| (Name => Package_Name, |
| Known => True, |
| First_Attribute => Empty_Attr); |
| Start := Finish + 1; |
| |
| when 'S' => |
| Var_Kind := Single; |
| Optional_Index := False; |
| |
| when 's' => |
| Var_Kind := Single; |
| Optional_Index := True; |
| |
| when 'L' => |
| Var_Kind := List; |
| Optional_Index := False; |
| |
| when 'l' => |
| Var_Kind := List; |
| Optional_Index := True; |
| |
| when others => |
| raise Program_Error; |
| end case; |
| |
| if Is_An_Attribute then |
| |
| -- New attribute |
| |
| Start := Start + 1; |
| case Initialization_Data (Start) is |
| when 'V' => |
| Attr_Kind := Single; |
| |
| when 'A' => |
| Attr_Kind := Associative_Array; |
| |
| when 'a' => |
| Attr_Kind := Case_Insensitive_Associative_Array; |
| |
| when 'b' => |
| if Osint.File_Names_Case_Sensitive then |
| Attr_Kind := Associative_Array; |
| else |
| Attr_Kind := Case_Insensitive_Associative_Array; |
| end if; |
| |
| when 'c' => |
| if Osint.File_Names_Case_Sensitive then |
| Attr_Kind := Optional_Index_Associative_Array; |
| else |
| Attr_Kind := |
| Optional_Index_Case_Insensitive_Associative_Array; |
| end if; |
| |
| when others => |
| raise Program_Error; |
| end case; |
| |
| Start := Start + 1; |
| Finish := Start; |
| |
| while Initialization_Data (Finish) /= '#' loop |
| Finish := Finish + 1; |
| end loop; |
| |
| Attribute_Name := |
| Name_Id_Of (Initialization_Data (Start .. Finish - 1)); |
| Attrs.Increment_Last; |
| |
| if Current_Attribute = Empty_Attr then |
| First_Attribute := Attrs.Last; |
| |
| if Current_Package /= Empty_Pkg then |
| Package_Attributes.Table (Current_Package).First_Attribute |
| := Attrs.Last; |
| end if; |
| |
| else |
| -- Check that there are no duplicate attributes |
| |
| for Index in First_Attribute .. Attrs.Last - 1 loop |
| if Attribute_Name = Attrs.Table (Index).Name then |
| Osint.Fail ("duplicate attribute """, |
| Initialization_Data (Start .. Finish - 1), |
| """ in " & Attribute_Location); |
| end if; |
| end loop; |
| |
| Attrs.Table (Current_Attribute).Next := |
| Attrs.Last; |
| end if; |
| |
| Current_Attribute := Attrs.Last; |
| Attrs.Table (Current_Attribute) := |
| (Name => Attribute_Name, |
| Var_Kind => Var_Kind, |
| Optional_Index => Optional_Index, |
| Attr_Kind => Attr_Kind, |
| Next => Empty_Attr); |
| Start := Finish + 1; |
| end if; |
| end loop; |
| |
| Initialized := True; |
| end Initialize; |
| |
| ---------------- |
| -- Name_Id_Of -- |
| ---------------- |
| |
| function Name_Id_Of (Name : String) return Name_Id is |
| begin |
| Name_Len := 0; |
| Add_Str_To_Name_Buffer (Name); |
| To_Lower (Name_Buffer (1 .. Name_Len)); |
| return Name_Find; |
| end Name_Id_Of; |
| |
| -------------------- |
| -- Next_Attribute -- |
| -------------------- |
| |
| function Next_Attribute |
| (After : Attribute_Node_Id) return Attribute_Node_Id |
| is |
| begin |
| if After = Empty_Attribute then |
| return Empty_Attribute; |
| else |
| return (Value => Attrs.Table (After.Value).Next); |
| end if; |
| end Next_Attribute; |
| |
| ----------------------- |
| -- Optional_Index_Of -- |
| ----------------------- |
| |
| function Optional_Index_Of (Attribute : Attribute_Node_Id) return Boolean is |
| begin |
| if Attribute = Empty_Attribute then |
| return False; |
| else |
| return Attrs.Table (Attribute.Value).Optional_Index; |
| end if; |
| end Optional_Index_Of; |
| |
| ------------------------ |
| -- Package_Node_Id_Of -- |
| ------------------------ |
| |
| function Package_Node_Id_Of (Name : Name_Id) return Package_Node_Id is |
| begin |
| for Index in Package_Attributes.First .. Package_Attributes.Last loop |
| if Package_Attributes.Table (Index).Name = Name then |
| return (Value => Index); |
| end if; |
| end loop; |
| |
| -- If there is no package with this name, return Empty_Package |
| |
| return Empty_Package; |
| end Package_Node_Id_Of; |
| |
| ---------------------------- |
| -- Register_New_Attribute -- |
| ---------------------------- |
| |
| procedure Register_New_Attribute |
| (Name : String; |
| In_Package : Package_Node_Id; |
| Attr_Kind : Defined_Attribute_Kind; |
| Var_Kind : Defined_Variable_Kind; |
| Index_Is_File_Name : Boolean := False; |
| Opt_Index : Boolean := False) |
| is |
| Attr_Name : Name_Id; |
| First_Attr : Attr_Node_Id := Empty_Attr; |
| Curr_Attr : Attr_Node_Id; |
| Real_Attr_Kind : Attribute_Kind; |
| |
| begin |
| if Name'Length = 0 then |
| Fail ("cannot register an attribute with no name"); |
| raise Project_Error; |
| end if; |
| |
| if In_Package = Empty_Package then |
| Fail ("attempt to add attribute """, Name, |
| """ to an undefined package"); |
| raise Project_Error; |
| end if; |
| |
| Attr_Name := Name_Id_Of (Name); |
| |
| First_Attr := |
| Package_Attributes.Table (In_Package.Value).First_Attribute; |
| |
| -- Check if attribute name is a duplicate |
| |
| Curr_Attr := First_Attr; |
| while Curr_Attr /= Empty_Attr loop |
| if Attrs.Table (Curr_Attr).Name = Attr_Name then |
| Fail ("duplicate attribute name """, Name, |
| """ in package """ & |
| Get_Name_String |
| (Package_Attributes.Table (In_Package.Value).Name) & |
| """"); |
| raise Project_Error; |
| end if; |
| |
| Curr_Attr := Attrs.Table (Curr_Attr).Next; |
| end loop; |
| |
| Real_Attr_Kind := Attr_Kind; |
| |
| -- If Index_Is_File_Name, change the attribute kind if necessary |
| |
| if Index_Is_File_Name and then not Osint.File_Names_Case_Sensitive then |
| case Attr_Kind is |
| when Associative_Array => |
| Real_Attr_Kind := Case_Insensitive_Associative_Array; |
| |
| when Optional_Index_Associative_Array => |
| Real_Attr_Kind := |
| Optional_Index_Case_Insensitive_Associative_Array; |
| |
| when others => |
| null; |
| end case; |
| end if; |
| |
| -- Add the new attribute |
| |
| Attrs.Increment_Last; |
| Attrs.Table (Attrs.Last) := |
| (Name => Attr_Name, |
| Var_Kind => Var_Kind, |
| Optional_Index => Opt_Index, |
| Attr_Kind => Real_Attr_Kind, |
| Next => First_Attr); |
| Package_Attributes.Table (In_Package.Value).First_Attribute := |
| Attrs.Last; |
| end Register_New_Attribute; |
| |
| -------------------------- |
| -- Register_New_Package -- |
| -------------------------- |
| |
| procedure Register_New_Package (Name : String; Id : out Package_Node_Id) is |
| Pkg_Name : Name_Id; |
| |
| begin |
| if Name'Length = 0 then |
| Fail ("cannot register a package with no name"); |
| Id := Empty_Package; |
| return; |
| end if; |
| |
| Pkg_Name := Name_Id_Of (Name); |
| |
| for Index in Package_Attributes.First .. Package_Attributes.Last loop |
| if Package_Attributes.Table (Index).Name = Pkg_Name then |
| Fail ("cannot register a package with a non unique name""", |
| Name, """"); |
| Id := Empty_Package; |
| return; |
| end if; |
| end loop; |
| |
| Package_Attributes.Increment_Last; |
| Id := (Value => Package_Attributes.Last); |
| Package_Attributes.Table (Package_Attributes.Last) := |
| (Name => Pkg_Name, Known => True, First_Attribute => Empty_Attr); |
| end Register_New_Package; |
| |
| procedure Register_New_Package |
| (Name : String; |
| Attributes : Attribute_Data_Array) |
| is |
| Pkg_Name : Name_Id; |
| Attr_Name : Name_Id; |
| First_Attr : Attr_Node_Id := Empty_Attr; |
| Curr_Attr : Attr_Node_Id; |
| Attr_Kind : Attribute_Kind; |
| |
| begin |
| if Name'Length = 0 then |
| Fail ("cannot register a package with no name"); |
| raise Project_Error; |
| end if; |
| |
| Pkg_Name := Name_Id_Of (Name); |
| |
| for Index in Package_Attributes.First .. Package_Attributes.Last loop |
| if Package_Attributes.Table (Index).Name = Pkg_Name then |
| Fail ("cannot register a package with a non unique name""", |
| Name, """"); |
| raise Project_Error; |
| end if; |
| end loop; |
| |
| for Index in Attributes'Range loop |
| Attr_Name := Name_Id_Of (Attributes (Index).Name); |
| |
| Curr_Attr := First_Attr; |
| while Curr_Attr /= Empty_Attr loop |
| if Attrs.Table (Curr_Attr).Name = Attr_Name then |
| Fail ("duplicate attribute name """, Attributes (Index).Name, |
| """ in new package """ & Name & """"); |
| raise Project_Error; |
| end if; |
| |
| Curr_Attr := Attrs.Table (Curr_Attr).Next; |
| end loop; |
| |
| Attr_Kind := Attributes (Index).Attr_Kind; |
| |
| if Attributes (Index).Index_Is_File_Name |
| and then not Osint.File_Names_Case_Sensitive |
| then |
| case Attr_Kind is |
| when Associative_Array => |
| Attr_Kind := Case_Insensitive_Associative_Array; |
| |
| when Optional_Index_Associative_Array => |
| Attr_Kind := |
| Optional_Index_Case_Insensitive_Associative_Array; |
| |
| when others => |
| null; |
| end case; |
| end if; |
| |
| Attrs.Increment_Last; |
| Attrs.Table (Attrs.Last) := |
| (Name => Attr_Name, |
| Var_Kind => Attributes (Index).Var_Kind, |
| Optional_Index => Attributes (Index).Opt_Index, |
| Attr_Kind => Attr_Kind, |
| Next => First_Attr); |
| First_Attr := Attrs.Last; |
| end loop; |
| |
| Package_Attributes.Increment_Last; |
| Package_Attributes.Table (Package_Attributes.Last) := |
| (Name => Pkg_Name, Known => True, First_Attribute => First_Attr); |
| end Register_New_Package; |
| |
| --------------------------- |
| -- Set_Attribute_Kind_Of -- |
| --------------------------- |
| |
| procedure Set_Attribute_Kind_Of |
| (Attribute : Attribute_Node_Id; |
| To : Attribute_Kind) |
| is |
| begin |
| if Attribute /= Empty_Attribute then |
| Attrs.Table (Attribute.Value).Attr_Kind := To; |
| end if; |
| end Set_Attribute_Kind_Of; |
| |
| -------------------------- |
| -- Set_Variable_Kind_Of -- |
| -------------------------- |
| |
| procedure Set_Variable_Kind_Of |
| (Attribute : Attribute_Node_Id; |
| To : Variable_Kind) |
| is |
| begin |
| if Attribute /= Empty_Attribute then |
| Attrs.Table (Attribute.Value).Var_Kind := To; |
| end if; |
| end Set_Variable_Kind_Of; |
| |
| ---------------------- |
| -- Variable_Kind_Of -- |
| ---------------------- |
| |
| function Variable_Kind_Of |
| (Attribute : Attribute_Node_Id) return Variable_Kind |
| is |
| begin |
| if Attribute = Empty_Attribute then |
| return Undefined; |
| else |
| return Attrs.Table (Attribute.Value).Var_Kind; |
| end if; |
| end Variable_Kind_Of; |
| |
| ------------------------ |
| -- First_Attribute_Of -- |
| ------------------------ |
| |
| function First_Attribute_Of |
| (Pkg : Package_Node_Id) return Attribute_Node_Id |
| is |
| begin |
| if Pkg = Empty_Package then |
| return Empty_Attribute; |
| else |
| return |
| (Value => Package_Attributes.Table (Pkg.Value).First_Attribute); |
| end if; |
| end First_Attribute_Of; |
| |
| end Prj.Attr; |
