1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2007, 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;
28 with System.Case_Util; use System.Case_Util;
30 package body Prj.Attr is
32 -- Data for predefined attributes and packages
34 -- Names are in lower case and end with '#'
36 -- Package names are preceded by 'P'
38 -- Attribute names are preceded by two or three letters:
40 -- The first letter is one of
42 -- 's' for Single with optional index
44 -- 'l' for List of strings with optional indexes
46 -- The second letter is one of
47 -- 'V' for single variable
48 -- 'A' for associative array
49 -- 'a' for case insensitive associative array
50 -- 'b' for associative array, case insensitive if file names are case
52 -- 'c' same as 'b', with optional index
54 -- The third optional letter is
55 -- 'R' to indicate that the attribute is read-only
57 -- End is indicated by two consecutive '#'
59 Initialization_Data : constant String :=
61 -- project level attributes
70 "SVexternally_built#" &
77 "LVexcluded_source_dirs#" &
82 "LVlocally_removed_files#" &
83 "LVexcluded_source_files#" &
84 "SVsource_list_file#" &
91 "SVlibrary_version#" &
92 "LVlibrary_interface#" &
93 "SVlibrary_auto_init#" &
94 "LVlibrary_options#" &
95 "SVlibrary_src_dir#" &
96 "SVlibrary_ali_dir#" &
98 "SVlibrary_symbol_file#" &
99 "SVlibrary_symbol_policy#" &
100 "SVlibrary_reference_symbol_file#" &
102 -- Configuration - General
104 "SVdefault_language#" &
105 "LVrun_path_option#" &
106 "Satoolchain_version#" &
107 "Satoolchain_description#" &
109 -- Configuration - Libraries
111 "SVlibrary_builder#" &
112 "SVlibrary_support#" &
114 -- Configuration - Archives
116 "LVarchive_builder#" &
117 "LVarchive_indexer#" &
118 "SVarchive_suffix#" &
119 "LVlibrary_partial_linker#" &
121 -- Configuration - Shared libraries
123 "SVshared_library_prefix#" &
124 "SVshared_library_suffix#" &
125 "SVsymbolic_link_supported#" &
126 "SVlibrary_major_minor_id_supported#" &
127 "SVlibrary_auto_init_supported#" &
128 "LVshared_library_minimum_switches#" &
129 "LVlibrary_version_switches#" &
130 "Saruntime_library_dir#" &
135 "Saspecification_suffix#" &
137 "Saimplementation_suffix#" &
139 "SVseparate_suffix#" &
141 "SVdot_replacement#" &
144 "sAimplementation#" &
146 "Laspecification_exceptions#" &
147 "Laimplementation_exceptions#" &
152 "Ladefault_switches#" &
154 "SVlocal_configuration_pragmas#" &
155 "Salocal_config_file#" &
157 -- Configuration - Compiling
160 "Larequired_switches#" &
163 -- Configuration - Mapping files
165 "Lamapping_file_switches#" &
166 "Samapping_spec_suffix#" &
167 "Samapping_body_suffix#" &
169 -- Configuration - Config files
171 "Laconfig_file_switches#" &
172 "Saconfig_body_file_name#" &
173 "Saconfig_spec_file_name#" &
174 "Saconfig_body_file_name_pattern#" &
175 "Saconfig_spec_file_name_pattern#" &
176 "Saconfig_file_unique#" &
178 -- Configuration - Dependencies
180 "Ladependency_switches#" &
181 "Ladependency_driver#" &
183 -- Configuration - Search paths
185 "Lainclude_switches#" &
187 "Sainclude_path_file#" &
192 "Ladefault_switches#" &
195 "SVexecutable_suffix#" &
196 "SVglobal_configuration_pragmas#" &
197 "Saglobal_config_file#" &
207 "Ladefault_switches#" &
210 -- Configuration - Binding
213 "Larequired_switches#" &
216 "Saobjects_path_file#" &
221 "LVrequired_switches#" &
222 "Ladefault_switches#" &
224 "LVlinker_options#" &
226 -- Configuration - Linking
229 "LVexecutable_switch#" &
230 "SVlib_dir_switch#" &
231 "SVlib_name_switch#" &
233 -- package Cross_Reference
235 "Pcross_reference#" &
236 "Ladefault_switches#" &
242 "Ladefault_switches#" &
245 -- package Pretty_Printer
248 "Ladefault_switches#" &
254 "Ladefault_switches#" &
260 "Ladefault_switches#" &
266 "Ladefault_switches#" &
272 "Ladefault_switches#" &
278 "Ladefault_switches#" &
281 "SVcommunication_protocol#" &
282 "Sacompiler_command#" &
283 "SVdebugger_command#" &
286 "SVvcs_file_check#" &
296 Initialized : Boolean := False;
297 -- A flag to avoid multiple initialization
299 function Name_Id_Of (Name : String) return Name_Id;
300 -- Returns the Name_Id for Name in lower case
302 -----------------------
303 -- Attribute_Kind_Of --
304 -----------------------
306 function Attribute_Kind_Of
307 (Attribute : Attribute_Node_Id) return Attribute_Kind
310 if Attribute = Empty_Attribute then
313 return Attrs.Table (Attribute.Value).Attr_Kind;
315 end Attribute_Kind_Of;
317 -----------------------
318 -- Attribute_Name_Of --
319 -----------------------
321 function Attribute_Name_Of (Attribute : Attribute_Node_Id) return Name_Id is
323 if Attribute = Empty_Attribute then
326 return Attrs.Table (Attribute.Value).Name;
328 end Attribute_Name_Of;
330 --------------------------
331 -- Attribute_Node_Id_Of --
332 --------------------------
334 function Attribute_Node_Id_Of
336 Starting_At : Attribute_Node_Id) return Attribute_Node_Id
338 Id : Attr_Node_Id := Starting_At.Value;
341 while Id /= Empty_Attr
342 and then Attrs.Table (Id).Name /= Name
344 Id := Attrs.Table (Id).Next;
347 return (Value => Id);
348 end Attribute_Node_Id_Of;
354 procedure Initialize is
355 Start : Positive := Initialization_Data'First;
356 Finish : Positive := Start;
357 Current_Package : Pkg_Node_Id := Empty_Pkg;
358 Current_Attribute : Attr_Node_Id := Empty_Attr;
359 Is_An_Attribute : Boolean := False;
360 Var_Kind : Variable_Kind := Undefined;
361 Optional_Index : Boolean := False;
362 Attr_Kind : Attribute_Kind := Single;
363 Package_Name : Name_Id := No_Name;
364 Attribute_Name : Name_Id := No_Name;
365 First_Attribute : Attr_Node_Id := Attr.First_Attribute;
368 function Attribute_Location return String;
369 -- Returns a string depending if we are in the project level attributes
370 -- or in the attributes of a package.
372 ------------------------
373 -- Attribute_Location --
374 ------------------------
376 function Attribute_Location return String is
378 if Package_Name = No_Name then
379 return "project level attributes";
382 return "attribute of package """ &
383 Get_Name_String (Package_Name) & """";
385 end Attribute_Location;
387 -- Start of processing for Initialize
390 -- Don't allow Initialize action to be repeated
396 -- Make sure the two tables are empty
399 Package_Attributes.Init;
401 while Initialization_Data (Start) /= '#' loop
402 Is_An_Attribute := True;
403 case Initialization_Data (Start) is
406 -- New allowed package
411 while Initialization_Data (Finish) /= '#' loop
412 Finish := Finish + 1;
416 Name_Id_Of (Initialization_Data (Start .. Finish - 1));
418 for Index in First_Package .. Package_Attributes.Last loop
419 if Package_Name = Package_Attributes.Table (Index).Name then
420 Osint.Fail ("duplicate name """,
421 Initialization_Data (Start .. Finish - 1),
422 """ in predefined packages.");
426 Is_An_Attribute := False;
427 Current_Attribute := Empty_Attr;
428 Package_Attributes.Increment_Last;
429 Current_Package := Package_Attributes.Last;
430 Package_Attributes.Table (Current_Package) :=
431 (Name => Package_Name,
433 First_Attribute => Empty_Attr);
438 Optional_Index := False;
442 Optional_Index := True;
446 Optional_Index := False;
450 Optional_Index := True;
456 if Is_An_Attribute then
461 case Initialization_Data (Start) is
466 Attr_Kind := Associative_Array;
469 Attr_Kind := Case_Insensitive_Associative_Array;
472 if Osint.File_Names_Case_Sensitive then
473 Attr_Kind := Associative_Array;
475 Attr_Kind := Case_Insensitive_Associative_Array;
479 if Osint.File_Names_Case_Sensitive then
480 Attr_Kind := Optional_Index_Associative_Array;
483 Optional_Index_Case_Insensitive_Associative_Array;
492 if Initialization_Data (Start) = 'R' then
502 while Initialization_Data (Finish) /= '#' loop
503 Finish := Finish + 1;
507 Name_Id_Of (Initialization_Data (Start .. Finish - 1));
508 Attrs.Increment_Last;
510 if Current_Attribute = Empty_Attr then
511 First_Attribute := Attrs.Last;
513 if Current_Package /= Empty_Pkg then
514 Package_Attributes.Table (Current_Package).First_Attribute
519 -- Check that there are no duplicate attributes
521 for Index in First_Attribute .. Attrs.Last - 1 loop
522 if Attribute_Name = Attrs.Table (Index).Name then
523 Osint.Fail ("duplicate attribute """,
524 Initialization_Data (Start .. Finish - 1),
525 """ in " & Attribute_Location);
529 Attrs.Table (Current_Attribute).Next :=
533 Current_Attribute := Attrs.Last;
534 Attrs.Table (Current_Attribute) :=
535 (Name => Attribute_Name,
536 Var_Kind => Var_Kind,
537 Optional_Index => Optional_Index,
538 Attr_Kind => Attr_Kind,
539 Read_Only => Read_Only,
552 function Is_Read_Only (Attribute : Attribute_Node_Id) return Boolean is
554 return Attrs.Table (Attribute.Value).Read_Only;
561 function Name_Id_Of (Name : String) return Name_Id is
564 Add_Str_To_Name_Buffer (Name);
565 To_Lower (Name_Buffer (1 .. Name_Len));
573 function Next_Attribute
574 (After : Attribute_Node_Id) return Attribute_Node_Id
577 if After = Empty_Attribute then
578 return Empty_Attribute;
580 return (Value => Attrs.Table (After.Value).Next);
584 -----------------------
585 -- Optional_Index_Of --
586 -----------------------
588 function Optional_Index_Of (Attribute : Attribute_Node_Id) return Boolean is
590 if Attribute = Empty_Attribute then
593 return Attrs.Table (Attribute.Value).Optional_Index;
595 end Optional_Index_Of;
597 ------------------------
598 -- Package_Node_Id_Of --
599 ------------------------
601 function Package_Node_Id_Of (Name : Name_Id) return Package_Node_Id is
603 for Index in Package_Attributes.First .. Package_Attributes.Last loop
604 if Package_Attributes.Table (Index).Name = Name then
605 return (Value => Index);
609 -- If there is no package with this name, return Empty_Package
611 return Empty_Package;
612 end Package_Node_Id_Of;
614 ----------------------------
615 -- Register_New_Attribute --
616 ----------------------------
618 procedure Register_New_Attribute
620 In_Package : Package_Node_Id;
621 Attr_Kind : Defined_Attribute_Kind;
622 Var_Kind : Defined_Variable_Kind;
623 Index_Is_File_Name : Boolean := False;
624 Opt_Index : Boolean := False)
627 First_Attr : Attr_Node_Id := Empty_Attr;
628 Curr_Attr : Attr_Node_Id;
629 Real_Attr_Kind : Attribute_Kind;
632 if Name'Length = 0 then
633 Fail ("cannot register an attribute with no name");
637 if In_Package = Empty_Package then
638 Fail ("attempt to add attribute """, Name,
639 """ to an undefined package");
643 Attr_Name := Name_Id_Of (Name);
646 Package_Attributes.Table (In_Package.Value).First_Attribute;
648 -- Check if attribute name is a duplicate
650 Curr_Attr := First_Attr;
651 while Curr_Attr /= Empty_Attr loop
652 if Attrs.Table (Curr_Attr).Name = Attr_Name then
653 Fail ("duplicate attribute name """, Name,
656 (Package_Attributes.Table (In_Package.Value).Name) &
661 Curr_Attr := Attrs.Table (Curr_Attr).Next;
664 Real_Attr_Kind := Attr_Kind;
666 -- If Index_Is_File_Name, change the attribute kind if necessary
668 if Index_Is_File_Name and then not Osint.File_Names_Case_Sensitive then
670 when Associative_Array =>
671 Real_Attr_Kind := Case_Insensitive_Associative_Array;
673 when Optional_Index_Associative_Array =>
675 Optional_Index_Case_Insensitive_Associative_Array;
682 -- Add the new attribute
684 Attrs.Increment_Last;
685 Attrs.Table (Attrs.Last) :=
687 Var_Kind => Var_Kind,
688 Optional_Index => Opt_Index,
689 Attr_Kind => Real_Attr_Kind,
692 Package_Attributes.Table (In_Package.Value).First_Attribute :=
694 end Register_New_Attribute;
696 --------------------------
697 -- Register_New_Package --
698 --------------------------
700 procedure Register_New_Package (Name : String; Id : out Package_Node_Id) is
704 if Name'Length = 0 then
705 Fail ("cannot register a package with no name");
710 Pkg_Name := Name_Id_Of (Name);
712 for Index in Package_Attributes.First .. Package_Attributes.Last loop
713 if Package_Attributes.Table (Index).Name = Pkg_Name then
714 Fail ("cannot register a package with a non unique name""",
721 Package_Attributes.Increment_Last;
722 Id := (Value => Package_Attributes.Last);
723 Package_Attributes.Table (Package_Attributes.Last) :=
726 First_Attribute => Empty_Attr);
727 end Register_New_Package;
729 procedure Register_New_Package
731 Attributes : Attribute_Data_Array)
735 First_Attr : Attr_Node_Id := Empty_Attr;
736 Curr_Attr : Attr_Node_Id;
737 Attr_Kind : Attribute_Kind;
740 if Name'Length = 0 then
741 Fail ("cannot register a package with no name");
745 Pkg_Name := Name_Id_Of (Name);
747 for Index in Package_Attributes.First .. Package_Attributes.Last loop
748 if Package_Attributes.Table (Index).Name = Pkg_Name then
749 Fail ("cannot register a package with a non unique name""",
755 for Index in Attributes'Range loop
756 Attr_Name := Name_Id_Of (Attributes (Index).Name);
758 Curr_Attr := First_Attr;
759 while Curr_Attr /= Empty_Attr loop
760 if Attrs.Table (Curr_Attr).Name = Attr_Name then
761 Fail ("duplicate attribute name """, Attributes (Index).Name,
762 """ in new package """ & Name & """");
766 Curr_Attr := Attrs.Table (Curr_Attr).Next;
769 Attr_Kind := Attributes (Index).Attr_Kind;
771 if Attributes (Index).Index_Is_File_Name
772 and then not Osint.File_Names_Case_Sensitive
775 when Associative_Array =>
776 Attr_Kind := Case_Insensitive_Associative_Array;
778 when Optional_Index_Associative_Array =>
780 Optional_Index_Case_Insensitive_Associative_Array;
787 Attrs.Increment_Last;
788 Attrs.Table (Attrs.Last) :=
790 Var_Kind => Attributes (Index).Var_Kind,
791 Optional_Index => Attributes (Index).Opt_Index,
792 Attr_Kind => Attr_Kind,
795 First_Attr := Attrs.Last;
798 Package_Attributes.Increment_Last;
799 Package_Attributes.Table (Package_Attributes.Last) :=
802 First_Attribute => First_Attr);
803 end Register_New_Package;
805 ---------------------------
806 -- Set_Attribute_Kind_Of --
807 ---------------------------
809 procedure Set_Attribute_Kind_Of
810 (Attribute : Attribute_Node_Id;
814 if Attribute /= Empty_Attribute then
815 Attrs.Table (Attribute.Value).Attr_Kind := To;
817 end Set_Attribute_Kind_Of;
819 --------------------------
820 -- Set_Variable_Kind_Of --
821 --------------------------
823 procedure Set_Variable_Kind_Of
824 (Attribute : Attribute_Node_Id;
828 if Attribute /= Empty_Attribute then
829 Attrs.Table (Attribute.Value).Var_Kind := To;
831 end Set_Variable_Kind_Of;
833 ----------------------
834 -- Variable_Kind_Of --
835 ----------------------
837 function Variable_Kind_Of
838 (Attribute : Attribute_Node_Id) return Variable_Kind
841 if Attribute = Empty_Attribute then
844 return Attrs.Table (Attribute.Value).Var_Kind;
846 end Variable_Kind_Of;
848 ------------------------
849 -- First_Attribute_Of --
850 ------------------------
852 function First_Attribute_Of
853 (Pkg : Package_Node_Id) return Attribute_Node_Id
856 if Pkg = Empty_Package then
857 return Empty_Attribute;
860 (Value => Package_Attributes.Table (Pkg.Value).First_Attribute);
862 end First_Attribute_Of;