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