diff options
Diffstat (limited to 'gcc-4.9/gcc/ada/prj-attr.adb')
| -rw-r--r-- | gcc-4.9/gcc/ada/prj-attr.adb | 1027 |
1 files changed, 1027 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/ada/prj-attr.adb b/gcc-4.9/gcc/ada/prj-attr.adb new file mode 100644 index 000000000..04ce48a4a --- /dev/null +++ b/gcc-4.9/gcc/ada/prj-attr.adb @@ -0,0 +1,1027 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . A T T R -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-2013, 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#" & + "SVRproject_dir#" & + "lVmain#" & + "LVlanguages#" & + "Lbroots#" & + "SVexternally_built#" & + + -- Directories + + "SVobject_dir#" & + "SVexec_dir#" & + "LVsource_dirs#" & + "Lainherit_source_path#" & + "LVexcluded_source_dirs#" & + "LVignore_source_sub_dirs#" & + + -- Source files + + "LVsource_files#" & + "LVlocally_removed_files#" & + "LVexcluded_source_files#" & + "SVsource_list_file#" & + "SVexcluded_source_list_file#" & + "LVinterfaces#" & + + -- Projects (in aggregate projects) + + "LVproject_files#" & + "LVproject_path#" & + "SAexternal#" & + + -- Libraries + + "SVlibrary_dir#" & + "SVlibrary_name#" & + "SVlibrary_kind#" & + "SVlibrary_version#" & + "LVlibrary_interface#" & + "SVlibrary_standalone#" & + "LVlibrary_encapsulated_options#" & + "SVlibrary_encapsulated_supported#" & + "SVlibrary_auto_init#" & + "LVleading_library_options#" & + "LVlibrary_options#" & + "Lalibrary_rpath_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#" & + "SVrun_path_origin#" & + "SVseparate_run_path_options#" & + "Satoolchain_version#" & + "Satoolchain_description#" & + "Saobject_generated#" & + "Saobjects_linked#" & + "SVtarget#" & + + -- 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#" & + "SVlibrary_install_name_option#" & + "Saruntime_library_dir#" & + "Saruntime_source_dir#" & + + -- package Naming + -- Some attributes are obsolescent, and renamed in the tree (see + -- Prj.Dect.Rename_Obsolescent_Attributes). + + "Pnaming#" & + "Saspecification_suffix#" & -- Always renamed to "spec_suffix" in tree + "Saspec_suffix#" & + "Saimplementation_suffix#" & -- Always renamed to "body_suffix" in tree + "Sabody_suffix#" & + "SVseparate_suffix#" & + "SVcasing#" & + "SVdot_replacement#" & + "saspecification#" & -- Always renamed to "spec" in project tree + "saspec#" & + "saimplementation#" & -- Always renamed to "body" in project tree + "sabody#" & + "Laspecification_exceptions#" & + "Laimplementation_exceptions#" & + + -- package Compiler + + "Pcompiler#" & + "Ladefault_switches#" & + "LcOswitches#" & + "SVlocal_configuration_pragmas#" & + "Salocal_config_file#" & + + -- Configuration - Compiling + + "Sadriver#" & + "Salanguage_kind#" & + "Sadependency_kind#" & + "Larequired_switches#" & + "Laleading_required_switches#" & + "Latrailing_required_switches#" & + "Lapic_option#" & + "Sapath_syntax#" & + "Lasource_file_switches#" & + "Saobject_file_suffix#" & + "Laobject_file_switches#" & + "Lamulti_unit_switches#" & + "Samulti_unit_object_separator#" & + + -- Configuration - Mapping files + + "Lamapping_file_switches#" & + "Samapping_spec_suffix#" & + "Samapping_body_suffix#" & + + -- Configuration - Config files + + "Laconfig_file_switches#" & + "Saconfig_body_file_name#" & + "Saconfig_body_file_name_index#" & + "Saconfig_body_file_name_pattern#" & + "Saconfig_spec_file_name#" & + "Saconfig_spec_file_name_index#" & + "Saconfig_spec_file_name_pattern#" & + "Saconfig_file_unique#" & + + -- Configuration - Dependencies + + "Ladependency_switches#" & + "Ladependency_driver#" & + + -- Configuration - Search paths + + "Lainclude_switches#" & + "Sainclude_path#" & + "Sainclude_path_file#" & + "Laobject_path_switches#" & + + -- 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#" & + "LcOleading_switches#" & + "LcOswitches#" & + "LcOtrailing_switches#" & + "LVlinker_options#" & + "SVmap_file_option#" & + + -- Configuration - Linking + + "SVdriver#" & + "LVexecutable_switch#" & + "SVlib_dir_switch#" & + "SVlib_name_switch#" & + + -- Configuration - Response files + + "SVmax_command_line_length#" & + "SVresponse_file_format#" & + "LVresponse_file_switches#" & + + -- package Clean + + "Pclean#" & + "LVswitches#" & + "Lasource_artifact_extensions#" & + "Laobject_artifact_extensions#" & + "LVartifacts_in_exec_dir#" & + "LVartifacts_in_object_dir#" & + + -- 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#" & + "SVdocumentation_dir#" & + + -- package Install + + "Pinstall#" & + "SVprefix#" & + "SVsources_subdir#" & + "SVexec_subdir#" & + "SVlib_subdir#" & + "SVproject_subdir#" & + "SVactive#" & + "LAartifacts#" & + + -- package Remote + + "Premote#" & + "SVroot_dir#" & + "LVexcluded_patterns#" & + "LVincluded_patterns#" & + "LVincluded_artifact_patterns#" & + + -- 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 or else Pkg = Unknown_Package then + return Empty_Attribute; + else + return + (Value => Package_Attributes.Table (Pkg.Value).First_Attribute); + end if; + end First_Attribute_Of; + +end Prj.Attr; |