projects / gcc.git / blob
? search:


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