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