aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.4.3/gcc/ada/prj-attr.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.4.3/gcc/ada/prj-attr.adb')
-rw-r--r--gcc-4.4.3/gcc/ada/prj-attr.adb952
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;