1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2014, 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 '#' or 'D'
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' the attribute is read-only
59 -- 'O' others is allowed as an index for an associative array
61 -- If the character after the name in lower case letter is a 'D' (for
62 -- default), then 'D' must be followed by an enumeration value of type
63 -- Attribute_Default_Value, followed by a '#'.
66 -- "SVobject_dirDdot_value#"
68 -- End is indicated by two consecutive '#'.
70 Initialization_Data
: constant String :=
72 -- project level attributes
81 "SVexternally_built#" &
85 "SVobject_dirDdot_value#" &
86 "SVexec_dirDobject_dir_value#" &
87 "LVsource_dirsDdot_value#" &
88 "Lainherit_source_path#" &
89 "LVexcluded_source_dirs#" &
90 "LVignore_source_sub_dirs#" &
95 "LVlocally_removed_files#" &
96 "LVexcluded_source_files#" &
97 "SVsource_list_file#" &
98 "SVexcluded_source_list_file#" &
101 -- Projects (in aggregate projects)
112 "SVlibrary_version#" &
113 "LVlibrary_interface#" &
114 "SVlibrary_standalone#" &
115 "LVlibrary_encapsulated_options#" &
116 "SVlibrary_encapsulated_supported#" &
117 "SVlibrary_auto_init#" &
118 "LVleading_library_options#" &
119 "LVlibrary_options#" &
120 "Lalibrary_rpath_options#" &
121 "SVlibrary_src_dir#" &
122 "SVlibrary_ali_dir#" &
124 "SVlibrary_symbol_file#" &
125 "SVlibrary_symbol_policy#" &
126 "SVlibrary_reference_symbol_file#" &
128 -- Configuration - General
130 "SVdefault_language#" &
131 "LVrun_path_option#" &
132 "SVrun_path_origin#" &
133 "SVseparate_run_path_options#" &
134 "Satoolchain_version#" &
135 "Satoolchain_description#" &
136 "Saobject_generated#" &
137 "Saobjects_linked#" &
138 "SVtargetDtarget_value#" &
140 -- Configuration - Libraries
142 "SVlibrary_builder#" &
143 "SVlibrary_support#" &
145 -- Configuration - Archives
147 "LVarchive_builder#" &
148 "LVarchive_builder_append_option#" &
149 "LVarchive_indexer#" &
150 "SVarchive_suffix#" &
151 "LVlibrary_partial_linker#" &
153 -- Configuration - Shared libraries
155 "SVshared_library_prefix#" &
156 "SVshared_library_suffix#" &
157 "SVsymbolic_link_supported#" &
158 "SVlibrary_major_minor_id_supported#" &
159 "SVlibrary_auto_init_supported#" &
160 "LVshared_library_minimum_switches#" &
161 "LVlibrary_version_switches#" &
162 "SVlibrary_install_name_option#" &
163 "Saruntime_library_dir#" &
164 "Saruntime_source_dir#" &
167 -- Some attributes are obsolescent, and renamed in the tree (see
168 -- Prj.Dect.Rename_Obsolescent_Attributes).
171 "Saspecification_suffix#" & -- Always renamed to "spec_suffix" in tree
173 "Saimplementation_suffix#" & -- Always renamed to "body_suffix" in tree
175 "SVseparate_suffix#" &
177 "SVdot_replacement#" &
178 "saspecification#" & -- Always renamed to "spec" in project tree
180 "saimplementation#" & -- Always renamed to "body" in project tree
182 "Laspecification_exceptions#" &
183 "Laimplementation_exceptions#" &
188 "Ladefault_switches#" &
190 "SVlocal_configuration_pragmas#" &
191 "Salocal_config_file#" &
193 -- Configuration - Compiling
197 "Sadependency_kind#" &
198 "Larequired_switches#" &
199 "Laleading_required_switches#" &
200 "Latrailing_required_switches#" &
203 "Lasource_file_switches#" &
204 "Saobject_file_suffix#" &
205 "Laobject_file_switches#" &
206 "Lamulti_unit_switches#" &
207 "Samulti_unit_object_separator#" &
209 -- Configuration - Mapping files
211 "Lamapping_file_switches#" &
212 "Samapping_spec_suffix#" &
213 "Samapping_body_suffix#" &
215 -- Configuration - Config files
217 "Laconfig_file_switches#" &
218 "Saconfig_body_file_name#" &
219 "Saconfig_body_file_name_index#" &
220 "Saconfig_body_file_name_pattern#" &
221 "Saconfig_spec_file_name#" &
222 "Saconfig_spec_file_name_index#" &
223 "Saconfig_spec_file_name_pattern#" &
224 "Saconfig_file_unique#" &
226 -- Configuration - Dependencies
228 "Ladependency_switches#" &
229 "Ladependency_driver#" &
231 -- Configuration - Search paths
233 "Lainclude_switches#" &
235 "Sainclude_path_file#" &
236 "Laobject_path_switches#" &
241 "Ladefault_switches#" &
243 "Lcglobal_compilation_switches#" &
245 "SVexecutable_suffix#" &
246 "SVglobal_configuration_pragmas#" &
247 "Saglobal_config_file#" &
257 "Ladefault_switches#" &
260 -- Configuration - Binding
263 "Larequired_switches#" &
266 "Saobjects_path_file#" &
271 "LVrequired_switches#" &
272 "Ladefault_switches#" &
273 "LcOleading_switches#" &
275 "LcOtrailing_switches#" &
276 "LVlinker_options#" &
277 "SVmap_file_option#" &
279 -- Configuration - Linking
282 "LVexecutable_switch#" &
283 "SVlib_dir_switch#" &
284 "SVlib_name_switch#" &
286 -- Configuration - Response files
288 "SVmax_command_line_length#" &
289 "SVresponse_file_format#" &
290 "LVresponse_file_switches#" &
296 "Lasource_artifact_extensions#" &
297 "Laobject_artifact_extensions#" &
298 "LVartifacts_in_exec_dir#" &
299 "LVartifacts_in_object_dir#" &
301 -- package Cross_Reference
303 "Pcross_reference#" &
304 "Ladefault_switches#" &
310 "Ladefault_switches#" &
313 -- package Pretty_Printer
316 "Ladefault_switches#" &
322 "Ladefault_switches#" &
328 "Ladefault_switches#" &
331 -- package Synchronize
334 "Ladefault_switches#" &
340 "Ladefault_switches#" &
346 "Ladefault_switches#" &
352 "Ladefault_switches#" &
355 "SVcommunication_protocol#" &
356 "Sacompiler_command#" &
357 "SVdebugger_command#" &
360 "SVvcs_file_check#" &
362 "SVdocumentation_dir#" &
368 "SVsources_subdir#" &
371 "SVproject_subdir#" &
379 "LVexcluded_patterns#" &
380 "LVincluded_patterns#" &
381 "LVincluded_artifact_patterns#" &
390 Initialized
: Boolean := False;
391 -- A flag to avoid multiple initialization
393 Package_Names
: String_List_Access
:= new Strings
.String_List
(1 .. 20);
394 Last_Package_Name
: Natural := 0;
395 -- Package_Names (1 .. Last_Package_Name) contains the list of the known
396 -- package names, coming from the Initialization_Data string or from
397 -- calls to one of the two procedures Register_New_Package.
399 procedure Add_Package_Name
(Name
: String);
400 -- Add a package name in the Package_Name list, extending it, if necessary
402 function Name_Id_Of
(Name
: String) return Name_Id
;
403 -- Returns the Name_Id for Name in lower case
405 ----------------------
406 -- Add_Package_Name --
407 ----------------------
409 procedure Add_Package_Name
(Name
: String) is
411 if Last_Package_Name
= Package_Names
'Last then
413 New_List
: constant Strings
.String_List_Access
:=
414 new Strings
.String_List
(1 .. Package_Names
'Last * 2);
416 New_List
(Package_Names
'Range) := Package_Names
.all;
417 Package_Names
:= New_List
;
421 Last_Package_Name
:= Last_Package_Name
+ 1;
422 Package_Names
(Last_Package_Name
) := new String'(Name);
423 end Add_Package_Name;
425 --------------------------
426 -- Attribute_Default_Of --
427 --------------------------
429 function Attribute_Default_Of
430 (Attribute : Attribute_Node_Id) return Attribute_Default_Value
433 if Attribute = Empty_Attribute then
436 return Attrs.Table (Attribute.Value).Default;
438 end Attribute_Default_Of;
440 -----------------------
441 -- Attribute_Kind_Of --
442 -----------------------
444 function Attribute_Kind_Of
445 (Attribute : Attribute_Node_Id) return Attribute_Kind
448 if Attribute = Empty_Attribute then
451 return Attrs.Table (Attribute.Value).Attr_Kind;
453 end Attribute_Kind_Of;
455 -----------------------
456 -- Attribute_Name_Of --
457 -----------------------
459 function Attribute_Name_Of (Attribute : Attribute_Node_Id) return Name_Id is
461 if Attribute = Empty_Attribute then
464 return Attrs.Table (Attribute.Value).Name;
466 end Attribute_Name_Of;
468 --------------------------
469 -- Attribute_Node_Id_Of --
470 --------------------------
472 function Attribute_Node_Id_Of
474 Starting_At : Attribute_Node_Id) return Attribute_Node_Id
476 Id : Attr_Node_Id := Starting_At.Value;
479 while Id /= Empty_Attr
480 and then Attrs.Table (Id).Name /= Name
482 Id := Attrs.Table (Id).Next;
485 return (Value => Id);
486 end Attribute_Node_Id_Of;
492 procedure Initialize is
493 Start : Positive := Initialization_Data'First;
494 Finish : Positive := Start;
495 Current_Package : Pkg_Node_Id := Empty_Pkg;
496 Current_Attribute : Attr_Node_Id := Empty_Attr;
497 Is_An_Attribute : Boolean := False;
498 Var_Kind : Variable_Kind := Undefined;
499 Optional_Index : Boolean := False;
500 Attr_Kind : Attribute_Kind := Single;
501 Package_Name : Name_Id := No_Name;
502 Attribute_Name : Name_Id := No_Name;
503 First_Attribute : Attr_Node_Id := Attr.First_Attribute;
505 Others_Allowed : Boolean;
506 Default : Attribute_Default_Value;
508 function Attribute_Location return String;
509 -- Returns a string depending if we are in the project level attributes
510 -- or in the attributes of a package.
512 ------------------------
513 -- Attribute_Location --
514 ------------------------
516 function Attribute_Location return String is
518 if Package_Name = No_Name then
519 return "project level attributes";
522 return "attribute of package """ &
523 Get_Name_String (Package_Name) & """";
525 end Attribute_Location;
527 -- Start of processing for Initialize
530 -- Don't allow Initialize action to be repeated
536 -- Make sure the two tables are empty
539 Package_Attributes.Init;
541 while Initialization_Data (Start) /= '#
' loop
542 Is_An_Attribute := True;
543 case Initialization_Data (Start) is
546 -- New allowed package
551 while Initialization_Data (Finish) /= '#
' loop
552 Finish := Finish + 1;
556 Name_Id_Of (Initialization_Data (Start .. Finish - 1));
558 for Index in First_Package .. Package_Attributes.Last loop
559 if Package_Name = Package_Attributes.Table (Index).Name then
560 Osint.Fail ("duplicate name """
561 & Initialization_Data (Start .. Finish - 1)
562 & """ in predefined packages.");
566 Is_An_Attribute := False;
567 Current_Attribute := Empty_Attr;
568 Package_Attributes.Increment_Last;
569 Current_Package := Package_Attributes.Last;
570 Package_Attributes.Table (Current_Package) :=
571 (Name => Package_Name,
573 First_Attribute => Empty_Attr);
576 Add_Package_Name (Get_Name_String (Package_Name));
580 Optional_Index := False;
584 Optional_Index := True;
588 Optional_Index := False;
592 Optional_Index := True;
598 if Is_An_Attribute then
603 case Initialization_Data (Start) is
608 Attr_Kind := Associative_Array;
611 Attr_Kind := Case_Insensitive_Associative_Array;
614 if Osint.File_Names_Case_Sensitive then
615 Attr_Kind := Associative_Array;
617 Attr_Kind := Case_Insensitive_Associative_Array;
621 if Osint.File_Names_Case_Sensitive then
622 Attr_Kind := Optional_Index_Associative_Array;
625 Optional_Index_Case_Insensitive_Associative_Array;
635 Others_Allowed := False;
636 Default := Empty_Value;
638 if Initialization_Data (Start) = 'R
' then
640 Default := Read_Only_Value;
643 elsif Initialization_Data (Start) = 'O
' then
644 Others_Allowed := True;
650 while Initialization_Data (Finish) /= '#
'
652 Initialization_Data (Finish) /= 'D
'
654 Finish := Finish + 1;
658 Name_Id_Of (Initialization_Data (Start .. Finish - 1));
660 if Initialization_Data (Finish) = 'D
' then
664 while Initialization_Data (Finish) /= '#
' loop
665 Finish := Finish + 1;
669 Default_Name : constant String :=
670 Initialization_Data (Start .. Finish - 1);
671 pragma Unsuppress (All_Checks);
673 Default := Attribute_Default_Value'Value (Default_Name);
675 when Constraint_Error =>
677 ("illegal default value """ &
679 """ for attribute " &
680 Get_Name_String (Attribute_Name));
684 Attrs.Increment_Last;
686 if Current_Attribute = Empty_Attr then
687 First_Attribute := Attrs.Last;
689 if Current_Package /= Empty_Pkg then
690 Package_Attributes.Table (Current_Package).First_Attribute
695 -- Check that there are no duplicate attributes
697 for Index in First_Attribute .. Attrs.Last - 1 loop
698 if Attribute_Name = Attrs.Table (Index).Name then
699 Osint.Fail ("duplicate attribute """
700 & Initialization_Data (Start .. Finish - 1)
701 & """ in " & Attribute_Location);
705 Attrs.Table (Current_Attribute).Next :=
709 Current_Attribute := Attrs.Last;
710 Attrs.Table (Current_Attribute) :=
711 (Name => Attribute_Name,
712 Var_Kind => Var_Kind,
713 Optional_Index => Optional_Index,
714 Attr_Kind => Attr_Kind,
715 Read_Only => Read_Only,
716 Others_Allowed => Others_Allowed,
730 function Is_Read_Only (Attribute : Attribute_Node_Id) return Boolean is
732 return Attrs.Table (Attribute.Value).Read_Only;
739 function Name_Id_Of (Name : String) return Name_Id is
742 Add_Str_To_Name_Buffer (Name);
743 To_Lower (Name_Buffer (1 .. Name_Len));
751 function Next_Attribute
752 (After : Attribute_Node_Id) return Attribute_Node_Id
755 if After = Empty_Attribute then
756 return Empty_Attribute;
758 return (Value => Attrs.Table (After.Value).Next);
762 -----------------------
763 -- Optional_Index_Of --
764 -----------------------
766 function Optional_Index_Of (Attribute : Attribute_Node_Id) return Boolean is
768 if Attribute = Empty_Attribute then
771 return Attrs.Table (Attribute.Value).Optional_Index;
773 end Optional_Index_Of;
775 function Others_Allowed_For
776 (Attribute : Attribute_Node_Id) return Boolean
779 if Attribute = Empty_Attribute then
782 return Attrs.Table (Attribute.Value).Others_Allowed;
784 end Others_Allowed_For;
786 -----------------------
787 -- Package_Name_List --
788 -----------------------
790 function Package_Name_List return Strings.String_List is
792 return Package_Names (1 .. Last_Package_Name);
793 end Package_Name_List;
795 ------------------------
796 -- Package_Node_Id_Of --
797 ------------------------
799 function Package_Node_Id_Of (Name : Name_Id) return Package_Node_Id is
801 for Index in Package_Attributes.First .. Package_Attributes.Last loop
802 if Package_Attributes.Table (Index).Name = Name then
803 if Package_Attributes.Table (Index).Known then
804 return (Value => Index);
806 return Unknown_Package;
811 -- If there is no package with this name, return Empty_Package
813 return Empty_Package;
814 end Package_Node_Id_Of;
816 ----------------------------
817 -- Register_New_Attribute --
818 ----------------------------
820 procedure Register_New_Attribute
822 In_Package : Package_Node_Id;
823 Attr_Kind : Defined_Attribute_Kind;
824 Var_Kind : Defined_Variable_Kind;
825 Index_Is_File_Name : Boolean := False;
826 Opt_Index : Boolean := False;
827 Default : Attribute_Default_Value := Empty_Value)
830 First_Attr : Attr_Node_Id := Empty_Attr;
831 Curr_Attr : Attr_Node_Id;
832 Real_Attr_Kind : Attribute_Kind;
835 if Name'Length = 0 then
836 Fail ("cannot register an attribute with no name");
840 if In_Package = Empty_Package then
841 Fail ("attempt to add attribute """
843 & """ to an undefined package");
847 Attr_Name := Name_Id_Of (Name);
850 Package_Attributes.Table (In_Package.Value).First_Attribute;
852 -- Check if attribute name is a duplicate
854 Curr_Attr := First_Attr;
855 while Curr_Attr /= Empty_Attr loop
856 if Attrs.Table (Curr_Attr).Name = Attr_Name then
857 Fail ("duplicate attribute name """
861 (Package_Attributes.Table (In_Package.Value).Name)
866 Curr_Attr := Attrs.Table (Curr_Attr).Next;
869 Real_Attr_Kind := Attr_Kind;
871 -- If Index_Is_File_Name, change the attribute kind if necessary
873 if Index_Is_File_Name and then not Osint.File_Names_Case_Sensitive then
875 when Associative_Array =>
876 Real_Attr_Kind := Case_Insensitive_Associative_Array;
878 when Optional_Index_Associative_Array =>
880 Optional_Index_Case_Insensitive_Associative_Array;
887 -- Add the new attribute
889 Attrs.Increment_Last;
890 Attrs.Table (Attrs.Last) :=
892 Var_Kind => Var_Kind,
893 Optional_Index => Opt_Index,
894 Attr_Kind => Real_Attr_Kind,
896 Others_Allowed => False,
900 Package_Attributes.Table (In_Package.Value).First_Attribute :=
902 end Register_New_Attribute;
904 --------------------------
905 -- Register_New_Package --
906 --------------------------
908 procedure Register_New_Package (Name : String; Id : out Package_Node_Id) is
912 if Name'Length = 0 then
913 Fail ("cannot register a package with no name");
918 Pkg_Name := Name_Id_Of (Name);
920 for Index in Package_Attributes.First .. Package_Attributes.Last loop
921 if Package_Attributes.Table (Index).Name = Pkg_Name then
922 Fail ("cannot register a package with a non unique name """
930 Package_Attributes.Increment_Last;
931 Id := (Value => Package_Attributes.Last);
932 Package_Attributes.Table (Package_Attributes.Last) :=
935 First_Attribute => Empty_Attr);
937 Add_Package_Name (Get_Name_String (Pkg_Name));
938 end Register_New_Package;
940 procedure Register_New_Package
942 Attributes : Attribute_Data_Array)
946 First_Attr : Attr_Node_Id := Empty_Attr;
947 Curr_Attr : Attr_Node_Id;
948 Attr_Kind : Attribute_Kind;
951 if Name'Length = 0 then
952 Fail ("cannot register a package with no name");
956 Pkg_Name := Name_Id_Of (Name);
958 for Index in Package_Attributes.First .. Package_Attributes.Last loop
959 if Package_Attributes.Table (Index).Name = Pkg_Name then
960 Fail ("cannot register a package with a non unique name """
967 for Index in Attributes'Range loop
968 Attr_Name := Name_Id_Of (Attributes (Index).Name);
970 Curr_Attr := First_Attr;
971 while Curr_Attr /= Empty_Attr loop
972 if Attrs.Table (Curr_Attr).Name = Attr_Name then
973 Fail ("duplicate attribute name """
974 & Attributes (Index).Name
975 & """ in new package """
981 Curr_Attr := Attrs.Table (Curr_Attr).Next;
984 Attr_Kind := Attributes (Index).Attr_Kind;
986 if Attributes (Index).Index_Is_File_Name
987 and then not Osint.File_Names_Case_Sensitive
990 when Associative_Array =>
991 Attr_Kind := Case_Insensitive_Associative_Array;
993 when Optional_Index_Associative_Array =>
995 Optional_Index_Case_Insensitive_Associative_Array;
1002 Attrs.Increment_Last;
1003 Attrs.Table (Attrs.Last) :=
1005 Var_Kind => Attributes (Index).Var_Kind,
1006 Optional_Index => Attributes (Index).Opt_Index,
1007 Attr_Kind => Attr_Kind,
1009 Others_Allowed => False,
1010 Default => Attributes (Index).Default,
1011 Next => First_Attr);
1012 First_Attr := Attrs.Last;
1015 Package_Attributes.Increment_Last;
1016 Package_Attributes.Table (Package_Attributes.Last) :=
1019 First_Attribute => First_Attr);
1021 Add_Package_Name (Get_Name_String (Pkg_Name));
1022 end Register_New_Package;
1024 ---------------------------
1025 -- Set_Attribute_Kind_Of --
1026 ---------------------------
1028 procedure Set_Attribute_Kind_Of
1029 (Attribute : Attribute_Node_Id;
1030 To : Attribute_Kind)
1033 if Attribute /= Empty_Attribute then
1034 Attrs.Table (Attribute.Value).Attr_Kind := To;
1036 end Set_Attribute_Kind_Of;
1038 --------------------------
1039 -- Set_Variable_Kind_Of --
1040 --------------------------
1042 procedure Set_Variable_Kind_Of
1043 (Attribute : Attribute_Node_Id;
1047 if Attribute /= Empty_Attribute then
1048 Attrs.Table (Attribute.Value).Var_Kind := To;
1050 end Set_Variable_Kind_Of;
1052 ----------------------
1053 -- Variable_Kind_Of --
1054 ----------------------
1056 function Variable_Kind_Of
1057 (Attribute : Attribute_Node_Id) return Variable_Kind
1060 if Attribute = Empty_Attribute then
1063 return Attrs.Table (Attribute.Value).Var_Kind;
1065 end Variable_Kind_Of;
1067 ------------------------
1068 -- First_Attribute_Of --
1069 ------------------------
1071 function First_Attribute_Of
1072 (Pkg : Package_Node_Id) return Attribute_Node_Id
1075 if Pkg = Empty_Package or else Pkg = Unknown_Package then
1076 return Empty_Attribute;
1079 (Value => Package_Attributes.Table (Pkg.Value).First_Attribute);
1081 end First_Attribute_Of;