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