?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Typo in last patch.
[official-gcc.git] / gcc / ada / prj-proc.adb
blob9d034a12dc52a58858d7489c41a9cbd40f623c78
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-2004 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
21 -- --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 -- --
25 ------------------------------------------------------------------------------
26
27 with Err_Vars; use Err_Vars;
28 with Namet; use Namet;
29 with Opt;
30 with Osint; use Osint;
31 with Output; use Output;
32 with Prj.Attr; use Prj.Attr;
33 with Prj.Com; use Prj.Com;
34 with Prj.Err; use Prj.Err;
35 with Prj.Ext; use Prj.Ext;
36 with Prj.Nmsc; use Prj.Nmsc;
37 with Snames;
38
39 with GNAT.Case_Util; use GNAT.Case_Util;
40 with GNAT.HTable;
41
42 package body Prj.Proc is
43
44 Error_Report : Put_Line_Access := null;
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 procedure Add (To_Exp : in out Name_Id; Str : Name_Id);
56 -- Concatenate two strings and returns another string if both
57 -- arguments are not null string.
58
59 procedure Add_Attributes
60 (Project : Project_Id;
61 Decl : in out Declarations;
62 First : Attribute_Node_Id);
63 -- Add all attributes, starting with First, with their default
64 -- values to the package or project with declarations Decl.
65
66 function Expression
67 (Project : Project_Id;
68 From_Project_Node : Project_Node_Id;
69 Pkg : Package_Id;
70 First_Term : Project_Node_Id;
71 Kind : Variable_Kind) return Variable_Value;
72 -- From N_Expression project node From_Project_Node, compute the value
73 -- of an expression and return it as a Variable_Value.
74
75 function Imported_Or_Extended_Project_From
76 (Project : Project_Id;
77 With_Name : Name_Id) return Project_Id;
78 -- Find an imported or extended project of Project whose name is With_Name
79
80 function Package_From
81 (Project : Project_Id;
82 With_Name : Name_Id) return Package_Id;
83 -- Find the package of Project whose name is With_Name
84
85 procedure Process_Declarative_Items
86 (Project : Project_Id;
87 From_Project_Node : Project_Node_Id;
88 Pkg : Package_Id;
89 Item : Project_Node_Id);
90 -- Process declarative items starting with From_Project_Node, and put them
91 -- in declarations Decl. This is a recursive procedure; it calls itself for
92 -- a package declaration or a case construction.
93
94 procedure Recursive_Process
95 (Project : out Project_Id;
96 From_Project_Node : Project_Node_Id;
97 Extended_By : Project_Id);
98 -- Process project with node From_Project_Node in the tree.
99 -- Do nothing if From_Project_Node is Empty_Node.
100 -- If project has already been processed, simply return its project id.
101 -- Otherwise create a new project id, mark it as processed, call itself
102 -- recursively for all imported projects and a extended project, if any.
103 -- Then process the declarative items of the project.
104
105 procedure Check
106 (Project : in out Project_Id;
107 Process_Languages : Languages_Processed;
108 Follow_Links : Boolean);
109 -- Set all projects to not checked, then call Recursive_Check for the
110 -- main project Project. Project is set to No_Project if errors occurred.
111 -- See Prj.Nmsc.Ada_Check for information on Follow_Links.
112
113 procedure Recursive_Check
114 (Project : Project_Id;
115 Process_Languages : Languages_Processed;
116 Follow_Links : Boolean);
117 -- If Project is not marked as checked, mark it as checked, call
118 -- Check_Naming_Scheme for the project, then call itself for a
119 -- possible extended project and all the imported projects of Project.
120 -- See Prj.Nmsc.Ada_Check for information on Follow_Links
121
122 ---------
123 -- Add --
124 ---------
125
126 procedure Add (To_Exp : in out Name_Id; Str : Name_Id) is
127 begin
128 if To_Exp = Types.No_Name or else To_Exp = Empty_String then
129
130 -- To_Exp is nil or empty. The result is Str.
131
132 To_Exp := Str;
133
134 -- If Str is nil, then do not change To_Ext
135
136 elsif Str /= No_Name and then Str /= Empty_String then
137 declare
138 S : constant String := Get_Name_String (Str);
139
140 begin
141 Get_Name_String (To_Exp);
142 Add_Str_To_Name_Buffer (S);
143 To_Exp := Name_Find;
144 end;
145 end if;
146 end Add;
147
148 --------------------
149 -- Add_Attributes --
150 --------------------
151
152 procedure Add_Attributes
153 (Project : Project_Id;
154 Decl : in out Declarations;
155 First : Attribute_Node_Id)
156 is
157 The_Attribute : Attribute_Node_Id := First;
158 Attribute_Data : Attribute_Record;
159
160 begin
161 while The_Attribute /= Empty_Attribute loop
162 Attribute_Data := Attributes.Table (The_Attribute);
163
164 if Attribute_Data.Kind_2 = Single then
165 declare
166 New_Attribute : Variable_Value;
167
168 begin
169 case Attribute_Data.Kind_1 is
170
171 -- Undefined should not happen
172
173 when Undefined =>
174 pragma Assert
175 (False, "attribute with an undefined kind");
176 raise Program_Error;
177
178 -- Single attributes have a default value of empty string
179
180 when Single =>
181 New_Attribute :=
182 (Project => Project,
183 Kind => Single,
184 Location => No_Location,
185 Default => True,
186 Value => Empty_String,
187 Index => 0);
188
189 -- List attributes have a default value of nil list
190
191 when List =>
192 New_Attribute :=
193 (Project => Project,
194 Kind => List,
195 Location => No_Location,
196 Default => True,
197 Values => Nil_String);
198
199 end case;
200
201 Variable_Elements.Increment_Last;
202 Variable_Elements.Table (Variable_Elements.Last) :=
203 (Next => Decl.Attributes,
204 Name => Attribute_Data.Name,
205 Value => New_Attribute);
206 Decl.Attributes := Variable_Elements.Last;
207 end;
208 end if;
209
210 The_Attribute := Attributes.Table (The_Attribute).Next;
211 end loop;
212 end Add_Attributes;
213
214 -----------
215 -- Check --
216 -----------
217
218 procedure Check
219 (Project : in out Project_Id;
220 Process_Languages : Languages_Processed;
221 Follow_Links : Boolean) is
222 begin
223 -- Make sure that all projects are marked as not checked
224
225 for Index in 1 .. Projects.Last loop
226 Projects.Table (Index).Checked := False;
227 end loop;
228
229 Recursive_Check (Project, Process_Languages, Follow_Links);
230
231 end Check;
232
233 ----------------
234 -- Expression --
235 ----------------
236
237 function Expression
238 (Project : Project_Id;
239 From_Project_Node : Project_Node_Id;
240 Pkg : Package_Id;
241 First_Term : Project_Node_Id;
242 Kind : Variable_Kind) return Variable_Value
243 is
244 The_Term : Project_Node_Id := First_Term;
245 -- The term in the expression list
246
247 The_Current_Term : Project_Node_Id := Empty_Node;
248 -- The current term node id
249
250 Result : Variable_Value (Kind => Kind);
251 -- The returned result
252
253 Last : String_List_Id := Nil_String;
254 -- Reference to the last string elements in Result, when Kind is List.
255
256 begin
257 Result.Project := Project;
258 Result.Location := Location_Of (First_Term);
259
260 -- Process each term of the expression, starting with First_Term
261
262 while The_Term /= Empty_Node loop
263 The_Current_Term := Current_Term (The_Term);
264
265 case Kind_Of (The_Current_Term) is
266
267 when N_Literal_String =>
268
269 case Kind is
270
271 when Undefined =>
272
273 -- Should never happen
274
275 pragma Assert (False, "Undefined expression kind");
276 raise Program_Error;
277
278 when Single =>
279 Add (Result.Value, String_Value_Of (The_Current_Term));
280 Result.Index := Source_Index_Of (The_Current_Term);
281
282 when List =>
283
284 String_Elements.Increment_Last;
285
286 if Last = Nil_String then
287
288 -- This can happen in an expression such as
289 -- () & "toto"
290
291 Result.Values := String_Elements.Last;
292
293 else
294 String_Elements.Table (Last).Next :=
295 String_Elements.Last;
296 end if;
297
298 Last := String_Elements.Last;
299 String_Elements.Table (Last) :=
300 (Value => String_Value_Of (The_Current_Term),
301 Index => Source_Index_Of (The_Current_Term),
302 Display_Value => No_Name,
303 Location => Location_Of (The_Current_Term),
304 Flag => False,
305 Next => Nil_String);
306
307 end case;
308
309 when N_Literal_String_List =>
310
311 declare
312 String_Node : Project_Node_Id :=
313 First_Expression_In_List (The_Current_Term);
314
315 Value : Variable_Value;
316
317 begin
318 if String_Node /= Empty_Node then
319
320 -- If String_Node is nil, it is an empty list,
321 -- there is nothing to do
322
323 Value := Expression
324 (Project => Project,
325 From_Project_Node => From_Project_Node,
326 Pkg => Pkg,
327 First_Term => Tree.First_Term (String_Node),
328 Kind => Single);
329 String_Elements.Increment_Last;
330
331 if Result.Values = Nil_String then
332
333 -- This literal string list is the first term
334 -- in a string list expression
335
336 Result.Values := String_Elements.Last;
337
338 else
339 String_Elements.Table (Last).Next :=
340 String_Elements.Last;
341 end if;
342
343 Last := String_Elements.Last;
344 String_Elements.Table (Last) :=
345 (Value => Value.Value,
346 Display_Value => No_Name,
347 Location => Value.Location,
348 Flag => False,
349 Next => Nil_String,
350 Index => Value.Index);
351
352 loop
353 -- Add the other element of the literal string list
354 -- one after the other
355
356 String_Node :=
357 Next_Expression_In_List (String_Node);
358
359 exit when String_Node = Empty_Node;
360
361 Value :=
362 Expression
363 (Project => Project,
364 From_Project_Node => From_Project_Node,
365 Pkg => Pkg,
366 First_Term => Tree.First_Term (String_Node),
367 Kind => Single);
368
369 String_Elements.Increment_Last;
370 String_Elements.Table (Last).Next :=
371 String_Elements.Last;
372 Last := String_Elements.Last;
373 String_Elements.Table (Last) :=
374 (Value => Value.Value,
375 Display_Value => No_Name,
376 Location => Value.Location,
377 Flag => False,
378 Next => Nil_String,
379 Index => Value.Index);
380 end loop;
381
382 end if;
383
384 end;
385
386 when N_Variable_Reference | N_Attribute_Reference =>
387
388 declare
389 The_Project : Project_Id := Project;
390 The_Package : Package_Id := Pkg;
391 The_Name : Name_Id := No_Name;
392 The_Variable_Id : Variable_Id := No_Variable;
393 The_Variable : Variable_Value;
394 Term_Project : constant Project_Node_Id :=
395 Project_Node_Of (The_Current_Term);
396 Term_Package : constant Project_Node_Id :=
397 Package_Node_Of (The_Current_Term);
398 Index : Name_Id := No_Name;
399
400 begin
401 if Term_Project /= Empty_Node and then
402 Term_Project /= From_Project_Node
403 then
404 -- This variable or attribute comes from another project
405
406 The_Name := Name_Of (Term_Project);
407 The_Project := Imported_Or_Extended_Project_From
408 (Project => Project,
409 With_Name => The_Name);
410 end if;
411
412 if Term_Package /= Empty_Node then
413
414 -- This is an attribute of a package
415
416 The_Name := Name_Of (Term_Package);
417 The_Package := Projects.Table (The_Project).Decl.Packages;
418
419 while The_Package /= No_Package
420 and then Packages.Table (The_Package).Name /= The_Name
421 loop
422 The_Package := Packages.Table (The_Package).Next;
423 end loop;
424
425 pragma Assert
426 (The_Package /= No_Package,
427 "package not found.");
428
429 elsif Kind_Of (The_Current_Term) = N_Attribute_Reference then
430 The_Package := No_Package;
431 end if;
432
433 The_Name := Name_Of (The_Current_Term);
434
435 if Kind_Of (The_Current_Term) = N_Attribute_Reference then
436 Index := Associative_Array_Index_Of (The_Current_Term);
437 end if;
438
439 -- If it is not an associative array attribute
440
441 if Index = No_Name then
442
443 -- It is not an associative array attribute
444
445 if The_Package /= No_Package then
446
447 -- First, if there is a package, look into the package
448
449 if
450 Kind_Of (The_Current_Term) = N_Variable_Reference
451 then
452 The_Variable_Id :=
453 Packages.Table (The_Package).Decl.Variables;
454
455 else
456 The_Variable_Id :=
457 Packages.Table (The_Package).Decl.Attributes;
458 end if;
459
460 while The_Variable_Id /= No_Variable
461 and then
462 Variable_Elements.Table (The_Variable_Id).Name /=
463 The_Name
464 loop
465 The_Variable_Id :=
466 Variable_Elements.Table (The_Variable_Id).Next;
467 end loop;
468
469 end if;
470
471 if The_Variable_Id = No_Variable then
472
473 -- If we have not found it, look into the project
474
475 if
476 Kind_Of (The_Current_Term) = N_Variable_Reference
477 then
478 The_Variable_Id :=
479 Projects.Table (The_Project).Decl.Variables;
480
481 else
482 The_Variable_Id :=
483 Projects.Table (The_Project).Decl.Attributes;
484 end if;
485
486 while The_Variable_Id /= No_Variable
487 and then
488 Variable_Elements.Table (The_Variable_Id).Name /=
489 The_Name
490 loop
491 The_Variable_Id :=
492 Variable_Elements.Table (The_Variable_Id).Next;
493 end loop;
494
495 end if;
496
497 pragma Assert (The_Variable_Id /= No_Variable,
498 "variable or attribute not found");
499
500 The_Variable := Variable_Elements.Table
501 (The_Variable_Id).Value;
502
503 else
504
505 -- It is an associative array attribute
506
507 declare
508 The_Array : Array_Id := No_Array;
509 The_Element : Array_Element_Id := No_Array_Element;
510 Array_Index : Name_Id := No_Name;
511 begin
512 if The_Package /= No_Package then
513 The_Array :=
514 Packages.Table (The_Package).Decl.Arrays;
515
516 else
517 The_Array :=
518 Projects.Table (The_Project).Decl.Arrays;
519 end if;
520
521 while The_Array /= No_Array
522 and then Arrays.Table (The_Array).Name /= The_Name
523 loop
524 The_Array := Arrays.Table (The_Array).Next;
525 end loop;
526
527 if The_Array /= No_Array then
528 The_Element := Arrays.Table (The_Array).Value;
529
530 Get_Name_String (Index);
531
532 if Case_Insensitive (The_Current_Term) then
533 To_Lower (Name_Buffer (1 .. Name_Len));
534 end if;
535
536 Array_Index := Name_Find;
537
538 while The_Element /= No_Array_Element
539 and then Array_Elements.Table (The_Element).Index
540 /= Array_Index
541 loop
542 The_Element :=
543 Array_Elements.Table (The_Element).Next;
544 end loop;
545
546 end if;
547
548 if The_Element /= No_Array_Element then
549 The_Variable :=
550 Array_Elements.Table (The_Element).Value;
551
552 else
553 if
554 Expression_Kind_Of (The_Current_Term) = List
555 then
556 The_Variable :=
557 (Project => Project,
558 Kind => List,
559 Location => No_Location,
560 Default => True,
561 Values => Nil_String);
562
563 else
564 The_Variable :=
565 (Project => Project,
566 Kind => Single,
567 Location => No_Location,
568 Default => True,
569 Value => Empty_String,
570 Index => 0);
571 end if;
572 end if;
573 end;
574 end if;
575
576 case Kind is
577
578 when Undefined =>
579
580 -- Should never happen
581
582 pragma Assert (False, "undefined expression kind");
583 null;
584
585 when Single =>
586
587 case The_Variable.Kind is
588
589 when Undefined =>
590 null;
591
592 when Single =>
593 Add (Result.Value, The_Variable.Value);
594
595 when List =>
596
597 -- Should never happen
598
599 pragma Assert
600 (False,
601 "list cannot appear in single " &
602 "string expression");
603 null;
604 end case;
605
606 when List =>
607 case The_Variable.Kind is
608
609 when Undefined =>
610 null;
611
612 when Single =>
613 String_Elements.Increment_Last;
614
615 if Last = Nil_String then
616
617 -- This can happen in an expression such as
618 -- () & Var
619
620 Result.Values := String_Elements.Last;
621
622 else
623 String_Elements.Table (Last).Next :=
624 String_Elements.Last;
625 end if;
626
627 Last := String_Elements.Last;
628 String_Elements.Table (Last) :=
629 (Value => The_Variable.Value,
630 Display_Value => No_Name,
631 Location => Location_Of (The_Current_Term),
632 Flag => False,
633 Next => Nil_String,
634 Index => 0);
635
636 when List =>
637
638 declare
639 The_List : String_List_Id :=
640 The_Variable.Values;
641
642 begin
643 while The_List /= Nil_String loop
644 String_Elements.Increment_Last;
645
646 if Last = Nil_String then
647 Result.Values := String_Elements.Last;
648
649 else
650 String_Elements.Table (Last).Next :=
651 String_Elements.Last;
652
653 end if;
654
655 Last := String_Elements.Last;
656 String_Elements.Table (Last) :=
657 (Value =>
658 String_Elements.Table
659 (The_List).Value,
660 Display_Value => No_Name,
661 Location => Location_Of
662 (The_Current_Term),
663 Flag => False,
664 Next => Nil_String,
665 Index => 0);
666 The_List :=
667 String_Elements.Table (The_List).Next;
668 end loop;
669 end;
670 end case;
671 end case;
672 end;
673
674 when N_External_Value =>
675 Get_Name_String
676 (String_Value_Of (External_Reference_Of (The_Current_Term)));
677
678 declare
679 Name : constant Name_Id := Name_Find;
680 Default : Name_Id := No_Name;
681 Value : Name_Id := No_Name;
682
683 Default_Node : constant Project_Node_Id :=
684 External_Default_Of (The_Current_Term);
685
686 begin
687 if Default_Node /= Empty_Node then
688 Default := String_Value_Of (Default_Node);
689 end if;
690
691 Value := Prj.Ext.Value_Of (Name, Default);
692
693 if Value = No_Name then
694 if not Opt.Quiet_Output then
695 if Error_Report = null then
696 Error_Msg
697 ("?undefined external reference",
698 Location_Of (The_Current_Term));
699
700 else
701 Error_Report
702 ("warning: """ & Get_Name_String (Name) &
703 """ is an undefined external reference",
704 Project);
705 end if;
706 end if;
707
708 Value := Empty_String;
709
710 end if;
711
712 case Kind is
713
714 when Undefined =>
715 null;
716
717 when Single =>
718 Add (Result.Value, Value);
719
720 when List =>
721 String_Elements.Increment_Last;
722
723 if Last = Nil_String then
724 Result.Values := String_Elements.Last;
725
726 else
727 String_Elements.Table (Last).Next :=
728 String_Elements.Last;
729 end if;
730
731 Last := String_Elements.Last;
732 String_Elements.Table (Last) :=
733 (Value => Value,
734 Display_Value => No_Name,
735 Location => Location_Of (The_Current_Term),
736 Flag => False,
737 Next => Nil_String,
738 Index => 0);
739
740 end case;
741 end;
742
743 when others =>
744
745 -- Should never happen
746
747 pragma Assert
748 (False,
749 "illegal node kind in an expression");
750 raise Program_Error;
751
752 end case;
753
754 The_Term := Next_Term (The_Term);
755 end loop;
756
757 return Result;
758 end Expression;
759
760 ---------------------------------------
761 -- Imported_Or_Extended_Project_From --
762 ---------------------------------------
763
764 function Imported_Or_Extended_Project_From
765 (Project : Project_Id;
766 With_Name : Name_Id) return Project_Id
767 is
768 Data : constant Project_Data := Projects.Table (Project);
769 List : Project_List := Data.Imported_Projects;
770
771 begin
772 -- First check if it is the name of a extended project
773
774 if Data.Extends /= No_Project
775 and then Projects.Table (Data.Extends).Name = With_Name
776 then
777 return Data.Extends;
778
779 else
780 -- Then check the name of each imported project
781
782 while List /= Empty_Project_List
783 and then
784 Projects.Table
785 (Project_Lists.Table (List).Project).Name /= With_Name
786
787 loop
788 List := Project_Lists.Table (List).Next;
789 end loop;
790
791 pragma Assert
792 (List /= Empty_Project_List,
793 "project not found");
794
795 return Project_Lists.Table (List).Project;
796 end if;
797 end Imported_Or_Extended_Project_From;
798
799 ------------------
800 -- Package_From --
801 ------------------
802
803 function Package_From
804 (Project : Project_Id;
805 With_Name : Name_Id) return Package_Id
806 is
807 Data : constant Project_Data := Projects.Table (Project);
808 Result : Package_Id := Data.Decl.Packages;
809
810 begin
811 -- Check the name of each existing package of Project
812
813 while Result /= No_Package
814 and then
815 Packages.Table (Result).Name /= With_Name
816 loop
817 Result := Packages.Table (Result).Next;
818 end loop;
819
820 if Result = No_Package then
821 -- Should never happen
822 Write_Line ("package """ & Get_Name_String (With_Name) &
823 """ not found");
824 raise Program_Error;
825
826 else
827 return Result;
828 end if;
829 end Package_From;
830
831 -------------
832 -- Process --
833 -------------
834
835 procedure Process
836 (Project : out Project_Id;
837 Success : out Boolean;
838 From_Project_Node : Project_Node_Id;
839 Report_Error : Put_Line_Access;
840 Process_Languages : Languages_Processed := Ada_Language;
841 Follow_Links : Boolean := True)
842 is
843 Obj_Dir : Name_Id;
844 Extending : Project_Id;
845 Extending2 : Project_Id;
846
847 begin
848 Error_Report := Report_Error;
849 Success := True;
850
851 -- Make sure there is no projects in the data structure
852
853 Projects.Set_Last (No_Project);
854 Processed_Projects.Reset;
855
856 -- And process the main project and all of the projects it depends on,
857 -- recursively
858
859 Recursive_Process
860 (Project => Project,
861 From_Project_Node => From_Project_Node,
862 Extended_By => No_Project);
863
864 if Project /= No_Project then
865 Check (Project, Process_Languages, Follow_Links);
866 end if;
867
868 -- If main project is an extending all project, set the object
869 -- directory of all virtual extending projects to the object directory
870 -- of the main project.
871
872 if Project /= No_Project
873 and then Is_Extending_All (From_Project_Node)
874 then
875 declare
876 Object_Dir : constant Name_Id :=
877 Projects.Table (Project).Object_Directory;
878 begin
879 for Index in Projects.First .. Projects.Last loop
880 if Projects.Table (Index).Virtual then
881 Projects.Table (Index).Object_Directory := Object_Dir;
882 end if;
883 end loop;
884 end;
885 end if;
886
887 -- Check that no extending project shares its object directory with
888 -- the project(s) it extends.
889
890 if Project /= No_Project then
891 for Proj in 1 .. Projects.Last loop
892 Extending := Projects.Table (Proj).Extended_By;
893
894 if Extending /= No_Project then
895 Obj_Dir := Projects.Table (Proj).Object_Directory;
896
897 -- Check that a project being extended does not share its
898 -- object directory with any project that extends it, directly
899 -- or indirectly, including a virtual extending project.
900
901 -- Start with the project directly extending it
902
903 Extending2 := Extending;
904
905 while Extending2 /= No_Project loop
906 if Projects.Table (Extending2).Sources_Present
907 and then
908 Projects.Table (Extending2).Object_Directory = Obj_Dir
909 then
910 if Projects.Table (Extending2).Virtual then
911 Error_Msg_Name_1 := Projects.Table (Proj).Name;
912
913 if Error_Report = null then
914 Error_Msg
915 ("project % cannot be extended by a virtual " &
916 "project with the same object directory",
917 Projects.Table (Proj).Location);
918
919 else
920 Error_Report
921 ("project """ &
922 Get_Name_String (Error_Msg_Name_1) &
923 """ cannot be extended by a virtual " &
924 "project with the same object directory",
925 Project);
926 end if;
927
928 else
929 Error_Msg_Name_1 :=
930 Projects.Table (Extending2).Name;
931 Error_Msg_Name_2 := Projects.Table (Proj).Name;
932
933 if Error_Report = null then
934 Error_Msg
935 ("project % cannot extend project %",
936 Projects.Table (Extending2).Location);
937 Error_Msg
938 ("\they share the same object directory",
939 Projects.Table (Extending2).Location);
940
941 else
942 Error_Report
943 ("project """ &
944 Get_Name_String (Error_Msg_Name_1) &
945 """ cannot extend project """ &
946 Get_Name_String (Error_Msg_Name_2) & """",
947 Project);
948 Error_Report
949 ("they share the same object directory",
950 Project);
951 end if;
952 end if;
953 end if;
954
955 -- Continue with the next extending project, if any
956
957 Extending2 := Projects.Table (Extending2).Extended_By;
958 end loop;
959 end if;
960 end loop;
961 end if;
962
963 Success := Total_Errors_Detected <= 0;
964 end Process;
965
966 -------------------------------
967 -- Process_Declarative_Items --
968 -------------------------------
969
970 procedure Process_Declarative_Items
971 (Project : Project_Id;
972 From_Project_Node : Project_Node_Id;
973 Pkg : Package_Id;
974 Item : Project_Node_Id)
975 is
976 Current_Declarative_Item : Project_Node_Id := Item;
977 Current_Item : Project_Node_Id := Empty_Node;
978
979 begin
980 -- For each declarative item
981
982 while Current_Declarative_Item /= Empty_Node loop
983
984 -- Get its data
985
986 Current_Item := Current_Item_Node (Current_Declarative_Item);
987
988 -- And set Current_Declarative_Item to the next declarative item
989 -- ready for the next iteration.
990
991 Current_Declarative_Item := Next_Declarative_Item
992 (Current_Declarative_Item);
993
994 case Kind_Of (Current_Item) is
995
996 when N_Package_Declaration =>
997 -- Do not process a package declaration that should be ignored
998
999 if Expression_Kind_Of (Current_Item) /= Ignored then
1000 -- Create the new package
1001
1002 Packages.Increment_Last;
1003
1004 declare
1005 New_Pkg : constant Package_Id := Packages.Last;
1006 The_New_Package : Package_Element;
1007
1008 Project_Of_Renamed_Package : constant Project_Node_Id :=
1009 Project_Of_Renamed_Package_Of
1010 (Current_Item);
1011
1012 begin
1013 -- Set the name of the new package
1014
1015 The_New_Package.Name := Name_Of (Current_Item);
1016
1017 -- Insert the new package in the appropriate list
1018
1019 if Pkg /= No_Package then
1020 The_New_Package.Next :=
1021 Packages.Table (Pkg).Decl.Packages;
1022 Packages.Table (Pkg).Decl.Packages := New_Pkg;
1023 else
1024 The_New_Package.Next :=
1025 Projects.Table (Project).Decl.Packages;
1026 Projects.Table (Project).Decl.Packages := New_Pkg;
1027 end if;
1028
1029 Packages.Table (New_Pkg) := The_New_Package;
1030
1031 if Project_Of_Renamed_Package /= Empty_Node then
1032
1033 -- Renamed package
1034
1035 declare
1036 Project_Name : constant Name_Id :=
1037 Name_Of
1038 (Project_Of_Renamed_Package);
1039
1040 Renamed_Project : constant Project_Id :=
1041 Imported_Or_Extended_Project_From
1042 (Project, Project_Name);
1043
1044 Renamed_Package : constant Package_Id :=
1045 Package_From
1046 (Renamed_Project,
1047 Name_Of (Current_Item));
1048
1049 begin
1050 -- For a renamed package, set declarations to
1051 -- the declarations of the renamed package.
1052
1053 Packages.Table (New_Pkg).Decl :=
1054 Packages.Table (Renamed_Package).Decl;
1055 end;
1056
1057 -- Standard package declaration, not renaming
1058
1059 else
1060 -- Set the default values of the attributes
1061
1062 Add_Attributes
1063 (Project,
1064 Packages.Table (New_Pkg).Decl,
1065 Package_Attributes.Table
1066 (Package_Id_Of (Current_Item)).First_Attribute);
1067
1068 -- And process declarative items of the new package
1069
1070 Process_Declarative_Items
1071 (Project => Project,
1072 From_Project_Node => From_Project_Node,
1073 Pkg => New_Pkg,
1074 Item => First_Declarative_Item_Of
1075 (Current_Item));
1076 end if;
1077 end;
1078 end if;
1079
1080 when N_String_Type_Declaration =>
1081
1082 -- There is nothing to process
1083
1084 null;
1085
1086 when N_Attribute_Declaration |
1087 N_Typed_Variable_Declaration |
1088 N_Variable_Declaration =>
1089
1090 if Expression_Of (Current_Item) = Empty_Node then
1091
1092 -- It must be a full associative array attribute declaration
1093
1094 declare
1095 Current_Item_Name : constant Name_Id :=
1096 Name_Of (Current_Item);
1097 -- The name of the attribute
1098
1099 New_Array : Array_Id;
1100 -- The new associative array created
1101
1102 Orig_Array : Array_Id;
1103 -- The associative array value
1104
1105 Orig_Project_Name : Name_Id := No_Name;
1106 -- The name of the project where the associative array
1107 -- value is.
1108
1109 Orig_Project : Project_Id := No_Project;
1110 -- The id of the project where the associative array
1111 -- value is.
1112
1113 Orig_Package_Name : Name_Id := No_Name;
1114 -- The name of the package, if any, where the associative
1115 -- array value is.
1116
1117 Orig_Package : Package_Id := No_Package;
1118 -- The id of the package, if any, where the associative
1119 -- array value is.
1120
1121 New_Element : Array_Element_Id := No_Array_Element;
1122 -- Id of a new array element created
1123
1124 Prev_Element : Array_Element_Id := No_Array_Element;
1125 -- Last new element id created
1126
1127 Orig_Element : Array_Element_Id := No_Array_Element;
1128 -- Current array element in the original associative
1129 -- array.
1130
1131 Next_Element : Array_Element_Id := No_Array_Element;
1132 -- Id of the array element that follows the new element.
1133 -- This is not always nil, because values for the
1134 -- associative array attribute may already have been
1135 -- declared, and the array elements declared are reused.
1136
1137 begin
1138 -- First, find if the associative array attribute already
1139 -- has elements declared.
1140
1141 if Pkg /= No_Package then
1142 New_Array := Packages.Table (Pkg).Decl.Arrays;
1143
1144 else
1145 New_Array := Projects.Table (Project).Decl.Arrays;
1146 end if;
1147
1148 while New_Array /= No_Array and then
1149 Arrays.Table (New_Array).Name /= Current_Item_Name
1150 loop
1151 New_Array := Arrays.Table (New_Array).Next;
1152 end loop;
1153
1154 -- If the attribute has never been declared add new entry
1155 -- in the arrays of the project/package and link it.
1156
1157 if New_Array = No_Array then
1158 Arrays.Increment_Last;
1159 New_Array := Arrays.Last;
1160
1161 if Pkg /= No_Package then
1162 Arrays.Table (New_Array) :=
1163 (Name => Current_Item_Name,
1164 Value => No_Array_Element,
1165 Next => Packages.Table (Pkg).Decl.Arrays);
1166 Packages.Table (Pkg).Decl.Arrays := New_Array;
1167
1168 else
1169 Arrays.Table (New_Array) :=
1170 (Name => Current_Item_Name,
1171 Value => No_Array_Element,
1172 Next => Projects.Table (Project).Decl.Arrays);
1173 Projects.Table (Project).Decl.Arrays := New_Array;
1174 end if;
1175 end if;
1176
1177 -- Find the project where the value is declared
1178
1179 Orig_Project_Name :=
1180 Name_Of (Associative_Project_Of (Current_Item));
1181
1182 for Index in Projects.First .. Projects.Last loop
1183 if Projects.Table (Index).Name = Orig_Project_Name then
1184 Orig_Project := Index;
1185 exit;
1186 end if;
1187 end loop;
1188
1189 pragma Assert (Orig_Project /= No_Project,
1190 "original project not found");
1191
1192 if Associative_Package_Of (Current_Item) = Empty_Node then
1193 Orig_Array :=
1194 Projects.Table (Orig_Project).Decl.Arrays;
1195
1196 else
1197 -- If in a package, find the package where the
1198 -- value is declared.
1199
1200 Orig_Package_Name :=
1201 Name_Of (Associative_Package_Of (Current_Item));
1202 Orig_Package :=
1203 Projects.Table (Orig_Project).Decl.Packages;
1204 pragma Assert (Orig_Package /= No_Package,
1205 "original package not found");
1206
1207 while Packages.Table (Orig_Package).Name /=
1208 Orig_Package_Name
1209 loop
1210 Orig_Package := Packages.Table (Orig_Package).Next;
1211 pragma Assert (Orig_Package /= No_Package,
1212 "original package not found");
1213 end loop;
1214
1215 Orig_Array :=
1216 Packages.Table (Orig_Package).Decl.Arrays;
1217 end if;
1218
1219 -- Now look for the array
1220
1221 while Orig_Array /= No_Array and then
1222 Arrays.Table (Orig_Array).Name /= Current_Item_Name
1223 loop
1224 Orig_Array := Arrays.Table (Orig_Array).Next;
1225 end loop;
1226
1227 if Orig_Array = No_Array then
1228 if Error_Report = null then
1229 Error_Msg
1230 ("associative array value cannot be found",
1231 Location_Of (Current_Item));
1232
1233 else
1234 Error_Report
1235 ("associative array value cannot be found",
1236 Project);
1237 end if;
1238
1239 else
1240 Orig_Element := Arrays.Table (Orig_Array).Value;
1241
1242 -- Copy each array element
1243
1244 while Orig_Element /= No_Array_Element loop
1245 -- If it is the first element ...
1246
1247 if Prev_Element = No_Array_Element then
1248 -- And there is no array element declared yet,
1249 -- create a new first array element.
1250
1251 if Arrays.Table (New_Array).Value =
1252 No_Array_Element
1253 then
1254 Array_Elements.Increment_Last;
1255 New_Element := Array_Elements.Last;
1256 Arrays.Table (New_Array).Value := New_Element;
1257 Next_Element := No_Array_Element;
1258
1259 -- Otherwise, the new element is the first
1260
1261 else
1262 New_Element := Arrays.Table (New_Array).Value;
1263 Next_Element :=
1264 Array_Elements.Table (New_Element).Next;
1265 end if;
1266
1267 -- Otherwise, reuse an existing element, or create
1268 -- one if necessary.
1269
1270 else
1271 Next_Element :=
1272 Array_Elements.Table (Prev_Element).Next;
1273
1274 if Next_Element = No_Array_Element then
1275 Array_Elements.Increment_Last;
1276 New_Element := Array_Elements.Last;
1277
1278 else
1279 New_Element := Next_Element;
1280 Next_Element :=
1281 Array_Elements.Table (New_Element).Next;
1282 end if;
1283 end if;
1284
1285 -- Copy the value of the element
1286
1287 Array_Elements.Table (New_Element) :=
1288 Array_Elements.Table (Orig_Element);
1289 Array_Elements.Table (New_Element).Value.Project :=
1290 Project;
1291
1292 -- Adjust the Next link
1293
1294 Array_Elements.Table (New_Element).Next :=
1295 Next_Element;
1296
1297 -- Adjust the previous id for the next element
1298
1299 Prev_Element := New_Element;
1300
1301 -- Go to the next element in the original array
1302 Orig_Element :=
1303 Array_Elements.Table (Orig_Element).Next;
1304 end loop;
1305
1306 -- Make sure that the array ends here, in case there
1307 -- previously a greater number of elements.
1308
1309 Array_Elements.Table (New_Element).Next :=
1310 No_Array_Element;
1311 end if;
1312 end;
1313
1314 -- Declarations other that full associative arrays
1315
1316 else
1317 declare
1318 New_Value : constant Variable_Value :=
1319 Expression
1320 (Project => Project,
1321 From_Project_Node => From_Project_Node,
1322 Pkg => Pkg,
1323 First_Term =>
1324 Tree.First_Term (Expression_Of
1325 (Current_Item)),
1326 Kind =>
1327 Expression_Kind_Of (Current_Item));
1328 -- The expression value
1329
1330 The_Variable : Variable_Id := No_Variable;
1331
1332 Current_Item_Name : constant Name_Id :=
1333 Name_Of (Current_Item);
1334
1335 begin
1336 -- Process a typed variable declaration
1337
1338 if
1339 Kind_Of (Current_Item) = N_Typed_Variable_Declaration
1340 then
1341 -- Report an error for an empty string
1342
1343 if New_Value.Value = Empty_String then
1344 Error_Msg_Name_1 := Name_Of (Current_Item);
1345
1346 if Error_Report = null then
1347 Error_Msg
1348 ("no value defined for %",
1349 Location_Of (Current_Item));
1350
1351 else
1352 Error_Report
1353 ("no value defined for " &
1354 Get_Name_String (Error_Msg_Name_1),
1355 Project);
1356 end if;
1357
1358 else
1359 declare
1360 Current_String : Project_Node_Id :=
1361 First_Literal_String
1362 (String_Type_Of
1363 (Current_Item));
1364
1365 begin
1366 -- Loop through all the valid strings for
1367 -- the string type and compare to the string
1368 -- value.
1369
1370 while Current_String /= Empty_Node
1371 and then String_Value_Of (Current_String) /=
1372 New_Value.Value
1373 loop
1374 Current_String :=
1375 Next_Literal_String (Current_String);
1376 end loop;
1377
1378 -- Report an error if the string value is not
1379 -- one for the string type.
1380
1381 if Current_String = Empty_Node then
1382 Error_Msg_Name_1 := New_Value.Value;
1383 Error_Msg_Name_2 := Name_Of (Current_Item);
1384
1385 if Error_Report = null then
1386 Error_Msg
1387 ("value { is illegal for typed string %",
1388 Location_Of (Current_Item));
1389
1390 else
1391 Error_Report
1392 ("value """ &
1393 Get_Name_String (Error_Msg_Name_1) &
1394 """ is illegal for typed string """ &
1395 Get_Name_String (Error_Msg_Name_2) &
1396 """",
1397 Project);
1398 end if;
1399 end if;
1400 end;
1401 end if;
1402 end if;
1403
1404 if Kind_Of (Current_Item) /= N_Attribute_Declaration
1405 or else
1406 Associative_Array_Index_Of (Current_Item) = No_Name
1407 then
1408 -- Case of a variable declaration or of a not
1409 -- associative array attribute.
1410
1411 -- First, find the list where to find the variable
1412 -- or attribute.
1413
1414 if
1415 Kind_Of (Current_Item) = N_Attribute_Declaration
1416 then
1417 if Pkg /= No_Package then
1418 The_Variable :=
1419 Packages.Table (Pkg).Decl.Attributes;
1420
1421 else
1422 The_Variable :=
1423 Projects.Table (Project).Decl.Attributes;
1424 end if;
1425
1426 else
1427 if Pkg /= No_Package then
1428 The_Variable :=
1429 Packages.Table (Pkg).Decl.Variables;
1430
1431 else
1432 The_Variable :=
1433 Projects.Table (Project).Decl.Variables;
1434 end if;
1435
1436 end if;
1437
1438 -- Loop through the list, to find if it has already
1439 -- been declared.
1440
1441 while
1442 The_Variable /= No_Variable
1443 and then
1444 Variable_Elements.Table (The_Variable).Name /=
1445 Current_Item_Name
1446 loop
1447 The_Variable :=
1448 Variable_Elements.Table (The_Variable).Next;
1449 end loop;
1450
1451 -- If it has not been declared, create a new entry
1452 -- in the list.
1453
1454 if The_Variable = No_Variable then
1455 -- All single string attribute should already have
1456 -- been declared with a default empty string value.
1457
1458 pragma Assert
1459 (Kind_Of (Current_Item) /=
1460 N_Attribute_Declaration,
1461 "illegal attribute declaration");
1462
1463 Variable_Elements.Increment_Last;
1464 The_Variable := Variable_Elements.Last;
1465
1466 -- Put the new variable in the appropriate list
1467
1468 if Pkg /= No_Package then
1469 Variable_Elements.Table (The_Variable) :=
1470 (Next =>
1471 Packages.Table (Pkg).Decl.Variables,
1472 Name => Current_Item_Name,
1473 Value => New_Value);
1474 Packages.Table (Pkg).Decl.Variables :=
1475 The_Variable;
1476
1477 else
1478 Variable_Elements.Table (The_Variable) :=
1479 (Next =>
1480 Projects.Table (Project).Decl.Variables,
1481 Name => Current_Item_Name,
1482 Value => New_Value);
1483 Projects.Table (Project).Decl.Variables :=
1484 The_Variable;
1485 end if;
1486
1487 -- If the variable/attribute has already been
1488 -- declared, just change the value.
1489
1490 else
1491 Variable_Elements.Table (The_Variable).Value :=
1492 New_Value;
1493
1494 end if;
1495
1496 else
1497 -- Associative array attribute
1498
1499 -- Get the string index
1500
1501 Get_Name_String
1502 (Associative_Array_Index_Of (Current_Item));
1503
1504 -- Put in lower case, if necessary
1505
1506 if Case_Insensitive (Current_Item) then
1507 GNAT.Case_Util.To_Lower
1508 (Name_Buffer (1 .. Name_Len));
1509 end if;
1510
1511 declare
1512 The_Array : Array_Id;
1513
1514 The_Array_Element : Array_Element_Id :=
1515 No_Array_Element;
1516
1517 Index_Name : constant Name_Id := Name_Find;
1518 -- The name id of the index
1519
1520 begin
1521 -- Look for the array in the appropriate list
1522
1523 if Pkg /= No_Package then
1524 The_Array := Packages.Table (Pkg).Decl.Arrays;
1525
1526 else
1527 The_Array := Projects.Table
1528 (Project).Decl.Arrays;
1529 end if;
1530
1531 while
1532 The_Array /= No_Array
1533 and then Arrays.Table (The_Array).Name /=
1534 Current_Item_Name
1535 loop
1536 The_Array := Arrays.Table (The_Array).Next;
1537 end loop;
1538
1539 -- If the array cannot be found, create a new
1540 -- entry in the list. As The_Array_Element is
1541 -- initialized to No_Array_Element, a new element
1542 -- will be created automatically later.
1543
1544 if The_Array = No_Array then
1545 Arrays.Increment_Last;
1546 The_Array := Arrays.Last;
1547
1548 if Pkg /= No_Package then
1549 Arrays.Table (The_Array) :=
1550 (Name => Current_Item_Name,
1551 Value => No_Array_Element,
1552 Next => Packages.Table (Pkg).Decl.Arrays);
1553 Packages.Table (Pkg).Decl.Arrays := The_Array;
1554
1555 else
1556 Arrays.Table (The_Array) :=
1557 (Name => Current_Item_Name,
1558 Value => No_Array_Element,
1559 Next =>
1560 Projects.Table (Project).Decl.Arrays);
1561 Projects.Table (Project).Decl.Arrays :=
1562 The_Array;
1563 end if;
1564
1565 -- Otherwise, initialize The_Array_Element as the
1566 -- head of the element list.
1567
1568 else
1569 The_Array_Element :=
1570 Arrays.Table (The_Array).Value;
1571 end if;
1572
1573 -- Look in the list, if any, to find an element
1574 -- with the same index.
1575
1576 while The_Array_Element /= No_Array_Element
1577 and then
1578 Array_Elements.Table (The_Array_Element).Index /=
1579 Index_Name
1580 loop
1581 The_Array_Element :=
1582 Array_Elements.Table (The_Array_Element).Next;
1583 end loop;
1584
1585 -- If no such element were found, create a new
1586 -- one and insert it in the element list, with
1587 -- the propoer value.
1588
1589 if The_Array_Element = No_Array_Element then
1590 Array_Elements.Increment_Last;
1591 The_Array_Element := Array_Elements.Last;
1592
1593 Array_Elements.Table (The_Array_Element) :=
1594 (Index => Index_Name,
1595 Src_Index => Source_Index_Of (Current_Item),
1596 Index_Case_Sensitive =>
1597 not Case_Insensitive (Current_Item),
1598 Value => New_Value,
1599 Next => Arrays.Table (The_Array).Value);
1600 Arrays.Table (The_Array).Value :=
1601 The_Array_Element;
1602
1603 -- An element with the same index already exists,
1604 -- just replace its value with the new one.
1605
1606 else
1607 Array_Elements.Table (The_Array_Element).Value :=
1608 New_Value;
1609 end if;
1610 end;
1611 end if;
1612 end;
1613 end if;
1614
1615 when N_Case_Construction =>
1616 declare
1617 The_Project : Project_Id := Project;
1618 -- The id of the project of the case variable
1619
1620 The_Package : Package_Id := Pkg;
1621 -- The id of the package, if any, of the case variable
1622
1623 The_Variable : Variable_Value := Nil_Variable_Value;
1624 -- The case variable
1625
1626 Case_Value : Name_Id := No_Name;
1627 -- The case variable value
1628
1629 Case_Item : Project_Node_Id := Empty_Node;
1630 Choice_String : Project_Node_Id := Empty_Node;
1631 Decl_Item : Project_Node_Id := Empty_Node;
1632
1633 begin
1634 declare
1635 Variable_Node : constant Project_Node_Id :=
1636 Case_Variable_Reference_Of
1637 (Current_Item);
1638
1639 Var_Id : Variable_Id := No_Variable;
1640 Name : Name_Id := No_Name;
1641
1642 begin
1643 -- If a project were specified for the case variable,
1644 -- get its id.
1645
1646 if Project_Node_Of (Variable_Node) /= Empty_Node then
1647 Name := Name_Of (Project_Node_Of (Variable_Node));
1648 The_Project :=
1649 Imported_Or_Extended_Project_From (Project, Name);
1650 end if;
1651
1652 -- If a package were specified for the case variable,
1653 -- get its id.
1654
1655 if Package_Node_Of (Variable_Node) /= Empty_Node then
1656 Name := Name_Of (Package_Node_Of (Variable_Node));
1657 The_Package := Package_From (The_Project, Name);
1658 end if;
1659
1660 Name := Name_Of (Variable_Node);
1661
1662 -- First, look for the case variable into the package,
1663 -- if any.
1664
1665 if The_Package /= No_Package then
1666 Var_Id := Packages.Table (The_Package).Decl.Variables;
1667 Name := Name_Of (Variable_Node);
1668 while Var_Id /= No_Variable
1669 and then
1670 Variable_Elements.Table (Var_Id).Name /= Name
1671 loop
1672 Var_Id := Variable_Elements.Table (Var_Id).Next;
1673 end loop;
1674 end if;
1675
1676 -- If not found in the package, or if there is no
1677 -- package, look at the project level.
1678
1679 if Var_Id = No_Variable
1680 and then Package_Node_Of (Variable_Node) = Empty_Node
1681 then
1682 Var_Id := Projects.Table (The_Project).Decl.Variables;
1683 while Var_Id /= No_Variable
1684 and then
1685 Variable_Elements.Table (Var_Id).Name /= Name
1686 loop
1687 Var_Id := Variable_Elements.Table (Var_Id).Next;
1688 end loop;
1689 end if;
1690
1691 if Var_Id = No_Variable then
1692
1693 -- Should never happen, because this has already been
1694 -- checked during parsing.
1695
1696 Write_Line ("variable """ &
1697 Get_Name_String (Name) &
1698 """ not found");
1699 raise Program_Error;
1700 end if;
1701
1702 -- Get the case variable
1703
1704 The_Variable := Variable_Elements.Table (Var_Id).Value;
1705
1706 if The_Variable.Kind /= Single then
1707
1708 -- Should never happen, because this has already been
1709 -- checked during parsing.
1710
1711 Write_Line ("variable""" &
1712 Get_Name_String (Name) &
1713 """ is not a single string variable");
1714 raise Program_Error;
1715 end if;
1716
1717 -- Get the case variable value
1718 Case_Value := The_Variable.Value;
1719 end;
1720
1721 -- Now look into all the case items of the case construction
1722
1723 Case_Item := First_Case_Item_Of (Current_Item);
1724 Case_Item_Loop :
1725 while Case_Item /= Empty_Node loop
1726 Choice_String := First_Choice_Of (Case_Item);
1727
1728 -- When Choice_String is nil, it means that it is
1729 -- the "when others =>" alternative.
1730
1731 if Choice_String = Empty_Node then
1732 Decl_Item := First_Declarative_Item_Of (Case_Item);
1733 exit Case_Item_Loop;
1734 end if;
1735
1736 -- Look into all the alternative of this case item
1737
1738 Choice_Loop :
1739 while Choice_String /= Empty_Node loop
1740 if
1741 Case_Value = String_Value_Of (Choice_String)
1742 then
1743 Decl_Item :=
1744 First_Declarative_Item_Of (Case_Item);
1745 exit Case_Item_Loop;
1746 end if;
1747
1748 Choice_String :=
1749 Next_Literal_String (Choice_String);
1750 end loop Choice_Loop;
1751 Case_Item := Next_Case_Item (Case_Item);
1752 end loop Case_Item_Loop;
1753
1754 -- If there is an alternative, then we process it
1755
1756 if Decl_Item /= Empty_Node then
1757 Process_Declarative_Items
1758 (Project => Project,
1759 From_Project_Node => From_Project_Node,
1760 Pkg => Pkg,
1761 Item => Decl_Item);
1762 end if;
1763 end;
1764
1765 when others =>
1766
1767 -- Should never happen
1768
1769 Write_Line ("Illegal declarative item: " &
1770 Project_Node_Kind'Image (Kind_Of (Current_Item)));
1771 raise Program_Error;
1772 end case;
1773 end loop;
1774 end Process_Declarative_Items;
1775
1776 ---------------------
1777 -- Recursive_Check --
1778 ---------------------
1779
1780 procedure Recursive_Check
1781 (Project : Project_Id;
1782 Process_Languages : Languages_Processed;
1783 Follow_Links : Boolean)
1784 is
1785 Data : Project_Data;
1786 Imported_Project_List : Project_List := Empty_Project_List;
1787
1788 begin
1789 -- Do nothing if Project is No_Project, or Project has already
1790 -- been marked as checked.
1791
1792 if Project /= No_Project
1793 and then not Projects.Table (Project).Checked
1794 then
1795 -- Mark project as checked, to avoid infinite recursion in
1796 -- ill-formed trees, where a project imports itself.
1797
1798 Projects.Table (Project).Checked := True;
1799
1800 Data := Projects.Table (Project);
1801
1802 -- Call itself for a possible extended project.
1803 -- (if there is no extended project, then nothing happens).
1804
1805 Recursive_Check (Data.Extends, Process_Languages, Follow_Links);
1806
1807 -- Call itself for all imported projects
1808
1809 Imported_Project_List := Data.Imported_Projects;
1810 while Imported_Project_List /= Empty_Project_List loop
1811 Recursive_Check
1812 (Project_Lists.Table (Imported_Project_List).Project,
1813 Process_Languages, Follow_Links);
1814 Imported_Project_List :=
1815 Project_Lists.Table (Imported_Project_List).Next;
1816 end loop;
1817
1818 if Opt.Verbose_Mode then
1819 Write_Str ("Checking project file """);
1820 Write_Str (Get_Name_String (Data.Name));
1821 Write_Line ("""");
1822 end if;
1823
1824 case Process_Languages is
1825 when Ada_Language =>
1826 Prj.Nmsc.Ada_Check (Project, Error_Report, Follow_Links);
1827
1828 when Other_Languages =>
1829 Prj.Nmsc.Other_Languages_Check (Project, Error_Report);
1830 end case;
1831 end if;
1832 end Recursive_Check;
1833
1834 -----------------------
1835 -- Recursive_Process --
1836 -----------------------
1837
1838 procedure Recursive_Process
1839 (Project : out Project_Id;
1840 From_Project_Node : Project_Node_Id;
1841 Extended_By : Project_Id)
1842 is
1843 With_Clause : Project_Node_Id;
1844
1845 begin
1846 if From_Project_Node = Empty_Node then
1847 Project := No_Project;
1848
1849 else
1850 declare
1851 Processed_Data : Project_Data := Empty_Project;
1852 Imported : Project_List := Empty_Project_List;
1853 Declaration_Node : Project_Node_Id := Empty_Node;
1854 Name : constant Name_Id := Name_Of (From_Project_Node);
1855
1856 begin
1857 Project := Processed_Projects.Get (Name);
1858
1859 if Project /= No_Project then
1860 return;
1861 end if;
1862
1863 Projects.Increment_Last;
1864 Project := Projects.Last;
1865 Processed_Projects.Set (Name, Project);
1866
1867 Processed_Data.Name := Name;
1868
1869 Get_Name_String (Name);
1870
1871 -- If name starts with the virtual prefix, flag the project as
1872 -- being a virtual extending project.
1873
1874 if Name_Len > Virtual_Prefix'Length
1875 and then Name_Buffer (1 .. Virtual_Prefix'Length) =
1876 Virtual_Prefix
1877 then
1878 Processed_Data.Virtual := True;
1879 end if;
1880
1881 Processed_Data.Display_Path_Name :=
1882 Path_Name_Of (From_Project_Node);
1883 Get_Name_String (Processed_Data.Display_Path_Name);
1884 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
1885 Processed_Data.Path_Name := Name_Find;
1886
1887 Processed_Data.Location := Location_Of (From_Project_Node);
1888
1889 Processed_Data.Display_Directory :=
1890 Directory_Of (From_Project_Node);
1891 Get_Name_String (Processed_Data.Display_Directory);
1892 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
1893 Processed_Data.Directory := Name_Find;
1894
1895 Processed_Data.Extended_By := Extended_By;
1896 Processed_Data.Naming := Standard_Naming_Data;
1897
1898 Add_Attributes (Project, Processed_Data.Decl, Attribute_First);
1899 With_Clause := First_With_Clause_Of (From_Project_Node);
1900
1901 while With_Clause /= Empty_Node loop
1902 declare
1903 New_Project : Project_Id;
1904 New_Data : Project_Data;
1905
1906 begin
1907 Recursive_Process
1908 (Project => New_Project,
1909 From_Project_Node => Project_Node_Of (With_Clause),
1910 Extended_By => No_Project);
1911 New_Data := Projects.Table (New_Project);
1912
1913 -- If we were the first project to import it,
1914 -- set First_Referred_By to us.
1915
1916 if New_Data.First_Referred_By = No_Project then
1917 New_Data.First_Referred_By := Project;
1918 Projects.Table (New_Project) := New_Data;
1919 end if;
1920
1921 -- Add this project to our list of imported projects
1922
1923 Project_Lists.Increment_Last;
1924 Project_Lists.Table (Project_Lists.Last) :=
1925 (Project => New_Project, Next => Empty_Project_List);
1926
1927 -- Imported is the id of the last imported project.
1928 -- If it is nil, then this imported project is our first.
1929
1930 if Imported = Empty_Project_List then
1931 Processed_Data.Imported_Projects := Project_Lists.Last;
1932
1933 else
1934 Project_Lists.Table (Imported).Next := Project_Lists.Last;
1935 end if;
1936
1937 Imported := Project_Lists.Last;
1938
1939 With_Clause := Next_With_Clause_Of (With_Clause);
1940 end;
1941 end loop;
1942
1943 Declaration_Node := Project_Declaration_Of (From_Project_Node);
1944
1945 Recursive_Process
1946 (Project => Processed_Data.Extends,
1947 From_Project_Node => Extended_Project_Of (Declaration_Node),
1948 Extended_By => Project);
1949
1950 Projects.Table (Project) := Processed_Data;
1951
1952 Process_Declarative_Items
1953 (Project => Project,
1954 From_Project_Node => From_Project_Node,
1955 Pkg => No_Package,
1956 Item => First_Declarative_Item_Of
1957 (Declaration_Node));
1958
1959 -- If it is an extending project, inherit all packages
1960 -- from the extended project that are not explicitely defined
1961 -- or renamed. Also inherit the languages, if attribute Languages
1962 -- is not explicitely defined.
1963
1964 if Processed_Data.Extends /= No_Project then
1965 Processed_Data := Projects.Table (Project);
1966
1967 declare
1968 Extended_Pkg : Package_Id :=
1969 Projects.Table
1970 (Processed_Data.Extends).Decl.Packages;
1971 Current_Pkg : Package_Id;
1972 Element : Package_Element;
1973 First : constant Package_Id :=
1974 Processed_Data.Decl.Packages;
1975 Attribute1 : Variable_Id;
1976 Attribute2 : Variable_Id;
1977 Attr_Value1 : Variable;
1978 Attr_Value2 : Variable;
1979
1980 begin
1981 while Extended_Pkg /= No_Package loop
1982 Element := Packages.Table (Extended_Pkg);
1983
1984 Current_Pkg := First;
1985
1986 loop
1987 exit when Current_Pkg = No_Package
1988 or else Packages.Table (Current_Pkg).Name
1989 = Element.Name;
1990 Current_Pkg := Packages.Table (Current_Pkg).Next;
1991 end loop;
1992
1993 if Current_Pkg = No_Package then
1994 Packages.Increment_Last;
1995 Current_Pkg := Packages.Last;
1996 Packages.Table (Current_Pkg) :=
1997 (Name => Element.Name,
1998 Decl => Element.Decl,
1999 Parent => No_Package,
2000 Next => Processed_Data.Decl.Packages);
2001 Processed_Data.Decl.Packages := Current_Pkg;
2002 end if;
2003
2004 Extended_Pkg := Element.Next;
2005 end loop;
2006
2007 -- Check if attribute Languages is declared in the
2008 -- extending project.
2009
2010 Attribute1 := Processed_Data.Decl.Attributes;
2011 while Attribute1 /= No_Variable loop
2012 Attr_Value1 := Variable_Elements.Table (Attribute1);
2013 exit when Attr_Value1.Name = Snames.Name_Languages;
2014 Attribute1 := Attr_Value1.Next;
2015 end loop;
2016
2017 if Attribute1 = No_Variable or else
2018 Attr_Value1.Value.Default
2019 then
2020 -- Attribute Languages is not declared in the extending
2021 -- project. Check if it is declared in the project being
2022 -- extended.
2023
2024 Attribute2 :=
2025 Projects.Table (Processed_Data.Extends).Decl.Attributes;
2026
2027 while Attribute2 /= No_Variable loop
2028 Attr_Value2 := Variable_Elements.Table (Attribute2);
2029 exit when Attr_Value2.Name = Snames.Name_Languages;
2030 Attribute2 := Attr_Value2.Next;
2031 end loop;
2032
2033 if Attribute2 /= No_Variable and then
2034 not Attr_Value2.Value.Default
2035 then
2036 -- As attribute Languages is declared in the project
2037 -- being extended, copy its value for the extending
2038 -- project.
2039
2040 if Attribute1 = No_Variable then
2041 Variable_Elements.Increment_Last;
2042 Attribute1 := Variable_Elements.Last;
2043 Attr_Value1.Next := Processed_Data.Decl.Attributes;
2044 Processed_Data.Decl.Attributes := Attribute1;
2045 end if;
2046
2047 Attr_Value1.Name := Snames.Name_Languages;
2048 Attr_Value1.Value := Attr_Value2.Value;
2049 Variable_Elements.Table (Attribute1) := Attr_Value1;
2050 end if;
2051 end if;
2052 end;
2053
2054 Projects.Table (Project) := Processed_Data;
2055 end if;
2056 end;
2057 end if;
2058 end Recursive_Process;
2059
2060 end Prj.Proc;
Mirror of the offical gcc git repository hosted at gcc.gnu.org