X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Fada%2Fprj-attr.adb;h=41bd6c4f4cebe347bc2704438488302fbb006346;hb=5f6832932ed0051ba8b9233b9ca408d5a3ff43bd;hp=6710f2119df9a9fb056a98ffda0648eb66b0d573;hpb=9ffca0cd58b37593feacfcbfd9e10c767ab16f49;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/ada/prj-attr.adb b/gcc/ada/prj-attr.adb index 6710f2119df..41bd6c4f4ce 100644 --- a/gcc/ada/prj-attr.adb +++ b/gcc/ada/prj-attr.adb @@ -2,153 +2,401 @@ -- -- -- GNAT COMPILER COMPONENTS -- -- -- --- P R J . A T T R -- +-- P R J . A T T R -- -- -- -- B o d y -- -- -- --- $Revision$ --- -- --- Copyright (C) 2001 Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2007, 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- -- +-- 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 COPYING. If not, write -- --- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, USA. -- +-- 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. -- --- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ -with Ada.Characters.Handling; use Ada.Characters.Handling; -with Namet; use Namet; -with Output; use Output; +with Osint; +with Prj.Com; use Prj.Com; +with System.Case_Util; use System.Case_Util; package body Prj.Attr is - -- Names end with '#' + -- 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 letters + -- Attribute names are preceded by two or three letters: -- The first letter is one of -- 'S' for Single - -- 'L' for list + -- '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 - -- End is indicated by two consecutive '#'. + -- End is indicated by two consecutive '#' Initialization_Data : constant String := - -- project attributes + -- project level attributes + + -- General + + "SVRname#" & + "lVmain#" & + "LVlanguages#" & + "SVmain_language#" & + "Laroots#" & + "SVexternally_built#" & + + -- Directories + + "SVobject_dir#" & + "SVexec_dir#" & + "LVsource_dirs#" & + "LVexcluded_source_dirs#" & + + -- Source files + + "LVsource_files#" & + "LVlocally_removed_files#" & + "LVexcluded_source_files#" & + "SVsource_list_file#" & + + -- 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#" & + + -- Configuration - Libraries + + "SVlibrary_builder#" & + "SVlibrary_support#" & + + -- Configuration - Archives + + "LVarchive_builder#" & + "LVarchive_indexer#" & + "SVarchive_suffix#" & + "LVlibrary_partial_linker#" & - "SVobject_dir#" & - "LVsource_dirs#" & - "LVsource_files#" & - "SVsource_list_file#" & - "SVlibrary_dir#" & - "SVlibrary_name#" & - "SVlibrary_kind#" & - "SVlibrary_elaboration#" & - "SVlibrary_version#" & - "LVmain#" & - "LVlanguages#" & + -- 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#" & - "Saimplementation_suffix#" & - "SVseparate_suffix#" & - "SVcasing#" & - "SVdot_replacement#" & - "SAspecification#" & - "SAimplementation#" & - "LAspecification_exceptions#" & - "LAimplementation_exceptions#" & + "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#" & - "LAswitches#" & - "SVlocal_configuration_pragmas#" & + "Pcompiler#" & + "Ladefault_switches#" & + "Lcswitches#" & + "SVlocal_configuration_pragmas#" & + "Salocal_config_file#" & + + -- Configuration - Compiling + + "Sadriver#" & + "Larequired_switches#" & + "Lapic_option#" & + + -- 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#" & + "Lacompute_dependency#" & + + -- Configuration - Search paths + + "Lainclude_switches#" & + "Sainclude_path#" & + "Sainclude_path_file#" & -- package Builder - "Pbuilder#" & - "Ladefault_switches#" & - "LAswitches#" & - "SVglobal_configuration_pragmas#" & + "Pbuilder#" & + "Ladefault_switches#" & + "Lcswitches#" & + "Scexecutable#" & + "SVexecutable_suffix#" & + "SVglobal_configuration_pragmas#" & + "Saglobal_config_file#" & -- package gnatls - "Pgnatls#" & - "LVswitches#" & + "Pgnatls#" & + "LVswitches#" & -- package Binder - "Pbinder#" & - "Ladefault_switches#" & - "LAswitches#" & + "Pbinder#" & + "Ladefault_switches#" & + "Lcswitches#" & + + -- Configuration - Binding + + "Sadriver#" & + "Larequired_switches#" & + "Saprefix#" & + "Saobjects_path#" & + "Saobjects_path_file#" & -- package Linker - "Plinker#" & - "Ladefault_switches#" & - "LAswitches#" & + "Plinker#" & + "LVrequired_switches#" & + "Ladefault_switches#" & + "Lcswitches#" & + "LVlinker_options#" & + + -- Configuration - Linking + + "SVdriver#" & + "LVexecutable_switch#" & + "SVlib_dir_switch#" & + "SVlib_name_switch#" & -- package Cross_Reference - "Pcross_reference#" & - "Ladefault_switches#" & - "LAswitches#" & + "Pcross_reference#" & + "Ladefault_switches#" & + "Lbswitches#" & -- package Finder - "Pfinder#" & - "Ladefault_switches#" & - "LAswitches#" & + "Pfinder#" & + "Ladefault_switches#" & + "Lbswitches#" & + + -- package Pretty_Printer + + "Ppretty_printer#" & + "Ladefault_switches#" & + "Lbswitches#" & - -- package Gnatstub + -- package gnatstub - "Pgnatstub#" & - "LVswitches#" & + "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 Stack + + "Pstack#" & + "LVswitches#" & + + "#"; + + 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 : Package_Node_Id := Empty_Package; - Current_Attribute : Attribute_Node_Id := Empty_Attribute; - Is_An_Attribute : Boolean := False; - Kind_1 : Variable_Kind := Undefined; - Kind_2 : Attribute_Kind := Single; - Package_Name : Name_Id := No_Name; - Attribute_Name : Name_Id := No_Name; - First_Attribute : Attribute_Node_Id := Attribute_First; + 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; + + 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 - Attributes.Set_Last (Attributes.First); - Package_Attributes.Set_Last (Package_Attributes.First); + Attrs.Init; + Package_Attributes.Init; while Initialization_Data (Start) /= '#' loop Is_An_Attribute := True; @@ -164,33 +412,42 @@ package body Prj.Attr is Finish := Finish + 1; end loop; - Name_Len := Finish - Start; - Name_Buffer (1 .. Name_Len) := - To_Lower (Initialization_Data (Start .. Finish - 1)); - Package_Name := Name_Find; + Package_Name := + Name_Id_Of (Initialization_Data (Start .. Finish - 1)); - for Index in Package_First .. Package_Attributes.Last loop + for Index in First_Package .. Package_Attributes.Last loop if Package_Name = Package_Attributes.Table (Index).Name then - Write_Line ("Duplicate package name """ & - Initialization_Data (Start .. Finish - 1) & - """ in Prj.Attr body."); - raise Program_Error; + Osint.Fail ("duplicate name """, + Initialization_Data (Start .. Finish - 1), + """ in predefined packages."); end if; end loop; Is_An_Attribute := False; - Current_Attribute := Empty_Attribute; + Current_Attribute := Empty_Attr; Package_Attributes.Increment_Last; Current_Package := Package_Attributes.Last; - Package_Attributes.Table (Current_Package).Name := - Package_Name; + Package_Attributes.Table (Current_Package) := + (Name => Package_Name, + Known => True, + First_Attribute => Empty_Attr); Start := Finish + 1; when 'S' => - Kind_1 := Single; + Var_Kind := Single; + Optional_Index := False; + + when 's' => + Var_Kind := Single; + Optional_Index := True; when 'L' => - Kind_1 := List; + Var_Kind := List; + Optional_Index := False; + + when 'l' => + Var_Kind := List; + Optional_Index := True; when others => raise Program_Error; @@ -203,61 +460,405 @@ package body Prj.Attr is Start := Start + 1; case Initialization_Data (Start) is when 'V' => - Kind_2 := Single; + Attr_Kind := Single; + when 'A' => - Kind_2 := Associative_Array; + Attr_Kind := Associative_Array; + when 'a' => - Kind_2 := Case_Insensitive_Associative_Array; + 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; + + if Initialization_Data (Start) = 'R' then + Read_Only := True; + Start := Start + 1; + + else + Read_Only := False; + end if; + Finish := Start; while Initialization_Data (Finish) /= '#' loop Finish := Finish + 1; end loop; - Name_Len := Finish - Start; - Name_Buffer (1 .. Name_Len) := - To_Lower (Initialization_Data (Start .. Finish - 1)); - Attribute_Name := Name_Find; - Attributes.Increment_Last; - if Current_Attribute = Empty_Attribute then - First_Attribute := Attributes.Last; + Attribute_Name := + Name_Id_Of (Initialization_Data (Start .. Finish - 1)); + Attrs.Increment_Last; - if Current_Package /= Empty_Package then + if Current_Attribute = Empty_Attr then + First_Attribute := Attrs.Last; + + if Current_Package /= Empty_Pkg then Package_Attributes.Table (Current_Package).First_Attribute - := Attributes.Last; + := Attrs.Last; end if; else -- Check that there are no duplicate attributes - for Index in First_Attribute .. Attributes.Last - 1 loop - if Attribute_Name = - Attributes.Table (Index).Name then - Write_Line ("Duplicate attribute name """ & - Initialization_Data (Start .. Finish - 1) & - """ in Prj.Attr body."); - raise Program_Error; + 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; - Attributes.Table (Current_Attribute).Next := - Attributes.Last; + Attrs.Table (Current_Attribute).Next := + Attrs.Last; end if; - Current_Attribute := Attributes.Last; - Attributes.Table (Current_Attribute) := - (Name => Attribute_Name, - Kind_1 => Kind_1, - Kind_2 => Kind_2, - Next => Empty_Attribute); + 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, + 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; + + ------------------------ + -- 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, + Read_Only => 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); + 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, + 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;