diff options
Diffstat (limited to 'gcc-4.2.1/gcc/ada/prj-attr.adb')
-rw-r--r-- | gcc-4.2.1/gcc/ada/prj-attr.adb | 749 |
1 files changed, 749 insertions, 0 deletions
diff --git a/gcc-4.2.1/gcc/ada/prj-attr.adb b/gcc-4.2.1/gcc/ada/prj-attr.adb new file mode 100644 index 000000000..f73751c8c --- /dev/null +++ b/gcc-4.2.1/gcc/ada/prj-attr.adb @@ -0,0 +1,749 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; |