1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2009, 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 Err_Vars
; use Err_Vars
;
28 with Osint
; use Osint
;
29 with Output
; use Output
;
30 with Prj
.Attr
; use Prj
.Attr
;
31 with Prj
.Err
; use Prj
.Err
;
32 with Prj
.Ext
; use Prj
.Ext
;
33 with Prj
.Nmsc
; use Prj
.Nmsc
;
36 with GNAT
.Case_Util
; use GNAT
.Case_Util
;
39 package body Prj
.Proc
is
41 package Processed_Projects
is new GNAT
.HTable
.Simple_HTable
42 (Header_Num
=> Header_Num
,
43 Element
=> Project_Id
,
44 No_Element
=> No_Project
,
48 -- This hash table contains all processed projects
50 package Unit_Htable
is new GNAT
.HTable
.Simple_HTable
51 (Header_Num
=> Header_Num
,
53 No_Element
=> No_Source
,
57 -- This hash table contains all processed projects
59 procedure Add
(To_Exp
: in out Name_Id
; Str
: Name_Id
);
60 -- Concatenate two strings and returns another string if both
61 -- arguments are not null string.
63 -- In the following procedures, we are expected to guess the meaning of
64 -- the parameters from their names, this is never a good idea, comments
65 -- should be added precisely defining every formal ???
67 procedure Add_Attributes
68 (Project
: Project_Id
;
69 Project_Name
: Name_Id
;
70 Project_Dir
: Name_Id
;
71 In_Tree
: Project_Tree_Ref
;
72 Decl
: in out Declarations
;
73 First
: Attribute_Node_Id
;
74 Project_Level
: Boolean);
75 -- Add all attributes, starting with First, with their default values to
76 -- the package or project with declarations Decl.
79 (In_Tree
: Project_Tree_Ref
;
81 Flags
: Processing_Flags
);
82 -- Set all projects to not checked, then call Recursive_Check for the
83 -- main project Project. Project is set to No_Project if errors occurred.
84 -- Current_Dir is for optimization purposes, avoiding extra system calls.
85 -- If Allow_Duplicate_Basenames, then files with the same base names are
86 -- authorized within a project for source-based languages (never for unit
89 procedure Copy_Package_Declarations
91 To
: in out Declarations
;
93 Naming_Restricted
: Boolean;
94 In_Tree
: Project_Tree_Ref
);
95 -- Copy a package declaration From to To for a renamed package. Change the
96 -- locations of all the attributes to New_Loc. When Naming_Restricted is
97 -- True, do not copy attributes Body, Spec, Implementation and
101 (Project
: Project_Id
;
102 In_Tree
: Project_Tree_Ref
;
103 Flags
: Processing_Flags
;
104 From_Project_Node
: Project_Node_Id
;
105 From_Project_Node_Tree
: Project_Node_Tree_Ref
;
107 First_Term
: Project_Node_Id
;
108 Kind
: Variable_Kind
) return Variable_Value
;
109 -- From N_Expression project node From_Project_Node, compute the value
110 -- of an expression and return it as a Variable_Value.
112 function Imported_Or_Extended_Project_From
113 (Project
: Project_Id
;
114 With_Name
: Name_Id
) return Project_Id
;
115 -- Find an imported or extended project of Project whose name is With_Name
117 function Package_From
118 (Project
: Project_Id
;
119 In_Tree
: Project_Tree_Ref
;
120 With_Name
: Name_Id
) return Package_Id
;
121 -- Find the package of Project whose name is With_Name
123 procedure Process_Declarative_Items
124 (Project
: Project_Id
;
125 In_Tree
: Project_Tree_Ref
;
126 Flags
: Processing_Flags
;
127 From_Project_Node
: Project_Node_Id
;
128 From_Project_Node_Tree
: Project_Node_Tree_Ref
;
130 Item
: Project_Node_Id
);
131 -- Process declarative items starting with From_Project_Node, and put them
132 -- in declarations Decl. This is a recursive procedure; it calls itself for
133 -- a package declaration or a case construction.
135 procedure Recursive_Process
136 (In_Tree
: Project_Tree_Ref
;
137 Project
: out Project_Id
;
138 Flags
: Processing_Flags
;
139 From_Project_Node
: Project_Node_Id
;
140 From_Project_Node_Tree
: Project_Node_Tree_Ref
;
141 Extended_By
: Project_Id
);
142 -- Process project with node From_Project_Node in the tree. Do nothing if
143 -- From_Project_Node is Empty_Node. If project has already been processed,
144 -- simply return its project id. Otherwise create a new project id, mark it
145 -- as processed, call itself recursively for all imported projects and a
146 -- extended project, if any. Then process the declarative items of the
149 function Get_Attribute_Index
150 (Tree
: Project_Node_Tree_Ref
;
151 Attr
: Project_Node_Id
;
152 Index
: Name_Id
) return Name_Id
;
153 -- Copy the index of the attribute into Name_Buffer, converting to lower
154 -- case if the attribute is case-insensitive.
160 procedure Add
(To_Exp
: in out Name_Id
; Str
: Name_Id
) is
162 if To_Exp
= No_Name
or else To_Exp
= Empty_String
then
164 -- To_Exp is nil or empty. The result is Str
168 -- If Str is nil, then do not change To_Ext
170 elsif Str
/= No_Name
and then Str
/= Empty_String
then
172 S
: constant String := Get_Name_String
(Str
);
174 Get_Name_String
(To_Exp
);
175 Add_Str_To_Name_Buffer
(S
);
185 procedure Add_Attributes
186 (Project
: Project_Id
;
187 Project_Name
: Name_Id
;
188 Project_Dir
: Name_Id
;
189 In_Tree
: Project_Tree_Ref
;
190 Decl
: in out Declarations
;
191 First
: Attribute_Node_Id
;
192 Project_Level
: Boolean)
194 The_Attribute
: Attribute_Node_Id
:= First
;
197 while The_Attribute
/= Empty_Attribute
loop
198 if Attribute_Kind_Of
(The_Attribute
) = Single
then
200 New_Attribute
: Variable_Value
;
203 case Variable_Kind_Of
(The_Attribute
) is
205 -- Undefined should not happen
209 (False, "attribute with an undefined kind");
212 -- Single attributes have a default value of empty string
218 Location
=> No_Location
,
220 Value
=> Empty_String
,
223 -- Special cases of <project>'Name and
224 -- <project>'Project_Dir.
226 if Project_Level
then
227 if Attribute_Name_Of
(The_Attribute
) =
230 New_Attribute
.Value
:= Project_Name
;
232 elsif Attribute_Name_Of
(The_Attribute
) =
233 Snames
.Name_Project_Dir
235 New_Attribute
.Value
:= Project_Dir
;
239 -- List attributes have a default value of nil list
245 Location
=> No_Location
,
247 Values
=> Nil_String
);
251 Variable_Element_Table
.Increment_Last
252 (In_Tree
.Variable_Elements
);
253 In_Tree
.Variable_Elements
.Table
254 (Variable_Element_Table
.Last
255 (In_Tree
.Variable_Elements
)) :=
256 (Next
=> Decl
.Attributes
,
257 Name
=> Attribute_Name_Of
(The_Attribute
),
258 Value
=> New_Attribute
);
259 Decl
.Attributes
:= Variable_Element_Table
.Last
260 (In_Tree
.Variable_Elements
);
264 The_Attribute
:= Next_Attribute
(After
=> The_Attribute
);
273 (In_Tree
: Project_Tree_Ref
;
274 Project
: Project_Id
;
275 Flags
: Processing_Flags
)
278 Process_Naming_Scheme
(In_Tree
, Project
, Flags
);
280 -- Set the Other_Part field for the units
286 Iter
: Source_Iterator
;
291 Iter
:= For_Each_Source
(In_Tree
);
293 Source1
:= Prj
.Element
(Iter
);
294 exit when Source1
= No_Source
;
296 if Source1
.Unit
/= No_Unit_Index
then
297 Name
:= Source1
.Unit
.Name
;
298 Source2
:= Unit_Htable
.Get
(Name
);
300 if Source2
= No_Source
then
301 Unit_Htable
.Set
(K
=> Name
, E
=> Source1
);
303 Unit_Htable
.Remove
(Name
);
312 -------------------------------
313 -- Copy_Package_Declarations --
314 -------------------------------
316 procedure Copy_Package_Declarations
317 (From
: Declarations
;
318 To
: in out Declarations
;
319 New_Loc
: Source_Ptr
;
320 Naming_Restricted
: Boolean;
321 In_Tree
: Project_Tree_Ref
)
324 V2
: Variable_Id
:= No_Variable
;
327 A2
: Array_Id
:= No_Array
;
329 E1
: Array_Element_Id
;
330 E2
: Array_Element_Id
:= No_Array_Element
;
334 -- To avoid references in error messages to attribute declarations in
335 -- an original package that has been renamed, copy all the attribute
336 -- declarations of the package and change all locations to New_Loc,
337 -- the location of the renamed package.
339 -- First single attributes
341 V1
:= From
.Attributes
;
342 while V1
/= No_Variable
loop
344 -- Copy the attribute
346 Var
:= In_Tree
.Variable_Elements
.Table
(V1
);
349 -- Remove the Next component
351 Var
.Next
:= No_Variable
;
353 -- Change the location to New_Loc
355 Var
.Value
.Location
:= New_Loc
;
356 Variable_Element_Table
.Increment_Last
(In_Tree
.Variable_Elements
);
358 -- Put in new declaration
360 if To
.Attributes
= No_Variable
then
362 Variable_Element_Table
.Last
(In_Tree
.Variable_Elements
);
364 In_Tree
.Variable_Elements
.Table
(V2
).Next
:=
365 Variable_Element_Table
.Last
(In_Tree
.Variable_Elements
);
368 V2
:= Variable_Element_Table
.Last
(In_Tree
.Variable_Elements
);
369 In_Tree
.Variable_Elements
.Table
(V2
) := Var
;
372 -- Then the associated array attributes
375 while A1
/= No_Array
loop
376 Arr
:= In_Tree
.Arrays
.Table
(A1
);
379 if not Naming_Restricted
or else
380 (Arr
.Name
/= Snames
.Name_Body
381 and then Arr
.Name
/= Snames
.Name_Spec
382 and then Arr
.Name
/= Snames
.Name_Implementation
383 and then Arr
.Name
/= Snames
.Name_Specification
)
385 -- Remove the Next component
387 Arr
.Next
:= No_Array
;
389 Array_Table
.Increment_Last
(In_Tree
.Arrays
);
391 -- Create new Array declaration
393 if To
.Arrays
= No_Array
then
394 To
.Arrays
:= Array_Table
.Last
(In_Tree
.Arrays
);
396 In_Tree
.Arrays
.Table
(A2
).Next
:=
397 Array_Table
.Last
(In_Tree
.Arrays
);
400 A2
:= Array_Table
.Last
(In_Tree
.Arrays
);
402 -- Don't store the array as its first element has not been set yet
404 -- Copy the array elements of the array
407 Arr
.Value
:= No_Array_Element
;
408 while E1
/= No_Array_Element
loop
410 -- Copy the array element
412 Elm
:= In_Tree
.Array_Elements
.Table
(E1
);
415 -- Remove the Next component
417 Elm
.Next
:= No_Array_Element
;
419 -- Change the location
421 Elm
.Value
.Location
:= New_Loc
;
422 Array_Element_Table
.Increment_Last
(In_Tree
.Array_Elements
);
424 -- Create new array element
426 if Arr
.Value
= No_Array_Element
then
428 Array_Element_Table
.Last
(In_Tree
.Array_Elements
);
430 In_Tree
.Array_Elements
.Table
(E2
).Next
:=
431 Array_Element_Table
.Last
(In_Tree
.Array_Elements
);
434 E2
:= Array_Element_Table
.Last
(In_Tree
.Array_Elements
);
435 In_Tree
.Array_Elements
.Table
(E2
) := Elm
;
438 -- Finally, store the new array
440 In_Tree
.Arrays
.Table
(A2
) := Arr
;
443 end Copy_Package_Declarations
;
445 -------------------------
446 -- Get_Attribute_Index --
447 -------------------------
449 function Get_Attribute_Index
450 (Tree
: Project_Node_Tree_Ref
;
451 Attr
: Project_Node_Id
;
452 Index
: Name_Id
) return Name_Id
457 Get_Name_String
(Index
);
458 Lower
:= Case_Insensitive
(Attr
, Tree
);
460 -- The index is always case insensitive if it does not include any dot.
461 -- ??? Why not use the properties from prj-attr, simply, maybe because
462 -- we don't know whether we have a file as an index?
467 for J
in 1 .. Name_Len
loop
468 if Name_Buffer
(J
) = '.' then
476 To_Lower
(Name_Buffer
(1 .. Name_Len
));
481 end Get_Attribute_Index
;
488 (Project
: Project_Id
;
489 In_Tree
: Project_Tree_Ref
;
490 Flags
: Processing_Flags
;
491 From_Project_Node
: Project_Node_Id
;
492 From_Project_Node_Tree
: Project_Node_Tree_Ref
;
494 First_Term
: Project_Node_Id
;
495 Kind
: Variable_Kind
) return Variable_Value
497 The_Term
: Project_Node_Id
;
498 -- The term in the expression list
500 The_Current_Term
: Project_Node_Id
:= Empty_Node
;
501 -- The current term node id
503 Result
: Variable_Value
(Kind
=> Kind
);
504 -- The returned result
506 Last
: String_List_Id
:= Nil_String
;
507 -- Reference to the last string elements in Result, when Kind is List
510 Result
.Project
:= Project
;
511 Result
.Location
:= Location_Of
(First_Term
, From_Project_Node_Tree
);
513 -- Process each term of the expression, starting with First_Term
515 The_Term
:= First_Term
;
516 while Present
(The_Term
) loop
517 The_Current_Term
:= Current_Term
(The_Term
, From_Project_Node_Tree
);
519 case Kind_Of
(The_Current_Term
, From_Project_Node_Tree
) is
521 when N_Literal_String
=>
527 -- Should never happen
529 pragma Assert
(False, "Undefined expression kind");
535 (The_Current_Term
, From_Project_Node_Tree
));
538 (The_Current_Term
, From_Project_Node_Tree
);
542 String_Element_Table
.Increment_Last
543 (In_Tree
.String_Elements
);
545 if Last
= Nil_String
then
547 -- This can happen in an expression like () & "toto"
549 Result
.Values
:= String_Element_Table
.Last
550 (In_Tree
.String_Elements
);
553 In_Tree
.String_Elements
.Table
554 (Last
).Next
:= String_Element_Table
.Last
555 (In_Tree
.String_Elements
);
558 Last
:= String_Element_Table
.Last
559 (In_Tree
.String_Elements
);
561 In_Tree
.String_Elements
.Table
(Last
) :=
562 (Value
=> String_Value_Of
564 From_Project_Node_Tree
),
565 Index
=> Source_Index_Of
567 From_Project_Node_Tree
),
568 Display_Value
=> No_Name
,
569 Location
=> Location_Of
571 From_Project_Node_Tree
),
576 when N_Literal_String_List
=>
579 String_Node
: Project_Node_Id
:=
580 First_Expression_In_List
582 From_Project_Node_Tree
);
584 Value
: Variable_Value
;
587 if Present
(String_Node
) then
589 -- If String_Node is nil, it is an empty list, there is
596 From_Project_Node
=> From_Project_Node
,
597 From_Project_Node_Tree
=> From_Project_Node_Tree
,
601 (String_Node
, From_Project_Node_Tree
),
603 String_Element_Table
.Increment_Last
604 (In_Tree
.String_Elements
);
606 if Result
.Values
= Nil_String
then
608 -- This literal string list is the first term in a
609 -- string list expression
612 String_Element_Table
.Last
(In_Tree
.String_Elements
);
615 In_Tree
.String_Elements
.Table
617 String_Element_Table
.Last
(In_Tree
.String_Elements
);
621 String_Element_Table
.Last
(In_Tree
.String_Elements
);
623 In_Tree
.String_Elements
.Table
(Last
) :=
624 (Value
=> Value
.Value
,
625 Display_Value
=> No_Name
,
626 Location
=> Value
.Location
,
629 Index
=> Value
.Index
);
632 -- Add the other element of the literal string list
633 -- one after the other
636 Next_Expression_In_List
637 (String_Node
, From_Project_Node_Tree
);
639 exit when No
(String_Node
);
646 From_Project_Node
=> From_Project_Node
,
647 From_Project_Node_Tree
=> From_Project_Node_Tree
,
651 (String_Node
, From_Project_Node_Tree
),
654 String_Element_Table
.Increment_Last
655 (In_Tree
.String_Elements
);
656 In_Tree
.String_Elements
.Table
657 (Last
).Next
:= String_Element_Table
.Last
658 (In_Tree
.String_Elements
);
659 Last
:= String_Element_Table
.Last
660 (In_Tree
.String_Elements
);
661 In_Tree
.String_Elements
.Table
(Last
) :=
662 (Value
=> Value
.Value
,
663 Display_Value
=> No_Name
,
664 Location
=> Value
.Location
,
667 Index
=> Value
.Index
);
672 when N_Variable_Reference | N_Attribute_Reference
=>
675 The_Project
: Project_Id
:= Project
;
676 The_Package
: Package_Id
:= Pkg
;
677 The_Name
: Name_Id
:= No_Name
;
678 The_Variable_Id
: Variable_Id
:= No_Variable
;
679 The_Variable
: Variable_Value
;
680 Term_Project
: constant Project_Node_Id
:=
683 From_Project_Node_Tree
);
684 Term_Package
: constant Project_Node_Id
:=
687 From_Project_Node_Tree
);
688 Index
: Name_Id
:= No_Name
;
691 if Present
(Term_Project
) and then
692 Term_Project
/= From_Project_Node
694 -- This variable or attribute comes from another project
697 Name_Of
(Term_Project
, From_Project_Node_Tree
);
698 The_Project
:= Imported_Or_Extended_Project_From
700 With_Name
=> The_Name
);
703 if Present
(Term_Package
) then
705 -- This is an attribute of a package
708 Name_Of
(Term_Package
, From_Project_Node_Tree
);
709 The_Package
:= The_Project
.Decl
.Packages
;
711 while The_Package
/= No_Package
712 and then In_Tree
.Packages
.Table
713 (The_Package
).Name
/= The_Name
716 In_Tree
.Packages
.Table
721 (The_Package
/= No_Package
,
722 "package not found.");
724 elsif Kind_Of
(The_Current_Term
, From_Project_Node_Tree
) =
725 N_Attribute_Reference
727 The_Package
:= No_Package
;
731 Name_Of
(The_Current_Term
, From_Project_Node_Tree
);
733 if Kind_Of
(The_Current_Term
, From_Project_Node_Tree
) =
734 N_Attribute_Reference
737 Associative_Array_Index_Of
738 (The_Current_Term
, From_Project_Node_Tree
);
741 -- If it is not an associative array attribute
743 if Index
= No_Name
then
745 -- It is not an associative array attribute
747 if The_Package
/= No_Package
then
749 -- First, if there is a package, look into the package
751 if Kind_Of
(The_Current_Term
, From_Project_Node_Tree
) =
755 In_Tree
.Packages
.Table
756 (The_Package
).Decl
.Variables
;
759 In_Tree
.Packages
.Table
760 (The_Package
).Decl
.Attributes
;
763 while The_Variable_Id
/= No_Variable
765 In_Tree
.Variable_Elements
.Table
766 (The_Variable_Id
).Name
/= The_Name
769 In_Tree
.Variable_Elements
.Table
770 (The_Variable_Id
).Next
;
775 if The_Variable_Id
= No_Variable
then
777 -- If we have not found it, look into the project
779 if Kind_Of
(The_Current_Term
, From_Project_Node_Tree
) =
782 The_Variable_Id
:= The_Project
.Decl
.Variables
;
784 The_Variable_Id
:= The_Project
.Decl
.Attributes
;
787 while The_Variable_Id
/= No_Variable
789 In_Tree
.Variable_Elements
.Table
790 (The_Variable_Id
).Name
/= The_Name
793 In_Tree
.Variable_Elements
.Table
794 (The_Variable_Id
).Next
;
799 pragma Assert
(The_Variable_Id
/= No_Variable
,
800 "variable or attribute not found");
803 In_Tree
.Variable_Elements
.Table
804 (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 In_Tree
.Packages
.Table
819 (The_Package
).Decl
.Arrays
;
821 The_Array
:= The_Project
.Decl
.Arrays
;
824 while The_Array
/= No_Array
825 and then In_Tree
.Arrays
.Table
826 (The_Array
).Name
/= The_Name
828 The_Array
:= In_Tree
.Arrays
.Table
832 if The_Array
/= No_Array
then
833 The_Element
:= In_Tree
.Arrays
.Table
837 (From_Project_Node_Tree
,
841 while The_Element
/= No_Array_Element
843 In_Tree
.Array_Elements
.Table
844 (The_Element
).Index
/= Array_Index
847 In_Tree
.Array_Elements
.Table
853 if The_Element
/= No_Array_Element
then
855 In_Tree
.Array_Elements
.Table
859 if Expression_Kind_Of
860 (The_Current_Term
, From_Project_Node_Tree
) =
866 Location
=> No_Location
,
868 Values
=> Nil_String
);
873 Location
=> No_Location
,
875 Value
=> Empty_String
,
886 -- Should never happen
888 pragma Assert
(False, "undefined expression kind");
893 case The_Variable
.Kind
is
899 Add
(Result
.Value
, The_Variable
.Value
);
903 -- Should never happen
907 "list cannot appear in single " &
908 "string expression");
913 case The_Variable
.Kind
is
919 String_Element_Table
.Increment_Last
920 (In_Tree
.String_Elements
);
922 if Last
= Nil_String
then
924 -- This can happen in an expression such as
928 String_Element_Table
.Last
929 (In_Tree
.String_Elements
);
932 In_Tree
.String_Elements
.Table
934 String_Element_Table
.Last
935 (In_Tree
.String_Elements
);
939 String_Element_Table
.Last
940 (In_Tree
.String_Elements
);
942 In_Tree
.String_Elements
.Table
(Last
) :=
943 (Value
=> The_Variable
.Value
,
944 Display_Value
=> No_Name
,
945 Location
=> Location_Of
947 From_Project_Node_Tree
),
955 The_List
: String_List_Id
:=
959 while The_List
/= Nil_String
loop
960 String_Element_Table
.Increment_Last
961 (In_Tree
.String_Elements
);
963 if Last
= Nil_String
then
965 String_Element_Table
.Last
971 String_Elements
.Table
(Last
).Next
:=
972 String_Element_Table
.Last
979 String_Element_Table
.Last
980 (In_Tree
.String_Elements
);
982 In_Tree
.String_Elements
.Table
(Last
) :=
984 In_Tree
.String_Elements
.Table
986 Display_Value
=> No_Name
,
990 From_Project_Node_Tree
),
996 In_Tree
. String_Elements
.Table
1004 when N_External_Value
=>
1007 (External_Reference_Of
1008 (The_Current_Term
, From_Project_Node_Tree
),
1009 From_Project_Node_Tree
));
1012 Name
: constant Name_Id
:= Name_Find
;
1013 Default
: Name_Id
:= No_Name
;
1014 Value
: Name_Id
:= No_Name
;
1016 Def_Var
: Variable_Value
;
1018 Default_Node
: constant Project_Node_Id
:=
1020 (The_Current_Term
, From_Project_Node_Tree
);
1023 -- If there is a default value for the external reference,
1026 if Present
(Default_Node
) then
1027 Def_Var
:= Expression
1028 (Project
=> Project
,
1031 From_Project_Node
=> From_Project_Node
,
1032 From_Project_Node_Tree
=> From_Project_Node_Tree
,
1036 (Default_Node
, From_Project_Node_Tree
),
1039 if Def_Var
/= Nil_Variable_Value
then
1040 Default
:= Def_Var
.Value
;
1045 Prj
.Ext
.Value_Of
(From_Project_Node_Tree
, Name
, Default
);
1047 if Value
= No_Name
then
1048 if not Quiet_Output
then
1050 (Flags
, "?undefined external reference",
1052 (The_Current_Term
, From_Project_Node_Tree
),
1056 Value
:= Empty_String
;
1065 Add
(Result
.Value
, Value
);
1068 String_Element_Table
.Increment_Last
1069 (In_Tree
.String_Elements
);
1071 if Last
= Nil_String
then
1072 Result
.Values
:= String_Element_Table
.Last
1073 (In_Tree
.String_Elements
);
1076 In_Tree
.String_Elements
.Table
1077 (Last
).Next
:= String_Element_Table
.Last
1078 (In_Tree
.String_Elements
);
1081 Last
:= String_Element_Table
.Last
1082 (In_Tree
.String_Elements
);
1083 In_Tree
.String_Elements
.Table
(Last
) :=
1085 Display_Value
=> No_Name
,
1088 (The_Current_Term
, From_Project_Node_Tree
),
1098 -- Should never happen
1102 "illegal node kind in an expression");
1103 raise Program_Error
;
1107 The_Term
:= Next_Term
(The_Term
, From_Project_Node_Tree
);
1113 ---------------------------------------
1114 -- Imported_Or_Extended_Project_From --
1115 ---------------------------------------
1117 function Imported_Or_Extended_Project_From
1118 (Project
: Project_Id
;
1119 With_Name
: Name_Id
) return Project_Id
1121 List
: Project_List
;
1122 Result
: Project_Id
;
1123 Temp_Result
: Project_Id
;
1126 -- First check if it is the name of an extended project
1128 Result
:= Project
.Extends
;
1129 while Result
/= No_Project
loop
1130 if Result
.Name
= With_Name
then
1133 Result
:= Result
.Extends
;
1137 -- Then check the name of each imported project
1139 Temp_Result
:= No_Project
;
1140 List
:= Project
.Imported_Projects
;
1141 while List
/= null loop
1142 Result
:= List
.Project
;
1144 -- If the project is directly imported, then returns its ID
1146 if Result
.Name
= With_Name
then
1150 -- If a project extending the project is imported, then keep this
1151 -- extending project as a possibility. It will be the returned ID
1152 -- if the project is not imported directly.
1158 Proj
:= Result
.Extends
;
1159 while Proj
/= No_Project
loop
1160 if Proj
.Name
= With_Name
then
1161 Temp_Result
:= Result
;
1165 Proj
:= Proj
.Extends
;
1172 pragma Assert
(Temp_Result
/= No_Project
, "project not found");
1174 end Imported_Or_Extended_Project_From
;
1180 function Package_From
1181 (Project
: Project_Id
;
1182 In_Tree
: Project_Tree_Ref
;
1183 With_Name
: Name_Id
) return Package_Id
1185 Result
: Package_Id
:= Project
.Decl
.Packages
;
1188 -- Check the name of each existing package of Project
1190 while Result
/= No_Package
1191 and then In_Tree
.Packages
.Table
(Result
).Name
/= With_Name
1193 Result
:= In_Tree
.Packages
.Table
(Result
).Next
;
1196 if Result
= No_Package
then
1198 -- Should never happen
1200 Write_Line
("package """ & Get_Name_String
(With_Name
) &
1202 raise Program_Error
;
1214 (In_Tree
: Project_Tree_Ref
;
1215 Project
: out Project_Id
;
1216 Success
: out Boolean;
1217 From_Project_Node
: Project_Node_Id
;
1218 From_Project_Node_Tree
: Project_Node_Tree_Ref
;
1219 Flags
: Processing_Flags
;
1220 Reset_Tree
: Boolean := True)
1223 Process_Project_Tree_Phase_1
1224 (In_Tree
=> In_Tree
,
1227 From_Project_Node
=> From_Project_Node
,
1228 From_Project_Node_Tree
=> From_Project_Node_Tree
,
1230 Reset_Tree
=> Reset_Tree
);
1232 if Project_Qualifier_Of
(From_Project_Node
, From_Project_Node_Tree
) /=
1235 Process_Project_Tree_Phase_2
1236 (In_Tree
=> In_Tree
,
1239 From_Project_Node
=> From_Project_Node
,
1240 From_Project_Node_Tree
=> From_Project_Node_Tree
,
1245 -------------------------------
1246 -- Process_Declarative_Items --
1247 -------------------------------
1249 procedure Process_Declarative_Items
1250 (Project
: Project_Id
;
1251 In_Tree
: Project_Tree_Ref
;
1252 Flags
: Processing_Flags
;
1253 From_Project_Node
: Project_Node_Id
;
1254 From_Project_Node_Tree
: Project_Node_Tree_Ref
;
1256 Item
: Project_Node_Id
)
1258 Current_Declarative_Item
: Project_Node_Id
;
1259 Current_Item
: Project_Node_Id
;
1262 -- Loop through declarative items
1264 Current_Item
:= Empty_Node
;
1266 Current_Declarative_Item
:= Item
;
1267 while Present
(Current_Declarative_Item
) loop
1273 (Current_Declarative_Item
, From_Project_Node_Tree
);
1275 -- And set Current_Declarative_Item to the next declarative item
1276 -- ready for the next iteration.
1278 Current_Declarative_Item
:=
1279 Next_Declarative_Item
1280 (Current_Declarative_Item
, From_Project_Node_Tree
);
1282 case Kind_Of
(Current_Item
, From_Project_Node_Tree
) is
1284 when N_Package_Declaration
=>
1286 -- Do not process a package declaration that should be ignored
1288 if Expression_Kind_Of
1289 (Current_Item
, From_Project_Node_Tree
) /= Ignored
1291 -- Create the new package
1293 Package_Table
.Increment_Last
(In_Tree
.Packages
);
1296 New_Pkg
: constant Package_Id
:=
1297 Package_Table
.Last
(In_Tree
.Packages
);
1298 The_New_Package
: Package_Element
;
1300 Project_Of_Renamed_Package
:
1301 constant Project_Node_Id
:=
1302 Project_Of_Renamed_Package_Of
1303 (Current_Item
, From_Project_Node_Tree
);
1306 -- Set the name of the new package
1308 The_New_Package
.Name
:=
1309 Name_Of
(Current_Item
, From_Project_Node_Tree
);
1311 -- Insert the new package in the appropriate list
1313 if Pkg
/= No_Package
then
1314 The_New_Package
.Next
:=
1315 In_Tree
.Packages
.Table
(Pkg
).Decl
.Packages
;
1316 In_Tree
.Packages
.Table
(Pkg
).Decl
.Packages
:=
1320 The_New_Package
.Next
:= Project
.Decl
.Packages
;
1321 Project
.Decl
.Packages
:= New_Pkg
;
1324 In_Tree
.Packages
.Table
(New_Pkg
) :=
1327 if Present
(Project_Of_Renamed_Package
) then
1332 Project_Name
: constant Name_Id
:=
1334 (Project_Of_Renamed_Package
,
1335 From_Project_Node_Tree
);
1338 constant Project_Id
:=
1339 Imported_Or_Extended_Project_From
1340 (Project
, Project_Name
);
1342 Renamed_Package
: constant Package_Id
:=
1344 (Renamed_Project
, In_Tree
,
1347 From_Project_Node_Tree
));
1350 -- For a renamed package, copy the declarations of
1351 -- the renamed package, but set all the locations
1352 -- to the location of the package name in the
1353 -- renaming declaration.
1355 Copy_Package_Declarations
1357 In_Tree
.Packages
.Table
(Renamed_Package
).Decl
,
1359 In_Tree
.Packages
.Table
(New_Pkg
).Decl
,
1362 (Current_Item
, From_Project_Node_Tree
),
1363 Naming_Restricted
=> False,
1364 In_Tree
=> In_Tree
);
1367 -- Standard package declaration, not renaming
1370 -- Set the default values of the attributes
1375 Name_Id
(Project
.Directory
.Name
),
1377 In_Tree
.Packages
.Table
(New_Pkg
).Decl
,
1380 (Current_Item
, From_Project_Node_Tree
)),
1381 Project_Level
=> False);
1383 -- And process declarative items of the new package
1385 Process_Declarative_Items
1386 (Project
=> Project
,
1389 From_Project_Node
=> From_Project_Node
,
1390 From_Project_Node_Tree
=> From_Project_Node_Tree
,
1393 First_Declarative_Item_Of
1394 (Current_Item
, From_Project_Node_Tree
));
1399 when N_String_Type_Declaration
=>
1401 -- There is nothing to process
1405 when N_Attribute_Declaration |
1406 N_Typed_Variable_Declaration |
1407 N_Variable_Declaration
=>
1409 if Expression_Of
(Current_Item
, From_Project_Node_Tree
) =
1413 -- It must be a full associative array attribute declaration
1416 Current_Item_Name
: constant Name_Id
:=
1419 From_Project_Node_Tree
);
1420 -- The name of the attribute
1422 Current_Location
: constant Source_Ptr
:=
1425 From_Project_Node_Tree
);
1427 New_Array
: Array_Id
;
1428 -- The new associative array created
1430 Orig_Array
: Array_Id
;
1431 -- The associative array value
1433 Orig_Project_Name
: Name_Id
:= No_Name
;
1434 -- The name of the project where the associative array
1437 Orig_Project
: Project_Id
:= No_Project
;
1438 -- The id of the project where the associative array
1441 Orig_Package_Name
: Name_Id
:= No_Name
;
1442 -- The name of the package, if any, where the associative
1445 Orig_Package
: Package_Id
:= No_Package
;
1446 -- The id of the package, if any, where the associative
1449 New_Element
: Array_Element_Id
:= No_Array_Element
;
1450 -- Id of a new array element created
1452 Prev_Element
: Array_Element_Id
:= No_Array_Element
;
1453 -- Last new element id created
1455 Orig_Element
: Array_Element_Id
:= No_Array_Element
;
1456 -- Current array element in original associative array
1458 Next_Element
: Array_Element_Id
:= No_Array_Element
;
1459 -- Id of the array element that follows the new element.
1460 -- This is not always nil, because values for the
1461 -- associative array attribute may already have been
1462 -- declared, and the array elements declared are reused.
1467 -- First find if the associative array attribute already
1468 -- has elements declared.
1470 if Pkg
/= No_Package
then
1471 New_Array
:= In_Tree
.Packages
.Table
1475 New_Array
:= Project
.Decl
.Arrays
;
1478 while New_Array
/= No_Array
1479 and then In_Tree
.Arrays
.Table
(New_Array
).Name
/=
1482 New_Array
:= In_Tree
.Arrays
.Table
(New_Array
).Next
;
1485 -- If the attribute has never been declared add new entry
1486 -- in the arrays of the project/package and link it.
1488 if New_Array
= No_Array
then
1489 Array_Table
.Increment_Last
(In_Tree
.Arrays
);
1490 New_Array
:= Array_Table
.Last
(In_Tree
.Arrays
);
1492 if Pkg
/= No_Package
then
1493 In_Tree
.Arrays
.Table
(New_Array
) :=
1494 (Name
=> Current_Item_Name
,
1495 Location
=> Current_Location
,
1496 Value
=> No_Array_Element
,
1497 Next
=> In_Tree
.Packages
.Table
1500 In_Tree
.Packages
.Table
(Pkg
).Decl
.Arrays
:=
1504 In_Tree
.Arrays
.Table
(New_Array
) :=
1505 (Name
=> Current_Item_Name
,
1506 Location
=> Current_Location
,
1507 Value
=> No_Array_Element
,
1508 Next
=> Project
.Decl
.Arrays
);
1510 Project
.Decl
.Arrays
:= New_Array
;
1514 -- Find the project where the value is declared
1516 Orig_Project_Name
:=
1518 (Associative_Project_Of
1519 (Current_Item
, From_Project_Node_Tree
),
1520 From_Project_Node_Tree
);
1522 Prj
:= In_Tree
.Projects
;
1523 while Prj
/= null loop
1524 if Prj
.Project
.Name
= Orig_Project_Name
then
1525 Orig_Project
:= Prj
.Project
;
1531 pragma Assert
(Orig_Project
/= No_Project
,
1532 "original project not found");
1534 if No
(Associative_Package_Of
1535 (Current_Item
, From_Project_Node_Tree
))
1537 Orig_Array
:= Orig_Project
.Decl
.Arrays
;
1540 -- If in a package, find the package where the value
1543 Orig_Package_Name
:=
1545 (Associative_Package_Of
1546 (Current_Item
, From_Project_Node_Tree
),
1547 From_Project_Node_Tree
);
1549 Orig_Package
:= Orig_Project
.Decl
.Packages
;
1550 pragma Assert
(Orig_Package
/= No_Package
,
1551 "original package not found");
1553 while In_Tree
.Packages
.Table
1554 (Orig_Package
).Name
/= Orig_Package_Name
1556 Orig_Package
:= In_Tree
.Packages
.Table
1557 (Orig_Package
).Next
;
1558 pragma Assert
(Orig_Package
/= No_Package
,
1559 "original package not found");
1563 In_Tree
.Packages
.Table
(Orig_Package
).Decl
.Arrays
;
1566 -- Now look for the array
1568 while Orig_Array
/= No_Array
1569 and then In_Tree
.Arrays
.Table
(Orig_Array
).Name
/=
1572 Orig_Array
:= In_Tree
.Arrays
.Table
1576 if Orig_Array
= No_Array
then
1579 "associative array value not found",
1580 Location_Of
(Current_Item
, From_Project_Node_Tree
),
1585 In_Tree
.Arrays
.Table
(Orig_Array
).Value
;
1587 -- Copy each array element
1589 while Orig_Element
/= No_Array_Element
loop
1591 -- Case of first element
1593 if Prev_Element
= No_Array_Element
then
1595 -- And there is no array element declared yet,
1596 -- create a new first array element.
1598 if In_Tree
.Arrays
.Table
(New_Array
).Value
=
1601 Array_Element_Table
.Increment_Last
1602 (In_Tree
.Array_Elements
);
1603 New_Element
:= Array_Element_Table
.Last
1604 (In_Tree
.Array_Elements
);
1605 In_Tree
.Arrays
.Table
1606 (New_Array
).Value
:= New_Element
;
1607 Next_Element
:= No_Array_Element
;
1609 -- Otherwise, the new element is the first
1612 New_Element
:= In_Tree
.Arrays
.
1613 Table
(New_Array
).Value
;
1615 In_Tree
.Array_Elements
.Table
1619 -- Otherwise, reuse an existing element, or create
1620 -- one if necessary.
1624 In_Tree
.Array_Elements
.Table
1625 (Prev_Element
).Next
;
1627 if Next_Element
= No_Array_Element
then
1628 Array_Element_Table
.Increment_Last
1629 (In_Tree
.Array_Elements
);
1631 Array_Element_Table
.Last
1632 (In_Tree
.Array_Elements
);
1633 In_Tree
.Array_Elements
.Table
1634 (Prev_Element
).Next
:= New_Element
;
1637 New_Element
:= Next_Element
;
1639 In_Tree
.Array_Elements
.Table
1644 -- Copy the value of the element
1646 In_Tree
.Array_Elements
.Table
1648 In_Tree
.Array_Elements
.Table
(Orig_Element
);
1649 In_Tree
.Array_Elements
.Table
1650 (New_Element
).Value
.Project
:= Project
;
1652 -- Adjust the Next link
1654 In_Tree
.Array_Elements
.Table
1655 (New_Element
).Next
:= Next_Element
;
1657 -- Adjust the previous id for the next element
1659 Prev_Element
:= New_Element
;
1661 -- Go to the next element in the original array
1664 In_Tree
.Array_Elements
.Table
1665 (Orig_Element
).Next
;
1668 -- Make sure that the array ends here, in case there
1669 -- previously a greater number of elements.
1671 In_Tree
.Array_Elements
.Table
1672 (New_Element
).Next
:= No_Array_Element
;
1676 -- Declarations other that full associative arrays
1680 New_Value
: constant Variable_Value
:=
1682 (Project
=> Project
,
1685 From_Project_Node
=> From_Project_Node
,
1686 From_Project_Node_Tree
=> From_Project_Node_Tree
,
1691 (Current_Item
, From_Project_Node_Tree
),
1692 From_Project_Node_Tree
),
1695 (Current_Item
, From_Project_Node_Tree
));
1696 -- The expression value
1698 The_Variable
: Variable_Id
:= No_Variable
;
1700 Current_Item_Name
: constant Name_Id
:=
1703 From_Project_Node_Tree
);
1705 Current_Location
: constant Source_Ptr
:=
1708 From_Project_Node_Tree
);
1711 -- Process a typed variable declaration
1713 if Kind_Of
(Current_Item
, From_Project_Node_Tree
) =
1714 N_Typed_Variable_Declaration
1716 -- Report an error for an empty string
1718 if New_Value
.Value
= Empty_String
then
1720 Name_Of
(Current_Item
, From_Project_Node_Tree
);
1723 "no value defined for %%",
1725 (Current_Item
, From_Project_Node_Tree
),
1730 Current_String
: Project_Node_Id
;
1733 -- Loop through all the valid strings for the
1734 -- string type and compare to the string value.
1737 First_Literal_String
1738 (String_Type_Of
(Current_Item
,
1739 From_Project_Node_Tree
),
1740 From_Project_Node_Tree
);
1741 while Present
(Current_String
)
1744 (Current_String
, From_Project_Node_Tree
) /=
1749 (Current_String
, From_Project_Node_Tree
);
1752 -- Report an error if the string value is not
1753 -- one for the string type.
1755 if No
(Current_String
) then
1756 Error_Msg_Name_1
:= New_Value
.Value
;
1759 (Current_Item
, From_Project_Node_Tree
);
1762 "value %% is illegal for typed string %%",
1764 (Current_Item
, From_Project_Node_Tree
),
1773 if Kind_Of
(Current_Item
, From_Project_Node_Tree
) /=
1774 N_Attribute_Declaration
1776 Associative_Array_Index_Of
1777 (Current_Item
, From_Project_Node_Tree
) = No_Name
1779 -- Case of a variable declaration or of a not
1780 -- associative array attribute.
1782 -- First, find the list where to find the variable
1785 if Kind_Of
(Current_Item
, From_Project_Node_Tree
) =
1786 N_Attribute_Declaration
1788 if Pkg
/= No_Package
then
1790 In_Tree
.Packages
.Table
1791 (Pkg
).Decl
.Attributes
;
1793 The_Variable
:= Project
.Decl
.Attributes
;
1797 if Pkg
/= No_Package
then
1799 In_Tree
.Packages
.Table
1800 (Pkg
).Decl
.Variables
;
1802 The_Variable
:= Project
.Decl
.Variables
;
1807 -- Loop through the list, to find if it has already
1810 while The_Variable
/= No_Variable
1812 In_Tree
.Variable_Elements
.Table
1813 (The_Variable
).Name
/= Current_Item_Name
1816 In_Tree
.Variable_Elements
.Table
1817 (The_Variable
).Next
;
1820 -- If it has not been declared, create a new entry
1823 if The_Variable
= No_Variable
then
1825 -- All single string attribute should already have
1826 -- been declared with a default empty string value.
1829 (Kind_Of
(Current_Item
, From_Project_Node_Tree
) /=
1830 N_Attribute_Declaration
,
1831 "illegal attribute declaration for "
1832 & Get_Name_String
(Current_Item_Name
));
1834 Variable_Element_Table
.Increment_Last
1835 (In_Tree
.Variable_Elements
);
1836 The_Variable
:= Variable_Element_Table
.Last
1837 (In_Tree
.Variable_Elements
);
1839 -- Put the new variable in the appropriate list
1841 if Pkg
/= No_Package
then
1842 In_Tree
.Variable_Elements
.Table
(The_Variable
) :=
1844 In_Tree
.Packages
.Table
1845 (Pkg
).Decl
.Variables
,
1846 Name
=> Current_Item_Name
,
1847 Value
=> New_Value
);
1848 In_Tree
.Packages
.Table
1849 (Pkg
).Decl
.Variables
:= The_Variable
;
1852 In_Tree
.Variable_Elements
.Table
(The_Variable
) :=
1853 (Next
=> Project
.Decl
.Variables
,
1854 Name
=> Current_Item_Name
,
1855 Value
=> New_Value
);
1856 Project
.Decl
.Variables
:= The_Variable
;
1859 -- If the variable/attribute has already been
1860 -- declared, just change the value.
1863 In_Tree
.Variable_Elements
.Table
1864 (The_Variable
).Value
:= New_Value
;
1867 -- Associative array attribute
1871 Index_Name
: Name_Id
:=
1872 Associative_Array_Index_Of
1873 (Current_Item
, From_Project_Node_Tree
);
1874 The_Array
: Array_Id
;
1875 The_Array_Element
: Array_Element_Id
:=
1879 if Index_Name
/= All_Other_Names
then
1880 Index_Name
:= Get_Attribute_Index
1881 (From_Project_Node_Tree
,
1883 Associative_Array_Index_Of
1884 (Current_Item
, From_Project_Node_Tree
));
1887 -- Look for the array in the appropriate list
1889 if Pkg
/= No_Package
then
1891 In_Tree
.Packages
.Table
(Pkg
).Decl
.Arrays
;
1894 The_Array
:= Project
.Decl
.Arrays
;
1898 The_Array
/= No_Array
1900 In_Tree
.Arrays
.Table
(The_Array
).Name
/=
1903 The_Array
:= In_Tree
.Arrays
.Table
1907 -- If the array cannot be found, create a new entry
1908 -- in the list. As The_Array_Element is initialized
1909 -- to No_Array_Element, a new element will be
1910 -- created automatically later
1912 if The_Array
= No_Array
then
1913 Array_Table
.Increment_Last
(In_Tree
.Arrays
);
1914 The_Array
:= Array_Table
.Last
(In_Tree
.Arrays
);
1916 if Pkg
/= No_Package
then
1917 In_Tree
.Arrays
.Table
(The_Array
) :=
1918 (Name
=> Current_Item_Name
,
1919 Location
=> Current_Location
,
1920 Value
=> No_Array_Element
,
1921 Next
=> In_Tree
.Packages
.Table
1924 In_Tree
.Packages
.Table
(Pkg
).Decl
.Arrays
:=
1928 In_Tree
.Arrays
.Table
(The_Array
) :=
1929 (Name
=> Current_Item_Name
,
1930 Location
=> Current_Location
,
1931 Value
=> No_Array_Element
,
1932 Next
=> Project
.Decl
.Arrays
);
1934 Project
.Decl
.Arrays
:= The_Array
;
1937 -- Otherwise initialize The_Array_Element as the
1938 -- head of the element list.
1941 The_Array_Element
:=
1942 In_Tree
.Arrays
.Table
(The_Array
).Value
;
1945 -- Look in the list, if any, to find an element
1946 -- with the same index.
1948 while The_Array_Element
/= No_Array_Element
1950 In_Tree
.Array_Elements
.Table
1951 (The_Array_Element
).Index
/= Index_Name
1953 The_Array_Element
:=
1954 In_Tree
.Array_Elements
.Table
1955 (The_Array_Element
).Next
;
1958 -- If no such element were found, create a new one
1959 -- and insert it in the element list, with the
1962 if The_Array_Element
= No_Array_Element
then
1963 Array_Element_Table
.Increment_Last
1964 (In_Tree
.Array_Elements
);
1965 The_Array_Element
:= Array_Element_Table
.Last
1966 (In_Tree
.Array_Elements
);
1968 In_Tree
.Array_Elements
.Table
1969 (The_Array_Element
) :=
1970 (Index
=> Index_Name
,
1973 (Current_Item
, From_Project_Node_Tree
),
1974 Index_Case_Sensitive
=>
1975 not Case_Insensitive
1976 (Current_Item
, From_Project_Node_Tree
),
1978 Next
=> In_Tree
.Arrays
.Table
1980 In_Tree
.Arrays
.Table
1981 (The_Array
).Value
:= The_Array_Element
;
1983 -- An element with the same index already exists,
1984 -- just replace its value with the new one.
1987 In_Tree
.Array_Elements
.Table
1988 (The_Array_Element
).Value
:= New_Value
;
1995 when N_Case_Construction
=>
1997 The_Project
: Project_Id
:= Project
;
1998 -- The id of the project of the case variable
2000 The_Package
: Package_Id
:= Pkg
;
2001 -- The id of the package, if any, of the case variable
2003 The_Variable
: Variable_Value
:= Nil_Variable_Value
;
2004 -- The case variable
2006 Case_Value
: Name_Id
:= No_Name
;
2007 -- The case variable value
2009 Case_Item
: Project_Node_Id
:= Empty_Node
;
2010 Choice_String
: Project_Node_Id
:= Empty_Node
;
2011 Decl_Item
: Project_Node_Id
:= Empty_Node
;
2015 Variable_Node
: constant Project_Node_Id
:=
2016 Case_Variable_Reference_Of
2018 From_Project_Node_Tree
);
2020 Var_Id
: Variable_Id
:= No_Variable
;
2021 Name
: Name_Id
:= No_Name
;
2024 -- If a project was specified for the case variable,
2027 if Present
(Project_Node_Of
2028 (Variable_Node
, From_Project_Node_Tree
))
2033 (Variable_Node
, From_Project_Node_Tree
),
2034 From_Project_Node_Tree
);
2036 Imported_Or_Extended_Project_From
(Project
, Name
);
2039 -- If a package were specified for the case variable,
2042 if Present
(Package_Node_Of
2043 (Variable_Node
, From_Project_Node_Tree
))
2048 (Variable_Node
, From_Project_Node_Tree
),
2049 From_Project_Node_Tree
);
2051 Package_From
(The_Project
, In_Tree
, Name
);
2054 Name
:= Name_Of
(Variable_Node
, From_Project_Node_Tree
);
2056 -- First, look for the case variable into the package,
2059 if The_Package
/= No_Package
then
2060 Var_Id
:= In_Tree
.Packages
.Table
2061 (The_Package
).Decl
.Variables
;
2063 Name_Of
(Variable_Node
, From_Project_Node_Tree
);
2064 while Var_Id
/= No_Variable
2066 In_Tree
.Variable_Elements
.Table
2067 (Var_Id
).Name
/= Name
2069 Var_Id
:= In_Tree
.Variable_Elements
.
2070 Table
(Var_Id
).Next
;
2074 -- If not found in the package, or if there is no
2075 -- package, look at the project level.
2077 if Var_Id
= No_Variable
2080 (Variable_Node
, From_Project_Node_Tree
))
2082 Var_Id
:= The_Project
.Decl
.Variables
;
2083 while Var_Id
/= No_Variable
2085 In_Tree
.Variable_Elements
.Table
2086 (Var_Id
).Name
/= Name
2088 Var_Id
:= In_Tree
.Variable_Elements
.
2089 Table
(Var_Id
).Next
;
2093 if Var_Id
= No_Variable
then
2095 -- Should never happen, because this has already been
2096 -- checked during parsing.
2098 Write_Line
("variable """ &
2099 Get_Name_String
(Name
) &
2101 raise Program_Error
;
2104 -- Get the case variable
2106 The_Variable
:= In_Tree
.Variable_Elements
.
2107 Table
(Var_Id
).Value
;
2109 if The_Variable
.Kind
/= Single
then
2111 -- Should never happen, because this has already been
2112 -- checked during parsing.
2114 Write_Line
("variable""" &
2115 Get_Name_String
(Name
) &
2116 """ is not a single string variable");
2117 raise Program_Error
;
2120 -- Get the case variable value
2121 Case_Value
:= The_Variable
.Value
;
2124 -- Now look into all the case items of the case construction
2127 First_Case_Item_Of
(Current_Item
, From_Project_Node_Tree
);
2129 while Present
(Case_Item
) loop
2131 First_Choice_Of
(Case_Item
, From_Project_Node_Tree
);
2133 -- When Choice_String is nil, it means that it is
2134 -- the "when others =>" alternative.
2136 if No
(Choice_String
) then
2138 First_Declarative_Item_Of
2139 (Case_Item
, From_Project_Node_Tree
);
2140 exit Case_Item_Loop
;
2143 -- Look into all the alternative of this case item
2146 while Present
(Choice_String
) loop
2149 (Choice_String
, From_Project_Node_Tree
)
2152 First_Declarative_Item_Of
2153 (Case_Item
, From_Project_Node_Tree
);
2154 exit Case_Item_Loop
;
2159 (Choice_String
, From_Project_Node_Tree
);
2160 end loop Choice_Loop
;
2163 Next_Case_Item
(Case_Item
, From_Project_Node_Tree
);
2164 end loop Case_Item_Loop
;
2166 -- If there is an alternative, then we process it
2168 if Present
(Decl_Item
) then
2169 Process_Declarative_Items
2170 (Project
=> Project
,
2173 From_Project_Node
=> From_Project_Node
,
2174 From_Project_Node_Tree
=> From_Project_Node_Tree
,
2182 -- Should never happen
2184 Write_Line
("Illegal declarative item: " &
2185 Project_Node_Kind
'Image
2187 (Current_Item
, From_Project_Node_Tree
)));
2188 raise Program_Error
;
2191 end Process_Declarative_Items
;
2193 ----------------------------------
2194 -- Process_Project_Tree_Phase_1 --
2195 ----------------------------------
2197 procedure Process_Project_Tree_Phase_1
2198 (In_Tree
: Project_Tree_Ref
;
2199 Project
: out Project_Id
;
2200 Success
: out Boolean;
2201 From_Project_Node
: Project_Node_Id
;
2202 From_Project_Node_Tree
: Project_Node_Tree_Ref
;
2203 Flags
: Processing_Flags
;
2204 Reset_Tree
: Boolean := True)
2209 -- Make sure there are no projects in the data structure
2211 Free_List
(In_Tree
.Projects
, Free_Project
=> True);
2214 Processed_Projects
.Reset
;
2216 -- And process the main project and all of the projects it depends on,
2220 (Project
=> Project
,
2223 From_Project_Node
=> From_Project_Node
,
2224 From_Project_Node_Tree
=> From_Project_Node_Tree
,
2225 Extended_By
=> No_Project
);
2228 Total_Errors_Detected
= 0
2230 (Warning_Mode
/= Treat_As_Error
or else Warnings_Detected
= 0);
2231 end Process_Project_Tree_Phase_1
;
2233 ----------------------------------
2234 -- Process_Project_Tree_Phase_2 --
2235 ----------------------------------
2237 procedure Process_Project_Tree_Phase_2
2238 (In_Tree
: Project_Tree_Ref
;
2239 Project
: Project_Id
;
2240 Success
: out Boolean;
2241 From_Project_Node
: Project_Node_Id
;
2242 From_Project_Node_Tree
: Project_Node_Tree_Ref
;
2243 Flags
: Processing_Flags
)
2245 Obj_Dir
: Path_Name_Type
;
2246 Extending
: Project_Id
;
2247 Extending2
: Project_Id
;
2250 -- Start of processing for Process_Project_Tree_Phase_2
2255 if Project
/= No_Project
then
2256 Check
(In_Tree
, Project
, Flags
);
2259 -- If main project is an extending all project, set object directory of
2260 -- all virtual extending projects to object directory of main project.
2262 if Project
/= No_Project
2264 Is_Extending_All
(From_Project_Node
, From_Project_Node_Tree
)
2267 Object_Dir
: constant Path_Name_Type
:=
2268 Project
.Object_Directory
.Name
;
2270 Prj
:= In_Tree
.Projects
;
2271 while Prj
/= null loop
2272 if Prj
.Project
.Virtual
then
2273 Prj
.Project
.Object_Directory
.Name
:= Object_Dir
;
2280 -- Check that no extending project shares its object directory with
2281 -- the project(s) it extends.
2283 if Project
/= No_Project
then
2284 Prj
:= In_Tree
.Projects
;
2285 while Prj
/= null loop
2286 Extending
:= Prj
.Project
.Extended_By
;
2288 if Extending
/= No_Project
then
2289 Obj_Dir
:= Prj
.Project
.Object_Directory
.Name
;
2291 -- Check that a project being extended does not share its
2292 -- object directory with any project that extends it, directly
2293 -- or indirectly, including a virtual extending project.
2295 -- Start with the project directly extending it
2297 Extending2
:= Extending
;
2298 while Extending2
/= No_Project
loop
2299 if Has_Ada_Sources
(Extending2
)
2300 and then Extending2
.Object_Directory
.Name
= Obj_Dir
2302 if Extending2
.Virtual
then
2303 Error_Msg_Name_1
:= Prj
.Project
.Display_Name
;
2306 "project %% cannot be extended by a virtual" &
2307 " project with the same object directory",
2308 Prj
.Project
.Location
, Project
);
2311 Error_Msg_Name_1
:= Extending2
.Display_Name
;
2312 Error_Msg_Name_2
:= Prj
.Project
.Display_Name
;
2315 "project %% cannot extend project %%",
2316 Extending2
.Location
, Project
);
2319 "\they share the same object directory",
2320 Extending2
.Location
, Project
);
2324 -- Continue with the next extending project, if any
2326 Extending2
:= Extending2
.Extended_By
;
2335 Total_Errors_Detected
= 0
2337 (Warning_Mode
/= Treat_As_Error
or else Warnings_Detected
= 0);
2338 end Process_Project_Tree_Phase_2
;
2340 -----------------------
2341 -- Recursive_Process --
2342 -----------------------
2344 procedure Recursive_Process
2345 (In_Tree
: Project_Tree_Ref
;
2346 Project
: out Project_Id
;
2347 Flags
: Processing_Flags
;
2348 From_Project_Node
: Project_Node_Id
;
2349 From_Project_Node_Tree
: Project_Node_Tree_Ref
;
2350 Extended_By
: Project_Id
)
2352 procedure Process_Imported_Projects
2353 (Imported
: in out Project_List
;
2354 Limited_With
: Boolean);
2355 -- Process imported projects. If Limited_With is True, then only
2356 -- projects processed through a "limited with" are processed, otherwise
2357 -- only projects imported through a standard "with" are processed.
2358 -- Imported is the id of the last imported project.
2360 -------------------------------
2361 -- Process_Imported_Projects --
2362 -------------------------------
2364 procedure Process_Imported_Projects
2365 (Imported
: in out Project_List
;
2366 Limited_With
: Boolean)
2368 With_Clause
: Project_Node_Id
;
2369 New_Project
: Project_Id
;
2370 Proj_Node
: Project_Node_Id
;
2374 First_With_Clause_Of
2375 (From_Project_Node
, From_Project_Node_Tree
);
2376 while Present
(With_Clause
) loop
2378 Non_Limited_Project_Node_Of
2379 (With_Clause
, From_Project_Node_Tree
);
2380 New_Project
:= No_Project
;
2382 if (Limited_With
and then No
(Proj_Node
))
2383 or else (not Limited_With
and then Present
(Proj_Node
))
2386 (In_Tree
=> In_Tree
,
2387 Project
=> New_Project
,
2389 From_Project_Node
=>
2391 (With_Clause
, From_Project_Node_Tree
),
2392 From_Project_Node_Tree
=> From_Project_Node_Tree
,
2393 Extended_By
=> No_Project
);
2395 -- Imported is the id of the last imported project. If
2396 -- it is nil, then this imported project is our first.
2398 if Imported
= null then
2399 Project
.Imported_Projects
:=
2400 new Project_List_Element
'
2401 (Project => New_Project,
2403 Imported := Project.Imported_Projects;
2405 Imported.Next := new Project_List_Element'
2406 (Project
=> New_Project
,
2408 Imported
:= Imported
.Next
;
2413 Next_With_Clause_Of
(With_Clause
, From_Project_Node_Tree
);
2415 end Process_Imported_Projects
;
2417 -- Start of processing for Recursive_Process
2420 if No
(From_Project_Node
) then
2421 Project
:= No_Project
;
2425 Imported
: Project_List
;
2426 Declaration_Node
: Project_Node_Id
:= Empty_Node
;
2428 Name
: constant Name_Id
:=
2429 Name_Of
(From_Project_Node
, From_Project_Node_Tree
);
2431 Name_Node
: constant Tree_Private_Part
.Project_Name_And_Node
:=
2432 Tree_Private_Part
.Projects_Htable
.Get
2433 (From_Project_Node_Tree
.Projects_HT
, Name
);
2436 Project
:= Processed_Projects
.Get
(Name
);
2438 if Project
/= No_Project
then
2440 -- Make sure that, when a project is extended, the project id
2441 -- of the project extending it is recorded in its data, even
2442 -- when it has already been processed as an imported project.
2443 -- This is for virtually extended projects.
2445 if Extended_By
/= No_Project
then
2446 Project
.Extended_By
:= Extended_By
;
2452 Project
:= new Project_Data
'(Empty_Project);
2453 In_Tree.Projects := new Project_List_Element'
2454 (Project
=> Project
,
2455 Next
=> In_Tree
.Projects
);
2457 Processed_Projects
.Set
(Name
, Project
);
2459 Project
.Name
:= Name
;
2460 Project
.Display_Name
:= Name_Node
.Display_Name
;
2461 Project
.Qualifier
:=
2462 Project_Qualifier_Of
(From_Project_Node
, From_Project_Node_Tree
);
2464 Get_Name_String
(Name
);
2466 -- If name starts with the virtual prefix, flag the project as
2467 -- being a virtual extending project.
2469 if Name_Len
> Virtual_Prefix
'Length
2470 and then Name_Buffer
(1 .. Virtual_Prefix
'Length) =
2473 Project
.Virtual
:= True;
2477 Project
.Path
.Display_Name
:=
2478 Path_Name_Of
(From_Project_Node
, From_Project_Node_Tree
);
2479 Get_Name_String
(Project
.Path
.Display_Name
);
2480 Canonical_Case_File_Name
(Name_Buffer
(1 .. Name_Len
));
2481 Project
.Path
.Name
:= Name_Find
;
2484 Location_Of
(From_Project_Node
, From_Project_Node_Tree
);
2486 Project
.Directory
.Display_Name
:=
2487 Directory_Of
(From_Project_Node
, From_Project_Node_Tree
);
2488 Get_Name_String
(Project
.Directory
.Display_Name
);
2489 Canonical_Case_File_Name
(Name_Buffer
(1 .. Name_Len
));
2490 Project
.Directory
.Name
:= Name_Find
;
2492 Project
.Extended_By
:= Extended_By
;
2497 Name_Id
(Project
.Directory
.Name
),
2500 Prj
.Attr
.Attribute_First
,
2501 Project_Level
=> True);
2503 Process_Imported_Projects
(Imported
, Limited_With
=> False);
2506 Project_Declaration_Of
2507 (From_Project_Node
, From_Project_Node_Tree
);
2510 (In_Tree
=> In_Tree
,
2511 Project
=> Project
.Extends
,
2513 From_Project_Node
=> Extended_Project_Of
2515 From_Project_Node_Tree
),
2516 From_Project_Node_Tree
=> From_Project_Node_Tree
,
2517 Extended_By
=> Project
);
2519 Process_Declarative_Items
2520 (Project
=> Project
,
2523 From_Project_Node
=> From_Project_Node
,
2524 From_Project_Node_Tree
=> From_Project_Node_Tree
,
2526 Item
=> First_Declarative_Item_Of
2528 From_Project_Node_Tree
));
2530 -- If it is an extending project, inherit all packages
2531 -- from the extended project that are not explicitly defined
2532 -- or renamed. Also inherit the languages, if attribute Languages
2533 -- is not explicitly defined.
2535 if Project
.Extends
/= No_Project
then
2537 Extended_Pkg
: Package_Id
;
2538 Current_Pkg
: Package_Id
;
2539 Element
: Package_Element
;
2540 First
: constant Package_Id
:=
2541 Project
.Decl
.Packages
;
2542 Attribute1
: Variable_Id
;
2543 Attribute2
: Variable_Id
;
2544 Attr_Value1
: Variable
;
2545 Attr_Value2
: Variable
;
2548 Extended_Pkg
:= Project
.Extends
.Decl
.Packages
;
2549 while Extended_Pkg
/= No_Package
loop
2550 Element
:= In_Tree
.Packages
.Table
(Extended_Pkg
);
2552 Current_Pkg
:= First
;
2553 while Current_Pkg
/= No_Package
2554 and then In_Tree
.Packages
.Table
(Current_Pkg
).Name
/=
2558 In_Tree
.Packages
.Table
(Current_Pkg
).Next
;
2561 if Current_Pkg
= No_Package
then
2562 Package_Table
.Increment_Last
2564 Current_Pkg
:= Package_Table
.Last
(In_Tree
.Packages
);
2565 In_Tree
.Packages
.Table
(Current_Pkg
) :=
2566 (Name
=> Element
.Name
,
2567 Decl
=> No_Declarations
,
2568 Parent
=> No_Package
,
2569 Next
=> Project
.Decl
.Packages
);
2570 Project
.Decl
.Packages
:= Current_Pkg
;
2571 Copy_Package_Declarations
2572 (From
=> Element
.Decl
,
2574 In_Tree
.Packages
.Table
(Current_Pkg
).Decl
,
2575 New_Loc
=> No_Location
,
2576 Naming_Restricted
=>
2577 Element
.Name
= Snames
.Name_Naming
,
2578 In_Tree
=> In_Tree
);
2581 Extended_Pkg
:= Element
.Next
;
2584 -- Check if attribute Languages is declared in the
2585 -- extending project.
2587 Attribute1
:= Project
.Decl
.Attributes
;
2588 while Attribute1
/= No_Variable
loop
2589 Attr_Value1
:= In_Tree
.Variable_Elements
.
2591 exit when Attr_Value1
.Name
= Snames
.Name_Languages
;
2592 Attribute1
:= Attr_Value1
.Next
;
2595 if Attribute1
= No_Variable
or else
2596 Attr_Value1
.Value
.Default
2598 -- Attribute Languages is not declared in the extending
2599 -- project. Check if it is declared in the project being
2602 Attribute2
:= Project
.Extends
.Decl
.Attributes
;
2603 while Attribute2
/= No_Variable
loop
2604 Attr_Value2
:= In_Tree
.Variable_Elements
.
2606 exit when Attr_Value2
.Name
= Snames
.Name_Languages
;
2607 Attribute2
:= Attr_Value2
.Next
;
2610 if Attribute2
/= No_Variable
and then
2611 not Attr_Value2
.Value
.Default
2613 -- As attribute Languages is declared in the project
2614 -- being extended, copy its value for the extending
2617 if Attribute1
= No_Variable
then
2618 Variable_Element_Table
.Increment_Last
2619 (In_Tree
.Variable_Elements
);
2620 Attribute1
:= Variable_Element_Table
.Last
2621 (In_Tree
.Variable_Elements
);
2622 Attr_Value1
.Next
:= Project
.Decl
.Attributes
;
2623 Project
.Decl
.Attributes
:= Attribute1
;
2626 Attr_Value1
.Name
:= Snames
.Name_Languages
;
2627 Attr_Value1
.Value
:= Attr_Value2
.Value
;
2628 In_Tree
.Variable_Elements
.Table
2629 (Attribute1
) := Attr_Value1
;
2635 Process_Imported_Projects
(Imported
, Limited_With
=> True);
2638 end Recursive_Process
;