953 lines
26 KiB
Ada
953 lines
26 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- 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;
|