PR rtl-optimization/57003
[official-gcc.git] / gcc / ada / prj-proc.adb
blob1fd71fc5dfdd90b35edf479d047e2dd7b8c9f39b
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- P R J . P R O C --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2001-2014, Free Software Foundation, Inc. --
10 -- --
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. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
26 with Atree; use Atree;
27 with Err_Vars; use Err_Vars;
28 with Opt; use Opt;
29 with Osint; use Osint;
30 with Output; use Output;
31 with Prj.Attr; use Prj.Attr;
32 with Prj.Env;
33 with Prj.Err; use Prj.Err;
34 with Prj.Ext; use Prj.Ext;
35 with Prj.Nmsc; use Prj.Nmsc;
36 with Prj.Part;
37 with Prj.Util;
38 with Snames;
40 with Ada.Containers.Vectors;
41 with Ada.Strings.Fixed; use Ada.Strings.Fixed;
43 with GNAT.Case_Util; use GNAT.Case_Util;
44 with GNAT.HTable;
46 package body Prj.Proc is
48 package Processed_Projects is new GNAT.HTable.Simple_HTable
49 (Header_Num => Header_Num,
50 Element => Project_Id,
51 No_Element => No_Project,
52 Key => Name_Id,
53 Hash => Hash,
54 Equal => "=");
55 -- This hash table contains all processed projects
57 package Unit_Htable is new GNAT.HTable.Simple_HTable
58 (Header_Num => Header_Num,
59 Element => Source_Id,
60 No_Element => No_Source,
61 Key => Name_Id,
62 Hash => Hash,
63 Equal => "=");
64 -- This hash table contains all processed projects
66 procedure Add (To_Exp : in out Name_Id; Str : Name_Id);
67 -- Concatenate two strings and returns another string if both
68 -- arguments are not null string.
70 -- In the following procedures, we are expected to guess the meaning of
71 -- the parameters from their names, this is never a good idea, comments
72 -- should be added precisely defining every formal ???
74 procedure Add_Attributes
75 (Project : Project_Id;
76 Project_Name : Name_Id;
77 Project_Dir : Name_Id;
78 Shared : Shared_Project_Tree_Data_Access;
79 Decl : in out Declarations;
80 First : Attribute_Node_Id;
81 Project_Level : Boolean);
82 -- Add all attributes, starting with First, with their default values to
83 -- the package or project with declarations Decl.
85 procedure Check
86 (In_Tree : Project_Tree_Ref;
87 Project : Project_Id;
88 Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
89 Flags : Processing_Flags);
90 -- Set all projects to not checked, then call Recursive_Check for the
91 -- main project Project. Project is set to No_Project if errors occurred.
92 -- Current_Dir is for optimization purposes, avoiding extra system calls.
93 -- If Allow_Duplicate_Basenames, then files with the same base names are
94 -- authorized within a project for source-based languages (never for unit
95 -- based languages)
97 procedure Copy_Package_Declarations
98 (From : Declarations;
99 To : in out Declarations;
100 New_Loc : Source_Ptr;
101 Restricted : Boolean;
102 Shared : Shared_Project_Tree_Data_Access);
103 -- Copy a package declaration From to To for a renamed package. Change the
104 -- locations of all the attributes to New_Loc. When Restricted is
105 -- True, do not copy attributes Body, Spec, Implementation, Specification
106 -- and Linker_Options.
108 function Expression
109 (Project : Project_Id;
110 Shared : Shared_Project_Tree_Data_Access;
111 From_Project_Node : Project_Node_Id;
112 From_Project_Node_Tree : Project_Node_Tree_Ref;
113 Env : Prj.Tree.Environment;
114 Pkg : Package_Id;
115 First_Term : Project_Node_Id;
116 Kind : Variable_Kind) return Variable_Value;
117 -- From N_Expression project node From_Project_Node, compute the value
118 -- of an expression and return it as a Variable_Value.
120 function Imported_Or_Extended_Project_From
121 (Project : Project_Id;
122 With_Name : Name_Id;
123 No_Extending : Boolean := False) return Project_Id;
124 -- Find an imported or extended project of Project whose name is With_Name.
125 -- When No_Extending is True, do not look for extending projects, returns
126 -- the exact project whose name is With_Name.
128 function Package_From
129 (Project : Project_Id;
130 Shared : Shared_Project_Tree_Data_Access;
131 With_Name : Name_Id) return Package_Id;
132 -- Find the package of Project whose name is With_Name
134 procedure Process_Declarative_Items
135 (Project : Project_Id;
136 In_Tree : Project_Tree_Ref;
137 From_Project_Node : Project_Node_Id;
138 Node_Tree : Project_Node_Tree_Ref;
139 Env : Prj.Tree.Environment;
140 Pkg : Package_Id;
141 Item : Project_Node_Id;
142 Child_Env : in out Prj.Tree.Environment);
143 -- Process declarative items starting with From_Project_Node, and put them
144 -- in declarations Decl. This is a recursive procedure; it calls itself for
145 -- a package declaration or a case construction.
147 -- Child_Env is the modified environment after seeing declarations like
148 -- "for External(...) use" or "for Project_Path use" in aggregate projects.
149 -- It should have been initialized first.
151 procedure Recursive_Process
152 (In_Tree : Project_Tree_Ref;
153 Project : out Project_Id;
154 Packages_To_Check : String_List_Access;
155 From_Project_Node : Project_Node_Id;
156 From_Project_Node_Tree : Project_Node_Tree_Ref;
157 Env : in out Prj.Tree.Environment;
158 Extended_By : Project_Id;
159 From_Encapsulated_Lib : Boolean;
160 On_New_Tree_Loaded : Tree_Loaded_Callback := null);
161 -- Process project with node From_Project_Node in the tree. Do nothing if
162 -- From_Project_Node is Empty_Node. If project has already been processed,
163 -- simply return its project id. Otherwise create a new project id, mark it
164 -- as processed, call itself recursively for all imported projects and a
165 -- extended project, if any. Then process the declarative items of the
166 -- project.
168 -- Is_Root_Project should be true only for the project that the user
169 -- explicitly loaded. In the context of aggregate projects, only that
170 -- project is allowed to modify the environment that will be used to load
171 -- projects (Child_Env).
173 -- From_Encapsulated_Lib is true if we are parsing a project from
174 -- encapsulated library dependencies.
176 -- If specified, On_New_Tree_Loaded is called after each aggregated project
177 -- has been processed succesfully.
179 function Get_Attribute_Index
180 (Tree : Project_Node_Tree_Ref;
181 Attr : Project_Node_Id;
182 Index : Name_Id) return Name_Id;
183 -- Copy the index of the attribute into Name_Buffer, converting to lower
184 -- case if the attribute is case-insensitive.
186 ---------
187 -- Add --
188 ---------
190 procedure Add (To_Exp : in out Name_Id; Str : Name_Id) is
191 begin
192 if To_Exp = No_Name or else To_Exp = Empty_String then
194 -- To_Exp is nil or empty. The result is Str
196 To_Exp := Str;
198 -- If Str is nil, then do not change To_Ext
200 elsif Str /= No_Name and then Str /= Empty_String then
201 declare
202 S : constant String := Get_Name_String (Str);
203 begin
204 Get_Name_String (To_Exp);
205 Add_Str_To_Name_Buffer (S);
206 To_Exp := Name_Find;
207 end;
208 end if;
209 end Add;
211 --------------------
212 -- Add_Attributes --
213 --------------------
215 procedure Add_Attributes
216 (Project : Project_Id;
217 Project_Name : Name_Id;
218 Project_Dir : Name_Id;
219 Shared : Shared_Project_Tree_Data_Access;
220 Decl : in out Declarations;
221 First : Attribute_Node_Id;
222 Project_Level : Boolean)
224 The_Attribute : Attribute_Node_Id := First;
226 begin
227 while The_Attribute /= Empty_Attribute loop
228 if Attribute_Kind_Of (The_Attribute) = Single then
229 declare
230 New_Attribute : Variable_Value;
232 begin
233 case Variable_Kind_Of (The_Attribute) is
235 -- Undefined should not happen
237 when Undefined =>
238 pragma Assert
239 (False, "attribute with an undefined kind");
240 raise Program_Error;
242 -- Single attributes have a default value of empty string
244 when Single =>
245 New_Attribute :=
246 (Project => Project,
247 Kind => Single,
248 Location => No_Location,
249 Default => True,
250 Value => Empty_String,
251 Index => 0);
253 -- Special cases of <project>'Name and
254 -- <project>'Project_Dir.
256 if Project_Level then
257 if Attribute_Name_Of (The_Attribute) =
258 Snames.Name_Name
259 then
260 New_Attribute.Value := Project_Name;
262 elsif Attribute_Name_Of (The_Attribute) =
263 Snames.Name_Project_Dir
264 then
265 New_Attribute.Value := Project_Dir;
266 end if;
267 end if;
269 -- List attributes have a default value of nil list
271 when List =>
272 New_Attribute :=
273 (Project => Project,
274 Kind => List,
275 Location => No_Location,
276 Default => True,
277 Values => Nil_String);
279 end case;
281 Variable_Element_Table.Increment_Last
282 (Shared.Variable_Elements);
283 Shared.Variable_Elements.Table
284 (Variable_Element_Table.Last (Shared.Variable_Elements)) :=
285 (Next => Decl.Attributes,
286 Name => Attribute_Name_Of (The_Attribute),
287 Value => New_Attribute);
288 Decl.Attributes :=
289 Variable_Element_Table.Last
290 (Shared.Variable_Elements);
291 end;
292 end if;
294 The_Attribute := Next_Attribute (After => The_Attribute);
295 end loop;
296 end Add_Attributes;
298 -----------
299 -- Check --
300 -----------
302 procedure Check
303 (In_Tree : Project_Tree_Ref;
304 Project : Project_Id;
305 Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
306 Flags : Processing_Flags)
308 begin
309 Process_Naming_Scheme (In_Tree, Project, Node_Tree, Flags);
311 -- Set the Other_Part field for the units
313 declare
314 Source1 : Source_Id;
315 Name : Name_Id;
316 Source2 : Source_Id;
317 Iter : Source_Iterator;
319 begin
320 Unit_Htable.Reset;
322 Iter := For_Each_Source (In_Tree);
323 loop
324 Source1 := Prj.Element (Iter);
325 exit when Source1 = No_Source;
327 if Source1.Unit /= No_Unit_Index then
328 Name := Source1.Unit.Name;
329 Source2 := Unit_Htable.Get (Name);
331 if Source2 = No_Source then
332 Unit_Htable.Set (K => Name, E => Source1);
333 else
334 Unit_Htable.Remove (Name);
335 end if;
336 end if;
338 Next (Iter);
339 end loop;
340 end;
341 end Check;
343 -------------------------------
344 -- Copy_Package_Declarations --
345 -------------------------------
347 procedure Copy_Package_Declarations
348 (From : Declarations;
349 To : in out Declarations;
350 New_Loc : Source_Ptr;
351 Restricted : Boolean;
352 Shared : Shared_Project_Tree_Data_Access)
354 V1 : Variable_Id;
355 V2 : Variable_Id := No_Variable;
356 Var : Variable;
357 A1 : Array_Id;
358 A2 : Array_Id := No_Array;
359 Arr : Array_Data;
360 E1 : Array_Element_Id;
361 E2 : Array_Element_Id := No_Array_Element;
362 Elm : Array_Element;
364 begin
365 -- To avoid references in error messages to attribute declarations in
366 -- an original package that has been renamed, copy all the attribute
367 -- declarations of the package and change all locations to New_Loc,
368 -- the location of the renamed package.
370 -- First single attributes
372 V1 := From.Attributes;
373 while V1 /= No_Variable loop
375 -- Copy the attribute
377 Var := Shared.Variable_Elements.Table (V1);
378 V1 := Var.Next;
380 -- Do not copy the value of attribute Linker_Options if Restricted
382 if Restricted and then Var.Name = Snames.Name_Linker_Options then
383 Var.Value.Values := Nil_String;
384 end if;
386 -- Remove the Next component
388 Var.Next := No_Variable;
390 -- Change the location to New_Loc
392 Var.Value.Location := New_Loc;
393 Variable_Element_Table.Increment_Last (Shared.Variable_Elements);
395 -- Put in new declaration
397 if To.Attributes = No_Variable then
398 To.Attributes :=
399 Variable_Element_Table.Last (Shared.Variable_Elements);
400 else
401 Shared.Variable_Elements.Table (V2).Next :=
402 Variable_Element_Table.Last (Shared.Variable_Elements);
403 end if;
405 V2 := Variable_Element_Table.Last (Shared.Variable_Elements);
406 Shared.Variable_Elements.Table (V2) := Var;
407 end loop;
409 -- Then the associated array attributes
411 A1 := From.Arrays;
412 while A1 /= No_Array loop
413 Arr := Shared.Arrays.Table (A1);
414 A1 := Arr.Next;
416 -- Remove the Next component
418 Arr.Next := No_Array;
419 Array_Table.Increment_Last (Shared.Arrays);
421 -- Create new Array declaration
423 if To.Arrays = No_Array then
424 To.Arrays := Array_Table.Last (Shared.Arrays);
425 else
426 Shared.Arrays.Table (A2).Next :=
427 Array_Table.Last (Shared.Arrays);
428 end if;
430 A2 := Array_Table.Last (Shared.Arrays);
432 -- Don't store the array as its first element has not been set yet
434 -- Copy the array elements of the array
436 E1 := Arr.Value;
437 Arr.Value := No_Array_Element;
438 while E1 /= No_Array_Element loop
440 -- Copy the array element
442 Elm := Shared.Array_Elements.Table (E1);
443 E1 := Elm.Next;
445 -- Remove the Next component
447 Elm.Next := No_Array_Element;
449 Elm.Restricted := Restricted;
451 -- Change the location
453 Elm.Value.Location := New_Loc;
454 Array_Element_Table.Increment_Last (Shared.Array_Elements);
456 -- Create new array element
458 if Arr.Value = No_Array_Element then
459 Arr.Value := Array_Element_Table.Last (Shared.Array_Elements);
460 else
461 Shared.Array_Elements.Table (E2).Next :=
462 Array_Element_Table.Last (Shared.Array_Elements);
463 end if;
465 E2 := Array_Element_Table.Last (Shared.Array_Elements);
466 Shared.Array_Elements.Table (E2) := Elm;
467 end loop;
469 -- Finally, store the new array
471 Shared.Arrays.Table (A2) := Arr;
472 end loop;
473 end Copy_Package_Declarations;
475 -------------------------
476 -- Get_Attribute_Index --
477 -------------------------
479 function Get_Attribute_Index
480 (Tree : Project_Node_Tree_Ref;
481 Attr : Project_Node_Id;
482 Index : Name_Id) return Name_Id
484 begin
485 if Index = All_Other_Names
486 or else not Case_Insensitive (Attr, Tree)
487 then
488 return Index;
489 end if;
491 Get_Name_String (Index);
492 To_Lower (Name_Buffer (1 .. Name_Len));
493 return Name_Find;
494 end Get_Attribute_Index;
496 ----------------
497 -- Expression --
498 ----------------
500 function Expression
501 (Project : Project_Id;
502 Shared : Shared_Project_Tree_Data_Access;
503 From_Project_Node : Project_Node_Id;
504 From_Project_Node_Tree : Project_Node_Tree_Ref;
505 Env : Prj.Tree.Environment;
506 Pkg : Package_Id;
507 First_Term : Project_Node_Id;
508 Kind : Variable_Kind) return Variable_Value
510 The_Term : Project_Node_Id;
511 -- The term in the expression list
513 The_Current_Term : Project_Node_Id := Empty_Node;
514 -- The current term node id
516 Result : Variable_Value (Kind => Kind);
517 -- The returned result
519 Last : String_List_Id := Nil_String;
520 -- Reference to the last string elements in Result, when Kind is List
522 Current_Term_Kind : Project_Node_Kind;
524 begin
525 Result.Project := Project;
526 Result.Location := Location_Of (First_Term, From_Project_Node_Tree);
528 -- Process each term of the expression, starting with First_Term
530 The_Term := First_Term;
531 while Present (The_Term) loop
532 The_Current_Term := Current_Term (The_Term, From_Project_Node_Tree);
533 Current_Term_Kind :=
534 Kind_Of (The_Current_Term, From_Project_Node_Tree);
536 case Current_Term_Kind is
538 when N_Literal_String =>
540 case Kind is
542 when Undefined =>
544 -- Should never happen
546 pragma Assert (False, "Undefined expression kind");
547 raise Program_Error;
549 when Single =>
550 Add (Result.Value,
551 String_Value_Of
552 (The_Current_Term, From_Project_Node_Tree));
553 Result.Index :=
554 Source_Index_Of
555 (The_Current_Term, From_Project_Node_Tree);
557 when List =>
559 String_Element_Table.Increment_Last
560 (Shared.String_Elements);
562 if Last = Nil_String then
564 -- This can happen in an expression like () & "toto"
566 Result.Values := String_Element_Table.Last
567 (Shared.String_Elements);
569 else
570 Shared.String_Elements.Table
571 (Last).Next := String_Element_Table.Last
572 (Shared.String_Elements);
573 end if;
575 Last := String_Element_Table.Last
576 (Shared.String_Elements);
578 Shared.String_Elements.Table (Last) :=
579 (Value => String_Value_Of
580 (The_Current_Term,
581 From_Project_Node_Tree),
582 Index => Source_Index_Of
583 (The_Current_Term,
584 From_Project_Node_Tree),
585 Display_Value => No_Name,
586 Location => Location_Of
587 (The_Current_Term,
588 From_Project_Node_Tree),
589 Flag => False,
590 Next => Nil_String);
591 end case;
593 when N_Literal_String_List =>
595 declare
596 String_Node : Project_Node_Id :=
597 First_Expression_In_List
598 (The_Current_Term,
599 From_Project_Node_Tree);
601 Value : Variable_Value;
603 begin
604 if Present (String_Node) then
606 -- If String_Node is nil, it is an empty list, there is
607 -- nothing to do.
609 Value := Expression
610 (Project => Project,
611 Shared => Shared,
612 From_Project_Node => From_Project_Node,
613 From_Project_Node_Tree => From_Project_Node_Tree,
614 Env => Env,
615 Pkg => Pkg,
616 First_Term =>
617 Tree.First_Term
618 (String_Node, From_Project_Node_Tree),
619 Kind => Single);
620 String_Element_Table.Increment_Last
621 (Shared.String_Elements);
623 if Result.Values = Nil_String then
625 -- This literal string list is the first term in a
626 -- string list expression
628 Result.Values :=
629 String_Element_Table.Last
630 (Shared.String_Elements);
632 else
633 Shared.String_Elements.Table (Last).Next :=
634 String_Element_Table.Last (Shared.String_Elements);
635 end if;
637 Last :=
638 String_Element_Table.Last (Shared.String_Elements);
640 Shared.String_Elements.Table (Last) :=
641 (Value => Value.Value,
642 Display_Value => No_Name,
643 Location => Value.Location,
644 Flag => False,
645 Next => Nil_String,
646 Index => Value.Index);
648 loop
649 -- Add the other element of the literal string list
650 -- one after the other.
652 String_Node :=
653 Next_Expression_In_List
654 (String_Node, From_Project_Node_Tree);
656 exit when No (String_Node);
658 Value :=
659 Expression
660 (Project => Project,
661 Shared => Shared,
662 From_Project_Node => From_Project_Node,
663 From_Project_Node_Tree => From_Project_Node_Tree,
664 Env => Env,
665 Pkg => Pkg,
666 First_Term =>
667 Tree.First_Term
668 (String_Node, From_Project_Node_Tree),
669 Kind => Single);
671 String_Element_Table.Increment_Last
672 (Shared.String_Elements);
673 Shared.String_Elements.Table (Last).Next :=
674 String_Element_Table.Last (Shared.String_Elements);
675 Last := String_Element_Table.Last
676 (Shared.String_Elements);
677 Shared.String_Elements.Table (Last) :=
678 (Value => Value.Value,
679 Display_Value => No_Name,
680 Location => Value.Location,
681 Flag => False,
682 Next => Nil_String,
683 Index => Value.Index);
684 end loop;
685 end if;
686 end;
688 when N_Variable_Reference | N_Attribute_Reference =>
690 declare
691 The_Project : Project_Id := Project;
692 The_Package : Package_Id := Pkg;
693 The_Name : Name_Id := No_Name;
694 The_Variable_Id : Variable_Id := No_Variable;
695 The_Variable : Variable_Value;
696 Term_Project : constant Project_Node_Id :=
697 Project_Node_Of
698 (The_Current_Term,
699 From_Project_Node_Tree);
700 Term_Package : constant Project_Node_Id :=
701 Package_Node_Of
702 (The_Current_Term,
703 From_Project_Node_Tree);
704 Index : Name_Id := No_Name;
706 begin
707 <<Object_Dir_Restart>>
708 The_Project := Project;
709 The_Package := Pkg;
710 The_Name := No_Name;
711 The_Variable_Id := No_Variable;
712 Index := No_Name;
714 if Present (Term_Project)
715 and then Term_Project /= From_Project_Node
716 then
717 -- This variable or attribute comes from another project
719 The_Name :=
720 Name_Of (Term_Project, From_Project_Node_Tree);
721 The_Project := Imported_Or_Extended_Project_From
722 (Project => Project,
723 With_Name => The_Name,
724 No_Extending => True);
725 end if;
727 if Present (Term_Package) then
729 -- This is an attribute of a package
731 The_Name :=
732 Name_Of (Term_Package, From_Project_Node_Tree);
734 The_Package := The_Project.Decl.Packages;
735 while The_Package /= No_Package
736 and then Shared.Packages.Table (The_Package).Name /=
737 The_Name
738 loop
739 The_Package :=
740 Shared.Packages.Table (The_Package).Next;
741 end loop;
743 pragma Assert
744 (The_Package /= No_Package, "package not found.");
746 elsif Kind_Of (The_Current_Term, From_Project_Node_Tree) =
747 N_Attribute_Reference
748 then
749 The_Package := No_Package;
750 end if;
752 The_Name :=
753 Name_Of (The_Current_Term, From_Project_Node_Tree);
755 if Current_Term_Kind = N_Attribute_Reference then
756 Index :=
757 Associative_Array_Index_Of
758 (The_Current_Term, From_Project_Node_Tree);
759 end if;
761 -- If it is not an associative array attribute
763 if Index = No_Name then
765 -- It is not an associative array attribute
767 if The_Package /= No_Package then
769 -- First, if there is a package, look into the package
771 if Current_Term_Kind = N_Variable_Reference then
772 The_Variable_Id :=
773 Shared.Packages.Table
774 (The_Package).Decl.Variables;
775 else
776 The_Variable_Id :=
777 Shared.Packages.Table
778 (The_Package).Decl.Attributes;
779 end if;
781 while The_Variable_Id /= No_Variable
782 and then Shared.Variable_Elements.Table
783 (The_Variable_Id).Name /= The_Name
784 loop
785 The_Variable_Id :=
786 Shared.Variable_Elements.Table
787 (The_Variable_Id).Next;
788 end loop;
790 end if;
792 if The_Variable_Id = No_Variable then
794 -- If we have not found it, look into the project
796 if Current_Term_Kind = N_Variable_Reference then
797 The_Variable_Id := The_Project.Decl.Variables;
798 else
799 The_Variable_Id := The_Project.Decl.Attributes;
800 end if;
802 while The_Variable_Id /= No_Variable
803 and then Shared.Variable_Elements.Table
804 (The_Variable_Id).Name /= The_Name
805 loop
806 The_Variable_Id :=
807 Shared.Variable_Elements.Table
808 (The_Variable_Id).Next;
809 end loop;
811 end if;
813 pragma Assert (The_Variable_Id /= No_Variable,
814 "variable or attribute not found");
816 The_Variable :=
817 Shared.Variable_Elements.Table (The_Variable_Id).Value;
819 else
821 -- It is an associative array attribute
823 declare
824 The_Array : Array_Id := No_Array;
825 The_Element : Array_Element_Id := No_Array_Element;
826 Array_Index : Name_Id := No_Name;
828 begin
829 if The_Package /= No_Package then
830 The_Array :=
831 Shared.Packages.Table (The_Package).Decl.Arrays;
832 else
833 The_Array := The_Project.Decl.Arrays;
834 end if;
836 while The_Array /= No_Array
837 and then Shared.Arrays.Table (The_Array).Name /=
838 The_Name
839 loop
840 The_Array := Shared.Arrays.Table (The_Array).Next;
841 end loop;
843 if The_Array /= No_Array then
844 The_Element :=
845 Shared.Arrays.Table (The_Array).Value;
846 Array_Index :=
847 Get_Attribute_Index
848 (From_Project_Node_Tree,
849 The_Current_Term,
850 Index);
852 while The_Element /= No_Array_Element
853 and then Shared.Array_Elements.Table
854 (The_Element).Index /= Array_Index
855 loop
856 The_Element :=
857 Shared.Array_Elements.Table (The_Element).Next;
858 end loop;
860 end if;
862 if The_Element /= No_Array_Element then
863 The_Variable :=
864 Shared.Array_Elements.Table (The_Element).Value;
866 else
867 if Expression_Kind_Of
868 (The_Current_Term, From_Project_Node_Tree) =
869 List
870 then
871 The_Variable :=
872 (Project => Project,
873 Kind => List,
874 Location => No_Location,
875 Default => True,
876 Values => Nil_String);
877 else
878 The_Variable :=
879 (Project => Project,
880 Kind => Single,
881 Location => No_Location,
882 Default => True,
883 Value => Empty_String,
884 Index => 0);
885 end if;
886 end if;
887 end;
888 end if;
890 -- Check the defaults
892 if Current_Term_Kind = N_Attribute_Reference
893 and then The_Variable.Default
894 then
895 declare
896 The_Default : constant Attribute_Default_Value :=
897 Default_Of
898 (The_Current_Term, From_Project_Node_Tree);
900 begin
901 case The_Variable.Kind is
902 when Undefined =>
903 null;
905 when Single =>
906 case The_Default is
907 when Read_Only_Value =>
908 null;
910 when Empty_Value =>
911 The_Variable.Value := Empty_String;
913 when Dot_Value =>
914 The_Variable.Value := Dot_String;
916 when Object_Dir_Value =>
917 From_Project_Node_Tree.Project_Nodes.Table
918 (The_Current_Term).Name :=
919 Snames.Name_Object_Dir;
920 From_Project_Node_Tree.Project_Nodes.Table
921 (The_Current_Term).Default :=
922 Dot_Value;
923 goto Object_Dir_Restart;
925 when Target_Value =>
926 null;
927 end case;
929 when List =>
930 case The_Default is
931 when Read_Only_Value =>
932 null;
934 when Empty_Value =>
935 The_Variable.Values := Nil_String;
937 when Dot_Value =>
938 The_Variable.Values :=
939 Shared.Dot_String_List;
941 when Object_Dir_Value | Target_Value =>
942 null;
943 end case;
944 end case;
945 end;
946 end if;
948 case Kind is
949 when Undefined =>
951 -- Should never happen
953 pragma Assert (False, "undefined expression kind");
954 null;
956 when Single =>
957 case The_Variable.Kind is
959 when Undefined =>
960 null;
962 when Single =>
963 Add (Result.Value, The_Variable.Value);
965 when List =>
967 -- Should never happen
969 pragma Assert
970 (False,
971 "list cannot appear in single " &
972 "string expression");
973 null;
974 end case;
976 when List =>
977 case The_Variable.Kind is
979 when Undefined =>
980 null;
982 when Single =>
983 String_Element_Table.Increment_Last
984 (Shared.String_Elements);
986 if Last = Nil_String then
988 -- This can happen in an expression such as
989 -- () & Var
991 Result.Values :=
992 String_Element_Table.Last
993 (Shared.String_Elements);
995 else
996 Shared.String_Elements.Table (Last).Next :=
997 String_Element_Table.Last
998 (Shared.String_Elements);
999 end if;
1001 Last :=
1002 String_Element_Table.Last
1003 (Shared.String_Elements);
1005 Shared.String_Elements.Table (Last) :=
1006 (Value => The_Variable.Value,
1007 Display_Value => No_Name,
1008 Location => Location_Of
1009 (The_Current_Term,
1010 From_Project_Node_Tree),
1011 Flag => False,
1012 Next => Nil_String,
1013 Index => 0);
1015 when List =>
1017 declare
1018 The_List : String_List_Id :=
1019 The_Variable.Values;
1021 begin
1022 while The_List /= Nil_String loop
1023 String_Element_Table.Increment_Last
1024 (Shared.String_Elements);
1026 if Last = Nil_String then
1027 Result.Values :=
1028 String_Element_Table.Last
1029 (Shared.String_Elements);
1031 else
1032 Shared.
1033 String_Elements.Table (Last).Next :=
1034 String_Element_Table.Last
1035 (Shared.String_Elements);
1037 end if;
1039 Last :=
1040 String_Element_Table.Last
1041 (Shared.String_Elements);
1043 Shared.String_Elements.Table
1044 (Last) :=
1045 (Value =>
1046 Shared.String_Elements.Table
1047 (The_List).Value,
1048 Display_Value => No_Name,
1049 Location =>
1050 Location_Of
1051 (The_Current_Term,
1052 From_Project_Node_Tree),
1053 Flag => False,
1054 Next => Nil_String,
1055 Index => 0);
1057 The_List := Shared.String_Elements.Table
1058 (The_List).Next;
1059 end loop;
1060 end;
1061 end case;
1062 end case;
1063 end;
1065 when N_External_Value =>
1066 Get_Name_String
1067 (String_Value_Of
1068 (External_Reference_Of
1069 (The_Current_Term, From_Project_Node_Tree),
1070 From_Project_Node_Tree));
1072 declare
1073 Name : constant Name_Id := Name_Find;
1074 Default : Name_Id := No_Name;
1075 Value : Name_Id := No_Name;
1076 Ext_List : Boolean := False;
1077 Str_List : String_List_Access := null;
1078 Def_Var : Variable_Value;
1080 Default_Node : constant Project_Node_Id :=
1081 External_Default_Of
1082 (The_Current_Term,
1083 From_Project_Node_Tree);
1085 begin
1086 -- If there is a default value for the external reference,
1087 -- get its value.
1089 if Present (Default_Node) then
1090 Def_Var := Expression
1091 (Project => Project,
1092 Shared => Shared,
1093 From_Project_Node => From_Project_Node,
1094 From_Project_Node_Tree => From_Project_Node_Tree,
1095 Env => Env,
1096 Pkg => Pkg,
1097 First_Term =>
1098 Tree.First_Term
1099 (Default_Node, From_Project_Node_Tree),
1100 Kind => Single);
1102 if Def_Var /= Nil_Variable_Value then
1103 Default := Def_Var.Value;
1104 end if;
1105 end if;
1107 Ext_List := Expression_Kind_Of
1108 (The_Current_Term,
1109 From_Project_Node_Tree) = List;
1111 if Ext_List then
1112 Value := Prj.Ext.Value_Of (Env.External, Name, No_Name);
1114 if Value /= No_Name then
1115 declare
1116 Sep : constant String :=
1117 Get_Name_String (Default);
1118 First : Positive := 1;
1119 Lst : Natural;
1120 Done : Boolean := False;
1121 Nmb : Natural;
1123 begin
1124 Get_Name_String (Value);
1126 if Name_Len = 0
1127 or else Sep'Length = 0
1128 or else Name_Buffer (1 .. Name_Len) = Sep
1129 then
1130 Done := True;
1131 end if;
1133 if not Done and then Name_Len < Sep'Length then
1134 Str_List :=
1135 new String_List'
1136 (1 => new String'
1137 (Name_Buffer (1 .. Name_Len)));
1138 Done := True;
1139 end if;
1141 if not Done then
1142 if Name_Buffer (1 .. Sep'Length) = Sep then
1143 First := Sep'Length + 1;
1144 end if;
1146 if Name_Len - First + 1 >= Sep'Length
1147 and then
1148 Name_Buffer (Name_Len - Sep'Length + 1 ..
1149 Name_Len) = Sep
1150 then
1151 Name_Len := Name_Len - Sep'Length;
1152 end if;
1154 if Name_Len = 0 then
1155 Str_List :=
1156 new String_List'(1 => new String'(""));
1157 Done := True;
1158 end if;
1159 end if;
1161 if not Done then
1163 -- Count the number of strings
1165 declare
1166 Saved : constant Positive := First;
1168 begin
1169 Nmb := 1;
1170 loop
1171 Lst :=
1172 Index
1173 (Source =>
1174 Name_Buffer (First .. Name_Len),
1175 Pattern => Sep);
1176 exit when Lst = 0;
1177 Nmb := Nmb + 1;
1178 First := Lst + Sep'Length;
1179 end loop;
1181 First := Saved;
1182 end;
1184 Str_List := new String_List (1 .. Nmb);
1186 -- Populate the string list
1188 Nmb := 1;
1189 loop
1190 Lst :=
1191 Index
1192 (Source =>
1193 Name_Buffer (First .. Name_Len),
1194 Pattern => Sep);
1196 if Lst = 0 then
1197 Str_List (Nmb) :=
1198 new String'
1199 (Name_Buffer (First .. Name_Len));
1200 exit;
1202 else
1203 Str_List (Nmb) :=
1204 new String'
1205 (Name_Buffer (First .. Lst - 1));
1206 Nmb := Nmb + 1;
1207 First := Lst + Sep'Length;
1208 end if;
1209 end loop;
1210 end if;
1211 end;
1212 end if;
1214 else
1215 -- Get the value
1217 Value := Prj.Ext.Value_Of (Env.External, Name, Default);
1219 if Value = No_Name then
1220 if not Quiet_Output then
1221 Error_Msg
1222 (Env.Flags, "?undefined external reference",
1223 Location_Of
1224 (The_Current_Term, From_Project_Node_Tree),
1225 Project);
1226 end if;
1228 Value := Empty_String;
1229 end if;
1230 end if;
1232 case Kind is
1234 when Undefined =>
1235 null;
1237 when Single =>
1238 if Ext_List then
1239 null; -- error
1241 else
1242 Add (Result.Value, Value);
1243 end if;
1245 when List =>
1246 if not Ext_List or else Str_List /= null then
1247 String_Element_Table.Increment_Last
1248 (Shared.String_Elements);
1250 if Last = Nil_String then
1251 Result.Values :=
1252 String_Element_Table.Last
1253 (Shared.String_Elements);
1255 else
1256 Shared.String_Elements.Table (Last).Next
1257 := String_Element_Table.Last
1258 (Shared.String_Elements);
1259 end if;
1261 Last := String_Element_Table.Last
1262 (Shared.String_Elements);
1264 if Ext_List then
1265 for Ind in Str_List'Range loop
1266 Name_Len := 0;
1267 Add_Str_To_Name_Buffer (Str_List (Ind).all);
1268 Value := Name_Find;
1269 Shared.String_Elements.Table (Last) :=
1270 (Value => Value,
1271 Display_Value => No_Name,
1272 Location =>
1273 Location_Of
1274 (The_Current_Term,
1275 From_Project_Node_Tree),
1276 Flag => False,
1277 Next => Nil_String,
1278 Index => 0);
1280 if Ind /= Str_List'Last then
1281 String_Element_Table.Increment_Last
1282 (Shared.String_Elements);
1283 Shared.String_Elements.Table (Last).Next :=
1284 String_Element_Table.Last
1285 (Shared.String_Elements);
1286 Last := String_Element_Table.Last
1287 (Shared.String_Elements);
1288 end if;
1289 end loop;
1291 else
1292 Shared.String_Elements.Table (Last) :=
1293 (Value => Value,
1294 Display_Value => No_Name,
1295 Location =>
1296 Location_Of
1297 (The_Current_Term,
1298 From_Project_Node_Tree),
1299 Flag => False,
1300 Next => Nil_String,
1301 Index => 0);
1302 end if;
1303 end if;
1304 end case;
1305 end;
1307 when others =>
1309 -- Should never happen
1311 pragma Assert
1312 (False,
1313 "illegal node kind in an expression");
1314 raise Program_Error;
1316 end case;
1318 The_Term := Next_Term (The_Term, From_Project_Node_Tree);
1319 end loop;
1321 return Result;
1322 end Expression;
1324 ---------------------------------------
1325 -- Imported_Or_Extended_Project_From --
1326 ---------------------------------------
1328 function Imported_Or_Extended_Project_From
1329 (Project : Project_Id;
1330 With_Name : Name_Id;
1331 No_Extending : Boolean := False) return Project_Id
1333 List : Project_List;
1334 Result : Project_Id;
1335 Temp_Result : Project_Id;
1337 begin
1338 -- First check if it is the name of an extended project
1340 Result := Project.Extends;
1341 while Result /= No_Project loop
1342 if Result.Name = With_Name then
1343 return Result;
1344 else
1345 Result := Result.Extends;
1346 end if;
1347 end loop;
1349 -- Then check the name of each imported project
1351 Temp_Result := No_Project;
1352 List := Project.Imported_Projects;
1353 while List /= null loop
1354 Result := List.Project;
1356 -- If the project is directly imported, then returns its ID
1358 if Result.Name = With_Name then
1359 return Result;
1360 end if;
1362 -- If a project extending the project is imported, then keep this
1363 -- extending project as a possibility. It will be the returned ID
1364 -- if the project is not imported directly.
1366 declare
1367 Proj : Project_Id;
1369 begin
1370 Proj := Result.Extends;
1371 while Proj /= No_Project loop
1372 if Proj.Name = With_Name then
1373 if No_Extending then
1374 Temp_Result := Proj;
1375 else
1376 Temp_Result := Result;
1377 end if;
1379 exit;
1380 end if;
1382 Proj := Proj.Extends;
1383 end loop;
1384 end;
1386 List := List.Next;
1387 end loop;
1389 pragma Assert (Temp_Result /= No_Project, "project not found");
1390 return Temp_Result;
1391 end Imported_Or_Extended_Project_From;
1393 ------------------
1394 -- Package_From --
1395 ------------------
1397 function Package_From
1398 (Project : Project_Id;
1399 Shared : Shared_Project_Tree_Data_Access;
1400 With_Name : Name_Id) return Package_Id
1402 Result : Package_Id := Project.Decl.Packages;
1404 begin
1405 -- Check the name of each existing package of Project
1407 while Result /= No_Package
1408 and then Shared.Packages.Table (Result).Name /= With_Name
1409 loop
1410 Result := Shared.Packages.Table (Result).Next;
1411 end loop;
1413 if Result = No_Package then
1415 -- Should never happen
1417 Write_Line
1418 ("package """ & Get_Name_String (With_Name) & """ not found");
1419 raise Program_Error;
1421 else
1422 return Result;
1423 end if;
1424 end Package_From;
1426 -------------
1427 -- Process --
1428 -------------
1430 procedure Process
1431 (In_Tree : Project_Tree_Ref;
1432 Project : out Project_Id;
1433 Packages_To_Check : String_List_Access;
1434 Success : out Boolean;
1435 From_Project_Node : Project_Node_Id;
1436 From_Project_Node_Tree : Project_Node_Tree_Ref;
1437 Env : in out Prj.Tree.Environment;
1438 Reset_Tree : Boolean := True;
1439 On_New_Tree_Loaded : Tree_Loaded_Callback := null)
1441 begin
1442 Process_Project_Tree_Phase_1
1443 (In_Tree => In_Tree,
1444 Project => Project,
1445 Success => Success,
1446 From_Project_Node => From_Project_Node,
1447 From_Project_Node_Tree => From_Project_Node_Tree,
1448 Env => Env,
1449 Packages_To_Check => Packages_To_Check,
1450 Reset_Tree => Reset_Tree,
1451 On_New_Tree_Loaded => On_New_Tree_Loaded);
1453 if Project_Qualifier_Of
1454 (From_Project_Node, From_Project_Node_Tree) /= Configuration
1455 then
1456 Process_Project_Tree_Phase_2
1457 (In_Tree => In_Tree,
1458 Project => Project,
1459 Success => Success,
1460 From_Project_Node => From_Project_Node,
1461 From_Project_Node_Tree => From_Project_Node_Tree,
1462 Env => Env);
1463 end if;
1464 end Process;
1466 -------------------------------
1467 -- Process_Declarative_Items --
1468 -------------------------------
1470 procedure Process_Declarative_Items
1471 (Project : Project_Id;
1472 In_Tree : Project_Tree_Ref;
1473 From_Project_Node : Project_Node_Id;
1474 Node_Tree : Project_Node_Tree_Ref;
1475 Env : Prj.Tree.Environment;
1476 Pkg : Package_Id;
1477 Item : Project_Node_Id;
1478 Child_Env : in out Prj.Tree.Environment)
1480 Shared : constant Shared_Project_Tree_Data_Access := In_Tree.Shared;
1482 procedure Check_Or_Set_Typed_Variable
1483 (Value : in out Variable_Value;
1484 Declaration : Project_Node_Id);
1485 -- Check whether Value is valid for this typed variable declaration. If
1486 -- it is an error, the behavior depends on the flags: either an error is
1487 -- reported, or a warning, or nothing. In the last two cases, the value
1488 -- of the variable is set to a valid value, replacing Value.
1490 procedure Process_Package_Declaration
1491 (Current_Item : Project_Node_Id);
1492 procedure Process_Attribute_Declaration
1493 (Current : Project_Node_Id);
1494 procedure Process_Case_Construction
1495 (Current_Item : Project_Node_Id);
1496 procedure Process_Associative_Array
1497 (Current_Item : Project_Node_Id);
1498 procedure Process_Expression
1499 (Current : Project_Node_Id);
1500 procedure Process_Expression_For_Associative_Array
1501 (Current : Project_Node_Id;
1502 New_Value : Variable_Value);
1503 procedure Process_Expression_Variable_Decl
1504 (Current_Item : Project_Node_Id;
1505 New_Value : Variable_Value);
1506 -- Process the various declarative items
1508 ---------------------------------
1509 -- Check_Or_Set_Typed_Variable --
1510 ---------------------------------
1512 procedure Check_Or_Set_Typed_Variable
1513 (Value : in out Variable_Value;
1514 Declaration : Project_Node_Id)
1516 Loc : constant Source_Ptr := Location_Of (Declaration, Node_Tree);
1518 Reset_Value : Boolean := False;
1519 Current_String : Project_Node_Id;
1521 begin
1522 -- Report an error for an empty string
1524 if Value.Value = Empty_String then
1525 Error_Msg_Name_1 := Name_Of (Declaration, Node_Tree);
1527 case Env.Flags.Allow_Invalid_External is
1528 when Error =>
1529 Error_Msg
1530 (Env.Flags, "no value defined for %%", Loc, Project);
1531 when Warning =>
1532 Reset_Value := True;
1533 Error_Msg
1534 (Env.Flags, "?no value defined for %%", Loc, Project);
1535 when Silent =>
1536 Reset_Value := True;
1537 end case;
1539 else
1540 -- Loop through all the valid strings for the
1541 -- string type and compare to the string value.
1543 Current_String :=
1544 First_Literal_String
1545 (String_Type_Of (Declaration, Node_Tree), Node_Tree);
1547 while Present (Current_String)
1548 and then
1549 String_Value_Of (Current_String, Node_Tree) /= Value.Value
1550 loop
1551 Current_String :=
1552 Next_Literal_String (Current_String, Node_Tree);
1553 end loop;
1555 -- Report error if string value is not one for the string type
1557 if No (Current_String) then
1558 Error_Msg_Name_1 := Value.Value;
1559 Error_Msg_Name_2 := Name_Of (Declaration, Node_Tree);
1561 case Env.Flags.Allow_Invalid_External is
1562 when Error =>
1563 Error_Msg
1564 (Env.Flags, "value %% is illegal for typed string %%",
1565 Loc, Project);
1567 when Warning =>
1568 Error_Msg
1569 (Env.Flags, "?value %% is illegal for typed string %%",
1570 Loc, Project);
1571 Reset_Value := True;
1573 when Silent =>
1574 Reset_Value := True;
1575 end case;
1576 end if;
1577 end if;
1579 if Reset_Value then
1580 Current_String :=
1581 First_Literal_String
1582 (String_Type_Of (Declaration, Node_Tree), Node_Tree);
1583 Value.Value := String_Value_Of (Current_String, Node_Tree);
1584 end if;
1585 end Check_Or_Set_Typed_Variable;
1587 ---------------------------------
1588 -- Process_Package_Declaration --
1589 ---------------------------------
1591 procedure Process_Package_Declaration
1592 (Current_Item : Project_Node_Id)
1594 begin
1595 -- Do not process a package declaration that should be ignored
1597 if Expression_Kind_Of (Current_Item, Node_Tree) /= Ignored then
1599 -- Create the new package
1601 Package_Table.Increment_Last (Shared.Packages);
1603 declare
1604 New_Pkg : constant Package_Id :=
1605 Package_Table.Last (Shared.Packages);
1606 The_New_Package : Package_Element;
1608 Project_Of_Renamed_Package : constant Project_Node_Id :=
1609 Project_Of_Renamed_Package_Of
1610 (Current_Item, Node_Tree);
1612 begin
1613 -- Set the name of the new package
1615 The_New_Package.Name := Name_Of (Current_Item, Node_Tree);
1617 -- Insert the new package in the appropriate list
1619 if Pkg /= No_Package then
1620 The_New_Package.Next :=
1621 Shared.Packages.Table (Pkg).Decl.Packages;
1622 Shared.Packages.Table (Pkg).Decl.Packages := New_Pkg;
1624 else
1625 The_New_Package.Next := Project.Decl.Packages;
1626 Project.Decl.Packages := New_Pkg;
1627 end if;
1629 Shared.Packages.Table (New_Pkg) := The_New_Package;
1631 if Present (Project_Of_Renamed_Package) then
1633 -- Renamed or extending package
1635 declare
1636 Project_Name : constant Name_Id :=
1637 Name_Of (Project_Of_Renamed_Package,
1638 Node_Tree);
1640 Renamed_Project : constant Project_Id :=
1641 Imported_Or_Extended_Project_From
1642 (Project, Project_Name);
1644 Renamed_Package : constant Package_Id :=
1645 Package_From
1646 (Renamed_Project, Shared,
1647 Name_Of (Current_Item, Node_Tree));
1649 begin
1650 -- For a renamed package, copy the declarations of the
1651 -- renamed package, but set all the locations to the
1652 -- location of the package name in the renaming
1653 -- declaration.
1655 Copy_Package_Declarations
1656 (From => Shared.Packages.Table
1657 (Renamed_Package).Decl,
1658 To => Shared.Packages.Table (New_Pkg).Decl,
1659 New_Loc => Location_Of (Current_Item, Node_Tree),
1660 Restricted => False,
1661 Shared => Shared);
1662 end;
1664 else
1665 -- Set the default values of the attributes
1667 Add_Attributes
1668 (Project,
1669 Project.Name,
1670 Name_Id (Project.Directory.Display_Name),
1671 Shared,
1672 Shared.Packages.Table (New_Pkg).Decl,
1673 First_Attribute_Of
1674 (Package_Id_Of (Current_Item, Node_Tree)),
1675 Project_Level => False);
1676 end if;
1678 -- Process declarative items (nothing to do when the package is
1679 -- renaming, as the first declarative item is null).
1681 Process_Declarative_Items
1682 (Project => Project,
1683 In_Tree => In_Tree,
1684 From_Project_Node => From_Project_Node,
1685 Node_Tree => Node_Tree,
1686 Env => Env,
1687 Pkg => New_Pkg,
1688 Item =>
1689 First_Declarative_Item_Of (Current_Item, Node_Tree),
1690 Child_Env => Child_Env);
1691 end;
1692 end if;
1693 end Process_Package_Declaration;
1695 -------------------------------
1696 -- Process_Associative_Array --
1697 -------------------------------
1699 procedure Process_Associative_Array
1700 (Current_Item : Project_Node_Id)
1702 Current_Item_Name : constant Name_Id :=
1703 Name_Of (Current_Item, Node_Tree);
1704 -- The name of the attribute
1706 Current_Location : constant Source_Ptr :=
1707 Location_Of (Current_Item, Node_Tree);
1709 New_Array : Array_Id;
1710 -- The new associative array created
1712 Orig_Array : Array_Id;
1713 -- The associative array value
1715 Orig_Project_Name : Name_Id := No_Name;
1716 -- The name of the project where the associative array
1717 -- value is.
1719 Orig_Project : Project_Id := No_Project;
1720 -- The id of the project where the associative array
1721 -- value is.
1723 Orig_Package_Name : Name_Id := No_Name;
1724 -- The name of the package, if any, where the associative array value
1725 -- is located.
1727 Orig_Package : Package_Id := No_Package;
1728 -- The id of the package, if any, where the associative array value
1729 -- is located.
1731 New_Element : Array_Element_Id := No_Array_Element;
1732 -- Id of a new array element created
1734 Prev_Element : Array_Element_Id := No_Array_Element;
1735 -- Last new element id created
1737 Orig_Element : Array_Element_Id := No_Array_Element;
1738 -- Current array element in original associative array
1740 Next_Element : Array_Element_Id := No_Array_Element;
1741 -- Id of the array element that follows the new element. This is not
1742 -- always nil, because values for the associative array attribute may
1743 -- already have been declared, and the array elements declared are
1744 -- reused.
1746 Prj : Project_List;
1748 begin
1749 -- First find if the associative array attribute already has elements
1750 -- declared.
1752 if Pkg /= No_Package then
1753 New_Array := Shared.Packages.Table (Pkg).Decl.Arrays;
1754 else
1755 New_Array := Project.Decl.Arrays;
1756 end if;
1758 while New_Array /= No_Array
1759 and then Shared.Arrays.Table (New_Array).Name /= Current_Item_Name
1760 loop
1761 New_Array := Shared.Arrays.Table (New_Array).Next;
1762 end loop;
1764 -- If the attribute has never been declared add new entry in the
1765 -- arrays of the project/package and link it.
1767 if New_Array = No_Array then
1768 Array_Table.Increment_Last (Shared.Arrays);
1769 New_Array := Array_Table.Last (Shared.Arrays);
1771 if Pkg /= No_Package then
1772 Shared.Arrays.Table (New_Array) :=
1773 (Name => Current_Item_Name,
1774 Location => Current_Location,
1775 Value => No_Array_Element,
1776 Next => Shared.Packages.Table (Pkg).Decl.Arrays);
1778 Shared.Packages.Table (Pkg).Decl.Arrays := New_Array;
1780 else
1781 Shared.Arrays.Table (New_Array) :=
1782 (Name => Current_Item_Name,
1783 Location => Current_Location,
1784 Value => No_Array_Element,
1785 Next => Project.Decl.Arrays);
1787 Project.Decl.Arrays := New_Array;
1788 end if;
1789 end if;
1791 -- Find the project where the value is declared
1793 Orig_Project_Name :=
1794 Name_Of
1795 (Associative_Project_Of (Current_Item, Node_Tree), Node_Tree);
1797 Prj := In_Tree.Projects;
1798 while Prj /= null loop
1799 if Prj.Project.Name = Orig_Project_Name then
1800 Orig_Project := Prj.Project;
1801 exit;
1802 end if;
1803 Prj := Prj.Next;
1804 end loop;
1806 pragma Assert (Orig_Project /= No_Project,
1807 "original project not found");
1809 if No (Associative_Package_Of (Current_Item, Node_Tree)) then
1810 Orig_Array := Orig_Project.Decl.Arrays;
1812 else
1813 -- If in a package, find the package where the value is declared
1815 Orig_Package_Name :=
1816 Name_Of
1817 (Associative_Package_Of (Current_Item, Node_Tree), Node_Tree);
1819 Orig_Package := Orig_Project.Decl.Packages;
1820 pragma Assert (Orig_Package /= No_Package,
1821 "original package not found");
1823 while Shared.Packages.Table
1824 (Orig_Package).Name /= Orig_Package_Name
1825 loop
1826 Orig_Package := Shared.Packages.Table (Orig_Package).Next;
1827 pragma Assert (Orig_Package /= No_Package,
1828 "original package not found");
1829 end loop;
1831 Orig_Array := Shared.Packages.Table (Orig_Package).Decl.Arrays;
1832 end if;
1834 -- Now look for the array
1836 while Orig_Array /= No_Array
1837 and then Shared.Arrays.Table (Orig_Array).Name /= Current_Item_Name
1838 loop
1839 Orig_Array := Shared.Arrays.Table (Orig_Array).Next;
1840 end loop;
1842 if Orig_Array = No_Array then
1843 Error_Msg
1844 (Env.Flags,
1845 "associative array value not found",
1846 Location_Of (Current_Item, Node_Tree),
1847 Project);
1849 else
1850 Orig_Element := Shared.Arrays.Table (Orig_Array).Value;
1852 -- Copy each array element
1854 while Orig_Element /= No_Array_Element loop
1856 -- Case of first element
1858 if Prev_Element = No_Array_Element then
1860 -- And there is no array element declared yet, create a new
1861 -- first array element.
1863 if Shared.Arrays.Table (New_Array).Value =
1864 No_Array_Element
1865 then
1866 Array_Element_Table.Increment_Last
1867 (Shared.Array_Elements);
1868 New_Element := Array_Element_Table.Last
1869 (Shared.Array_Elements);
1870 Shared.Arrays.Table (New_Array).Value := New_Element;
1871 Next_Element := No_Array_Element;
1873 -- Otherwise, the new element is the first
1875 else
1876 New_Element := Shared.Arrays.Table (New_Array).Value;
1877 Next_Element :=
1878 Shared.Array_Elements.Table (New_Element).Next;
1879 end if;
1881 -- Otherwise, reuse an existing element, or create
1882 -- one if necessary.
1884 else
1885 Next_Element :=
1886 Shared.Array_Elements.Table (Prev_Element).Next;
1888 if Next_Element = No_Array_Element then
1889 Array_Element_Table.Increment_Last
1890 (Shared.Array_Elements);
1891 New_Element := Array_Element_Table.Last
1892 (Shared.Array_Elements);
1893 Shared.Array_Elements.Table (Prev_Element).Next :=
1894 New_Element;
1896 else
1897 New_Element := Next_Element;
1898 Next_Element :=
1899 Shared.Array_Elements.Table (New_Element).Next;
1900 end if;
1901 end if;
1903 -- Copy the value of the element
1905 Shared.Array_Elements.Table (New_Element) :=
1906 Shared.Array_Elements.Table (Orig_Element);
1907 Shared.Array_Elements.Table (New_Element).Value.Project
1908 := Project;
1910 -- Adjust the Next link
1912 Shared.Array_Elements.Table (New_Element).Next := Next_Element;
1914 -- Adjust the previous id for the next element
1916 Prev_Element := New_Element;
1918 -- Go to the next element in the original array
1920 Orig_Element := Shared.Array_Elements.Table (Orig_Element).Next;
1921 end loop;
1923 -- Make sure that the array ends here, in case there previously a
1924 -- greater number of elements.
1926 Shared.Array_Elements.Table (New_Element).Next := No_Array_Element;
1927 end if;
1928 end Process_Associative_Array;
1930 ----------------------------------------------
1931 -- Process_Expression_For_Associative_Array --
1932 ----------------------------------------------
1934 procedure Process_Expression_For_Associative_Array
1935 (Current : Project_Node_Id;
1936 New_Value : Variable_Value)
1938 Name : constant Name_Id := Name_Of (Current, Node_Tree);
1939 Current_Location : constant Source_Ptr :=
1940 Location_Of (Current, Node_Tree);
1942 Index_Name : Name_Id :=
1943 Associative_Array_Index_Of (Current, Node_Tree);
1945 Source_Index : constant Int :=
1946 Source_Index_Of (Current, Node_Tree);
1948 The_Array : Array_Id;
1949 Elem : Array_Element_Id := No_Array_Element;
1951 begin
1952 if Index_Name /= All_Other_Names then
1953 Index_Name := Get_Attribute_Index (Node_Tree, Current, Index_Name);
1954 end if;
1956 -- Look for the array in the appropriate list
1958 if Pkg /= No_Package then
1959 The_Array := Shared.Packages.Table (Pkg).Decl.Arrays;
1960 else
1961 The_Array := Project.Decl.Arrays;
1962 end if;
1964 while The_Array /= No_Array
1965 and then Shared.Arrays.Table (The_Array).Name /= Name
1966 loop
1967 The_Array := Shared.Arrays.Table (The_Array).Next;
1968 end loop;
1970 -- If the array cannot be found, create a new entry in the list.
1971 -- As The_Array_Element is initialized to No_Array_Element, a new
1972 -- element will be created automatically later
1974 if The_Array = No_Array then
1975 Array_Table.Increment_Last (Shared.Arrays);
1976 The_Array := Array_Table.Last (Shared.Arrays);
1978 if Pkg /= No_Package then
1979 Shared.Arrays.Table (The_Array) :=
1980 (Name => Name,
1981 Location => Current_Location,
1982 Value => No_Array_Element,
1983 Next => Shared.Packages.Table (Pkg).Decl.Arrays);
1985 Shared.Packages.Table (Pkg).Decl.Arrays := The_Array;
1987 else
1988 Shared.Arrays.Table (The_Array) :=
1989 (Name => Name,
1990 Location => Current_Location,
1991 Value => No_Array_Element,
1992 Next => Project.Decl.Arrays);
1994 Project.Decl.Arrays := The_Array;
1995 end if;
1997 else
1998 Elem := Shared.Arrays.Table (The_Array).Value;
1999 end if;
2001 -- Look in the list, if any, to find an element with the same index
2002 -- and same source index.
2004 while Elem /= No_Array_Element
2005 and then
2006 (Shared.Array_Elements.Table (Elem).Index /= Index_Name
2007 or else
2008 Shared.Array_Elements.Table (Elem).Src_Index /= Source_Index)
2009 loop
2010 Elem := Shared.Array_Elements.Table (Elem).Next;
2011 end loop;
2013 -- If no such element were found, create a new one
2014 -- and insert it in the element list, with the
2015 -- proper value.
2017 if Elem = No_Array_Element then
2018 Array_Element_Table.Increment_Last (Shared.Array_Elements);
2019 Elem := Array_Element_Table.Last (Shared.Array_Elements);
2021 Shared.Array_Elements.Table
2022 (Elem) :=
2023 (Index => Index_Name,
2024 Restricted => False,
2025 Src_Index => Source_Index,
2026 Index_Case_Sensitive =>
2027 not Case_Insensitive (Current, Node_Tree),
2028 Value => New_Value,
2029 Next => Shared.Arrays.Table (The_Array).Value);
2031 Shared.Arrays.Table (The_Array).Value := Elem;
2033 else
2034 -- An element with the same index already exists, just replace its
2035 -- value with the new one.
2037 Shared.Array_Elements.Table (Elem).Value := New_Value;
2038 end if;
2040 if Name = Snames.Name_External then
2041 if In_Tree.Is_Root_Tree then
2042 Add (Child_Env.External,
2043 External_Name => Get_Name_String (Index_Name),
2044 Value => Get_Name_String (New_Value.Value),
2045 Source => From_External_Attribute);
2046 Add (Env.External,
2047 External_Name => Get_Name_String (Index_Name),
2048 Value => Get_Name_String (New_Value.Value),
2049 Source => From_External_Attribute,
2050 Silent => True);
2051 else
2052 if Current_Verbosity = High then
2053 Debug_Output
2054 ("'for External' has no effect except in root aggregate ("
2055 & Get_Name_String (Index_Name) & ")", New_Value.Value);
2056 end if;
2057 end if;
2058 end if;
2059 end Process_Expression_For_Associative_Array;
2061 --------------------------------------
2062 -- Process_Expression_Variable_Decl --
2063 --------------------------------------
2065 procedure Process_Expression_Variable_Decl
2066 (Current_Item : Project_Node_Id;
2067 New_Value : Variable_Value)
2069 Name : constant Name_Id := Name_Of (Current_Item, Node_Tree);
2071 Is_Attribute : constant Boolean :=
2072 Kind_Of (Current_Item, Node_Tree) =
2073 N_Attribute_Declaration;
2075 Var : Variable_Id := No_Variable;
2077 begin
2078 -- First, find the list where to find the variable or attribute
2080 if Is_Attribute then
2081 if Pkg /= No_Package then
2082 Var := Shared.Packages.Table (Pkg).Decl.Attributes;
2083 else
2084 Var := Project.Decl.Attributes;
2085 end if;
2087 else
2088 if Pkg /= No_Package then
2089 Var := Shared.Packages.Table (Pkg).Decl.Variables;
2090 else
2091 Var := Project.Decl.Variables;
2092 end if;
2093 end if;
2095 -- Loop through the list, to find if it has already been declared
2097 while Var /= No_Variable
2098 and then Shared.Variable_Elements.Table (Var).Name /= Name
2099 loop
2100 Var := Shared.Variable_Elements.Table (Var).Next;
2101 end loop;
2103 -- If it has not been declared, create a new entry in the list
2105 if Var = No_Variable then
2107 -- All single string attribute should already have been declared
2108 -- with a default empty string value.
2110 pragma Assert
2111 (not Is_Attribute,
2112 "illegal attribute declaration for " & Get_Name_String (Name));
2114 Variable_Element_Table.Increment_Last (Shared.Variable_Elements);
2115 Var := Variable_Element_Table.Last (Shared.Variable_Elements);
2117 -- Put the new variable in the appropriate list
2119 if Pkg /= No_Package then
2120 Shared.Variable_Elements.Table (Var) :=
2121 (Next => Shared.Packages.Table (Pkg).Decl.Variables,
2122 Name => Name,
2123 Value => New_Value);
2124 Shared.Packages.Table (Pkg).Decl.Variables := Var;
2126 else
2127 Shared.Variable_Elements.Table (Var) :=
2128 (Next => Project.Decl.Variables,
2129 Name => Name,
2130 Value => New_Value);
2131 Project.Decl.Variables := Var;
2132 end if;
2134 -- If the variable/attribute has already been declared, just
2135 -- change the value.
2137 else
2138 Shared.Variable_Elements.Table (Var).Value := New_Value;
2139 end if;
2141 if Is_Attribute and then Name = Snames.Name_Project_Path then
2142 if In_Tree.Is_Root_Tree then
2143 declare
2144 package Name_Ids is
2145 new Ada.Containers.Vectors (Positive, Name_Id);
2146 Val : String_List_Id := New_Value.Values;
2147 List : Name_Ids.Vector;
2148 begin
2149 -- Get all values
2151 while Val /= Nil_String loop
2152 List.Prepend
2153 (Shared.String_Elements.Table (Val).Value);
2154 Val := Shared.String_Elements.Table (Val).Next;
2155 end loop;
2157 -- Prepend them in the order found in the attribute
2159 for K in Positive range 1 .. Positive (List.Length) loop
2160 Prj.Env.Add_Directories
2161 (Child_Env.Project_Path,
2162 Normalize_Pathname
2163 (Name => Get_Name_String
2164 (List.Element (K)),
2165 Directory => Get_Name_String
2166 (Project.Directory.Display_Name)),
2167 Prepend => True);
2168 end loop;
2169 end;
2171 else
2172 if Current_Verbosity = High then
2173 Debug_Output
2174 ("'for Project_Path' has no effect except in"
2175 & " root aggregate");
2176 end if;
2177 end if;
2178 end if;
2179 end Process_Expression_Variable_Decl;
2181 ------------------------
2182 -- Process_Expression --
2183 ------------------------
2185 procedure Process_Expression (Current : Project_Node_Id) is
2186 New_Value : Variable_Value :=
2187 Expression
2188 (Project => Project,
2189 Shared => Shared,
2190 From_Project_Node => From_Project_Node,
2191 From_Project_Node_Tree => Node_Tree,
2192 Env => Env,
2193 Pkg => Pkg,
2194 First_Term =>
2195 Tree.First_Term
2196 (Expression_Of (Current, Node_Tree), Node_Tree),
2197 Kind =>
2198 Expression_Kind_Of (Current, Node_Tree));
2200 begin
2201 -- Process a typed variable declaration
2203 if Kind_Of (Current, Node_Tree) = N_Typed_Variable_Declaration then
2204 Check_Or_Set_Typed_Variable (New_Value, Current);
2205 end if;
2207 if Kind_Of (Current, Node_Tree) /= N_Attribute_Declaration
2208 or else Associative_Array_Index_Of (Current, Node_Tree) = No_Name
2209 then
2210 Process_Expression_Variable_Decl (Current, New_Value);
2211 else
2212 Process_Expression_For_Associative_Array (Current, New_Value);
2213 end if;
2214 end Process_Expression;
2216 -----------------------------------
2217 -- Process_Attribute_Declaration --
2218 -----------------------------------
2220 procedure Process_Attribute_Declaration (Current : Project_Node_Id) is
2221 begin
2222 if Expression_Of (Current, Node_Tree) = Empty_Node then
2223 Process_Associative_Array (Current);
2224 else
2225 Process_Expression (Current);
2226 end if;
2227 end Process_Attribute_Declaration;
2229 -------------------------------
2230 -- Process_Case_Construction --
2231 -------------------------------
2233 procedure Process_Case_Construction
2234 (Current_Item : Project_Node_Id)
2236 The_Project : Project_Id := Project;
2237 -- The id of the project of the case variable
2239 The_Package : Package_Id := Pkg;
2240 -- The id of the package, if any, of the case variable
2242 The_Variable : Variable_Value := Nil_Variable_Value;
2243 -- The case variable
2245 Case_Value : Name_Id := No_Name;
2246 -- The case variable value
2248 Case_Item : Project_Node_Id := Empty_Node;
2249 Choice_String : Project_Node_Id := Empty_Node;
2250 Decl_Item : Project_Node_Id := Empty_Node;
2252 begin
2253 declare
2254 Variable_Node : constant Project_Node_Id :=
2255 Case_Variable_Reference_Of
2256 (Current_Item,
2257 Node_Tree);
2259 Var_Id : Variable_Id := No_Variable;
2260 Name : Name_Id := No_Name;
2262 begin
2263 -- If a project was specified for the case variable, get its id
2265 if Present (Project_Node_Of (Variable_Node, Node_Tree)) then
2266 Name :=
2267 Name_Of
2268 (Project_Node_Of (Variable_Node, Node_Tree), Node_Tree);
2269 The_Project :=
2270 Imported_Or_Extended_Project_From (Project, Name);
2271 end if;
2273 -- If a package was specified for the case variable, get its id
2275 if Present (Package_Node_Of (Variable_Node, Node_Tree)) then
2276 Name :=
2277 Name_Of
2278 (Package_Node_Of (Variable_Node, Node_Tree), Node_Tree);
2279 The_Package := Package_From (The_Project, Shared, Name);
2280 end if;
2282 Name := Name_Of (Variable_Node, Node_Tree);
2284 -- First, look for the case variable into the package, if any
2286 if The_Package /= No_Package then
2287 Name := Name_Of (Variable_Node, Node_Tree);
2289 Var_Id := Shared.Packages.Table (The_Package).Decl.Variables;
2290 while Var_Id /= No_Variable
2291 and then Shared.Variable_Elements.Table (Var_Id).Name /= Name
2292 loop
2293 Var_Id := Shared.Variable_Elements.Table (Var_Id).Next;
2294 end loop;
2295 end if;
2297 -- If not found in the package, or if there is no package, look at
2298 -- the project level.
2300 if Var_Id = No_Variable
2301 and then No (Package_Node_Of (Variable_Node, Node_Tree))
2302 then
2303 Var_Id := The_Project.Decl.Variables;
2304 while Var_Id /= No_Variable
2305 and then Shared.Variable_Elements.Table (Var_Id).Name /= Name
2306 loop
2307 Var_Id := Shared.Variable_Elements.Table (Var_Id).Next;
2308 end loop;
2309 end if;
2311 if Var_Id = No_Variable then
2313 -- Should never happen, because this has already been checked
2314 -- during parsing.
2316 Write_Line
2317 ("variable """ & Get_Name_String (Name) & """ not found");
2318 raise Program_Error;
2319 end if;
2321 -- Get the case variable
2323 The_Variable := Shared.Variable_Elements. Table (Var_Id).Value;
2325 if The_Variable.Kind /= Single then
2327 -- Should never happen, because this has already been checked
2328 -- during parsing.
2330 Write_Line ("variable""" & Get_Name_String (Name) &
2331 """ is not a single string variable");
2332 raise Program_Error;
2333 end if;
2335 -- Get the case variable value
2337 Case_Value := The_Variable.Value;
2338 end;
2340 -- Now look into all the case items of the case construction
2342 Case_Item := First_Case_Item_Of (Current_Item, Node_Tree);
2344 Case_Item_Loop :
2345 while Present (Case_Item) loop
2346 Choice_String := First_Choice_Of (Case_Item, Node_Tree);
2348 -- When Choice_String is nil, it means that it is the
2349 -- "when others =>" alternative.
2351 if No (Choice_String) then
2352 Decl_Item := First_Declarative_Item_Of (Case_Item, Node_Tree);
2353 exit Case_Item_Loop;
2354 end if;
2356 -- Look into all the alternative of this case item
2358 Choice_Loop :
2359 while Present (Choice_String) loop
2360 if Case_Value = String_Value_Of (Choice_String, Node_Tree) then
2361 Decl_Item :=
2362 First_Declarative_Item_Of (Case_Item, Node_Tree);
2363 exit Case_Item_Loop;
2364 end if;
2366 Choice_String := Next_Literal_String (Choice_String, Node_Tree);
2367 end loop Choice_Loop;
2369 Case_Item := Next_Case_Item (Case_Item, Node_Tree);
2370 end loop Case_Item_Loop;
2372 -- If there is an alternative, then we process it
2374 if Present (Decl_Item) then
2375 Process_Declarative_Items
2376 (Project => Project,
2377 In_Tree => In_Tree,
2378 From_Project_Node => From_Project_Node,
2379 Node_Tree => Node_Tree,
2380 Env => Env,
2381 Pkg => Pkg,
2382 Item => Decl_Item,
2383 Child_Env => Child_Env);
2384 end if;
2385 end Process_Case_Construction;
2387 -- Local variables
2389 Current, Decl : Project_Node_Id;
2390 Kind : Project_Node_Kind;
2392 -- Start of processing for Process_Declarative_Items
2394 begin
2395 Decl := Item;
2396 while Present (Decl) loop
2397 Current := Current_Item_Node (Decl, Node_Tree);
2398 Decl := Next_Declarative_Item (Decl, Node_Tree);
2399 Kind := Kind_Of (Current, Node_Tree);
2401 case Kind is
2402 when N_Package_Declaration =>
2403 Process_Package_Declaration (Current);
2405 -- Nothing to process for string type declaration
2407 when N_String_Type_Declaration =>
2408 null;
2410 when N_Attribute_Declaration |
2411 N_Typed_Variable_Declaration |
2412 N_Variable_Declaration =>
2413 Process_Attribute_Declaration (Current);
2415 when N_Case_Construction =>
2416 Process_Case_Construction (Current);
2418 when others =>
2419 Write_Line ("Illegal declarative item: " & Kind'Img);
2420 raise Program_Error;
2421 end case;
2422 end loop;
2423 end Process_Declarative_Items;
2425 ----------------------------------
2426 -- Process_Project_Tree_Phase_1 --
2427 ----------------------------------
2429 procedure Process_Project_Tree_Phase_1
2430 (In_Tree : Project_Tree_Ref;
2431 Project : out Project_Id;
2432 Packages_To_Check : String_List_Access;
2433 Success : out Boolean;
2434 From_Project_Node : Project_Node_Id;
2435 From_Project_Node_Tree : Project_Node_Tree_Ref;
2436 Env : in out Prj.Tree.Environment;
2437 Reset_Tree : Boolean := True;
2438 On_New_Tree_Loaded : Tree_Loaded_Callback := null)
2440 begin
2441 if Reset_Tree then
2443 -- Make sure there are no projects in the data structure
2445 Free_List (In_Tree.Projects, Free_Project => True);
2446 end if;
2448 Processed_Projects.Reset;
2450 -- And process the main project and all of the projects it depends on,
2451 -- recursively.
2453 Debug_Increase_Indent ("Process tree, phase 1");
2455 Recursive_Process
2456 (Project => Project,
2457 In_Tree => In_Tree,
2458 Packages_To_Check => Packages_To_Check,
2459 From_Project_Node => From_Project_Node,
2460 From_Project_Node_Tree => From_Project_Node_Tree,
2461 Env => Env,
2462 Extended_By => No_Project,
2463 From_Encapsulated_Lib => False,
2464 On_New_Tree_Loaded => On_New_Tree_Loaded);
2466 Success :=
2467 Total_Errors_Detected = 0
2468 and then
2469 (Warning_Mode /= Treat_As_Error or else Warnings_Detected = 0);
2471 if Current_Verbosity = High then
2472 Debug_Decrease_Indent
2473 ("Done Process tree, phase 1, Success=" & Success'Img);
2474 end if;
2475 end Process_Project_Tree_Phase_1;
2477 ----------------------------------
2478 -- Process_Project_Tree_Phase_2 --
2479 ----------------------------------
2481 procedure Process_Project_Tree_Phase_2
2482 (In_Tree : Project_Tree_Ref;
2483 Project : Project_Id;
2484 Success : out Boolean;
2485 From_Project_Node : Project_Node_Id;
2486 From_Project_Node_Tree : Project_Node_Tree_Ref;
2487 Env : Environment)
2489 Obj_Dir : Path_Name_Type;
2490 Extending : Project_Id;
2491 Extending2 : Project_Id;
2492 Prj : Project_List;
2494 -- Start of processing for Process_Project_Tree_Phase_2
2496 begin
2497 Success := True;
2499 Debug_Increase_Indent ("Process tree, phase 2", Project.Name);
2501 if Project /= No_Project then
2502 Check (In_Tree, Project, From_Project_Node_Tree, Env.Flags);
2503 end if;
2505 -- If main project is an extending all project, set object directory of
2506 -- all virtual extending projects to object directory of main project.
2508 if Project /= No_Project
2509 and then Is_Extending_All (From_Project_Node, From_Project_Node_Tree)
2510 then
2511 declare
2512 Object_Dir : constant Path_Information := Project.Object_Directory;
2514 begin
2515 Prj := In_Tree.Projects;
2516 while Prj /= null loop
2517 if Prj.Project.Virtual then
2518 Prj.Project.Object_Directory := Object_Dir;
2519 end if;
2521 Prj := Prj.Next;
2522 end loop;
2523 end;
2524 end if;
2526 -- Check that no extending project shares its object directory with
2527 -- the project(s) it extends.
2529 if Project /= No_Project then
2530 Prj := In_Tree.Projects;
2531 while Prj /= null loop
2532 Extending := Prj.Project.Extended_By;
2534 if Extending /= No_Project then
2535 Obj_Dir := Prj.Project.Object_Directory.Name;
2537 -- Check that a project being extended does not share its
2538 -- object directory with any project that extends it, directly
2539 -- or indirectly, including a virtual extending project.
2541 -- Start with the project directly extending it
2543 Extending2 := Extending;
2544 while Extending2 /= No_Project loop
2545 if Has_Ada_Sources (Extending2)
2546 and then Extending2.Object_Directory.Name = Obj_Dir
2547 then
2548 if Extending2.Virtual then
2549 Error_Msg_Name_1 := Prj.Project.Display_Name;
2550 Error_Msg
2551 (Env.Flags,
2552 "project %% cannot be extended by a virtual" &
2553 " project with the same object directory",
2554 Prj.Project.Location, Project);
2556 else
2557 Error_Msg_Name_1 := Extending2.Display_Name;
2558 Error_Msg_Name_2 := Prj.Project.Display_Name;
2559 Error_Msg
2560 (Env.Flags,
2561 "project %% cannot extend project %%",
2562 Extending2.Location, Project);
2563 Error_Msg
2564 (Env.Flags,
2565 "\they share the same object directory",
2566 Extending2.Location, Project);
2567 end if;
2568 end if;
2570 -- Continue with the next extending project, if any
2572 Extending2 := Extending2.Extended_By;
2573 end loop;
2574 end if;
2576 Prj := Prj.Next;
2577 end loop;
2578 end if;
2580 Debug_Decrease_Indent ("Done Process tree, phase 2");
2582 Success := Total_Errors_Detected = 0
2583 and then
2584 (Warning_Mode /= Treat_As_Error or else Warnings_Detected = 0);
2585 end Process_Project_Tree_Phase_2;
2587 -----------------------
2588 -- Recursive_Process --
2589 -----------------------
2591 procedure Recursive_Process
2592 (In_Tree : Project_Tree_Ref;
2593 Project : out Project_Id;
2594 Packages_To_Check : String_List_Access;
2595 From_Project_Node : Project_Node_Id;
2596 From_Project_Node_Tree : Project_Node_Tree_Ref;
2597 Env : in out Prj.Tree.Environment;
2598 Extended_By : Project_Id;
2599 From_Encapsulated_Lib : Boolean;
2600 On_New_Tree_Loaded : Tree_Loaded_Callback := null)
2602 Shared : constant Shared_Project_Tree_Data_Access := In_Tree.Shared;
2604 Child_Env : Prj.Tree.Environment;
2605 -- Only used for the root aggregate project (if any). This is left
2606 -- uninitialized otherwise.
2608 procedure Process_Imported_Projects
2609 (Imported : in out Project_List;
2610 Limited_With : Boolean);
2611 -- Process imported projects. If Limited_With is True, then only
2612 -- projects processed through a "limited with" are processed, otherwise
2613 -- only projects imported through a standard "with" are processed.
2614 -- Imported is the id of the last imported project.
2616 procedure Process_Aggregated_Projects;
2617 -- Process all the projects aggregated in List. This does nothing if the
2618 -- project is not an aggregate project.
2620 procedure Process_Extended_Project;
2621 -- Process the extended project: inherit all packages from the extended
2622 -- project that are not explicitly defined or renamed. Also inherit the
2623 -- languages, if attribute Languages is not explicitly defined.
2625 -------------------------------
2626 -- Process_Imported_Projects --
2627 -------------------------------
2629 procedure Process_Imported_Projects
2630 (Imported : in out Project_List;
2631 Limited_With : Boolean)
2633 With_Clause : Project_Node_Id;
2634 New_Project : Project_Id;
2635 Proj_Node : Project_Node_Id;
2637 begin
2638 With_Clause :=
2639 First_With_Clause_Of
2640 (From_Project_Node, From_Project_Node_Tree);
2642 while Present (With_Clause) loop
2643 Proj_Node :=
2644 Non_Limited_Project_Node_Of
2645 (With_Clause, From_Project_Node_Tree);
2646 New_Project := No_Project;
2648 if (Limited_With and then No (Proj_Node))
2649 or else (not Limited_With and then Present (Proj_Node))
2650 then
2651 Recursive_Process
2652 (In_Tree => In_Tree,
2653 Project => New_Project,
2654 Packages_To_Check => Packages_To_Check,
2655 From_Project_Node =>
2656 Project_Node_Of (With_Clause, From_Project_Node_Tree),
2657 From_Project_Node_Tree => From_Project_Node_Tree,
2658 Env => Env,
2659 Extended_By => No_Project,
2660 From_Encapsulated_Lib => From_Encapsulated_Lib,
2661 On_New_Tree_Loaded => On_New_Tree_Loaded);
2663 if Imported = null then
2664 Project.Imported_Projects := new Project_List_Element'
2665 (Project => New_Project,
2666 From_Encapsulated_Lib => False,
2667 Next => null);
2668 Imported := Project.Imported_Projects;
2669 else
2670 Imported.Next := new Project_List_Element'
2671 (Project => New_Project,
2672 From_Encapsulated_Lib => False,
2673 Next => null);
2674 Imported := Imported.Next;
2675 end if;
2676 end if;
2678 With_Clause :=
2679 Next_With_Clause_Of (With_Clause, From_Project_Node_Tree);
2680 end loop;
2681 end Process_Imported_Projects;
2683 ---------------------------------
2684 -- Process_Aggregated_Projects --
2685 ---------------------------------
2687 procedure Process_Aggregated_Projects is
2688 List : Aggregated_Project_List;
2689 Loaded_Project : Prj.Tree.Project_Node_Id;
2690 Success : Boolean := True;
2691 Tree : Project_Tree_Ref;
2692 Node_Tree : Project_Node_Tree_Ref;
2694 begin
2695 if Project.Qualifier not in Aggregate_Project then
2696 return;
2697 end if;
2699 Debug_Increase_Indent ("Process_Aggregated_Projects", Project.Name);
2701 Prj.Nmsc.Process_Aggregated_Projects
2702 (Tree => In_Tree,
2703 Project => Project,
2704 Node_Tree => From_Project_Node_Tree,
2705 Flags => Env.Flags);
2707 List := Project.Aggregated_Projects;
2708 while Success and then List /= null loop
2709 Node_Tree := new Project_Node_Tree_Data;
2710 Initialize (Node_Tree);
2712 Prj.Part.Parse
2713 (In_Tree => Node_Tree,
2714 Project => Loaded_Project,
2715 Packages_To_Check => Packages_To_Check,
2716 Project_File_Name => Get_Name_String (List.Path),
2717 Errout_Handling => Prj.Part.Never_Finalize,
2718 Current_Directory => Get_Name_String (Project.Directory.Name),
2719 Is_Config_File => False,
2720 Env => Child_Env);
2722 Success := not Prj.Tree.No (Loaded_Project);
2724 if Success then
2725 List.Tree := new Project_Tree_Data (Is_Root_Tree => False);
2726 Prj.Initialize (List.Tree);
2727 List.Tree.Shared := In_Tree.Shared;
2729 -- In aggregate library, aggregated projects are parsed using
2730 -- the aggregate library tree.
2732 if Project.Qualifier = Aggregate_Library then
2733 Tree := In_Tree;
2734 else
2735 Tree := List.Tree;
2736 end if;
2738 -- We can only do the phase 1 of the processing, since we do
2739 -- not have access to the configuration file yet (this is
2740 -- called when doing phase 1 of the processing for the root
2741 -- aggregate project).
2743 if In_Tree.Is_Root_Tree then
2744 Process_Project_Tree_Phase_1
2745 (In_Tree => Tree,
2746 Project => List.Project,
2747 Packages_To_Check => Packages_To_Check,
2748 Success => Success,
2749 From_Project_Node => Loaded_Project,
2750 From_Project_Node_Tree => Node_Tree,
2751 Env => Child_Env,
2752 Reset_Tree => False,
2753 On_New_Tree_Loaded => On_New_Tree_Loaded);
2754 else
2755 -- use the same environment as the rest of the aggregated
2756 -- projects, ie the one that was setup by the root aggregate
2757 Process_Project_Tree_Phase_1
2758 (In_Tree => Tree,
2759 Project => List.Project,
2760 Packages_To_Check => Packages_To_Check,
2761 Success => Success,
2762 From_Project_Node => Loaded_Project,
2763 From_Project_Node_Tree => Node_Tree,
2764 Env => Env,
2765 Reset_Tree => False,
2766 On_New_Tree_Loaded => On_New_Tree_Loaded);
2767 end if;
2769 if On_New_Tree_Loaded /= null then
2770 On_New_Tree_Loaded
2771 (Node_Tree, Tree, Loaded_Project, List.Project);
2772 end if;
2774 else
2775 Debug_Output ("Failed to parse", Name_Id (List.Path));
2776 end if;
2778 List := List.Next;
2779 end loop;
2781 Debug_Decrease_Indent ("Done Process_Aggregated_Projects");
2782 end Process_Aggregated_Projects;
2784 ------------------------------
2785 -- Process_Extended_Project --
2786 ------------------------------
2788 procedure Process_Extended_Project is
2789 Extended_Pkg : Package_Id;
2790 Current_Pkg : Package_Id;
2791 Element : Package_Element;
2792 First : constant Package_Id := Project.Decl.Packages;
2793 Attribute1 : Variable_Id;
2794 Attribute2 : Variable_Id;
2795 Attr_Value1 : Variable;
2796 Attr_Value2 : Variable;
2798 begin
2799 Extended_Pkg := Project.Extends.Decl.Packages;
2800 while Extended_Pkg /= No_Package loop
2801 Element := Shared.Packages.Table (Extended_Pkg);
2803 Current_Pkg := First;
2804 while Current_Pkg /= No_Package
2805 and then
2806 Shared.Packages.Table (Current_Pkg).Name /= Element.Name
2807 loop
2808 Current_Pkg := Shared.Packages.Table (Current_Pkg).Next;
2809 end loop;
2811 if Current_Pkg = No_Package then
2812 Package_Table.Increment_Last (Shared.Packages);
2813 Current_Pkg := Package_Table.Last (Shared.Packages);
2814 Shared.Packages.Table (Current_Pkg) :=
2815 (Name => Element.Name,
2816 Decl => No_Declarations,
2817 Parent => No_Package,
2818 Next => Project.Decl.Packages);
2819 Project.Decl.Packages := Current_Pkg;
2820 Copy_Package_Declarations
2821 (From => Element.Decl,
2822 To => Shared.Packages.Table (Current_Pkg).Decl,
2823 New_Loc => No_Location,
2824 Restricted => True,
2825 Shared => Shared);
2826 end if;
2828 Extended_Pkg := Element.Next;
2829 end loop;
2831 -- Check if attribute Languages is declared in the extending project
2833 Attribute1 := Project.Decl.Attributes;
2834 while Attribute1 /= No_Variable loop
2835 Attr_Value1 := Shared.Variable_Elements. Table (Attribute1);
2836 exit when Attr_Value1.Name = Snames.Name_Languages;
2837 Attribute1 := Attr_Value1.Next;
2838 end loop;
2840 if Attribute1 = No_Variable or else Attr_Value1.Value.Default then
2842 -- Attribute Languages is not declared in the extending project.
2843 -- Check if it is declared in the project being extended.
2845 Attribute2 := Project.Extends.Decl.Attributes;
2846 while Attribute2 /= No_Variable loop
2847 Attr_Value2 := Shared.Variable_Elements.Table (Attribute2);
2848 exit when Attr_Value2.Name = Snames.Name_Languages;
2849 Attribute2 := Attr_Value2.Next;
2850 end loop;
2852 if Attribute2 /= No_Variable
2853 and then not Attr_Value2.Value.Default
2854 then
2855 -- As attribute Languages is declared in the project being
2856 -- extended, copy its value for the extending project.
2858 if Attribute1 = No_Variable then
2859 Variable_Element_Table.Increment_Last
2860 (Shared.Variable_Elements);
2861 Attribute1 := Variable_Element_Table.Last
2862 (Shared.Variable_Elements);
2863 Attr_Value1.Next := Project.Decl.Attributes;
2864 Project.Decl.Attributes := Attribute1;
2865 end if;
2867 Attr_Value1.Name := Snames.Name_Languages;
2868 Attr_Value1.Value := Attr_Value2.Value;
2869 Shared.Variable_Elements.Table (Attribute1) := Attr_Value1;
2870 end if;
2871 end if;
2872 end Process_Extended_Project;
2874 -- Start of processing for Recursive_Process
2876 begin
2877 if No (From_Project_Node) then
2878 Project := No_Project;
2880 else
2881 declare
2882 Imported, Mark : Project_List;
2883 Declaration_Node : Project_Node_Id := Empty_Node;
2885 Name : constant Name_Id :=
2886 Name_Of (From_Project_Node, From_Project_Node_Tree);
2888 Name_Node : constant Tree_Private_Part.Project_Name_And_Node :=
2889 Tree_Private_Part.Projects_Htable.Get
2890 (From_Project_Node_Tree.Projects_HT, Name);
2892 begin
2893 Project := Processed_Projects.Get (Name);
2895 if Project /= No_Project then
2897 -- Make sure that, when a project is extended, the project id
2898 -- of the project extending it is recorded in its data, even
2899 -- when it has already been processed as an imported project.
2900 -- This is for virtually extended projects.
2902 if Extended_By /= No_Project then
2903 Project.Extended_By := Extended_By;
2904 end if;
2906 return;
2907 end if;
2909 -- Check if the project is already in the tree
2911 Project := No_Project;
2913 declare
2914 List : Project_List := In_Tree.Projects;
2915 Path : constant Path_Name_Type :=
2916 Path_Name_Of (From_Project_Node,
2917 From_Project_Node_Tree);
2919 begin
2920 while List /= null loop
2921 if List.Project.Path.Display_Name = Path then
2922 Project := List.Project;
2923 exit;
2924 end if;
2926 List := List.Next;
2927 end loop;
2928 end;
2930 if Project = No_Project then
2931 Project :=
2932 new Project_Data'
2933 (Empty_Project
2934 (Project_Qualifier_Of
2935 (From_Project_Node, From_Project_Node_Tree)));
2937 -- Note that at this point we do not know yet if the project
2938 -- has been withed from an encapsulated library or not.
2940 In_Tree.Projects :=
2941 new Project_List_Element'
2942 (Project => Project,
2943 From_Encapsulated_Lib => False,
2944 Next => In_Tree.Projects);
2945 end if;
2947 -- Keep track of this point
2949 Mark := In_Tree.Projects;
2951 Processed_Projects.Set (Name, Project);
2953 Project.Name := Name;
2954 Project.Display_Name := Name_Node.Display_Name;
2955 Get_Name_String (Name);
2957 -- If name starts with the virtual prefix, flag the project as
2958 -- being a virtual extending project.
2960 if Name_Len > Virtual_Prefix'Length
2961 and then
2962 Name_Buffer (1 .. Virtual_Prefix'Length) = Virtual_Prefix
2963 then
2964 Project.Virtual := True;
2965 end if;
2967 Project.Path.Display_Name :=
2968 Path_Name_Of (From_Project_Node, From_Project_Node_Tree);
2969 Get_Name_String (Project.Path.Display_Name);
2970 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
2971 Project.Path.Name := Name_Find;
2973 Project.Location :=
2974 Location_Of (From_Project_Node, From_Project_Node_Tree);
2976 Project.Directory.Display_Name :=
2977 Directory_Of (From_Project_Node, From_Project_Node_Tree);
2978 Get_Name_String (Project.Directory.Display_Name);
2979 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
2980 Project.Directory.Name := Name_Find;
2982 Project.Extended_By := Extended_By;
2984 Add_Attributes
2985 (Project,
2986 Name,
2987 Name_Id (Project.Directory.Display_Name),
2988 In_Tree.Shared,
2989 Project.Decl,
2990 Prj.Attr.Attribute_First,
2991 Project_Level => True);
2993 Process_Imported_Projects (Imported, Limited_With => False);
2995 if Project.Qualifier = Aggregate then
2996 Initialize_And_Copy (Child_Env, Copy_From => Env);
2998 elsif Project.Qualifier = Aggregate_Library then
3000 -- The child environment is the same as the current one
3002 Child_Env := Env;
3004 else
3005 -- No need to initialize Child_Env, since it will not be
3006 -- used anyway by Process_Declarative_Items (only the root
3007 -- aggregate can modify it, and it is never read anyway).
3009 null;
3010 end if;
3012 Declaration_Node :=
3013 Project_Declaration_Of
3014 (From_Project_Node, From_Project_Node_Tree);
3016 Recursive_Process
3017 (In_Tree => In_Tree,
3018 Project => Project.Extends,
3019 Packages_To_Check => Packages_To_Check,
3020 From_Project_Node =>
3021 Extended_Project_Of
3022 (Declaration_Node, From_Project_Node_Tree),
3023 From_Project_Node_Tree => From_Project_Node_Tree,
3024 Env => Env,
3025 Extended_By => Project,
3026 From_Encapsulated_Lib => From_Encapsulated_Lib,
3027 On_New_Tree_Loaded => On_New_Tree_Loaded);
3029 Process_Declarative_Items
3030 (Project => Project,
3031 In_Tree => In_Tree,
3032 From_Project_Node => From_Project_Node,
3033 Node_Tree => From_Project_Node_Tree,
3034 Env => Env,
3035 Pkg => No_Package,
3036 Item => First_Declarative_Item_Of
3037 (Declaration_Node, From_Project_Node_Tree),
3038 Child_Env => Child_Env);
3040 if Project.Extends /= No_Project then
3041 Process_Extended_Project;
3042 end if;
3044 Process_Imported_Projects (Imported, Limited_With => True);
3046 if Total_Errors_Detected = 0 then
3047 Process_Aggregated_Projects;
3048 end if;
3050 -- At this point (after Process_Declarative_Items) we have the
3051 -- attribute values set, we can backtrace In_Tree.Project and
3052 -- set the From_Encapsulated_Library status.
3054 declare
3055 Lib_Standalone : constant Prj.Variable_Value :=
3056 Prj.Util.Value_Of
3057 (Snames.Name_Library_Standalone,
3058 Project.Decl.Attributes,
3059 Shared);
3060 List : Project_List := In_Tree.Projects;
3061 Is_Encapsulated : Boolean;
3063 begin
3064 Get_Name_String (Lib_Standalone.Value);
3065 To_Lower (Name_Buffer (1 .. Name_Len));
3067 Is_Encapsulated := Name_Buffer (1 .. Name_Len) = "encapsulated";
3069 if Is_Encapsulated then
3070 while List /= null and then List /= Mark loop
3071 List.From_Encapsulated_Lib := Is_Encapsulated;
3072 List := List.Next;
3073 end loop;
3074 end if;
3076 if Total_Errors_Detected = 0 then
3078 -- For an aggregate library we add the aggregated projects
3079 -- as imported ones. This is necessary to give visibility
3080 -- to all sources from the aggregates from the aggregated
3081 -- library projects.
3083 if Project.Qualifier = Aggregate_Library then
3084 declare
3085 L : Aggregated_Project_List;
3086 begin
3087 L := Project.Aggregated_Projects;
3088 while L /= null loop
3089 Project.Imported_Projects :=
3090 new Project_List_Element'
3091 (Project => L.Project,
3092 From_Encapsulated_Lib => Is_Encapsulated,
3093 Next =>
3094 Project.Imported_Projects);
3095 L := L.Next;
3096 end loop;
3097 end;
3098 end if;
3099 end if;
3100 end;
3102 if Project.Qualifier = Aggregate and then In_Tree.Is_Root_Tree then
3103 Free (Child_Env);
3104 end if;
3105 end;
3106 end if;
3107 end Recursive_Process;
3109 end Prj.Proc;