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 Err_Vars; use Err_Vars;
28 with Namet; use Namet;
30 with Osint; use Osint;
31 with Output; use Output;
32 with Prj.Attr; use Prj.Attr;
33 with Prj.Com; use Prj.Com;
34 with Prj.Err; use Prj.Err;
35 with Prj.Ext; use Prj.Ext;
36 with Prj.Nmsc; use Prj.Nmsc;
39 with GNAT.Case_Util; use GNAT.Case_Util;
42 package body Prj.Proc is
44 Error_Report : Put_Line_Access := null;
46 package Processed_Projects is new GNAT.HTable.Simple_HTable
47 (Header_Num => Header_Num,
48 Element => Project_Id,
49 No_Element => No_Project,
53 -- This hash table contains all processed projects
55 procedure Add (To_Exp : in out Name_Id; Str : Name_Id);
56 -- Concatenate two strings and returns another string if both
57 -- arguments are not null string.
59 procedure Add_Attributes
60 (Project : Project_Id;
61 Decl : in out Declarations;
62 First : Attribute_Node_Id);
63 -- Add all attributes, starting with First, with their default
64 -- values to the package or project with declarations Decl.
67 (Project : in out Project_Id;
68 Process_Languages : Languages_Processed;
69 Follow_Links : Boolean);
70 -- Set all projects to not checked, then call Recursive_Check for the
71 -- main project Project. Project is set to No_Project if errors occurred.
72 -- See Prj.Nmsc.Ada_Check for information on Follow_Links.
75 (Project : Project_Id;
76 From_Project_Node : Project_Node_Id;
78 First_Term : Project_Node_Id;
79 Kind : Variable_Kind) return Variable_Value;
80 -- From N_Expression project node From_Project_Node, compute the value
81 -- of an expression and return it as a Variable_Value.
83 function Imported_Or_Extended_Project_From
84 (Project : Project_Id;
85 With_Name : Name_Id) return Project_Id;
86 -- Find an imported or extended project of Project whose name is With_Name
89 (Project : Project_Id;
90 With_Name : Name_Id) return Package_Id;
91 -- Find the package of Project whose name is With_Name
93 procedure Process_Declarative_Items
94 (Project : Project_Id;
95 From_Project_Node : Project_Node_Id;
97 Item : Project_Node_Id);
98 -- Process declarative items starting with From_Project_Node, and put them
99 -- in declarations Decl. This is a recursive procedure; it calls itself for
100 -- a package declaration or a case construction.
102 procedure Recursive_Process
103 (Project : out Project_Id;
104 From_Project_Node : Project_Node_Id;
105 Extended_By : Project_Id);
106 -- Process project with node From_Project_Node in the tree.
107 -- Do nothing if From_Project_Node is Empty_Node.
108 -- If project has already been processed, simply return its project id.
109 -- Otherwise create a new project id, mark it as processed, call itself
110 -- recursively for all imported projects and a extended project, if any.
111 -- Then process the declarative items of the project.
113 procedure Recursive_Check
114 (Project : Project_Id;
115 Process_Languages : Languages_Processed;
116 Follow_Links : Boolean);
117 -- If Project is not marked as checked, mark it as checked, call
118 -- Check_Naming_Scheme for the project, then call itself for a
119 -- possible extended project and all the imported projects of Project.
120 -- See Prj.Nmsc.Ada_Check for information on Follow_Links
126 procedure Add (To_Exp : in out Name_Id; Str : Name_Id) is
128 if To_Exp = Types.No_Name or else To_Exp = Empty_String then
130 -- To_Exp is nil or empty. The result is Str.
134 -- If Str is nil, then do not change To_Ext
136 elsif Str /= No_Name and then Str /= Empty_String then
138 S : constant String := Get_Name_String (Str);
141 Get_Name_String (To_Exp);
142 Add_Str_To_Name_Buffer (S);
152 procedure Add_Attributes
153 (Project : Project_Id;
154 Decl : in out Declarations;
155 First : Attribute_Node_Id)
157 The_Attribute : Attribute_Node_Id := First;
160 while The_Attribute /= Empty_Attribute loop
161 if Attribute_Kind_Of (The_Attribute) = Single then
163 New_Attribute : Variable_Value;
166 case Variable_Kind_Of (The_Attribute) is
168 -- Undefined should not happen
172 (False, "attribute with an undefined kind");
175 -- Single attributes have a default value of empty string
181 Location => No_Location,
183 Value => Empty_String,
186 -- List attributes have a default value of nil list
192 Location => No_Location,
194 Values => Nil_String);
198 Variable_Elements.Increment_Last;
199 Variable_Elements.Table (Variable_Elements.Last) :=
200 (Next => Decl.Attributes,
201 Name => Attribute_Name_Of (The_Attribute),
202 Value => New_Attribute);
203 Decl.Attributes := Variable_Elements.Last;
207 The_Attribute := Next_Attribute (After => The_Attribute);
216 (Project : in out Project_Id;
217 Process_Languages : Languages_Processed;
218 Follow_Links : Boolean) is
220 -- Make sure that all projects are marked as not checked
222 for Index in 1 .. Projects.Last loop
223 Projects.Table (Index).Checked := False;
226 Recursive_Check (Project, Process_Languages, Follow_Links);
235 (Project : Project_Id;
236 From_Project_Node : Project_Node_Id;
238 First_Term : Project_Node_Id;
239 Kind : Variable_Kind) return Variable_Value
241 The_Term : Project_Node_Id := First_Term;
242 -- The term in the expression list
244 The_Current_Term : Project_Node_Id := Empty_Node;
245 -- The current term node id
247 Result : Variable_Value (Kind => Kind);
248 -- The returned result
250 Last : String_List_Id := Nil_String;
251 -- Reference to the last string elements in Result, when Kind is List.
254 Result.Project := Project;
255 Result.Location := Location_Of (First_Term);
257 -- Process each term of the expression, starting with First_Term
259 while The_Term /= Empty_Node loop
260 The_Current_Term := Current_Term (The_Term);
262 case Kind_Of (The_Current_Term) is
264 when N_Literal_String =>
270 -- Should never happen
272 pragma Assert (False, "Undefined expression kind");
276 Add (Result.Value, String_Value_Of (The_Current_Term));
277 Result.Index := Source_Index_Of (The_Current_Term);
281 String_Elements.Increment_Last;
283 if Last = Nil_String then
285 -- This can happen in an expression such as
288 Result.Values := String_Elements.Last;
291 String_Elements.Table (Last).Next :=
292 String_Elements.Last;
295 Last := String_Elements.Last;
296 String_Elements.Table (Last) :=
297 (Value => String_Value_Of (The_Current_Term),
298 Index => Source_Index_Of (The_Current_Term),
299 Display_Value => No_Name,
300 Location => Location_Of (The_Current_Term),
306 when N_Literal_String_List =>
309 String_Node : Project_Node_Id :=
310 First_Expression_In_List (The_Current_Term);
312 Value : Variable_Value;
315 if String_Node /= Empty_Node then
317 -- If String_Node is nil, it is an empty list,
318 -- there is nothing to do
322 From_Project_Node => From_Project_Node,
324 First_Term => Tree.First_Term (String_Node),
326 String_Elements.Increment_Last;
328 if Result.Values = Nil_String then
330 -- This literal string list is the first term
331 -- in a string list expression
333 Result.Values := String_Elements.Last;
336 String_Elements.Table (Last).Next :=
337 String_Elements.Last;
340 Last := String_Elements.Last;
341 String_Elements.Table (Last) :=
342 (Value => Value.Value,
343 Display_Value => No_Name,
344 Location => Value.Location,
347 Index => Value.Index);
350 -- Add the other element of the literal string list
351 -- one after the other
354 Next_Expression_In_List (String_Node);
356 exit when String_Node = Empty_Node;
361 From_Project_Node => From_Project_Node,
363 First_Term => Tree.First_Term (String_Node),
366 String_Elements.Increment_Last;
367 String_Elements.Table (Last).Next :=
368 String_Elements.Last;
369 Last := String_Elements.Last;
370 String_Elements.Table (Last) :=
371 (Value => Value.Value,
372 Display_Value => No_Name,
373 Location => Value.Location,
376 Index => Value.Index);
383 when N_Variable_Reference | N_Attribute_Reference =>
386 The_Project : Project_Id := Project;
387 The_Package : Package_Id := Pkg;
388 The_Name : Name_Id := No_Name;
389 The_Variable_Id : Variable_Id := No_Variable;
390 The_Variable : Variable_Value;
391 Term_Project : constant Project_Node_Id :=
392 Project_Node_Of (The_Current_Term);
393 Term_Package : constant Project_Node_Id :=
394 Package_Node_Of (The_Current_Term);
395 Index : Name_Id := No_Name;
398 if Term_Project /= Empty_Node and then
399 Term_Project /= From_Project_Node
401 -- This variable or attribute comes from another project
403 The_Name := Name_Of (Term_Project);
404 The_Project := Imported_Or_Extended_Project_From
406 With_Name => The_Name);
409 if Term_Package /= Empty_Node then
411 -- This is an attribute of a package
413 The_Name := Name_Of (Term_Package);
414 The_Package := Projects.Table (The_Project).Decl.Packages;
416 while The_Package /= No_Package
417 and then Packages.Table (The_Package).Name /= The_Name
419 The_Package := Packages.Table (The_Package).Next;
423 (The_Package /= No_Package,
424 "package not found.");
426 elsif Kind_Of (The_Current_Term) = N_Attribute_Reference then
427 The_Package := No_Package;
430 The_Name := Name_Of (The_Current_Term);
432 if Kind_Of (The_Current_Term) = N_Attribute_Reference then
433 Index := Associative_Array_Index_Of (The_Current_Term);
436 -- If it is not an associative array attribute
438 if Index = No_Name then
440 -- It is not an associative array attribute
442 if The_Package /= No_Package then
444 -- First, if there is a package, look into the package
447 Kind_Of (The_Current_Term) = N_Variable_Reference
450 Packages.Table (The_Package).Decl.Variables;
454 Packages.Table (The_Package).Decl.Attributes;
457 while The_Variable_Id /= No_Variable
459 Variable_Elements.Table (The_Variable_Id).Name /=
463 Variable_Elements.Table (The_Variable_Id).Next;
468 if The_Variable_Id = No_Variable then
470 -- If we have not found it, look into the project
473 Kind_Of (The_Current_Term) = N_Variable_Reference
476 Projects.Table (The_Project).Decl.Variables;
480 Projects.Table (The_Project).Decl.Attributes;
483 while The_Variable_Id /= No_Variable
485 Variable_Elements.Table (The_Variable_Id).Name /=
489 Variable_Elements.Table (The_Variable_Id).Next;
494 pragma Assert (The_Variable_Id /= No_Variable,
495 "variable or attribute not found");
497 The_Variable := Variable_Elements.Table
498 (The_Variable_Id).Value;
502 -- It is an associative array attribute
505 The_Array : Array_Id := No_Array;
506 The_Element : Array_Element_Id := No_Array_Element;
507 Array_Index : Name_Id := No_Name;
509 if The_Package /= No_Package then
511 Packages.Table (The_Package).Decl.Arrays;
515 Projects.Table (The_Project).Decl.Arrays;
518 while The_Array /= No_Array
519 and then Arrays.Table (The_Array).Name /= The_Name
521 The_Array := Arrays.Table (The_Array).Next;
524 if The_Array /= No_Array then
525 The_Element := Arrays.Table (The_Array).Value;
527 Get_Name_String (Index);
529 if Case_Insensitive (The_Current_Term) then
530 To_Lower (Name_Buffer (1 .. Name_Len));
533 Array_Index := Name_Find;
535 while The_Element /= No_Array_Element
536 and then Array_Elements.Table (The_Element).Index
540 Array_Elements.Table (The_Element).Next;
545 if The_Element /= No_Array_Element then
547 Array_Elements.Table (The_Element).Value;
551 Expression_Kind_Of (The_Current_Term) = List
556 Location => No_Location,
558 Values => Nil_String);
564 Location => No_Location,
566 Value => Empty_String,
577 -- Should never happen
579 pragma Assert (False, "undefined expression kind");
584 case The_Variable.Kind is
590 Add (Result.Value, The_Variable.Value);
594 -- Should never happen
598 "list cannot appear in single " &
599 "string expression");
604 case The_Variable.Kind is
610 String_Elements.Increment_Last;
612 if Last = Nil_String then
614 -- This can happen in an expression such as
617 Result.Values := String_Elements.Last;
620 String_Elements.Table (Last).Next :=
621 String_Elements.Last;
624 Last := String_Elements.Last;
625 String_Elements.Table (Last) :=
626 (Value => The_Variable.Value,
627 Display_Value => No_Name,
628 Location => Location_Of (The_Current_Term),
636 The_List : String_List_Id :=
640 while The_List /= Nil_String loop
641 String_Elements.Increment_Last;
643 if Last = Nil_String then
644 Result.Values := String_Elements.Last;
647 String_Elements.Table (Last).Next :=
648 String_Elements.Last;
652 Last := String_Elements.Last;
653 String_Elements.Table (Last) :=
655 String_Elements.Table
657 Display_Value => No_Name,
658 Location => Location_Of
664 String_Elements.Table (The_List).Next;
671 when N_External_Value =>
673 (String_Value_Of (External_Reference_Of (The_Current_Term)));
676 Name : constant Name_Id := Name_Find;
677 Default : Name_Id := No_Name;
678 Value : Name_Id := No_Name;
680 Default_Node : constant Project_Node_Id :=
681 External_Default_Of (The_Current_Term);
684 if Default_Node /= Empty_Node then
685 Default := String_Value_Of (Default_Node);
688 Value := Prj.Ext.Value_Of (Name, Default);
690 if Value = No_Name then
691 if not Opt.Quiet_Output then
692 if Error_Report = null then
694 ("?undefined external reference",
695 Location_Of (The_Current_Term));
699 ("warning: """ & Get_Name_String (Name) &
700 """ is an undefined external reference",
705 Value := Empty_String;
715 Add (Result.Value, Value);
718 String_Elements.Increment_Last;
720 if Last = Nil_String then
721 Result.Values := String_Elements.Last;
724 String_Elements.Table (Last).Next :=
725 String_Elements.Last;
728 Last := String_Elements.Last;
729 String_Elements.Table (Last) :=
731 Display_Value => No_Name,
732 Location => Location_Of (The_Current_Term),
742 -- Should never happen
746 "illegal node kind in an expression");
751 The_Term := Next_Term (The_Term);
757 ---------------------------------------
758 -- Imported_Or_Extended_Project_From --
759 ---------------------------------------
761 function Imported_Or_Extended_Project_From
762 (Project : Project_Id;
763 With_Name : Name_Id) return Project_Id
765 Data : constant Project_Data := Projects.Table (Project);
766 List : Project_List := Data.Imported_Projects;
767 Result : Project_Id := No_Project;
768 Temp_Result : Project_Id := No_Project;
771 -- First check if it is the name of an extended project
773 if Data.Extends /= No_Project
774 and then Projects.Table (Data.Extends).Name = With_Name
779 -- Then check the name of each imported project
781 while List /= Empty_Project_List loop
782 Result := Project_Lists.Table (List).Project;
784 -- If the project is directly imported, then returns its ID
786 if Projects.Table (Result).Name = With_Name then
790 -- If a project extending the project is imported, then keep
791 -- this extending project as a possibility. It will be the
792 -- returned ID if the project is not imported directly.
795 Proj : Project_Id := Projects.Table (Result).Extends;
797 while Proj /= No_Project loop
798 if Projects.Table (Proj).Name = With_Name then
799 Temp_Result := Result;
803 Proj := Projects.Table (Proj).Extends;
807 List := Project_Lists.Table (List).Next;
811 (Temp_Result /= No_Project,
812 "project not found");
816 end Imported_Or_Extended_Project_From;
822 function Package_From
823 (Project : Project_Id;
824 With_Name : Name_Id) return Package_Id
826 Data : constant Project_Data := Projects.Table (Project);
827 Result : Package_Id := Data.Decl.Packages;
830 -- Check the name of each existing package of Project
832 while Result /= No_Package
834 Packages.Table (Result).Name /= With_Name
836 Result := Packages.Table (Result).Next;
839 if Result = No_Package then
840 -- Should never happen
841 Write_Line ("package """ & Get_Name_String (With_Name) &
855 (Project : out Project_Id;
856 Success : out Boolean;
857 From_Project_Node : Project_Node_Id;
858 Report_Error : Put_Line_Access;
859 Process_Languages : Languages_Processed := Ada_Language;
860 Follow_Links : Boolean := True)
863 Extending : Project_Id;
864 Extending2 : Project_Id;
867 Error_Report := Report_Error;
870 -- Make sure there is no projects in the data structure
872 Projects.Set_Last (No_Project);
873 Processed_Projects.Reset;
875 -- And process the main project and all of the projects it depends on,
880 From_Project_Node => From_Project_Node,
881 Extended_By => No_Project);
883 if Project /= No_Project then
884 Check (Project, Process_Languages, Follow_Links);
887 -- If main project is an extending all project, set the object
888 -- directory of all virtual extending projects to the object directory
889 -- of the main project.
891 if Project /= No_Project
892 and then Is_Extending_All (From_Project_Node)
895 Object_Dir : constant Name_Id :=
896 Projects.Table (Project).Object_Directory;
898 for Index in Projects.First .. Projects.Last loop
899 if Projects.Table (Index).Virtual then
900 Projects.Table (Index).Object_Directory := Object_Dir;
906 -- Check that no extending project shares its object directory with
907 -- the project(s) it extends.
909 if Project /= No_Project then
910 for Proj in 1 .. Projects.Last loop
911 Extending := Projects.Table (Proj).Extended_By;
913 if Extending /= No_Project then
914 Obj_Dir := Projects.Table (Proj).Object_Directory;
916 -- Check that a project being extended does not share its
917 -- object directory with any project that extends it, directly
918 -- or indirectly, including a virtual extending project.
920 -- Start with the project directly extending it
922 Extending2 := Extending;
924 while Extending2 /= No_Project loop
925 if ((Process_Languages = Ada_Language
927 Projects.Table (Extending2).Ada_Sources_Present)
929 (Process_Languages = Other_Languages
931 Projects.Table (Extending2).Other_Sources_Present))
933 Projects.Table (Extending2).Object_Directory = Obj_Dir
935 if Projects.Table (Extending2).Virtual then
936 Error_Msg_Name_1 := Projects.Table (Proj).Name;
938 if Error_Report = null then
940 ("project % cannot be extended by a virtual " &
941 "project with the same object directory",
942 Projects.Table (Proj).Location);
947 Get_Name_String (Error_Msg_Name_1) &
948 """ cannot be extended by a virtual " &
949 "project with the same object directory",
955 Projects.Table (Extending2).Name;
956 Error_Msg_Name_2 := Projects.Table (Proj).Name;
958 if Error_Report = null then
960 ("project % cannot extend project %",
961 Projects.Table (Extending2).Location);
963 ("\they share the same object directory",
964 Projects.Table (Extending2).Location);
969 Get_Name_String (Error_Msg_Name_1) &
970 """ cannot extend project """ &
971 Get_Name_String (Error_Msg_Name_2) & """",
974 ("they share the same object directory",
980 -- Continue with the next extending project, if any
982 Extending2 := Projects.Table (Extending2).Extended_By;
988 Success := Total_Errors_Detected <= 0;
991 -------------------------------
992 -- Process_Declarative_Items --
993 -------------------------------
995 procedure Process_Declarative_Items
996 (Project : Project_Id;
997 From_Project_Node : Project_Node_Id;
999 Item : Project_Node_Id)
1001 Current_Declarative_Item : Project_Node_Id := Item;
1002 Current_Item : Project_Node_Id := Empty_Node;
1005 -- For each declarative item
1007 while Current_Declarative_Item /= Empty_Node loop
1011 Current_Item := Current_Item_Node (Current_Declarative_Item);
1013 -- And set Current_Declarative_Item to the next declarative item
1014 -- ready for the next iteration.
1016 Current_Declarative_Item := Next_Declarative_Item
1017 (Current_Declarative_Item);
1019 case Kind_Of (Current_Item) is
1021 when N_Package_Declaration =>
1022 -- Do not process a package declaration that should be ignored
1024 if Expression_Kind_Of (Current_Item) /= Ignored then
1025 -- Create the new package
1027 Packages.Increment_Last;
1030 New_Pkg : constant Package_Id := Packages.Last;
1031 The_New_Package : Package_Element;
1033 Project_Of_Renamed_Package : constant Project_Node_Id :=
1034 Project_Of_Renamed_Package_Of
1038 -- Set the name of the new package
1040 The_New_Package.Name := Name_Of (Current_Item);
1042 -- Insert the new package in the appropriate list
1044 if Pkg /= No_Package then
1045 The_New_Package.Next :=
1046 Packages.Table (Pkg).Decl.Packages;
1047 Packages.Table (Pkg).Decl.Packages := New_Pkg;
1049 The_New_Package.Next :=
1050 Projects.Table (Project).Decl.Packages;
1051 Projects.Table (Project).Decl.Packages := New_Pkg;
1054 Packages.Table (New_Pkg) := The_New_Package;
1056 if Project_Of_Renamed_Package /= Empty_Node then
1061 Project_Name : constant Name_Id :=
1063 (Project_Of_Renamed_Package);
1065 Renamed_Project : constant Project_Id :=
1066 Imported_Or_Extended_Project_From
1067 (Project, Project_Name);
1069 Renamed_Package : constant Package_Id :=
1072 Name_Of (Current_Item));
1075 -- For a renamed package, set declarations to
1076 -- the declarations of the renamed package.
1078 Packages.Table (New_Pkg).Decl :=
1079 Packages.Table (Renamed_Package).Decl;
1082 -- Standard package declaration, not renaming
1085 -- Set the default values of the attributes
1089 Packages.Table (New_Pkg).Decl,
1091 (Package_Id_Of (Current_Item)));
1093 -- And process declarative items of the new package
1095 Process_Declarative_Items
1096 (Project => Project,
1097 From_Project_Node => From_Project_Node,
1099 Item => First_Declarative_Item_Of
1105 when N_String_Type_Declaration =>
1107 -- There is nothing to process
1111 when N_Attribute_Declaration |
1112 N_Typed_Variable_Declaration |
1113 N_Variable_Declaration =>
1115 if Expression_Of (Current_Item) = Empty_Node then
1117 -- It must be a full associative array attribute declaration
1120 Current_Item_Name : constant Name_Id :=
1121 Name_Of (Current_Item);
1122 -- The name of the attribute
1124 New_Array : Array_Id;
1125 -- The new associative array created
1127 Orig_Array : Array_Id;
1128 -- The associative array value
1130 Orig_Project_Name : Name_Id := No_Name;
1131 -- The name of the project where the associative array
1134 Orig_Project : Project_Id := No_Project;
1135 -- The id of the project where the associative array
1138 Orig_Package_Name : Name_Id := No_Name;
1139 -- The name of the package, if any, where the associative
1142 Orig_Package : Package_Id := No_Package;
1143 -- The id of the package, if any, where the associative
1146 New_Element : Array_Element_Id := No_Array_Element;
1147 -- Id of a new array element created
1149 Prev_Element : Array_Element_Id := No_Array_Element;
1150 -- Last new element id created
1152 Orig_Element : Array_Element_Id := No_Array_Element;
1153 -- Current array element in the original associative
1156 Next_Element : Array_Element_Id := No_Array_Element;
1157 -- Id of the array element that follows the new element.
1158 -- This is not always nil, because values for the
1159 -- associative array attribute may already have been
1160 -- declared, and the array elements declared are reused.
1163 -- First, find if the associative array attribute already
1164 -- has elements declared.
1166 if Pkg /= No_Package then
1167 New_Array := Packages.Table (Pkg).Decl.Arrays;
1170 New_Array := Projects.Table (Project).Decl.Arrays;
1173 while New_Array /= No_Array and then
1174 Arrays.Table (New_Array).Name /= Current_Item_Name
1176 New_Array := Arrays.Table (New_Array).Next;
1179 -- If the attribute has never been declared add new entry
1180 -- in the arrays of the project/package and link it.
1182 if New_Array = No_Array then
1183 Arrays.Increment_Last;
1184 New_Array := Arrays.Last;
1186 if Pkg /= No_Package then
1187 Arrays.Table (New_Array) :=
1188 (Name => Current_Item_Name,
1189 Value => No_Array_Element,
1190 Next => Packages.Table (Pkg).Decl.Arrays);
1191 Packages.Table (Pkg).Decl.Arrays := New_Array;
1194 Arrays.Table (New_Array) :=
1195 (Name => Current_Item_Name,
1196 Value => No_Array_Element,
1197 Next => Projects.Table (Project).Decl.Arrays);
1198 Projects.Table (Project).Decl.Arrays := New_Array;
1202 -- Find the project where the value is declared
1204 Orig_Project_Name :=
1205 Name_Of (Associative_Project_Of (Current_Item));
1207 for Index in Projects.First .. Projects.Last loop
1208 if Projects.Table (Index).Name = Orig_Project_Name then
1209 Orig_Project := Index;
1214 pragma Assert (Orig_Project /= No_Project,
1215 "original project not found");
1217 if Associative_Package_Of (Current_Item) = Empty_Node then
1219 Projects.Table (Orig_Project).Decl.Arrays;
1222 -- If in a package, find the package where the
1223 -- value is declared.
1225 Orig_Package_Name :=
1226 Name_Of (Associative_Package_Of (Current_Item));
1228 Projects.Table (Orig_Project).Decl.Packages;
1229 pragma Assert (Orig_Package /= No_Package,
1230 "original package not found");
1232 while Packages.Table (Orig_Package).Name /=
1235 Orig_Package := Packages.Table (Orig_Package).Next;
1236 pragma Assert (Orig_Package /= No_Package,
1237 "original package not found");
1241 Packages.Table (Orig_Package).Decl.Arrays;
1244 -- Now look for the array
1246 while Orig_Array /= No_Array and then
1247 Arrays.Table (Orig_Array).Name /= Current_Item_Name
1249 Orig_Array := Arrays.Table (Orig_Array).Next;
1252 if Orig_Array = No_Array then
1253 if Error_Report = null then
1255 ("associative array value cannot be found",
1256 Location_Of (Current_Item));
1260 ("associative array value cannot be found",
1265 Orig_Element := Arrays.Table (Orig_Array).Value;
1267 -- Copy each array element
1269 while Orig_Element /= No_Array_Element loop
1270 -- If it is the first element ...
1272 if Prev_Element = No_Array_Element then
1273 -- And there is no array element declared yet,
1274 -- create a new first array element.
1276 if Arrays.Table (New_Array).Value =
1279 Array_Elements.Increment_Last;
1280 New_Element := Array_Elements.Last;
1281 Arrays.Table (New_Array).Value := New_Element;
1282 Next_Element := No_Array_Element;
1284 -- Otherwise, the new element is the first
1287 New_Element := Arrays.Table (New_Array).Value;
1289 Array_Elements.Table (New_Element).Next;
1292 -- Otherwise, reuse an existing element, or create
1293 -- one if necessary.
1297 Array_Elements.Table (Prev_Element).Next;
1299 if Next_Element = No_Array_Element then
1300 Array_Elements.Increment_Last;
1301 New_Element := Array_Elements.Last;
1304 New_Element := Next_Element;
1306 Array_Elements.Table (New_Element).Next;
1310 -- Copy the value of the element
1312 Array_Elements.Table (New_Element) :=
1313 Array_Elements.Table (Orig_Element);
1314 Array_Elements.Table (New_Element).Value.Project :=
1317 -- Adjust the Next link
1319 Array_Elements.Table (New_Element).Next :=
1322 -- Adjust the previous id for the next element
1324 Prev_Element := New_Element;
1326 -- Go to the next element in the original array
1328 Array_Elements.Table (Orig_Element).Next;
1331 -- Make sure that the array ends here, in case there
1332 -- previously a greater number of elements.
1334 Array_Elements.Table (New_Element).Next :=
1339 -- Declarations other that full associative arrays
1343 New_Value : constant Variable_Value :=
1345 (Project => Project,
1346 From_Project_Node => From_Project_Node,
1349 Tree.First_Term (Expression_Of
1352 Expression_Kind_Of (Current_Item));
1353 -- The expression value
1355 The_Variable : Variable_Id := No_Variable;
1357 Current_Item_Name : constant Name_Id :=
1358 Name_Of (Current_Item);
1361 -- Process a typed variable declaration
1364 Kind_Of (Current_Item) = N_Typed_Variable_Declaration
1366 -- Report an error for an empty string
1368 if New_Value.Value = Empty_String then
1369 Error_Msg_Name_1 := Name_Of (Current_Item);
1371 if Error_Report = null then
1373 ("no value defined for %",
1374 Location_Of (Current_Item));
1378 ("no value defined for " &
1379 Get_Name_String (Error_Msg_Name_1),
1385 Current_String : Project_Node_Id :=
1386 First_Literal_String
1391 -- Loop through all the valid strings for
1392 -- the string type and compare to the string
1395 while Current_String /= Empty_Node
1396 and then String_Value_Of (Current_String) /=
1400 Next_Literal_String (Current_String);
1403 -- Report an error if the string value is not
1404 -- one for the string type.
1406 if Current_String = Empty_Node then
1407 Error_Msg_Name_1 := New_Value.Value;
1408 Error_Msg_Name_2 := Name_Of (Current_Item);
1410 if Error_Report = null then
1412 ("value { is illegal for typed string %",
1413 Location_Of (Current_Item));
1418 Get_Name_String (Error_Msg_Name_1) &
1419 """ is illegal for typed string """ &
1420 Get_Name_String (Error_Msg_Name_2) &
1429 if Kind_Of (Current_Item) /= N_Attribute_Declaration
1431 Associative_Array_Index_Of (Current_Item) = No_Name
1433 -- Case of a variable declaration or of a not
1434 -- associative array attribute.
1436 -- First, find the list where to find the variable
1440 Kind_Of (Current_Item) = N_Attribute_Declaration
1442 if Pkg /= No_Package then
1444 Packages.Table (Pkg).Decl.Attributes;
1448 Projects.Table (Project).Decl.Attributes;
1452 if Pkg /= No_Package then
1454 Packages.Table (Pkg).Decl.Variables;
1458 Projects.Table (Project).Decl.Variables;
1463 -- Loop through the list, to find if it has already
1467 The_Variable /= No_Variable
1469 Variable_Elements.Table (The_Variable).Name /=
1473 Variable_Elements.Table (The_Variable).Next;
1476 -- If it has not been declared, create a new entry
1479 if The_Variable = No_Variable then
1480 -- All single string attribute should already have
1481 -- been declared with a default empty string value.
1484 (Kind_Of (Current_Item) /=
1485 N_Attribute_Declaration,
1486 "illegal attribute declaration");
1488 Variable_Elements.Increment_Last;
1489 The_Variable := Variable_Elements.Last;
1491 -- Put the new variable in the appropriate list
1493 if Pkg /= No_Package then
1494 Variable_Elements.Table (The_Variable) :=
1496 Packages.Table (Pkg).Decl.Variables,
1497 Name => Current_Item_Name,
1498 Value => New_Value);
1499 Packages.Table (Pkg).Decl.Variables :=
1503 Variable_Elements.Table (The_Variable) :=
1505 Projects.Table (Project).Decl.Variables,
1506 Name => Current_Item_Name,
1507 Value => New_Value);
1508 Projects.Table (Project).Decl.Variables :=
1512 -- If the variable/attribute has already been
1513 -- declared, just change the value.
1516 Variable_Elements.Table (The_Variable).Value :=
1522 -- Associative array attribute
1524 -- Get the string index
1527 (Associative_Array_Index_Of (Current_Item));
1529 -- Put in lower case, if necessary
1531 if Case_Insensitive (Current_Item) then
1532 GNAT.Case_Util.To_Lower
1533 (Name_Buffer (1 .. Name_Len));
1537 The_Array : Array_Id;
1539 The_Array_Element : Array_Element_Id :=
1542 Index_Name : constant Name_Id := Name_Find;
1543 -- The name id of the index
1546 -- Look for the array in the appropriate list
1548 if Pkg /= No_Package then
1549 The_Array := Packages.Table (Pkg).Decl.Arrays;
1552 The_Array := Projects.Table
1553 (Project).Decl.Arrays;
1557 The_Array /= No_Array
1558 and then Arrays.Table (The_Array).Name /=
1561 The_Array := Arrays.Table (The_Array).Next;
1564 -- If the array cannot be found, create a new
1565 -- entry in the list. As The_Array_Element is
1566 -- initialized to No_Array_Element, a new element
1567 -- will be created automatically later.
1569 if The_Array = No_Array then
1570 Arrays.Increment_Last;
1571 The_Array := Arrays.Last;
1573 if Pkg /= No_Package then
1574 Arrays.Table (The_Array) :=
1575 (Name => Current_Item_Name,
1576 Value => No_Array_Element,
1577 Next => Packages.Table (Pkg).Decl.Arrays);
1578 Packages.Table (Pkg).Decl.Arrays := The_Array;
1581 Arrays.Table (The_Array) :=
1582 (Name => Current_Item_Name,
1583 Value => No_Array_Element,
1585 Projects.Table (Project).Decl.Arrays);
1586 Projects.Table (Project).Decl.Arrays :=
1590 -- Otherwise, initialize The_Array_Element as the
1591 -- head of the element list.
1594 The_Array_Element :=
1595 Arrays.Table (The_Array).Value;
1598 -- Look in the list, if any, to find an element
1599 -- with the same index.
1601 while The_Array_Element /= No_Array_Element
1603 Array_Elements.Table (The_Array_Element).Index /=
1606 The_Array_Element :=
1607 Array_Elements.Table (The_Array_Element).Next;
1610 -- If no such element were found, create a new
1611 -- one and insert it in the element list, with
1612 -- the propoer value.
1614 if The_Array_Element = No_Array_Element then
1615 Array_Elements.Increment_Last;
1616 The_Array_Element := Array_Elements.Last;
1618 Array_Elements.Table (The_Array_Element) :=
1619 (Index => Index_Name,
1620 Src_Index => Source_Index_Of (Current_Item),
1621 Index_Case_Sensitive =>
1622 not Case_Insensitive (Current_Item),
1624 Next => Arrays.Table (The_Array).Value);
1625 Arrays.Table (The_Array).Value :=
1628 -- An element with the same index already exists,
1629 -- just replace its value with the new one.
1632 Array_Elements.Table (The_Array_Element).Value :=
1640 when N_Case_Construction =>
1642 The_Project : Project_Id := Project;
1643 -- The id of the project of the case variable
1645 The_Package : Package_Id := Pkg;
1646 -- The id of the package, if any, of the case variable
1648 The_Variable : Variable_Value := Nil_Variable_Value;
1649 -- The case variable
1651 Case_Value : Name_Id := No_Name;
1652 -- The case variable value
1654 Case_Item : Project_Node_Id := Empty_Node;
1655 Choice_String : Project_Node_Id := Empty_Node;
1656 Decl_Item : Project_Node_Id := Empty_Node;
1660 Variable_Node : constant Project_Node_Id :=
1661 Case_Variable_Reference_Of
1664 Var_Id : Variable_Id := No_Variable;
1665 Name : Name_Id := No_Name;
1668 -- If a project were specified for the case variable,
1671 if Project_Node_Of (Variable_Node) /= Empty_Node then
1672 Name := Name_Of (Project_Node_Of (Variable_Node));
1674 Imported_Or_Extended_Project_From (Project, Name);
1677 -- If a package were specified for the case variable,
1680 if Package_Node_Of (Variable_Node) /= Empty_Node then
1681 Name := Name_Of (Package_Node_Of (Variable_Node));
1682 The_Package := Package_From (The_Project, Name);
1685 Name := Name_Of (Variable_Node);
1687 -- First, look for the case variable into the package,
1690 if The_Package /= No_Package then
1691 Var_Id := Packages.Table (The_Package).Decl.Variables;
1692 Name := Name_Of (Variable_Node);
1693 while Var_Id /= No_Variable
1695 Variable_Elements.Table (Var_Id).Name /= Name
1697 Var_Id := Variable_Elements.Table (Var_Id).Next;
1701 -- If not found in the package, or if there is no
1702 -- package, look at the project level.
1704 if Var_Id = No_Variable
1705 and then Package_Node_Of (Variable_Node) = Empty_Node
1707 Var_Id := Projects.Table (The_Project).Decl.Variables;
1708 while Var_Id /= No_Variable
1710 Variable_Elements.Table (Var_Id).Name /= Name
1712 Var_Id := Variable_Elements.Table (Var_Id).Next;
1716 if Var_Id = No_Variable then
1718 -- Should never happen, because this has already been
1719 -- checked during parsing.
1721 Write_Line ("variable """ &
1722 Get_Name_String (Name) &
1724 raise Program_Error;
1727 -- Get the case variable
1729 The_Variable := Variable_Elements.Table (Var_Id).Value;
1731 if The_Variable.Kind /= Single then
1733 -- Should never happen, because this has already been
1734 -- checked during parsing.
1736 Write_Line ("variable""" &
1737 Get_Name_String (Name) &
1738 """ is not a single string variable");
1739 raise Program_Error;
1742 -- Get the case variable value
1743 Case_Value := The_Variable.Value;
1746 -- Now look into all the case items of the case construction
1748 Case_Item := First_Case_Item_Of (Current_Item);
1750 while Case_Item /= Empty_Node loop
1751 Choice_String := First_Choice_Of (Case_Item);
1753 -- When Choice_String is nil, it means that it is
1754 -- the "when others =>" alternative.
1756 if Choice_String = Empty_Node then
1757 Decl_Item := First_Declarative_Item_Of (Case_Item);
1758 exit Case_Item_Loop;
1761 -- Look into all the alternative of this case item
1764 while Choice_String /= Empty_Node loop
1766 Case_Value = String_Value_Of (Choice_String)
1769 First_Declarative_Item_Of (Case_Item);
1770 exit Case_Item_Loop;
1774 Next_Literal_String (Choice_String);
1775 end loop Choice_Loop;
1776 Case_Item := Next_Case_Item (Case_Item);
1777 end loop Case_Item_Loop;
1779 -- If there is an alternative, then we process it
1781 if Decl_Item /= Empty_Node then
1782 Process_Declarative_Items
1783 (Project => Project,
1784 From_Project_Node => From_Project_Node,
1792 -- Should never happen
1794 Write_Line ("Illegal declarative item: " &
1795 Project_Node_Kind'Image (Kind_Of (Current_Item)));
1796 raise Program_Error;
1799 end Process_Declarative_Items;
1801 ---------------------
1802 -- Recursive_Check --
1803 ---------------------
1805 procedure Recursive_Check
1806 (Project : Project_Id;
1807 Process_Languages : Languages_Processed;
1808 Follow_Links : Boolean)
1810 Data : Project_Data;
1811 Imported_Project_List : Project_List := Empty_Project_List;
1814 -- Do nothing if Project is No_Project, or Project has already
1815 -- been marked as checked.
1817 if Project /= No_Project
1818 and then not Projects.Table (Project).Checked
1820 -- Mark project as checked, to avoid infinite recursion in
1821 -- ill-formed trees, where a project imports itself.
1823 Projects.Table (Project).Checked := True;
1825 Data := Projects.Table (Project);
1827 -- Call itself for a possible extended project.
1828 -- (if there is no extended project, then nothing happens).
1830 Recursive_Check (Data.Extends, Process_Languages, Follow_Links);
1832 -- Call itself for all imported projects
1834 Imported_Project_List := Data.Imported_Projects;
1835 while Imported_Project_List /= Empty_Project_List loop
1837 (Project_Lists.Table (Imported_Project_List).Project,
1838 Process_Languages, Follow_Links);
1839 Imported_Project_List :=
1840 Project_Lists.Table (Imported_Project_List).Next;
1843 if Opt.Verbose_Mode then
1844 Write_Str ("Checking project file """);
1845 Write_Str (Get_Name_String (Data.Name));
1849 case Process_Languages is
1850 when Ada_Language =>
1851 Prj.Nmsc.Ada_Check (Project, Error_Report, Follow_Links);
1853 when Other_Languages =>
1854 Prj.Nmsc.Other_Languages_Check (Project, Error_Report);
1856 when All_Languages =>
1857 Prj.Nmsc.Ada_Check (Project, Error_Report, Follow_Links);
1858 Prj.Nmsc.Other_Languages_Check (Project, Error_Report);
1862 end Recursive_Check;
1864 -----------------------
1865 -- Recursive_Process --
1866 -----------------------
1868 procedure Recursive_Process
1869 (Project : out Project_Id;
1870 From_Project_Node : Project_Node_Id;
1871 Extended_By : Project_Id)
1873 With_Clause : Project_Node_Id;
1876 if From_Project_Node = Empty_Node then
1877 Project := No_Project;
1881 Processed_Data : Project_Data := Empty_Project;
1882 Imported : Project_List := Empty_Project_List;
1883 Declaration_Node : Project_Node_Id := Empty_Node;
1884 Name : constant Name_Id := Name_Of (From_Project_Node);
1887 Project := Processed_Projects.Get (Name);
1889 if Project /= No_Project then
1893 Projects.Increment_Last;
1894 Project := Projects.Last;
1895 Processed_Projects.Set (Name, Project);
1897 Processed_Data.Name := Name;
1899 Get_Name_String (Name);
1901 -- If name starts with the virtual prefix, flag the project as
1902 -- being a virtual extending project.
1904 if Name_Len > Virtual_Prefix'Length
1905 and then Name_Buffer (1 .. Virtual_Prefix'Length) =
1908 Processed_Data.Virtual := True;
1911 Processed_Data.Display_Path_Name :=
1912 Path_Name_Of (From_Project_Node);
1913 Get_Name_String (Processed_Data.Display_Path_Name);
1914 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
1915 Processed_Data.Path_Name := Name_Find;
1917 Processed_Data.Location := Location_Of (From_Project_Node);
1919 Processed_Data.Display_Directory :=
1920 Directory_Of (From_Project_Node);
1921 Get_Name_String (Processed_Data.Display_Directory);
1922 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
1923 Processed_Data.Directory := Name_Find;
1925 Processed_Data.Extended_By := Extended_By;
1926 Processed_Data.Naming := Standard_Naming_Data;
1928 Add_Attributes (Project, Processed_Data.Decl, Attribute_First);
1929 With_Clause := First_With_Clause_Of (From_Project_Node);
1931 while With_Clause /= Empty_Node loop
1933 New_Project : Project_Id;
1934 New_Data : Project_Data;
1938 (Project => New_Project,
1939 From_Project_Node => Project_Node_Of (With_Clause),
1940 Extended_By => No_Project);
1941 New_Data := Projects.Table (New_Project);
1943 -- If we were the first project to import it,
1944 -- set First_Referred_By to us.
1946 if New_Data.First_Referred_By = No_Project then
1947 New_Data.First_Referred_By := Project;
1948 Projects.Table (New_Project) := New_Data;
1951 -- Add this project to our list of imported projects
1953 Project_Lists.Increment_Last;
1954 Project_Lists.Table (Project_Lists.Last) :=
1955 (Project => New_Project, Next => Empty_Project_List);
1957 -- Imported is the id of the last imported project.
1958 -- If it is nil, then this imported project is our first.
1960 if Imported = Empty_Project_List then
1961 Processed_Data.Imported_Projects := Project_Lists.Last;
1964 Project_Lists.Table (Imported).Next := Project_Lists.Last;
1967 Imported := Project_Lists.Last;
1969 With_Clause := Next_With_Clause_Of (With_Clause);
1973 Declaration_Node := Project_Declaration_Of (From_Project_Node);
1976 (Project => Processed_Data.Extends,
1977 From_Project_Node => Extended_Project_Of (Declaration_Node),
1978 Extended_By => Project);
1980 Projects.Table (Project) := Processed_Data;
1982 Process_Declarative_Items
1983 (Project => Project,
1984 From_Project_Node => From_Project_Node,
1986 Item => First_Declarative_Item_Of
1987 (Declaration_Node));
1989 -- If it is an extending project, inherit all packages
1990 -- from the extended project that are not explicitely defined
1991 -- or renamed. Also inherit the languages, if attribute Languages
1992 -- is not explicitely defined.
1994 if Processed_Data.Extends /= No_Project then
1995 Processed_Data := Projects.Table (Project);
1998 Extended_Pkg : Package_Id :=
2000 (Processed_Data.Extends).Decl.Packages;
2001 Current_Pkg : Package_Id;
2002 Element : Package_Element;
2003 First : constant Package_Id :=
2004 Processed_Data.Decl.Packages;
2005 Attribute1 : Variable_Id;
2006 Attribute2 : Variable_Id;
2007 Attr_Value1 : Variable;
2008 Attr_Value2 : Variable;
2011 while Extended_Pkg /= No_Package loop
2012 Element := Packages.Table (Extended_Pkg);
2014 Current_Pkg := First;
2017 exit when Current_Pkg = No_Package
2018 or else Packages.Table (Current_Pkg).Name
2020 Current_Pkg := Packages.Table (Current_Pkg).Next;
2023 if Current_Pkg = No_Package then
2024 Packages.Increment_Last;
2025 Current_Pkg := Packages.Last;
2026 Packages.Table (Current_Pkg) :=
2027 (Name => Element.Name,
2028 Decl => Element.Decl,
2029 Parent => No_Package,
2030 Next => Processed_Data.Decl.Packages);
2031 Processed_Data.Decl.Packages := Current_Pkg;
2034 Extended_Pkg := Element.Next;
2037 -- Check if attribute Languages is declared in the
2038 -- extending project.
2040 Attribute1 := Processed_Data.Decl.Attributes;
2041 while Attribute1 /= No_Variable loop
2042 Attr_Value1 := Variable_Elements.Table (Attribute1);
2043 exit when Attr_Value1.Name = Snames.Name_Languages;
2044 Attribute1 := Attr_Value1.Next;
2047 if Attribute1 = No_Variable or else
2048 Attr_Value1.Value.Default
2050 -- Attribute Languages is not declared in the extending
2051 -- project. Check if it is declared in the project being
2055 Projects.Table (Processed_Data.Extends).Decl.Attributes;
2057 while Attribute2 /= No_Variable loop
2058 Attr_Value2 := Variable_Elements.Table (Attribute2);
2059 exit when Attr_Value2.Name = Snames.Name_Languages;
2060 Attribute2 := Attr_Value2.Next;
2063 if Attribute2 /= No_Variable and then
2064 not Attr_Value2.Value.Default
2066 -- As attribute Languages is declared in the project
2067 -- being extended, copy its value for the extending
2070 if Attribute1 = No_Variable then
2071 Variable_Elements.Increment_Last;
2072 Attribute1 := Variable_Elements.Last;
2073 Attr_Value1.Next := Processed_Data.Decl.Attributes;
2074 Processed_Data.Decl.Attributes := Attribute1;
2077 Attr_Value1.Name := Snames.Name_Languages;
2078 Attr_Value1.Value := Attr_Value2.Value;
2079 Variable_Elements.Table (Attribute1) := Attr_Value1;
2084 Projects.Table (Project) := Processed_Data;
2088 end Recursive_Process;