1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2007, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
27 with Prj
.Com
; use Prj
.Com
;
28 with System
.Case_Util
; use System
.Case_Util
;
30 package body Prj
.Attr
is
32 -- Data for predefined attributes and packages
34 -- Names are in lower case and end with '#'
36 -- Package names are preceded by 'P'
38 -- Attribute names are preceded by two or three letters:
40 -- The first letter is one of
42 -- 's' for Single with optional index
44 -- 'l' for List of strings with optional indexes
46 -- The second letter is one of
47 -- 'V' for single variable
48 -- 'A' for associative array
49 -- 'a' for case insensitive associative array
50 -- 'b' for associative array, case insensitive if file names are case
52 -- 'c' same as 'b', with optional index
54 -- The third optional letter is
55 -- 'R' to indicate that the attribute is read-only
57 -- End is indicated by two consecutive '#'
59 Initialization_Data
: constant String :=
61 -- project level attributes
70 "SVexternally_built#" &
77 "LVexcluded_source_dirs#" &
82 "LVlocally_removed_files#" &
83 "LVexcluded_source_files#" &
84 "SVsource_list_file#" &
91 "SVlibrary_version#" &
92 "LVlibrary_interface#" &
93 "SVlibrary_auto_init#" &
94 "LVlibrary_options#" &
95 "SVlibrary_src_dir#" &
96 "SVlibrary_ali_dir#" &
98 "SVlibrary_symbol_file#" &
99 "SVlibrary_symbol_policy#" &
100 "SVlibrary_reference_symbol_file#" &
102 -- Configuration - General
104 "SVdefault_language#" &
105 "LVrun_path_option#" &
106 "Satoolchain_version#" &
107 "Satoolchain_description#" &
109 -- Configuration - Libraries
111 "SVlibrary_builder#" &
112 "SVlibrary_support#" &
114 -- Configuration - Archives
116 "LVarchive_builder#" &
117 "LVarchive_indexer#" &
118 "SVarchive_suffix#" &
119 "LVlibrary_partial_linker#" &
121 -- Configuration - Shared libraries
123 "SVshared_library_prefix#" &
124 "SVshared_library_suffix#" &
125 "SVsymbolic_link_supported#" &
126 "SVlibrary_major_minor_id_supported#" &
127 "SVlibrary_auto_init_supported#" &
128 "LVshared_library_minimum_switches#" &
129 "LVlibrary_version_switches#" &
134 "Saspecification_suffix#" &
136 "Saimplementation_suffix#" &
138 "SVseparate_suffix#" &
140 "SVdot_replacement#" &
143 "sAimplementation#" &
145 "Laspecification_exceptions#" &
146 "Laimplementation_exceptions#" &
151 "Ladefault_switches#" &
153 "SVlocal_configuration_pragmas#" &
154 "Salocal_config_file#" &
156 -- Configuration - Compiling
159 "Larequired_switches#" &
162 -- Configuration - Mapping files
164 "Lamapping_file_switches#" &
165 "Samapping_spec_suffix#" &
166 "Samapping_body_suffix#" &
168 -- Configuration - Config files
170 "Laconfig_file_switches#" &
171 "Saconfig_body_file_name#" &
172 "Saconfig_spec_file_name#" &
173 "Saconfig_body_file_name_pattern#" &
174 "Saconfig_spec_file_name_pattern#" &
175 "Saconfig_file_unique#" &
177 -- Configuration - Dependencies
179 "Ladependency_switches#" &
180 "Lacompute_dependency#" &
182 -- Configuration - Search paths
184 "Lainclude_switches#" &
186 "Sainclude_path_file#" &
191 "Ladefault_switches#" &
194 "SVexecutable_suffix#" &
195 "SVglobal_configuration_pragmas#" &
196 "Saglobal_config_file#" &
206 "Ladefault_switches#" &
209 -- Configuration - Binding
212 "Larequired_switches#" &
215 "Saobjects_path_file#" &
220 "LVrequired_switches#" &
221 "Ladefault_switches#" &
223 "LVlinker_options#" &
225 -- Configuration - Linking
228 "LVexecutable_switch#" &
229 "SVlib_dir_switch#" &
230 "SVlib_name_switch#" &
232 -- package Cross_Reference
234 "Pcross_reference#" &
235 "Ladefault_switches#" &
241 "Ladefault_switches#" &
244 -- package Pretty_Printer
247 "Ladefault_switches#" &
253 "Ladefault_switches#" &
259 "Ladefault_switches#" &
265 "Ladefault_switches#" &
271 "Ladefault_switches#" &
277 "Ladefault_switches#" &
280 "SVcommunication_protocol#" &
281 "Sacompiler_command#" &
282 "SVdebugger_command#" &
285 "SVvcs_file_check#" &
295 Initialized
: Boolean := False;
296 -- A flag to avoid multiple initialization
298 function Name_Id_Of
(Name
: String) return Name_Id
;
299 -- Returns the Name_Id for Name in lower case
301 -----------------------
302 -- Attribute_Kind_Of --
303 -----------------------
305 function Attribute_Kind_Of
306 (Attribute
: Attribute_Node_Id
) return Attribute_Kind
309 if Attribute
= Empty_Attribute
then
312 return Attrs
.Table
(Attribute
.Value
).Attr_Kind
;
314 end Attribute_Kind_Of
;
316 -----------------------
317 -- Attribute_Name_Of --
318 -----------------------
320 function Attribute_Name_Of
(Attribute
: Attribute_Node_Id
) return Name_Id
is
322 if Attribute
= Empty_Attribute
then
325 return Attrs
.Table
(Attribute
.Value
).Name
;
327 end Attribute_Name_Of
;
329 --------------------------
330 -- Attribute_Node_Id_Of --
331 --------------------------
333 function Attribute_Node_Id_Of
335 Starting_At
: Attribute_Node_Id
) return Attribute_Node_Id
337 Id
: Attr_Node_Id
:= Starting_At
.Value
;
340 while Id
/= Empty_Attr
341 and then Attrs
.Table
(Id
).Name
/= Name
343 Id
:= Attrs
.Table
(Id
).Next
;
346 return (Value
=> Id
);
347 end Attribute_Node_Id_Of
;
353 procedure Initialize
is
354 Start
: Positive := Initialization_Data
'First;
355 Finish
: Positive := Start
;
356 Current_Package
: Pkg_Node_Id
:= Empty_Pkg
;
357 Current_Attribute
: Attr_Node_Id
:= Empty_Attr
;
358 Is_An_Attribute
: Boolean := False;
359 Var_Kind
: Variable_Kind
:= Undefined
;
360 Optional_Index
: Boolean := False;
361 Attr_Kind
: Attribute_Kind
:= Single
;
362 Package_Name
: Name_Id
:= No_Name
;
363 Attribute_Name
: Name_Id
:= No_Name
;
364 First_Attribute
: Attr_Node_Id
:= Attr
.First_Attribute
;
367 function Attribute_Location
return String;
368 -- Returns a string depending if we are in the project level attributes
369 -- or in the attributes of a package.
371 ------------------------
372 -- Attribute_Location --
373 ------------------------
375 function Attribute_Location
return String is
377 if Package_Name
= No_Name
then
378 return "project level attributes";
381 return "attribute of package """ &
382 Get_Name_String
(Package_Name
) & """";
384 end Attribute_Location
;
386 -- Start of processing for Initialize
389 -- Don't allow Initialize action to be repeated
395 -- Make sure the two tables are empty
398 Package_Attributes
.Init
;
400 while Initialization_Data
(Start
) /= '#' loop
401 Is_An_Attribute
:= True;
402 case Initialization_Data
(Start
) is
405 -- New allowed package
410 while Initialization_Data
(Finish
) /= '#' loop
411 Finish
:= Finish
+ 1;
415 Name_Id_Of
(Initialization_Data
(Start
.. Finish
- 1));
417 for Index
in First_Package
.. Package_Attributes
.Last
loop
418 if Package_Name
= Package_Attributes
.Table
(Index
).Name
then
419 Osint
.Fail
("duplicate name """,
420 Initialization_Data
(Start
.. Finish
- 1),
421 """ in predefined packages.");
425 Is_An_Attribute
:= False;
426 Current_Attribute
:= Empty_Attr
;
427 Package_Attributes
.Increment_Last
;
428 Current_Package
:= Package_Attributes
.Last
;
429 Package_Attributes
.Table
(Current_Package
) :=
430 (Name
=> Package_Name
,
432 First_Attribute
=> Empty_Attr
);
437 Optional_Index
:= False;
441 Optional_Index
:= True;
445 Optional_Index
:= False;
449 Optional_Index
:= True;
455 if Is_An_Attribute
then
460 case Initialization_Data
(Start
) is
465 Attr_Kind
:= Associative_Array
;
468 Attr_Kind
:= Case_Insensitive_Associative_Array
;
471 if Osint
.File_Names_Case_Sensitive
then
472 Attr_Kind
:= Associative_Array
;
474 Attr_Kind
:= Case_Insensitive_Associative_Array
;
478 if Osint
.File_Names_Case_Sensitive
then
479 Attr_Kind
:= Optional_Index_Associative_Array
;
482 Optional_Index_Case_Insensitive_Associative_Array
;
491 if Initialization_Data
(Start
) = 'R' then
501 while Initialization_Data
(Finish
) /= '#' loop
502 Finish
:= Finish
+ 1;
506 Name_Id_Of
(Initialization_Data
(Start
.. Finish
- 1));
507 Attrs
.Increment_Last
;
509 if Current_Attribute
= Empty_Attr
then
510 First_Attribute
:= Attrs
.Last
;
512 if Current_Package
/= Empty_Pkg
then
513 Package_Attributes
.Table
(Current_Package
).First_Attribute
518 -- Check that there are no duplicate attributes
520 for Index
in First_Attribute
.. Attrs
.Last
- 1 loop
521 if Attribute_Name
= Attrs
.Table
(Index
).Name
then
522 Osint
.Fail
("duplicate attribute """,
523 Initialization_Data
(Start
.. Finish
- 1),
524 """ in " & Attribute_Location
);
528 Attrs
.Table
(Current_Attribute
).Next
:=
532 Current_Attribute
:= Attrs
.Last
;
533 Attrs
.Table
(Current_Attribute
) :=
534 (Name
=> Attribute_Name
,
535 Var_Kind
=> Var_Kind
,
536 Optional_Index
=> Optional_Index
,
537 Attr_Kind
=> Attr_Kind
,
538 Read_Only
=> Read_Only
,
551 function Is_Read_Only
(Attribute
: Attribute_Node_Id
) return Boolean is
553 return Attrs
.Table
(Attribute
.Value
).Read_Only
;
560 function Name_Id_Of
(Name
: String) return Name_Id
is
563 Add_Str_To_Name_Buffer
(Name
);
564 To_Lower
(Name_Buffer
(1 .. Name_Len
));
572 function Next_Attribute
573 (After
: Attribute_Node_Id
) return Attribute_Node_Id
576 if After
= Empty_Attribute
then
577 return Empty_Attribute
;
579 return (Value
=> Attrs
.Table
(After
.Value
).Next
);
583 -----------------------
584 -- Optional_Index_Of --
585 -----------------------
587 function Optional_Index_Of
(Attribute
: Attribute_Node_Id
) return Boolean is
589 if Attribute
= Empty_Attribute
then
592 return Attrs
.Table
(Attribute
.Value
).Optional_Index
;
594 end Optional_Index_Of
;
596 ------------------------
597 -- Package_Node_Id_Of --
598 ------------------------
600 function Package_Node_Id_Of
(Name
: Name_Id
) return Package_Node_Id
is
602 for Index
in Package_Attributes
.First
.. Package_Attributes
.Last
loop
603 if Package_Attributes
.Table
(Index
).Name
= Name
then
604 return (Value
=> Index
);
608 -- If there is no package with this name, return Empty_Package
610 return Empty_Package
;
611 end Package_Node_Id_Of
;
613 ----------------------------
614 -- Register_New_Attribute --
615 ----------------------------
617 procedure Register_New_Attribute
619 In_Package
: Package_Node_Id
;
620 Attr_Kind
: Defined_Attribute_Kind
;
621 Var_Kind
: Defined_Variable_Kind
;
622 Index_Is_File_Name
: Boolean := False;
623 Opt_Index
: Boolean := False)
626 First_Attr
: Attr_Node_Id
:= Empty_Attr
;
627 Curr_Attr
: Attr_Node_Id
;
628 Real_Attr_Kind
: Attribute_Kind
;
631 if Name
'Length = 0 then
632 Fail
("cannot register an attribute with no name");
636 if In_Package
= Empty_Package
then
637 Fail
("attempt to add attribute """, Name
,
638 """ to an undefined package");
642 Attr_Name
:= Name_Id_Of
(Name
);
645 Package_Attributes
.Table
(In_Package
.Value
).First_Attribute
;
647 -- Check if attribute name is a duplicate
649 Curr_Attr
:= First_Attr
;
650 while Curr_Attr
/= Empty_Attr
loop
651 if Attrs
.Table
(Curr_Attr
).Name
= Attr_Name
then
652 Fail
("duplicate attribute name """, Name
,
655 (Package_Attributes
.Table
(In_Package
.Value
).Name
) &
660 Curr_Attr
:= Attrs
.Table
(Curr_Attr
).Next
;
663 Real_Attr_Kind
:= Attr_Kind
;
665 -- If Index_Is_File_Name, change the attribute kind if necessary
667 if Index_Is_File_Name
and then not Osint
.File_Names_Case_Sensitive
then
669 when Associative_Array
=>
670 Real_Attr_Kind
:= Case_Insensitive_Associative_Array
;
672 when Optional_Index_Associative_Array
=>
674 Optional_Index_Case_Insensitive_Associative_Array
;
681 -- Add the new attribute
683 Attrs
.Increment_Last
;
684 Attrs
.Table
(Attrs
.Last
) :=
686 Var_Kind
=> Var_Kind
,
687 Optional_Index
=> Opt_Index
,
688 Attr_Kind
=> Real_Attr_Kind
,
691 Package_Attributes
.Table
(In_Package
.Value
).First_Attribute
:=
693 end Register_New_Attribute
;
695 --------------------------
696 -- Register_New_Package --
697 --------------------------
699 procedure Register_New_Package
(Name
: String; Id
: out Package_Node_Id
) is
703 if Name
'Length = 0 then
704 Fail
("cannot register a package with no name");
709 Pkg_Name
:= Name_Id_Of
(Name
);
711 for Index
in Package_Attributes
.First
.. Package_Attributes
.Last
loop
712 if Package_Attributes
.Table
(Index
).Name
= Pkg_Name
then
713 Fail
("cannot register a package with a non unique name""",
720 Package_Attributes
.Increment_Last
;
721 Id
:= (Value
=> Package_Attributes
.Last
);
722 Package_Attributes
.Table
(Package_Attributes
.Last
) :=
725 First_Attribute
=> Empty_Attr
);
726 end Register_New_Package
;
728 procedure Register_New_Package
730 Attributes
: Attribute_Data_Array
)
734 First_Attr
: Attr_Node_Id
:= Empty_Attr
;
735 Curr_Attr
: Attr_Node_Id
;
736 Attr_Kind
: Attribute_Kind
;
739 if Name
'Length = 0 then
740 Fail
("cannot register a package with no name");
744 Pkg_Name
:= Name_Id_Of
(Name
);
746 for Index
in Package_Attributes
.First
.. Package_Attributes
.Last
loop
747 if Package_Attributes
.Table
(Index
).Name
= Pkg_Name
then
748 Fail
("cannot register a package with a non unique name""",
754 for Index
in Attributes
'Range loop
755 Attr_Name
:= Name_Id_Of
(Attributes
(Index
).Name
);
757 Curr_Attr
:= First_Attr
;
758 while Curr_Attr
/= Empty_Attr
loop
759 if Attrs
.Table
(Curr_Attr
).Name
= Attr_Name
then
760 Fail
("duplicate attribute name """, Attributes
(Index
).Name
,
761 """ in new package """ & Name
& """");
765 Curr_Attr
:= Attrs
.Table
(Curr_Attr
).Next
;
768 Attr_Kind
:= Attributes
(Index
).Attr_Kind
;
770 if Attributes
(Index
).Index_Is_File_Name
771 and then not Osint
.File_Names_Case_Sensitive
774 when Associative_Array
=>
775 Attr_Kind
:= Case_Insensitive_Associative_Array
;
777 when Optional_Index_Associative_Array
=>
779 Optional_Index_Case_Insensitive_Associative_Array
;
786 Attrs
.Increment_Last
;
787 Attrs
.Table
(Attrs
.Last
) :=
789 Var_Kind
=> Attributes
(Index
).Var_Kind
,
790 Optional_Index
=> Attributes
(Index
).Opt_Index
,
791 Attr_Kind
=> Attr_Kind
,
794 First_Attr
:= Attrs
.Last
;
797 Package_Attributes
.Increment_Last
;
798 Package_Attributes
.Table
(Package_Attributes
.Last
) :=
801 First_Attribute
=> First_Attr
);
802 end Register_New_Package
;
804 ---------------------------
805 -- Set_Attribute_Kind_Of --
806 ---------------------------
808 procedure Set_Attribute_Kind_Of
809 (Attribute
: Attribute_Node_Id
;
813 if Attribute
/= Empty_Attribute
then
814 Attrs
.Table
(Attribute
.Value
).Attr_Kind
:= To
;
816 end Set_Attribute_Kind_Of
;
818 --------------------------
819 -- Set_Variable_Kind_Of --
820 --------------------------
822 procedure Set_Variable_Kind_Of
823 (Attribute
: Attribute_Node_Id
;
827 if Attribute
/= Empty_Attribute
then
828 Attrs
.Table
(Attribute
.Value
).Var_Kind
:= To
;
830 end Set_Variable_Kind_Of
;
832 ----------------------
833 -- Variable_Kind_Of --
834 ----------------------
836 function Variable_Kind_Of
837 (Attribute
: Attribute_Node_Id
) return Variable_Kind
840 if Attribute
= Empty_Attribute
then
843 return Attrs
.Table
(Attribute
.Value
).Var_Kind
;
845 end Variable_Kind_Of
;
847 ------------------------
848 -- First_Attribute_Of --
849 ------------------------
851 function First_Attribute_Of
852 (Pkg
: Package_Node_Id
) return Attribute_Node_Id
855 if Pkg
= Empty_Package
then
856 return Empty_Attribute
;
859 (Value
=> Package_Attributes
.Table
(Pkg
.Value
).First_Attribute
);
861 end First_Attribute_Of
;