with Namet; use Namet;
with Osint;
with Prj.Com; use Prj.Com;
with Table;
with System.Case_Util; use System.Case_Util;
package body Prj.Attr is
Initialization_Data : constant String :=
"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#" &
"LVada_roots#" &
"SVexternally_built#" &
"Pnaming#" &
"Saspecification_suffix#" &
"Saspec_suffix#" &
"Saimplementation_suffix#" &
"Sabody_suffix#" &
"SVseparate_suffix#" &
"SVcasing#" &
"SVdot_replacement#" &
"sAspecification#" &
"sAspec#" &
"sAimplementation#" &
"sAbody#" &
"Laspecification_exceptions#" &
"Laimplementation_exceptions#" &
"Pcompiler#" &
"Ladefault_switches#" &
"Lcswitches#" &
"SVlocal_configuration_pragmas#" &
"Pbuilder#" &
"Ladefault_switches#" &
"Lcswitches#" &
"Scexecutable#" &
"SVexecutable_suffix#" &
"SVglobal_configuration_pragmas#" &
"Pgnatls#" &
"LVswitches#" &
"Pbinder#" &
"Ladefault_switches#" &
"Lcswitches#" &
"Plinker#" &
"Ladefault_switches#" &
"Lcswitches#" &
"LVlinker_options#" &
"Pcross_reference#" &
"Ladefault_switches#" &
"Lbswitches#" &
"Pfinder#" &
"Ladefault_switches#" &
"Lbswitches#" &
"Ppretty_printer#" &
"Ladefault_switches#" &
"Lbswitches#" &
"Pgnatstub#" &
"Ladefault_switches#" &
"Lbswitches#" &
"Peliminate#" &
"Ladefault_switches#" &
"Lbswitches#" &
"Pmetrics#" &
"Ladefault_switches#" &
"Lbswitches#" &
"Pide#" &
"Ladefault_switches#" &
"SVremote_host#" &
"SVprogram_host#" &
"SVcommunication_protocol#" &
"Sacompiler_command#" &
"SVdebugger_command#" &
"SVgnatlist#" &
"SVvcs_kind#" &
"SVvcs_file_check#" &
"SVvcs_log_check#" &
"Planguage_processing#" &
"Lacompiler_driver#" &
"Sacompiler_kind#" &
"Ladependency_option#" &
"Lacompute_dependency#" &
"Lainclude_option#" &
"Sabinder_driver#" &
"SVdefault_linker#" &
"#";
Initialized : Boolean := False;
function Name_Id_Of (Name : String) return Name_Id;
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;
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;
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;
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;
function Attribute_Location return String;
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;
begin
if Initialized then
return;
end if;
Attrs.Init;
Package_Attributes.Init;
while Initialization_Data (Start) /= '#' loop
Is_An_Attribute := True;
case Initialization_Data (Start) is
when 'P' =>
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;
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
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;
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
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,
Next => Empty_Attr);
Start := Finish + 1;
end if;
end loop;
Initialized := True;
end Initialize;
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;
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;
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 Package_Node_Id_Of (Name : Name_Id) return Package_Node_Id is
begin
for Index in Package_Attributes.First .. Package_Attributes.Last loop
if Package_Attributes.Table (Index).Name = Name then
return (Value => Index);
end if;
end loop;
return Empty_Package;
end Package_Node_Id_Of;
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;
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 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;
Attrs.Increment_Last;
Attrs.Table (Attrs.Last) :=
(Name => Attr_Name,
Var_Kind => Var_Kind,
Optional_Index => Opt_Index,
Attr_Kind => Real_Attr_Kind,
Next => First_Attr);
Package_Attributes.Table (In_Package.Value).First_Attribute :=
Attrs.Last;
end Register_New_Attribute;
procedure Register_New_Package (Name : String; Id : out Package_Node_Id) is
Pkg_Name : Name_Id;
begin
if Name'Length = 0 then
Fail ("cannot register a package with no name");
Id := Empty_Package;
return;
end if;
Pkg_Name := Name_Id_Of (Name);
for Index in Package_Attributes.First .. Package_Attributes.Last loop
if Package_Attributes.Table (Index).Name = Pkg_Name then
Fail ("cannot register a package with a non unique name""",
Name, """");
Id := Empty_Package;
return;
end if;
end loop;
Package_Attributes.Increment_Last;
Id := (Value => Package_Attributes.Last);
Package_Attributes.Table (Package_Attributes.Last) :=
(Name => Pkg_Name, Known => True, First_Attribute => Empty_Attr);
end Register_New_Package;
procedure Register_New_Package
(Name : String;
Attributes : Attribute_Data_Array)
is
Pkg_Name : Name_Id;
Attr_Name : Name_Id;
First_Attr : Attr_Node_Id := Empty_Attr;
Curr_Attr : Attr_Node_Id;
Attr_Kind : Attribute_Kind;
begin
if Name'Length = 0 then
Fail ("cannot register a package with no name");
raise Project_Error;
end if;
Pkg_Name := Name_Id_Of (Name);
for Index in Package_Attributes.First .. Package_Attributes.Last loop
if Package_Attributes.Table (Index).Name = Pkg_Name then
Fail ("cannot register a package with a non unique name""",
Name, """");
raise Project_Error;
end if;
end loop;
for Index in Attributes'Range loop
Attr_Name := Name_Id_Of (Attributes (Index).Name);
Curr_Attr := First_Attr;
while Curr_Attr /= Empty_Attr loop
if Attrs.Table (Curr_Attr).Name = Attr_Name then
Fail ("duplicate attribute name """, Attributes (Index).Name,
""" in new package """ & Name & """");
raise Project_Error;
end if;
Curr_Attr := Attrs.Table (Curr_Attr).Next;
end loop;
Attr_Kind := Attributes (Index).Attr_Kind;
if Attributes (Index).Index_Is_File_Name
and then not Osint.File_Names_Case_Sensitive
then
case Attr_Kind is
when Associative_Array =>
Attr_Kind := Case_Insensitive_Associative_Array;
when Optional_Index_Associative_Array =>
Attr_Kind :=
Optional_Index_Case_Insensitive_Associative_Array;
when others =>
null;
end case;
end if;
Attrs.Increment_Last;
Attrs.Table (Attrs.Last) :=
(Name => Attr_Name,
Var_Kind => Attributes (Index).Var_Kind,
Optional_Index => Attributes (Index).Opt_Index,
Attr_Kind => Attr_Kind,
Next => First_Attr);
First_Attr := Attrs.Last;
end loop;
Package_Attributes.Increment_Last;
Package_Attributes.Table (Package_Attributes.Last) :=
(Name => Pkg_Name, Known => True, First_Attribute => First_Attr);
end Register_New_Package;
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;
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;
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;
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;