?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Merge from mainline (163495:164578).
[official-gcc/graphite-test-results.git] / gcc / ada / prj-proc.adb
blob3cbb089ad0868dcc06505db70d5e08bb0bd73532
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-2010, 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 ------------------------------------------------------------------------------
25
26 with Err_Vars; use Err_Vars;
27 with Opt; use Opt;
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;
34 with Snames;
35
36 with GNAT.Case_Util; use GNAT.Case_Util;
37 with GNAT.HTable;
38
39 package body Prj.Proc is
40
41 package Processed_Projects is new GNAT.HTable.Simple_HTable
42 (Header_Num => Header_Num,
43 Element => Project_Id,
44 No_Element => No_Project,
45 Key => Name_Id,
46 Hash => Hash,
47 Equal => "=");
48 -- This hash table contains all processed projects
49
50 package Unit_Htable is new GNAT.HTable.Simple_HTable
51 (Header_Num => Header_Num,
52 Element => Source_Id,
53 No_Element => No_Source,
54 Key => Name_Id,
55 Hash => Hash,
56 Equal => "=");
57 -- This hash table contains all processed projects
58
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.
62
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 ???
66
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.
77
78 procedure Check
79 (In_Tree : Project_Tree_Ref;
80 Project : Project_Id;
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
87 -- based languages)
88
89 procedure Copy_Package_Declarations
90 (From : Declarations;
91 To : in out Declarations;
92 New_Loc : Source_Ptr;
93 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 Restricted is
97 -- True, do not copy attributes Body, Spec, Implementation, Specification
98 -- and Linker_Options.
99
100 function Expression
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;
106 Pkg : Package_Id;
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.
111
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
116
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
122
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;
129 Pkg : Package_Id;
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.
134
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
147 -- project.
148
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.
155
156 ---------
157 -- Add --
158 ---------
159
160 procedure Add (To_Exp : in out Name_Id; Str : Name_Id) is
161 begin
162 if To_Exp = No_Name or else To_Exp = Empty_String then
163
164 -- To_Exp is nil or empty. The result is Str
165
166 To_Exp := Str;
167
168 -- If Str is nil, then do not change To_Ext
169
170 elsif Str /= No_Name and then Str /= Empty_String then
171 declare
172 S : constant String := Get_Name_String (Str);
173 begin
174 Get_Name_String (To_Exp);
175 Add_Str_To_Name_Buffer (S);
176 To_Exp := Name_Find;
177 end;
178 end if;
179 end Add;
180
181 --------------------
182 -- Add_Attributes --
183 --------------------
184
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)
193 is
194 The_Attribute : Attribute_Node_Id := First;
195
196 begin
197 while The_Attribute /= Empty_Attribute loop
198 if Attribute_Kind_Of (The_Attribute) = Single then
199 declare
200 New_Attribute : Variable_Value;
201
202 begin
203 case Variable_Kind_Of (The_Attribute) is
204
205 -- Undefined should not happen
206
207 when Undefined =>
208 pragma Assert
209 (False, "attribute with an undefined kind");
210 raise Program_Error;
211
212 -- Single attributes have a default value of empty string
213
214 when Single =>
215 New_Attribute :=
216 (Project => Project,
217 Kind => Single,
218 Location => No_Location,
219 Default => True,
220 Value => Empty_String,
221 Index => 0);
222
223 -- Special cases of <project>'Name and
224 -- <project>'Project_Dir.
225
226 if Project_Level then
227 if Attribute_Name_Of (The_Attribute) =
228 Snames.Name_Name
229 then
230 New_Attribute.Value := Project_Name;
231
232 elsif Attribute_Name_Of (The_Attribute) =
233 Snames.Name_Project_Dir
234 then
235 New_Attribute.Value := Project_Dir;
236 end if;
237 end if;
238
239 -- List attributes have a default value of nil list
240
241 when List =>
242 New_Attribute :=
243 (Project => Project,
244 Kind => List,
245 Location => No_Location,
246 Default => True,
247 Values => Nil_String);
248
249 end case;
250
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);
261 end;
262 end if;
263
264 The_Attribute := Next_Attribute (After => The_Attribute);
265 end loop;
266 end Add_Attributes;
267
268 -----------
269 -- Check --
270 -----------
271
272 procedure Check
273 (In_Tree : Project_Tree_Ref;
274 Project : Project_Id;
275 Flags : Processing_Flags)
276 is
277 begin
278 Process_Naming_Scheme (In_Tree, Project, Flags);
279
280 -- Set the Other_Part field for the units
281
282 declare
283 Source1 : Source_Id;
284 Name : Name_Id;
285 Source2 : Source_Id;
286 Iter : Source_Iterator;
287
288 begin
289 Unit_Htable.Reset;
290
291 Iter := For_Each_Source (In_Tree);
292 loop
293 Source1 := Prj.Element (Iter);
294 exit when Source1 = No_Source;
295
296 if Source1.Unit /= No_Unit_Index then
297 Name := Source1.Unit.Name;
298 Source2 := Unit_Htable.Get (Name);
299
300 if Source2 = No_Source then
301 Unit_Htable.Set (K => Name, E => Source1);
302 else
303 Unit_Htable.Remove (Name);
304 end if;
305 end if;
306
307 Next (Iter);
308 end loop;
309 end;
310 end Check;
311
312 -------------------------------
313 -- Copy_Package_Declarations --
314 -------------------------------
315
316 procedure Copy_Package_Declarations
317 (From : Declarations;
318 To : in out Declarations;
319 New_Loc : Source_Ptr;
320 Restricted : Boolean;
321 In_Tree : Project_Tree_Ref)
322 is
323 V1 : Variable_Id;
324 V2 : Variable_Id := No_Variable;
325 Var : Variable;
326 A1 : Array_Id;
327 A2 : Array_Id := No_Array;
328 Arr : Array_Data;
329 E1 : Array_Element_Id;
330 E2 : Array_Element_Id := No_Array_Element;
331 Elm : Array_Element;
332
333 begin
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.
338
339 -- First single attributes
340
341 V1 := From.Attributes;
342 while V1 /= No_Variable loop
343
344 -- Copy the attribute
345
346 Var := In_Tree.Variable_Elements.Table (V1);
347 V1 := Var.Next;
348
349 -- Do not copy the value of attribute Linker_Options if Restricted
350
351 if Restricted and then Var.Name = Snames.Name_Linker_Options then
352 Var.Value.Values := Nil_String;
353 end if;
354
355 -- Remove the Next component
356
357 Var.Next := No_Variable;
358
359 -- Change the location to New_Loc
360
361 Var.Value.Location := New_Loc;
362 Variable_Element_Table.Increment_Last (In_Tree.Variable_Elements);
363
364 -- Put in new declaration
365
366 if To.Attributes = No_Variable then
367 To.Attributes :=
368 Variable_Element_Table.Last (In_Tree.Variable_Elements);
369 else
370 In_Tree.Variable_Elements.Table (V2).Next :=
371 Variable_Element_Table.Last (In_Tree.Variable_Elements);
372 end if;
373
374 V2 := Variable_Element_Table.Last (In_Tree.Variable_Elements);
375 In_Tree.Variable_Elements.Table (V2) := Var;
376 end loop;
377
378 -- Then the associated array attributes
379
380 A1 := From.Arrays;
381 while A1 /= No_Array loop
382 Arr := In_Tree.Arrays.Table (A1);
383 A1 := Arr.Next;
384
385 if not Restricted
386 or else
387 (Arr.Name /= Snames.Name_Body and then
388 Arr.Name /= Snames.Name_Spec and then
389 Arr.Name /= Snames.Name_Implementation and then
390 Arr.Name /= Snames.Name_Specification)
391 then
392 -- Remove the Next component
393
394 Arr.Next := No_Array;
395 Array_Table.Increment_Last (In_Tree.Arrays);
396
397 -- Create new Array declaration
398
399 if To.Arrays = No_Array then
400 To.Arrays := Array_Table.Last (In_Tree.Arrays);
401 else
402 In_Tree.Arrays.Table (A2).Next :=
403 Array_Table.Last (In_Tree.Arrays);
404 end if;
405
406 A2 := Array_Table.Last (In_Tree.Arrays);
407
408 -- Don't store the array as its first element has not been set yet
409
410 -- Copy the array elements of the array
411
412 E1 := Arr.Value;
413 Arr.Value := No_Array_Element;
414 while E1 /= No_Array_Element loop
415
416 -- Copy the array element
417
418 Elm := In_Tree.Array_Elements.Table (E1);
419 E1 := Elm.Next;
420
421 -- Remove the Next component
422
423 Elm.Next := No_Array_Element;
424
425 -- Change the location
426
427 Elm.Value.Location := New_Loc;
428 Array_Element_Table.Increment_Last (In_Tree.Array_Elements);
429
430 -- Create new array element
431
432 if Arr.Value = No_Array_Element then
433 Arr.Value :=
434 Array_Element_Table.Last (In_Tree.Array_Elements);
435 else
436 In_Tree.Array_Elements.Table (E2).Next :=
437 Array_Element_Table.Last (In_Tree.Array_Elements);
438 end if;
439
440 E2 := Array_Element_Table.Last (In_Tree.Array_Elements);
441 In_Tree.Array_Elements.Table (E2) := Elm;
442 end loop;
443
444 -- Finally, store the new array
445
446 In_Tree.Arrays.Table (A2) := Arr;
447 end if;
448 end loop;
449 end Copy_Package_Declarations;
450
451 -------------------------
452 -- Get_Attribute_Index --
453 -------------------------
454
455 function Get_Attribute_Index
456 (Tree : Project_Node_Tree_Ref;
457 Attr : Project_Node_Id;
458 Index : Name_Id) return Name_Id
459 is
460 Lower : Boolean;
461
462 begin
463 if Index = All_Other_Names then
464 return Index;
465 end if;
466
467 Get_Name_String (Index);
468 Lower := Case_Insensitive (Attr, Tree);
469
470 -- The index is always case insensitive if it does not include any dot.
471 -- ??? Why not use the properties from prj-attr, simply, maybe because
472 -- we don't know whether we have a file as an index?
473
474 if not Lower then
475 Lower := True;
476
477 for J in 1 .. Name_Len loop
478 if Name_Buffer (J) = '.' then
479 Lower := False;
480 exit;
481 end if;
482 end loop;
483 end if;
484
485 if Lower then
486 To_Lower (Name_Buffer (1 .. Name_Len));
487 return Name_Find;
488 else
489 return Index;
490 end if;
491 end Get_Attribute_Index;
492
493 ----------------
494 -- Expression --
495 ----------------
496
497 function Expression
498 (Project : Project_Id;
499 In_Tree : Project_Tree_Ref;
500 Flags : Processing_Flags;
501 From_Project_Node : Project_Node_Id;
502 From_Project_Node_Tree : Project_Node_Tree_Ref;
503 Pkg : Package_Id;
504 First_Term : Project_Node_Id;
505 Kind : Variable_Kind) return Variable_Value
506 is
507 The_Term : Project_Node_Id;
508 -- The term in the expression list
509
510 The_Current_Term : Project_Node_Id := Empty_Node;
511 -- The current term node id
512
513 Result : Variable_Value (Kind => Kind);
514 -- The returned result
515
516 Last : String_List_Id := Nil_String;
517 -- Reference to the last string elements in Result, when Kind is List
518
519 begin
520 Result.Project := Project;
521 Result.Location := Location_Of (First_Term, From_Project_Node_Tree);
522
523 -- Process each term of the expression, starting with First_Term
524
525 The_Term := First_Term;
526 while Present (The_Term) loop
527 The_Current_Term := Current_Term (The_Term, From_Project_Node_Tree);
528
529 case Kind_Of (The_Current_Term, From_Project_Node_Tree) is
530
531 when N_Literal_String =>
532
533 case Kind is
534
535 when Undefined =>
536
537 -- Should never happen
538
539 pragma Assert (False, "Undefined expression kind");
540 raise Program_Error;
541
542 when Single =>
543 Add (Result.Value,
544 String_Value_Of
545 (The_Current_Term, From_Project_Node_Tree));
546 Result.Index :=
547 Source_Index_Of
548 (The_Current_Term, From_Project_Node_Tree);
549
550 when List =>
551
552 String_Element_Table.Increment_Last
553 (In_Tree.String_Elements);
554
555 if Last = Nil_String then
556
557 -- This can happen in an expression like () & "toto"
558
559 Result.Values := String_Element_Table.Last
560 (In_Tree.String_Elements);
561
562 else
563 In_Tree.String_Elements.Table
564 (Last).Next := String_Element_Table.Last
565 (In_Tree.String_Elements);
566 end if;
567
568 Last := String_Element_Table.Last
569 (In_Tree.String_Elements);
570
571 In_Tree.String_Elements.Table (Last) :=
572 (Value => String_Value_Of
573 (The_Current_Term,
574 From_Project_Node_Tree),
575 Index => Source_Index_Of
576 (The_Current_Term,
577 From_Project_Node_Tree),
578 Display_Value => No_Name,
579 Location => Location_Of
580 (The_Current_Term,
581 From_Project_Node_Tree),
582 Flag => False,
583 Next => Nil_String);
584 end case;
585
586 when N_Literal_String_List =>
587
588 declare
589 String_Node : Project_Node_Id :=
590 First_Expression_In_List
591 (The_Current_Term,
592 From_Project_Node_Tree);
593
594 Value : Variable_Value;
595
596 begin
597 if Present (String_Node) then
598
599 -- If String_Node is nil, it is an empty list, there is
600 -- nothing to do
601
602 Value := Expression
603 (Project => Project,
604 In_Tree => In_Tree,
605 Flags => Flags,
606 From_Project_Node => From_Project_Node,
607 From_Project_Node_Tree => From_Project_Node_Tree,
608 Pkg => Pkg,
609 First_Term =>
610 Tree.First_Term
611 (String_Node, From_Project_Node_Tree),
612 Kind => Single);
613 String_Element_Table.Increment_Last
614 (In_Tree.String_Elements);
615
616 if Result.Values = Nil_String then
617
618 -- This literal string list is the first term in a
619 -- string list expression
620
621 Result.Values :=
622 String_Element_Table.Last (In_Tree.String_Elements);
623
624 else
625 In_Tree.String_Elements.Table
626 (Last).Next :=
627 String_Element_Table.Last (In_Tree.String_Elements);
628 end if;
629
630 Last :=
631 String_Element_Table.Last (In_Tree.String_Elements);
632
633 In_Tree.String_Elements.Table (Last) :=
634 (Value => Value.Value,
635 Display_Value => No_Name,
636 Location => Value.Location,
637 Flag => False,
638 Next => Nil_String,
639 Index => Value.Index);
640
641 loop
642 -- Add the other element of the literal string list
643 -- one after the other
644
645 String_Node :=
646 Next_Expression_In_List
647 (String_Node, From_Project_Node_Tree);
648
649 exit when No (String_Node);
650
651 Value :=
652 Expression
653 (Project => Project,
654 In_Tree => In_Tree,
655 Flags => Flags,
656 From_Project_Node => From_Project_Node,
657 From_Project_Node_Tree => From_Project_Node_Tree,
658 Pkg => Pkg,
659 First_Term =>
660 Tree.First_Term
661 (String_Node, From_Project_Node_Tree),
662 Kind => Single);
663
664 String_Element_Table.Increment_Last
665 (In_Tree.String_Elements);
666 In_Tree.String_Elements.Table
667 (Last).Next := String_Element_Table.Last
668 (In_Tree.String_Elements);
669 Last := String_Element_Table.Last
670 (In_Tree.String_Elements);
671 In_Tree.String_Elements.Table (Last) :=
672 (Value => Value.Value,
673 Display_Value => No_Name,
674 Location => Value.Location,
675 Flag => False,
676 Next => Nil_String,
677 Index => Value.Index);
678 end loop;
679 end if;
680 end;
681
682 when N_Variable_Reference | N_Attribute_Reference =>
683
684 declare
685 The_Project : Project_Id := Project;
686 The_Package : Package_Id := Pkg;
687 The_Name : Name_Id := No_Name;
688 The_Variable_Id : Variable_Id := No_Variable;
689 The_Variable : Variable_Value;
690 Term_Project : constant Project_Node_Id :=
691 Project_Node_Of
692 (The_Current_Term,
693 From_Project_Node_Tree);
694 Term_Package : constant Project_Node_Id :=
695 Package_Node_Of
696 (The_Current_Term,
697 From_Project_Node_Tree);
698 Index : Name_Id := No_Name;
699
700 begin
701 if Present (Term_Project) and then
702 Term_Project /= From_Project_Node
703 then
704 -- This variable or attribute comes from another project
705
706 The_Name :=
707 Name_Of (Term_Project, From_Project_Node_Tree);
708 The_Project := Imported_Or_Extended_Project_From
709 (Project => Project,
710 With_Name => The_Name);
711 end if;
712
713 if Present (Term_Package) then
714
715 -- This is an attribute of a package
716
717 The_Name :=
718 Name_Of (Term_Package, From_Project_Node_Tree);
719 The_Package := The_Project.Decl.Packages;
720
721 while The_Package /= No_Package
722 and then In_Tree.Packages.Table
723 (The_Package).Name /= The_Name
724 loop
725 The_Package :=
726 In_Tree.Packages.Table
727 (The_Package).Next;
728 end loop;
729
730 pragma Assert
731 (The_Package /= No_Package,
732 "package not found.");
733
734 elsif Kind_Of (The_Current_Term, From_Project_Node_Tree) =
735 N_Attribute_Reference
736 then
737 The_Package := No_Package;
738 end if;
739
740 The_Name :=
741 Name_Of (The_Current_Term, From_Project_Node_Tree);
742
743 if Kind_Of (The_Current_Term, From_Project_Node_Tree) =
744 N_Attribute_Reference
745 then
746 Index :=
747 Associative_Array_Index_Of
748 (The_Current_Term, From_Project_Node_Tree);
749 end if;
750
751 -- If it is not an associative array attribute
752
753 if Index = No_Name then
754
755 -- It is not an associative array attribute
756
757 if The_Package /= No_Package then
758
759 -- First, if there is a package, look into the package
760
761 if Kind_Of (The_Current_Term, From_Project_Node_Tree) =
762 N_Variable_Reference
763 then
764 The_Variable_Id :=
765 In_Tree.Packages.Table
766 (The_Package).Decl.Variables;
767 else
768 The_Variable_Id :=
769 In_Tree.Packages.Table
770 (The_Package).Decl.Attributes;
771 end if;
772
773 while The_Variable_Id /= No_Variable
774 and then
775 In_Tree.Variable_Elements.Table
776 (The_Variable_Id).Name /= The_Name
777 loop
778 The_Variable_Id :=
779 In_Tree.Variable_Elements.Table
780 (The_Variable_Id).Next;
781 end loop;
782
783 end if;
784
785 if The_Variable_Id = No_Variable then
786
787 -- If we have not found it, look into the project
788
789 if Kind_Of (The_Current_Term, From_Project_Node_Tree) =
790 N_Variable_Reference
791 then
792 The_Variable_Id := The_Project.Decl.Variables;
793 else
794 The_Variable_Id := The_Project.Decl.Attributes;
795 end if;
796
797 while The_Variable_Id /= No_Variable
798 and then
799 In_Tree.Variable_Elements.Table
800 (The_Variable_Id).Name /= The_Name
801 loop
802 The_Variable_Id :=
803 In_Tree.Variable_Elements.Table
804 (The_Variable_Id).Next;
805 end loop;
806
807 end if;
808
809 pragma Assert (The_Variable_Id /= No_Variable,
810 "variable or attribute not found");
811
812 The_Variable :=
813 In_Tree.Variable_Elements.Table
814 (The_Variable_Id).Value;
815
816 else
817
818 -- It is an associative array attribute
819
820 declare
821 The_Array : Array_Id := No_Array;
822 The_Element : Array_Element_Id := No_Array_Element;
823 Array_Index : Name_Id := No_Name;
824
825 begin
826 if The_Package /= No_Package then
827 The_Array :=
828 In_Tree.Packages.Table
829 (The_Package).Decl.Arrays;
830 else
831 The_Array := The_Project.Decl.Arrays;
832 end if;
833
834 while The_Array /= No_Array
835 and then In_Tree.Arrays.Table
836 (The_Array).Name /= The_Name
837 loop
838 The_Array := In_Tree.Arrays.Table
839 (The_Array).Next;
840 end loop;
841
842 if The_Array /= No_Array then
843 The_Element := In_Tree.Arrays.Table
844 (The_Array).Value;
845 Array_Index :=
846 Get_Attribute_Index
847 (From_Project_Node_Tree,
848 The_Current_Term,
849 Index);
850
851 while The_Element /= No_Array_Element
852 and then
853 In_Tree.Array_Elements.Table
854 (The_Element).Index /= Array_Index
855 loop
856 The_Element :=
857 In_Tree.Array_Elements.Table
858 (The_Element).Next;
859 end loop;
860
861 end if;
862
863 if The_Element /= No_Array_Element then
864 The_Variable :=
865 In_Tree.Array_Elements.Table
866 (The_Element).Value;
867
868 else
869 if Expression_Kind_Of
870 (The_Current_Term, From_Project_Node_Tree) =
871 List
872 then
873 The_Variable :=
874 (Project => Project,
875 Kind => List,
876 Location => No_Location,
877 Default => True,
878 Values => Nil_String);
879 else
880 The_Variable :=
881 (Project => Project,
882 Kind => Single,
883 Location => No_Location,
884 Default => True,
885 Value => Empty_String,
886 Index => 0);
887 end if;
888 end if;
889 end;
890 end if;
891
892 case Kind is
893
894 when Undefined =>
895
896 -- Should never happen
897
898 pragma Assert (False, "undefined expression kind");
899 null;
900
901 when Single =>
902
903 case The_Variable.Kind is
904
905 when Undefined =>
906 null;
907
908 when Single =>
909 Add (Result.Value, The_Variable.Value);
910
911 when List =>
912
913 -- Should never happen
914
915 pragma Assert
916 (False,
917 "list cannot appear in single " &
918 "string expression");
919 null;
920 end case;
921
922 when List =>
923 case The_Variable.Kind is
924
925 when Undefined =>
926 null;
927
928 when Single =>
929 String_Element_Table.Increment_Last
930 (In_Tree.String_Elements);
931
932 if Last = Nil_String then
933
934 -- This can happen in an expression such as
935 -- () & Var
936
937 Result.Values :=
938 String_Element_Table.Last
939 (In_Tree.String_Elements);
940
941 else
942 In_Tree.String_Elements.Table
943 (Last).Next :=
944 String_Element_Table.Last
945 (In_Tree.String_Elements);
946 end if;
947
948 Last :=
949 String_Element_Table.Last
950 (In_Tree.String_Elements);
951
952 In_Tree.String_Elements.Table (Last) :=
953 (Value => The_Variable.Value,
954 Display_Value => No_Name,
955 Location => Location_Of
956 (The_Current_Term,
957 From_Project_Node_Tree),
958 Flag => False,
959 Next => Nil_String,
960 Index => 0);
961
962 when List =>
963
964 declare
965 The_List : String_List_Id :=
966 The_Variable.Values;
967
968 begin
969 while The_List /= Nil_String loop
970 String_Element_Table.Increment_Last
971 (In_Tree.String_Elements);
972
973 if Last = Nil_String then
974 Result.Values :=
975 String_Element_Table.Last
976 (In_Tree.
977 String_Elements);
978
979 else
980 In_Tree.
981 String_Elements.Table (Last).Next :=
982 String_Element_Table.Last
983 (In_Tree.
984 String_Elements);
985
986 end if;
987
988 Last :=
989 String_Element_Table.Last
990 (In_Tree.String_Elements);
991
992 In_Tree.String_Elements.Table (Last) :=
993 (Value =>
994 In_Tree.String_Elements.Table
995 (The_List).Value,
996 Display_Value => No_Name,
997 Location =>
998 Location_Of
999 (The_Current_Term,
1000 From_Project_Node_Tree),
1001 Flag => False,
1002 Next => Nil_String,
1003 Index => 0);
1004
1005 The_List :=
1006 In_Tree. String_Elements.Table
1007 (The_List).Next;
1008 end loop;
1009 end;
1010 end case;
1011 end case;
1012 end;
1013
1014 when N_External_Value =>
1015 Get_Name_String
1016 (String_Value_Of
1017 (External_Reference_Of
1018 (The_Current_Term, From_Project_Node_Tree),
1019 From_Project_Node_Tree));
1020
1021 declare
1022 Name : constant Name_Id := Name_Find;
1023 Default : Name_Id := No_Name;
1024 Value : Name_Id := No_Name;
1025
1026 Def_Var : Variable_Value;
1027
1028 Default_Node : constant Project_Node_Id :=
1029 External_Default_Of
1030 (The_Current_Term, From_Project_Node_Tree);
1031
1032 begin
1033 -- If there is a default value for the external reference,
1034 -- get its value.
1035
1036 if Present (Default_Node) then
1037 Def_Var := Expression
1038 (Project => Project,
1039 In_Tree => In_Tree,
1040 Flags => Flags,
1041 From_Project_Node => From_Project_Node,
1042 From_Project_Node_Tree => From_Project_Node_Tree,
1043 Pkg => Pkg,
1044 First_Term =>
1045 Tree.First_Term
1046 (Default_Node, From_Project_Node_Tree),
1047 Kind => Single);
1048
1049 if Def_Var /= Nil_Variable_Value then
1050 Default := Def_Var.Value;
1051 end if;
1052 end if;
1053
1054 Value :=
1055 Prj.Ext.Value_Of (From_Project_Node_Tree, Name, Default);
1056
1057 if Value = No_Name then
1058 if not Quiet_Output then
1059 Error_Msg
1060 (Flags, "?undefined external reference",
1061 Location_Of
1062 (The_Current_Term, From_Project_Node_Tree),
1063 Project);
1064 end if;
1065
1066 Value := Empty_String;
1067 end if;
1068
1069 case Kind is
1070
1071 when Undefined =>
1072 null;
1073
1074 when Single =>
1075 Add (Result.Value, Value);
1076
1077 when List =>
1078 String_Element_Table.Increment_Last
1079 (In_Tree.String_Elements);
1080
1081 if Last = Nil_String then
1082 Result.Values := String_Element_Table.Last
1083 (In_Tree.String_Elements);
1084
1085 else
1086 In_Tree.String_Elements.Table
1087 (Last).Next := String_Element_Table.Last
1088 (In_Tree.String_Elements);
1089 end if;
1090
1091 Last := String_Element_Table.Last
1092 (In_Tree.String_Elements);
1093 In_Tree.String_Elements.Table (Last) :=
1094 (Value => Value,
1095 Display_Value => No_Name,
1096 Location =>
1097 Location_Of
1098 (The_Current_Term, From_Project_Node_Tree),
1099 Flag => False,
1100 Next => Nil_String,
1101 Index => 0);
1102
1103 end case;
1104 end;
1105
1106 when others =>
1107
1108 -- Should never happen
1109
1110 pragma Assert
1111 (False,
1112 "illegal node kind in an expression");
1113 raise Program_Error;
1114
1115 end case;
1116
1117 The_Term := Next_Term (The_Term, From_Project_Node_Tree);
1118 end loop;
1119
1120 return Result;
1121 end Expression;
1122
1123 ---------------------------------------
1124 -- Imported_Or_Extended_Project_From --
1125 ---------------------------------------
1126
1127 function Imported_Or_Extended_Project_From
1128 (Project : Project_Id;
1129 With_Name : Name_Id) return Project_Id
1130 is
1131 List : Project_List;
1132 Result : Project_Id;
1133 Temp_Result : Project_Id;
1134
1135 begin
1136 -- First check if it is the name of an extended project
1137
1138 Result := Project.Extends;
1139 while Result /= No_Project loop
1140 if Result.Name = With_Name then
1141 return Result;
1142 else
1143 Result := Result.Extends;
1144 end if;
1145 end loop;
1146
1147 -- Then check the name of each imported project
1148
1149 Temp_Result := No_Project;
1150 List := Project.Imported_Projects;
1151 while List /= null loop
1152 Result := List.Project;
1153
1154 -- If the project is directly imported, then returns its ID
1155
1156 if Result.Name = With_Name then
1157 return Result;
1158 end if;
1159
1160 -- If a project extending the project is imported, then keep this
1161 -- extending project as a possibility. It will be the returned ID
1162 -- if the project is not imported directly.
1163
1164 declare
1165 Proj : Project_Id;
1166
1167 begin
1168 Proj := Result.Extends;
1169 while Proj /= No_Project loop
1170 if Proj.Name = With_Name then
1171 Temp_Result := Result;
1172 exit;
1173 end if;
1174
1175 Proj := Proj.Extends;
1176 end loop;
1177 end;
1178
1179 List := List.Next;
1180 end loop;
1181
1182 pragma Assert (Temp_Result /= No_Project, "project not found");
1183 return Temp_Result;
1184 end Imported_Or_Extended_Project_From;
1185
1186 ------------------
1187 -- Package_From --
1188 ------------------
1189
1190 function Package_From
1191 (Project : Project_Id;
1192 In_Tree : Project_Tree_Ref;
1193 With_Name : Name_Id) return Package_Id
1194 is
1195 Result : Package_Id := Project.Decl.Packages;
1196
1197 begin
1198 -- Check the name of each existing package of Project
1199
1200 while Result /= No_Package
1201 and then In_Tree.Packages.Table (Result).Name /= With_Name
1202 loop
1203 Result := In_Tree.Packages.Table (Result).Next;
1204 end loop;
1205
1206 if Result = No_Package then
1207
1208 -- Should never happen
1209
1210 Write_Line ("package """ & Get_Name_String (With_Name) &
1211 """ not found");
1212 raise Program_Error;
1213
1214 else
1215 return Result;
1216 end if;
1217 end Package_From;
1218
1219 -------------
1220 -- Process --
1221 -------------
1222
1223 procedure Process
1224 (In_Tree : Project_Tree_Ref;
1225 Project : out Project_Id;
1226 Success : out Boolean;
1227 From_Project_Node : Project_Node_Id;
1228 From_Project_Node_Tree : Project_Node_Tree_Ref;
1229 Flags : Processing_Flags;
1230 Reset_Tree : Boolean := True)
1231 is
1232 begin
1233 Process_Project_Tree_Phase_1
1234 (In_Tree => In_Tree,
1235 Project => Project,
1236 Success => Success,
1237 From_Project_Node => From_Project_Node,
1238 From_Project_Node_Tree => From_Project_Node_Tree,
1239 Flags => Flags,
1240 Reset_Tree => Reset_Tree);
1241
1242 if Project_Qualifier_Of (From_Project_Node, From_Project_Node_Tree) /=
1243 Configuration
1244 then
1245 Process_Project_Tree_Phase_2
1246 (In_Tree => In_Tree,
1247 Project => Project,
1248 Success => Success,
1249 From_Project_Node => From_Project_Node,
1250 From_Project_Node_Tree => From_Project_Node_Tree,
1251 Flags => Flags);
1252 end if;
1253 end Process;
1254
1255 -------------------------------
1256 -- Process_Declarative_Items --
1257 -------------------------------
1258
1259 procedure Process_Declarative_Items
1260 (Project : Project_Id;
1261 In_Tree : Project_Tree_Ref;
1262 Flags : Processing_Flags;
1263 From_Project_Node : Project_Node_Id;
1264 From_Project_Node_Tree : Project_Node_Tree_Ref;
1265 Pkg : Package_Id;
1266 Item : Project_Node_Id)
1267 is
1268 procedure Check_Or_Set_Typed_Variable
1269 (Value : in out Variable_Value;
1270 Declaration : Project_Node_Id);
1271 -- Check whether Value is valid for this typed variable declaration. If
1272 -- it is an error, the behavior depends on the flags: either an error is
1273 -- reported, or a warning, or nothing. In the last two cases, the value
1274 -- of the variable is set to a valid value, replacing Value.
1275
1276 ---------------------------------
1277 -- Check_Or_Set_Typed_Variable --
1278 ---------------------------------
1279
1280 procedure Check_Or_Set_Typed_Variable
1281 (Value : in out Variable_Value;
1282 Declaration : Project_Node_Id)
1283 is
1284 Loc : constant Source_Ptr :=
1285 Location_Of (Declaration, From_Project_Node_Tree);
1286
1287 Reset_Value : Boolean := False;
1288 Current_String : Project_Node_Id;
1289
1290 begin
1291 -- Report an error for an empty string
1292
1293 if Value.Value = Empty_String then
1294 Error_Msg_Name_1 := Name_Of (Declaration, From_Project_Node_Tree);
1295
1296 case Flags.Allow_Invalid_External is
1297 when Error =>
1298 Error_Msg (Flags, "no value defined for %%", Loc, Project);
1299 when Warning =>
1300 Reset_Value := True;
1301 Error_Msg (Flags, "?no value defined for %%", Loc, Project);
1302 when Silent =>
1303 Reset_Value := True;
1304 end case;
1305
1306 else
1307 -- Loop through all the valid strings for the
1308 -- string type and compare to the string value.
1309
1310 Current_String :=
1311 First_Literal_String
1312 (String_Type_Of (Declaration, From_Project_Node_Tree),
1313 From_Project_Node_Tree);
1314 while Present (Current_String)
1315 and then String_Value_Of
1316 (Current_String, From_Project_Node_Tree) /= Value.Value
1317 loop
1318 Current_String :=
1319 Next_Literal_String (Current_String, From_Project_Node_Tree);
1320 end loop;
1321
1322 -- Report error if string value is not one for the string type
1323
1324 if No (Current_String) then
1325 Error_Msg_Name_1 := Value.Value;
1326 Error_Msg_Name_2 :=
1327 Name_Of (Declaration, From_Project_Node_Tree);
1328
1329 case Flags.Allow_Invalid_External is
1330 when Error =>
1331 Error_Msg
1332 (Flags, "value %% is illegal for typed string %%",
1333 Loc, Project);
1334 when Warning =>
1335 Error_Msg
1336 (Flags, "?value %% is illegal for typed string %%",
1337 Loc, Project);
1338 Reset_Value := True;
1339 when Silent =>
1340 Reset_Value := True;
1341 end case;
1342 end if;
1343 end if;
1344
1345 if Reset_Value then
1346 Current_String :=
1347 First_Literal_String
1348 (String_Type_Of (Declaration, From_Project_Node_Tree),
1349 From_Project_Node_Tree);
1350
1351 Value.Value := String_Value_Of
1352 (Current_String, From_Project_Node_Tree);
1353 end if;
1354 end Check_Or_Set_Typed_Variable;
1355
1356 -- Local variables
1357
1358 Current_Declarative_Item : Project_Node_Id;
1359 Current_Item : Project_Node_Id;
1360
1361 -- Start of processing for Process_Declarative_Items
1362
1363 begin
1364 -- Loop through declarative items
1365
1366 Current_Item := Empty_Node;
1367
1368 Current_Declarative_Item := Item;
1369 while Present (Current_Declarative_Item) loop
1370
1371 -- Get its data
1372
1373 Current_Item :=
1374 Current_Item_Node
1375 (Current_Declarative_Item, From_Project_Node_Tree);
1376
1377 -- And set Current_Declarative_Item to the next declarative item
1378 -- ready for the next iteration.
1379
1380 Current_Declarative_Item :=
1381 Next_Declarative_Item
1382 (Current_Declarative_Item, From_Project_Node_Tree);
1383
1384 case Kind_Of (Current_Item, From_Project_Node_Tree) is
1385
1386 when N_Package_Declaration =>
1387
1388 -- Do not process a package declaration that should be ignored
1389
1390 if Expression_Kind_Of
1391 (Current_Item, From_Project_Node_Tree) /= Ignored
1392 then
1393 -- Create the new package
1394
1395 Package_Table.Increment_Last (In_Tree.Packages);
1396
1397 declare
1398 New_Pkg : constant Package_Id :=
1399 Package_Table.Last (In_Tree.Packages);
1400 The_New_Package : Package_Element;
1401
1402 Project_Of_Renamed_Package :
1403 constant Project_Node_Id :=
1404 Project_Of_Renamed_Package_Of
1405 (Current_Item, From_Project_Node_Tree);
1406
1407 begin
1408 -- Set the name of the new package
1409
1410 The_New_Package.Name :=
1411 Name_Of (Current_Item, From_Project_Node_Tree);
1412
1413 -- Insert the new package in the appropriate list
1414
1415 if Pkg /= No_Package then
1416 The_New_Package.Next :=
1417 In_Tree.Packages.Table (Pkg).Decl.Packages;
1418 In_Tree.Packages.Table (Pkg).Decl.Packages :=
1419 New_Pkg;
1420
1421 else
1422 The_New_Package.Next := Project.Decl.Packages;
1423 Project.Decl.Packages := New_Pkg;
1424 end if;
1425
1426 In_Tree.Packages.Table (New_Pkg) :=
1427 The_New_Package;
1428
1429 if Present (Project_Of_Renamed_Package) then
1430
1431 -- Renamed or extending package
1432
1433 declare
1434 Project_Name : constant Name_Id :=
1435 Name_Of
1436 (Project_Of_Renamed_Package,
1437 From_Project_Node_Tree);
1438
1439 Renamed_Project :
1440 constant Project_Id :=
1441 Imported_Or_Extended_Project_From
1442 (Project, Project_Name);
1443
1444 Renamed_Package : constant Package_Id :=
1445 Package_From
1446 (Renamed_Project, In_Tree,
1447 Name_Of
1448 (Current_Item,
1449 From_Project_Node_Tree));
1450
1451 begin
1452 -- For a renamed package, copy the declarations of
1453 -- the renamed package, but set all the locations
1454 -- to the location of the package name in the
1455 -- renaming declaration.
1456
1457 Copy_Package_Declarations
1458 (From =>
1459 In_Tree.Packages.Table (Renamed_Package).Decl,
1460 To =>
1461 In_Tree.Packages.Table (New_Pkg).Decl,
1462 New_Loc =>
1463 Location_Of
1464 (Current_Item, From_Project_Node_Tree),
1465 Restricted => False,
1466 In_Tree => In_Tree);
1467 end;
1468
1469 else
1470 -- Set the default values of the attributes
1471
1472 Add_Attributes
1473 (Project,
1474 Project.Name,
1475 Name_Id (Project.Directory.Name),
1476 In_Tree,
1477 In_Tree.Packages.Table (New_Pkg).Decl,
1478 First_Attribute_Of
1479 (Package_Id_Of
1480 (Current_Item, From_Project_Node_Tree)),
1481 Project_Level => False);
1482
1483 end if;
1484
1485 -- Process declarative items (nothing to do when the
1486 -- package is renaming, as the first declarative item is
1487 -- null).
1488
1489 Process_Declarative_Items
1490 (Project => Project,
1491 In_Tree => In_Tree,
1492 Flags => Flags,
1493 From_Project_Node => From_Project_Node,
1494 From_Project_Node_Tree => From_Project_Node_Tree,
1495 Pkg => New_Pkg,
1496 Item =>
1497 First_Declarative_Item_Of
1498 (Current_Item, From_Project_Node_Tree));
1499 end;
1500 end if;
1501
1502 when N_String_Type_Declaration =>
1503
1504 -- There is nothing to process
1505
1506 null;
1507
1508 when N_Attribute_Declaration |
1509 N_Typed_Variable_Declaration |
1510 N_Variable_Declaration =>
1511
1512 if Expression_Of (Current_Item, From_Project_Node_Tree) =
1513 Empty_Node
1514 then
1515
1516 -- It must be a full associative array attribute declaration
1517
1518 declare
1519 Current_Item_Name : constant Name_Id :=
1520 Name_Of
1521 (Current_Item,
1522 From_Project_Node_Tree);
1523 -- The name of the attribute
1524
1525 Current_Location : constant Source_Ptr :=
1526 Location_Of
1527 (Current_Item,
1528 From_Project_Node_Tree);
1529
1530 New_Array : Array_Id;
1531 -- The new associative array created
1532
1533 Orig_Array : Array_Id;
1534 -- The associative array value
1535
1536 Orig_Project_Name : Name_Id := No_Name;
1537 -- The name of the project where the associative array
1538 -- value is.
1539
1540 Orig_Project : Project_Id := No_Project;
1541 -- The id of the project where the associative array
1542 -- value is.
1543
1544 Orig_Package_Name : Name_Id := No_Name;
1545 -- The name of the package, if any, where the associative
1546 -- array value is.
1547
1548 Orig_Package : Package_Id := No_Package;
1549 -- The id of the package, if any, where the associative
1550 -- array value is.
1551
1552 New_Element : Array_Element_Id := No_Array_Element;
1553 -- Id of a new array element created
1554
1555 Prev_Element : Array_Element_Id := No_Array_Element;
1556 -- Last new element id created
1557
1558 Orig_Element : Array_Element_Id := No_Array_Element;
1559 -- Current array element in original associative array
1560
1561 Next_Element : Array_Element_Id := No_Array_Element;
1562 -- Id of the array element that follows the new element.
1563 -- This is not always nil, because values for the
1564 -- associative array attribute may already have been
1565 -- declared, and the array elements declared are reused.
1566
1567 Prj : Project_List;
1568
1569 begin
1570 -- First find if the associative array attribute already
1571 -- has elements declared.
1572
1573 if Pkg /= No_Package then
1574 New_Array := In_Tree.Packages.Table
1575 (Pkg).Decl.Arrays;
1576
1577 else
1578 New_Array := Project.Decl.Arrays;
1579 end if;
1580
1581 while New_Array /= No_Array
1582 and then In_Tree.Arrays.Table (New_Array).Name /=
1583 Current_Item_Name
1584 loop
1585 New_Array := In_Tree.Arrays.Table (New_Array).Next;
1586 end loop;
1587
1588 -- If the attribute has never been declared add new entry
1589 -- in the arrays of the project/package and link it.
1590
1591 if New_Array = No_Array then
1592 Array_Table.Increment_Last (In_Tree.Arrays);
1593 New_Array := Array_Table.Last (In_Tree.Arrays);
1594
1595 if Pkg /= No_Package then
1596 In_Tree.Arrays.Table (New_Array) :=
1597 (Name => Current_Item_Name,
1598 Location => Current_Location,
1599 Value => No_Array_Element,
1600 Next => In_Tree.Packages.Table
1601 (Pkg).Decl.Arrays);
1602
1603 In_Tree.Packages.Table (Pkg).Decl.Arrays :=
1604 New_Array;
1605
1606 else
1607 In_Tree.Arrays.Table (New_Array) :=
1608 (Name => Current_Item_Name,
1609 Location => Current_Location,
1610 Value => No_Array_Element,
1611 Next => Project.Decl.Arrays);
1612
1613 Project.Decl.Arrays := New_Array;
1614 end if;
1615 end if;
1616
1617 -- Find the project where the value is declared
1618
1619 Orig_Project_Name :=
1620 Name_Of
1621 (Associative_Project_Of
1622 (Current_Item, From_Project_Node_Tree),
1623 From_Project_Node_Tree);
1624
1625 Prj := In_Tree.Projects;
1626 while Prj /= null loop
1627 if Prj.Project.Name = Orig_Project_Name then
1628 Orig_Project := Prj.Project;
1629 exit;
1630 end if;
1631 Prj := Prj.Next;
1632 end loop;
1633
1634 pragma Assert (Orig_Project /= No_Project,
1635 "original project not found");
1636
1637 if No (Associative_Package_Of
1638 (Current_Item, From_Project_Node_Tree))
1639 then
1640 Orig_Array := Orig_Project.Decl.Arrays;
1641
1642 else
1643 -- If in a package, find the package where the value
1644 -- is declared.
1645
1646 Orig_Package_Name :=
1647 Name_Of
1648 (Associative_Package_Of
1649 (Current_Item, From_Project_Node_Tree),
1650 From_Project_Node_Tree);
1651
1652 Orig_Package := Orig_Project.Decl.Packages;
1653 pragma Assert (Orig_Package /= No_Package,
1654 "original package not found");
1655
1656 while In_Tree.Packages.Table
1657 (Orig_Package).Name /= Orig_Package_Name
1658 loop
1659 Orig_Package := In_Tree.Packages.Table
1660 (Orig_Package).Next;
1661 pragma Assert (Orig_Package /= No_Package,
1662 "original package not found");
1663 end loop;
1664
1665 Orig_Array :=
1666 In_Tree.Packages.Table (Orig_Package).Decl.Arrays;
1667 end if;
1668
1669 -- Now look for the array
1670
1671 while Orig_Array /= No_Array
1672 and then In_Tree.Arrays.Table (Orig_Array).Name /=
1673 Current_Item_Name
1674 loop
1675 Orig_Array := In_Tree.Arrays.Table
1676 (Orig_Array).Next;
1677 end loop;
1678
1679 if Orig_Array = No_Array then
1680 Error_Msg
1681 (Flags,
1682 "associative array value not found",
1683 Location_Of (Current_Item, From_Project_Node_Tree),
1684 Project);
1685
1686 else
1687 Orig_Element :=
1688 In_Tree.Arrays.Table (Orig_Array).Value;
1689
1690 -- Copy each array element
1691
1692 while Orig_Element /= No_Array_Element loop
1693
1694 -- Case of first element
1695
1696 if Prev_Element = No_Array_Element then
1697
1698 -- And there is no array element declared yet,
1699 -- create a new first array element.
1700
1701 if In_Tree.Arrays.Table (New_Array).Value =
1702 No_Array_Element
1703 then
1704 Array_Element_Table.Increment_Last
1705 (In_Tree.Array_Elements);
1706 New_Element := Array_Element_Table.Last
1707 (In_Tree.Array_Elements);
1708 In_Tree.Arrays.Table
1709 (New_Array).Value := New_Element;
1710 Next_Element := No_Array_Element;
1711
1712 -- Otherwise, the new element is the first
1713
1714 else
1715 New_Element := In_Tree.Arrays.
1716 Table (New_Array).Value;
1717 Next_Element :=
1718 In_Tree.Array_Elements.Table
1719 (New_Element).Next;
1720 end if;
1721
1722 -- Otherwise, reuse an existing element, or create
1723 -- one if necessary.
1724
1725 else
1726 Next_Element :=
1727 In_Tree.Array_Elements.Table
1728 (Prev_Element).Next;
1729
1730 if Next_Element = No_Array_Element then
1731 Array_Element_Table.Increment_Last
1732 (In_Tree.Array_Elements);
1733 New_Element :=
1734 Array_Element_Table.Last
1735 (In_Tree.Array_Elements);
1736 In_Tree.Array_Elements.Table
1737 (Prev_Element).Next := New_Element;
1738
1739 else
1740 New_Element := Next_Element;
1741 Next_Element :=
1742 In_Tree.Array_Elements.Table
1743 (New_Element).Next;
1744 end if;
1745 end if;
1746
1747 -- Copy the value of the element
1748
1749 In_Tree.Array_Elements.Table
1750 (New_Element) :=
1751 In_Tree.Array_Elements.Table (Orig_Element);
1752 In_Tree.Array_Elements.Table
1753 (New_Element).Value.Project := Project;
1754
1755 -- Adjust the Next link
1756
1757 In_Tree.Array_Elements.Table
1758 (New_Element).Next := Next_Element;
1759
1760 -- Adjust the previous id for the next element
1761
1762 Prev_Element := New_Element;
1763
1764 -- Go to the next element in the original array
1765
1766 Orig_Element :=
1767 In_Tree.Array_Elements.Table
1768 (Orig_Element).Next;
1769 end loop;
1770
1771 -- Make sure that the array ends here, in case there
1772 -- previously a greater number of elements.
1773
1774 In_Tree.Array_Elements.Table
1775 (New_Element).Next := No_Array_Element;
1776 end if;
1777 end;
1778
1779 -- Declarations other that full associative arrays
1780
1781 else
1782 declare
1783 New_Value : Variable_Value :=
1784 Expression
1785 (Project => Project,
1786 In_Tree => In_Tree,
1787 Flags => Flags,
1788 From_Project_Node => From_Project_Node,
1789 From_Project_Node_Tree => From_Project_Node_Tree,
1790 Pkg => Pkg,
1791 First_Term =>
1792 Tree.First_Term
1793 (Expression_Of
1794 (Current_Item, From_Project_Node_Tree),
1795 From_Project_Node_Tree),
1796 Kind =>
1797 Expression_Kind_Of
1798 (Current_Item, From_Project_Node_Tree));
1799 -- The expression value
1800
1801 The_Variable : Variable_Id := No_Variable;
1802
1803 Current_Item_Name : constant Name_Id :=
1804 Name_Of
1805 (Current_Item,
1806 From_Project_Node_Tree);
1807
1808 Current_Location : constant Source_Ptr :=
1809 Location_Of
1810 (Current_Item,
1811 From_Project_Node_Tree);
1812
1813 begin
1814 -- Process a typed variable declaration
1815
1816 if Kind_Of (Current_Item, From_Project_Node_Tree) =
1817 N_Typed_Variable_Declaration
1818 then
1819 Check_Or_Set_Typed_Variable
1820 (Value => New_Value,
1821 Declaration => Current_Item);
1822 end if;
1823
1824 -- Comment here ???
1825
1826 if Kind_Of (Current_Item, From_Project_Node_Tree) /=
1827 N_Attribute_Declaration
1828 or else
1829 Associative_Array_Index_Of
1830 (Current_Item, From_Project_Node_Tree) = No_Name
1831 then
1832 -- Case of a variable declaration or of a not
1833 -- associative array attribute.
1834
1835 -- First, find the list where to find the variable
1836 -- or attribute.
1837
1838 if Kind_Of (Current_Item, From_Project_Node_Tree) =
1839 N_Attribute_Declaration
1840 then
1841 if Pkg /= No_Package then
1842 The_Variable :=
1843 In_Tree.Packages.Table
1844 (Pkg).Decl.Attributes;
1845 else
1846 The_Variable := Project.Decl.Attributes;
1847 end if;
1848
1849 else
1850 if Pkg /= No_Package then
1851 The_Variable :=
1852 In_Tree.Packages.Table
1853 (Pkg).Decl.Variables;
1854 else
1855 The_Variable := Project.Decl.Variables;
1856 end if;
1857
1858 end if;
1859
1860 -- Loop through the list, to find if it has already
1861 -- been declared.
1862
1863 while The_Variable /= No_Variable
1864 and then
1865 In_Tree.Variable_Elements.Table
1866 (The_Variable).Name /= Current_Item_Name
1867 loop
1868 The_Variable :=
1869 In_Tree.Variable_Elements.Table
1870 (The_Variable).Next;
1871 end loop;
1872
1873 -- If it has not been declared, create a new entry
1874 -- in the list.
1875
1876 if The_Variable = No_Variable then
1877
1878 -- All single string attribute should already have
1879 -- been declared with a default empty string value.
1880
1881 pragma Assert
1882 (Kind_Of (Current_Item, From_Project_Node_Tree) /=
1883 N_Attribute_Declaration,
1884 "illegal attribute declaration for "
1885 & Get_Name_String (Current_Item_Name));
1886
1887 Variable_Element_Table.Increment_Last
1888 (In_Tree.Variable_Elements);
1889 The_Variable := Variable_Element_Table.Last
1890 (In_Tree.Variable_Elements);
1891
1892 -- Put the new variable in the appropriate list
1893
1894 if Pkg /= No_Package then
1895 In_Tree.Variable_Elements.Table (The_Variable) :=
1896 (Next =>
1897 In_Tree.Packages.Table
1898 (Pkg).Decl.Variables,
1899 Name => Current_Item_Name,
1900 Value => New_Value);
1901 In_Tree.Packages.Table
1902 (Pkg).Decl.Variables := The_Variable;
1903
1904 else
1905 In_Tree.Variable_Elements.Table (The_Variable) :=
1906 (Next => Project.Decl.Variables,
1907 Name => Current_Item_Name,
1908 Value => New_Value);
1909 Project.Decl.Variables := The_Variable;
1910 end if;
1911
1912 -- If the variable/attribute has already been
1913 -- declared, just change the value.
1914
1915 else
1916 In_Tree.Variable_Elements.Table
1917 (The_Variable).Value := New_Value;
1918 end if;
1919
1920 -- Associative array attribute
1921
1922 else
1923 declare
1924 Index_Name : Name_Id :=
1925 Associative_Array_Index_Of
1926 (Current_Item,
1927 From_Project_Node_Tree);
1928
1929 Source_Index : constant Int :=
1930 Source_Index_Of
1931 (Current_Item,
1932 From_Project_Node_Tree);
1933
1934 The_Array : Array_Id;
1935 The_Array_Element : Array_Element_Id :=
1936 No_Array_Element;
1937
1938 begin
1939 if Index_Name /= All_Other_Names then
1940 Index_Name := Get_Attribute_Index
1941 (From_Project_Node_Tree,
1942 Current_Item,
1943 Associative_Array_Index_Of
1944 (Current_Item, From_Project_Node_Tree));
1945 end if;
1946
1947 -- Look for the array in the appropriate list
1948
1949 if Pkg /= No_Package then
1950 The_Array :=
1951 In_Tree.Packages.Table (Pkg).Decl.Arrays;
1952 else
1953 The_Array :=
1954 Project.Decl.Arrays;
1955 end if;
1956
1957 while
1958 The_Array /= No_Array
1959 and then
1960 In_Tree.Arrays.Table (The_Array).Name /=
1961 Current_Item_Name
1962 loop
1963 The_Array :=
1964 In_Tree.Arrays.Table (The_Array).Next;
1965 end loop;
1966
1967 -- If the array cannot be found, create a new entry
1968 -- in the list. As The_Array_Element is initialized
1969 -- to No_Array_Element, a new element will be
1970 -- created automatically later
1971
1972 if The_Array = No_Array then
1973 Array_Table.Increment_Last (In_Tree.Arrays);
1974 The_Array := Array_Table.Last (In_Tree.Arrays);
1975
1976 if Pkg /= No_Package then
1977 In_Tree.Arrays.Table (The_Array) :=
1978 (Name => Current_Item_Name,
1979 Location => Current_Location,
1980 Value => No_Array_Element,
1981 Next => In_Tree.Packages.Table
1982 (Pkg).Decl.Arrays);
1983
1984 In_Tree.Packages.Table (Pkg).Decl.Arrays :=
1985 The_Array;
1986
1987 else
1988 In_Tree.Arrays.Table (The_Array) :=
1989 (Name => Current_Item_Name,
1990 Location => Current_Location,
1991 Value => No_Array_Element,
1992 Next => Project.Decl.Arrays);
1993
1994 Project.Decl.Arrays := The_Array;
1995 end if;
1996
1997 -- Otherwise initialize The_Array_Element as the
1998 -- head of the element list.
1999
2000 else
2001 The_Array_Element :=
2002 In_Tree.Arrays.Table (The_Array).Value;
2003 end if;
2004
2005 -- Look in the list, if any, to find an element
2006 -- with the same index and same source index.
2007
2008 while The_Array_Element /= No_Array_Element
2009 and then
2010 (In_Tree.Array_Elements.Table
2011 (The_Array_Element).Index /= Index_Name
2012 or else
2013 In_Tree.Array_Elements.Table
2014 (The_Array_Element).Src_Index /= Source_Index)
2015 loop
2016 The_Array_Element :=
2017 In_Tree.Array_Elements.Table
2018 (The_Array_Element).Next;
2019 end loop;
2020
2021 -- If no such element were found, create a new one
2022 -- and insert it in the element list, with the
2023 -- proper value.
2024
2025 if The_Array_Element = No_Array_Element then
2026 Array_Element_Table.Increment_Last
2027 (In_Tree.Array_Elements);
2028 The_Array_Element :=
2029 Array_Element_Table.Last
2030 (In_Tree.Array_Elements);
2031
2032 In_Tree.Array_Elements.Table
2033 (The_Array_Element) :=
2034 (Index => Index_Name,
2035 Src_Index => Source_Index,
2036 Index_Case_Sensitive =>
2037 not Case_Insensitive
2038 (Current_Item, From_Project_Node_Tree),
2039 Value => New_Value,
2040 Next =>
2041 In_Tree.Arrays.Table (The_Array).Value);
2042
2043 In_Tree.Arrays.Table (The_Array).Value :=
2044 The_Array_Element;
2045
2046 -- An element with the same index already exists,
2047 -- just replace its value with the new one.
2048
2049 else
2050 In_Tree.Array_Elements.Table
2051 (The_Array_Element).Value := New_Value;
2052 end if;
2053 end;
2054 end if;
2055 end;
2056 end if;
2057
2058 when N_Case_Construction =>
2059 declare
2060 The_Project : Project_Id := Project;
2061 -- The id of the project of the case variable
2062
2063 The_Package : Package_Id := Pkg;
2064 -- The id of the package, if any, of the case variable
2065
2066 The_Variable : Variable_Value := Nil_Variable_Value;
2067 -- The case variable
2068
2069 Case_Value : Name_Id := No_Name;
2070 -- The case variable value
2071
2072 Case_Item : Project_Node_Id := Empty_Node;
2073 Choice_String : Project_Node_Id := Empty_Node;
2074 Decl_Item : Project_Node_Id := Empty_Node;
2075
2076 begin
2077 declare
2078 Variable_Node : constant Project_Node_Id :=
2079 Case_Variable_Reference_Of
2080 (Current_Item,
2081 From_Project_Node_Tree);
2082
2083 Var_Id : Variable_Id := No_Variable;
2084 Name : Name_Id := No_Name;
2085
2086 begin
2087 -- If a project was specified for the case variable,
2088 -- get its id.
2089
2090 if Present (Project_Node_Of
2091 (Variable_Node, From_Project_Node_Tree))
2092 then
2093 Name :=
2094 Name_Of
2095 (Project_Node_Of
2096 (Variable_Node, From_Project_Node_Tree),
2097 From_Project_Node_Tree);
2098 The_Project :=
2099 Imported_Or_Extended_Project_From (Project, Name);
2100 end if;
2101
2102 -- If a package were specified for the case variable,
2103 -- get its id.
2104
2105 if Present (Package_Node_Of
2106 (Variable_Node, From_Project_Node_Tree))
2107 then
2108 Name :=
2109 Name_Of
2110 (Package_Node_Of
2111 (Variable_Node, From_Project_Node_Tree),
2112 From_Project_Node_Tree);
2113 The_Package :=
2114 Package_From (The_Project, In_Tree, Name);
2115 end if;
2116
2117 Name := Name_Of (Variable_Node, From_Project_Node_Tree);
2118
2119 -- First, look for the case variable into the package,
2120 -- if any.
2121
2122 if The_Package /= No_Package then
2123 Var_Id := In_Tree.Packages.Table
2124 (The_Package).Decl.Variables;
2125 Name :=
2126 Name_Of (Variable_Node, From_Project_Node_Tree);
2127 while Var_Id /= No_Variable
2128 and then
2129 In_Tree.Variable_Elements.Table
2130 (Var_Id).Name /= Name
2131 loop
2132 Var_Id := In_Tree.Variable_Elements.
2133 Table (Var_Id).Next;
2134 end loop;
2135 end if;
2136
2137 -- If not found in the package, or if there is no
2138 -- package, look at the project level.
2139
2140 if Var_Id = No_Variable
2141 and then
2142 No (Package_Node_Of
2143 (Variable_Node, From_Project_Node_Tree))
2144 then
2145 Var_Id := The_Project.Decl.Variables;
2146 while Var_Id /= No_Variable
2147 and then
2148 In_Tree.Variable_Elements.Table
2149 (Var_Id).Name /= Name
2150 loop
2151 Var_Id := In_Tree.Variable_Elements.
2152 Table (Var_Id).Next;
2153 end loop;
2154 end if;
2155
2156 if Var_Id = No_Variable then
2157
2158 -- Should never happen, because this has already been
2159 -- checked during parsing.
2160
2161 Write_Line ("variable """ &
2162 Get_Name_String (Name) &
2163 """ not found");
2164 raise Program_Error;
2165 end if;
2166
2167 -- Get the case variable
2168
2169 The_Variable := In_Tree.Variable_Elements.
2170 Table (Var_Id).Value;
2171
2172 if The_Variable.Kind /= Single then
2173
2174 -- Should never happen, because this has already been
2175 -- checked during parsing.
2176
2177 Write_Line ("variable""" &
2178 Get_Name_String (Name) &
2179 """ is not a single string variable");
2180 raise Program_Error;
2181 end if;
2182
2183 -- Get the case variable value
2184 Case_Value := The_Variable.Value;
2185 end;
2186
2187 -- Now look into all the case items of the case construction
2188
2189 Case_Item :=
2190 First_Case_Item_Of (Current_Item, From_Project_Node_Tree);
2191 Case_Item_Loop :
2192 while Present (Case_Item) loop
2193 Choice_String :=
2194 First_Choice_Of (Case_Item, From_Project_Node_Tree);
2195
2196 -- When Choice_String is nil, it means that it is
2197 -- the "when others =>" alternative.
2198
2199 if No (Choice_String) then
2200 Decl_Item :=
2201 First_Declarative_Item_Of
2202 (Case_Item, From_Project_Node_Tree);
2203 exit Case_Item_Loop;
2204 end if;
2205
2206 -- Look into all the alternative of this case item
2207
2208 Choice_Loop :
2209 while Present (Choice_String) loop
2210 if Case_Value =
2211 String_Value_Of
2212 (Choice_String, From_Project_Node_Tree)
2213 then
2214 Decl_Item :=
2215 First_Declarative_Item_Of
2216 (Case_Item, From_Project_Node_Tree);
2217 exit Case_Item_Loop;
2218 end if;
2219
2220 Choice_String :=
2221 Next_Literal_String
2222 (Choice_String, From_Project_Node_Tree);
2223 end loop Choice_Loop;
2224
2225 Case_Item :=
2226 Next_Case_Item (Case_Item, From_Project_Node_Tree);
2227 end loop Case_Item_Loop;
2228
2229 -- If there is an alternative, then we process it
2230
2231 if Present (Decl_Item) then
2232 Process_Declarative_Items
2233 (Project => Project,
2234 In_Tree => In_Tree,
2235 Flags => Flags,
2236 From_Project_Node => From_Project_Node,
2237 From_Project_Node_Tree => From_Project_Node_Tree,
2238 Pkg => Pkg,
2239 Item => Decl_Item);
2240 end if;
2241 end;
2242
2243 when others =>
2244
2245 -- Should never happen
2246
2247 Write_Line ("Illegal declarative item: " &
2248 Project_Node_Kind'Image
2249 (Kind_Of
2250 (Current_Item, From_Project_Node_Tree)));
2251 raise Program_Error;
2252 end case;
2253 end loop;
2254 end Process_Declarative_Items;
2255
2256 ----------------------------------
2257 -- Process_Project_Tree_Phase_1 --
2258 ----------------------------------
2259
2260 procedure Process_Project_Tree_Phase_1
2261 (In_Tree : Project_Tree_Ref;
2262 Project : out Project_Id;
2263 Success : out Boolean;
2264 From_Project_Node : Project_Node_Id;
2265 From_Project_Node_Tree : Project_Node_Tree_Ref;
2266 Flags : Processing_Flags;
2267 Reset_Tree : Boolean := True)
2268 is
2269 begin
2270 if Reset_Tree then
2271
2272 -- Make sure there are no projects in the data structure
2273
2274 Free_List (In_Tree.Projects, Free_Project => True);
2275 end if;
2276
2277 Processed_Projects.Reset;
2278
2279 -- And process the main project and all of the projects it depends on,
2280 -- recursively.
2281
2282 Recursive_Process
2283 (Project => Project,
2284 In_Tree => In_Tree,
2285 Flags => Flags,
2286 From_Project_Node => From_Project_Node,
2287 From_Project_Node_Tree => From_Project_Node_Tree,
2288 Extended_By => No_Project);
2289
2290 Success :=
2291 Total_Errors_Detected = 0
2292 and then
2293 (Warning_Mode /= Treat_As_Error or else Warnings_Detected = 0);
2294 end Process_Project_Tree_Phase_1;
2295
2296 ----------------------------------
2297 -- Process_Project_Tree_Phase_2 --
2298 ----------------------------------
2299
2300 procedure Process_Project_Tree_Phase_2
2301 (In_Tree : Project_Tree_Ref;
2302 Project : Project_Id;
2303 Success : out Boolean;
2304 From_Project_Node : Project_Node_Id;
2305 From_Project_Node_Tree : Project_Node_Tree_Ref;
2306 Flags : Processing_Flags)
2307 is
2308 Obj_Dir : Path_Name_Type;
2309 Extending : Project_Id;
2310 Extending2 : Project_Id;
2311 Prj : Project_List;
2312
2313 -- Start of processing for Process_Project_Tree_Phase_2
2314
2315 begin
2316 Success := True;
2317
2318 if Project /= No_Project then
2319 Check (In_Tree, Project, Flags);
2320 end if;
2321
2322 -- If main project is an extending all project, set object directory of
2323 -- all virtual extending projects to object directory of main project.
2324
2325 if Project /= No_Project
2326 and then
2327 Is_Extending_All (From_Project_Node, From_Project_Node_Tree)
2328 then
2329 declare
2330 Object_Dir : constant Path_Information :=
2331 Project.Object_Directory;
2332 begin
2333 Prj := In_Tree.Projects;
2334 while Prj /= null loop
2335 if Prj.Project.Virtual then
2336 Prj.Project.Object_Directory := Object_Dir;
2337 end if;
2338 Prj := Prj.Next;
2339 end loop;
2340 end;
2341 end if;
2342
2343 -- Check that no extending project shares its object directory with
2344 -- the project(s) it extends.
2345
2346 if Project /= No_Project then
2347 Prj := In_Tree.Projects;
2348 while Prj /= null loop
2349 Extending := Prj.Project.Extended_By;
2350
2351 if Extending /= No_Project then
2352 Obj_Dir := Prj.Project.Object_Directory.Name;
2353
2354 -- Check that a project being extended does not share its
2355 -- object directory with any project that extends it, directly
2356 -- or indirectly, including a virtual extending project.
2357
2358 -- Start with the project directly extending it
2359
2360 Extending2 := Extending;
2361 while Extending2 /= No_Project loop
2362 if Has_Ada_Sources (Extending2)
2363 and then Extending2.Object_Directory.Name = Obj_Dir
2364 then
2365 if Extending2.Virtual then
2366 Error_Msg_Name_1 := Prj.Project.Display_Name;
2367 Error_Msg
2368 (Flags,
2369 "project %% cannot be extended by a virtual" &
2370 " project with the same object directory",
2371 Prj.Project.Location, Project);
2372
2373 else
2374 Error_Msg_Name_1 := Extending2.Display_Name;
2375 Error_Msg_Name_2 := Prj.Project.Display_Name;
2376 Error_Msg
2377 (Flags,
2378 "project %% cannot extend project %%",
2379 Extending2.Location, Project);
2380 Error_Msg
2381 (Flags,
2382 "\they share the same object directory",
2383 Extending2.Location, Project);
2384 end if;
2385 end if;
2386
2387 -- Continue with the next extending project, if any
2388
2389 Extending2 := Extending2.Extended_By;
2390 end loop;
2391 end if;
2392
2393 Prj := Prj.Next;
2394 end loop;
2395 end if;
2396
2397 Success :=
2398 Total_Errors_Detected = 0
2399 and then
2400 (Warning_Mode /= Treat_As_Error or else Warnings_Detected = 0);
2401 end Process_Project_Tree_Phase_2;
2402
2403 -----------------------
2404 -- Recursive_Process --
2405 -----------------------
2406
2407 procedure Recursive_Process
2408 (In_Tree : Project_Tree_Ref;
2409 Project : out Project_Id;
2410 Flags : Processing_Flags;
2411 From_Project_Node : Project_Node_Id;
2412 From_Project_Node_Tree : Project_Node_Tree_Ref;
2413 Extended_By : Project_Id)
2414 is
2415 procedure Process_Imported_Projects
2416 (Imported : in out Project_List;
2417 Limited_With : Boolean);
2418 -- Process imported projects. If Limited_With is True, then only
2419 -- projects processed through a "limited with" are processed, otherwise
2420 -- only projects imported through a standard "with" are processed.
2421 -- Imported is the id of the last imported project.
2422
2423 -------------------------------
2424 -- Process_Imported_Projects --
2425 -------------------------------
2426
2427 procedure Process_Imported_Projects
2428 (Imported : in out Project_List;
2429 Limited_With : Boolean)
2430 is
2431 With_Clause : Project_Node_Id;
2432 New_Project : Project_Id;
2433 Proj_Node : Project_Node_Id;
2434
2435 begin
2436 With_Clause :=
2437 First_With_Clause_Of
2438 (From_Project_Node, From_Project_Node_Tree);
2439 while Present (With_Clause) loop
2440 Proj_Node :=
2441 Non_Limited_Project_Node_Of
2442 (With_Clause, From_Project_Node_Tree);
2443 New_Project := No_Project;
2444
2445 if (Limited_With and then No (Proj_Node))
2446 or else (not Limited_With and then Present (Proj_Node))
2447 then
2448 Recursive_Process
2449 (In_Tree => In_Tree,
2450 Project => New_Project,
2451 Flags => Flags,
2452 From_Project_Node =>
2453 Project_Node_Of
2454 (With_Clause, From_Project_Node_Tree),
2455 From_Project_Node_Tree => From_Project_Node_Tree,
2456 Extended_By => No_Project);
2457
2458 -- Imported is the id of the last imported project. If
2459 -- it is nil, then this imported project is our first.
2460
2461 if Imported = null then
2462 Project.Imported_Projects :=
2463 new Project_List_Element'
2464 (Project => New_Project,
2465 Next => null);
2466 Imported := Project.Imported_Projects;
2467 else
2468 Imported.Next := new Project_List_Element'
2469 (Project => New_Project,
2470 Next => null);
2471 Imported := Imported.Next;
2472 end if;
2473 end if;
2474
2475 With_Clause :=
2476 Next_With_Clause_Of (With_Clause, From_Project_Node_Tree);
2477 end loop;
2478 end Process_Imported_Projects;
2479
2480 -- Start of processing for Recursive_Process
2481
2482 begin
2483 if No (From_Project_Node) then
2484 Project := No_Project;
2485
2486 else
2487 declare
2488 Imported : Project_List;
2489 Declaration_Node : Project_Node_Id := Empty_Node;
2490
2491 Name : constant Name_Id :=
2492 Name_Of (From_Project_Node, From_Project_Node_Tree);
2493
2494 Name_Node : constant Tree_Private_Part.Project_Name_And_Node :=
2495 Tree_Private_Part.Projects_Htable.Get
2496 (From_Project_Node_Tree.Projects_HT, Name);
2497
2498 begin
2499 Project := Processed_Projects.Get (Name);
2500
2501 if Project /= No_Project then
2502
2503 -- Make sure that, when a project is extended, the project id
2504 -- of the project extending it is recorded in its data, even
2505 -- when it has already been processed as an imported project.
2506 -- This is for virtually extended projects.
2507
2508 if Extended_By /= No_Project then
2509 Project.Extended_By := Extended_By;
2510 end if;
2511
2512 return;
2513 end if;
2514
2515 Project := new Project_Data'(Empty_Project);
2516 In_Tree.Projects := new Project_List_Element'
2517 (Project => Project,
2518 Next => In_Tree.Projects);
2519
2520 Processed_Projects.Set (Name, Project);
2521
2522 Project.Name := Name;
2523 Project.Display_Name := Name_Node.Display_Name;
2524 Project.Qualifier :=
2525 Project_Qualifier_Of (From_Project_Node, From_Project_Node_Tree);
2526
2527 Get_Name_String (Name);
2528
2529 -- If name starts with the virtual prefix, flag the project as
2530 -- being a virtual extending project.
2531
2532 if Name_Len > Virtual_Prefix'Length
2533 and then Name_Buffer (1 .. Virtual_Prefix'Length) =
2534 Virtual_Prefix
2535 then
2536 Project.Virtual := True;
2537
2538 end if;
2539
2540 Project.Path.Display_Name :=
2541 Path_Name_Of (From_Project_Node, From_Project_Node_Tree);
2542 Get_Name_String (Project.Path.Display_Name);
2543 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
2544 Project.Path.Name := Name_Find;
2545
2546 Project.Location :=
2547 Location_Of (From_Project_Node, From_Project_Node_Tree);
2548
2549 Project.Directory.Display_Name :=
2550 Directory_Of (From_Project_Node, From_Project_Node_Tree);
2551 Get_Name_String (Project.Directory.Display_Name);
2552 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
2553 Project.Directory.Name := Name_Find;
2554
2555 Project.Extended_By := Extended_By;
2556
2557 Add_Attributes
2558 (Project,
2559 Name,
2560 Name_Id (Project.Directory.Name),
2561 In_Tree,
2562 Project.Decl,
2563 Prj.Attr.Attribute_First,
2564 Project_Level => True);
2565
2566 Process_Imported_Projects (Imported, Limited_With => False);
2567
2568 Declaration_Node :=
2569 Project_Declaration_Of
2570 (From_Project_Node, From_Project_Node_Tree);
2571
2572 Recursive_Process
2573 (In_Tree => In_Tree,
2574 Project => Project.Extends,
2575 Flags => Flags,
2576 From_Project_Node => Extended_Project_Of
2577 (Declaration_Node,
2578 From_Project_Node_Tree),
2579 From_Project_Node_Tree => From_Project_Node_Tree,
2580 Extended_By => Project);
2581
2582 Process_Declarative_Items
2583 (Project => Project,
2584 In_Tree => In_Tree,
2585 Flags => Flags,
2586 From_Project_Node => From_Project_Node,
2587 From_Project_Node_Tree => From_Project_Node_Tree,
2588 Pkg => No_Package,
2589 Item => First_Declarative_Item_Of
2590 (Declaration_Node,
2591 From_Project_Node_Tree));
2592
2593 -- If it is an extending project, inherit all packages
2594 -- from the extended project that are not explicitly defined
2595 -- or renamed. Also inherit the languages, if attribute Languages
2596 -- is not explicitly defined.
2597
2598 if Project.Extends /= No_Project then
2599 declare
2600 Extended_Pkg : Package_Id;
2601 Current_Pkg : Package_Id;
2602 Element : Package_Element;
2603 First : constant Package_Id :=
2604 Project.Decl.Packages;
2605 Attribute1 : Variable_Id;
2606 Attribute2 : Variable_Id;
2607 Attr_Value1 : Variable;
2608 Attr_Value2 : Variable;
2609
2610 begin
2611 Extended_Pkg := Project.Extends.Decl.Packages;
2612 while Extended_Pkg /= No_Package loop
2613 Element := In_Tree.Packages.Table (Extended_Pkg);
2614
2615 Current_Pkg := First;
2616 while Current_Pkg /= No_Package
2617 and then In_Tree.Packages.Table (Current_Pkg).Name /=
2618 Element.Name
2619 loop
2620 Current_Pkg :=
2621 In_Tree.Packages.Table (Current_Pkg).Next;
2622 end loop;
2623
2624 if Current_Pkg = No_Package then
2625 Package_Table.Increment_Last
2626 (In_Tree.Packages);
2627 Current_Pkg := Package_Table.Last (In_Tree.Packages);
2628 In_Tree.Packages.Table (Current_Pkg) :=
2629 (Name => Element.Name,
2630 Decl => No_Declarations,
2631 Parent => No_Package,
2632 Next => Project.Decl.Packages);
2633 Project.Decl.Packages := Current_Pkg;
2634 Copy_Package_Declarations
2635 (From => Element.Decl,
2636 To =>
2637 In_Tree.Packages.Table (Current_Pkg).Decl,
2638 New_Loc => No_Location,
2639 Restricted => True,
2640 In_Tree => In_Tree);
2641 end if;
2642
2643 Extended_Pkg := Element.Next;
2644 end loop;
2645
2646 -- Check if attribute Languages is declared in the
2647 -- extending project.
2648
2649 Attribute1 := Project.Decl.Attributes;
2650 while Attribute1 /= No_Variable loop
2651 Attr_Value1 := In_Tree.Variable_Elements.
2652 Table (Attribute1);
2653 exit when Attr_Value1.Name = Snames.Name_Languages;
2654 Attribute1 := Attr_Value1.Next;
2655 end loop;
2656
2657 if Attribute1 = No_Variable or else
2658 Attr_Value1.Value.Default
2659 then
2660 -- Attribute Languages is not declared in the extending
2661 -- project. Check if it is declared in the project being
2662 -- extended.
2663
2664 Attribute2 := Project.Extends.Decl.Attributes;
2665 while Attribute2 /= No_Variable loop
2666 Attr_Value2 := In_Tree.Variable_Elements.
2667 Table (Attribute2);
2668 exit when Attr_Value2.Name = Snames.Name_Languages;
2669 Attribute2 := Attr_Value2.Next;
2670 end loop;
2671
2672 if Attribute2 /= No_Variable and then
2673 not Attr_Value2.Value.Default
2674 then
2675 -- As attribute Languages is declared in the project
2676 -- being extended, copy its value for the extending
2677 -- project.
2678
2679 if Attribute1 = No_Variable then
2680 Variable_Element_Table.Increment_Last
2681 (In_Tree.Variable_Elements);
2682 Attribute1 := Variable_Element_Table.Last
2683 (In_Tree.Variable_Elements);
2684 Attr_Value1.Next := Project.Decl.Attributes;
2685 Project.Decl.Attributes := Attribute1;
2686 end if;
2687
2688 Attr_Value1.Name := Snames.Name_Languages;
2689 Attr_Value1.Value := Attr_Value2.Value;
2690 In_Tree.Variable_Elements.Table
2691 (Attribute1) := Attr_Value1;
2692 end if;
2693 end if;
2694 end;
2695 end if;
2696
2697 Process_Imported_Projects (Imported, Limited_With => True);
2698 end;
2699 end if;
2700 end Recursive_Process;
2701
2702 end Prj.Proc;
GCC graphite test results