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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
28 with Prj.Com; use Prj.Com;
29 with System.Case_Util; use System.Case_Util;
31 package body Prj.Attr is
33 -- Data for predefined attributes and packages
37 -- Package names are preceded by 'P'
39 -- Attribute names are preceded by two letters:
41 -- The first letter is one of
43 -- 's' for Single with optional index
45 -- 'l' for List of strings with optional indexes
47 -- The second letter is one of
48 -- 'V' for single variable
49 -- 'A' for associative array
50 -- 'a' for case insensitive associative array
51 -- 'b' for associative array, case insensitive if file names are case
53 -- 'c' same as 'b', with optional index
55 -- End is indicated by two consecutive '#'
57 Initialization_Data : constant String :=
65 "LVlocally_removed_files#" &
66 "SVsource_list_file#" &
70 "SVlibrary_version#" &
71 "LVlibrary_interface#" &
72 "SVlibrary_auto_init#" &
73 "LVlibrary_options#" &
74 "SVlibrary_src_dir#" &
75 "SVlibrary_ali_dir#" &
77 "SVlibrary_symbol_file#" &
78 "SVlibrary_symbol_policy#" &
79 "SVlibrary_reference_symbol_file#" &
84 "SVexternally_built#" &
89 "Saspecification_suffix#" &
91 "Saimplementation_suffix#" &
93 "SVseparate_suffix#" &
95 "SVdot_replacement#" &
100 "Laspecification_exceptions#" &
101 "Laimplementation_exceptions#" &
106 "Ladefault_switches#" &
108 "SVlocal_configuration_pragmas#" &
113 "Ladefault_switches#" &
116 "SVexecutable_suffix#" &
117 "SVglobal_configuration_pragmas#" &
127 "Ladefault_switches#" &
133 "Ladefault_switches#" &
135 "LVlinker_options#" &
137 -- package Cross_Reference
139 "Pcross_reference#" &
140 "Ladefault_switches#" &
146 "Ladefault_switches#" &
149 -- package Pretty_Printer
152 "Ladefault_switches#" &
158 "Ladefault_switches#" &
164 "Ladefault_switches#" &
170 "Ladefault_switches#" &
176 "Ladefault_switches#" &
182 "Ladefault_switches#" &
185 "SVcommunication_protocol#" &
186 "Sacompiler_command#" &
187 "SVdebugger_command#" &
190 "SVvcs_file_check#" &
198 -- package Language_Processing
200 "Planguage_processing#" &
201 "Lacompiler_driver#" &
203 "Ladependency_option#" &
204 "Lacompute_dependency#" &
205 "Lainclude_option#" &
207 "SVdefault_linker#" &
211 Initialized : Boolean := False;
212 -- A flag to avoid multiple initialization
214 function Name_Id_Of (Name : String) return Name_Id;
215 -- Returns the Name_Id for Name in lower case
217 -----------------------
218 -- Attribute_Kind_Of --
219 -----------------------
221 function Attribute_Kind_Of
222 (Attribute : Attribute_Node_Id) return Attribute_Kind
225 if Attribute = Empty_Attribute then
228 return Attrs.Table (Attribute.Value).Attr_Kind;
230 end Attribute_Kind_Of;
232 -----------------------
233 -- Attribute_Name_Of --
234 -----------------------
236 function Attribute_Name_Of (Attribute : Attribute_Node_Id) return Name_Id is
238 if Attribute = Empty_Attribute then
241 return Attrs.Table (Attribute.Value).Name;
243 end Attribute_Name_Of;
245 --------------------------
246 -- Attribute_Node_Id_Of --
247 --------------------------
249 function Attribute_Node_Id_Of
251 Starting_At : Attribute_Node_Id) return Attribute_Node_Id
253 Id : Attr_Node_Id := Starting_At.Value;
256 while Id /= Empty_Attr
257 and then Attrs.Table (Id).Name /= Name
259 Id := Attrs.Table (Id).Next;
262 return (Value => Id);
263 end Attribute_Node_Id_Of;
269 procedure Initialize is
270 Start : Positive := Initialization_Data'First;
271 Finish : Positive := Start;
272 Current_Package : Pkg_Node_Id := Empty_Pkg;
273 Current_Attribute : Attr_Node_Id := Empty_Attr;
274 Is_An_Attribute : Boolean := False;
275 Var_Kind : Variable_Kind := Undefined;
276 Optional_Index : Boolean := False;
277 Attr_Kind : Attribute_Kind := Single;
278 Package_Name : Name_Id := No_Name;
279 Attribute_Name : Name_Id := No_Name;
280 First_Attribute : Attr_Node_Id := Attr.First_Attribute;
282 function Attribute_Location return String;
283 -- Returns a string depending if we are in the project level attributes
284 -- or in the attributes of a package.
286 ------------------------
287 -- Attribute_Location --
288 ------------------------
290 function Attribute_Location return String is
292 if Package_Name = No_Name then
293 return "project level attributes";
296 return "attribute of package """ &
297 Get_Name_String (Package_Name) & """";
299 end Attribute_Location;
301 -- Start of processing for Initialize
304 -- Don't allow Initialize action to be repeated
310 -- Make sure the two tables are empty
313 Package_Attributes.Init;
315 while Initialization_Data (Start) /= '#' loop
316 Is_An_Attribute := True;
317 case Initialization_Data (Start) is
320 -- New allowed package
325 while Initialization_Data (Finish) /= '#' loop
326 Finish := Finish + 1;
330 Name_Id_Of (Initialization_Data (Start .. Finish - 1));
332 for Index in First_Package .. Package_Attributes.Last loop
333 if Package_Name = Package_Attributes.Table (Index).Name then
334 Osint.Fail ("duplicate name """,
335 Initialization_Data (Start .. Finish - 1),
336 """ in predefined packages.");
340 Is_An_Attribute := False;
341 Current_Attribute := Empty_Attr;
342 Package_Attributes.Increment_Last;
343 Current_Package := Package_Attributes.Last;
344 Package_Attributes.Table (Current_Package) :=
345 (Name => Package_Name,
347 First_Attribute => Empty_Attr);
352 Optional_Index := False;
356 Optional_Index := True;
360 Optional_Index := False;
364 Optional_Index := True;
370 if Is_An_Attribute then
375 case Initialization_Data (Start) is
380 Attr_Kind := Associative_Array;
383 Attr_Kind := Case_Insensitive_Associative_Array;
386 if Osint.File_Names_Case_Sensitive then
387 Attr_Kind := Associative_Array;
389 Attr_Kind := Case_Insensitive_Associative_Array;
393 if Osint.File_Names_Case_Sensitive then
394 Attr_Kind := Optional_Index_Associative_Array;
397 Optional_Index_Case_Insensitive_Associative_Array;
407 while Initialization_Data (Finish) /= '#' loop
408 Finish := Finish + 1;
412 Name_Id_Of (Initialization_Data (Start .. Finish - 1));
413 Attrs.Increment_Last;
415 if Current_Attribute = Empty_Attr then
416 First_Attribute := Attrs.Last;
418 if Current_Package /= Empty_Pkg then
419 Package_Attributes.Table (Current_Package).First_Attribute
424 -- Check that there are no duplicate attributes
426 for Index in First_Attribute .. Attrs.Last - 1 loop
427 if Attribute_Name = Attrs.Table (Index).Name then
428 Osint.Fail ("duplicate attribute """,
429 Initialization_Data (Start .. Finish - 1),
430 """ in " & Attribute_Location);
434 Attrs.Table (Current_Attribute).Next :=
438 Current_Attribute := Attrs.Last;
439 Attrs.Table (Current_Attribute) :=
440 (Name => Attribute_Name,
441 Var_Kind => Var_Kind,
442 Optional_Index => Optional_Index,
443 Attr_Kind => Attr_Kind,
456 function Name_Id_Of (Name : String) return Name_Id is
459 Add_Str_To_Name_Buffer (Name);
460 To_Lower (Name_Buffer (1 .. Name_Len));
468 function Next_Attribute
469 (After : Attribute_Node_Id) return Attribute_Node_Id
472 if After = Empty_Attribute then
473 return Empty_Attribute;
475 return (Value => Attrs.Table (After.Value).Next);
479 -----------------------
480 -- Optional_Index_Of --
481 -----------------------
483 function Optional_Index_Of (Attribute : Attribute_Node_Id) return Boolean is
485 if Attribute = Empty_Attribute then
488 return Attrs.Table (Attribute.Value).Optional_Index;
490 end Optional_Index_Of;
492 ------------------------
493 -- Package_Node_Id_Of --
494 ------------------------
496 function Package_Node_Id_Of (Name : Name_Id) return Package_Node_Id is
498 for Index in Package_Attributes.First .. Package_Attributes.Last loop
499 if Package_Attributes.Table (Index).Name = Name then
500 return (Value => Index);
504 -- If there is no package with this name, return Empty_Package
506 return Empty_Package;
507 end Package_Node_Id_Of;
509 ----------------------------
510 -- Register_New_Attribute --
511 ----------------------------
513 procedure Register_New_Attribute
515 In_Package : Package_Node_Id;
516 Attr_Kind : Defined_Attribute_Kind;
517 Var_Kind : Defined_Variable_Kind;
518 Index_Is_File_Name : Boolean := False;
519 Opt_Index : Boolean := False)
522 First_Attr : Attr_Node_Id := Empty_Attr;
523 Curr_Attr : Attr_Node_Id;
524 Real_Attr_Kind : Attribute_Kind;
527 if Name'Length = 0 then
528 Fail ("cannot register an attribute with no name");
532 if In_Package = Empty_Package then
533 Fail ("attempt to add attribute """, Name,
534 """ to an undefined package");
538 Attr_Name := Name_Id_Of (Name);
541 Package_Attributes.Table (In_Package.Value).First_Attribute;
543 -- Check if attribute name is a duplicate
545 Curr_Attr := First_Attr;
546 while Curr_Attr /= Empty_Attr loop
547 if Attrs.Table (Curr_Attr).Name = Attr_Name then
548 Fail ("duplicate attribute name """, Name,
551 (Package_Attributes.Table (In_Package.Value).Name) &
556 Curr_Attr := Attrs.Table (Curr_Attr).Next;
559 Real_Attr_Kind := Attr_Kind;
561 -- If Index_Is_File_Name, change the attribute kind if necessary
563 if Index_Is_File_Name and then not Osint.File_Names_Case_Sensitive then
565 when Associative_Array =>
566 Real_Attr_Kind := Case_Insensitive_Associative_Array;
568 when Optional_Index_Associative_Array =>
570 Optional_Index_Case_Insensitive_Associative_Array;
577 -- Add the new attribute
579 Attrs.Increment_Last;
580 Attrs.Table (Attrs.Last) :=
582 Var_Kind => Var_Kind,
583 Optional_Index => Opt_Index,
584 Attr_Kind => Real_Attr_Kind,
586 Package_Attributes.Table (In_Package.Value).First_Attribute :=
588 end Register_New_Attribute;
590 --------------------------
591 -- Register_New_Package --
592 --------------------------
594 procedure Register_New_Package (Name : String; Id : out Package_Node_Id) is
598 if Name'Length = 0 then
599 Fail ("cannot register a package with no name");
604 Pkg_Name := Name_Id_Of (Name);
606 for Index in Package_Attributes.First .. Package_Attributes.Last loop
607 if Package_Attributes.Table (Index).Name = Pkg_Name then
608 Fail ("cannot register a package with a non unique name""",
615 Package_Attributes.Increment_Last;
616 Id := (Value => Package_Attributes.Last);
617 Package_Attributes.Table (Package_Attributes.Last) :=
618 (Name => Pkg_Name, Known => True, First_Attribute => Empty_Attr);
619 end Register_New_Package;
621 procedure Register_New_Package
623 Attributes : Attribute_Data_Array)
627 First_Attr : Attr_Node_Id := Empty_Attr;
628 Curr_Attr : Attr_Node_Id;
629 Attr_Kind : Attribute_Kind;
632 if Name'Length = 0 then
633 Fail ("cannot register a package with no name");
637 Pkg_Name := Name_Id_Of (Name);
639 for Index in Package_Attributes.First .. Package_Attributes.Last loop
640 if Package_Attributes.Table (Index).Name = Pkg_Name then
641 Fail ("cannot register a package with a non unique name""",
647 for Index in Attributes'Range loop
648 Attr_Name := Name_Id_Of (Attributes (Index).Name);
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 """, Attributes (Index).Name,
654 """ in new package """ & Name & """");
658 Curr_Attr := Attrs.Table (Curr_Attr).Next;
661 Attr_Kind := Attributes (Index).Attr_Kind;
663 if Attributes (Index).Index_Is_File_Name
664 and then not Osint.File_Names_Case_Sensitive
667 when Associative_Array =>
668 Attr_Kind := Case_Insensitive_Associative_Array;
670 when Optional_Index_Associative_Array =>
672 Optional_Index_Case_Insensitive_Associative_Array;
679 Attrs.Increment_Last;
680 Attrs.Table (Attrs.Last) :=
682 Var_Kind => Attributes (Index).Var_Kind,
683 Optional_Index => Attributes (Index).Opt_Index,
684 Attr_Kind => Attr_Kind,
686 First_Attr := Attrs.Last;
689 Package_Attributes.Increment_Last;
690 Package_Attributes.Table (Package_Attributes.Last) :=
691 (Name => Pkg_Name, Known => True, First_Attribute => First_Attr);
692 end Register_New_Package;
694 ---------------------------
695 -- Set_Attribute_Kind_Of --
696 ---------------------------
698 procedure Set_Attribute_Kind_Of
699 (Attribute : Attribute_Node_Id;
703 if Attribute /= Empty_Attribute then
704 Attrs.Table (Attribute.Value).Attr_Kind := To;
706 end Set_Attribute_Kind_Of;
708 --------------------------
709 -- Set_Variable_Kind_Of --
710 --------------------------
712 procedure Set_Variable_Kind_Of
713 (Attribute : Attribute_Node_Id;
717 if Attribute /= Empty_Attribute then
718 Attrs.Table (Attribute.Value).Var_Kind := To;
720 end Set_Variable_Kind_Of;
722 ----------------------
723 -- Variable_Kind_Of --
724 ----------------------
726 function Variable_Kind_Of
727 (Attribute : Attribute_Node_Id) return Variable_Kind
730 if Attribute = Empty_Attribute then
733 return Attrs.Table (Attribute.Value).Var_Kind;
735 end Variable_Kind_Of;
737 ------------------------
738 -- First_Attribute_Of --
739 ------------------------
741 function First_Attribute_Of
742 (Pkg : Package_Node_Id) return Attribute_Node_Id
745 if Pkg = Empty_Package then
746 return Empty_Attribute;
749 (Value => Package_Attributes.Table (Pkg.Value).First_Attribute);
751 end First_Attribute_Of;