diff options
Diffstat (limited to 'gcc-4.4.3/gcc/ada/prj-attr.adb')
-rw-r--r-- | gcc-4.4.3/gcc/ada/prj-attr.adb | 952 |
1 files changed, 0 insertions, 952 deletions
diff --git a/gcc-4.4.3/gcc/ada/prj-attr.adb b/gcc-4.4.3/gcc/ada/prj-attr.adb deleted file mode 100644 index 63651f94d..000000000 --- a/gcc-4.4.3/gcc/ada/prj-attr.adb +++ /dev/null @@ -1,952 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- P R J . A T T R -- --- -- --- B o d y -- --- -- --- Copyright (C) 2001-2008, 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 3, 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 COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the license. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Osint; -with Prj.Com; use Prj.Com; - -with GNAT.Case_Util; use GNAT.Case_Util; - -package body Prj.Attr is - - use GNAT; - - -- Data for predefined attributes and packages - - -- Names are in lower case and end with '#' - - -- Package names are preceded by 'P' - - -- Attribute names are preceded by two or three 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 - - -- The third optional letter is - -- 'R' to indicate that the attribute is read-only - -- 'O' to indicate that others is allowed as an index for an associative - -- array - - -- End is indicated by two consecutive '#' - - Initialization_Data : constant String := - - -- project level attributes - - -- General - - "SVRname#" & - "lVmain#" & - "LVlanguages#" & - "SVmain_language#" & - "Lbroots#" & - "SVexternally_built#" & - - -- Directories - - "SVobject_dir#" & - "SVexec_dir#" & - "LVsource_dirs#" & - "Lainherit_source_path#" & - "LVexcluded_source_dirs#" & - - -- Source files - - "LVsource_files#" & - "LVlocally_removed_files#" & - "LVexcluded_source_files#" & - "SVsource_list_file#" & - "SVexcluded_source_list_file#" & - "LVinterfaces#" & - - -- Libraries - - "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#" & - - -- Configuration - General - - "SVdefault_language#" & - "LVrun_path_option#" & - "Satoolchain_version#" & - "Satoolchain_description#" & - "Saobject_generated#" & - "Saobjects_linked#" & - - -- Configuration - Libraries - - "SVlibrary_builder#" & - "SVlibrary_support#" & - - -- Configuration - Archives - - "LVarchive_builder#" & - "LVarchive_builder_append_option#" & - "LVarchive_indexer#" & - "SVarchive_suffix#" & - "LVlibrary_partial_linker#" & - - -- Configuration - Shared libraries - - "SVshared_library_prefix#" & - "SVshared_library_suffix#" & - "SVsymbolic_link_supported#" & - "SVlibrary_major_minor_id_supported#" & - "SVlibrary_auto_init_supported#" & - "LVshared_library_minimum_switches#" & - "LVlibrary_version_switches#" & - "Saruntime_library_dir#" & - - -- 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#" & - "LcOswitches#" & - "SVlocal_configuration_pragmas#" & - "Salocal_config_file#" & - - -- Configuration - Compiling - - "Sadriver#" & - "Larequired_switches#" & - "Lapic_option#" & - "Sapath_syntax#" & - - -- Configuration - Mapping files - - "Lamapping_file_switches#" & - "Samapping_spec_suffix#" & - "Samapping_body_suffix#" & - - -- Configuration - Config files - - "Laconfig_file_switches#" & - "Saconfig_body_file_name#" & - "Saconfig_spec_file_name#" & - "Saconfig_body_file_name_pattern#" & - "Saconfig_spec_file_name_pattern#" & - "Saconfig_file_unique#" & - - -- Configuration - Dependencies - - "Ladependency_switches#" & - "Ladependency_driver#" & - - -- Configuration - Search paths - - "Lainclude_switches#" & - "Sainclude_path#" & - "Sainclude_path_file#" & - - -- package Builder - - "Pbuilder#" & - "Ladefault_switches#" & - "LcOswitches#" & - "Lcglobal_compilation_switches#" & - "Scexecutable#" & - "SVexecutable_suffix#" & - "SVglobal_configuration_pragmas#" & - "Saglobal_config_file#" & - - -- package gnatls - - "Pgnatls#" & - "LVswitches#" & - - -- package Binder - - "Pbinder#" & - "Ladefault_switches#" & - "LcOswitches#" & - - -- Configuration - Binding - - "Sadriver#" & - "Larequired_switches#" & - "Saprefix#" & - "Saobjects_path#" & - "Saobjects_path_file#" & - - -- package Linker - - "Plinker#" & - "LVrequired_switches#" & - "Ladefault_switches#" & - "LcOswitches#" & - "LVlinker_options#" & - "SVmap_file_option#" & - - -- Configuration - Linking - - "SVdriver#" & - "LVexecutable_switch#" & - "SVlib_dir_switch#" & - "SVlib_name_switch#" & - - -- package Cross_Reference - - "Pcross_reference#" & - "Ladefault_switches#" & - "LbOswitches#" & - - -- package Finder - - "Pfinder#" & - "Ladefault_switches#" & - "LbOswitches#" & - - -- package Pretty_Printer - - "Ppretty_printer#" & - "Ladefault_switches#" & - "LbOswitches#" & - - -- package gnatstub - - "Pgnatstub#" & - "Ladefault_switches#" & - "LbOswitches#" & - - -- package Check - - "Pcheck#" & - "Ladefault_switches#" & - "LbOswitches#" & - - -- package Synchronize - - "Psynchronize#" & - "Ladefault_switches#" & - "LbOswitches#" & - - -- package Eliminate - - "Peliminate#" & - "Ladefault_switches#" & - "LbOswitches#" & - - -- package Metrics - - "Pmetrics#" & - "Ladefault_switches#" & - "LbOswitches#" & - - -- 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 Stack - - "Pstack#" & - "LVswitches#" & - - "#"; - - Initialized : Boolean := False; - -- A flag to avoid multiple initialization - - Package_Names : String_List_Access := new Strings.String_List (1 .. 20); - Last_Package_Name : Natural := 0; - -- Package_Names (1 .. Last_Package_Name) contains the list of the known - -- package names, coming from the Initialization_Data string or from - -- calls to one of the two procedures Register_New_Package. - - procedure Add_Package_Name (Name : String); - -- Add a package name in the Package_Name list, extending it, if necessary - - function Name_Id_Of (Name : String) return Name_Id; - -- Returns the Name_Id for Name in lower case - - ---------------------- - -- Add_Package_Name -- - ---------------------- - - procedure Add_Package_Name (Name : String) is - begin - if Last_Package_Name = Package_Names'Last then - declare - New_List : constant Strings.String_List_Access := - new Strings.String_List (1 .. Package_Names'Last * 2); - begin - New_List (Package_Names'Range) := Package_Names.all; - Package_Names := New_List; - end; - end if; - - Last_Package_Name := Last_Package_Name + 1; - Package_Names (Last_Package_Name) := new String'(Name); - end Add_Package_Name; - - ----------------------- - -- 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; - Read_Only : Boolean; - Others_Allowed : Boolean; - - 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; - - Add_Package_Name (Get_Name_String (Package_Name)); - - 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; - - Read_Only := False; - Others_Allowed := False; - - if Initialization_Data (Start) = 'R' then - Read_Only := True; - Start := Start + 1; - - elsif Initialization_Data (Start) = 'O' then - Others_Allowed := True; - Start := Start + 1; - end if; - - 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, - Read_Only => Read_Only, - Others_Allowed => Others_Allowed, - Next => Empty_Attr); - Start := Finish + 1; - end if; - end loop; - - Initialized := True; - end Initialize; - - ------------------ - -- Is_Read_Only -- - ------------------ - - function Is_Read_Only (Attribute : Attribute_Node_Id) return Boolean is - begin - return Attrs.Table (Attribute.Value).Read_Only; - end Is_Read_Only; - - ---------------- - -- 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; - - function Others_Allowed_For - (Attribute : Attribute_Node_Id) return Boolean - is - begin - if Attribute = Empty_Attribute then - return False; - else - return Attrs.Table (Attribute.Value).Others_Allowed; - end if; - end Others_Allowed_For; - - ----------------------- - -- Package_Name_List -- - ----------------------- - - function Package_Name_List return Strings.String_List is - begin - return Package_Names (1 .. Last_Package_Name); - end Package_Name_List; - - ------------------------ - -- 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 - if Package_Attributes.Table (Index).Known then - return (Value => Index); - else - return Unknown_Package; - end if; - 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, - Read_Only => False, - Others_Allowed => False, - 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); - - Add_Package_Name (Get_Name_String (Pkg_Name)); - 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, - Read_Only => False, - Others_Allowed => False, - 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); - - Add_Package_Name (Get_Name_String (Pkg_Name)); - 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; |