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