1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2013, 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_standalone#" &
109 "LVlibrary_encapsulated_options#" &
110 "SVlibrary_encapsulated_supported#" &
111 "SVlibrary_auto_init#" &
112 "LVleading_library_options#" &
113 "LVlibrary_options#" &
114 "Lalibrary_rpath_options#" &
115 "SVlibrary_src_dir#" &
116 "SVlibrary_ali_dir#" &
118 "SVlibrary_symbol_file#" &
119 "SVlibrary_symbol_policy#" &
120 "SVlibrary_reference_symbol_file#" &
122 -- Configuration - General
124 "SVdefault_language#" &
125 "LVrun_path_option#" &
126 "SVrun_path_origin#" &
127 "SVseparate_run_path_options#" &
128 "Satoolchain_version#" &
129 "Satoolchain_description#" &
130 "Saobject_generated#" &
131 "Saobjects_linked#" &
134 -- Configuration - Libraries
136 "SVlibrary_builder#" &
137 "SVlibrary_support#" &
139 -- Configuration - Archives
141 "LVarchive_builder#" &
142 "LVarchive_builder_append_option#" &
143 "LVarchive_indexer#" &
144 "SVarchive_suffix#" &
145 "LVlibrary_partial_linker#" &
147 -- Configuration - Shared libraries
149 "SVshared_library_prefix#" &
150 "SVshared_library_suffix#" &
151 "SVsymbolic_link_supported#" &
152 "SVlibrary_major_minor_id_supported#" &
153 "SVlibrary_auto_init_supported#" &
154 "LVshared_library_minimum_switches#" &
155 "LVlibrary_version_switches#" &
156 "SVlibrary_install_name_option#" &
157 "Saruntime_library_dir#" &
158 "Saruntime_source_dir#" &
161 -- Some attributes are obsolescent, and renamed in the tree (see
162 -- Prj.Dect.Rename_Obsolescent_Attributes).
165 "Saspecification_suffix#" & -- Always renamed to "spec_suffix" in tree
167 "Saimplementation_suffix#" & -- Always renamed to "body_suffix" in tree
169 "SVseparate_suffix#" &
171 "SVdot_replacement#" &
172 "saspecification#" & -- Always renamed to "spec" in project tree
174 "saimplementation#" & -- Always renamed to "body" in project tree
176 "Laspecification_exceptions#" &
177 "Laimplementation_exceptions#" &
182 "Ladefault_switches#" &
184 "SVlocal_configuration_pragmas#" &
185 "Salocal_config_file#" &
187 -- Configuration - Compiling
191 "Sadependency_kind#" &
192 "Larequired_switches#" &
193 "Laleading_required_switches#" &
194 "Latrailing_required_switches#" &
197 "Lasource_file_switches#" &
198 "Saobject_file_suffix#" &
199 "Laobject_file_switches#" &
200 "Lamulti_unit_switches#" &
201 "Samulti_unit_object_separator#" &
203 -- Configuration - Mapping files
205 "Lamapping_file_switches#" &
206 "Samapping_spec_suffix#" &
207 "Samapping_body_suffix#" &
209 -- Configuration - Config files
211 "Laconfig_file_switches#" &
212 "Saconfig_body_file_name#" &
213 "Saconfig_body_file_name_index#" &
214 "Saconfig_body_file_name_pattern#" &
215 "Saconfig_spec_file_name#" &
216 "Saconfig_spec_file_name_index#" &
217 "Saconfig_spec_file_name_pattern#" &
218 "Saconfig_file_unique#" &
220 -- Configuration - Dependencies
222 "Ladependency_switches#" &
223 "Ladependency_driver#" &
225 -- Configuration - Search paths
227 "Lainclude_switches#" &
229 "Sainclude_path_file#" &
230 "Laobject_path_switches#" &
235 "Ladefault_switches#" &
237 "Lcglobal_compilation_switches#" &
239 "SVexecutable_suffix#" &
240 "SVglobal_configuration_pragmas#" &
241 "Saglobal_config_file#" &
251 "Ladefault_switches#" &
254 -- Configuration - Binding
257 "Larequired_switches#" &
260 "Saobjects_path_file#" &
265 "LVrequired_switches#" &
266 "Ladefault_switches#" &
267 "LcOleading_switches#" &
269 "LcOtrailing_switches#" &
270 "LVlinker_options#" &
271 "SVmap_file_option#" &
273 -- Configuration - Linking
276 "LVexecutable_switch#" &
277 "SVlib_dir_switch#" &
278 "SVlib_name_switch#" &
280 -- Configuration - Response files
282 "SVmax_command_line_length#" &
283 "SVresponse_file_format#" &
284 "LVresponse_file_switches#" &
290 "Lasource_artifact_extensions#" &
291 "Laobject_artifact_extensions#" &
292 "LVartifacts_in_exec_dir#" &
293 "LVartifacts_in_object_dir#" &
295 -- package Cross_Reference
297 "Pcross_reference#" &
298 "Ladefault_switches#" &
304 "Ladefault_switches#" &
307 -- package Pretty_Printer
310 "Ladefault_switches#" &
316 "Ladefault_switches#" &
322 "Ladefault_switches#" &
325 -- package Synchronize
328 "Ladefault_switches#" &
334 "Ladefault_switches#" &
340 "Ladefault_switches#" &
346 "Ladefault_switches#" &
349 "SVcommunication_protocol#" &
350 "Sacompiler_command#" &
351 "SVdebugger_command#" &
354 "SVvcs_file_check#" &
356 "SVdocumentation_dir#" &
362 "SVsources_subdir#" &
365 "SVproject_subdir#" &
372 "LVexcluded_patterns#" &
381 Initialized
: Boolean := False;
382 -- A flag to avoid multiple initialization
384 Package_Names
: String_List_Access
:= new Strings
.String_List
(1 .. 20);
385 Last_Package_Name
: Natural := 0;
386 -- Package_Names (1 .. Last_Package_Name) contains the list of the known
387 -- package names, coming from the Initialization_Data string or from
388 -- calls to one of the two procedures Register_New_Package.
390 procedure Add_Package_Name
(Name
: String);
391 -- Add a package name in the Package_Name list, extending it, if necessary
393 function Name_Id_Of
(Name
: String) return Name_Id
;
394 -- Returns the Name_Id for Name in lower case
396 ----------------------
397 -- Add_Package_Name --
398 ----------------------
400 procedure Add_Package_Name
(Name
: String) is
402 if Last_Package_Name
= Package_Names
'Last then
404 New_List
: constant Strings
.String_List_Access
:=
405 new Strings
.String_List
(1 .. Package_Names
'Last * 2);
407 New_List
(Package_Names
'Range) := Package_Names
.all;
408 Package_Names
:= New_List
;
412 Last_Package_Name
:= Last_Package_Name
+ 1;
413 Package_Names
(Last_Package_Name
) := new String'(Name);
414 end Add_Package_Name;
416 -----------------------
417 -- Attribute_Kind_Of --
418 -----------------------
420 function Attribute_Kind_Of
421 (Attribute : Attribute_Node_Id) return Attribute_Kind
424 if Attribute = Empty_Attribute then
427 return Attrs.Table (Attribute.Value).Attr_Kind;
429 end Attribute_Kind_Of;
431 -----------------------
432 -- Attribute_Name_Of --
433 -----------------------
435 function Attribute_Name_Of (Attribute : Attribute_Node_Id) return Name_Id is
437 if Attribute = Empty_Attribute then
440 return Attrs.Table (Attribute.Value).Name;
442 end Attribute_Name_Of;
444 --------------------------
445 -- Attribute_Node_Id_Of --
446 --------------------------
448 function Attribute_Node_Id_Of
450 Starting_At : Attribute_Node_Id) return Attribute_Node_Id
452 Id : Attr_Node_Id := Starting_At.Value;
455 while Id /= Empty_Attr
456 and then Attrs.Table (Id).Name /= Name
458 Id := Attrs.Table (Id).Next;
461 return (Value => Id);
462 end Attribute_Node_Id_Of;
468 procedure Initialize is
469 Start : Positive := Initialization_Data'First;
470 Finish : Positive := Start;
471 Current_Package : Pkg_Node_Id := Empty_Pkg;
472 Current_Attribute : Attr_Node_Id := Empty_Attr;
473 Is_An_Attribute : Boolean := False;
474 Var_Kind : Variable_Kind := Undefined;
475 Optional_Index : Boolean := False;
476 Attr_Kind : Attribute_Kind := Single;
477 Package_Name : Name_Id := No_Name;
478 Attribute_Name : Name_Id := No_Name;
479 First_Attribute : Attr_Node_Id := Attr.First_Attribute;
481 Others_Allowed : Boolean;
483 function Attribute_Location return String;
484 -- Returns a string depending if we are in the project level attributes
485 -- or in the attributes of a package.
487 ------------------------
488 -- Attribute_Location --
489 ------------------------
491 function Attribute_Location return String is
493 if Package_Name = No_Name then
494 return "project level attributes";
497 return "attribute of package """ &
498 Get_Name_String (Package_Name) & """";
500 end Attribute_Location;
502 -- Start of processing for Initialize
505 -- Don't allow Initialize action to be repeated
511 -- Make sure the two tables are empty
514 Package_Attributes.Init;
516 while Initialization_Data (Start) /= '#
' loop
517 Is_An_Attribute := True;
518 case Initialization_Data (Start) is
521 -- New allowed package
526 while Initialization_Data (Finish) /= '#
' loop
527 Finish := Finish + 1;
531 Name_Id_Of (Initialization_Data (Start .. Finish - 1));
533 for Index in First_Package .. Package_Attributes.Last loop
534 if Package_Name = Package_Attributes.Table (Index).Name then
535 Osint.Fail ("duplicate name """
536 & Initialization_Data (Start .. Finish - 1)
537 & """ in predefined packages.");
541 Is_An_Attribute := False;
542 Current_Attribute := Empty_Attr;
543 Package_Attributes.Increment_Last;
544 Current_Package := Package_Attributes.Last;
545 Package_Attributes.Table (Current_Package) :=
546 (Name => Package_Name,
548 First_Attribute => Empty_Attr);
551 Add_Package_Name (Get_Name_String (Package_Name));
555 Optional_Index := False;
559 Optional_Index := True;
563 Optional_Index := False;
567 Optional_Index := True;
573 if Is_An_Attribute then
578 case Initialization_Data (Start) is
583 Attr_Kind := Associative_Array;
586 Attr_Kind := Case_Insensitive_Associative_Array;
589 if Osint.File_Names_Case_Sensitive then
590 Attr_Kind := Associative_Array;
592 Attr_Kind := Case_Insensitive_Associative_Array;
596 if Osint.File_Names_Case_Sensitive then
597 Attr_Kind := Optional_Index_Associative_Array;
600 Optional_Index_Case_Insensitive_Associative_Array;
610 Others_Allowed := False;
612 if Initialization_Data (Start) = 'R
' then
616 elsif Initialization_Data (Start) = 'O
' then
617 Others_Allowed := True;
623 while Initialization_Data (Finish) /= '#
' loop
624 Finish := Finish + 1;
628 Name_Id_Of (Initialization_Data (Start .. Finish - 1));
629 Attrs.Increment_Last;
631 if Current_Attribute = Empty_Attr then
632 First_Attribute := Attrs.Last;
634 if Current_Package /= Empty_Pkg then
635 Package_Attributes.Table (Current_Package).First_Attribute
640 -- Check that there are no duplicate attributes
642 for Index in First_Attribute .. Attrs.Last - 1 loop
643 if Attribute_Name = Attrs.Table (Index).Name then
644 Osint.Fail ("duplicate attribute """
645 & Initialization_Data (Start .. Finish - 1)
646 & """ in " & Attribute_Location);
650 Attrs.Table (Current_Attribute).Next :=
654 Current_Attribute := Attrs.Last;
655 Attrs.Table (Current_Attribute) :=
656 (Name => Attribute_Name,
657 Var_Kind => Var_Kind,
658 Optional_Index => Optional_Index,
659 Attr_Kind => Attr_Kind,
660 Read_Only => Read_Only,
661 Others_Allowed => Others_Allowed,
674 function Is_Read_Only (Attribute : Attribute_Node_Id) return Boolean is
676 return Attrs.Table (Attribute.Value).Read_Only;
683 function Name_Id_Of (Name : String) return Name_Id is
686 Add_Str_To_Name_Buffer (Name);
687 To_Lower (Name_Buffer (1 .. Name_Len));
695 function Next_Attribute
696 (After : Attribute_Node_Id) return Attribute_Node_Id
699 if After = Empty_Attribute then
700 return Empty_Attribute;
702 return (Value => Attrs.Table (After.Value).Next);
706 -----------------------
707 -- Optional_Index_Of --
708 -----------------------
710 function Optional_Index_Of (Attribute : Attribute_Node_Id) return Boolean is
712 if Attribute = Empty_Attribute then
715 return Attrs.Table (Attribute.Value).Optional_Index;
717 end Optional_Index_Of;
719 function Others_Allowed_For
720 (Attribute : Attribute_Node_Id) return Boolean
723 if Attribute = Empty_Attribute then
726 return Attrs.Table (Attribute.Value).Others_Allowed;
728 end Others_Allowed_For;
730 -----------------------
731 -- Package_Name_List --
732 -----------------------
734 function Package_Name_List return Strings.String_List is
736 return Package_Names (1 .. Last_Package_Name);
737 end Package_Name_List;
739 ------------------------
740 -- Package_Node_Id_Of --
741 ------------------------
743 function Package_Node_Id_Of (Name : Name_Id) return Package_Node_Id is
745 for Index in Package_Attributes.First .. Package_Attributes.Last loop
746 if Package_Attributes.Table (Index).Name = Name then
747 if Package_Attributes.Table (Index).Known then
748 return (Value => Index);
750 return Unknown_Package;
755 -- If there is no package with this name, return Empty_Package
757 return Empty_Package;
758 end Package_Node_Id_Of;
760 ----------------------------
761 -- Register_New_Attribute --
762 ----------------------------
764 procedure Register_New_Attribute
766 In_Package : Package_Node_Id;
767 Attr_Kind : Defined_Attribute_Kind;
768 Var_Kind : Defined_Variable_Kind;
769 Index_Is_File_Name : Boolean := False;
770 Opt_Index : Boolean := False)
773 First_Attr : Attr_Node_Id := Empty_Attr;
774 Curr_Attr : Attr_Node_Id;
775 Real_Attr_Kind : Attribute_Kind;
778 if Name'Length = 0 then
779 Fail ("cannot register an attribute with no name");
783 if In_Package = Empty_Package then
784 Fail ("attempt to add attribute """
786 & """ to an undefined package");
790 Attr_Name := Name_Id_Of (Name);
793 Package_Attributes.Table (In_Package.Value).First_Attribute;
795 -- Check if attribute name is a duplicate
797 Curr_Attr := First_Attr;
798 while Curr_Attr /= Empty_Attr loop
799 if Attrs.Table (Curr_Attr).Name = Attr_Name then
800 Fail ("duplicate attribute name """
804 (Package_Attributes.Table (In_Package.Value).Name)
809 Curr_Attr := Attrs.Table (Curr_Attr).Next;
812 Real_Attr_Kind := Attr_Kind;
814 -- If Index_Is_File_Name, change the attribute kind if necessary
816 if Index_Is_File_Name and then not Osint.File_Names_Case_Sensitive then
818 when Associative_Array =>
819 Real_Attr_Kind := Case_Insensitive_Associative_Array;
821 when Optional_Index_Associative_Array =>
823 Optional_Index_Case_Insensitive_Associative_Array;
830 -- Add the new attribute
832 Attrs.Increment_Last;
833 Attrs.Table (Attrs.Last) :=
835 Var_Kind => Var_Kind,
836 Optional_Index => Opt_Index,
837 Attr_Kind => Real_Attr_Kind,
839 Others_Allowed => False,
842 Package_Attributes.Table (In_Package.Value).First_Attribute :=
844 end Register_New_Attribute;
846 --------------------------
847 -- Register_New_Package --
848 --------------------------
850 procedure Register_New_Package (Name : String; Id : out Package_Node_Id) is
854 if Name'Length = 0 then
855 Fail ("cannot register a package with no name");
860 Pkg_Name := Name_Id_Of (Name);
862 for Index in Package_Attributes.First .. Package_Attributes.Last loop
863 if Package_Attributes.Table (Index).Name = Pkg_Name then
864 Fail ("cannot register a package with a non unique name """
872 Package_Attributes.Increment_Last;
873 Id := (Value => Package_Attributes.Last);
874 Package_Attributes.Table (Package_Attributes.Last) :=
877 First_Attribute => Empty_Attr);
879 Add_Package_Name (Get_Name_String (Pkg_Name));
880 end Register_New_Package;
882 procedure Register_New_Package
884 Attributes : Attribute_Data_Array)
888 First_Attr : Attr_Node_Id := Empty_Attr;
889 Curr_Attr : Attr_Node_Id;
890 Attr_Kind : Attribute_Kind;
893 if Name'Length = 0 then
894 Fail ("cannot register a package with no name");
898 Pkg_Name := Name_Id_Of (Name);
900 for Index in Package_Attributes.First .. Package_Attributes.Last loop
901 if Package_Attributes.Table (Index).Name = Pkg_Name then
902 Fail ("cannot register a package with a non unique name """
909 for Index in Attributes'Range loop
910 Attr_Name := Name_Id_Of (Attributes (Index).Name);
912 Curr_Attr := First_Attr;
913 while Curr_Attr /= Empty_Attr loop
914 if Attrs.Table (Curr_Attr).Name = Attr_Name then
915 Fail ("duplicate attribute name """
916 & Attributes (Index).Name
917 & """ in new package """
923 Curr_Attr := Attrs.Table (Curr_Attr).Next;
926 Attr_Kind := Attributes (Index).Attr_Kind;
928 if Attributes (Index).Index_Is_File_Name
929 and then not Osint.File_Names_Case_Sensitive
932 when Associative_Array =>
933 Attr_Kind := Case_Insensitive_Associative_Array;
935 when Optional_Index_Associative_Array =>
937 Optional_Index_Case_Insensitive_Associative_Array;
944 Attrs.Increment_Last;
945 Attrs.Table (Attrs.Last) :=
947 Var_Kind => Attributes (Index).Var_Kind,
948 Optional_Index => Attributes (Index).Opt_Index,
949 Attr_Kind => Attr_Kind,
951 Others_Allowed => False,
953 First_Attr := Attrs.Last;
956 Package_Attributes.Increment_Last;
957 Package_Attributes.Table (Package_Attributes.Last) :=
960 First_Attribute => First_Attr);
962 Add_Package_Name (Get_Name_String (Pkg_Name));
963 end Register_New_Package;
965 ---------------------------
966 -- Set_Attribute_Kind_Of --
967 ---------------------------
969 procedure Set_Attribute_Kind_Of
970 (Attribute : Attribute_Node_Id;
974 if Attribute /= Empty_Attribute then
975 Attrs.Table (Attribute.Value).Attr_Kind := To;
977 end Set_Attribute_Kind_Of;
979 --------------------------
980 -- Set_Variable_Kind_Of --
981 --------------------------
983 procedure Set_Variable_Kind_Of
984 (Attribute : Attribute_Node_Id;
988 if Attribute /= Empty_Attribute then
989 Attrs.Table (Attribute.Value).Var_Kind := To;
991 end Set_Variable_Kind_Of;
993 ----------------------
994 -- Variable_Kind_Of --
995 ----------------------
997 function Variable_Kind_Of
998 (Attribute : Attribute_Node_Id) return Variable_Kind
1001 if Attribute = Empty_Attribute then
1004 return Attrs.Table (Attribute.Value).Var_Kind;
1006 end Variable_Kind_Of;
1008 ------------------------
1009 -- First_Attribute_Of --
1010 ------------------------
1012 function First_Attribute_Of
1013 (Pkg : Package_Node_Id) return Attribute_Node_Id
1016 if Pkg = Empty_Package then
1017 return Empty_Attribute;
1020 (Value => Package_Attributes.Table (Pkg.Value).First_Attribute);
1022 end First_Attribute_Of;