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#" &
139 "SaruntimeDruntime_value#" &
141 -- Configuration - Libraries
143 "SVlibrary_builder#" &
144 "SVlibrary_support#" &
146 -- Configuration - Archives
148 "LVarchive_builder#" &
149 "LVarchive_builder_append_option#" &
150 "LVarchive_indexer#" &
151 "SVarchive_suffix#" &
152 "LVlibrary_partial_linker#" &
154 -- Configuration - Shared libraries
156 "SVshared_library_prefix#" &
157 "SVshared_library_suffix#" &
158 "SVsymbolic_link_supported#" &
159 "SVlibrary_major_minor_id_supported#" &
160 "SVlibrary_auto_init_supported#" &
161 "LVshared_library_minimum_switches#" &
162 "LVlibrary_version_switches#" &
163 "SVlibrary_install_name_option#" &
164 "Saruntime_library_dir#" &
165 "Saruntime_source_dir#" &
168 -- Some attributes are obsolescent, and renamed in the tree (see
169 -- Prj.Dect.Rename_Obsolescent_Attributes).
172 "Saspecification_suffix#" & -- Always renamed to "spec_suffix" in tree
174 "Saimplementation_suffix#" & -- Always renamed to "body_suffix" in tree
176 "SVseparate_suffix#" &
178 "SVdot_replacement#" &
179 "saspecification#" & -- Always renamed to "spec" in project tree
181 "saimplementation#" & -- Always renamed to "body" in project tree
183 "Laspecification_exceptions#" &
184 "Laimplementation_exceptions#" &
189 "Ladefault_switches#" &
191 "SVlocal_configuration_pragmas#" &
192 "Salocal_config_file#" &
194 -- Configuration - Compiling
198 "Sadependency_kind#" &
199 "Larequired_switches#" &
200 "Laleading_required_switches#" &
201 "Latrailing_required_switches#" &
204 "Lasource_file_switches#" &
205 "Saobject_file_suffix#" &
206 "Laobject_file_switches#" &
207 "Lamulti_unit_switches#" &
208 "Samulti_unit_object_separator#" &
210 -- Configuration - Mapping files
212 "Lamapping_file_switches#" &
213 "Samapping_spec_suffix#" &
214 "Samapping_body_suffix#" &
216 -- Configuration - Config files
218 "Laconfig_file_switches#" &
219 "Saconfig_body_file_name#" &
220 "Saconfig_body_file_name_index#" &
221 "Saconfig_body_file_name_pattern#" &
222 "Saconfig_spec_file_name#" &
223 "Saconfig_spec_file_name_index#" &
224 "Saconfig_spec_file_name_pattern#" &
225 "Saconfig_file_unique#" &
227 -- Configuration - Dependencies
229 "Ladependency_switches#" &
230 "Ladependency_driver#" &
232 -- Configuration - Search paths
234 "Lainclude_switches#" &
236 "Sainclude_path_file#" &
237 "Laobject_path_switches#" &
242 "Ladefault_switches#" &
244 "Lcglobal_compilation_switches#" &
246 "SVexecutable_suffix#" &
247 "SVglobal_configuration_pragmas#" &
248 "Saglobal_config_file#" &
258 "Ladefault_switches#" &
261 -- Configuration - Binding
264 "Larequired_switches#" &
267 "Saobjects_path_file#" &
272 "LVrequired_switches#" &
273 "Ladefault_switches#" &
274 "LcOleading_switches#" &
276 "LcOtrailing_switches#" &
277 "LVlinker_options#" &
278 "SVmap_file_option#" &
280 -- Configuration - Linking
284 -- Configuration - Response files
286 "SVmax_command_line_length#" &
287 "SVresponse_file_format#" &
288 "LVresponse_file_switches#" &
294 "Lasource_artifact_extensions#" &
295 "Laobject_artifact_extensions#" &
296 "LVartifacts_in_exec_dir#" &
297 "LVartifacts_in_object_dir#" &
299 -- package Cross_Reference
301 "Pcross_reference#" &
302 "Ladefault_switches#" &
308 "Ladefault_switches#" &
311 -- package Pretty_Printer
314 "Ladefault_switches#" &
320 "Ladefault_switches#" &
326 "Ladefault_switches#" &
332 "Ladefault_switches#" &
338 "Ladefault_switches#" &
344 "Ladefault_switches#" &
347 "SVcommunication_protocol#" &
348 "Sacompiler_command#" &
349 "SVdebugger_command#" &
352 "SVvcs_file_check#" &
354 "SVdocumentation_dir#" &
360 "SVsources_subdir#" &
363 "SVproject_subdir#" &
373 "LVexcluded_patterns#" &
374 "LVincluded_patterns#" &
375 "LVincluded_artifact_patterns#" &
384 Initialized : Boolean := False;
385 -- A flag to avoid multiple initialization
387 Package_Names : String_List_Access := new Strings.String_List (1 .. 20);
388 Last_Package_Name : Natural := 0;
389 -- Package_Names (1 .. Last_Package_Name) contains the list of the known
390 -- package names, coming from the Initialization_Data string or from
391 -- calls to one of the two procedures Register_New_Package.
393 procedure Add_Package_Name (Name : String);
394 -- Add a package name in the Package_Name list, extending it, if necessary
396 function Name_Id_Of (Name : String) return Name_Id;
397 -- Returns the Name_Id for Name in lower case
399 ----------------------
400 -- Add_Package_Name --
401 ----------------------
403 procedure Add_Package_Name (Name : String) is
405 if Last_Package_Name = Package_Names'Last then
407 New_List : constant Strings.String_List_Access :=
408 new Strings.String_List (1 .. Package_Names'Last * 2);
410 New_List (Package_Names'Range) := Package_Names.all;
411 Package_Names := New_List;
415 Last_Package_Name := Last_Package_Name + 1;
416 Package_Names (Last_Package_Name) := new String'(Name);
417 end Add_Package_Name;
419 --------------------------
420 -- Attribute_Default_Of --
421 --------------------------
423 function Attribute_Default_Of
424 (Attribute : Attribute_Node_Id) return Attribute_Default_Value
427 if Attribute = Empty_Attribute then
430 return Attrs.Table (Attribute.Value).Default;
432 end Attribute_Default_Of;
434 -----------------------
435 -- Attribute_Kind_Of --
436 -----------------------
438 function Attribute_Kind_Of
439 (Attribute : Attribute_Node_Id) return Attribute_Kind
442 if Attribute = Empty_Attribute then
445 return Attrs.Table (Attribute.Value).Attr_Kind;
447 end Attribute_Kind_Of;
449 -----------------------
450 -- Attribute_Name_Of --
451 -----------------------
453 function Attribute_Name_Of (Attribute : Attribute_Node_Id) return Name_Id is
455 if Attribute = Empty_Attribute then
458 return Attrs.Table (Attribute.Value).Name;
460 end Attribute_Name_Of;
462 --------------------------
463 -- Attribute_Node_Id_Of --
464 --------------------------
466 function Attribute_Node_Id_Of
468 Starting_At : Attribute_Node_Id) return Attribute_Node_Id
470 Id : Attr_Node_Id := Starting_At.Value;
473 while Id /= Empty_Attr
474 and then Attrs.Table (Id).Name /= Name
476 Id := Attrs.Table (Id).Next;
479 return (Value => Id);
480 end Attribute_Node_Id_Of;
486 procedure Initialize is
487 Start : Positive := Initialization_Data'First;
488 Finish : Positive := Start;
489 Current_Package : Pkg_Node_Id := Empty_Pkg;
490 Current_Attribute : Attr_Node_Id := Empty_Attr;
491 Is_An_Attribute : Boolean := False;
492 Var_Kind : Variable_Kind := Undefined;
493 Optional_Index : Boolean := False;
494 Attr_Kind : Attribute_Kind := Single;
495 Package_Name : Name_Id := No_Name;
496 Attribute_Name : Name_Id := No_Name;
497 First_Attribute : Attr_Node_Id := Attr.First_Attribute;
499 Others_Allowed : Boolean;
500 Default : Attribute_Default_Value;
502 function Attribute_Location return String;
503 -- Returns a string depending if we are in the project level attributes
504 -- or in the attributes of a package.
506 ------------------------
507 -- Attribute_Location --
508 ------------------------
510 function Attribute_Location return String is
512 if Package_Name = No_Name then
513 return "project level attributes";
516 return "attribute of package """ &
517 Get_Name_String (Package_Name) & """";
519 end Attribute_Location;
521 -- Start of processing for Initialize
524 -- Don't allow Initialize action to be repeated
530 -- Make sure the two tables are empty
533 Package_Attributes.Init;
535 while Initialization_Data (Start) /= '#' loop
536 Is_An_Attribute := True;
537 case Initialization_Data (Start) is
540 -- New allowed package
545 while Initialization_Data (Finish) /= '#' loop
546 Finish := Finish + 1;
550 Name_Id_Of (Initialization_Data (Start .. Finish - 1));
552 for Index in First_Package .. Package_Attributes.Last loop
553 if Package_Name = Package_Attributes.Table (Index).Name then
554 Osint.Fail ("duplicate name """
555 & Initialization_Data (Start .. Finish - 1)
556 & """ in predefined packages.");
560 Is_An_Attribute := False;
561 Current_Attribute := Empty_Attr;
562 Package_Attributes.Increment_Last;
563 Current_Package := Package_Attributes.Last;
564 Package_Attributes.Table (Current_Package) :=
565 (Name => Package_Name,
567 First_Attribute => Empty_Attr);
570 Add_Package_Name (Get_Name_String (Package_Name));
574 Optional_Index := False;
578 Optional_Index := True;
582 Optional_Index := False;
586 Optional_Index := True;
592 if Is_An_Attribute then
597 case Initialization_Data (Start) is
602 Attr_Kind := Associative_Array;
605 Attr_Kind := Case_Insensitive_Associative_Array;
608 if Osint.File_Names_Case_Sensitive then
609 Attr_Kind := Associative_Array;
611 Attr_Kind := Case_Insensitive_Associative_Array;
615 if Osint.File_Names_Case_Sensitive then
616 Attr_Kind := Optional_Index_Associative_Array;
619 Optional_Index_Case_Insensitive_Associative_Array;
629 Others_Allowed := False;
630 Default := Empty_Value;
632 if Initialization_Data (Start) = 'R' then
634 Default := Read_Only_Value;
637 elsif Initialization_Data (Start) = 'O' then
638 Others_Allowed := True;
644 while Initialization_Data (Finish) /= '#'
646 Initialization_Data (Finish) /= 'D'
648 Finish := Finish + 1;
652 Name_Id_Of (Initialization_Data (Start .. Finish - 1));
654 if Initialization_Data (Finish) = 'D' then
658 while Initialization_Data (Finish) /= '#' loop
659 Finish := Finish + 1;
663 Default_Name : constant String :=
664 Initialization_Data (Start .. Finish - 1);
665 pragma Unsuppress (All_Checks);
667 Default := Attribute_Default_Value'Value (Default_Name);
669 when Constraint_Error =>
671 ("illegal default value """ &
673 """ for attribute " &
674 Get_Name_String (Attribute_Name));
678 Attrs.Increment_Last;
680 if Current_Attribute = Empty_Attr then
681 First_Attribute := Attrs.Last;
683 if Current_Package /= Empty_Pkg then
684 Package_Attributes.Table (Current_Package).First_Attribute
689 -- Check that there are no duplicate attributes
691 for Index in First_Attribute .. Attrs.Last - 1 loop
692 if Attribute_Name = Attrs.Table (Index).Name then
693 Osint.Fail ("duplicate attribute """
694 & Initialization_Data (Start .. Finish - 1)
695 & """ in " & Attribute_Location);
699 Attrs.Table (Current_Attribute).Next :=
703 Current_Attribute := Attrs.Last;
704 Attrs.Table (Current_Attribute) :=
705 (Name => Attribute_Name,
706 Var_Kind => Var_Kind,
707 Optional_Index => Optional_Index,
708 Attr_Kind => Attr_Kind,
709 Read_Only => Read_Only,
710 Others_Allowed => Others_Allowed,
724 function Is_Read_Only (Attribute : Attribute_Node_Id) return Boolean is
726 return Attrs.Table (Attribute.Value).Read_Only;
733 function Name_Id_Of (Name : String) return Name_Id is
736 Add_Str_To_Name_Buffer (Name);
737 To_Lower (Name_Buffer (1 .. Name_Len));
745 function Next_Attribute
746 (After : Attribute_Node_Id) return Attribute_Node_Id
749 if After = Empty_Attribute then
750 return Empty_Attribute;
752 return (Value => Attrs.Table (After.Value).Next);
756 -----------------------
757 -- Optional_Index_Of --
758 -----------------------
760 function Optional_Index_Of (Attribute : Attribute_Node_Id) return Boolean is
762 if Attribute = Empty_Attribute then
765 return Attrs.Table (Attribute.Value).Optional_Index;
767 end Optional_Index_Of;
769 function Others_Allowed_For
770 (Attribute : Attribute_Node_Id) return Boolean
773 if Attribute = Empty_Attribute then
776 return Attrs.Table (Attribute.Value).Others_Allowed;
778 end Others_Allowed_For;
780 -----------------------
781 -- Package_Name_List --
782 -----------------------
784 function Package_Name_List return Strings.String_List is
786 return Package_Names (1 .. Last_Package_Name);
787 end Package_Name_List;
789 ------------------------
790 -- Package_Node_Id_Of --
791 ------------------------
793 function Package_Node_Id_Of (Name : Name_Id) return Package_Node_Id is
795 for Index in Package_Attributes.First .. Package_Attributes.Last loop
796 if Package_Attributes.Table (Index).Name = Name then
797 if Package_Attributes.Table (Index).Known then
798 return (Value => Index);
800 return Unknown_Package;
805 -- If there is no package with this name, return Empty_Package
807 return Empty_Package;
808 end Package_Node_Id_Of;
810 ----------------------------
811 -- Register_New_Attribute --
812 ----------------------------
814 procedure Register_New_Attribute
816 In_Package : Package_Node_Id;
817 Attr_Kind : Defined_Attribute_Kind;
818 Var_Kind : Defined_Variable_Kind;
819 Index_Is_File_Name : Boolean := False;
820 Opt_Index : Boolean := False;
821 Default : Attribute_Default_Value := Empty_Value)
824 First_Attr : Attr_Node_Id := Empty_Attr;
825 Curr_Attr : Attr_Node_Id;
826 Real_Attr_Kind : Attribute_Kind;
829 if Name'Length = 0 then
830 Fail ("cannot register an attribute with no name");
834 if In_Package = Empty_Package then
835 Fail ("attempt to add attribute """
837 & """ to an undefined package");
841 Attr_Name := Name_Id_Of (Name);
844 Package_Attributes.Table (In_Package.Value).First_Attribute;
846 -- Check if attribute name is a duplicate
848 Curr_Attr := First_Attr;
849 while Curr_Attr /= Empty_Attr loop
850 if Attrs.Table (Curr_Attr).Name = Attr_Name then
851 Fail ("duplicate attribute name """
855 (Package_Attributes.Table (In_Package.Value).Name)
860 Curr_Attr := Attrs.Table (Curr_Attr).Next;
863 Real_Attr_Kind := Attr_Kind;
865 -- If Index_Is_File_Name, change the attribute kind if necessary
867 if Index_Is_File_Name and then not Osint.File_Names_Case_Sensitive then
869 when Associative_Array =>
870 Real_Attr_Kind := Case_Insensitive_Associative_Array;
872 when Optional_Index_Associative_Array =>
874 Optional_Index_Case_Insensitive_Associative_Array;
881 -- Add the new attribute
883 Attrs.Increment_Last;
884 Attrs.Table (Attrs.Last) :=
886 Var_Kind => Var_Kind,
887 Optional_Index => Opt_Index,
888 Attr_Kind => Real_Attr_Kind,
890 Others_Allowed => False,
894 Package_Attributes.Table (In_Package.Value).First_Attribute :=
896 end Register_New_Attribute;
898 --------------------------
899 -- Register_New_Package --
900 --------------------------
902 procedure Register_New_Package (Name : String; Id : out Package_Node_Id) is
904 Found : Boolean := False;
907 if Name'Length = 0 then
908 Fail ("cannot register a package with no name");
913 Pkg_Name := Name_Id_Of (Name);
915 for Index in Package_Attributes.First .. Package_Attributes.Last loop
916 if Package_Attributes.Table (Index).Name = Pkg_Name then
917 if Package_Attributes.Table (Index).Known then
918 Fail ("cannot register a package with a non unique name """
926 Id := (Value => Index);
933 Package_Attributes.Increment_Last;
934 Id := (Value => Package_Attributes.Last);
937 Package_Attributes.Table (Id.Value) :=
940 First_Attribute => Empty_Attr);
942 Add_Package_Name (Get_Name_String (Pkg_Name));
943 end Register_New_Package;
945 procedure Register_New_Package
947 Attributes : Attribute_Data_Array)
951 First_Attr : Attr_Node_Id := Empty_Attr;
952 Curr_Attr : Attr_Node_Id;
953 Attr_Kind : Attribute_Kind;
956 if Name'Length = 0 then
957 Fail ("cannot register a package with no name");
961 Pkg_Name := Name_Id_Of (Name);
963 for Index in Package_Attributes.First .. Package_Attributes.Last loop
964 if Package_Attributes.Table (Index).Name = Pkg_Name then
965 Fail ("cannot register a package with a non unique name """
972 for Index in Attributes'Range loop
973 Attr_Name := Name_Id_Of (Attributes (Index).Name);
975 Curr_Attr := First_Attr;
976 while Curr_Attr /= Empty_Attr loop
977 if Attrs.Table (Curr_Attr).Name = Attr_Name then
978 Fail ("duplicate attribute name """
979 & Attributes (Index).Name
980 & """ in new package """
986 Curr_Attr := Attrs.Table (Curr_Attr).Next;
989 Attr_Kind := Attributes (Index).Attr_Kind;
991 if Attributes (Index).Index_Is_File_Name
992 and then not Osint.File_Names_Case_Sensitive
995 when Associative_Array =>
996 Attr_Kind := Case_Insensitive_Associative_Array;
998 when Optional_Index_Associative_Array =>
1000 Optional_Index_Case_Insensitive_Associative_Array;
1007 Attrs.Increment_Last;
1008 Attrs.Table (Attrs.Last) :=
1010 Var_Kind => Attributes (Index).Var_Kind,
1011 Optional_Index => Attributes (Index).Opt_Index,
1012 Attr_Kind => Attr_Kind,
1014 Others_Allowed => False,
1015 Default => Attributes (Index).Default,
1016 Next => First_Attr);
1017 First_Attr := Attrs.Last;
1020 Package_Attributes.Increment_Last;
1021 Package_Attributes.Table (Package_Attributes.Last) :=
1024 First_Attribute => First_Attr);
1026 Add_Package_Name (Get_Name_String (Pkg_Name));
1027 end Register_New_Package;
1029 ---------------------------
1030 -- Set_Attribute_Kind_Of --
1031 ---------------------------
1033 procedure Set_Attribute_Kind_Of
1034 (Attribute : Attribute_Node_Id;
1035 To : Attribute_Kind)
1038 if Attribute /= Empty_Attribute then
1039 Attrs.Table (Attribute.Value).Attr_Kind := To;
1041 end Set_Attribute_Kind_Of;
1043 --------------------------
1044 -- Set_Variable_Kind_Of --
1045 --------------------------
1047 procedure Set_Variable_Kind_Of
1048 (Attribute : Attribute_Node_Id;
1052 if Attribute /= Empty_Attribute then
1053 Attrs.Table (Attribute.Value).Var_Kind := To;
1055 end Set_Variable_Kind_Of;
1057 ----------------------
1058 -- Variable_Kind_Of --
1059 ----------------------
1061 function Variable_Kind_Of
1062 (Attribute : Attribute_Node_Id) return Variable_Kind
1065 if Attribute = Empty_Attribute then
1068 return Attrs.Table (Attribute.Value).Var_Kind;
1070 end Variable_Kind_Of;
1072 ------------------------
1073 -- First_Attribute_Of --
1074 ------------------------
1076 function First_Attribute_Of
1077 (Pkg : Package_Node_Id) return Attribute_Node_Id
1080 if Pkg = Empty_Package or else Pkg = Unknown_Package then
1081 return Empty_Attribute;
1084 (Value => Package_Attributes.Table (Pkg.Value).First_Attribute);
1086 end First_Attribute_Of;