-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2011, 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. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-with Ada.Characters.Handling; use Ada.Characters.Handling;
-with Namet; use Namet;
-with Osint; use Osint;
-with Output; use Output;
+with Osint;
+with Prj.Com; use Prj.Com;
+
+with GNAT.Case_Util; use GNAT.Case_Util;
package body Prj.Attr is
- -- Names end with '#'
+ 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 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 case insensitive associative array
-- 'b' for associative array, case insensitive if file names are case
-- insensitive
+ -- 'c' same as 'b', with optional index
- -- End is indicated by two consecutive '#'.
+ -- 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 attributes
-
- "SVobject_dir#" &
- "SVexec_dir#" &
- "LVsource_dirs#" &
- "LVsource_files#" &
- "LVlocally_removed_files#" &
- "SVsource_list_file#" &
- "SVlibrary_dir#" &
- "SVlibrary_name#" &
- "SVlibrary_kind#" &
- "SVlibrary_version#" &
- "LVlibrary_interface#" &
- "SVlibrary_auto_init#" &
- "LVlibrary_options#" &
- "SVlibrary_src_dir#" &
- "SVlibrary_gcc#" &
- "SVlibrary_symbol_file#" &
- "SVlibrary_symbol_policy#" &
- "SVlibrary_reference_symbol_file#" &
- "LVmain#" &
- "LVlanguages#" &
- "SVmain_language#" &
+ -- 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#" &
+ "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
-
- "Pnaming#" &
- "Saspecification_suffix#" &
- "Saspec_suffix#" &
- "Saimplementation_suffix#" &
- "Sabody_suffix#" &
- "SVseparate_suffix#" &
- "SVcasing#" &
- "SVdot_replacement#" &
- "SAspecification#" &
- "SAspec#" &
- "SAimplementation#" &
- "SAbody#" &
- "Laspecification_exceptions#" &
- "Laimplementation_exceptions#" &
+ -- 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#" &
- "Lbswitches#" &
- "SVlocal_configuration_pragmas#" &
+ "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#" &
-- package Builder
- "Pbuilder#" &
- "Ladefault_switches#" &
- "Lbswitches#" &
- "SAexecutable#" &
- "SVexecutable_suffix#" &
- "SVglobal_configuration_pragmas#" &
+ "Pbuilder#" &
+ "Ladefault_switches#" &
+ "LcOswitches#" &
+ "Lcglobal_compilation_switches#" &
+ "Scexecutable#" &
+ "SVexecutable_suffix#" &
+ "SVglobal_configuration_pragmas#" &
+ "Saglobal_config_file#" &
-- package gnatls
- "Pgnatls#" &
- "LVswitches#" &
+ "Pgnatls#" &
+ "LVswitches#" &
-- package Binder
- "Pbinder#" &
- "Ladefault_switches#" &
- "Lbswitches#" &
+ "Pbinder#" &
+ "Ladefault_switches#" &
+ "LcOswitches#" &
+
+ -- Configuration - Binding
+
+ "Sadriver#" &
+ "Larequired_switches#" &
+ "Saprefix#" &
+ "Saobjects_path#" &
+ "Saobjects_path_file#" &
-- package Linker
- "Plinker#" &
- "Ladefault_switches#" &
- "Lbswitches#" &
- "LVlinker_options#" &
+ "Plinker#" &
+ "LVrequired_switches#" &
+ "Ladefault_switches#" &
+ "LcOleading_switches#" &
+ "LcOswitches#" &
+ "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 Cross_Reference
- "Pcross_reference#" &
- "Ladefault_switches#" &
- "Lbswitches#" &
+ "Pcross_reference#" &
+ "Ladefault_switches#" &
+ "LbOswitches#" &
-- package Finder
- "Pfinder#" &
- "Ladefault_switches#" &
- "Lbswitches#" &
+ "Pfinder#" &
+ "Ladefault_switches#" &
+ "LbOswitches#" &
-- package Pretty_Printer
- "Ppretty_printer#" &
- "Ladefault_switches#" &
- "Lbswitches#" &
+ "Ppretty_printer#" &
+ "Ladefault_switches#" &
+ "LbOswitches#" &
-- package gnatstub
- "Pgnatstub#" &
- "Ladefault_switches#" &
- "Lbswitches#" &
+ "Pgnatstub#" &
+ "Ladefault_switches#" &
+ "LbOswitches#" &
+
+ -- package Check
+
+ "Pcheck#" &
+ "Ladefault_switches#" &
+ "LbOswitches#" &
+
+ -- package Synchronize
+
+ "Psynchronize#" &
+ "Ladefault_switches#" &
+ "LbOswitches#" &
-- package Eliminate
- "Peliminate#" &
- "Ladefault_switches#" &
- "Lbswitches#" &
+ "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#" &
+ "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 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 : 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;
+ 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
- Attributes.Init;
+ Attrs.Init;
Package_Attributes.Init;
while Initialization_Data (Start) /= '#' loop
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;
+ Add_Package_Name (Get_Name_String (Package_Name));
+
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;
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 File_Names_Case_Sensitive then
- Kind_2 := Case_Insensitive_Associative_Array;
+ if Osint.File_Names_Case_Sensitive then
+ Attr_Kind := Associative_Array;
else
- Kind_2 := Case_Insensitive_Associative_Array;
+ 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 =>
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;
- 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,
+ 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;
OSDN Git Service
