1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2010, 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
;
29 with GNAT
.Case_Util
; use GNAT
.Case_Util
;
31 package body Prj
.Attr
is
35 -- Data for predefined attributes and packages
37 -- Names are in lower case and end with '#'
39 -- Package names are preceded by 'P'
41 -- Attribute names are preceded by two or three letters:
43 -- The first letter is one of
45 -- 's' for Single with optional index
47 -- 'l' for List of strings with optional indexes
49 -- The second letter is one of
50 -- 'V' for single variable
51 -- 'A' for associative array
52 -- 'a' for case insensitive associative array
53 -- 'b' for associative array, case insensitive if file names are case
55 -- 'c' same as 'b', with optional index
57 -- The third optional letter is
58 -- 'R' to indicate that the attribute is read-only
59 -- 'O' to indicate that others is allowed as an index for an associative
62 -- End is indicated by two consecutive '#'
64 Initialization_Data
: constant String :=
66 -- project level attributes
75 "SVexternally_built#" &
82 "Lainherit_source_path#" &
83 "LVexcluded_source_dirs#" &
84 "LVignore_source_sub_dirs#" &
89 "LVlocally_removed_files#" &
90 "LVexcluded_source_files#" &
91 "SVsource_list_file#" &
92 "SVexcluded_source_list_file#" &
95 -- Projects (in aggregate projects)
106 "SVlibrary_version#" &
107 "LVlibrary_interface#" &
108 "SVlibrary_auto_init#" &
109 "LVleading_library_options#" &
110 "LVlibrary_options#" &
111 "SVlibrary_src_dir#" &
112 "SVlibrary_ali_dir#" &
114 "SVlibrary_symbol_file#" &
115 "SVlibrary_symbol_policy#" &
116 "SVlibrary_reference_symbol_file#" &
118 -- Configuration - General
120 "SVdefault_language#" &
121 "LVrun_path_option#" &
122 "SVrun_path_origin#" &
123 "SVseparate_run_path_options#" &
124 "Satoolchain_version#" &
125 "Satoolchain_description#" &
126 "Saobject_generated#" &
127 "Saobjects_linked#" &
130 -- Configuration - Libraries
132 "SVlibrary_builder#" &
133 "SVlibrary_support#" &
135 -- Configuration - Archives
137 "LVarchive_builder#" &
138 "LVarchive_builder_append_option#" &
139 "LVarchive_indexer#" &
140 "SVarchive_suffix#" &
141 "LVlibrary_partial_linker#" &
143 -- Configuration - Shared libraries
145 "SVshared_library_prefix#" &
146 "SVshared_library_suffix#" &
147 "SVsymbolic_link_supported#" &
148 "SVlibrary_major_minor_id_supported#" &
149 "SVlibrary_auto_init_supported#" &
150 "LVshared_library_minimum_switches#" &
151 "LVlibrary_version_switches#" &
152 "SVlibrary_install_name_option#" &
153 "Saruntime_library_dir#" &
154 "Saruntime_source_dir#" &
157 -- Some attributes are obsolescent, and renamed in the tree (see
158 -- Prj.Dect.Rename_Obsolescent_Attributes).
161 "Saspecification_suffix#" & -- Always renamed to "spec_suffix" in tree
163 "Saimplementation_suffix#" & -- Always renamed to "body_suffix" in tree
165 "SVseparate_suffix#" &
167 "SVdot_replacement#" &
168 "sAspecification#" & -- Always renamed to "spec" in project tree
170 "sAimplementation#" & -- Always renamed to "body" in project tree
172 "Laspecification_exceptions#" &
173 "Laimplementation_exceptions#" &
178 "Ladefault_switches#" &
180 "SVlocal_configuration_pragmas#" &
181 "Salocal_config_file#" &
183 -- Configuration - Compiling
186 "Larequired_switches#" &
187 "Laleading_required_switches#" &
188 "Latrailing_required_switches#" &
191 "Saobject_file_suffix#" &
192 "Laobject_file_switches#" &
193 "Lamulti_unit_switches#" &
194 "Samulti_unit_object_separator#" &
196 -- Configuration - Mapping files
198 "Lamapping_file_switches#" &
199 "Samapping_spec_suffix#" &
200 "Samapping_body_suffix#" &
202 -- Configuration - Config files
204 "Laconfig_file_switches#" &
205 "Saconfig_body_file_name#" &
206 "Saconfig_body_file_name_index#" &
207 "Saconfig_body_file_name_pattern#" &
208 "Saconfig_spec_file_name#" &
209 "Saconfig_spec_file_name_index#" &
210 "Saconfig_spec_file_name_pattern#" &
211 "Saconfig_file_unique#" &
213 -- Configuration - Dependencies
215 "Ladependency_switches#" &
216 "Ladependency_driver#" &
218 -- Configuration - Search paths
220 "Lainclude_switches#" &
222 "Sainclude_path_file#" &
227 "Ladefault_switches#" &
229 "Lcglobal_compilation_switches#" &
231 "SVexecutable_suffix#" &
232 "SVglobal_configuration_pragmas#" &
233 "Saglobal_config_file#" &
243 "Ladefault_switches#" &
246 -- Configuration - Binding
249 "Larequired_switches#" &
252 "Saobjects_path_file#" &
257 "LVrequired_switches#" &
258 "Ladefault_switches#" &
259 "LcOleading_switches#" &
261 "LVlinker_options#" &
262 "SVmap_file_option#" &
264 -- Configuration - Linking
267 "LVexecutable_switch#" &
268 "SVlib_dir_switch#" &
269 "SVlib_name_switch#" &
271 -- Configuration - Response files
273 "SVmax_command_line_length#" &
274 "SVresponse_file_format#" &
275 "LVresponse_file_switches#" &
277 -- package Cross_Reference
279 "Pcross_reference#" &
280 "Ladefault_switches#" &
286 "Ladefault_switches#" &
289 -- package Pretty_Printer
292 "Ladefault_switches#" &
298 "Ladefault_switches#" &
304 "Ladefault_switches#" &
307 -- package Synchronize
310 "Ladefault_switches#" &
316 "Ladefault_switches#" &
322 "Ladefault_switches#" &
328 "Ladefault_switches#" &
331 "SVcommunication_protocol#" &
332 "Sacompiler_command#" &
333 "SVdebugger_command#" &
336 "SVvcs_file_check#" &
338 "SVdocumentation_dir#" &
347 Initialized
: Boolean := False;
348 -- A flag to avoid multiple initialization
350 Package_Names
: String_List_Access
:= new Strings
.String_List
(1 .. 20);
351 Last_Package_Name
: Natural := 0;
352 -- Package_Names (1 .. Last_Package_Name) contains the list of the known
353 -- package names, coming from the Initialization_Data string or from
354 -- calls to one of the two procedures Register_New_Package.
356 procedure Add_Package_Name
(Name
: String);
357 -- Add a package name in the Package_Name list, extending it, if necessary
359 function Name_Id_Of
(Name
: String) return Name_Id
;
360 -- Returns the Name_Id for Name in lower case
362 ----------------------
363 -- Add_Package_Name --
364 ----------------------
366 procedure Add_Package_Name
(Name
: String) is
368 if Last_Package_Name
= Package_Names
'Last then
370 New_List
: constant Strings
.String_List_Access
:=
371 new Strings
.String_List
(1 .. Package_Names
'Last * 2);
373 New_List
(Package_Names
'Range) := Package_Names
.all;
374 Package_Names
:= New_List
;
378 Last_Package_Name
:= Last_Package_Name
+ 1;
379 Package_Names
(Last_Package_Name
) := new String'(Name);
380 end Add_Package_Name;
382 -----------------------
383 -- Attribute_Kind_Of --
384 -----------------------
386 function Attribute_Kind_Of
387 (Attribute : Attribute_Node_Id) return Attribute_Kind
390 if Attribute = Empty_Attribute then
393 return Attrs.Table (Attribute.Value).Attr_Kind;
395 end Attribute_Kind_Of;
397 -----------------------
398 -- Attribute_Name_Of --
399 -----------------------
401 function Attribute_Name_Of (Attribute : Attribute_Node_Id) return Name_Id is
403 if Attribute = Empty_Attribute then
406 return Attrs.Table (Attribute.Value).Name;
408 end Attribute_Name_Of;
410 --------------------------
411 -- Attribute_Node_Id_Of --
412 --------------------------
414 function Attribute_Node_Id_Of
416 Starting_At : Attribute_Node_Id) return Attribute_Node_Id
418 Id : Attr_Node_Id := Starting_At.Value;
421 while Id /= Empty_Attr
422 and then Attrs.Table (Id).Name /= Name
424 Id := Attrs.Table (Id).Next;
427 return (Value => Id);
428 end Attribute_Node_Id_Of;
434 procedure Initialize is
435 Start : Positive := Initialization_Data'First;
436 Finish : Positive := Start;
437 Current_Package : Pkg_Node_Id := Empty_Pkg;
438 Current_Attribute : Attr_Node_Id := Empty_Attr;
439 Is_An_Attribute : Boolean := False;
440 Var_Kind : Variable_Kind := Undefined;
441 Optional_Index : Boolean := False;
442 Attr_Kind : Attribute_Kind := Single;
443 Package_Name : Name_Id := No_Name;
444 Attribute_Name : Name_Id := No_Name;
445 First_Attribute : Attr_Node_Id := Attr.First_Attribute;
447 Others_Allowed : Boolean;
449 function Attribute_Location return String;
450 -- Returns a string depending if we are in the project level attributes
451 -- or in the attributes of a package.
453 ------------------------
454 -- Attribute_Location --
455 ------------------------
457 function Attribute_Location return String is
459 if Package_Name = No_Name then
460 return "project level attributes";
463 return "attribute of package """ &
464 Get_Name_String (Package_Name) & """";
466 end Attribute_Location;
468 -- Start of processing for Initialize
471 -- Don't allow Initialize action to be repeated
477 -- Make sure the two tables are empty
480 Package_Attributes.Init;
482 while Initialization_Data (Start) /= '#
' loop
483 Is_An_Attribute := True;
484 case Initialization_Data (Start) is
487 -- New allowed package
492 while Initialization_Data (Finish) /= '#
' loop
493 Finish := Finish + 1;
497 Name_Id_Of (Initialization_Data (Start .. Finish - 1));
499 for Index in First_Package .. Package_Attributes.Last loop
500 if Package_Name = Package_Attributes.Table (Index).Name then
501 Osint.Fail ("duplicate name """
502 & Initialization_Data (Start .. Finish - 1)
503 & """ in predefined packages.");
507 Is_An_Attribute := False;
508 Current_Attribute := Empty_Attr;
509 Package_Attributes.Increment_Last;
510 Current_Package := Package_Attributes.Last;
511 Package_Attributes.Table (Current_Package) :=
512 (Name => Package_Name,
514 First_Attribute => Empty_Attr);
517 Add_Package_Name (Get_Name_String (Package_Name));
521 Optional_Index := False;
525 Optional_Index := True;
529 Optional_Index := False;
533 Optional_Index := True;
539 if Is_An_Attribute then
544 case Initialization_Data (Start) is
549 Attr_Kind := Associative_Array;
552 Attr_Kind := Case_Insensitive_Associative_Array;
555 if Osint.File_Names_Case_Sensitive then
556 Attr_Kind := Associative_Array;
558 Attr_Kind := Case_Insensitive_Associative_Array;
562 if Osint.File_Names_Case_Sensitive then
563 Attr_Kind := Optional_Index_Associative_Array;
566 Optional_Index_Case_Insensitive_Associative_Array;
576 Others_Allowed := False;
578 if Initialization_Data (Start) = 'R
' then
582 elsif Initialization_Data (Start) = 'O
' then
583 Others_Allowed := True;
589 while Initialization_Data (Finish) /= '#
' loop
590 Finish := Finish + 1;
594 Name_Id_Of (Initialization_Data (Start .. Finish - 1));
595 Attrs.Increment_Last;
597 if Current_Attribute = Empty_Attr then
598 First_Attribute := Attrs.Last;
600 if Current_Package /= Empty_Pkg then
601 Package_Attributes.Table (Current_Package).First_Attribute
606 -- Check that there are no duplicate attributes
608 for Index in First_Attribute .. Attrs.Last - 1 loop
609 if Attribute_Name = Attrs.Table (Index).Name then
610 Osint.Fail ("duplicate attribute """
611 & Initialization_Data (Start .. Finish - 1)
612 & """ in " & Attribute_Location);
616 Attrs.Table (Current_Attribute).Next :=
620 Current_Attribute := Attrs.Last;
621 Attrs.Table (Current_Attribute) :=
622 (Name => Attribute_Name,
623 Var_Kind => Var_Kind,
624 Optional_Index => Optional_Index,
625 Attr_Kind => Attr_Kind,
626 Read_Only => Read_Only,
627 Others_Allowed => Others_Allowed,
640 function Is_Read_Only (Attribute : Attribute_Node_Id) return Boolean is
642 return Attrs.Table (Attribute.Value).Read_Only;
649 function Name_Id_Of (Name : String) return Name_Id is
652 Add_Str_To_Name_Buffer (Name);
653 To_Lower (Name_Buffer (1 .. Name_Len));
661 function Next_Attribute
662 (After : Attribute_Node_Id) return Attribute_Node_Id
665 if After = Empty_Attribute then
666 return Empty_Attribute;
668 return (Value => Attrs.Table (After.Value).Next);
672 -----------------------
673 -- Optional_Index_Of --
674 -----------------------
676 function Optional_Index_Of (Attribute : Attribute_Node_Id) return Boolean is
678 if Attribute = Empty_Attribute then
681 return Attrs.Table (Attribute.Value).Optional_Index;
683 end Optional_Index_Of;
685 function Others_Allowed_For
686 (Attribute : Attribute_Node_Id) return Boolean
689 if Attribute = Empty_Attribute then
692 return Attrs.Table (Attribute.Value).Others_Allowed;
694 end Others_Allowed_For;
696 -----------------------
697 -- Package_Name_List --
698 -----------------------
700 function Package_Name_List return Strings.String_List is
702 return Package_Names (1 .. Last_Package_Name);
703 end Package_Name_List;
705 ------------------------
706 -- Package_Node_Id_Of --
707 ------------------------
709 function Package_Node_Id_Of (Name : Name_Id) return Package_Node_Id is
711 for Index in Package_Attributes.First .. Package_Attributes.Last loop
712 if Package_Attributes.Table (Index).Name = Name then
713 if Package_Attributes.Table (Index).Known then
714 return (Value => Index);
716 return Unknown_Package;
721 -- If there is no package with this name, return Empty_Package
723 return Empty_Package;
724 end Package_Node_Id_Of;
726 ----------------------------
727 -- Register_New_Attribute --
728 ----------------------------
730 procedure Register_New_Attribute
732 In_Package : Package_Node_Id;
733 Attr_Kind : Defined_Attribute_Kind;
734 Var_Kind : Defined_Variable_Kind;
735 Index_Is_File_Name : Boolean := False;
736 Opt_Index : Boolean := False)
739 First_Attr : Attr_Node_Id := Empty_Attr;
740 Curr_Attr : Attr_Node_Id;
741 Real_Attr_Kind : Attribute_Kind;
744 if Name'Length = 0 then
745 Fail ("cannot register an attribute with no name");
749 if In_Package = Empty_Package then
750 Fail ("attempt to add attribute """
752 & """ to an undefined package");
756 Attr_Name := Name_Id_Of (Name);
759 Package_Attributes.Table (In_Package.Value).First_Attribute;
761 -- Check if attribute name is a duplicate
763 Curr_Attr := First_Attr;
764 while Curr_Attr /= Empty_Attr loop
765 if Attrs.Table (Curr_Attr).Name = Attr_Name then
766 Fail ("duplicate attribute name """
770 (Package_Attributes.Table (In_Package.Value).Name)
775 Curr_Attr := Attrs.Table (Curr_Attr).Next;
778 Real_Attr_Kind := Attr_Kind;
780 -- If Index_Is_File_Name, change the attribute kind if necessary
782 if Index_Is_File_Name and then not Osint.File_Names_Case_Sensitive then
784 when Associative_Array =>
785 Real_Attr_Kind := Case_Insensitive_Associative_Array;
787 when Optional_Index_Associative_Array =>
789 Optional_Index_Case_Insensitive_Associative_Array;
796 -- Add the new attribute
798 Attrs.Increment_Last;
799 Attrs.Table (Attrs.Last) :=
801 Var_Kind => Var_Kind,
802 Optional_Index => Opt_Index,
803 Attr_Kind => Real_Attr_Kind,
805 Others_Allowed => False,
808 Package_Attributes.Table (In_Package.Value).First_Attribute :=
810 end Register_New_Attribute;
812 --------------------------
813 -- Register_New_Package --
814 --------------------------
816 procedure Register_New_Package (Name : String; Id : out Package_Node_Id) is
820 if Name'Length = 0 then
821 Fail ("cannot register a package with no name");
826 Pkg_Name := Name_Id_Of (Name);
828 for Index in Package_Attributes.First .. Package_Attributes.Last loop
829 if Package_Attributes.Table (Index).Name = Pkg_Name then
830 Fail ("cannot register a package with a non unique name"""
838 Package_Attributes.Increment_Last;
839 Id := (Value => Package_Attributes.Last);
840 Package_Attributes.Table (Package_Attributes.Last) :=
843 First_Attribute => Empty_Attr);
845 Add_Package_Name (Get_Name_String (Pkg_Name));
846 end Register_New_Package;
848 procedure Register_New_Package
850 Attributes : Attribute_Data_Array)
854 First_Attr : Attr_Node_Id := Empty_Attr;
855 Curr_Attr : Attr_Node_Id;
856 Attr_Kind : Attribute_Kind;
859 if Name'Length = 0 then
860 Fail ("cannot register a package with no name");
864 Pkg_Name := Name_Id_Of (Name);
866 for Index in Package_Attributes.First .. Package_Attributes.Last loop
867 if Package_Attributes.Table (Index).Name = Pkg_Name then
868 Fail ("cannot register a package with a non unique name"""
875 for Index in Attributes'Range loop
876 Attr_Name := Name_Id_Of (Attributes (Index).Name);
878 Curr_Attr := First_Attr;
879 while Curr_Attr /= Empty_Attr loop
880 if Attrs.Table (Curr_Attr).Name = Attr_Name then
881 Fail ("duplicate attribute name """
882 & Attributes (Index).Name
883 & """ in new package """
889 Curr_Attr := Attrs.Table (Curr_Attr).Next;
892 Attr_Kind := Attributes (Index).Attr_Kind;
894 if Attributes (Index).Index_Is_File_Name
895 and then not Osint.File_Names_Case_Sensitive
898 when Associative_Array =>
899 Attr_Kind := Case_Insensitive_Associative_Array;
901 when Optional_Index_Associative_Array =>
903 Optional_Index_Case_Insensitive_Associative_Array;
910 Attrs.Increment_Last;
911 Attrs.Table (Attrs.Last) :=
913 Var_Kind => Attributes (Index).Var_Kind,
914 Optional_Index => Attributes (Index).Opt_Index,
915 Attr_Kind => Attr_Kind,
917 Others_Allowed => False,
919 First_Attr := Attrs.Last;
922 Package_Attributes.Increment_Last;
923 Package_Attributes.Table (Package_Attributes.Last) :=
926 First_Attribute => First_Attr);
928 Add_Package_Name (Get_Name_String (Pkg_Name));
929 end Register_New_Package;
931 ---------------------------
932 -- Set_Attribute_Kind_Of --
933 ---------------------------
935 procedure Set_Attribute_Kind_Of
936 (Attribute : Attribute_Node_Id;
940 if Attribute /= Empty_Attribute then
941 Attrs.Table (Attribute.Value).Attr_Kind := To;
943 end Set_Attribute_Kind_Of;
945 --------------------------
946 -- Set_Variable_Kind_Of --
947 --------------------------
949 procedure Set_Variable_Kind_Of
950 (Attribute : Attribute_Node_Id;
954 if Attribute /= Empty_Attribute then
955 Attrs.Table (Attribute.Value).Var_Kind := To;
957 end Set_Variable_Kind_Of;
959 ----------------------
960 -- Variable_Kind_Of --
961 ----------------------
963 function Variable_Kind_Of
964 (Attribute : Attribute_Node_Id) return Variable_Kind
967 if Attribute = Empty_Attribute then
970 return Attrs.Table (Attribute.Value).Var_Kind;
972 end Variable_Kind_Of;
974 ------------------------
975 -- First_Attribute_Of --
976 ------------------------
978 function First_Attribute_Of
979 (Pkg : Package_Node_Id) return Attribute_Node_Id
982 if Pkg = Empty_Package then
983 return Empty_Attribute;
986 (Value => Package_Attributes.Table (Pkg.Value).First_Attribute);
988 end First_Attribute_Of;