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 "SVlibrary_src_dir#" &
115 "SVlibrary_ali_dir#" &
117 "SVlibrary_symbol_file#" &
118 "SVlibrary_symbol_policy#" &
119 "SVlibrary_reference_symbol_file#" &
121 -- Configuration - General
123 "SVdefault_language#" &
124 "LVrun_path_option#" &
125 "SVrun_path_origin#" &
126 "SVseparate_run_path_options#" &
127 "Satoolchain_version#" &
128 "Satoolchain_description#" &
129 "Saobject_generated#" &
130 "Saobjects_linked#" &
133 -- Configuration - Libraries
135 "SVlibrary_builder#" &
136 "SVlibrary_support#" &
138 -- Configuration - Archives
140 "LVarchive_builder#" &
141 "LVarchive_builder_append_option#" &
142 "LVarchive_indexer#" &
143 "SVarchive_suffix#" &
144 "LVlibrary_partial_linker#" &
146 -- Configuration - Shared libraries
148 "SVshared_library_prefix#" &
149 "SVshared_library_suffix#" &
150 "SVsymbolic_link_supported#" &
151 "SVlibrary_major_minor_id_supported#" &
152 "SVlibrary_auto_init_supported#" &
153 "LVshared_library_minimum_switches#" &
154 "LVlibrary_version_switches#" &
155 "SVlibrary_install_name_option#" &
156 "Saruntime_library_dir#" &
157 "Saruntime_source_dir#" &
160 -- Some attributes are obsolescent, and renamed in the tree (see
161 -- Prj.Dect.Rename_Obsolescent_Attributes).
164 "Saspecification_suffix#" & -- Always renamed to "spec_suffix" in tree
166 "Saimplementation_suffix#" & -- Always renamed to "body_suffix" in tree
168 "SVseparate_suffix#" &
170 "SVdot_replacement#" &
171 "saspecification#" & -- Always renamed to "spec" in project tree
173 "saimplementation#" & -- Always renamed to "body" in project tree
175 "Laspecification_exceptions#" &
176 "Laimplementation_exceptions#" &
181 "Ladefault_switches#" &
183 "SVlocal_configuration_pragmas#" &
184 "Salocal_config_file#" &
186 -- Configuration - Compiling
190 "Sadependency_kind#" &
191 "Larequired_switches#" &
192 "Laleading_required_switches#" &
193 "Latrailing_required_switches#" &
196 "Lasource_file_switches#" &
197 "Saobject_file_suffix#" &
198 "Laobject_file_switches#" &
199 "Lamulti_unit_switches#" &
200 "Samulti_unit_object_separator#" &
202 -- Configuration - Mapping files
204 "Lamapping_file_switches#" &
205 "Samapping_spec_suffix#" &
206 "Samapping_body_suffix#" &
208 -- Configuration - Config files
210 "Laconfig_file_switches#" &
211 "Saconfig_body_file_name#" &
212 "Saconfig_body_file_name_index#" &
213 "Saconfig_body_file_name_pattern#" &
214 "Saconfig_spec_file_name#" &
215 "Saconfig_spec_file_name_index#" &
216 "Saconfig_spec_file_name_pattern#" &
217 "Saconfig_file_unique#" &
219 -- Configuration - Dependencies
221 "Ladependency_switches#" &
222 "Ladependency_driver#" &
224 -- Configuration - Search paths
226 "Lainclude_switches#" &
228 "Sainclude_path_file#" &
229 "Laobject_path_switches#" &
234 "Ladefault_switches#" &
236 "Lcglobal_compilation_switches#" &
238 "SVexecutable_suffix#" &
239 "SVglobal_configuration_pragmas#" &
240 "Saglobal_config_file#" &
250 "Ladefault_switches#" &
253 -- Configuration - Binding
256 "Larequired_switches#" &
259 "Saobjects_path_file#" &
264 "LVrequired_switches#" &
265 "Ladefault_switches#" &
266 "LcOleading_switches#" &
268 "LcOtrailing_switches#" &
269 "LVlinker_options#" &
270 "SVmap_file_option#" &
272 -- Configuration - Linking
275 "LVexecutable_switch#" &
276 "SVlib_dir_switch#" &
277 "SVlib_name_switch#" &
279 -- Configuration - Response files
281 "SVmax_command_line_length#" &
282 "SVresponse_file_format#" &
283 "LVresponse_file_switches#" &
289 "Lasource_artifact_extensions#" &
290 "Laobject_artifact_extensions#" &
292 -- package Cross_Reference
294 "Pcross_reference#" &
295 "Ladefault_switches#" &
301 "Ladefault_switches#" &
304 -- package Pretty_Printer
307 "Ladefault_switches#" &
313 "Ladefault_switches#" &
319 "Ladefault_switches#" &
322 -- package Synchronize
325 "Ladefault_switches#" &
331 "Ladefault_switches#" &
337 "Ladefault_switches#" &
343 "Ladefault_switches#" &
346 "SVcommunication_protocol#" &
347 "Sacompiler_command#" &
348 "SVdebugger_command#" &
351 "SVvcs_file_check#" &
353 "SVdocumentation_dir#" &
359 "SVsources_subdir#" &
362 "SVproject_subdir#" &
377 Initialized
: Boolean := False;
378 -- A flag to avoid multiple initialization
380 Package_Names
: String_List_Access
:= new Strings
.String_List
(1 .. 20);
381 Last_Package_Name
: Natural := 0;
382 -- Package_Names (1 .. Last_Package_Name) contains the list of the known
383 -- package names, coming from the Initialization_Data string or from
384 -- calls to one of the two procedures Register_New_Package.
386 procedure Add_Package_Name
(Name
: String);
387 -- Add a package name in the Package_Name list, extending it, if necessary
389 function Name_Id_Of
(Name
: String) return Name_Id
;
390 -- Returns the Name_Id for Name in lower case
392 ----------------------
393 -- Add_Package_Name --
394 ----------------------
396 procedure Add_Package_Name
(Name
: String) is
398 if Last_Package_Name
= Package_Names
'Last then
400 New_List
: constant Strings
.String_List_Access
:=
401 new Strings
.String_List
(1 .. Package_Names
'Last * 2);
403 New_List
(Package_Names
'Range) := Package_Names
.all;
404 Package_Names
:= New_List
;
408 Last_Package_Name
:= Last_Package_Name
+ 1;
409 Package_Names
(Last_Package_Name
) := new String'(Name);
410 end Add_Package_Name;
412 -----------------------
413 -- Attribute_Kind_Of --
414 -----------------------
416 function Attribute_Kind_Of
417 (Attribute : Attribute_Node_Id) return Attribute_Kind
420 if Attribute = Empty_Attribute then
423 return Attrs.Table (Attribute.Value).Attr_Kind;
425 end Attribute_Kind_Of;
427 -----------------------
428 -- Attribute_Name_Of --
429 -----------------------
431 function Attribute_Name_Of (Attribute : Attribute_Node_Id) return Name_Id is
433 if Attribute = Empty_Attribute then
436 return Attrs.Table (Attribute.Value).Name;
438 end Attribute_Name_Of;
440 --------------------------
441 -- Attribute_Node_Id_Of --
442 --------------------------
444 function Attribute_Node_Id_Of
446 Starting_At : Attribute_Node_Id) return Attribute_Node_Id
448 Id : Attr_Node_Id := Starting_At.Value;
451 while Id /= Empty_Attr
452 and then Attrs.Table (Id).Name /= Name
454 Id := Attrs.Table (Id).Next;
457 return (Value => Id);
458 end Attribute_Node_Id_Of;
464 procedure Initialize is
465 Start : Positive := Initialization_Data'First;
466 Finish : Positive := Start;
467 Current_Package : Pkg_Node_Id := Empty_Pkg;
468 Current_Attribute : Attr_Node_Id := Empty_Attr;
469 Is_An_Attribute : Boolean := False;
470 Var_Kind : Variable_Kind := Undefined;
471 Optional_Index : Boolean := False;
472 Attr_Kind : Attribute_Kind := Single;
473 Package_Name : Name_Id := No_Name;
474 Attribute_Name : Name_Id := No_Name;
475 First_Attribute : Attr_Node_Id := Attr.First_Attribute;
477 Others_Allowed : Boolean;
479 function Attribute_Location return String;
480 -- Returns a string depending if we are in the project level attributes
481 -- or in the attributes of a package.
483 ------------------------
484 -- Attribute_Location --
485 ------------------------
487 function Attribute_Location return String is
489 if Package_Name = No_Name then
490 return "project level attributes";
493 return "attribute of package """ &
494 Get_Name_String (Package_Name) & """";
496 end Attribute_Location;
498 -- Start of processing for Initialize
501 -- Don't allow Initialize action to be repeated
507 -- Make sure the two tables are empty
510 Package_Attributes.Init;
512 while Initialization_Data (Start) /= '#
' loop
513 Is_An_Attribute := True;
514 case Initialization_Data (Start) is
517 -- New allowed package
522 while Initialization_Data (Finish) /= '#
' loop
523 Finish := Finish + 1;
527 Name_Id_Of (Initialization_Data (Start .. Finish - 1));
529 for Index in First_Package .. Package_Attributes.Last loop
530 if Package_Name = Package_Attributes.Table (Index).Name then
531 Osint.Fail ("duplicate name """
532 & Initialization_Data (Start .. Finish - 1)
533 & """ in predefined packages.");
537 Is_An_Attribute := False;
538 Current_Attribute := Empty_Attr;
539 Package_Attributes.Increment_Last;
540 Current_Package := Package_Attributes.Last;
541 Package_Attributes.Table (Current_Package) :=
542 (Name => Package_Name,
544 First_Attribute => Empty_Attr);
547 Add_Package_Name (Get_Name_String (Package_Name));
551 Optional_Index := False;
555 Optional_Index := True;
559 Optional_Index := False;
563 Optional_Index := True;
569 if Is_An_Attribute then
574 case Initialization_Data (Start) is
579 Attr_Kind := Associative_Array;
582 Attr_Kind := Case_Insensitive_Associative_Array;
585 if Osint.File_Names_Case_Sensitive then
586 Attr_Kind := Associative_Array;
588 Attr_Kind := Case_Insensitive_Associative_Array;
592 if Osint.File_Names_Case_Sensitive then
593 Attr_Kind := Optional_Index_Associative_Array;
596 Optional_Index_Case_Insensitive_Associative_Array;
606 Others_Allowed := False;
608 if Initialization_Data (Start) = 'R
' then
612 elsif Initialization_Data (Start) = 'O
' then
613 Others_Allowed := True;
619 while Initialization_Data (Finish) /= '#
' loop
620 Finish := Finish + 1;
624 Name_Id_Of (Initialization_Data (Start .. Finish - 1));
625 Attrs.Increment_Last;
627 if Current_Attribute = Empty_Attr then
628 First_Attribute := Attrs.Last;
630 if Current_Package /= Empty_Pkg then
631 Package_Attributes.Table (Current_Package).First_Attribute
636 -- Check that there are no duplicate attributes
638 for Index in First_Attribute .. Attrs.Last - 1 loop
639 if Attribute_Name = Attrs.Table (Index).Name then
640 Osint.Fail ("duplicate attribute """
641 & Initialization_Data (Start .. Finish - 1)
642 & """ in " & Attribute_Location);
646 Attrs.Table (Current_Attribute).Next :=
650 Current_Attribute := Attrs.Last;
651 Attrs.Table (Current_Attribute) :=
652 (Name => Attribute_Name,
653 Var_Kind => Var_Kind,
654 Optional_Index => Optional_Index,
655 Attr_Kind => Attr_Kind,
656 Read_Only => Read_Only,
657 Others_Allowed => Others_Allowed,
670 function Is_Read_Only (Attribute : Attribute_Node_Id) return Boolean is
672 return Attrs.Table (Attribute.Value).Read_Only;
679 function Name_Id_Of (Name : String) return Name_Id is
682 Add_Str_To_Name_Buffer (Name);
683 To_Lower (Name_Buffer (1 .. Name_Len));
691 function Next_Attribute
692 (After : Attribute_Node_Id) return Attribute_Node_Id
695 if After = Empty_Attribute then
696 return Empty_Attribute;
698 return (Value => Attrs.Table (After.Value).Next);
702 -----------------------
703 -- Optional_Index_Of --
704 -----------------------
706 function Optional_Index_Of (Attribute : Attribute_Node_Id) return Boolean is
708 if Attribute = Empty_Attribute then
711 return Attrs.Table (Attribute.Value).Optional_Index;
713 end Optional_Index_Of;
715 function Others_Allowed_For
716 (Attribute : Attribute_Node_Id) return Boolean
719 if Attribute = Empty_Attribute then
722 return Attrs.Table (Attribute.Value).Others_Allowed;
724 end Others_Allowed_For;
726 -----------------------
727 -- Package_Name_List --
728 -----------------------
730 function Package_Name_List return Strings.String_List is
732 return Package_Names (1 .. Last_Package_Name);
733 end Package_Name_List;
735 ------------------------
736 -- Package_Node_Id_Of --
737 ------------------------
739 function Package_Node_Id_Of (Name : Name_Id) return Package_Node_Id is
741 for Index in Package_Attributes.First .. Package_Attributes.Last loop
742 if Package_Attributes.Table (Index).Name = Name then
743 if Package_Attributes.Table (Index).Known then
744 return (Value => Index);
746 return Unknown_Package;
751 -- If there is no package with this name, return Empty_Package
753 return Empty_Package;
754 end Package_Node_Id_Of;
756 ----------------------------
757 -- Register_New_Attribute --
758 ----------------------------
760 procedure Register_New_Attribute
762 In_Package : Package_Node_Id;
763 Attr_Kind : Defined_Attribute_Kind;
764 Var_Kind : Defined_Variable_Kind;
765 Index_Is_File_Name : Boolean := False;
766 Opt_Index : Boolean := False)
769 First_Attr : Attr_Node_Id := Empty_Attr;
770 Curr_Attr : Attr_Node_Id;
771 Real_Attr_Kind : Attribute_Kind;
774 if Name'Length = 0 then
775 Fail ("cannot register an attribute with no name");
779 if In_Package = Empty_Package then
780 Fail ("attempt to add attribute """
782 & """ to an undefined package");
786 Attr_Name := Name_Id_Of (Name);
789 Package_Attributes.Table (In_Package.Value).First_Attribute;
791 -- Check if attribute name is a duplicate
793 Curr_Attr := First_Attr;
794 while Curr_Attr /= Empty_Attr loop
795 if Attrs.Table (Curr_Attr).Name = Attr_Name then
796 Fail ("duplicate attribute name """
800 (Package_Attributes.Table (In_Package.Value).Name)
805 Curr_Attr := Attrs.Table (Curr_Attr).Next;
808 Real_Attr_Kind := Attr_Kind;
810 -- If Index_Is_File_Name, change the attribute kind if necessary
812 if Index_Is_File_Name and then not Osint.File_Names_Case_Sensitive then
814 when Associative_Array =>
815 Real_Attr_Kind := Case_Insensitive_Associative_Array;
817 when Optional_Index_Associative_Array =>
819 Optional_Index_Case_Insensitive_Associative_Array;
826 -- Add the new attribute
828 Attrs.Increment_Last;
829 Attrs.Table (Attrs.Last) :=
831 Var_Kind => Var_Kind,
832 Optional_Index => Opt_Index,
833 Attr_Kind => Real_Attr_Kind,
835 Others_Allowed => False,
838 Package_Attributes.Table (In_Package.Value).First_Attribute :=
840 end Register_New_Attribute;
842 --------------------------
843 -- Register_New_Package --
844 --------------------------
846 procedure Register_New_Package (Name : String; Id : out Package_Node_Id) is
850 if Name'Length = 0 then
851 Fail ("cannot register a package with no name");
856 Pkg_Name := Name_Id_Of (Name);
858 for Index in Package_Attributes.First .. Package_Attributes.Last loop
859 if Package_Attributes.Table (Index).Name = Pkg_Name then
860 Fail ("cannot register a package with a non unique name """
868 Package_Attributes.Increment_Last;
869 Id := (Value => Package_Attributes.Last);
870 Package_Attributes.Table (Package_Attributes.Last) :=
873 First_Attribute => Empty_Attr);
875 Add_Package_Name (Get_Name_String (Pkg_Name));
876 end Register_New_Package;
878 procedure Register_New_Package
880 Attributes : Attribute_Data_Array)
884 First_Attr : Attr_Node_Id := Empty_Attr;
885 Curr_Attr : Attr_Node_Id;
886 Attr_Kind : Attribute_Kind;
889 if Name'Length = 0 then
890 Fail ("cannot register a package with no name");
894 Pkg_Name := Name_Id_Of (Name);
896 for Index in Package_Attributes.First .. Package_Attributes.Last loop
897 if Package_Attributes.Table (Index).Name = Pkg_Name then
898 Fail ("cannot register a package with a non unique name """
905 for Index in Attributes'Range loop
906 Attr_Name := Name_Id_Of (Attributes (Index).Name);
908 Curr_Attr := First_Attr;
909 while Curr_Attr /= Empty_Attr loop
910 if Attrs.Table (Curr_Attr).Name = Attr_Name then
911 Fail ("duplicate attribute name """
912 & Attributes (Index).Name
913 & """ in new package """
919 Curr_Attr := Attrs.Table (Curr_Attr).Next;
922 Attr_Kind := Attributes (Index).Attr_Kind;
924 if Attributes (Index).Index_Is_File_Name
925 and then not Osint.File_Names_Case_Sensitive
928 when Associative_Array =>
929 Attr_Kind := Case_Insensitive_Associative_Array;
931 when Optional_Index_Associative_Array =>
933 Optional_Index_Case_Insensitive_Associative_Array;
940 Attrs.Increment_Last;
941 Attrs.Table (Attrs.Last) :=
943 Var_Kind => Attributes (Index).Var_Kind,
944 Optional_Index => Attributes (Index).Opt_Index,
945 Attr_Kind => Attr_Kind,
947 Others_Allowed => False,
949 First_Attr := Attrs.Last;
952 Package_Attributes.Increment_Last;
953 Package_Attributes.Table (Package_Attributes.Last) :=
956 First_Attribute => First_Attr);
958 Add_Package_Name (Get_Name_String (Pkg_Name));
959 end Register_New_Package;
961 ---------------------------
962 -- Set_Attribute_Kind_Of --
963 ---------------------------
965 procedure Set_Attribute_Kind_Of
966 (Attribute : Attribute_Node_Id;
970 if Attribute /= Empty_Attribute then
971 Attrs.Table (Attribute.Value).Attr_Kind := To;
973 end Set_Attribute_Kind_Of;
975 --------------------------
976 -- Set_Variable_Kind_Of --
977 --------------------------
979 procedure Set_Variable_Kind_Of
980 (Attribute : Attribute_Node_Id;
984 if Attribute /= Empty_Attribute then
985 Attrs.Table (Attribute.Value).Var_Kind := To;
987 end Set_Variable_Kind_Of;
989 ----------------------
990 -- Variable_Kind_Of --
991 ----------------------
993 function Variable_Kind_Of
994 (Attribute : Attribute_Node_Id) return Variable_Kind
997 if Attribute = Empty_Attribute then
1000 return Attrs.Table (Attribute.Value).Var_Kind;
1002 end Variable_Kind_Of;
1004 ------------------------
1005 -- First_Attribute_Of --
1006 ------------------------
1008 function First_Attribute_Of
1009 (Pkg : Package_Node_Id) return Attribute_Node_Id
1012 if Pkg = Empty_Package then
1013 return Empty_Attribute;
1016 (Value => Package_Attributes.Table (Pkg.Value).First_Attribute);
1018 end First_Attribute_Of;