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