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