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
1874 From_Project_Node_Tree
);
1876 Source_Index
: constant Int
:=
1879 From_Project_Node_Tree
);
1881 The_Array
: Array_Id
;
1882 The_Array_Element
: Array_Element_Id
:=
1886 if Index_Name
/= All_Other_Names
then
1887 Index_Name
:= Get_Attribute_Index
1888 (From_Project_Node_Tree
,
1890 Associative_Array_Index_Of
1891 (Current_Item
, From_Project_Node_Tree
));
1894 -- Look for the array in the appropriate list
1896 if Pkg
/= No_Package
then
1898 In_Tree
.Packages
.Table
(Pkg
).Decl
.Arrays
;
1901 Project
.Decl
.Arrays
;
1905 The_Array
/= No_Array
1907 In_Tree
.Arrays
.Table
(The_Array
).Name
/=
1911 In_Tree
.Arrays
.Table
(The_Array
).Next
;
1914 -- If the array cannot be found, create a new entry
1915 -- in the list. As The_Array_Element is initialized
1916 -- to No_Array_Element, a new element will be
1917 -- created automatically later
1919 if The_Array
= No_Array
then
1920 Array_Table
.Increment_Last
(In_Tree
.Arrays
);
1921 The_Array
:= Array_Table
.Last
(In_Tree
.Arrays
);
1923 if Pkg
/= No_Package
then
1924 In_Tree
.Arrays
.Table
(The_Array
) :=
1925 (Name
=> Current_Item_Name
,
1926 Location
=> Current_Location
,
1927 Value
=> No_Array_Element
,
1928 Next
=> In_Tree
.Packages
.Table
1931 In_Tree
.Packages
.Table
(Pkg
).Decl
.Arrays
:=
1935 In_Tree
.Arrays
.Table
(The_Array
) :=
1936 (Name
=> Current_Item_Name
,
1937 Location
=> Current_Location
,
1938 Value
=> No_Array_Element
,
1939 Next
=> Project
.Decl
.Arrays
);
1941 Project
.Decl
.Arrays
:= The_Array
;
1944 -- Otherwise initialize The_Array_Element as the
1945 -- head of the element list.
1948 The_Array_Element
:=
1949 In_Tree
.Arrays
.Table
(The_Array
).Value
;
1952 -- Look in the list, if any, to find an element
1953 -- with the same index and same source index.
1955 while The_Array_Element
/= No_Array_Element
1957 (In_Tree
.Array_Elements
.Table
1958 (The_Array_Element
).Index
/= Index_Name
1960 In_Tree
.Array_Elements
.Table
1961 (The_Array_Element
).Src_Index
/= Source_Index
)
1963 The_Array_Element
:=
1964 In_Tree
.Array_Elements
.Table
1965 (The_Array_Element
).Next
;
1968 -- If no such element were found, create a new one
1969 -- and insert it in the element list, with the
1972 if The_Array_Element
= No_Array_Element
then
1973 Array_Element_Table
.Increment_Last
1974 (In_Tree
.Array_Elements
);
1975 The_Array_Element
:=
1976 Array_Element_Table
.Last
1977 (In_Tree
.Array_Elements
);
1979 In_Tree
.Array_Elements
.Table
1980 (The_Array_Element
) :=
1981 (Index
=> Index_Name
,
1982 Src_Index
=> Source_Index
,
1983 Index_Case_Sensitive
=>
1984 not Case_Insensitive
1985 (Current_Item
, From_Project_Node_Tree
),
1988 In_Tree
.Arrays
.Table
(The_Array
).Value
);
1990 In_Tree
.Arrays
.Table
(The_Array
).Value
:=
1993 -- An element with the same index already exists,
1994 -- just replace its value with the new one.
1997 In_Tree
.Array_Elements
.Table
1998 (The_Array_Element
).Value
:= New_Value
;
2005 when N_Case_Construction
=>
2007 The_Project
: Project_Id
:= Project
;
2008 -- The id of the project of the case variable
2010 The_Package
: Package_Id
:= Pkg
;
2011 -- The id of the package, if any, of the case variable
2013 The_Variable
: Variable_Value
:= Nil_Variable_Value
;
2014 -- The case variable
2016 Case_Value
: Name_Id
:= No_Name
;
2017 -- The case variable value
2019 Case_Item
: Project_Node_Id
:= Empty_Node
;
2020 Choice_String
: Project_Node_Id
:= Empty_Node
;
2021 Decl_Item
: Project_Node_Id
:= Empty_Node
;
2025 Variable_Node
: constant Project_Node_Id
:=
2026 Case_Variable_Reference_Of
2028 From_Project_Node_Tree
);
2030 Var_Id
: Variable_Id
:= No_Variable
;
2031 Name
: Name_Id
:= No_Name
;
2034 -- If a project was specified for the case variable,
2037 if Present
(Project_Node_Of
2038 (Variable_Node
, From_Project_Node_Tree
))
2043 (Variable_Node
, From_Project_Node_Tree
),
2044 From_Project_Node_Tree
);
2046 Imported_Or_Extended_Project_From
(Project
, Name
);
2049 -- If a package were specified for the case variable,
2052 if Present
(Package_Node_Of
2053 (Variable_Node
, From_Project_Node_Tree
))
2058 (Variable_Node
, From_Project_Node_Tree
),
2059 From_Project_Node_Tree
);
2061 Package_From
(The_Project
, In_Tree
, Name
);
2064 Name
:= Name_Of
(Variable_Node
, From_Project_Node_Tree
);
2066 -- First, look for the case variable into the package,
2069 if The_Package
/= No_Package
then
2070 Var_Id
:= In_Tree
.Packages
.Table
2071 (The_Package
).Decl
.Variables
;
2073 Name_Of
(Variable_Node
, From_Project_Node_Tree
);
2074 while Var_Id
/= No_Variable
2076 In_Tree
.Variable_Elements
.Table
2077 (Var_Id
).Name
/= Name
2079 Var_Id
:= In_Tree
.Variable_Elements
.
2080 Table
(Var_Id
).Next
;
2084 -- If not found in the package, or if there is no
2085 -- package, look at the project level.
2087 if Var_Id
= No_Variable
2090 (Variable_Node
, From_Project_Node_Tree
))
2092 Var_Id
:= The_Project
.Decl
.Variables
;
2093 while Var_Id
/= No_Variable
2095 In_Tree
.Variable_Elements
.Table
2096 (Var_Id
).Name
/= Name
2098 Var_Id
:= In_Tree
.Variable_Elements
.
2099 Table
(Var_Id
).Next
;
2103 if Var_Id
= No_Variable
then
2105 -- Should never happen, because this has already been
2106 -- checked during parsing.
2108 Write_Line
("variable """ &
2109 Get_Name_String
(Name
) &
2111 raise Program_Error
;
2114 -- Get the case variable
2116 The_Variable
:= In_Tree
.Variable_Elements
.
2117 Table
(Var_Id
).Value
;
2119 if The_Variable
.Kind
/= Single
then
2121 -- Should never happen, because this has already been
2122 -- checked during parsing.
2124 Write_Line
("variable""" &
2125 Get_Name_String
(Name
) &
2126 """ is not a single string variable");
2127 raise Program_Error
;
2130 -- Get the case variable value
2131 Case_Value
:= The_Variable
.Value
;
2134 -- Now look into all the case items of the case construction
2137 First_Case_Item_Of
(Current_Item
, From_Project_Node_Tree
);
2139 while Present
(Case_Item
) loop
2141 First_Choice_Of
(Case_Item
, From_Project_Node_Tree
);
2143 -- When Choice_String is nil, it means that it is
2144 -- the "when others =>" alternative.
2146 if No
(Choice_String
) then
2148 First_Declarative_Item_Of
2149 (Case_Item
, From_Project_Node_Tree
);
2150 exit Case_Item_Loop
;
2153 -- Look into all the alternative of this case item
2156 while Present
(Choice_String
) loop
2159 (Choice_String
, From_Project_Node_Tree
)
2162 First_Declarative_Item_Of
2163 (Case_Item
, From_Project_Node_Tree
);
2164 exit Case_Item_Loop
;
2169 (Choice_String
, From_Project_Node_Tree
);
2170 end loop Choice_Loop
;
2173 Next_Case_Item
(Case_Item
, From_Project_Node_Tree
);
2174 end loop Case_Item_Loop
;
2176 -- If there is an alternative, then we process it
2178 if Present
(Decl_Item
) then
2179 Process_Declarative_Items
2180 (Project
=> Project
,
2183 From_Project_Node
=> From_Project_Node
,
2184 From_Project_Node_Tree
=> From_Project_Node_Tree
,
2192 -- Should never happen
2194 Write_Line
("Illegal declarative item: " &
2195 Project_Node_Kind
'Image
2197 (Current_Item
, From_Project_Node_Tree
)));
2198 raise Program_Error
;
2201 end Process_Declarative_Items
;
2203 ----------------------------------
2204 -- Process_Project_Tree_Phase_1 --
2205 ----------------------------------
2207 procedure Process_Project_Tree_Phase_1
2208 (In_Tree
: Project_Tree_Ref
;
2209 Project
: out Project_Id
;
2210 Success
: out Boolean;
2211 From_Project_Node
: Project_Node_Id
;
2212 From_Project_Node_Tree
: Project_Node_Tree_Ref
;
2213 Flags
: Processing_Flags
;
2214 Reset_Tree
: Boolean := True)
2219 -- Make sure there are no projects in the data structure
2221 Free_List
(In_Tree
.Projects
, Free_Project
=> True);
2224 Processed_Projects
.Reset
;
2226 -- And process the main project and all of the projects it depends on,
2230 (Project
=> Project
,
2233 From_Project_Node
=> From_Project_Node
,
2234 From_Project_Node_Tree
=> From_Project_Node_Tree
,
2235 Extended_By
=> No_Project
);
2238 Total_Errors_Detected
= 0
2240 (Warning_Mode
/= Treat_As_Error
or else Warnings_Detected
= 0);
2241 end Process_Project_Tree_Phase_1
;
2243 ----------------------------------
2244 -- Process_Project_Tree_Phase_2 --
2245 ----------------------------------
2247 procedure Process_Project_Tree_Phase_2
2248 (In_Tree
: Project_Tree_Ref
;
2249 Project
: Project_Id
;
2250 Success
: out Boolean;
2251 From_Project_Node
: Project_Node_Id
;
2252 From_Project_Node_Tree
: Project_Node_Tree_Ref
;
2253 Flags
: Processing_Flags
)
2255 Obj_Dir
: Path_Name_Type
;
2256 Extending
: Project_Id
;
2257 Extending2
: Project_Id
;
2260 -- Start of processing for Process_Project_Tree_Phase_2
2265 if Project
/= No_Project
then
2266 Check
(In_Tree
, Project
, Flags
);
2269 -- If main project is an extending all project, set object directory of
2270 -- all virtual extending projects to object directory of main project.
2272 if Project
/= No_Project
2274 Is_Extending_All
(From_Project_Node
, From_Project_Node_Tree
)
2277 Object_Dir
: constant Path_Name_Type
:=
2278 Project
.Object_Directory
.Name
;
2280 Prj
:= In_Tree
.Projects
;
2281 while Prj
/= null loop
2282 if Prj
.Project
.Virtual
then
2283 Prj
.Project
.Object_Directory
.Name
:= Object_Dir
;
2290 -- Check that no extending project shares its object directory with
2291 -- the project(s) it extends.
2293 if Project
/= No_Project
then
2294 Prj
:= In_Tree
.Projects
;
2295 while Prj
/= null loop
2296 Extending
:= Prj
.Project
.Extended_By
;
2298 if Extending
/= No_Project
then
2299 Obj_Dir
:= Prj
.Project
.Object_Directory
.Name
;
2301 -- Check that a project being extended does not share its
2302 -- object directory with any project that extends it, directly
2303 -- or indirectly, including a virtual extending project.
2305 -- Start with the project directly extending it
2307 Extending2
:= Extending
;
2308 while Extending2
/= No_Project
loop
2309 if Has_Ada_Sources
(Extending2
)
2310 and then Extending2
.Object_Directory
.Name
= Obj_Dir
2312 if Extending2
.Virtual
then
2313 Error_Msg_Name_1
:= Prj
.Project
.Display_Name
;
2316 "project %% cannot be extended by a virtual" &
2317 " project with the same object directory",
2318 Prj
.Project
.Location
, Project
);
2321 Error_Msg_Name_1
:= Extending2
.Display_Name
;
2322 Error_Msg_Name_2
:= Prj
.Project
.Display_Name
;
2325 "project %% cannot extend project %%",
2326 Extending2
.Location
, Project
);
2329 "\they share the same object directory",
2330 Extending2
.Location
, Project
);
2334 -- Continue with the next extending project, if any
2336 Extending2
:= Extending2
.Extended_By
;
2345 Total_Errors_Detected
= 0
2347 (Warning_Mode
/= Treat_As_Error
or else Warnings_Detected
= 0);
2348 end Process_Project_Tree_Phase_2
;
2350 -----------------------
2351 -- Recursive_Process --
2352 -----------------------
2354 procedure Recursive_Process
2355 (In_Tree
: Project_Tree_Ref
;
2356 Project
: out Project_Id
;
2357 Flags
: Processing_Flags
;
2358 From_Project_Node
: Project_Node_Id
;
2359 From_Project_Node_Tree
: Project_Node_Tree_Ref
;
2360 Extended_By
: Project_Id
)
2362 procedure Process_Imported_Projects
2363 (Imported
: in out Project_List
;
2364 Limited_With
: Boolean);
2365 -- Process imported projects. If Limited_With is True, then only
2366 -- projects processed through a "limited with" are processed, otherwise
2367 -- only projects imported through a standard "with" are processed.
2368 -- Imported is the id of the last imported project.
2370 -------------------------------
2371 -- Process_Imported_Projects --
2372 -------------------------------
2374 procedure Process_Imported_Projects
2375 (Imported
: in out Project_List
;
2376 Limited_With
: Boolean)
2378 With_Clause
: Project_Node_Id
;
2379 New_Project
: Project_Id
;
2380 Proj_Node
: Project_Node_Id
;
2384 First_With_Clause_Of
2385 (From_Project_Node
, From_Project_Node_Tree
);
2386 while Present
(With_Clause
) loop
2388 Non_Limited_Project_Node_Of
2389 (With_Clause
, From_Project_Node_Tree
);
2390 New_Project
:= No_Project
;
2392 if (Limited_With
and then No
(Proj_Node
))
2393 or else (not Limited_With
and then Present
(Proj_Node
))
2396 (In_Tree
=> In_Tree
,
2397 Project
=> New_Project
,
2399 From_Project_Node
=>
2401 (With_Clause
, From_Project_Node_Tree
),
2402 From_Project_Node_Tree
=> From_Project_Node_Tree
,
2403 Extended_By
=> No_Project
);
2405 -- Imported is the id of the last imported project. If
2406 -- it is nil, then this imported project is our first.
2408 if Imported
= null then
2409 Project
.Imported_Projects
:=
2410 new Project_List_Element
'
2411 (Project => New_Project,
2413 Imported := Project.Imported_Projects;
2415 Imported.Next := new Project_List_Element'
2416 (Project
=> New_Project
,
2418 Imported
:= Imported
.Next
;
2423 Next_With_Clause_Of
(With_Clause
, From_Project_Node_Tree
);
2425 end Process_Imported_Projects
;
2427 -- Start of processing for Recursive_Process
2430 if No
(From_Project_Node
) then
2431 Project
:= No_Project
;
2435 Imported
: Project_List
;
2436 Declaration_Node
: Project_Node_Id
:= Empty_Node
;
2438 Name
: constant Name_Id
:=
2439 Name_Of
(From_Project_Node
, From_Project_Node_Tree
);
2441 Name_Node
: constant Tree_Private_Part
.Project_Name_And_Node
:=
2442 Tree_Private_Part
.Projects_Htable
.Get
2443 (From_Project_Node_Tree
.Projects_HT
, Name
);
2446 Project
:= Processed_Projects
.Get
(Name
);
2448 if Project
/= No_Project
then
2450 -- Make sure that, when a project is extended, the project id
2451 -- of the project extending it is recorded in its data, even
2452 -- when it has already been processed as an imported project.
2453 -- This is for virtually extended projects.
2455 if Extended_By
/= No_Project
then
2456 Project
.Extended_By
:= Extended_By
;
2462 Project
:= new Project_Data
'(Empty_Project);
2463 In_Tree.Projects := new Project_List_Element'
2464 (Project
=> Project
,
2465 Next
=> In_Tree
.Projects
);
2467 Processed_Projects
.Set
(Name
, Project
);
2469 Project
.Name
:= Name
;
2470 Project
.Display_Name
:= Name_Node
.Display_Name
;
2471 Project
.Qualifier
:=
2472 Project_Qualifier_Of
(From_Project_Node
, From_Project_Node_Tree
);
2474 Get_Name_String
(Name
);
2476 -- If name starts with the virtual prefix, flag the project as
2477 -- being a virtual extending project.
2479 if Name_Len
> Virtual_Prefix
'Length
2480 and then Name_Buffer
(1 .. Virtual_Prefix
'Length) =
2483 Project
.Virtual
:= True;
2487 Project
.Path
.Display_Name
:=
2488 Path_Name_Of
(From_Project_Node
, From_Project_Node_Tree
);
2489 Get_Name_String
(Project
.Path
.Display_Name
);
2490 Canonical_Case_File_Name
(Name_Buffer
(1 .. Name_Len
));
2491 Project
.Path
.Name
:= Name_Find
;
2494 Location_Of
(From_Project_Node
, From_Project_Node_Tree
);
2496 Project
.Directory
.Display_Name
:=
2497 Directory_Of
(From_Project_Node
, From_Project_Node_Tree
);
2498 Get_Name_String
(Project
.Directory
.Display_Name
);
2499 Canonical_Case_File_Name
(Name_Buffer
(1 .. Name_Len
));
2500 Project
.Directory
.Name
:= Name_Find
;
2502 Project
.Extended_By
:= Extended_By
;
2507 Name_Id
(Project
.Directory
.Name
),
2510 Prj
.Attr
.Attribute_First
,
2511 Project_Level
=> True);
2513 Process_Imported_Projects
(Imported
, Limited_With
=> False);
2516 Project_Declaration_Of
2517 (From_Project_Node
, From_Project_Node_Tree
);
2520 (In_Tree
=> In_Tree
,
2521 Project
=> Project
.Extends
,
2523 From_Project_Node
=> Extended_Project_Of
2525 From_Project_Node_Tree
),
2526 From_Project_Node_Tree
=> From_Project_Node_Tree
,
2527 Extended_By
=> Project
);
2529 Process_Declarative_Items
2530 (Project
=> Project
,
2533 From_Project_Node
=> From_Project_Node
,
2534 From_Project_Node_Tree
=> From_Project_Node_Tree
,
2536 Item
=> First_Declarative_Item_Of
2538 From_Project_Node_Tree
));
2540 -- If it is an extending project, inherit all packages
2541 -- from the extended project that are not explicitly defined
2542 -- or renamed. Also inherit the languages, if attribute Languages
2543 -- is not explicitly defined.
2545 if Project
.Extends
/= No_Project
then
2547 Extended_Pkg
: Package_Id
;
2548 Current_Pkg
: Package_Id
;
2549 Element
: Package_Element
;
2550 First
: constant Package_Id
:=
2551 Project
.Decl
.Packages
;
2552 Attribute1
: Variable_Id
;
2553 Attribute2
: Variable_Id
;
2554 Attr_Value1
: Variable
;
2555 Attr_Value2
: Variable
;
2558 Extended_Pkg
:= Project
.Extends
.Decl
.Packages
;
2559 while Extended_Pkg
/= No_Package
loop
2560 Element
:= In_Tree
.Packages
.Table
(Extended_Pkg
);
2562 Current_Pkg
:= First
;
2563 while Current_Pkg
/= No_Package
2564 and then In_Tree
.Packages
.Table
(Current_Pkg
).Name
/=
2568 In_Tree
.Packages
.Table
(Current_Pkg
).Next
;
2571 if Current_Pkg
= No_Package
then
2572 Package_Table
.Increment_Last
2574 Current_Pkg
:= Package_Table
.Last
(In_Tree
.Packages
);
2575 In_Tree
.Packages
.Table
(Current_Pkg
) :=
2576 (Name
=> Element
.Name
,
2577 Decl
=> No_Declarations
,
2578 Parent
=> No_Package
,
2579 Next
=> Project
.Decl
.Packages
);
2580 Project
.Decl
.Packages
:= Current_Pkg
;
2581 Copy_Package_Declarations
2582 (From
=> Element
.Decl
,
2584 In_Tree
.Packages
.Table
(Current_Pkg
).Decl
,
2585 New_Loc
=> No_Location
,
2586 Naming_Restricted
=>
2587 Element
.Name
= Snames
.Name_Naming
,
2588 In_Tree
=> In_Tree
);
2591 Extended_Pkg
:= Element
.Next
;
2594 -- Check if attribute Languages is declared in the
2595 -- extending project.
2597 Attribute1
:= Project
.Decl
.Attributes
;
2598 while Attribute1
/= No_Variable
loop
2599 Attr_Value1
:= In_Tree
.Variable_Elements
.
2601 exit when Attr_Value1
.Name
= Snames
.Name_Languages
;
2602 Attribute1
:= Attr_Value1
.Next
;
2605 if Attribute1
= No_Variable
or else
2606 Attr_Value1
.Value
.Default
2608 -- Attribute Languages is not declared in the extending
2609 -- project. Check if it is declared in the project being
2612 Attribute2
:= Project
.Extends
.Decl
.Attributes
;
2613 while Attribute2
/= No_Variable
loop
2614 Attr_Value2
:= In_Tree
.Variable_Elements
.
2616 exit when Attr_Value2
.Name
= Snames
.Name_Languages
;
2617 Attribute2
:= Attr_Value2
.Next
;
2620 if Attribute2
/= No_Variable
and then
2621 not Attr_Value2
.Value
.Default
2623 -- As attribute Languages is declared in the project
2624 -- being extended, copy its value for the extending
2627 if Attribute1
= No_Variable
then
2628 Variable_Element_Table
.Increment_Last
2629 (In_Tree
.Variable_Elements
);
2630 Attribute1
:= Variable_Element_Table
.Last
2631 (In_Tree
.Variable_Elements
);
2632 Attr_Value1
.Next
:= Project
.Decl
.Attributes
;
2633 Project
.Decl
.Attributes
:= Attribute1
;
2636 Attr_Value1
.Name
:= Snames
.Name_Languages
;
2637 Attr_Value1
.Value
:= Attr_Value2
.Value
;
2638 In_Tree
.Variable_Elements
.Table
2639 (Attribute1
) := Attr_Value1
;
2645 Process_Imported_Projects
(Imported
, Limited_With
=> True);
2648 end Recursive_Process
;