1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2013, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Err_Vars
; use Err_Vars
;
29 with Osint
; use Osint
;
30 with Output
; use Output
;
31 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
;
40 with Ada
.Containers
.Vectors
;
41 with Ada
.Strings
.Fixed
; use Ada
.Strings
.Fixed
;
43 with GNAT
.Case_Util
; use GNAT
.Case_Util
;
46 package body Prj
.Proc
is
48 package Processed_Projects
is new GNAT
.HTable
.Simple_HTable
49 (Header_Num
=> Header_Num
,
50 Element
=> Project_Id
,
51 No_Element
=> No_Project
,
55 -- This hash table contains all processed projects
57 package Unit_Htable
is new GNAT
.HTable
.Simple_HTable
58 (Header_Num
=> Header_Num
,
60 No_Element
=> No_Source
,
64 -- This hash table contains all processed projects
66 procedure Add
(To_Exp
: in out Name_Id
; Str
: Name_Id
);
67 -- Concatenate two strings and returns another string if both
68 -- arguments are not null string.
70 -- In the following procedures, we are expected to guess the meaning of
71 -- the parameters from their names, this is never a good idea, comments
72 -- should be added precisely defining every formal ???
74 procedure Add_Attributes
75 (Project
: Project_Id
;
76 Project_Name
: Name_Id
;
77 Project_Dir
: Name_Id
;
78 Shared
: Shared_Project_Tree_Data_Access
;
79 Decl
: in out Declarations
;
80 First
: Attribute_Node_Id
;
81 Project_Level
: Boolean);
82 -- Add all attributes, starting with First, with their default values to
83 -- the package or project with declarations Decl.
86 (In_Tree
: Project_Tree_Ref
;
88 Node_Tree
: Prj
.Tree
.Project_Node_Tree_Ref
;
89 Flags
: Processing_Flags
);
90 -- Set all projects to not checked, then call Recursive_Check for the
91 -- main project Project. Project is set to No_Project if errors occurred.
92 -- Current_Dir is for optimization purposes, avoiding extra system calls.
93 -- If Allow_Duplicate_Basenames, then files with the same base names are
94 -- authorized within a project for source-based languages (never for unit
97 procedure Copy_Package_Declarations
99 To
: in out Declarations
;
100 New_Loc
: Source_Ptr
;
101 Restricted
: Boolean;
102 Shared
: Shared_Project_Tree_Data_Access
);
103 -- Copy a package declaration From to To for a renamed package. Change the
104 -- locations of all the attributes to New_Loc. When Restricted is
105 -- True, do not copy attributes Body, Spec, Implementation, Specification
106 -- and Linker_Options.
109 (Project
: Project_Id
;
110 Shared
: Shared_Project_Tree_Data_Access
;
111 From_Project_Node
: Project_Node_Id
;
112 From_Project_Node_Tree
: Project_Node_Tree_Ref
;
113 Env
: Prj
.Tree
.Environment
;
115 First_Term
: Project_Node_Id
;
116 Kind
: Variable_Kind
) return Variable_Value
;
117 -- From N_Expression project node From_Project_Node, compute the value
118 -- of an expression and return it as a Variable_Value.
120 function Imported_Or_Extended_Project_From
121 (Project
: Project_Id
;
122 With_Name
: Name_Id
) return Project_Id
;
123 -- Find an imported or extended project of Project whose name is With_Name
125 function Package_From
126 (Project
: Project_Id
;
127 Shared
: Shared_Project_Tree_Data_Access
;
128 With_Name
: Name_Id
) return Package_Id
;
129 -- Find the package of Project whose name is With_Name
131 procedure Process_Declarative_Items
132 (Project
: Project_Id
;
133 In_Tree
: Project_Tree_Ref
;
134 From_Project_Node
: Project_Node_Id
;
135 Node_Tree
: Project_Node_Tree_Ref
;
136 Env
: Prj
.Tree
.Environment
;
138 Item
: Project_Node_Id
;
139 Child_Env
: in out Prj
.Tree
.Environment
);
140 -- Process declarative items starting with From_Project_Node, and put them
141 -- in declarations Decl. This is a recursive procedure; it calls itself for
142 -- a package declaration or a case construction.
144 -- Child_Env is the modified environment after seeing declarations like
145 -- "for External(...) use" or "for Project_Path use" in aggregate projects.
146 -- It should have been initialized first.
148 procedure Recursive_Process
149 (In_Tree
: Project_Tree_Ref
;
150 Project
: out Project_Id
;
151 Packages_To_Check
: String_List_Access
;
152 From_Project_Node
: Project_Node_Id
;
153 From_Project_Node_Tree
: Project_Node_Tree_Ref
;
154 Env
: in out Prj
.Tree
.Environment
;
155 Extended_By
: Project_Id
;
156 From_Encapsulated_Lib
: Boolean);
157 -- Process project with node From_Project_Node in the tree. Do nothing if
158 -- From_Project_Node is Empty_Node. If project has already been processed,
159 -- simply return its project id. Otherwise create a new project id, mark it
160 -- as processed, call itself recursively for all imported projects and a
161 -- extended project, if any. Then process the declarative items of the
164 -- Is_Root_Project should be true only for the project that the user
165 -- explicitly loaded. In the context of aggregate projects, only that
166 -- project is allowed to modify the environment that will be used to load
167 -- projects (Child_Env).
169 -- From_Encapsulated_Lib is true if we are parsing a project from
170 -- encapsulated library dependencies.
172 function Get_Attribute_Index
173 (Tree
: Project_Node_Tree_Ref
;
174 Attr
: Project_Node_Id
;
175 Index
: Name_Id
) return Name_Id
;
176 -- Copy the index of the attribute into Name_Buffer, converting to lower
177 -- case if the attribute is case-insensitive.
183 procedure Add
(To_Exp
: in out Name_Id
; Str
: Name_Id
) is
185 if To_Exp
= No_Name
or else To_Exp
= Empty_String
then
187 -- To_Exp is nil or empty. The result is Str
191 -- If Str is nil, then do not change To_Ext
193 elsif Str
/= No_Name
and then Str
/= Empty_String
then
195 S
: constant String := Get_Name_String
(Str
);
197 Get_Name_String
(To_Exp
);
198 Add_Str_To_Name_Buffer
(S
);
208 procedure Add_Attributes
209 (Project
: Project_Id
;
210 Project_Name
: Name_Id
;
211 Project_Dir
: Name_Id
;
212 Shared
: Shared_Project_Tree_Data_Access
;
213 Decl
: in out Declarations
;
214 First
: Attribute_Node_Id
;
215 Project_Level
: Boolean)
217 The_Attribute
: Attribute_Node_Id
:= First
;
220 while The_Attribute
/= Empty_Attribute
loop
221 if Attribute_Kind_Of
(The_Attribute
) = Single
then
223 New_Attribute
: Variable_Value
;
226 case Variable_Kind_Of
(The_Attribute
) is
228 -- Undefined should not happen
232 (False, "attribute with an undefined kind");
235 -- Single attributes have a default value of empty string
241 Location
=> No_Location
,
243 Value
=> Empty_String
,
246 -- Special cases of <project>'Name and
247 -- <project>'Project_Dir.
249 if Project_Level
then
250 if Attribute_Name_Of
(The_Attribute
) =
253 New_Attribute
.Value
:= Project_Name
;
255 elsif Attribute_Name_Of
(The_Attribute
) =
256 Snames
.Name_Project_Dir
258 New_Attribute
.Value
:= Project_Dir
;
262 -- List attributes have a default value of nil list
268 Location
=> No_Location
,
270 Values
=> Nil_String
);
274 Variable_Element_Table
.Increment_Last
275 (Shared
.Variable_Elements
);
276 Shared
.Variable_Elements
.Table
277 (Variable_Element_Table
.Last
(Shared
.Variable_Elements
)) :=
278 (Next
=> Decl
.Attributes
,
279 Name
=> Attribute_Name_Of
(The_Attribute
),
280 Value
=> New_Attribute
);
282 Variable_Element_Table
.Last
283 (Shared
.Variable_Elements
);
287 The_Attribute
:= Next_Attribute
(After
=> The_Attribute
);
296 (In_Tree
: Project_Tree_Ref
;
297 Project
: Project_Id
;
298 Node_Tree
: Prj
.Tree
.Project_Node_Tree_Ref
;
299 Flags
: Processing_Flags
)
302 Process_Naming_Scheme
(In_Tree
, Project
, Node_Tree
, Flags
);
304 -- Set the Other_Part field for the units
310 Iter
: Source_Iterator
;
315 Iter
:= For_Each_Source
(In_Tree
);
317 Source1
:= Prj
.Element
(Iter
);
318 exit when Source1
= No_Source
;
320 if Source1
.Unit
/= No_Unit_Index
then
321 Name
:= Source1
.Unit
.Name
;
322 Source2
:= Unit_Htable
.Get
(Name
);
324 if Source2
= No_Source
then
325 Unit_Htable
.Set
(K
=> Name
, E
=> Source1
);
327 Unit_Htable
.Remove
(Name
);
336 -------------------------------
337 -- Copy_Package_Declarations --
338 -------------------------------
340 procedure Copy_Package_Declarations
341 (From
: Declarations
;
342 To
: in out Declarations
;
343 New_Loc
: Source_Ptr
;
344 Restricted
: Boolean;
345 Shared
: Shared_Project_Tree_Data_Access
)
348 V2
: Variable_Id
:= No_Variable
;
351 A2
: Array_Id
:= No_Array
;
353 E1
: Array_Element_Id
;
354 E2
: Array_Element_Id
:= No_Array_Element
;
358 -- To avoid references in error messages to attribute declarations in
359 -- an original package that has been renamed, copy all the attribute
360 -- declarations of the package and change all locations to New_Loc,
361 -- the location of the renamed package.
363 -- First single attributes
365 V1
:= From
.Attributes
;
366 while V1
/= No_Variable
loop
368 -- Copy the attribute
370 Var
:= Shared
.Variable_Elements
.Table
(V1
);
373 -- Do not copy the value of attribute Linker_Options if Restricted
375 if Restricted
and then Var
.Name
= Snames
.Name_Linker_Options
then
376 Var
.Value
.Values
:= Nil_String
;
379 -- Remove the Next component
381 Var
.Next
:= No_Variable
;
383 -- Change the location to New_Loc
385 Var
.Value
.Location
:= New_Loc
;
386 Variable_Element_Table
.Increment_Last
(Shared
.Variable_Elements
);
388 -- Put in new declaration
390 if To
.Attributes
= No_Variable
then
392 Variable_Element_Table
.Last
(Shared
.Variable_Elements
);
394 Shared
.Variable_Elements
.Table
(V2
).Next
:=
395 Variable_Element_Table
.Last
(Shared
.Variable_Elements
);
398 V2
:= Variable_Element_Table
.Last
(Shared
.Variable_Elements
);
399 Shared
.Variable_Elements
.Table
(V2
) := Var
;
402 -- Then the associated array attributes
405 while A1
/= No_Array
loop
406 Arr
:= Shared
.Arrays
.Table
(A1
);
409 -- Remove the Next component
411 Arr
.Next
:= No_Array
;
412 Array_Table
.Increment_Last
(Shared
.Arrays
);
414 -- Create new Array declaration
416 if To
.Arrays
= No_Array
then
417 To
.Arrays
:= Array_Table
.Last
(Shared
.Arrays
);
419 Shared
.Arrays
.Table
(A2
).Next
:=
420 Array_Table
.Last
(Shared
.Arrays
);
423 A2
:= Array_Table
.Last
(Shared
.Arrays
);
425 -- Don't store the array as its first element has not been set yet
427 -- Copy the array elements of the array
430 Arr
.Value
:= No_Array_Element
;
431 while E1
/= No_Array_Element
loop
433 -- Copy the array element
435 Elm
:= Shared
.Array_Elements
.Table
(E1
);
438 -- Remove the Next component
440 Elm
.Next
:= No_Array_Element
;
442 Elm
.Restricted
:= Restricted
;
444 -- Change the location
446 Elm
.Value
.Location
:= New_Loc
;
447 Array_Element_Table
.Increment_Last
(Shared
.Array_Elements
);
449 -- Create new array element
451 if Arr
.Value
= No_Array_Element
then
452 Arr
.Value
:= Array_Element_Table
.Last
(Shared
.Array_Elements
);
454 Shared
.Array_Elements
.Table
(E2
).Next
:=
455 Array_Element_Table
.Last
(Shared
.Array_Elements
);
458 E2
:= Array_Element_Table
.Last
(Shared
.Array_Elements
);
459 Shared
.Array_Elements
.Table
(E2
) := Elm
;
462 -- Finally, store the new array
464 Shared
.Arrays
.Table
(A2
) := Arr
;
466 end Copy_Package_Declarations
;
468 -------------------------
469 -- Get_Attribute_Index --
470 -------------------------
472 function Get_Attribute_Index
473 (Tree
: Project_Node_Tree_Ref
;
474 Attr
: Project_Node_Id
;
475 Index
: Name_Id
) return Name_Id
478 if Index
= All_Other_Names
479 or else not Case_Insensitive
(Attr
, Tree
)
484 Get_Name_String
(Index
);
485 To_Lower
(Name_Buffer
(1 .. Name_Len
));
487 end Get_Attribute_Index
;
494 (Project
: Project_Id
;
495 Shared
: Shared_Project_Tree_Data_Access
;
496 From_Project_Node
: Project_Node_Id
;
497 From_Project_Node_Tree
: Project_Node_Tree_Ref
;
498 Env
: Prj
.Tree
.Environment
;
500 First_Term
: Project_Node_Id
;
501 Kind
: Variable_Kind
) return Variable_Value
503 The_Term
: Project_Node_Id
;
504 -- The term in the expression list
506 The_Current_Term
: Project_Node_Id
:= Empty_Node
;
507 -- The current term node id
509 Result
: Variable_Value
(Kind
=> Kind
);
510 -- The returned result
512 Last
: String_List_Id
:= Nil_String
;
513 -- Reference to the last string elements in Result, when Kind is List
516 Result
.Project
:= Project
;
517 Result
.Location
:= Location_Of
(First_Term
, From_Project_Node_Tree
);
519 -- Process each term of the expression, starting with First_Term
521 The_Term
:= First_Term
;
522 while Present
(The_Term
) loop
523 The_Current_Term
:= Current_Term
(The_Term
, From_Project_Node_Tree
);
525 case Kind_Of
(The_Current_Term
, From_Project_Node_Tree
) is
527 when N_Literal_String
=>
533 -- Should never happen
535 pragma Assert
(False, "Undefined expression kind");
541 (The_Current_Term
, From_Project_Node_Tree
));
544 (The_Current_Term
, From_Project_Node_Tree
);
548 String_Element_Table
.Increment_Last
549 (Shared
.String_Elements
);
551 if Last
= Nil_String
then
553 -- This can happen in an expression like () & "toto"
555 Result
.Values
:= String_Element_Table
.Last
556 (Shared
.String_Elements
);
559 Shared
.String_Elements
.Table
560 (Last
).Next
:= String_Element_Table
.Last
561 (Shared
.String_Elements
);
564 Last
:= String_Element_Table
.Last
565 (Shared
.String_Elements
);
567 Shared
.String_Elements
.Table
(Last
) :=
568 (Value
=> String_Value_Of
570 From_Project_Node_Tree
),
571 Index
=> Source_Index_Of
573 From_Project_Node_Tree
),
574 Display_Value
=> No_Name
,
575 Location
=> Location_Of
577 From_Project_Node_Tree
),
582 when N_Literal_String_List
=>
585 String_Node
: Project_Node_Id
:=
586 First_Expression_In_List
588 From_Project_Node_Tree
);
590 Value
: Variable_Value
;
593 if Present
(String_Node
) then
595 -- If String_Node is nil, it is an empty list, there is
601 From_Project_Node
=> From_Project_Node
,
602 From_Project_Node_Tree
=> From_Project_Node_Tree
,
607 (String_Node
, From_Project_Node_Tree
),
609 String_Element_Table
.Increment_Last
610 (Shared
.String_Elements
);
612 if Result
.Values
= Nil_String
then
614 -- This literal string list is the first term in a
615 -- string list expression
618 String_Element_Table
.Last
619 (Shared
.String_Elements
);
622 Shared
.String_Elements
.Table
(Last
).Next
:=
623 String_Element_Table
.Last
(Shared
.String_Elements
);
627 String_Element_Table
.Last
(Shared
.String_Elements
);
629 Shared
.String_Elements
.Table
(Last
) :=
630 (Value
=> Value
.Value
,
631 Display_Value
=> No_Name
,
632 Location
=> Value
.Location
,
635 Index
=> Value
.Index
);
638 -- Add the other element of the literal string list
639 -- one after the other.
642 Next_Expression_In_List
643 (String_Node
, From_Project_Node_Tree
);
645 exit when No
(String_Node
);
651 From_Project_Node
=> From_Project_Node
,
652 From_Project_Node_Tree
=> From_Project_Node_Tree
,
657 (String_Node
, From_Project_Node_Tree
),
660 String_Element_Table
.Increment_Last
661 (Shared
.String_Elements
);
662 Shared
.String_Elements
.Table
(Last
).Next
:=
663 String_Element_Table
.Last
(Shared
.String_Elements
);
664 Last
:= String_Element_Table
.Last
665 (Shared
.String_Elements
);
666 Shared
.String_Elements
.Table
(Last
) :=
667 (Value
=> Value
.Value
,
668 Display_Value
=> No_Name
,
669 Location
=> Value
.Location
,
672 Index
=> Value
.Index
);
677 when N_Variable_Reference | N_Attribute_Reference
=>
680 The_Project
: Project_Id
:= Project
;
681 The_Package
: Package_Id
:= Pkg
;
682 The_Name
: Name_Id
:= No_Name
;
683 The_Variable_Id
: Variable_Id
:= No_Variable
;
684 The_Variable
: Variable_Value
;
685 Term_Project
: constant Project_Node_Id
:=
688 From_Project_Node_Tree
);
689 Term_Package
: constant Project_Node_Id
:=
692 From_Project_Node_Tree
);
693 Index
: Name_Id
:= No_Name
;
696 if Present
(Term_Project
)
697 and then Term_Project
/= From_Project_Node
699 -- This variable or attribute comes from another project
702 Name_Of
(Term_Project
, From_Project_Node_Tree
);
703 The_Project
:= Imported_Or_Extended_Project_From
705 With_Name
=> The_Name
);
708 if Present
(Term_Package
) then
710 -- This is an attribute of a package
713 Name_Of
(Term_Package
, From_Project_Node_Tree
);
715 The_Package
:= The_Project
.Decl
.Packages
;
716 while The_Package
/= No_Package
717 and then Shared
.Packages
.Table
(The_Package
).Name
/=
721 Shared
.Packages
.Table
(The_Package
).Next
;
725 (The_Package
/= No_Package
, "package not found.");
727 elsif Kind_Of
(The_Current_Term
, From_Project_Node_Tree
) =
728 N_Attribute_Reference
730 The_Package
:= No_Package
;
734 Name_Of
(The_Current_Term
, From_Project_Node_Tree
);
736 if Kind_Of
(The_Current_Term
, From_Project_Node_Tree
) =
737 N_Attribute_Reference
740 Associative_Array_Index_Of
741 (The_Current_Term
, From_Project_Node_Tree
);
744 -- If it is not an associative array attribute
746 if Index
= No_Name
then
748 -- It is not an associative array attribute
750 if The_Package
/= No_Package
then
752 -- First, if there is a package, look into the package
754 if Kind_Of
(The_Current_Term
, From_Project_Node_Tree
) =
758 Shared
.Packages
.Table
759 (The_Package
).Decl
.Variables
;
762 Shared
.Packages
.Table
763 (The_Package
).Decl
.Attributes
;
766 while The_Variable_Id
/= No_Variable
767 and then Shared
.Variable_Elements
.Table
768 (The_Variable_Id
).Name
/= The_Name
771 Shared
.Variable_Elements
.Table
772 (The_Variable_Id
).Next
;
777 if The_Variable_Id
= No_Variable
then
779 -- If we have not found it, look into the project
781 if Kind_Of
(The_Current_Term
, From_Project_Node_Tree
) =
784 The_Variable_Id
:= The_Project
.Decl
.Variables
;
786 The_Variable_Id
:= The_Project
.Decl
.Attributes
;
789 while The_Variable_Id
/= No_Variable
790 and then Shared
.Variable_Elements
.Table
791 (The_Variable_Id
).Name
/= The_Name
794 Shared
.Variable_Elements
.Table
795 (The_Variable_Id
).Next
;
800 pragma Assert
(The_Variable_Id
/= No_Variable
,
801 "variable or attribute not found");
804 Shared
.Variable_Elements
.Table
(The_Variable_Id
).Value
;
808 -- It is an associative array attribute
811 The_Array
: Array_Id
:= No_Array
;
812 The_Element
: Array_Element_Id
:= No_Array_Element
;
813 Array_Index
: Name_Id
:= No_Name
;
816 if The_Package
/= No_Package
then
818 Shared
.Packages
.Table
(The_Package
).Decl
.Arrays
;
820 The_Array
:= The_Project
.Decl
.Arrays
;
823 while The_Array
/= No_Array
824 and then Shared
.Arrays
.Table
(The_Array
).Name
/=
827 The_Array
:= Shared
.Arrays
.Table
(The_Array
).Next
;
830 if The_Array
/= No_Array
then
832 Shared
.Arrays
.Table
(The_Array
).Value
;
835 (From_Project_Node_Tree
,
839 while The_Element
/= No_Array_Element
840 and then Shared
.Array_Elements
.Table
841 (The_Element
).Index
/= Array_Index
844 Shared
.Array_Elements
.Table
(The_Element
).Next
;
849 if The_Element
/= No_Array_Element
then
851 Shared
.Array_Elements
.Table
(The_Element
).Value
;
854 if Expression_Kind_Of
855 (The_Current_Term
, From_Project_Node_Tree
) =
861 Location
=> No_Location
,
863 Values
=> Nil_String
);
868 Location
=> No_Location
,
870 Value
=> Empty_String
,
881 -- Should never happen
883 pragma Assert
(False, "undefined expression kind");
888 case The_Variable
.Kind
is
894 Add
(Result
.Value
, The_Variable
.Value
);
898 -- Should never happen
902 "list cannot appear in single " &
903 "string expression");
908 case The_Variable
.Kind
is
914 String_Element_Table
.Increment_Last
915 (Shared
.String_Elements
);
917 if Last
= Nil_String
then
919 -- This can happen in an expression such as
923 String_Element_Table
.Last
924 (Shared
.String_Elements
);
927 Shared
.String_Elements
.Table
(Last
).Next
:=
928 String_Element_Table
.Last
929 (Shared
.String_Elements
);
933 String_Element_Table
.Last
934 (Shared
.String_Elements
);
936 Shared
.String_Elements
.Table
(Last
) :=
937 (Value
=> The_Variable
.Value
,
938 Display_Value
=> No_Name
,
939 Location
=> Location_Of
941 From_Project_Node_Tree
),
949 The_List
: String_List_Id
:=
953 while The_List
/= Nil_String
loop
954 String_Element_Table
.Increment_Last
955 (Shared
.String_Elements
);
957 if Last
= Nil_String
then
959 String_Element_Table
.Last
960 (Shared
.String_Elements
);
964 String_Elements
.Table
(Last
).Next
:=
965 String_Element_Table
.Last
966 (Shared
.String_Elements
);
971 String_Element_Table
.Last
972 (Shared
.String_Elements
);
974 Shared
.String_Elements
.Table
977 Shared
.String_Elements
.Table
979 Display_Value
=> No_Name
,
983 From_Project_Node_Tree
),
988 The_List
:= Shared
.String_Elements
.Table
996 when N_External_Value
=>
999 (External_Reference_Of
1000 (The_Current_Term
, From_Project_Node_Tree
),
1001 From_Project_Node_Tree
));
1004 Name
: constant Name_Id
:= Name_Find
;
1005 Default
: Name_Id
:= No_Name
;
1006 Value
: Name_Id
:= No_Name
;
1007 Ext_List
: Boolean := False;
1008 Str_List
: String_List_Access
:= null;
1009 Def_Var
: Variable_Value
;
1011 Default_Node
: constant Project_Node_Id
:=
1014 From_Project_Node_Tree
);
1017 -- If there is a default value for the external reference,
1020 if Present
(Default_Node
) then
1021 Def_Var
:= Expression
1022 (Project
=> Project
,
1024 From_Project_Node
=> From_Project_Node
,
1025 From_Project_Node_Tree
=> From_Project_Node_Tree
,
1030 (Default_Node
, From_Project_Node_Tree
),
1033 if Def_Var
/= Nil_Variable_Value
then
1034 Default
:= Def_Var
.Value
;
1038 Ext_List
:= Expression_Kind_Of
1040 From_Project_Node_Tree
) = List
;
1043 Value
:= Prj
.Ext
.Value_Of
(Env
.External
, Name
, No_Name
);
1045 if Value
/= No_Name
then
1047 Sep
: constant String :=
1048 Get_Name_String
(Default
);
1049 First
: Positive := 1;
1051 Done
: Boolean := False;
1055 Get_Name_String
(Value
);
1058 or else Sep
'Length = 0
1059 or else Name_Buffer
(1 .. Name_Len
) = Sep
1064 if not Done
and then Name_Len
< Sep
'Length then
1068 (Name_Buffer
(1 .. Name_Len
)));
1073 if Name_Buffer
(1 .. Sep
'Length) = Sep
then
1074 First
:= Sep
'Length + 1;
1077 if Name_Len
- First
+ 1 >= Sep
'Length
1079 Name_Buffer
(Name_Len
- Sep
'Length + 1 ..
1082 Name_Len
:= Name_Len
- Sep
'Length;
1085 if Name_Len
= 0 then
1087 new String_List
'(1 => new String'(""));
1094 -- Count the number of strings
1097 Saved
: constant Positive := First
;
1105 Name_Buffer
(First
.. Name_Len
),
1109 First
:= Lst
+ Sep
'Length;
1115 Str_List
:= new String_List
(1 .. Nmb
);
1117 -- Populate the string list
1124 Name_Buffer
(First
.. Name_Len
),
1130 (Name_Buffer (First .. Name_Len));
1136 (Name_Buffer
(First
.. Lst
- 1));
1138 First
:= Lst
+ Sep
'Length;
1148 Value
:= Prj
.Ext
.Value_Of
(Env
.External
, Name
, Default
);
1150 if Value
= No_Name
then
1151 if not Quiet_Output
then
1153 (Env
.Flags
, "?undefined external reference",
1155 (The_Current_Term
, From_Project_Node_Tree
),
1159 Value
:= Empty_String
;
1173 Add
(Result
.Value
, Value
);
1177 if not Ext_List
or else Str_List
/= null then
1178 String_Element_Table
.Increment_Last
1179 (Shared
.String_Elements
);
1181 if Last
= Nil_String
then
1183 String_Element_Table
.Last
1184 (Shared
.String_Elements
);
1187 Shared
.String_Elements
.Table
(Last
).Next
1188 := String_Element_Table
.Last
1189 (Shared
.String_Elements
);
1192 Last
:= String_Element_Table
.Last
1193 (Shared
.String_Elements
);
1196 for Ind
in Str_List
'Range loop
1198 Add_Str_To_Name_Buffer
(Str_List
(Ind
).all);
1200 Shared
.String_Elements
.Table
(Last
) :=
1202 Display_Value
=> No_Name
,
1206 From_Project_Node_Tree
),
1211 if Ind
/= Str_List
'Last then
1212 String_Element_Table
.Increment_Last
1213 (Shared
.String_Elements
);
1214 Shared
.String_Elements
.Table
(Last
).Next
:=
1215 String_Element_Table
.Last
1216 (Shared
.String_Elements
);
1217 Last
:= String_Element_Table
.Last
1218 (Shared
.String_Elements
);
1223 Shared
.String_Elements
.Table
(Last
) :=
1225 Display_Value
=> No_Name
,
1229 From_Project_Node_Tree
),
1240 -- Should never happen
1244 "illegal node kind in an expression");
1245 raise Program_Error
;
1249 The_Term
:= Next_Term
(The_Term
, From_Project_Node_Tree
);
1255 ---------------------------------------
1256 -- Imported_Or_Extended_Project_From --
1257 ---------------------------------------
1259 function Imported_Or_Extended_Project_From
1260 (Project
: Project_Id
;
1261 With_Name
: Name_Id
) return Project_Id
1263 List
: Project_List
;
1264 Result
: Project_Id
;
1265 Temp_Result
: Project_Id
;
1268 -- First check if it is the name of an extended project
1270 Result
:= Project
.Extends
;
1271 while Result
/= No_Project
loop
1272 if Result
.Name
= With_Name
then
1275 Result
:= Result
.Extends
;
1279 -- Then check the name of each imported project
1281 Temp_Result
:= No_Project
;
1282 List
:= Project
.Imported_Projects
;
1283 while List
/= null loop
1284 Result
:= List
.Project
;
1286 -- If the project is directly imported, then returns its ID
1288 if Result
.Name
= With_Name
then
1292 -- If a project extending the project is imported, then keep this
1293 -- extending project as a possibility. It will be the returned ID
1294 -- if the project is not imported directly.
1300 Proj
:= Result
.Extends
;
1301 while Proj
/= No_Project
loop
1302 if Proj
.Name
= With_Name
then
1303 Temp_Result
:= Result
;
1307 Proj
:= Proj
.Extends
;
1314 pragma Assert
(Temp_Result
/= No_Project
, "project not found");
1316 end Imported_Or_Extended_Project_From
;
1322 function Package_From
1323 (Project
: Project_Id
;
1324 Shared
: Shared_Project_Tree_Data_Access
;
1325 With_Name
: Name_Id
) return Package_Id
1327 Result
: Package_Id
:= Project
.Decl
.Packages
;
1330 -- Check the name of each existing package of Project
1332 while Result
/= No_Package
1333 and then Shared
.Packages
.Table
(Result
).Name
/= With_Name
1335 Result
:= Shared
.Packages
.Table
(Result
).Next
;
1338 if Result
= No_Package
then
1340 -- Should never happen
1343 ("package """ & Get_Name_String
(With_Name
) & """ not found");
1344 raise Program_Error
;
1356 (In_Tree
: Project_Tree_Ref
;
1357 Project
: out Project_Id
;
1358 Packages_To_Check
: String_List_Access
;
1359 Success
: out Boolean;
1360 From_Project_Node
: Project_Node_Id
;
1361 From_Project_Node_Tree
: Project_Node_Tree_Ref
;
1362 Env
: in out Prj
.Tree
.Environment
;
1363 Reset_Tree
: Boolean := True)
1366 Process_Project_Tree_Phase_1
1367 (In_Tree
=> In_Tree
,
1370 From_Project_Node
=> From_Project_Node
,
1371 From_Project_Node_Tree
=> From_Project_Node_Tree
,
1373 Packages_To_Check
=> Packages_To_Check
,
1374 Reset_Tree
=> Reset_Tree
);
1376 if Project_Qualifier_Of
1377 (From_Project_Node
, From_Project_Node_Tree
) /= Configuration
1379 Process_Project_Tree_Phase_2
1380 (In_Tree
=> In_Tree
,
1383 From_Project_Node
=> From_Project_Node
,
1384 From_Project_Node_Tree
=> From_Project_Node_Tree
,
1389 -------------------------------
1390 -- Process_Declarative_Items --
1391 -------------------------------
1393 procedure Process_Declarative_Items
1394 (Project
: Project_Id
;
1395 In_Tree
: Project_Tree_Ref
;
1396 From_Project_Node
: Project_Node_Id
;
1397 Node_Tree
: Project_Node_Tree_Ref
;
1398 Env
: Prj
.Tree
.Environment
;
1400 Item
: Project_Node_Id
;
1401 Child_Env
: in out Prj
.Tree
.Environment
)
1403 Shared
: constant Shared_Project_Tree_Data_Access
:= In_Tree
.Shared
;
1405 procedure Check_Or_Set_Typed_Variable
1406 (Value
: in out Variable_Value
;
1407 Declaration
: Project_Node_Id
);
1408 -- Check whether Value is valid for this typed variable declaration. If
1409 -- it is an error, the behavior depends on the flags: either an error is
1410 -- reported, or a warning, or nothing. In the last two cases, the value
1411 -- of the variable is set to a valid value, replacing Value.
1413 procedure Process_Package_Declaration
1414 (Current_Item
: Project_Node_Id
);
1415 procedure Process_Attribute_Declaration
1416 (Current
: Project_Node_Id
);
1417 procedure Process_Case_Construction
1418 (Current_Item
: Project_Node_Id
);
1419 procedure Process_Associative_Array
1420 (Current_Item
: Project_Node_Id
);
1421 procedure Process_Expression
1422 (Current
: Project_Node_Id
);
1423 procedure Process_Expression_For_Associative_Array
1424 (Current
: Project_Node_Id
;
1425 New_Value
: Variable_Value
);
1426 procedure Process_Expression_Variable_Decl
1427 (Current_Item
: Project_Node_Id
;
1428 New_Value
: Variable_Value
);
1429 -- Process the various declarative items
1431 ---------------------------------
1432 -- Check_Or_Set_Typed_Variable --
1433 ---------------------------------
1435 procedure Check_Or_Set_Typed_Variable
1436 (Value
: in out Variable_Value
;
1437 Declaration
: Project_Node_Id
)
1439 Loc
: constant Source_Ptr
:= Location_Of
(Declaration
, Node_Tree
);
1441 Reset_Value
: Boolean := False;
1442 Current_String
: Project_Node_Id
;
1445 -- Report an error for an empty string
1447 if Value
.Value
= Empty_String
then
1448 Error_Msg_Name_1
:= Name_Of
(Declaration
, Node_Tree
);
1450 case Env
.Flags
.Allow_Invalid_External
is
1453 (Env
.Flags
, "no value defined for %%", Loc
, Project
);
1455 Reset_Value
:= True;
1457 (Env
.Flags
, "?no value defined for %%", Loc
, Project
);
1459 Reset_Value
:= True;
1463 -- Loop through all the valid strings for the
1464 -- string type and compare to the string value.
1467 First_Literal_String
1468 (String_Type_Of
(Declaration
, Node_Tree
), Node_Tree
);
1470 while Present
(Current_String
)
1472 String_Value_Of
(Current_String
, Node_Tree
) /= Value
.Value
1475 Next_Literal_String
(Current_String
, Node_Tree
);
1478 -- Report error if string value is not one for the string type
1480 if No
(Current_String
) then
1481 Error_Msg_Name_1
:= Value
.Value
;
1482 Error_Msg_Name_2
:= Name_Of
(Declaration
, Node_Tree
);
1484 case Env
.Flags
.Allow_Invalid_External
is
1487 (Env
.Flags
, "value %% is illegal for typed string %%",
1492 (Env
.Flags
, "?value %% is illegal for typed string %%",
1494 Reset_Value
:= True;
1497 Reset_Value
:= True;
1504 First_Literal_String
1505 (String_Type_Of
(Declaration
, Node_Tree
), Node_Tree
);
1506 Value
.Value
:= String_Value_Of
(Current_String
, Node_Tree
);
1508 end Check_Or_Set_Typed_Variable
;
1510 ---------------------------------
1511 -- Process_Package_Declaration --
1512 ---------------------------------
1514 procedure Process_Package_Declaration
1515 (Current_Item
: Project_Node_Id
)
1518 -- Do not process a package declaration that should be ignored
1520 if Expression_Kind_Of
(Current_Item
, Node_Tree
) /= Ignored
then
1522 -- Create the new package
1524 Package_Table
.Increment_Last
(Shared
.Packages
);
1527 New_Pkg
: constant Package_Id
:=
1528 Package_Table
.Last
(Shared
.Packages
);
1529 The_New_Package
: Package_Element
;
1531 Project_Of_Renamed_Package
: constant Project_Node_Id
:=
1532 Project_Of_Renamed_Package_Of
1533 (Current_Item
, Node_Tree
);
1536 -- Set the name of the new package
1538 The_New_Package
.Name
:= Name_Of
(Current_Item
, Node_Tree
);
1540 -- Insert the new package in the appropriate list
1542 if Pkg
/= No_Package
then
1543 The_New_Package
.Next
:=
1544 Shared
.Packages
.Table
(Pkg
).Decl
.Packages
;
1545 Shared
.Packages
.Table
(Pkg
).Decl
.Packages
:= New_Pkg
;
1548 The_New_Package
.Next
:= Project
.Decl
.Packages
;
1549 Project
.Decl
.Packages
:= New_Pkg
;
1552 Shared
.Packages
.Table
(New_Pkg
) := The_New_Package
;
1554 if Present
(Project_Of_Renamed_Package
) then
1556 -- Renamed or extending package
1559 Project_Name
: constant Name_Id
:=
1560 Name_Of
(Project_Of_Renamed_Package
,
1563 Renamed_Project
: constant Project_Id
:=
1564 Imported_Or_Extended_Project_From
1565 (Project
, Project_Name
);
1567 Renamed_Package
: constant Package_Id
:=
1569 (Renamed_Project
, Shared
,
1570 Name_Of
(Current_Item
, Node_Tree
));
1573 -- For a renamed package, copy the declarations of the
1574 -- renamed package, but set all the locations to the
1575 -- location of the package name in the renaming
1578 Copy_Package_Declarations
1579 (From
=> Shared
.Packages
.Table
1580 (Renamed_Package
).Decl
,
1581 To
=> Shared
.Packages
.Table
(New_Pkg
).Decl
,
1582 New_Loc
=> Location_Of
(Current_Item
, Node_Tree
),
1583 Restricted
=> False,
1588 -- Set the default values of the attributes
1593 Name_Id
(Project
.Directory
.Display_Name
),
1595 Shared
.Packages
.Table
(New_Pkg
).Decl
,
1597 (Package_Id_Of
(Current_Item
, Node_Tree
)),
1598 Project_Level
=> False);
1601 -- Process declarative items (nothing to do when the package is
1602 -- renaming, as the first declarative item is null).
1604 Process_Declarative_Items
1605 (Project
=> Project
,
1607 From_Project_Node
=> From_Project_Node
,
1608 Node_Tree
=> Node_Tree
,
1612 First_Declarative_Item_Of
(Current_Item
, Node_Tree
),
1613 Child_Env
=> Child_Env
);
1616 end Process_Package_Declaration
;
1618 -------------------------------
1619 -- Process_Associative_Array --
1620 -------------------------------
1622 procedure Process_Associative_Array
1623 (Current_Item
: Project_Node_Id
)
1625 Current_Item_Name
: constant Name_Id
:=
1626 Name_Of
(Current_Item
, Node_Tree
);
1627 -- The name of the attribute
1629 Current_Location
: constant Source_Ptr
:=
1630 Location_Of
(Current_Item
, Node_Tree
);
1632 New_Array
: Array_Id
;
1633 -- The new associative array created
1635 Orig_Array
: Array_Id
;
1636 -- The associative array value
1638 Orig_Project_Name
: Name_Id
:= No_Name
;
1639 -- The name of the project where the associative array
1642 Orig_Project
: Project_Id
:= No_Project
;
1643 -- The id of the project where the associative array
1646 Orig_Package_Name
: Name_Id
:= No_Name
;
1647 -- The name of the package, if any, where the associative array value
1650 Orig_Package
: Package_Id
:= No_Package
;
1651 -- The id of the package, if any, where the associative array value
1654 New_Element
: Array_Element_Id
:= No_Array_Element
;
1655 -- Id of a new array element created
1657 Prev_Element
: Array_Element_Id
:= No_Array_Element
;
1658 -- Last new element id created
1660 Orig_Element
: Array_Element_Id
:= No_Array_Element
;
1661 -- Current array element in original associative array
1663 Next_Element
: Array_Element_Id
:= No_Array_Element
;
1664 -- Id of the array element that follows the new element. This is not
1665 -- always nil, because values for the associative array attribute may
1666 -- already have been declared, and the array elements declared are
1672 -- First find if the associative array attribute already has elements
1675 if Pkg
/= No_Package
then
1676 New_Array
:= Shared
.Packages
.Table
(Pkg
).Decl
.Arrays
;
1678 New_Array
:= Project
.Decl
.Arrays
;
1681 while New_Array
/= No_Array
1682 and then Shared
.Arrays
.Table
(New_Array
).Name
/= Current_Item_Name
1684 New_Array
:= Shared
.Arrays
.Table
(New_Array
).Next
;
1687 -- If the attribute has never been declared add new entry in the
1688 -- arrays of the project/package and link it.
1690 if New_Array
= No_Array
then
1691 Array_Table
.Increment_Last
(Shared
.Arrays
);
1692 New_Array
:= Array_Table
.Last
(Shared
.Arrays
);
1694 if Pkg
/= No_Package
then
1695 Shared
.Arrays
.Table
(New_Array
) :=
1696 (Name
=> Current_Item_Name
,
1697 Location
=> Current_Location
,
1698 Value
=> No_Array_Element
,
1699 Next
=> Shared
.Packages
.Table
(Pkg
).Decl
.Arrays
);
1701 Shared
.Packages
.Table
(Pkg
).Decl
.Arrays
:= New_Array
;
1704 Shared
.Arrays
.Table
(New_Array
) :=
1705 (Name
=> Current_Item_Name
,
1706 Location
=> Current_Location
,
1707 Value
=> No_Array_Element
,
1708 Next
=> Project
.Decl
.Arrays
);
1710 Project
.Decl
.Arrays
:= New_Array
;
1714 -- Find the project where the value is declared
1716 Orig_Project_Name
:=
1718 (Associative_Project_Of
(Current_Item
, Node_Tree
), Node_Tree
);
1720 Prj
:= In_Tree
.Projects
;
1721 while Prj
/= null loop
1722 if Prj
.Project
.Name
= Orig_Project_Name
then
1723 Orig_Project
:= Prj
.Project
;
1729 pragma Assert
(Orig_Project
/= No_Project
,
1730 "original project not found");
1732 if No
(Associative_Package_Of
(Current_Item
, Node_Tree
)) then
1733 Orig_Array
:= Orig_Project
.Decl
.Arrays
;
1736 -- If in a package, find the package where the value is declared
1738 Orig_Package_Name
:=
1740 (Associative_Package_Of
(Current_Item
, Node_Tree
), Node_Tree
);
1742 Orig_Package
:= Orig_Project
.Decl
.Packages
;
1743 pragma Assert
(Orig_Package
/= No_Package
,
1744 "original package not found");
1746 while Shared
.Packages
.Table
1747 (Orig_Package
).Name
/= Orig_Package_Name
1749 Orig_Package
:= Shared
.Packages
.Table
(Orig_Package
).Next
;
1750 pragma Assert
(Orig_Package
/= No_Package
,
1751 "original package not found");
1754 Orig_Array
:= Shared
.Packages
.Table
(Orig_Package
).Decl
.Arrays
;
1757 -- Now look for the array
1759 while Orig_Array
/= No_Array
1760 and then Shared
.Arrays
.Table
(Orig_Array
).Name
/= Current_Item_Name
1762 Orig_Array
:= Shared
.Arrays
.Table
(Orig_Array
).Next
;
1765 if Orig_Array
= No_Array
then
1768 "associative array value not found",
1769 Location_Of
(Current_Item
, Node_Tree
),
1773 Orig_Element
:= Shared
.Arrays
.Table
(Orig_Array
).Value
;
1775 -- Copy each array element
1777 while Orig_Element
/= No_Array_Element
loop
1779 -- Case of first element
1781 if Prev_Element
= No_Array_Element
then
1783 -- And there is no array element declared yet, create a new
1784 -- first array element.
1786 if Shared
.Arrays
.Table
(New_Array
).Value
=
1789 Array_Element_Table
.Increment_Last
1790 (Shared
.Array_Elements
);
1791 New_Element
:= Array_Element_Table
.Last
1792 (Shared
.Array_Elements
);
1793 Shared
.Arrays
.Table
(New_Array
).Value
:= New_Element
;
1794 Next_Element
:= No_Array_Element
;
1796 -- Otherwise, the new element is the first
1799 New_Element
:= Shared
.Arrays
.Table
(New_Array
).Value
;
1801 Shared
.Array_Elements
.Table
(New_Element
).Next
;
1804 -- Otherwise, reuse an existing element, or create
1805 -- one if necessary.
1809 Shared
.Array_Elements
.Table
(Prev_Element
).Next
;
1811 if Next_Element
= No_Array_Element
then
1812 Array_Element_Table
.Increment_Last
1813 (Shared
.Array_Elements
);
1814 New_Element
:= Array_Element_Table
.Last
1815 (Shared
.Array_Elements
);
1816 Shared
.Array_Elements
.Table
(Prev_Element
).Next
:=
1820 New_Element
:= Next_Element
;
1822 Shared
.Array_Elements
.Table
(New_Element
).Next
;
1826 -- Copy the value of the element
1828 Shared
.Array_Elements
.Table
(New_Element
) :=
1829 Shared
.Array_Elements
.Table
(Orig_Element
);
1830 Shared
.Array_Elements
.Table
(New_Element
).Value
.Project
1833 -- Adjust the Next link
1835 Shared
.Array_Elements
.Table
(New_Element
).Next
:= Next_Element
;
1837 -- Adjust the previous id for the next element
1839 Prev_Element
:= New_Element
;
1841 -- Go to the next element in the original array
1843 Orig_Element
:= Shared
.Array_Elements
.Table
(Orig_Element
).Next
;
1846 -- Make sure that the array ends here, in case there previously a
1847 -- greater number of elements.
1849 Shared
.Array_Elements
.Table
(New_Element
).Next
:= No_Array_Element
;
1851 end Process_Associative_Array
;
1853 ----------------------------------------------
1854 -- Process_Expression_For_Associative_Array --
1855 ----------------------------------------------
1857 procedure Process_Expression_For_Associative_Array
1858 (Current
: Project_Node_Id
;
1859 New_Value
: Variable_Value
)
1861 Name
: constant Name_Id
:= Name_Of
(Current
, Node_Tree
);
1862 Current_Location
: constant Source_Ptr
:=
1863 Location_Of
(Current
, Node_Tree
);
1865 Index_Name
: Name_Id
:=
1866 Associative_Array_Index_Of
(Current
, Node_Tree
);
1868 Source_Index
: constant Int
:=
1869 Source_Index_Of
(Current
, Node_Tree
);
1871 The_Array
: Array_Id
;
1872 Elem
: Array_Element_Id
:= No_Array_Element
;
1875 if Index_Name
/= All_Other_Names
then
1876 Index_Name
:= Get_Attribute_Index
(Node_Tree
, Current
, Index_Name
);
1879 -- Look for the array in the appropriate list
1881 if Pkg
/= No_Package
then
1882 The_Array
:= Shared
.Packages
.Table
(Pkg
).Decl
.Arrays
;
1884 The_Array
:= Project
.Decl
.Arrays
;
1887 while The_Array
/= No_Array
1888 and then Shared
.Arrays
.Table
(The_Array
).Name
/= Name
1890 The_Array
:= Shared
.Arrays
.Table
(The_Array
).Next
;
1893 -- If the array cannot be found, create a new entry in the list.
1894 -- As The_Array_Element is initialized to No_Array_Element, a new
1895 -- element will be created automatically later
1897 if The_Array
= No_Array
then
1898 Array_Table
.Increment_Last
(Shared
.Arrays
);
1899 The_Array
:= Array_Table
.Last
(Shared
.Arrays
);
1901 if Pkg
/= No_Package
then
1902 Shared
.Arrays
.Table
(The_Array
) :=
1904 Location
=> Current_Location
,
1905 Value
=> No_Array_Element
,
1906 Next
=> Shared
.Packages
.Table
(Pkg
).Decl
.Arrays
);
1908 Shared
.Packages
.Table
(Pkg
).Decl
.Arrays
:= The_Array
;
1911 Shared
.Arrays
.Table
(The_Array
) :=
1913 Location
=> Current_Location
,
1914 Value
=> No_Array_Element
,
1915 Next
=> Project
.Decl
.Arrays
);
1917 Project
.Decl
.Arrays
:= The_Array
;
1921 Elem
:= Shared
.Arrays
.Table
(The_Array
).Value
;
1924 -- Look in the list, if any, to find an element with the same index
1925 -- and same source index.
1927 while Elem
/= No_Array_Element
1929 (Shared
.Array_Elements
.Table
(Elem
).Index
/= Index_Name
1931 Shared
.Array_Elements
.Table
(Elem
).Src_Index
/= Source_Index
)
1933 Elem
:= Shared
.Array_Elements
.Table
(Elem
).Next
;
1936 -- If no such element were found, create a new one
1937 -- and insert it in the element list, with the
1940 if Elem
= No_Array_Element
then
1941 Array_Element_Table
.Increment_Last
(Shared
.Array_Elements
);
1942 Elem
:= Array_Element_Table
.Last
(Shared
.Array_Elements
);
1944 Shared
.Array_Elements
.Table
1946 (Index
=> Index_Name
,
1947 Restricted
=> False,
1948 Src_Index
=> Source_Index
,
1949 Index_Case_Sensitive
=>
1950 not Case_Insensitive
(Current
, Node_Tree
),
1952 Next
=> Shared
.Arrays
.Table
(The_Array
).Value
);
1954 Shared
.Arrays
.Table
(The_Array
).Value
:= Elem
;
1957 -- An element with the same index already exists, just replace its
1958 -- value with the new one.
1960 Shared
.Array_Elements
.Table
(Elem
).Value
:= New_Value
;
1963 if Name
= Snames
.Name_External
then
1964 if In_Tree
.Is_Root_Tree
then
1965 Add
(Child_Env
.External
,
1966 External_Name
=> Get_Name_String
(Index_Name
),
1967 Value
=> Get_Name_String
(New_Value
.Value
),
1968 Source
=> From_External_Attribute
);
1970 External_Name
=> Get_Name_String
(Index_Name
),
1971 Value
=> Get_Name_String
(New_Value
.Value
),
1972 Source
=> From_External_Attribute
);
1974 if Current_Verbosity
= High
then
1976 ("'for External' has no effect except in root aggregate ("
1977 & Get_Name_String
(Index_Name
) & ")", New_Value
.Value
);
1981 end Process_Expression_For_Associative_Array
;
1983 --------------------------------------
1984 -- Process_Expression_Variable_Decl --
1985 --------------------------------------
1987 procedure Process_Expression_Variable_Decl
1988 (Current_Item
: Project_Node_Id
;
1989 New_Value
: Variable_Value
)
1991 Name
: constant Name_Id
:= Name_Of
(Current_Item
, Node_Tree
);
1993 Is_Attribute
: constant Boolean :=
1994 Kind_Of
(Current_Item
, Node_Tree
) =
1995 N_Attribute_Declaration
;
1997 Var
: Variable_Id
:= No_Variable
;
2000 -- First, find the list where to find the variable or attribute
2002 if Is_Attribute
then
2003 if Pkg
/= No_Package
then
2004 Var
:= Shared
.Packages
.Table
(Pkg
).Decl
.Attributes
;
2006 Var
:= Project
.Decl
.Attributes
;
2010 if Pkg
/= No_Package
then
2011 Var
:= Shared
.Packages
.Table
(Pkg
).Decl
.Variables
;
2013 Var
:= Project
.Decl
.Variables
;
2017 -- Loop through the list, to find if it has already been declared
2019 while Var
/= No_Variable
2020 and then Shared
.Variable_Elements
.Table
(Var
).Name
/= Name
2022 Var
:= Shared
.Variable_Elements
.Table
(Var
).Next
;
2025 -- If it has not been declared, create a new entry in the list
2027 if Var
= No_Variable
then
2029 -- All single string attribute should already have been declared
2030 -- with a default empty string value.
2034 "illegal attribute declaration for " & Get_Name_String
(Name
));
2036 Variable_Element_Table
.Increment_Last
(Shared
.Variable_Elements
);
2037 Var
:= Variable_Element_Table
.Last
(Shared
.Variable_Elements
);
2039 -- Put the new variable in the appropriate list
2041 if Pkg
/= No_Package
then
2042 Shared
.Variable_Elements
.Table
(Var
) :=
2043 (Next
=> Shared
.Packages
.Table
(Pkg
).Decl
.Variables
,
2045 Value
=> New_Value
);
2046 Shared
.Packages
.Table
(Pkg
).Decl
.Variables
:= Var
;
2049 Shared
.Variable_Elements
.Table
(Var
) :=
2050 (Next
=> Project
.Decl
.Variables
,
2052 Value
=> New_Value
);
2053 Project
.Decl
.Variables
:= Var
;
2056 -- If the variable/attribute has already been declared, just
2057 -- change the value.
2060 Shared
.Variable_Elements
.Table
(Var
).Value
:= New_Value
;
2063 if Is_Attribute
and then Name
= Snames
.Name_Project_Path
then
2064 if In_Tree
.Is_Root_Tree
then
2067 new Ada
.Containers
.Vectors
(Positive, Name_Id
);
2068 Val
: String_List_Id
:= New_Value
.Values
;
2069 List
: Name_Ids
.Vector
;
2073 while Val
/= Nil_String
loop
2075 (Shared
.String_Elements
.Table
(Val
).Value
);
2076 Val
:= Shared
.String_Elements
.Table
(Val
).Next
;
2079 -- Prepend them in the order found in the attribute
2081 for K
in Positive range 1 .. Positive (List
.Length
) loop
2082 Prj
.Env
.Add_Directories
2083 (Child_Env
.Project_Path
,
2085 (Name
=> Get_Name_String
2087 Directory
=> Get_Name_String
2088 (Project
.Directory
.Display_Name
)),
2094 if Current_Verbosity
= High
then
2096 ("'for Project_Path' has no effect except in"
2097 & " root aggregate");
2101 end Process_Expression_Variable_Decl
;
2103 ------------------------
2104 -- Process_Expression --
2105 ------------------------
2107 procedure Process_Expression
(Current
: Project_Node_Id
) is
2108 New_Value
: Variable_Value
:=
2110 (Project
=> Project
,
2112 From_Project_Node
=> From_Project_Node
,
2113 From_Project_Node_Tree
=> Node_Tree
,
2118 (Expression_Of
(Current
, Node_Tree
), Node_Tree
),
2120 Expression_Kind_Of
(Current
, Node_Tree
));
2123 -- Process a typed variable declaration
2125 if Kind_Of
(Current
, Node_Tree
) = N_Typed_Variable_Declaration
then
2126 Check_Or_Set_Typed_Variable
(New_Value
, Current
);
2129 if Kind_Of
(Current
, Node_Tree
) /= N_Attribute_Declaration
2130 or else Associative_Array_Index_Of
(Current
, Node_Tree
) = No_Name
2132 Process_Expression_Variable_Decl
(Current
, New_Value
);
2134 Process_Expression_For_Associative_Array
(Current
, New_Value
);
2136 end Process_Expression
;
2138 -----------------------------------
2139 -- Process_Attribute_Declaration --
2140 -----------------------------------
2142 procedure Process_Attribute_Declaration
(Current
: Project_Node_Id
) is
2144 if Expression_Of
(Current
, Node_Tree
) = Empty_Node
then
2145 Process_Associative_Array
(Current
);
2147 Process_Expression
(Current
);
2149 end Process_Attribute_Declaration
;
2151 -------------------------------
2152 -- Process_Case_Construction --
2153 -------------------------------
2155 procedure Process_Case_Construction
2156 (Current_Item
: Project_Node_Id
)
2158 The_Project
: Project_Id
:= Project
;
2159 -- The id of the project of the case variable
2161 The_Package
: Package_Id
:= Pkg
;
2162 -- The id of the package, if any, of the case variable
2164 The_Variable
: Variable_Value
:= Nil_Variable_Value
;
2165 -- The case variable
2167 Case_Value
: Name_Id
:= No_Name
;
2168 -- The case variable value
2170 Case_Item
: Project_Node_Id
:= Empty_Node
;
2171 Choice_String
: Project_Node_Id
:= Empty_Node
;
2172 Decl_Item
: Project_Node_Id
:= Empty_Node
;
2176 Variable_Node
: constant Project_Node_Id
:=
2177 Case_Variable_Reference_Of
2181 Var_Id
: Variable_Id
:= No_Variable
;
2182 Name
: Name_Id
:= No_Name
;
2185 -- If a project was specified for the case variable, get its id
2187 if Present
(Project_Node_Of
(Variable_Node
, Node_Tree
)) then
2190 (Project_Node_Of
(Variable_Node
, Node_Tree
), Node_Tree
);
2192 Imported_Or_Extended_Project_From
(Project
, Name
);
2195 -- If a package was specified for the case variable, get its id
2197 if Present
(Package_Node_Of
(Variable_Node
, Node_Tree
)) then
2200 (Package_Node_Of
(Variable_Node
, Node_Tree
), Node_Tree
);
2201 The_Package
:= Package_From
(The_Project
, Shared
, Name
);
2204 Name
:= Name_Of
(Variable_Node
, Node_Tree
);
2206 -- First, look for the case variable into the package, if any
2208 if The_Package
/= No_Package
then
2209 Name
:= Name_Of
(Variable_Node
, Node_Tree
);
2211 Var_Id
:= Shared
.Packages
.Table
(The_Package
).Decl
.Variables
;
2212 while Var_Id
/= No_Variable
2213 and then Shared
.Variable_Elements
.Table
(Var_Id
).Name
/= Name
2215 Var_Id
:= Shared
.Variable_Elements
.Table
(Var_Id
).Next
;
2219 -- If not found in the package, or if there is no package, look at
2220 -- the project level.
2222 if Var_Id
= No_Variable
2223 and then No
(Package_Node_Of
(Variable_Node
, Node_Tree
))
2225 Var_Id
:= The_Project
.Decl
.Variables
;
2226 while Var_Id
/= No_Variable
2227 and then Shared
.Variable_Elements
.Table
(Var_Id
).Name
/= Name
2229 Var_Id
:= Shared
.Variable_Elements
.Table
(Var_Id
).Next
;
2233 if Var_Id
= No_Variable
then
2235 -- Should never happen, because this has already been checked
2239 ("variable """ & Get_Name_String
(Name
) & """ not found");
2240 raise Program_Error
;
2243 -- Get the case variable
2245 The_Variable
:= Shared
.Variable_Elements
. Table
(Var_Id
).Value
;
2247 if The_Variable
.Kind
/= Single
then
2249 -- Should never happen, because this has already been checked
2252 Write_Line
("variable""" & Get_Name_String
(Name
) &
2253 """ is not a single string variable");
2254 raise Program_Error
;
2257 -- Get the case variable value
2259 Case_Value
:= The_Variable
.Value
;
2262 -- Now look into all the case items of the case construction
2264 Case_Item
:= First_Case_Item_Of
(Current_Item
, Node_Tree
);
2267 while Present
(Case_Item
) loop
2268 Choice_String
:= First_Choice_Of
(Case_Item
, Node_Tree
);
2270 -- When Choice_String is nil, it means that it is the
2271 -- "when others =>" alternative.
2273 if No
(Choice_String
) then
2274 Decl_Item
:= First_Declarative_Item_Of
(Case_Item
, Node_Tree
);
2275 exit Case_Item_Loop
;
2278 -- Look into all the alternative of this case item
2281 while Present
(Choice_String
) loop
2282 if Case_Value
= String_Value_Of
(Choice_String
, Node_Tree
) then
2284 First_Declarative_Item_Of
(Case_Item
, Node_Tree
);
2285 exit Case_Item_Loop
;
2288 Choice_String
:= Next_Literal_String
(Choice_String
, Node_Tree
);
2289 end loop Choice_Loop
;
2291 Case_Item
:= Next_Case_Item
(Case_Item
, Node_Tree
);
2292 end loop Case_Item_Loop
;
2294 -- If there is an alternative, then we process it
2296 if Present
(Decl_Item
) then
2297 Process_Declarative_Items
2298 (Project
=> Project
,
2300 From_Project_Node
=> From_Project_Node
,
2301 Node_Tree
=> Node_Tree
,
2305 Child_Env
=> Child_Env
);
2307 end Process_Case_Construction
;
2311 Current
, Decl
: Project_Node_Id
;
2312 Kind
: Project_Node_Kind
;
2314 -- Start of processing for Process_Declarative_Items
2318 while Present
(Decl
) loop
2319 Current
:= Current_Item_Node
(Decl
, Node_Tree
);
2320 Decl
:= Next_Declarative_Item
(Decl
, Node_Tree
);
2321 Kind
:= Kind_Of
(Current
, Node_Tree
);
2324 when N_Package_Declaration
=>
2325 Process_Package_Declaration
(Current
);
2327 -- Nothing to process for string type declaration
2329 when N_String_Type_Declaration
=>
2332 when N_Attribute_Declaration |
2333 N_Typed_Variable_Declaration |
2334 N_Variable_Declaration
=>
2335 Process_Attribute_Declaration
(Current
);
2337 when N_Case_Construction
=>
2338 Process_Case_Construction
(Current
);
2341 Write_Line
("Illegal declarative item: " & Kind
'Img);
2342 raise Program_Error
;
2345 end Process_Declarative_Items
;
2347 ----------------------------------
2348 -- Process_Project_Tree_Phase_1 --
2349 ----------------------------------
2351 procedure Process_Project_Tree_Phase_1
2352 (In_Tree
: Project_Tree_Ref
;
2353 Project
: out Project_Id
;
2354 Packages_To_Check
: String_List_Access
;
2355 Success
: out Boolean;
2356 From_Project_Node
: Project_Node_Id
;
2357 From_Project_Node_Tree
: Project_Node_Tree_Ref
;
2358 Env
: in out Prj
.Tree
.Environment
;
2359 Reset_Tree
: Boolean := True)
2364 -- Make sure there are no projects in the data structure
2366 Free_List
(In_Tree
.Projects
, Free_Project
=> True);
2369 Processed_Projects
.Reset
;
2371 -- And process the main project and all of the projects it depends on,
2374 Debug_Increase_Indent
("Process tree, phase 1");
2377 (Project
=> Project
,
2379 Packages_To_Check
=> Packages_To_Check
,
2380 From_Project_Node
=> From_Project_Node
,
2381 From_Project_Node_Tree
=> From_Project_Node_Tree
,
2383 Extended_By
=> No_Project
,
2384 From_Encapsulated_Lib
=> False);
2387 Total_Errors_Detected
= 0
2389 (Warning_Mode
/= Treat_As_Error
or else Warnings_Detected
= 0);
2391 if Current_Verbosity
= High
then
2392 Debug_Decrease_Indent
2393 ("Done Process tree, phase 1, Success=" & Success
'Img);
2395 end Process_Project_Tree_Phase_1
;
2397 ----------------------------------
2398 -- Process_Project_Tree_Phase_2 --
2399 ----------------------------------
2401 procedure Process_Project_Tree_Phase_2
2402 (In_Tree
: Project_Tree_Ref
;
2403 Project
: Project_Id
;
2404 Success
: out Boolean;
2405 From_Project_Node
: Project_Node_Id
;
2406 From_Project_Node_Tree
: Project_Node_Tree_Ref
;
2409 Obj_Dir
: Path_Name_Type
;
2410 Extending
: Project_Id
;
2411 Extending2
: Project_Id
;
2414 -- Start of processing for Process_Project_Tree_Phase_2
2419 Debug_Increase_Indent
("Process tree, phase 2", Project
.Name
);
2421 if Project
/= No_Project
then
2422 Check
(In_Tree
, Project
, From_Project_Node_Tree
, Env
.Flags
);
2425 -- If main project is an extending all project, set object directory of
2426 -- all virtual extending projects to object directory of main project.
2428 if Project
/= No_Project
2429 and then Is_Extending_All
(From_Project_Node
, From_Project_Node_Tree
)
2432 Object_Dir
: constant Path_Information
:= Project
.Object_Directory
;
2435 Prj
:= In_Tree
.Projects
;
2436 while Prj
/= null loop
2437 if Prj
.Project
.Virtual
then
2438 Prj
.Project
.Object_Directory
:= Object_Dir
;
2446 -- Check that no extending project shares its object directory with
2447 -- the project(s) it extends.
2449 if Project
/= No_Project
then
2450 Prj
:= In_Tree
.Projects
;
2451 while Prj
/= null loop
2452 Extending
:= Prj
.Project
.Extended_By
;
2454 if Extending
/= No_Project
then
2455 Obj_Dir
:= Prj
.Project
.Object_Directory
.Name
;
2457 -- Check that a project being extended does not share its
2458 -- object directory with any project that extends it, directly
2459 -- or indirectly, including a virtual extending project.
2461 -- Start with the project directly extending it
2463 Extending2
:= Extending
;
2464 while Extending2
/= No_Project
loop
2465 if Has_Ada_Sources
(Extending2
)
2466 and then Extending2
.Object_Directory
.Name
= Obj_Dir
2468 if Extending2
.Virtual
then
2469 Error_Msg_Name_1
:= Prj
.Project
.Display_Name
;
2472 "project %% cannot be extended by a virtual" &
2473 " project with the same object directory",
2474 Prj
.Project
.Location
, Project
);
2477 Error_Msg_Name_1
:= Extending2
.Display_Name
;
2478 Error_Msg_Name_2
:= Prj
.Project
.Display_Name
;
2481 "project %% cannot extend project %%",
2482 Extending2
.Location
, Project
);
2485 "\they share the same object directory",
2486 Extending2
.Location
, Project
);
2490 -- Continue with the next extending project, if any
2492 Extending2
:= Extending2
.Extended_By
;
2500 Debug_Decrease_Indent
("Done Process tree, phase 2");
2502 Success
:= Total_Errors_Detected
= 0
2504 (Warning_Mode
/= Treat_As_Error
or else Warnings_Detected
= 0);
2505 end Process_Project_Tree_Phase_2
;
2507 -----------------------
2508 -- Recursive_Process --
2509 -----------------------
2511 procedure Recursive_Process
2512 (In_Tree
: Project_Tree_Ref
;
2513 Project
: out Project_Id
;
2514 Packages_To_Check
: String_List_Access
;
2515 From_Project_Node
: Project_Node_Id
;
2516 From_Project_Node_Tree
: Project_Node_Tree_Ref
;
2517 Env
: in out Prj
.Tree
.Environment
;
2518 Extended_By
: Project_Id
;
2519 From_Encapsulated_Lib
: Boolean)
2521 Shared
: constant Shared_Project_Tree_Data_Access
:= In_Tree
.Shared
;
2523 Child_Env
: Prj
.Tree
.Environment
;
2524 -- Only used for the root aggregate project (if any). This is left
2525 -- uninitialized otherwise.
2527 procedure Process_Imported_Projects
2528 (Imported
: in out Project_List
;
2529 Limited_With
: Boolean);
2530 -- Process imported projects. If Limited_With is True, then only
2531 -- projects processed through a "limited with" are processed, otherwise
2532 -- only projects imported through a standard "with" are processed.
2533 -- Imported is the id of the last imported project.
2535 procedure Process_Aggregated_Projects
;
2536 -- Process all the projects aggregated in List. This does nothing if the
2537 -- project is not an aggregate project.
2539 procedure Process_Extended_Project
;
2540 -- Process the extended project: inherit all packages from the extended
2541 -- project that are not explicitly defined or renamed. Also inherit the
2542 -- languages, if attribute Languages is not explicitly defined.
2544 -------------------------------
2545 -- Process_Imported_Projects --
2546 -------------------------------
2548 procedure Process_Imported_Projects
2549 (Imported
: in out Project_List
;
2550 Limited_With
: Boolean)
2552 With_Clause
: Project_Node_Id
;
2553 New_Project
: Project_Id
;
2554 Proj_Node
: Project_Node_Id
;
2558 First_With_Clause_Of
2559 (From_Project_Node
, From_Project_Node_Tree
);
2561 while Present
(With_Clause
) loop
2563 Non_Limited_Project_Node_Of
2564 (With_Clause
, From_Project_Node_Tree
);
2565 New_Project
:= No_Project
;
2567 if (Limited_With
and then No
(Proj_Node
))
2568 or else (not Limited_With
and then Present
(Proj_Node
))
2571 (In_Tree
=> In_Tree
,
2572 Project
=> New_Project
,
2573 Packages_To_Check
=> Packages_To_Check
,
2574 From_Project_Node
=>
2575 Project_Node_Of
(With_Clause
, From_Project_Node_Tree
),
2576 From_Project_Node_Tree
=> From_Project_Node_Tree
,
2578 Extended_By
=> No_Project
,
2579 From_Encapsulated_Lib
=> From_Encapsulated_Lib
);
2581 if Imported
= null then
2582 Project
.Imported_Projects
:= new Project_List_Element
'
2583 (Project => New_Project,
2584 From_Encapsulated_Lib => False,
2586 Imported := Project.Imported_Projects;
2588 Imported.Next := new Project_List_Element'
2589 (Project
=> New_Project
,
2590 From_Encapsulated_Lib
=> False,
2592 Imported
:= Imported
.Next
;
2597 Next_With_Clause_Of
(With_Clause
, From_Project_Node_Tree
);
2599 end Process_Imported_Projects
;
2601 ---------------------------------
2602 -- Process_Aggregated_Projects --
2603 ---------------------------------
2605 procedure Process_Aggregated_Projects
is
2606 List
: Aggregated_Project_List
;
2607 Loaded_Project
: Prj
.Tree
.Project_Node_Id
;
2608 Success
: Boolean := True;
2609 Tree
: Project_Tree_Ref
;
2610 Node_Tree
: Project_Node_Tree_Ref
;
2613 if Project
.Qualifier
not in Aggregate_Project
then
2617 Debug_Increase_Indent
("Process_Aggregated_Projects", Project
.Name
);
2619 Prj
.Nmsc
.Process_Aggregated_Projects
2622 Node_Tree
=> From_Project_Node_Tree
,
2623 Flags
=> Env
.Flags
);
2625 List
:= Project
.Aggregated_Projects
;
2626 while Success
and then List
/= null loop
2627 Node_Tree
:= new Project_Node_Tree_Data
;
2628 Initialize
(Node_Tree
);
2631 (In_Tree
=> Node_Tree
,
2632 Project
=> Loaded_Project
,
2633 Packages_To_Check
=> Packages_To_Check
,
2634 Project_File_Name
=> Get_Name_String
(List
.Path
),
2635 Errout_Handling
=> Prj
.Part
.Never_Finalize
,
2636 Current_Directory
=> Get_Name_String
(Project
.Directory
.Name
),
2637 Is_Config_File
=> False,
2640 Success
:= not Prj
.Tree
.No
(Loaded_Project
);
2643 List
.Tree
:= new Project_Tree_Data
(Is_Root_Tree
=> False);
2644 Prj
.Initialize
(List
.Tree
);
2645 List
.Tree
.Shared
:= In_Tree
.Shared
;
2647 -- In aggregate library, aggregated projects are parsed using
2648 -- the aggregate library tree.
2650 if Project
.Qualifier
= Aggregate_Library
then
2656 -- We can only do the phase 1 of the processing, since we do
2657 -- not have access to the configuration file yet (this is
2658 -- called when doing phase 1 of the processing for the root
2659 -- aggregate project).
2661 if In_Tree
.Is_Root_Tree
then
2662 Process_Project_Tree_Phase_1
2664 Project
=> List
.Project
,
2665 Packages_To_Check
=> Packages_To_Check
,
2667 From_Project_Node
=> Loaded_Project
,
2668 From_Project_Node_Tree
=> Node_Tree
,
2670 Reset_Tree
=> False);
2672 -- use the same environment as the rest of the aggregated
2673 -- projects, ie the one that was setup by the root aggregate
2674 Process_Project_Tree_Phase_1
2676 Project
=> List
.Project
,
2677 Packages_To_Check
=> Packages_To_Check
,
2679 From_Project_Node
=> Loaded_Project
,
2680 From_Project_Node_Tree
=> Node_Tree
,
2682 Reset_Tree
=> False);
2686 Debug_Output
("Failed to parse", Name_Id
(List
.Path
));
2692 Debug_Decrease_Indent
("Done Process_Aggregated_Projects");
2693 end Process_Aggregated_Projects
;
2695 ------------------------------
2696 -- Process_Extended_Project --
2697 ------------------------------
2699 procedure Process_Extended_Project
is
2700 Extended_Pkg
: Package_Id
;
2701 Current_Pkg
: Package_Id
;
2702 Element
: Package_Element
;
2703 First
: constant Package_Id
:= Project
.Decl
.Packages
;
2704 Attribute1
: Variable_Id
;
2705 Attribute2
: Variable_Id
;
2706 Attr_Value1
: Variable
;
2707 Attr_Value2
: Variable
;
2710 Extended_Pkg
:= Project
.Extends
.Decl
.Packages
;
2711 while Extended_Pkg
/= No_Package
loop
2712 Element
:= Shared
.Packages
.Table
(Extended_Pkg
);
2714 Current_Pkg
:= First
;
2715 while Current_Pkg
/= No_Package
2717 Shared
.Packages
.Table
(Current_Pkg
).Name
/= Element
.Name
2719 Current_Pkg
:= Shared
.Packages
.Table
(Current_Pkg
).Next
;
2722 if Current_Pkg
= No_Package
then
2723 Package_Table
.Increment_Last
(Shared
.Packages
);
2724 Current_Pkg
:= Package_Table
.Last
(Shared
.Packages
);
2725 Shared
.Packages
.Table
(Current_Pkg
) :=
2726 (Name
=> Element
.Name
,
2727 Decl
=> No_Declarations
,
2728 Parent
=> No_Package
,
2729 Next
=> Project
.Decl
.Packages
);
2730 Project
.Decl
.Packages
:= Current_Pkg
;
2731 Copy_Package_Declarations
2732 (From
=> Element
.Decl
,
2733 To
=> Shared
.Packages
.Table
(Current_Pkg
).Decl
,
2734 New_Loc
=> No_Location
,
2739 Extended_Pkg
:= Element
.Next
;
2742 -- Check if attribute Languages is declared in the extending project
2744 Attribute1
:= Project
.Decl
.Attributes
;
2745 while Attribute1
/= No_Variable
loop
2746 Attr_Value1
:= Shared
.Variable_Elements
. Table
(Attribute1
);
2747 exit when Attr_Value1
.Name
= Snames
.Name_Languages
;
2748 Attribute1
:= Attr_Value1
.Next
;
2751 if Attribute1
= No_Variable
or else Attr_Value1
.Value
.Default
then
2753 -- Attribute Languages is not declared in the extending project.
2754 -- Check if it is declared in the project being extended.
2756 Attribute2
:= Project
.Extends
.Decl
.Attributes
;
2757 while Attribute2
/= No_Variable
loop
2758 Attr_Value2
:= Shared
.Variable_Elements
.Table
(Attribute2
);
2759 exit when Attr_Value2
.Name
= Snames
.Name_Languages
;
2760 Attribute2
:= Attr_Value2
.Next
;
2763 if Attribute2
/= No_Variable
2764 and then not Attr_Value2
.Value
.Default
2766 -- As attribute Languages is declared in the project being
2767 -- extended, copy its value for the extending project.
2769 if Attribute1
= No_Variable
then
2770 Variable_Element_Table
.Increment_Last
2771 (Shared
.Variable_Elements
);
2772 Attribute1
:= Variable_Element_Table
.Last
2773 (Shared
.Variable_Elements
);
2774 Attr_Value1
.Next
:= Project
.Decl
.Attributes
;
2775 Project
.Decl
.Attributes
:= Attribute1
;
2778 Attr_Value1
.Name
:= Snames
.Name_Languages
;
2779 Attr_Value1
.Value
:= Attr_Value2
.Value
;
2780 Shared
.Variable_Elements
.Table
(Attribute1
) := Attr_Value1
;
2783 end Process_Extended_Project
;
2785 -- Start of processing for Recursive_Process
2788 if No
(From_Project_Node
) then
2789 Project
:= No_Project
;
2793 Imported
, Mark
: Project_List
;
2794 Declaration_Node
: Project_Node_Id
:= Empty_Node
;
2796 Name
: constant Name_Id
:=
2797 Name_Of
(From_Project_Node
, From_Project_Node_Tree
);
2799 Name_Node
: constant Tree_Private_Part
.Project_Name_And_Node
:=
2800 Tree_Private_Part
.Projects_Htable
.Get
2801 (From_Project_Node_Tree
.Projects_HT
, Name
);
2804 Project
:= Processed_Projects
.Get
(Name
);
2806 if Project
/= No_Project
then
2808 -- Make sure that, when a project is extended, the project id
2809 -- of the project extending it is recorded in its data, even
2810 -- when it has already been processed as an imported project.
2811 -- This is for virtually extended projects.
2813 if Extended_By
/= No_Project
then
2814 Project
.Extended_By
:= Extended_By
;
2823 (Project_Qualifier_Of
2824 (From_Project_Node, From_Project_Node_Tree)));
2826 -- Note that at this point we do not know yet if the project has
2827 -- been withed from an encapsulated library or not.
2830 new Project_List_Element'
2831 (Project
=> Project
,
2832 From_Encapsulated_Lib
=> False,
2833 Next
=> In_Tree
.Projects
);
2835 -- Keep track of this point
2837 Mark
:= In_Tree
.Projects
;
2839 Processed_Projects
.Set
(Name
, Project
);
2841 Project
.Name
:= Name
;
2842 Project
.Display_Name
:= Name_Node
.Display_Name
;
2843 Get_Name_String
(Name
);
2845 -- If name starts with the virtual prefix, flag the project as
2846 -- being a virtual extending project.
2848 if Name_Len
> Virtual_Prefix
'Length
2850 Name_Buffer
(1 .. Virtual_Prefix
'Length) = Virtual_Prefix
2852 Project
.Virtual
:= True;
2855 Project
.Path
.Display_Name
:=
2856 Path_Name_Of
(From_Project_Node
, From_Project_Node_Tree
);
2857 Get_Name_String
(Project
.Path
.Display_Name
);
2858 Canonical_Case_File_Name
(Name_Buffer
(1 .. Name_Len
));
2859 Project
.Path
.Name
:= Name_Find
;
2862 Location_Of
(From_Project_Node
, From_Project_Node_Tree
);
2864 Project
.Directory
.Display_Name
:=
2865 Directory_Of
(From_Project_Node
, From_Project_Node_Tree
);
2866 Get_Name_String
(Project
.Directory
.Display_Name
);
2867 Canonical_Case_File_Name
(Name_Buffer
(1 .. Name_Len
));
2868 Project
.Directory
.Name
:= Name_Find
;
2870 Project
.Extended_By
:= Extended_By
;
2875 Name_Id
(Project
.Directory
.Display_Name
),
2878 Prj
.Attr
.Attribute_First
,
2879 Project_Level
=> True);
2881 Process_Imported_Projects
(Imported
, Limited_With
=> False);
2883 if Project
.Qualifier
= Aggregate
and then In_Tree
.Is_Root_Tree
then
2884 Initialize_And_Copy
(Child_Env
, Copy_From
=> Env
);
2886 elsif Project
.Qualifier
= Aggregate_Library
then
2888 -- The child environment is the same as the current one
2893 -- No need to initialize Child_Env, since it will not be
2894 -- used anyway by Process_Declarative_Items (only the root
2895 -- aggregate can modify it, and it is never read anyway).
2901 Project_Declaration_Of
2902 (From_Project_Node
, From_Project_Node_Tree
);
2905 (In_Tree
=> In_Tree
,
2906 Project
=> Project
.Extends
,
2907 Packages_To_Check
=> Packages_To_Check
,
2908 From_Project_Node
=>
2910 (Declaration_Node
, From_Project_Node_Tree
),
2911 From_Project_Node_Tree
=> From_Project_Node_Tree
,
2913 Extended_By
=> Project
,
2914 From_Encapsulated_Lib
=> From_Encapsulated_Lib
);
2916 Process_Declarative_Items
2917 (Project
=> Project
,
2919 From_Project_Node
=> From_Project_Node
,
2920 Node_Tree
=> From_Project_Node_Tree
,
2923 Item
=> First_Declarative_Item_Of
2924 (Declaration_Node
, From_Project_Node_Tree
),
2925 Child_Env
=> Child_Env
);
2927 if Project
.Extends
/= No_Project
then
2928 Process_Extended_Project
;
2931 Process_Imported_Projects
(Imported
, Limited_With
=> True);
2933 if Total_Errors_Detected
= 0 then
2934 Process_Aggregated_Projects
;
2937 -- At this point (after Process_Declarative_Items) we have the
2938 -- attribute values set, we can backtrace In_Tree.Project and
2939 -- set the From_Encapsulated_Library status.
2942 Lib_Standalone
: constant Prj
.Variable_Value
:=
2944 (Snames
.Name_Library_Standalone
,
2945 Project
.Decl
.Attributes
,
2947 List
: Project_List
:= In_Tree
.Projects
;
2948 Is_Encapsulated
: Boolean;
2951 Get_Name_String
(Lib_Standalone
.Value
);
2952 To_Lower
(Name_Buffer
(1 .. Name_Len
));
2954 Is_Encapsulated
:= Name_Buffer
(1 .. Name_Len
) = "encapsulated";
2956 if Is_Encapsulated
then
2957 while List
/= null and then List
/= Mark
loop
2958 List
.From_Encapsulated_Lib
:= Is_Encapsulated
;
2963 if Total_Errors_Detected
= 0 then
2965 -- For an aggregate library we add the aggregated projects
2966 -- as imported ones. This is necessary to give visibility
2967 -- to all sources from the aggregates from the aggregated
2968 -- library projects.
2970 if Project
.Qualifier
= Aggregate_Library
then
2972 L
: Aggregated_Project_List
;
2974 L
:= Project
.Aggregated_Projects
;
2975 while L
/= null loop
2976 Project
.Imported_Projects
:=
2977 new Project_List_Element
'
2978 (Project => L.Project,
2979 From_Encapsulated_Lib => Is_Encapsulated,
2981 Project.Imported_Projects);
2989 if Project.Qualifier = Aggregate and then In_Tree.Is_Root_Tree then
2994 end Recursive_Process;