| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- P R J . A T T R -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 2001-2014, 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 '#' or 'D' |
| |
| -- 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' the attribute is read-only |
| -- 'O' others is allowed as an index for an associative array |
| |
| -- If the character after the name in lower case letter is a 'D' (for |
| -- default), then 'D' must be followed by an enumeration value of type |
| -- Attribute_Default_Value, followed by a '#'. |
| |
| -- Example: |
| -- "SVobject_dirDdot_value#" |
| |
| -- End is indicated by two consecutive '#'. |
| |
| Initialization_Data : constant String := |
| |
| -- project level attributes |
| |
| -- General |
| |
| "SVRname#" & |
| "SVRproject_dir#" & |
| "lVmain#" & |
| "LVlanguages#" & |
| "Lbroots#" & |
| "SVexternally_built#" & |
| |
| -- Directories |
| |
| "SVobject_dirDdot_value#" & |
| "SVexec_dirDobject_dir_value#" & |
| "LVsource_dirsDdot_value#" & |
| "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#" & |
| "SVtargetDtarget_value#" & |
| "SaruntimeDruntime_value#" & |
| |
| -- 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#" & |
| |
| -- 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 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#" & |
| "SVmode#" & |
| "SVinstall_name#" & |
| |
| -- 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_Default_Of -- |
| -------------------------- |
| |
| function Attribute_Default_Of |
| (Attribute : Attribute_Node_Id) return Attribute_Default_Value |
| is |
| begin |
| if Attribute = Empty_Attribute then |
| return Empty_Value; |
| else |
| return Attrs.Table (Attribute.Value).Default; |
| end if; |
| end Attribute_Default_Of; |
| |
| ----------------------- |
| -- 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; |
| Default : Attribute_Default_Value; |
| |
| 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; |
| Default := Empty_Value; |
| |
| if Initialization_Data (Start) = 'R' then |
| Read_Only := True; |
| Default := Read_Only_Value; |
| Start := Start + 1; |
| |
| elsif Initialization_Data (Start) = 'O' then |
| Others_Allowed := True; |
| Start := Start + 1; |
| end if; |
| |
| Finish := Start; |
| |
| while Initialization_Data (Finish) /= '#' |
| and then |
| Initialization_Data (Finish) /= 'D' |
| loop |
| Finish := Finish + 1; |
| end loop; |
| |
| Attribute_Name := |
| Name_Id_Of (Initialization_Data (Start .. Finish - 1)); |
| |
| if Initialization_Data (Finish) = 'D' then |
| Start := Finish + 1; |
| |
| Finish := Start; |
| while Initialization_Data (Finish) /= '#' loop |
| Finish := Finish + 1; |
| end loop; |
| |
| declare |
| Default_Name : constant String := |
| Initialization_Data (Start .. Finish - 1); |
| pragma Unsuppress (All_Checks); |
| begin |
| Default := Attribute_Default_Value'Value (Default_Name); |
| exception |
| when Constraint_Error => |
| Osint.Fail |
| ("illegal default value """ & |
| Default_Name & |
| """ for attribute " & |
| Get_Name_String (Attribute_Name)); |
| end; |
| end if; |
| |
| 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, |
| Default => Default, |
| 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; |
| Default : Attribute_Default_Value := Empty_Value) |
| 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, |
| Default => Default, |
| 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; |
| Found : Boolean := False; |
| |
| 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 |
| if Package_Attributes.Table (Index).Known then |
| Fail ("cannot register a package with a non unique name """ |
| & Name |
| & """"); |
| Id := Empty_Package; |
| return; |
| |
| else |
| Found := True; |
| Id := (Value => Index); |
| exit; |
| end if; |
| end if; |
| end loop; |
| |
| if not Found then |
| Package_Attributes.Increment_Last; |
| Id := (Value => Package_Attributes.Last); |
| end if; |
| |
| Package_Attributes.Table (Id.Value) := |
| (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, |
| Default => Attributes (Index).Default, |
| 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; |
