1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2005, 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 ------------------------------------------------------------------------------
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
.Err
; use Prj
.Err
;
34 with Prj
.Ext
; use Prj
.Ext
;
35 with Prj
.Nmsc
; use Prj
.Nmsc
;
36 with Sinput
; use Sinput
;
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 In_Tree
: Project_Tree_Ref
;
62 Decl
: in out Declarations
;
63 First
: Attribute_Node_Id
);
64 -- Add all attributes, starting with First, with their default
65 -- values to the package or project with declarations Decl.
68 (In_Tree
: Project_Tree_Ref
;
69 Project
: in out Project_Id
;
70 Follow_Links
: Boolean;
71 When_No_Sources
: Error_Warning
);
72 -- Set all projects to not checked, then call Recursive_Check for the
73 -- main project Project. Project is set to No_Project if errors occurred.
75 procedure Copy_Package_Declarations
77 To
: in out Declarations
;
79 In_Tree
: Project_Tree_Ref
);
80 -- Copy a package declaration From to To for a renamed package. Change the
81 -- locations of all the attributes to New_Loc.
84 (Project
: Project_Id
;
85 In_Tree
: Project_Tree_Ref
;
86 From_Project_Node
: Project_Node_Id
;
87 From_Project_Node_Tree
: Project_Node_Tree_Ref
;
89 First_Term
: Project_Node_Id
;
90 Kind
: Variable_Kind
) return Variable_Value
;
91 -- From N_Expression project node From_Project_Node, compute the value
92 -- of an expression and return it as a Variable_Value.
94 function Imported_Or_Extended_Project_From
95 (Project
: Project_Id
;
96 In_Tree
: Project_Tree_Ref
;
97 With_Name
: Name_Id
) return Project_Id
;
98 -- Find an imported or extended project of Project whose name is With_Name
100 function Package_From
101 (Project
: Project_Id
;
102 In_Tree
: Project_Tree_Ref
;
103 With_Name
: Name_Id
) return Package_Id
;
104 -- Find the package of Project whose name is With_Name
106 procedure Process_Declarative_Items
107 (Project
: Project_Id
;
108 In_Tree
: Project_Tree_Ref
;
109 From_Project_Node
: Project_Node_Id
;
110 From_Project_Node_Tree
: Project_Node_Tree_Ref
;
112 Item
: Project_Node_Id
);
113 -- Process declarative items starting with From_Project_Node, and put them
114 -- in declarations Decl. This is a recursive procedure; it calls itself for
115 -- a package declaration or a case construction.
117 procedure Recursive_Process
118 (In_Tree
: Project_Tree_Ref
;
119 Project
: out Project_Id
;
120 From_Project_Node
: Project_Node_Id
;
121 From_Project_Node_Tree
: Project_Node_Tree_Ref
;
122 Extended_By
: Project_Id
);
123 -- Process project with node From_Project_Node in the tree.
124 -- Do nothing if From_Project_Node is Empty_Node.
125 -- If project has already been processed, simply return its project id.
126 -- Otherwise create a new project id, mark it as processed, call itself
127 -- recursively for all imported projects and a extended project, if any.
128 -- Then process the declarative items of the project.
130 procedure Recursive_Check
131 (Project
: Project_Id
;
132 In_Tree
: Project_Tree_Ref
;
133 Follow_Links
: Boolean;
134 When_No_Sources
: Error_Warning
);
135 -- If Project is not marked as checked, mark it as checked, call
136 -- Check_Naming_Scheme for the project, then call itself for a
137 -- possible extended project and all the imported projects of Project.
143 procedure Add
(To_Exp
: in out Name_Id
; Str
: Name_Id
) is
145 if To_Exp
= Types
.No_Name
or else To_Exp
= Empty_String
then
147 -- To_Exp is nil or empty. The result is Str
151 -- If Str is nil, then do not change To_Ext
153 elsif Str
/= No_Name
and then Str
/= Empty_String
then
155 S
: constant String := Get_Name_String
(Str
);
158 Get_Name_String
(To_Exp
);
159 Add_Str_To_Name_Buffer
(S
);
169 procedure Add_Attributes
170 (Project
: Project_Id
;
171 In_Tree
: Project_Tree_Ref
;
172 Decl
: in out Declarations
;
173 First
: Attribute_Node_Id
)
175 The_Attribute
: Attribute_Node_Id
:= First
;
178 while The_Attribute
/= Empty_Attribute
loop
179 if Attribute_Kind_Of
(The_Attribute
) = Single
then
181 New_Attribute
: Variable_Value
;
184 case Variable_Kind_Of
(The_Attribute
) is
186 -- Undefined should not happen
190 (False, "attribute with an undefined kind");
193 -- Single attributes have a default value of empty string
199 Location
=> No_Location
,
201 Value
=> Empty_String
,
204 -- List attributes have a default value of nil list
210 Location
=> No_Location
,
212 Values
=> Nil_String
);
216 Variable_Element_Table
.Increment_Last
217 (In_Tree
.Variable_Elements
);
218 In_Tree
.Variable_Elements
.Table
219 (Variable_Element_Table
.Last
220 (In_Tree
.Variable_Elements
)) :=
221 (Next
=> Decl
.Attributes
,
222 Name
=> Attribute_Name_Of
(The_Attribute
),
223 Value
=> New_Attribute
);
224 Decl
.Attributes
:= Variable_Element_Table
.Last
225 (In_Tree
.Variable_Elements
);
229 The_Attribute
:= Next_Attribute
(After
=> The_Attribute
);
238 (In_Tree
: Project_Tree_Ref
;
239 Project
: in out Project_Id
;
240 Follow_Links
: Boolean;
241 When_No_Sources
: Error_Warning
)
244 -- Make sure that all projects are marked as not checked
246 for Index
in Project_Table
.First
..
247 Project_Table
.Last
(In_Tree
.Projects
)
249 In_Tree
.Projects
.Table
(Index
).Checked
:= False;
252 Recursive_Check
(Project
, In_Tree
, Follow_Links
, When_No_Sources
);
255 -------------------------------
256 -- Copy_Package_Declarations --
257 -------------------------------
259 procedure Copy_Package_Declarations
260 (From
: Declarations
;
261 To
: in out Declarations
;
262 New_Loc
: Source_Ptr
;
263 In_Tree
: Project_Tree_Ref
)
265 V1
: Variable_Id
:= From
.Attributes
;
266 V2
: Variable_Id
:= No_Variable
;
268 A1
: Array_Id
:= From
.Arrays
;
269 A2
: Array_Id
:= No_Array
;
271 E1
: Array_Element_Id
;
272 E2
: Array_Element_Id
:= No_Array_Element
;
276 -- To avoid references in error messages to attribute declarations in
277 -- an original package that has been renamed, copy all the attribute
278 -- declarations of the package and change all locations to New_Loc,
279 -- the location of the renamed package.
281 -- First single attributes
283 while V1
/= No_Variable
loop
285 -- Copy the attribute
287 Var
:= In_Tree
.Variable_Elements
.Table
(V1
);
290 -- Remove the Next component
292 Var
.Next
:= No_Variable
;
294 -- Change the location to New_Loc
296 Var
.Value
.Location
:= New_Loc
;
297 Variable_Element_Table
.Increment_Last
(In_Tree
.Variable_Elements
);
299 -- Put in new declaration
301 if To
.Attributes
= No_Variable
then
303 Variable_Element_Table
.Last
(In_Tree
.Variable_Elements
);
306 In_Tree
.Variable_Elements
.Table
(V2
).Next
:=
307 Variable_Element_Table
.Last
(In_Tree
.Variable_Elements
);
310 V2
:= Variable_Element_Table
.Last
(In_Tree
.Variable_Elements
);
311 In_Tree
.Variable_Elements
.Table
(V2
) := Var
;
314 -- Then the associated array attributes
316 while A1
/= No_Array
loop
320 Arr
:= In_Tree
.Arrays
.Table
(A1
);
323 -- Remove the Next component
325 Arr
.Next
:= No_Array
;
327 Array_Table
.Increment_Last
(In_Tree
.Arrays
);
329 -- Create new Array declaration
330 if To
.Arrays
= No_Array
then
331 To
.Arrays
:= Array_Table
.Last
(In_Tree
.Arrays
);
334 In_Tree
.Arrays
.Table
(A2
).Next
:=
335 Array_Table
.Last
(In_Tree
.Arrays
);
338 A2
:= Array_Table
.Last
(In_Tree
.Arrays
);
340 -- Don't store the array, as its first element has not been set yet
342 -- Copy the array elements of the array
345 Arr
.Value
:= No_Array_Element
;
347 while E1
/= No_Array_Element
loop
349 -- Copy the array element
351 Elm
:= In_Tree
.Array_Elements
.Table
(E1
);
354 -- Remove the Next component
356 Elm
.Next
:= No_Array_Element
;
358 -- Change the location
360 Elm
.Value
.Location
:= New_Loc
;
361 Array_Element_Table
.Increment_Last
(In_Tree
.Array_Elements
);
363 -- Create new array element
365 if Arr
.Value
= No_Array_Element
then
366 Arr
.Value
:= Array_Element_Table
.Last
(In_Tree
.Array_Elements
);
368 In_Tree
.Array_Elements
.Table
(E2
).Next
:=
369 Array_Element_Table
.Last
(In_Tree
.Array_Elements
);
372 E2
:= Array_Element_Table
.Last
(In_Tree
.Array_Elements
);
373 In_Tree
.Array_Elements
.Table
(E2
) := Elm
;
376 -- Finally, store the new array
378 In_Tree
.Arrays
.Table
(A2
) := Arr
;
380 end Copy_Package_Declarations
;
387 (Project
: Project_Id
;
388 In_Tree
: Project_Tree_Ref
;
389 From_Project_Node
: Project_Node_Id
;
390 From_Project_Node_Tree
: Project_Node_Tree_Ref
;
392 First_Term
: Project_Node_Id
;
393 Kind
: Variable_Kind
) return Variable_Value
395 The_Term
: Project_Node_Id
:= First_Term
;
396 -- The term in the expression list
398 The_Current_Term
: Project_Node_Id
:= Empty_Node
;
399 -- The current term node id
401 Result
: Variable_Value
(Kind
=> Kind
);
402 -- The returned result
404 Last
: String_List_Id
:= Nil_String
;
405 -- Reference to the last string elements in Result, when Kind is List
408 Result
.Project
:= Project
;
409 Result
.Location
:= Location_Of
(First_Term
, From_Project_Node_Tree
);
411 -- Process each term of the expression, starting with First_Term
413 while The_Term
/= Empty_Node
loop
414 The_Current_Term
:= Current_Term
(The_Term
, From_Project_Node_Tree
);
416 case Kind_Of
(The_Current_Term
, From_Project_Node_Tree
) is
418 when N_Literal_String
=>
424 -- Should never happen
426 pragma Assert
(False, "Undefined expression kind");
432 (The_Current_Term
, From_Project_Node_Tree
));
435 (The_Current_Term
, From_Project_Node_Tree
);
439 String_Element_Table
.Increment_Last
440 (In_Tree
.String_Elements
);
442 if Last
= Nil_String
then
444 -- This can happen in an expression like () & "toto"
446 Result
.Values
:= String_Element_Table
.Last
447 (In_Tree
.String_Elements
);
450 In_Tree
.String_Elements
.Table
451 (Last
).Next
:= String_Element_Table
.Last
452 (In_Tree
.String_Elements
);
455 Last
:= String_Element_Table
.Last
456 (In_Tree
.String_Elements
);
457 In_Tree
.String_Elements
.Table
(Last
) :=
461 From_Project_Node_Tree
),
464 (The_Current_Term
, From_Project_Node_Tree
),
465 Display_Value
=> No_Name
,
469 From_Project_Node_Tree
),
474 when N_Literal_String_List
=>
477 String_Node
: Project_Node_Id
:=
478 First_Expression_In_List
480 From_Project_Node_Tree
);
482 Value
: Variable_Value
;
485 if String_Node
/= Empty_Node
then
487 -- If String_Node is nil, it is an empty list,
488 -- there is nothing to do
493 From_Project_Node
=> From_Project_Node
,
494 From_Project_Node_Tree
=> From_Project_Node_Tree
,
498 (String_Node
, From_Project_Node_Tree
),
500 String_Element_Table
.Increment_Last
501 (In_Tree
.String_Elements
);
503 if Result
.Values
= Nil_String
then
505 -- This literal string list is the first term
506 -- in a string list expression
509 String_Element_Table
.Last
(In_Tree
.String_Elements
);
512 In_Tree
.String_Elements
.Table
514 String_Element_Table
.Last
(In_Tree
.String_Elements
);
518 String_Element_Table
.Last
(In_Tree
.String_Elements
);
520 In_Tree
.String_Elements
.Table
(Last
) :=
521 (Value
=> Value
.Value
,
522 Display_Value
=> No_Name
,
523 Location
=> Value
.Location
,
526 Index
=> Value
.Index
);
529 -- Add the other element of the literal string list
530 -- one after the other
533 Next_Expression_In_List
534 (String_Node
, From_Project_Node_Tree
);
536 exit when String_Node
= Empty_Node
;
542 From_Project_Node
=> From_Project_Node
,
543 From_Project_Node_Tree
=> From_Project_Node_Tree
,
547 (String_Node
, From_Project_Node_Tree
),
550 String_Element_Table
.Increment_Last
551 (In_Tree
.String_Elements
);
552 In_Tree
.String_Elements
.Table
553 (Last
).Next
:= String_Element_Table
.Last
554 (In_Tree
.String_Elements
);
555 Last
:= String_Element_Table
.Last
556 (In_Tree
.String_Elements
);
557 In_Tree
.String_Elements
.Table
(Last
) :=
558 (Value
=> Value
.Value
,
559 Display_Value
=> No_Name
,
560 Location
=> Value
.Location
,
563 Index
=> Value
.Index
);
568 when N_Variable_Reference | N_Attribute_Reference
=>
571 The_Project
: Project_Id
:= Project
;
572 The_Package
: Package_Id
:= Pkg
;
573 The_Name
: Name_Id
:= No_Name
;
574 The_Variable_Id
: Variable_Id
:= No_Variable
;
575 The_Variable
: Variable_Value
;
576 Term_Project
: constant Project_Node_Id
:=
578 (The_Current_Term
, From_Project_Node_Tree
);
579 Term_Package
: constant Project_Node_Id
:=
581 (The_Current_Term
, From_Project_Node_Tree
);
582 Index
: Name_Id
:= No_Name
;
585 if Term_Project
/= Empty_Node
and then
586 Term_Project
/= From_Project_Node
588 -- This variable or attribute comes from another project
591 Name_Of
(Term_Project
, From_Project_Node_Tree
);
592 The_Project
:= Imported_Or_Extended_Project_From
595 With_Name
=> The_Name
);
598 if Term_Package
/= Empty_Node
then
600 -- This is an attribute of a package
603 Name_Of
(Term_Package
, From_Project_Node_Tree
);
604 The_Package
:= In_Tree
.Projects
.Table
605 (The_Project
).Decl
.Packages
;
607 while The_Package
/= No_Package
608 and then In_Tree
.Packages
.Table
609 (The_Package
).Name
/= The_Name
612 In_Tree
.Packages
.Table
617 (The_Package
/= No_Package
,
618 "package not found.");
620 elsif Kind_Of
(The_Current_Term
, From_Project_Node_Tree
) =
621 N_Attribute_Reference
623 The_Package
:= No_Package
;
627 Name_Of
(The_Current_Term
, From_Project_Node_Tree
);
629 if Kind_Of
(The_Current_Term
, From_Project_Node_Tree
) =
630 N_Attribute_Reference
633 Associative_Array_Index_Of
634 (The_Current_Term
, From_Project_Node_Tree
);
637 -- If it is not an associative array attribute
639 if Index
= No_Name
then
641 -- It is not an associative array attribute
643 if The_Package
/= No_Package
then
645 -- First, if there is a package, look into the package
647 if Kind_Of
(The_Current_Term
, From_Project_Node_Tree
) =
651 In_Tree
.Packages
.Table
652 (The_Package
).Decl
.Variables
;
655 In_Tree
.Packages
.Table
656 (The_Package
).Decl
.Attributes
;
659 while The_Variable_Id
/= No_Variable
661 In_Tree
.Variable_Elements
.Table
662 (The_Variable_Id
).Name
/= The_Name
665 In_Tree
.Variable_Elements
.Table
666 (The_Variable_Id
).Next
;
671 if The_Variable_Id
= No_Variable
then
673 -- If we have not found it, look into the project
675 if Kind_Of
(The_Current_Term
, From_Project_Node_Tree
) =
679 In_Tree
.Projects
.Table
680 (The_Project
).Decl
.Variables
;
683 In_Tree
.Projects
.Table
684 (The_Project
).Decl
.Attributes
;
687 while The_Variable_Id
/= No_Variable
689 In_Tree
.Variable_Elements
.Table
690 (The_Variable_Id
).Name
/= The_Name
693 In_Tree
.Variable_Elements
.Table
694 (The_Variable_Id
).Next
;
699 pragma Assert
(The_Variable_Id
/= No_Variable
,
700 "variable or attribute not found");
703 In_Tree
.Variable_Elements
.Table
704 (The_Variable_Id
).Value
;
708 -- It is an associative array attribute
711 The_Array
: Array_Id
:= No_Array
;
712 The_Element
: Array_Element_Id
:= No_Array_Element
;
713 Array_Index
: Name_Id
:= No_Name
;
716 if The_Package
/= No_Package
then
718 In_Tree
.Packages
.Table
719 (The_Package
).Decl
.Arrays
;
722 In_Tree
.Projects
.Table
723 (The_Project
).Decl
.Arrays
;
726 while The_Array
/= No_Array
727 and then In_Tree
.Arrays
.Table
728 (The_Array
).Name
/= The_Name
730 The_Array
:= In_Tree
.Arrays
.Table
734 if The_Array
/= No_Array
then
735 The_Element
:= In_Tree
.Arrays
.Table
738 Get_Name_String
(Index
);
741 (The_Current_Term
, From_Project_Node_Tree
)
743 To_Lower
(Name_Buffer
(1 .. Name_Len
));
746 Array_Index
:= Name_Find
;
748 while The_Element
/= No_Array_Element
750 In_Tree
.Array_Elements
.Table
751 (The_Element
).Index
/= Array_Index
754 In_Tree
.Array_Elements
.Table
760 if The_Element
/= No_Array_Element
then
762 In_Tree
.Array_Elements
.Table
766 if Expression_Kind_Of
767 (The_Current_Term
, From_Project_Node_Tree
) =
773 Location
=> No_Location
,
775 Values
=> Nil_String
);
780 Location
=> No_Location
,
782 Value
=> Empty_String
,
793 -- Should never happen
795 pragma Assert
(False, "undefined expression kind");
800 case The_Variable
.Kind
is
806 Add
(Result
.Value
, The_Variable
.Value
);
810 -- Should never happen
814 "list cannot appear in single " &
815 "string expression");
820 case The_Variable
.Kind
is
826 String_Element_Table
.Increment_Last
827 (In_Tree
.String_Elements
);
829 if Last
= Nil_String
then
831 -- This can happen in an expression such as
835 String_Element_Table
.Last
836 (In_Tree
.String_Elements
);
839 In_Tree
.String_Elements
.Table
841 String_Element_Table
.Last
842 (In_Tree
.String_Elements
);
846 String_Element_Table
.Last
847 (In_Tree
.String_Elements
);
849 In_Tree
.String_Elements
.Table
(Last
) :=
850 (Value
=> The_Variable
.Value
,
851 Display_Value
=> No_Name
,
852 Location
=> Location_Of
854 From_Project_Node_Tree
),
862 The_List
: String_List_Id
:=
866 while The_List
/= Nil_String
loop
867 String_Element_Table
.Increment_Last
868 (In_Tree
.String_Elements
);
870 if Last
= Nil_String
then
872 String_Element_Table
.Last
878 String_Elements
.Table
(Last
).Next
:=
879 String_Element_Table
.Last
886 String_Element_Table
.Last
887 (In_Tree
.String_Elements
);
889 In_Tree
.String_Elements
.Table
(Last
) :=
891 In_Tree
.String_Elements
.Table
893 Display_Value
=> No_Name
,
897 From_Project_Node_Tree
),
903 In_Tree
. String_Elements
.Table
911 when N_External_Value
=>
914 (External_Reference_Of
915 (The_Current_Term
, From_Project_Node_Tree
),
916 From_Project_Node_Tree
));
919 Name
: constant Name_Id
:= Name_Find
;
920 Default
: Name_Id
:= No_Name
;
921 Value
: Name_Id
:= No_Name
;
923 Def_Var
: Variable_Value
;
925 Default_Node
: constant Project_Node_Id
:=
927 (The_Current_Term
, From_Project_Node_Tree
);
930 -- If there is a default value for the external reference,
933 if Default_Node
/= Empty_Node
then
934 Def_Var
:= Expression
937 From_Project_Node
=> Default_Node
,
938 From_Project_Node_Tree
=> From_Project_Node_Tree
,
942 (Default_Node
, From_Project_Node_Tree
),
945 if Def_Var
/= Nil_Variable_Value
then
946 Default
:= Def_Var
.Value
;
950 Value
:= Prj
.Ext
.Value_Of
(Name
, Default
);
952 if Value
= No_Name
then
953 if not Opt
.Quiet_Output
then
954 if Error_Report
= null then
956 ("?undefined external reference",
958 (The_Current_Term
, From_Project_Node_Tree
));
961 ("warning: """ & Get_Name_String
(Name
) &
962 """ is an undefined external reference",
967 Value
:= Empty_String
;
976 Add
(Result
.Value
, Value
);
979 String_Element_Table
.Increment_Last
980 (In_Tree
.String_Elements
);
982 if Last
= Nil_String
then
983 Result
.Values
:= String_Element_Table
.Last
984 (In_Tree
.String_Elements
);
987 In_Tree
.String_Elements
.Table
988 (Last
).Next
:= String_Element_Table
.Last
989 (In_Tree
.String_Elements
);
992 Last
:= String_Element_Table
.Last
993 (In_Tree
.String_Elements
);
994 In_Tree
.String_Elements
.Table
(Last
) :=
996 Display_Value
=> No_Name
,
999 (The_Current_Term
, From_Project_Node_Tree
),
1009 -- Should never happen
1013 "illegal node kind in an expression");
1014 raise Program_Error
;
1018 The_Term
:= Next_Term
(The_Term
, From_Project_Node_Tree
);
1024 ---------------------------------------
1025 -- Imported_Or_Extended_Project_From --
1026 ---------------------------------------
1028 function Imported_Or_Extended_Project_From
1029 (Project
: Project_Id
;
1030 In_Tree
: Project_Tree_Ref
;
1031 With_Name
: Name_Id
) return Project_Id
1033 Data
: constant Project_Data
:=
1034 In_Tree
.Projects
.Table
(Project
);
1035 List
: Project_List
:= Data
.Imported_Projects
;
1036 Result
: Project_Id
:= No_Project
;
1037 Temp_Result
: Project_Id
:= No_Project
;
1040 -- First check if it is the name of an extended project
1042 if Data
.Extends
/= No_Project
1043 and then In_Tree
.Projects
.Table
(Data
.Extends
).Name
=
1046 return Data
.Extends
;
1049 -- Then check the name of each imported project
1051 while List
/= Empty_Project_List
loop
1052 Result
:= In_Tree
.Project_Lists
.Table
(List
).Project
;
1054 -- If the project is directly imported, then returns its ID
1057 In_Tree
.Projects
.Table
(Result
).Name
= With_Name
1062 -- If a project extending the project is imported, then keep
1063 -- this extending project as a possibility. It will be the
1064 -- returned ID if the project is not imported directly.
1067 Proj
: Project_Id
:=
1068 In_Tree
.Projects
.Table
(Result
).Extends
;
1070 while Proj
/= No_Project
loop
1071 if In_Tree
.Projects
.Table
(Proj
).Name
=
1074 Temp_Result
:= Result
;
1078 Proj
:= In_Tree
.Projects
.Table
(Proj
).Extends
;
1082 List
:= In_Tree
.Project_Lists
.Table
(List
).Next
;
1086 (Temp_Result
/= No_Project
,
1087 "project not found");
1091 end Imported_Or_Extended_Project_From
;
1097 function Package_From
1098 (Project
: Project_Id
;
1099 In_Tree
: Project_Tree_Ref
;
1100 With_Name
: Name_Id
) return Package_Id
1102 Data
: constant Project_Data
:=
1103 In_Tree
.Projects
.Table
(Project
);
1104 Result
: Package_Id
:= Data
.Decl
.Packages
;
1107 -- Check the name of each existing package of Project
1109 while Result
/= No_Package
1110 and then In_Tree
.Packages
.Table
(Result
).Name
/= With_Name
1112 Result
:= In_Tree
.Packages
.Table
(Result
).Next
;
1115 if Result
= No_Package
then
1117 -- Should never happen
1119 Write_Line
("package """ & Get_Name_String
(With_Name
) &
1121 raise Program_Error
;
1133 (In_Tree
: Project_Tree_Ref
;
1134 Project
: out Project_Id
;
1135 Success
: out Boolean;
1136 From_Project_Node
: Project_Node_Id
;
1137 From_Project_Node_Tree
: Project_Node_Tree_Ref
;
1138 Report_Error
: Put_Line_Access
;
1139 Follow_Links
: Boolean := True;
1140 When_No_Sources
: Error_Warning
:= Error
)
1143 Extending
: Project_Id
;
1144 Extending2
: Project_Id
;
1147 Error_Report
:= Report_Error
;
1150 -- Make sure there is no projects in the data structure
1152 Project_Table
.Set_Last
(In_Tree
.Projects
, No_Project
);
1153 Processed_Projects
.Reset
;
1155 -- And process the main project and all of the projects it depends on,
1159 (Project
=> Project
,
1161 From_Project_Node
=> From_Project_Node
,
1162 From_Project_Node_Tree
=> From_Project_Node_Tree
,
1163 Extended_By
=> No_Project
);
1165 if Project
/= No_Project
then
1166 Check
(In_Tree
, Project
, Follow_Links
, When_No_Sources
);
1169 -- If main project is an extending all project, set the object
1170 -- directory of all virtual extending projects to the object directory
1171 -- of the main project.
1173 if Project
/= No_Project
1174 and then Is_Extending_All
(From_Project_Node
, From_Project_Node_Tree
)
1177 Object_Dir
: constant Name_Id
:=
1178 In_Tree
.Projects
.Table
(Project
).Object_Directory
;
1181 Project_Table
.First
.. Project_Table
.Last
(In_Tree
.Projects
)
1183 if In_Tree
.Projects
.Table
(Index
).Virtual
then
1184 In_Tree
.Projects
.Table
(Index
).Object_Directory
:=
1191 -- Check that no extending project shares its object directory with
1192 -- the project(s) it extends.
1194 if Project
/= No_Project
then
1196 Project_Table
.First
.. Project_Table
.Last
(In_Tree
.Projects
)
1198 Extending
:= In_Tree
.Projects
.Table
(Proj
).Extended_By
;
1200 if Extending
/= No_Project
then
1201 Obj_Dir
:= In_Tree
.Projects
.Table
(Proj
).Object_Directory
;
1203 -- Check that a project being extended does not share its
1204 -- object directory with any project that extends it, directly
1205 -- or indirectly, including a virtual extending project.
1207 -- Start with the project directly extending it
1209 Extending2
:= Extending
;
1210 while Extending2
/= No_Project
loop
1211 if In_Tree
.Projects
.Table
(Extending2
).Ada_Sources_Present
1213 In_Tree
.Projects
.Table
(Extending2
).Object_Directory
=
1216 if In_Tree
.Projects
.Table
(Extending2
).Virtual
then
1218 In_Tree
.Projects
.Table
(Proj
).Display_Name
;
1220 if Error_Report
= null then
1222 ("project { cannot be extended by a virtual " &
1223 "project with the same object directory",
1224 In_Tree
.Projects
.Table
(Proj
).Location
);
1228 Get_Name_String
(Error_Msg_Name_1
) &
1229 """ cannot be extended by a virtual " &
1230 "project with the same object directory",
1236 In_Tree
.Projects
.Table
(Extending2
).Display_Name
;
1238 In_Tree
.Projects
.Table
(Proj
).Display_Name
;
1240 if Error_Report
= null then
1242 ("project { cannot extend project {",
1243 In_Tree
.Projects
.Table
(Extending2
).Location
);
1245 ("\they share the same object directory",
1246 In_Tree
.Projects
.Table
(Extending2
).Location
);
1251 Get_Name_String
(Error_Msg_Name_1
) &
1252 """ cannot extend project """ &
1253 Get_Name_String
(Error_Msg_Name_2
) & """",
1256 ("they share the same object directory",
1262 -- Continue with the next extending project, if any
1265 In_Tree
.Projects
.Table
(Extending2
).Extended_By
;
1271 Success
:= Total_Errors_Detected
= 0;
1274 -------------------------------
1275 -- Process_Declarative_Items --
1276 -------------------------------
1278 procedure Process_Declarative_Items
1279 (Project
: Project_Id
;
1280 In_Tree
: Project_Tree_Ref
;
1281 From_Project_Node
: Project_Node_Id
;
1282 From_Project_Node_Tree
: Project_Node_Tree_Ref
;
1284 Item
: Project_Node_Id
)
1286 Current_Declarative_Item
: Project_Node_Id
:= Item
;
1287 Current_Item
: Project_Node_Id
:= Empty_Node
;
1290 -- For each declarative item
1292 while Current_Declarative_Item
/= Empty_Node
loop
1298 (Current_Declarative_Item
, From_Project_Node_Tree
);
1300 -- And set Current_Declarative_Item to the next declarative item
1301 -- ready for the next iteration.
1303 Current_Declarative_Item
:=
1304 Next_Declarative_Item
1305 (Current_Declarative_Item
, From_Project_Node_Tree
);
1307 case Kind_Of
(Current_Item
, From_Project_Node_Tree
) is
1309 when N_Package_Declaration
=>
1310 -- Do not process a package declaration that should be ignored
1312 if Expression_Kind_Of
1313 (Current_Item
, From_Project_Node_Tree
) /= Ignored
1315 -- Create the new package
1317 Package_Table
.Increment_Last
(In_Tree
.Packages
);
1320 New_Pkg
: constant Package_Id
:=
1321 Package_Table
.Last
(In_Tree
.Packages
);
1322 The_New_Package
: Package_Element
;
1324 Project_Of_Renamed_Package
:
1325 constant Project_Node_Id
:=
1326 Project_Of_Renamed_Package_Of
1327 (Current_Item
, From_Project_Node_Tree
);
1330 -- Set the name of the new package
1332 The_New_Package
.Name
:=
1333 Name_Of
(Current_Item
, From_Project_Node_Tree
);
1335 -- Insert the new package in the appropriate list
1337 if Pkg
/= No_Package
then
1338 The_New_Package
.Next
:=
1339 In_Tree
.Packages
.Table
(Pkg
).Decl
.Packages
;
1340 In_Tree
.Packages
.Table
(Pkg
).Decl
.Packages
:=
1343 The_New_Package
.Next
:=
1344 In_Tree
.Projects
.Table
(Project
).Decl
.Packages
;
1345 In_Tree
.Projects
.Table
(Project
).Decl
.Packages
:=
1349 In_Tree
.Packages
.Table
(New_Pkg
) :=
1352 if Project_Of_Renamed_Package
/= Empty_Node
then
1357 Project_Name
: constant Name_Id
:=
1359 (Project_Of_Renamed_Package
,
1360 From_Project_Node_Tree
);
1363 constant Project_Id
:=
1364 Imported_Or_Extended_Project_From
1365 (Project
, In_Tree
, Project_Name
);
1367 Renamed_Package
: constant Package_Id
:=
1369 (Renamed_Project
, In_Tree
,
1372 From_Project_Node_Tree
));
1375 -- For a renamed package, copy the declarations of
1376 -- the renamed package, but set all the locations
1377 -- to the location of the package name in the
1378 -- renaming declaration.
1380 Copy_Package_Declarations
1382 In_Tree
.Packages
.Table
(Renamed_Package
).Decl
,
1384 In_Tree
.Packages
.Table
(New_Pkg
).Decl
,
1387 (Current_Item
, From_Project_Node_Tree
),
1388 In_Tree
=> In_Tree
);
1391 -- Standard package declaration, not renaming
1394 -- Set the default values of the attributes
1398 In_Tree
.Packages
.Table
(New_Pkg
).Decl
,
1401 (Current_Item
, From_Project_Node_Tree
)));
1403 -- And process declarative items of the new package
1405 Process_Declarative_Items
1406 (Project
=> Project
,
1408 From_Project_Node
=> From_Project_Node
,
1409 From_Project_Node_Tree
=> From_Project_Node_Tree
,
1412 First_Declarative_Item_Of
1413 (Current_Item
, From_Project_Node_Tree
));
1418 when N_String_Type_Declaration
=>
1420 -- There is nothing to process
1424 when N_Attribute_Declaration |
1425 N_Typed_Variable_Declaration |
1426 N_Variable_Declaration
=>
1428 if Expression_Of
(Current_Item
, From_Project_Node_Tree
) =
1432 -- It must be a full associative array attribute declaration
1435 Current_Item_Name
: constant Name_Id
:=
1436 Name_Of
(Current_Item
, From_Project_Node_Tree
);
1437 -- The name of the attribute
1439 New_Array
: Array_Id
;
1440 -- The new associative array created
1442 Orig_Array
: Array_Id
;
1443 -- The associative array value
1445 Orig_Project_Name
: Name_Id
:= No_Name
;
1446 -- The name of the project where the associative array
1449 Orig_Project
: Project_Id
:= No_Project
;
1450 -- The id of the project where the associative array
1453 Orig_Package_Name
: Name_Id
:= No_Name
;
1454 -- The name of the package, if any, where the associative
1457 Orig_Package
: Package_Id
:= No_Package
;
1458 -- The id of the package, if any, where the associative
1461 New_Element
: Array_Element_Id
:= No_Array_Element
;
1462 -- Id of a new array element created
1464 Prev_Element
: Array_Element_Id
:= No_Array_Element
;
1465 -- Last new element id created
1467 Orig_Element
: Array_Element_Id
:= No_Array_Element
;
1468 -- Current array element in the original associative
1471 Next_Element
: Array_Element_Id
:= No_Array_Element
;
1472 -- Id of the array element that follows the new element.
1473 -- This is not always nil, because values for the
1474 -- associative array attribute may already have been
1475 -- declared, and the array elements declared are reused.
1478 -- First, find if the associative array attribute already
1479 -- has elements declared.
1481 if Pkg
/= No_Package
then
1482 New_Array
:= In_Tree
.Packages
.Table
1486 New_Array
:= In_Tree
.Projects
.Table
1487 (Project
).Decl
.Arrays
;
1490 while New_Array
/= No_Array
1491 and then In_Tree
.Arrays
.Table
(New_Array
).Name
/=
1494 New_Array
:= In_Tree
.Arrays
.Table
(New_Array
).Next
;
1497 -- If the attribute has never been declared add new entry
1498 -- in the arrays of the project/package and link it.
1500 if New_Array
= No_Array
then
1501 Array_Table
.Increment_Last
(In_Tree
.Arrays
);
1502 New_Array
:= Array_Table
.Last
(In_Tree
.Arrays
);
1504 if Pkg
/= No_Package
then
1505 In_Tree
.Arrays
.Table
(New_Array
) :=
1506 (Name
=> Current_Item_Name
,
1507 Value
=> No_Array_Element
,
1509 In_Tree
.Packages
.Table
(Pkg
).Decl
.Arrays
);
1511 In_Tree
.Packages
.Table
(Pkg
).Decl
.Arrays
:=
1515 In_Tree
.Arrays
.Table
(New_Array
) :=
1516 (Name
=> Current_Item_Name
,
1517 Value
=> No_Array_Element
,
1519 In_Tree
.Projects
.Table
(Project
).Decl
.Arrays
);
1521 In_Tree
.Projects
.Table
(Project
).Decl
.Arrays
:=
1526 -- Find the project where the value is declared
1528 Orig_Project_Name
:=
1530 (Associative_Project_Of
1531 (Current_Item
, From_Project_Node_Tree
),
1532 From_Project_Node_Tree
);
1534 for Index
in Project_Table
.First
..
1538 if In_Tree
.Projects
.Table
(Index
).Name
=
1541 Orig_Project
:= Index
;
1546 pragma Assert
(Orig_Project
/= No_Project
,
1547 "original project not found");
1549 if Associative_Package_Of
1550 (Current_Item
, From_Project_Node_Tree
) = Empty_Node
1553 In_Tree
.Projects
.Table
1554 (Orig_Project
).Decl
.Arrays
;
1557 -- If in a package, find the package where the
1558 -- value is declared.
1560 Orig_Package_Name
:=
1562 (Associative_Package_Of
1563 (Current_Item
, From_Project_Node_Tree
),
1564 From_Project_Node_Tree
);
1567 In_Tree
.Projects
.Table
1568 (Orig_Project
).Decl
.Packages
;
1569 pragma Assert
(Orig_Package
/= No_Package
,
1570 "original package not found");
1572 while In_Tree
.Packages
.Table
1573 (Orig_Package
).Name
/= Orig_Package_Name
1575 Orig_Package
:= In_Tree
.Packages
.Table
1576 (Orig_Package
).Next
;
1577 pragma Assert
(Orig_Package
/= No_Package
,
1578 "original package not found");
1582 In_Tree
.Packages
.Table
1583 (Orig_Package
).Decl
.Arrays
;
1586 -- Now look for the array
1588 while Orig_Array
/= No_Array
and then
1589 In_Tree
.Arrays
.Table
(Orig_Array
).Name
/=
1592 Orig_Array
:= In_Tree
.Arrays
.Table
1596 if Orig_Array
= No_Array
then
1597 if Error_Report
= null then
1599 ("associative array value cannot be found",
1601 (Current_Item
, From_Project_Node_Tree
));
1605 ("associative array value cannot be found",
1611 In_Tree
.Arrays
.Table
(Orig_Array
).Value
;
1613 -- Copy each array element
1615 while Orig_Element
/= No_Array_Element
loop
1617 -- Case of first element
1619 if Prev_Element
= No_Array_Element
then
1621 -- And there is no array element declared yet,
1622 -- create a new first array element.
1624 if In_Tree
.Arrays
.Table
(New_Array
).Value
=
1627 Array_Element_Table
.Increment_Last
1628 (In_Tree
.Array_Elements
);
1629 New_Element
:= Array_Element_Table
.Last
1630 (In_Tree
.Array_Elements
);
1631 In_Tree
.Arrays
.Table
1632 (New_Array
).Value
:= New_Element
;
1633 Next_Element
:= No_Array_Element
;
1635 -- Otherwise, the new element is the first
1638 New_Element
:= In_Tree
.Arrays
.
1639 Table
(New_Array
).Value
;
1641 In_Tree
.Array_Elements
.Table
1645 -- Otherwise, reuse an existing element, or create
1646 -- one if necessary.
1650 In_Tree
.Array_Elements
.Table
1651 (Prev_Element
).Next
;
1653 if Next_Element
= No_Array_Element
then
1654 Array_Element_Table
.Increment_Last
1655 (In_Tree
.Array_Elements
);
1656 New_Element
:= Array_Element_Table
.Last
1657 (In_Tree
.Array_Elements
);
1660 New_Element
:= Next_Element
;
1662 In_Tree
.Array_Elements
.Table
1667 -- Copy the value of the element
1669 In_Tree
.Array_Elements
.Table
1671 In_Tree
.Array_Elements
.Table
1673 In_Tree
.Array_Elements
.Table
1674 (New_Element
).Value
.Project
:= Project
;
1676 -- Adjust the Next link
1678 In_Tree
.Array_Elements
.Table
1679 (New_Element
).Next
:= Next_Element
;
1681 -- Adjust the previous id for the next element
1683 Prev_Element
:= New_Element
;
1685 -- Go to the next element in the original array
1688 In_Tree
.Array_Elements
.Table
1689 (Orig_Element
).Next
;
1692 -- Make sure that the array ends here, in case there
1693 -- previously a greater number of elements.
1695 In_Tree
.Array_Elements
.Table
1696 (New_Element
).Next
:= No_Array_Element
;
1700 -- Declarations other that full associative arrays
1704 New_Value
: constant Variable_Value
:=
1706 (Project
=> Project
,
1708 From_Project_Node
=> From_Project_Node
,
1709 From_Project_Node_Tree
=> From_Project_Node_Tree
,
1714 (Current_Item
, From_Project_Node_Tree
),
1715 From_Project_Node_Tree
),
1718 (Current_Item
, From_Project_Node_Tree
));
1719 -- The expression value
1721 The_Variable
: Variable_Id
:= No_Variable
;
1723 Current_Item_Name
: constant Name_Id
:=
1724 Name_Of
(Current_Item
, From_Project_Node_Tree
);
1727 -- Process a typed variable declaration
1729 if Kind_Of
(Current_Item
, From_Project_Node_Tree
) =
1730 N_Typed_Variable_Declaration
1732 -- Report an error for an empty string
1734 if New_Value
.Value
= Empty_String
then
1736 Name_Of
(Current_Item
, From_Project_Node_Tree
);
1738 if Error_Report
= null then
1740 ("no value defined for %",
1742 (Current_Item
, From_Project_Node_Tree
));
1746 ("no value defined for " &
1747 Get_Name_String
(Error_Msg_Name_1
),
1753 Current_String
: Project_Node_Id
:=
1754 First_Literal_String
1757 From_Project_Node_Tree
),
1758 From_Project_Node_Tree
);
1761 -- Loop through all the valid strings for the
1762 -- string type and compare to the string value.
1764 while Current_String
/= Empty_Node
1767 (Current_String
, From_Project_Node_Tree
) /=
1772 (Current_String
, From_Project_Node_Tree
);
1775 -- Report an error if the string value is not
1776 -- one for the string type.
1778 if Current_String
= Empty_Node
then
1779 Error_Msg_Name_1
:= New_Value
.Value
;
1782 (Current_Item
, From_Project_Node_Tree
);
1784 if Error_Report
= null then
1786 ("value { is illegal for typed string %",
1789 From_Project_Node_Tree
));
1794 Get_Name_String
(Error_Msg_Name_1
) &
1795 """ is illegal for typed string """ &
1796 Get_Name_String
(Error_Msg_Name_2
) &
1805 if Kind_Of
(Current_Item
, From_Project_Node_Tree
) /=
1806 N_Attribute_Declaration
1808 Associative_Array_Index_Of
1809 (Current_Item
, From_Project_Node_Tree
) = No_Name
1811 -- Case of a variable declaration or of a not
1812 -- associative array attribute.
1814 -- First, find the list where to find the variable
1817 if Kind_Of
(Current_Item
, From_Project_Node_Tree
) =
1818 N_Attribute_Declaration
1820 if Pkg
/= No_Package
then
1822 In_Tree
.Packages
.Table
1823 (Pkg
).Decl
.Attributes
;
1826 In_Tree
.Projects
.Table
1827 (Project
).Decl
.Attributes
;
1831 if Pkg
/= No_Package
then
1833 In_Tree
.Packages
.Table
1834 (Pkg
).Decl
.Variables
;
1837 In_Tree
.Projects
.Table
1838 (Project
).Decl
.Variables
;
1843 -- Loop through the list, to find if it has already
1846 while The_Variable
/= No_Variable
1848 In_Tree
.Variable_Elements
.Table
1849 (The_Variable
).Name
/= Current_Item_Name
1852 In_Tree
.Variable_Elements
.Table
1853 (The_Variable
).Next
;
1856 -- If it has not been declared, create a new entry
1859 if The_Variable
= No_Variable
then
1861 -- All single string attribute should already have
1862 -- been declared with a default empty string value.
1865 (Kind_Of
(Current_Item
, From_Project_Node_Tree
) /=
1866 N_Attribute_Declaration
,
1867 "illegal attribute declaration");
1869 Variable_Element_Table
.Increment_Last
1870 (In_Tree
.Variable_Elements
);
1871 The_Variable
:= Variable_Element_Table
.Last
1872 (In_Tree
.Variable_Elements
);
1874 -- Put the new variable in the appropriate list
1876 if Pkg
/= No_Package
then
1877 In_Tree
.Variable_Elements
.Table
(The_Variable
) :=
1879 In_Tree
.Packages
.Table
1880 (Pkg
).Decl
.Variables
,
1881 Name
=> Current_Item_Name
,
1882 Value
=> New_Value
);
1883 In_Tree
.Packages
.Table
1884 (Pkg
).Decl
.Variables
:= The_Variable
;
1887 In_Tree
.Variable_Elements
.Table
(The_Variable
) :=
1889 In_Tree
.Projects
.Table
1890 (Project
).Decl
.Variables
,
1891 Name
=> Current_Item_Name
,
1892 Value
=> New_Value
);
1893 In_Tree
.Projects
.Table
1894 (Project
).Decl
.Variables
:=
1898 -- If the variable/attribute has already been
1899 -- declared, just change the value.
1902 In_Tree
.Variable_Elements
.Table
1903 (The_Variable
).Value
:=
1909 -- Associative array attribute
1911 -- Get the string index
1914 (Associative_Array_Index_Of
1915 (Current_Item
, From_Project_Node_Tree
));
1917 -- Put in lower case, if necessary
1920 (Current_Item
, From_Project_Node_Tree
)
1922 GNAT
.Case_Util
.To_Lower
1923 (Name_Buffer
(1 .. Name_Len
));
1927 The_Array
: Array_Id
;
1929 The_Array_Element
: Array_Element_Id
:=
1932 Index_Name
: constant Name_Id
:= Name_Find
;
1933 -- The name id of the index
1936 -- Look for the array in the appropriate list
1938 if Pkg
/= No_Package
then
1939 The_Array
:= In_Tree
.Packages
.Table
1943 The_Array
:= In_Tree
.Projects
.Table
1944 (Project
).Decl
.Arrays
;
1948 The_Array
/= No_Array
1949 and then In_Tree
.Arrays
.Table
1950 (The_Array
).Name
/= Current_Item_Name
1952 The_Array
:= In_Tree
.Arrays
.Table
1956 -- If the array cannot be found, create a new
1957 -- entry in the list. As The_Array_Element is
1958 -- initialized to No_Array_Element, a new element
1959 -- will be created automatically later.
1961 if The_Array
= No_Array
then
1962 Array_Table
.Increment_Last
1964 The_Array
:= Array_Table
.Last
1967 if Pkg
/= No_Package
then
1968 In_Tree
.Arrays
.Table
1970 (Name
=> Current_Item_Name
,
1971 Value
=> No_Array_Element
,
1973 In_Tree
.Packages
.Table
1976 In_Tree
.Packages
.Table
1977 (Pkg
).Decl
.Arrays
:=
1981 In_Tree
.Arrays
.Table
1983 (Name
=> Current_Item_Name
,
1984 Value
=> No_Array_Element
,
1986 In_Tree
.Projects
.Table
1987 (Project
).Decl
.Arrays
);
1989 In_Tree
.Projects
.Table
1990 (Project
).Decl
.Arrays
:=
1994 -- Otherwise, initialize The_Array_Element as the
1995 -- head of the element list.
1998 The_Array_Element
:=
1999 In_Tree
.Arrays
.Table
2003 -- Look in the list, if any, to find an element
2004 -- with the same index.
2006 while The_Array_Element
/= No_Array_Element
2008 In_Tree
.Array_Elements
.Table
2009 (The_Array_Element
).Index
/= Index_Name
2011 The_Array_Element
:=
2012 In_Tree
.Array_Elements
.Table
2013 (The_Array_Element
).Next
;
2016 -- If no such element were found, create a new
2017 -- one and insert it in the element list, with
2018 -- the propoer value.
2020 if The_Array_Element
= No_Array_Element
then
2021 Array_Element_Table
.Increment_Last
2022 (In_Tree
.Array_Elements
);
2023 The_Array_Element
:= Array_Element_Table
.Last
2024 (In_Tree
.Array_Elements
);
2026 In_Tree
.Array_Elements
.Table
2027 (The_Array_Element
) :=
2028 (Index
=> Index_Name
,
2031 (Current_Item
, From_Project_Node_Tree
),
2032 Index_Case_Sensitive
=>
2033 not Case_Insensitive
2034 (Current_Item
, From_Project_Node_Tree
),
2036 Next
=> In_Tree
.Arrays
.Table
2038 In_Tree
.Arrays
.Table
2039 (The_Array
).Value
:= The_Array_Element
;
2041 -- An element with the same index already exists,
2042 -- just replace its value with the new one.
2045 In_Tree
.Array_Elements
.Table
2046 (The_Array_Element
).Value
:= New_Value
;
2053 when N_Case_Construction
=>
2055 The_Project
: Project_Id
:= Project
;
2056 -- The id of the project of the case variable
2058 The_Package
: Package_Id
:= Pkg
;
2059 -- The id of the package, if any, of the case variable
2061 The_Variable
: Variable_Value
:= Nil_Variable_Value
;
2062 -- The case variable
2064 Case_Value
: Name_Id
:= No_Name
;
2065 -- The case variable value
2067 Case_Item
: Project_Node_Id
:= Empty_Node
;
2068 Choice_String
: Project_Node_Id
:= Empty_Node
;
2069 Decl_Item
: Project_Node_Id
:= Empty_Node
;
2073 Variable_Node
: constant Project_Node_Id
:=
2074 Case_Variable_Reference_Of
2076 From_Project_Node_Tree
);
2078 Var_Id
: Variable_Id
:= No_Variable
;
2079 Name
: Name_Id
:= No_Name
;
2082 -- If a project were specified for the case variable,
2086 (Variable_Node
, From_Project_Node_Tree
) /= Empty_Node
2091 (Variable_Node
, From_Project_Node_Tree
),
2092 From_Project_Node_Tree
);
2094 Imported_Or_Extended_Project_From
2095 (Project
, In_Tree
, Name
);
2098 -- If a package were specified for the case variable,
2102 (Variable_Node
, From_Project_Node_Tree
) /= Empty_Node
2107 (Variable_Node
, From_Project_Node_Tree
),
2108 From_Project_Node_Tree
);
2110 Package_From
(The_Project
, In_Tree
, Name
);
2113 Name
:= Name_Of
(Variable_Node
, From_Project_Node_Tree
);
2115 -- First, look for the case variable into the package,
2118 if The_Package
/= No_Package
then
2119 Var_Id
:= In_Tree
.Packages
.Table
2120 (The_Package
).Decl
.Variables
;
2122 Name_Of
(Variable_Node
, From_Project_Node_Tree
);
2123 while Var_Id
/= No_Variable
2125 In_Tree
.Variable_Elements
.Table
2126 (Var_Id
).Name
/= Name
2128 Var_Id
:= In_Tree
.Variable_Elements
.
2129 Table
(Var_Id
).Next
;
2133 -- If not found in the package, or if there is no
2134 -- package, look at the project level.
2136 if Var_Id
= No_Variable
2139 (Variable_Node
, From_Project_Node_Tree
) = Empty_Node
2141 Var_Id
:= In_Tree
.Projects
.Table
2142 (The_Project
).Decl
.Variables
;
2143 while Var_Id
/= No_Variable
2145 In_Tree
.Variable_Elements
.Table
2146 (Var_Id
).Name
/= Name
2148 Var_Id
:= In_Tree
.Variable_Elements
.
2149 Table
(Var_Id
).Next
;
2153 if Var_Id
= No_Variable
then
2155 -- Should never happen, because this has already been
2156 -- checked during parsing.
2158 Write_Line
("variable """ &
2159 Get_Name_String
(Name
) &
2161 raise Program_Error
;
2164 -- Get the case variable
2166 The_Variable
:= In_Tree
.Variable_Elements
.
2167 Table
(Var_Id
).Value
;
2169 if The_Variable
.Kind
/= Single
then
2171 -- Should never happen, because this has already been
2172 -- checked during parsing.
2174 Write_Line
("variable""" &
2175 Get_Name_String
(Name
) &
2176 """ is not a single string variable");
2177 raise Program_Error
;
2180 -- Get the case variable value
2181 Case_Value
:= The_Variable
.Value
;
2184 -- Now look into all the case items of the case construction
2187 First_Case_Item_Of
(Current_Item
, From_Project_Node_Tree
);
2189 while Case_Item
/= Empty_Node
loop
2191 First_Choice_Of
(Case_Item
, From_Project_Node_Tree
);
2193 -- When Choice_String is nil, it means that it is
2194 -- the "when others =>" alternative.
2196 if Choice_String
= Empty_Node
then
2198 First_Declarative_Item_Of
2199 (Case_Item
, From_Project_Node_Tree
);
2200 exit Case_Item_Loop
;
2203 -- Look into all the alternative of this case item
2206 while Choice_String
/= Empty_Node
loop
2209 (Choice_String
, From_Project_Node_Tree
)
2212 First_Declarative_Item_Of
2213 (Case_Item
, From_Project_Node_Tree
);
2214 exit Case_Item_Loop
;
2219 (Choice_String
, From_Project_Node_Tree
);
2220 end loop Choice_Loop
;
2223 Next_Case_Item
(Case_Item
, From_Project_Node_Tree
);
2224 end loop Case_Item_Loop
;
2226 -- If there is an alternative, then we process it
2228 if Decl_Item
/= Empty_Node
then
2229 Process_Declarative_Items
2230 (Project
=> Project
,
2232 From_Project_Node
=> From_Project_Node
,
2233 From_Project_Node_Tree
=> From_Project_Node_Tree
,
2241 -- Should never happen
2243 Write_Line
("Illegal declarative item: " &
2244 Project_Node_Kind
'Image
2246 (Current_Item
, From_Project_Node_Tree
)));
2247 raise Program_Error
;
2250 end Process_Declarative_Items
;
2252 ---------------------
2253 -- Recursive_Check --
2254 ---------------------
2256 procedure Recursive_Check
2257 (Project
: Project_Id
;
2258 In_Tree
: Project_Tree_Ref
;
2259 Follow_Links
: Boolean;
2260 When_No_Sources
: Error_Warning
)
2262 Data
: Project_Data
;
2263 Imported_Project_List
: Project_List
:= Empty_Project_List
;
2266 -- Do nothing if Project is No_Project, or Project has already
2267 -- been marked as checked.
2269 if Project
/= No_Project
2270 and then not In_Tree
.Projects
.Table
(Project
).Checked
2272 -- Mark project as checked, to avoid infinite recursion in
2273 -- ill-formed trees, where a project imports itself.
2275 In_Tree
.Projects
.Table
(Project
).Checked
:= True;
2277 Data
:= In_Tree
.Projects
.Table
(Project
);
2279 -- Call itself for a possible extended project.
2280 -- (if there is no extended project, then nothing happens).
2283 (Data
.Extends
, In_Tree
, Follow_Links
, When_No_Sources
);
2285 -- Call itself for all imported projects
2287 Imported_Project_List
:= Data
.Imported_Projects
;
2288 while Imported_Project_List
/= Empty_Project_List
loop
2290 (In_Tree
.Project_Lists
.Table
2291 (Imported_Project_List
).Project
,
2292 In_Tree
, Follow_Links
, When_No_Sources
);
2293 Imported_Project_List
:=
2294 In_Tree
.Project_Lists
.Table
2295 (Imported_Project_List
).Next
;
2298 if Opt
.Verbose_Mode
then
2299 Write_Str
("Checking project file """);
2300 Write_Str
(Get_Name_String
(Data
.Name
));
2305 (Project
, In_Tree
, Error_Report
, Follow_Links
, When_No_Sources
);
2307 end Recursive_Check
;
2309 -----------------------
2310 -- Recursive_Process --
2311 -----------------------
2313 procedure Recursive_Process
2314 (In_Tree
: Project_Tree_Ref
;
2315 Project
: out Project_Id
;
2316 From_Project_Node
: Project_Node_Id
;
2317 From_Project_Node_Tree
: Project_Node_Tree_Ref
;
2318 Extended_By
: Project_Id
)
2320 With_Clause
: Project_Node_Id
;
2323 if From_Project_Node
= Empty_Node
then
2324 Project
:= No_Project
;
2328 Processed_Data
: Project_Data
:= Empty_Project
(In_Tree
);
2329 Imported
: Project_List
:= Empty_Project_List
;
2330 Declaration_Node
: Project_Node_Id
:= Empty_Node
;
2331 Tref
: Source_Buffer_Ptr
;
2332 Name
: constant Name_Id
:=
2334 (From_Project_Node
, From_Project_Node_Tree
);
2335 Location
: Source_Ptr
:=
2337 (From_Project_Node
, From_Project_Node_Tree
);
2340 Project
:= Processed_Projects
.Get
(Name
);
2342 if Project
/= No_Project
then
2346 Project_Table
.Increment_Last
(In_Tree
.Projects
);
2347 Project
:= Project_Table
.Last
(In_Tree
.Projects
);
2348 Processed_Projects
.Set
(Name
, Project
);
2350 Processed_Data
.Name
:= Name
;
2352 Get_Name_String
(Name
);
2354 -- If name starts with the virtual prefix, flag the project as
2355 -- being a virtual extending project.
2357 if Name_Len
> Virtual_Prefix
'Length
2358 and then Name_Buffer
(1 .. Virtual_Prefix
'Length) =
2361 Processed_Data
.Virtual
:= True;
2362 Processed_Data
.Display_Name
:= Name
;
2364 -- If there is no file, for example when the project node tree is
2365 -- built in memory by GPS, the Display_Name cannot be found in
2366 -- the source, so its value is the same as Name.
2368 elsif Location
= No_Location
then
2369 Processed_Data
.Display_Name
:= Name
;
2371 -- Get the spelling of the project name from the project file
2374 Tref
:= Source_Text
(Get_Source_File_Index
(Location
));
2376 for J
in 1 .. Name_Len
loop
2377 Name_Buffer
(J
) := Tref
(Location
);
2378 Location
:= Location
+ 1;
2381 Processed_Data
.Display_Name
:= Name_Find
;
2384 Processed_Data
.Display_Path_Name
:=
2385 Path_Name_Of
(From_Project_Node
, From_Project_Node_Tree
);
2386 Get_Name_String
(Processed_Data
.Display_Path_Name
);
2387 Canonical_Case_File_Name
(Name_Buffer
(1 .. Name_Len
));
2388 Processed_Data
.Path_Name
:= Name_Find
;
2390 Processed_Data
.Location
:=
2391 Location_Of
(From_Project_Node
, From_Project_Node_Tree
);
2393 Processed_Data
.Display_Directory
:=
2394 Directory_Of
(From_Project_Node
, From_Project_Node_Tree
);
2395 Get_Name_String
(Processed_Data
.Display_Directory
);
2396 Canonical_Case_File_Name
(Name_Buffer
(1 .. Name_Len
));
2397 Processed_Data
.Directory
:= Name_Find
;
2399 Processed_Data
.Extended_By
:= Extended_By
;
2402 (Project
, In_Tree
, Processed_Data
.Decl
, Attribute_First
);
2404 First_With_Clause_Of
(From_Project_Node
, From_Project_Node_Tree
);
2406 while With_Clause
/= Empty_Node
loop
2408 New_Project
: Project_Id
;
2409 New_Data
: Project_Data
;
2413 (In_Tree
=> In_Tree
,
2414 Project
=> New_Project
,
2415 From_Project_Node
=>
2416 Project_Node_Of
(With_Clause
, From_Project_Node_Tree
),
2417 From_Project_Node_Tree
=> From_Project_Node_Tree
,
2418 Extended_By
=> No_Project
);
2420 In_Tree
.Projects
.Table
(New_Project
);
2422 -- If we were the first project to import it,
2423 -- set First_Referred_By to us.
2425 if New_Data
.First_Referred_By
= No_Project
then
2426 New_Data
.First_Referred_By
:= Project
;
2427 In_Tree
.Projects
.Table
(New_Project
) :=
2431 -- Add this project to our list of imported projects
2433 Project_List_Table
.Increment_Last
2434 (In_Tree
.Project_Lists
);
2435 In_Tree
.Project_Lists
.Table
2436 (Project_List_Table
.Last
2437 (In_Tree
.Project_Lists
)) :=
2438 (Project
=> New_Project
, Next
=> Empty_Project_List
);
2440 -- Imported is the id of the last imported project.
2441 -- If it is nil, then this imported project is our first.
2443 if Imported
= Empty_Project_List
then
2444 Processed_Data
.Imported_Projects
:=
2445 Project_List_Table
.Last
2446 (In_Tree
.Project_Lists
);
2449 In_Tree
.Project_Lists
.Table
2450 (Imported
).Next
:= Project_List_Table
.Last
2451 (In_Tree
.Project_Lists
);
2454 Imported
:= Project_List_Table
.Last
2455 (In_Tree
.Project_Lists
);
2458 Next_With_Clause_Of
(With_Clause
, From_Project_Node_Tree
);
2463 Project_Declaration_Of
2464 (From_Project_Node
, From_Project_Node_Tree
);
2467 (In_Tree
=> In_Tree
,
2468 Project
=> Processed_Data
.Extends
,
2469 From_Project_Node
=>
2471 (Declaration_Node
, From_Project_Node_Tree
),
2472 From_Project_Node_Tree
=> From_Project_Node_Tree
,
2473 Extended_By
=> Project
);
2475 In_Tree
.Projects
.Table
(Project
) := Processed_Data
;
2477 Process_Declarative_Items
2478 (Project
=> Project
,
2480 From_Project_Node
=> From_Project_Node
,
2481 From_Project_Node_Tree
=> From_Project_Node_Tree
,
2484 First_Declarative_Item_Of
2485 (Declaration_Node
, From_Project_Node_Tree
));
2487 -- If it is an extending project, inherit all packages
2488 -- from the extended project that are not explicitely defined
2489 -- or renamed. Also inherit the languages, if attribute Languages
2490 -- is not explicitely defined.
2492 if Processed_Data
.Extends
/= No_Project
then
2493 Processed_Data
:= In_Tree
.Projects
.Table
(Project
);
2496 Extended_Pkg
: Package_Id
:=
2497 In_Tree
.Projects
.Table
2498 (Processed_Data
.Extends
).Decl
.Packages
;
2499 Current_Pkg
: Package_Id
;
2500 Element
: Package_Element
;
2501 First
: constant Package_Id
:=
2502 Processed_Data
.Decl
.Packages
;
2503 Attribute1
: Variable_Id
;
2504 Attribute2
: Variable_Id
;
2505 Attr_Value1
: Variable
;
2506 Attr_Value2
: Variable
;
2509 while Extended_Pkg
/= No_Package
loop
2511 In_Tree
.Packages
.Table
(Extended_Pkg
);
2513 Current_Pkg
:= First
;
2516 exit when Current_Pkg
= No_Package
2517 or else In_Tree
.Packages
.Table
2518 (Current_Pkg
).Name
= Element
.Name
;
2519 Current_Pkg
:= In_Tree
.Packages
.Table
2523 if Current_Pkg
= No_Package
then
2524 Package_Table
.Increment_Last
2526 Current_Pkg
:= Package_Table
.Last
2528 In_Tree
.Packages
.Table
(Current_Pkg
) :=
2529 (Name
=> Element
.Name
,
2530 Decl
=> Element
.Decl
,
2531 Parent
=> No_Package
,
2532 Next
=> Processed_Data
.Decl
.Packages
);
2533 Processed_Data
.Decl
.Packages
:= Current_Pkg
;
2536 Extended_Pkg
:= Element
.Next
;
2539 -- Check if attribute Languages is declared in the
2540 -- extending project.
2542 Attribute1
:= Processed_Data
.Decl
.Attributes
;
2543 while Attribute1
/= No_Variable
loop
2544 Attr_Value1
:= In_Tree
.Variable_Elements
.
2546 exit when Attr_Value1
.Name
= Snames
.Name_Languages
;
2547 Attribute1
:= Attr_Value1
.Next
;
2550 if Attribute1
= No_Variable
or else
2551 Attr_Value1
.Value
.Default
2553 -- Attribute Languages is not declared in the extending
2554 -- project. Check if it is declared in the project being
2558 In_Tree
.Projects
.Table
2559 (Processed_Data
.Extends
).Decl
.Attributes
;
2561 while Attribute2
/= No_Variable
loop
2562 Attr_Value2
:= In_Tree
.Variable_Elements
.
2564 exit when Attr_Value2
.Name
= Snames
.Name_Languages
;
2565 Attribute2
:= Attr_Value2
.Next
;
2568 if Attribute2
/= No_Variable
and then
2569 not Attr_Value2
.Value
.Default
2571 -- As attribute Languages is declared in the project
2572 -- being extended, copy its value for the extending
2575 if Attribute1
= No_Variable
then
2576 Variable_Element_Table
.Increment_Last
2577 (In_Tree
.Variable_Elements
);
2578 Attribute1
:= Variable_Element_Table
.Last
2579 (In_Tree
.Variable_Elements
);
2580 Attr_Value1
.Next
:= Processed_Data
.Decl
.Attributes
;
2581 Processed_Data
.Decl
.Attributes
:= Attribute1
;
2584 Attr_Value1
.Name
:= Snames
.Name_Languages
;
2585 Attr_Value1
.Value
:= Attr_Value2
.Value
;
2586 In_Tree
.Variable_Elements
.Table
2587 (Attribute1
) := Attr_Value1
;
2592 In_Tree
.Projects
.Table
(Project
) := Processed_Data
;
2596 end Recursive_Process
;