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