1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2004 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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, 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 ------------------------------------------------------------------------------
27 with Namet; use Namet;
29 with Prj.Com; use Prj.Com;
32 with System.Case_Util; use System.Case_Util;
34 package body Prj.Attr is
36 -- Data for predefined attributes and packages
40 -- Package names are preceded by 'P'
42 -- Attribute names are preceded by two letters:
44 -- The first letter is one of
46 -- 's' for Single with optional index
48 -- 'l' for List of strings with optional indexes
50 -- The second letter is one of
51 -- 'V' for single variable
52 -- 'A' for associative array
53 -- 'a' for case insensitive associative array
54 -- 'b' for associative array, case insensitive if file names are case
56 -- 'c' same as 'b', with optional index
58 -- End is indicated by two consecutive '#'.
60 Initialization_Data : constant String :=
68 "LVlocally_removed_files#" &
69 "SVsource_list_file#" &
73 "SVlibrary_version#" &
74 "LVlibrary_interface#" &
75 "SVlibrary_auto_init#" &
76 "LVlibrary_options#" &
77 "SVlibrary_src_dir#" &
79 "SVlibrary_symbol_file#" &
80 "SVlibrary_symbol_policy#" &
81 "SVlibrary_reference_symbol_file#" &
86 "SVexternally_built#" &
91 "Saspecification_suffix#" &
93 "Saimplementation_suffix#" &
95 "SVseparate_suffix#" &
97 "SVdot_replacement#" &
100 "sAimplementation#" &
102 "Laspecification_exceptions#" &
103 "Laimplementation_exceptions#" &
108 "Ladefault_switches#" &
110 "SVlocal_configuration_pragmas#" &
115 "Ladefault_switches#" &
118 "SVexecutable_suffix#" &
119 "SVglobal_configuration_pragmas#" &
129 "Ladefault_switches#" &
135 "Ladefault_switches#" &
137 "LVlinker_options#" &
139 -- package Cross_Reference
141 "Pcross_reference#" &
142 "Ladefault_switches#" &
148 "Ladefault_switches#" &
151 -- package Pretty_Printer
154 "Ladefault_switches#" &
160 "Ladefault_switches#" &
166 "Ladefault_switches#" &
172 "Ladefault_switches#" &
178 "Ladefault_switches#" &
181 "SVcommunication_protocol#" &
182 "Sacompiler_command#" &
183 "SVdebugger_command#" &
186 "SVvcs_file_check#" &
189 -- package Language_Processing
191 "Planguage_processing#" &
192 "Lacompiler_driver#" &
194 "Ladependency_option#" &
195 "Lacompute_dependency#" &
196 "Lainclude_option#" &
198 "SVdefault_linker#" &
202 Initialized : Boolean := False;
203 -- A flag to avoid multiple initialization
205 function Name_Id_Of (Name : String) return Name_Id;
206 -- Returns the Name_Id for Name in lower case
208 -----------------------
209 -- Attribute_Kind_Of --
210 -----------------------
212 function Attribute_Kind_Of
213 (Attribute : Attribute_Node_Id) return Attribute_Kind
216 if Attribute = Empty_Attribute then
219 return Attrs.Table (Attribute.Value).Attr_Kind;
221 end Attribute_Kind_Of;
223 -----------------------
224 -- Attribute_Name_Of --
225 -----------------------
227 function Attribute_Name_Of (Attribute : Attribute_Node_Id) return Name_Id is
229 if Attribute = Empty_Attribute then
232 return Attrs.Table (Attribute.Value).Name;
234 end Attribute_Name_Of;
236 --------------------------
237 -- Attribute_Node_Id_Of --
238 --------------------------
240 function Attribute_Node_Id_Of
242 Starting_At : Attribute_Node_Id) return Attribute_Node_Id
244 Id : Attr_Node_Id := Starting_At.Value;
247 while Id /= Empty_Attr
248 and then Attrs.Table (Id).Name /= Name
250 Id := Attrs.Table (Id).Next;
253 return (Value => Id);
254 end Attribute_Node_Id_Of;
260 procedure Initialize is
261 Start : Positive := Initialization_Data'First;
262 Finish : Positive := Start;
263 Current_Package : Pkg_Node_Id := Empty_Pkg;
264 Current_Attribute : Attr_Node_Id := Empty_Attr;
265 Is_An_Attribute : Boolean := False;
266 Var_Kind : Variable_Kind := Undefined;
267 Optional_Index : Boolean := False;
268 Attr_Kind : Attribute_Kind := Single;
269 Package_Name : Name_Id := No_Name;
270 Attribute_Name : Name_Id := No_Name;
271 First_Attribute : Attr_Node_Id := Attr.First_Attribute;
273 function Attribute_Location return String;
274 -- Returns a string depending if we are in the project level attributes
275 -- or in the attributes of a package.
277 ------------------------
278 -- Attribute_Location --
279 ------------------------
281 function Attribute_Location return String is
283 if Package_Name = No_Name then
284 return "project level attributes";
287 return "attribute of package """ &
288 Get_Name_String (Package_Name) & """";
290 end Attribute_Location;
292 -- Start of processing for Initialize
295 -- Don't allow Initialize action to be repeated
301 -- Make sure the two tables are empty
304 Package_Attributes.Init;
306 while Initialization_Data (Start) /= '#' loop
307 Is_An_Attribute := True;
308 case Initialization_Data (Start) is
311 -- New allowed package
316 while Initialization_Data (Finish) /= '#' loop
317 Finish := Finish + 1;
321 Name_Id_Of (Initialization_Data (Start .. Finish - 1));
323 for Index in First_Package .. Package_Attributes.Last loop
324 if Package_Name = Package_Attributes.Table (Index).Name then
325 Osint.Fail ("duplicate name """,
326 Initialization_Data (Start .. Finish - 1),
327 """ in predefined packages.");
331 Is_An_Attribute := False;
332 Current_Attribute := Empty_Attr;
333 Package_Attributes.Increment_Last;
334 Current_Package := Package_Attributes.Last;
335 Package_Attributes.Table (Current_Package) :=
336 (Name => Package_Name,
338 First_Attribute => Empty_Attr);
343 Optional_Index := False;
347 Optional_Index := True;
351 Optional_Index := False;
355 Optional_Index := True;
361 if Is_An_Attribute then
366 case Initialization_Data (Start) is
371 Attr_Kind := Associative_Array;
374 Attr_Kind := Case_Insensitive_Associative_Array;
377 if Osint.File_Names_Case_Sensitive then
378 Attr_Kind := Associative_Array;
380 Attr_Kind := Case_Insensitive_Associative_Array;
384 if Osint.File_Names_Case_Sensitive then
385 Attr_Kind := Optional_Index_Associative_Array;
388 Optional_Index_Case_Insensitive_Associative_Array;
398 while Initialization_Data (Finish) /= '#' loop
399 Finish := Finish + 1;
403 Name_Id_Of (Initialization_Data (Start .. Finish - 1));
404 Attrs.Increment_Last;
406 if Current_Attribute = Empty_Attr then
407 First_Attribute := Attrs.Last;
409 if Current_Package /= Empty_Pkg then
410 Package_Attributes.Table (Current_Package).First_Attribute
415 -- Check that there are no duplicate attributes
417 for Index in First_Attribute .. Attrs.Last - 1 loop
418 if Attribute_Name = Attrs.Table (Index).Name then
419 Osint.Fail ("duplicate attribute """,
420 Initialization_Data (Start .. Finish - 1),
421 """ in " & Attribute_Location);
425 Attrs.Table (Current_Attribute).Next :=
429 Current_Attribute := Attrs.Last;
430 Attrs.Table (Current_Attribute) :=
431 (Name => Attribute_Name,
432 Var_Kind => Var_Kind,
433 Optional_Index => Optional_Index,
434 Attr_Kind => Attr_Kind,
447 function Name_Id_Of (Name : String) return Name_Id is
450 Add_Str_To_Name_Buffer (Name);
451 To_Lower (Name_Buffer (1 .. Name_Len));
459 function Next_Attribute
460 (After : Attribute_Node_Id) return Attribute_Node_Id
463 if After = Empty_Attribute then
464 return Empty_Attribute;
466 return (Value => Attrs.Table (After.Value).Next);
470 -----------------------
471 -- Optional_Index_Of --
472 -----------------------
474 function Optional_Index_Of (Attribute : Attribute_Node_Id) return Boolean is
476 if Attribute = Empty_Attribute then
479 return Attrs.Table (Attribute.Value).Optional_Index;
481 end Optional_Index_Of;
483 ------------------------
484 -- Package_Node_Id_Of --
485 ------------------------
487 function Package_Node_Id_Of (Name : Name_Id) return Package_Node_Id is
489 for Index in Package_Attributes.First .. Package_Attributes.Last loop
490 if Package_Attributes.Table (Index).Name = Name then
491 return (Value => Index);
495 -- If there is no package with this name, return Empty_Package
497 return Empty_Package;
498 end Package_Node_Id_Of;
500 ----------------------------
501 -- Register_New_Attribute --
502 ----------------------------
504 procedure Register_New_Attribute
506 In_Package : Package_Node_Id;
507 Attr_Kind : Defined_Attribute_Kind;
508 Var_Kind : Defined_Variable_Kind;
509 Index_Is_File_Name : Boolean := False;
510 Opt_Index : Boolean := False)
513 First_Attr : Attr_Node_Id := Empty_Attr;
514 Curr_Attr : Attr_Node_Id;
515 Real_Attr_Kind : Attribute_Kind;
518 if Name'Length = 0 then
519 Fail ("cannot register an attribute with no name");
523 if In_Package = Empty_Package then
524 Fail ("attempt to add attribute """, Name,
525 """ to an undefined package");
529 Attr_Name := Name_Id_Of (Name);
532 Package_Attributes.Table (In_Package.Value).First_Attribute;
534 -- Check if attribute name is a duplicate
536 Curr_Attr := First_Attr;
537 while Curr_Attr /= Empty_Attr loop
538 if Attrs.Table (Curr_Attr).Name = Attr_Name then
539 Fail ("duplicate attribute name """, Name,
542 (Package_Attributes.Table (In_Package.Value).Name) &
547 Curr_Attr := Attrs.Table (Curr_Attr).Next;
550 Real_Attr_Kind := Attr_Kind;
552 -- If Index_Is_File_Name, change the attribute kind if necessary
554 if Index_Is_File_Name and then not Osint.File_Names_Case_Sensitive then
556 when Associative_Array =>
557 Real_Attr_Kind := Case_Insensitive_Associative_Array;
559 when Optional_Index_Associative_Array =>
561 Optional_Index_Case_Insensitive_Associative_Array;
568 -- Add the new attribute
570 Attrs.Increment_Last;
571 Attrs.Table (Attrs.Last) :=
573 Var_Kind => Var_Kind,
574 Optional_Index => Opt_Index,
575 Attr_Kind => Real_Attr_Kind,
577 Package_Attributes.Table (In_Package.Value).First_Attribute :=
579 end Register_New_Attribute;
581 --------------------------
582 -- Register_New_Package --
583 --------------------------
585 procedure Register_New_Package (Name : String; Id : out Package_Node_Id) is
589 if Name'Length = 0 then
590 Fail ("cannot register a package with no name");
595 Pkg_Name := Name_Id_Of (Name);
597 for Index in Package_Attributes.First .. Package_Attributes.Last loop
598 if Package_Attributes.Table (Index).Name = Pkg_Name then
599 Fail ("cannot register a package with a non unique name""",
606 Package_Attributes.Increment_Last;
607 Id := (Value => Package_Attributes.Last);
608 Package_Attributes.Table (Package_Attributes.Last) :=
609 (Name => Pkg_Name, Known => True, First_Attribute => Empty_Attr);
610 end Register_New_Package;
612 procedure Register_New_Package
614 Attributes : Attribute_Data_Array)
618 First_Attr : Attr_Node_Id := Empty_Attr;
619 Curr_Attr : Attr_Node_Id;
620 Attr_Kind : Attribute_Kind;
623 if Name'Length = 0 then
624 Fail ("cannot register a package with no name");
628 Pkg_Name := Name_Id_Of (Name);
630 for Index in Package_Attributes.First .. Package_Attributes.Last loop
631 if Package_Attributes.Table (Index).Name = Pkg_Name then
632 Fail ("cannot register a package with a non unique name""",
638 for Index in Attributes'Range loop
639 Attr_Name := Name_Id_Of (Attributes (Index).Name);
641 Curr_Attr := First_Attr;
642 while Curr_Attr /= Empty_Attr loop
643 if Attrs.Table (Curr_Attr).Name = Attr_Name then
644 Fail ("duplicate attribute name """, Attributes (Index).Name,
645 """ in new package """ & Name & """");
649 Curr_Attr := Attrs.Table (Curr_Attr).Next;
652 Attr_Kind := Attributes (Index).Attr_Kind;
654 if Attributes (Index).Index_Is_File_Name
655 and then not Osint.File_Names_Case_Sensitive
658 when Associative_Array =>
659 Attr_Kind := Case_Insensitive_Associative_Array;
661 when Optional_Index_Associative_Array =>
663 Optional_Index_Case_Insensitive_Associative_Array;
670 Attrs.Increment_Last;
671 Attrs.Table (Attrs.Last) :=
673 Var_Kind => Attributes (Index).Var_Kind,
674 Optional_Index => Attributes (Index).Opt_Index,
675 Attr_Kind => Attr_Kind,
677 First_Attr := Attrs.Last;
680 Package_Attributes.Increment_Last;
681 Package_Attributes.Table (Package_Attributes.Last) :=
682 (Name => Pkg_Name, Known => True, First_Attribute => First_Attr);
683 end Register_New_Package;
685 ---------------------------
686 -- Set_Attribute_Kind_Of --
687 ---------------------------
689 procedure Set_Attribute_Kind_Of
690 (Attribute : Attribute_Node_Id;
694 if Attribute /= Empty_Attribute then
695 Attrs.Table (Attribute.Value).Attr_Kind := To;
697 end Set_Attribute_Kind_Of;
699 --------------------------
700 -- Set_Variable_Kind_Of --
701 --------------------------
703 procedure Set_Variable_Kind_Of
704 (Attribute : Attribute_Node_Id;
708 if Attribute /= Empty_Attribute then
709 Attrs.Table (Attribute.Value).Var_Kind := To;
711 end Set_Variable_Kind_Of;
713 ----------------------
714 -- Variable_Kind_Of --
715 ----------------------
717 function Variable_Kind_Of
718 (Attribute : Attribute_Node_Id) return Variable_Kind
721 if Attribute = Empty_Attribute then
724 return Attrs.Table (Attribute.Value).Var_Kind;
726 end Variable_Kind_Of;
728 ------------------------
729 -- First_Attribute_Of --
730 ------------------------
732 function First_Attribute_Of
733 (Pkg : Package_Node_Id) return Attribute_Node_Id
736 if Pkg = Empty_Package then
737 return Empty_Attribute;
740 (Value => Package_Attributes.Table (Pkg.Value).First_Attribute);
742 end First_Attribute_Of;