1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2004 Free Software Foundation, Inc. --
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. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Err_Vars
; use Err_Vars
;
28 with Namet
; use Namet
;
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
;
38 with GNAT
.Case_Util
; use GNAT
.Case_Util
;
41 package body Prj
.Proc
is
43 Error_Report
: Put_Line_Access
:= null;
45 package Processed_Projects
is new GNAT
.HTable
.Simple_HTable
46 (Header_Num
=> Header_Num
,
47 Element
=> Project_Id
,
48 No_Element
=> No_Project
,
52 -- This hash table contains all processed projects
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.
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.
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.
72 (Project
: Project_Id
;
73 From_Project_Node
: Project_Node_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.
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
86 (Project
: Project_Id
;
87 With_Name
: Name_Id
) return Package_Id
;
88 -- Find the package of Project whose name is With_Name
90 procedure Process_Declarative_Items
91 (Project
: Project_Id
;
92 From_Project_Node
: Project_Node_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.
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.
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.
121 procedure Add
(To_Exp
: in out Name_Id
; Str
: Name_Id
) is
123 if To_Exp
= Types
.No_Name
or else To_Exp
= Empty_String
then
125 -- To_Exp is nil or empty. The result is Str
129 -- If Str is nil, then do not change To_Ext
131 elsif Str
/= No_Name
and then Str
/= Empty_String
then
133 S
: constant String := Get_Name_String
(Str
);
136 Get_Name_String
(To_Exp
);
137 Add_Str_To_Name_Buffer
(S
);
147 procedure Add_Attributes
148 (Project
: Project_Id
;
149 Decl
: in out Declarations
;
150 First
: Attribute_Node_Id
)
152 The_Attribute
: Attribute_Node_Id
:= First
;
155 while The_Attribute
/= Empty_Attribute
loop
156 if Attribute_Kind_Of
(The_Attribute
) = Single
then
158 New_Attribute
: Variable_Value
;
161 case Variable_Kind_Of
(The_Attribute
) is
163 -- Undefined should not happen
167 (False, "attribute with an undefined kind");
170 -- Single attributes have a default value of empty string
176 Location
=> No_Location
,
178 Value
=> Empty_String
,
181 -- List attributes have a default value of nil list
187 Location
=> No_Location
,
189 Values
=> Nil_String
);
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
;
202 The_Attribute
:= Next_Attribute
(After
=> The_Attribute
);
211 (Project
: in out Project_Id
;
212 Follow_Links
: Boolean)
215 -- Make sure that all projects are marked as not checked
217 for Index
in 1 .. Projects
.Last
loop
218 Projects
.Table
(Index
).Checked
:= False;
221 Recursive_Check
(Project
, Follow_Links
);
229 (Project
: Project_Id
;
230 From_Project_Node
: Project_Node_Id
;
232 First_Term
: Project_Node_Id
;
233 Kind
: Variable_Kind
) return Variable_Value
235 The_Term
: Project_Node_Id
:= First_Term
;
236 -- The term in the expression list
238 The_Current_Term
: Project_Node_Id
:= Empty_Node
;
239 -- The current term node id
241 Result
: Variable_Value
(Kind
=> Kind
);
242 -- The returned result
244 Last
: String_List_Id
:= Nil_String
;
245 -- Reference to the last string elements in Result, when Kind is List
248 Result
.Project
:= Project
;
249 Result
.Location
:= Location_Of
(First_Term
);
251 -- Process each term of the expression, starting with First_Term
253 while The_Term
/= Empty_Node
loop
254 The_Current_Term
:= Current_Term
(The_Term
);
256 case Kind_Of
(The_Current_Term
) is
258 when N_Literal_String
=>
264 -- Should never happen
266 pragma Assert
(False, "Undefined expression kind");
270 Add
(Result
.Value
, String_Value_Of
(The_Current_Term
));
271 Result
.Index
:= Source_Index_Of
(The_Current_Term
);
275 String_Elements
.Increment_Last
;
277 if Last
= Nil_String
then
279 -- This can happen in an expression like () & "toto"
281 Result
.Values
:= String_Elements
.Last
;
284 String_Elements
.Table
(Last
).Next
:=
285 String_Elements
.Last
;
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
),
298 when N_Literal_String_List
=>
301 String_Node
: Project_Node_Id
:=
302 First_Expression_In_List
(The_Current_Term
);
304 Value
: Variable_Value
;
307 if String_Node
/= Empty_Node
then
309 -- If String_Node is nil, it is an empty list,
310 -- there is nothing to do
314 From_Project_Node
=> From_Project_Node
,
316 First_Term
=> Tree
.First_Term
(String_Node
),
318 String_Elements
.Increment_Last
;
320 if Result
.Values
= Nil_String
then
322 -- This literal string list is the first term
323 -- in a string list expression
325 Result
.Values
:= String_Elements
.Last
;
328 String_Elements
.Table
(Last
).Next
:=
329 String_Elements
.Last
;
332 Last
:= String_Elements
.Last
;
333 String_Elements
.Table
(Last
) :=
334 (Value
=> Value
.Value
,
335 Display_Value
=> No_Name
,
336 Location
=> Value
.Location
,
339 Index
=> Value
.Index
);
342 -- Add the other element of the literal string list
343 -- one after the other
346 Next_Expression_In_List
(String_Node
);
348 exit when String_Node
= Empty_Node
;
353 From_Project_Node
=> From_Project_Node
,
355 First_Term
=> Tree
.First_Term
(String_Node
),
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
,
368 Index
=> Value
.Index
);
375 when N_Variable_Reference | N_Attribute_Reference
=>
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
;
390 if Term_Project
/= Empty_Node
and then
391 Term_Project
/= From_Project_Node
393 -- This variable or attribute comes from another project
395 The_Name
:= Name_Of
(Term_Project
);
396 The_Project
:= Imported_Or_Extended_Project_From
398 With_Name
=> The_Name
);
401 if Term_Package
/= Empty_Node
then
403 -- This is an attribute of a package
405 The_Name
:= Name_Of
(Term_Package
);
406 The_Package
:= Projects
.Table
(The_Project
).Decl
.Packages
;
408 while The_Package
/= No_Package
409 and then Packages
.Table
(The_Package
).Name
/= The_Name
411 The_Package
:= Packages
.Table
(The_Package
).Next
;
415 (The_Package
/= No_Package
,
416 "package not found.");
418 elsif Kind_Of
(The_Current_Term
) = N_Attribute_Reference
then
419 The_Package
:= No_Package
;
422 The_Name
:= Name_Of
(The_Current_Term
);
424 if Kind_Of
(The_Current_Term
) = N_Attribute_Reference
then
425 Index
:= Associative_Array_Index_Of
(The_Current_Term
);
428 -- If it is not an associative array attribute
430 if Index
= No_Name
then
432 -- It is not an associative array attribute
434 if The_Package
/= No_Package
then
436 -- First, if there is a package, look into the package
439 Kind_Of
(The_Current_Term
) = N_Variable_Reference
442 Packages
.Table
(The_Package
).Decl
.Variables
;
446 Packages
.Table
(The_Package
).Decl
.Attributes
;
449 while The_Variable_Id
/= No_Variable
451 Variable_Elements
.Table
(The_Variable_Id
).Name
/=
455 Variable_Elements
.Table
(The_Variable_Id
).Next
;
460 if The_Variable_Id
= No_Variable
then
462 -- If we have not found it, look into the project
465 Kind_Of
(The_Current_Term
) = N_Variable_Reference
468 Projects
.Table
(The_Project
).Decl
.Variables
;
472 Projects
.Table
(The_Project
).Decl
.Attributes
;
475 while The_Variable_Id
/= No_Variable
477 Variable_Elements
.Table
(The_Variable_Id
).Name
/=
481 Variable_Elements
.Table
(The_Variable_Id
).Next
;
486 pragma Assert
(The_Variable_Id
/= No_Variable
,
487 "variable or attribute not found");
489 The_Variable
:= Variable_Elements
.Table
490 (The_Variable_Id
).Value
;
494 -- It is an associative array attribute
497 The_Array
: Array_Id
:= No_Array
;
498 The_Element
: Array_Element_Id
:= No_Array_Element
;
499 Array_Index
: Name_Id
:= No_Name
;
501 if The_Package
/= No_Package
then
503 Packages
.Table
(The_Package
).Decl
.Arrays
;
507 Projects
.Table
(The_Project
).Decl
.Arrays
;
510 while The_Array
/= No_Array
511 and then Arrays
.Table
(The_Array
).Name
/= The_Name
513 The_Array
:= Arrays
.Table
(The_Array
).Next
;
516 if The_Array
/= No_Array
then
517 The_Element
:= Arrays
.Table
(The_Array
).Value
;
519 Get_Name_String
(Index
);
521 if Case_Insensitive
(The_Current_Term
) then
522 To_Lower
(Name_Buffer
(1 .. Name_Len
));
525 Array_Index
:= Name_Find
;
527 while The_Element
/= No_Array_Element
528 and then Array_Elements
.Table
(The_Element
).Index
532 Array_Elements
.Table
(The_Element
).Next
;
537 if The_Element
/= No_Array_Element
then
539 Array_Elements
.Table
(The_Element
).Value
;
543 Expression_Kind_Of
(The_Current_Term
) = List
548 Location
=> No_Location
,
550 Values
=> Nil_String
);
556 Location
=> No_Location
,
558 Value
=> Empty_String
,
569 -- Should never happen
571 pragma Assert
(False, "undefined expression kind");
576 case The_Variable
.Kind
is
582 Add
(Result
.Value
, The_Variable
.Value
);
586 -- Should never happen
590 "list cannot appear in single " &
591 "string expression");
596 case The_Variable
.Kind
is
602 String_Elements
.Increment_Last
;
604 if Last
= Nil_String
then
606 -- This can happen in an expression such as
609 Result
.Values
:= String_Elements
.Last
;
612 String_Elements
.Table
(Last
).Next
:=
613 String_Elements
.Last
;
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
),
628 The_List
: String_List_Id
:=
632 while The_List
/= Nil_String
loop
633 String_Elements
.Increment_Last
;
635 if Last
= Nil_String
then
636 Result
.Values
:= String_Elements
.Last
;
639 String_Elements
.Table
(Last
).Next
:=
640 String_Elements
.Last
;
644 Last
:= String_Elements
.Last
;
645 String_Elements
.Table
(Last
) :=
647 String_Elements
.Table
649 Display_Value
=> No_Name
,
650 Location
=> Location_Of
656 String_Elements
.Table
(The_List
).Next
;
663 when N_External_Value
=>
665 (String_Value_Of
(External_Reference_Of
(The_Current_Term
)));
668 Name
: constant Name_Id
:= Name_Find
;
669 Default
: Name_Id
:= No_Name
;
670 Value
: Name_Id
:= No_Name
;
672 Default_Node
: constant Project_Node_Id
:=
673 External_Default_Of
(The_Current_Term
);
676 if Default_Node
/= Empty_Node
then
677 Default
:= String_Value_Of
(Default_Node
);
680 Value
:= Prj
.Ext
.Value_Of
(Name
, Default
);
682 if Value
= No_Name
then
683 if not Opt
.Quiet_Output
then
684 if Error_Report
= null then
686 ("?undefined external reference",
687 Location_Of
(The_Current_Term
));
691 ("warning: """ & Get_Name_String
(Name
) &
692 """ is an undefined external reference",
697 Value
:= Empty_String
;
707 Add
(Result
.Value
, Value
);
710 String_Elements
.Increment_Last
;
712 if Last
= Nil_String
then
713 Result
.Values
:= String_Elements
.Last
;
716 String_Elements
.Table
(Last
).Next
:=
717 String_Elements
.Last
;
720 Last
:= String_Elements
.Last
;
721 String_Elements
.Table
(Last
) :=
723 Display_Value
=> No_Name
,
724 Location
=> Location_Of
(The_Current_Term
),
734 -- Should never happen
738 "illegal node kind in an expression");
743 The_Term
:= Next_Term
(The_Term
);
749 ---------------------------------------
750 -- Imported_Or_Extended_Project_From --
751 ---------------------------------------
753 function Imported_Or_Extended_Project_From
754 (Project
: Project_Id
;
755 With_Name
: Name_Id
) return Project_Id
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
;
763 -- First check if it is the name of an extended project
765 if Data
.Extends
/= No_Project
766 and then Projects
.Table
(Data
.Extends
).Name
= With_Name
771 -- Then check the name of each imported project
773 while List
/= Empty_Project_List
loop
774 Result
:= Project_Lists
.Table
(List
).Project
;
776 -- If the project is directly imported, then returns its ID
778 if Projects
.Table
(Result
).Name
= With_Name
then
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.
787 Proj
: Project_Id
:= Projects
.Table
(Result
).Extends
;
789 while Proj
/= No_Project
loop
790 if Projects
.Table
(Proj
).Name
= With_Name
then
791 Temp_Result
:= Result
;
795 Proj
:= Projects
.Table
(Proj
).Extends
;
799 List
:= Project_Lists
.Table
(List
).Next
;
803 (Temp_Result
/= No_Project
,
804 "project not found");
808 end Imported_Or_Extended_Project_From
;
814 function Package_From
815 (Project
: Project_Id
;
816 With_Name
: Name_Id
) return Package_Id
818 Data
: constant Project_Data
:= Projects
.Table
(Project
);
819 Result
: Package_Id
:= Data
.Decl
.Packages
;
822 -- Check the name of each existing package of Project
824 while Result
/= No_Package
826 Packages
.Table
(Result
).Name
/= With_Name
828 Result
:= Packages
.Table
(Result
).Next
;
831 if Result
= No_Package
then
832 -- Should never happen
833 Write_Line
("package """ & Get_Name_String
(With_Name
) &
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)
854 Extending
: Project_Id
;
855 Extending2
: Project_Id
;
858 Error_Report
:= Report_Error
;
861 -- Make sure there is no projects in the data structure
863 Projects
.Set_Last
(No_Project
);
864 Processed_Projects
.Reset
;
866 -- And process the main project and all of the projects it depends on,
871 From_Project_Node
=> From_Project_Node
,
872 Extended_By
=> No_Project
);
874 if Project
/= No_Project
then
875 Check
(Project
, Follow_Links
);
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.
882 if Project
/= No_Project
883 and then Is_Extending_All
(From_Project_Node
)
886 Object_Dir
: constant Name_Id
:=
887 Projects
.Table
(Project
).Object_Directory
;
889 for Index
in Projects
.First
.. Projects
.Last
loop
890 if Projects
.Table
(Index
).Virtual
then
891 Projects
.Table
(Index
).Object_Directory
:= Object_Dir
;
897 -- Check that no extending project shares its object directory with
898 -- the project(s) it extends.
900 if Project
/= No_Project
then
901 for Proj
in 1 .. Projects
.Last
loop
902 Extending
:= Projects
.Table
(Proj
).Extended_By
;
904 if Extending
/= No_Project
then
905 Obj_Dir
:= Projects
.Table
(Proj
).Object_Directory
;
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.
911 -- Start with the project directly extending it
913 Extending2
:= Extending
;
915 while Extending2
/= No_Project
loop
917 -- why is this code commented out ???
919 -- if ((Process_Languages = Ada_Language
921 -- Projects.Table (Extending2).Ada_Sources_Present)
923 -- (Process_Languages = Other_Languages
925 -- Projects.Table (Extending2).Other_Sources_Present))
927 if Projects
.Table
(Extending2
).Ada_Sources_Present
929 Projects
.Table
(Extending2
).Object_Directory
= Obj_Dir
931 if Projects
.Table
(Extending2
).Virtual
then
932 Error_Msg_Name_1
:= Projects
.Table
(Proj
).Name
;
934 if Error_Report
= null then
936 ("project % cannot be extended by a virtual " &
937 "project with the same object directory",
938 Projects
.Table
(Proj
).Location
);
943 Get_Name_String
(Error_Msg_Name_1
) &
944 """ cannot be extended by a virtual " &
945 "project with the same object directory",
951 Projects
.Table
(Extending2
).Name
;
952 Error_Msg_Name_2
:= Projects
.Table
(Proj
).Name
;
954 if Error_Report
= null then
956 ("project % cannot extend project %",
957 Projects
.Table
(Extending2
).Location
);
959 ("\they share the same object directory",
960 Projects
.Table
(Extending2
).Location
);
965 Get_Name_String
(Error_Msg_Name_1
) &
966 """ cannot extend project """ &
967 Get_Name_String
(Error_Msg_Name_2
) & """",
970 ("they share the same object directory",
976 -- Continue with the next extending project, if any
978 Extending2
:= Projects
.Table
(Extending2
).Extended_By
;
984 Success
:= Total_Errors_Detected
<= 0;
987 -------------------------------
988 -- Process_Declarative_Items --
989 -------------------------------
991 procedure Process_Declarative_Items
992 (Project
: Project_Id
;
993 From_Project_Node
: Project_Node_Id
;
995 Item
: Project_Node_Id
)
997 Current_Declarative_Item
: Project_Node_Id
:= Item
;
998 Current_Item
: Project_Node_Id
:= Empty_Node
;
1001 -- For each declarative item
1003 while Current_Declarative_Item
/= Empty_Node
loop
1007 Current_Item
:= Current_Item_Node
(Current_Declarative_Item
);
1009 -- And set Current_Declarative_Item to the next declarative item
1010 -- ready for the next iteration.
1012 Current_Declarative_Item
:= Next_Declarative_Item
1013 (Current_Declarative_Item
);
1015 case Kind_Of
(Current_Item
) is
1017 when N_Package_Declaration
=>
1018 -- Do not process a package declaration that should be ignored
1020 if Expression_Kind_Of
(Current_Item
) /= Ignored
then
1021 -- Create the new package
1023 Packages
.Increment_Last
;
1026 New_Pkg
: constant Package_Id
:= Packages
.Last
;
1027 The_New_Package
: Package_Element
;
1029 Project_Of_Renamed_Package
: constant Project_Node_Id
:=
1030 Project_Of_Renamed_Package_Of
1034 -- Set the name of the new package
1036 The_New_Package
.Name
:= Name_Of
(Current_Item
);
1038 -- Insert the new package in the appropriate list
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
;
1045 The_New_Package
.Next
:=
1046 Projects
.Table
(Project
).Decl
.Packages
;
1047 Projects
.Table
(Project
).Decl
.Packages
:= New_Pkg
;
1050 Packages
.Table
(New_Pkg
) := The_New_Package
;
1052 if Project_Of_Renamed_Package
/= Empty_Node
then
1057 Project_Name
: constant Name_Id
:=
1059 (Project_Of_Renamed_Package
);
1061 Renamed_Project
: constant Project_Id
:=
1062 Imported_Or_Extended_Project_From
1063 (Project
, Project_Name
);
1065 Renamed_Package
: constant Package_Id
:=
1068 Name_Of
(Current_Item
));
1071 -- For a renamed package, set declarations to
1072 -- the declarations of the renamed package.
1074 Packages
.Table
(New_Pkg
).Decl
:=
1075 Packages
.Table
(Renamed_Package
).Decl
;
1078 -- Standard package declaration, not renaming
1081 -- Set the default values of the attributes
1085 Packages
.Table
(New_Pkg
).Decl
,
1087 (Package_Id_Of
(Current_Item
)));
1089 -- And process declarative items of the new package
1091 Process_Declarative_Items
1092 (Project
=> Project
,
1093 From_Project_Node
=> From_Project_Node
,
1095 Item
=> First_Declarative_Item_Of
1101 when N_String_Type_Declaration
=>
1103 -- There is nothing to process
1107 when N_Attribute_Declaration |
1108 N_Typed_Variable_Declaration |
1109 N_Variable_Declaration
=>
1111 if Expression_Of
(Current_Item
) = Empty_Node
then
1113 -- It must be a full associative array attribute declaration
1116 Current_Item_Name
: constant Name_Id
:=
1117 Name_Of
(Current_Item
);
1118 -- The name of the attribute
1120 New_Array
: Array_Id
;
1121 -- The new associative array created
1123 Orig_Array
: Array_Id
;
1124 -- The associative array value
1126 Orig_Project_Name
: Name_Id
:= No_Name
;
1127 -- The name of the project where the associative array
1130 Orig_Project
: Project_Id
:= No_Project
;
1131 -- The id of the project where the associative array
1134 Orig_Package_Name
: Name_Id
:= No_Name
;
1135 -- The name of the package, if any, where the associative
1138 Orig_Package
: Package_Id
:= No_Package
;
1139 -- The id of the package, if any, where the associative
1142 New_Element
: Array_Element_Id
:= No_Array_Element
;
1143 -- Id of a new array element created
1145 Prev_Element
: Array_Element_Id
:= No_Array_Element
;
1146 -- Last new element id created
1148 Orig_Element
: Array_Element_Id
:= No_Array_Element
;
1149 -- Current array element in the original associative
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.
1159 -- First, find if the associative array attribute already
1160 -- has elements declared.
1162 if Pkg
/= No_Package
then
1163 New_Array
:= Packages
.Table
(Pkg
).Decl
.Arrays
;
1166 New_Array
:= Projects
.Table
(Project
).Decl
.Arrays
;
1169 while New_Array
/= No_Array
and then
1170 Arrays
.Table
(New_Array
).Name
/= Current_Item_Name
1172 New_Array
:= Arrays
.Table
(New_Array
).Next
;
1175 -- If the attribute has never been declared add new entry
1176 -- in the arrays of the project/package and link it.
1178 if New_Array
= No_Array
then
1179 Arrays
.Increment_Last
;
1180 New_Array
:= Arrays
.Last
;
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
;
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
;
1198 -- Find the project where the value is declared
1200 Orig_Project_Name
:=
1201 Name_Of
(Associative_Project_Of
(Current_Item
));
1203 for Index
in Projects
.First
.. Projects
.Last
loop
1204 if Projects
.Table
(Index
).Name
= Orig_Project_Name
then
1205 Orig_Project
:= Index
;
1210 pragma Assert
(Orig_Project
/= No_Project
,
1211 "original project not found");
1213 if Associative_Package_Of
(Current_Item
) = Empty_Node
then
1215 Projects
.Table
(Orig_Project
).Decl
.Arrays
;
1218 -- If in a package, find the package where the
1219 -- value is declared.
1221 Orig_Package_Name
:=
1222 Name_Of
(Associative_Package_Of
(Current_Item
));
1224 Projects
.Table
(Orig_Project
).Decl
.Packages
;
1225 pragma Assert
(Orig_Package
/= No_Package
,
1226 "original package not found");
1228 while Packages
.Table
(Orig_Package
).Name
/=
1231 Orig_Package
:= Packages
.Table
(Orig_Package
).Next
;
1232 pragma Assert
(Orig_Package
/= No_Package
,
1233 "original package not found");
1237 Packages
.Table
(Orig_Package
).Decl
.Arrays
;
1240 -- Now look for the array
1242 while Orig_Array
/= No_Array
and then
1243 Arrays
.Table
(Orig_Array
).Name
/= Current_Item_Name
1245 Orig_Array
:= Arrays
.Table
(Orig_Array
).Next
;
1248 if Orig_Array
= No_Array
then
1249 if Error_Report
= null then
1251 ("associative array value cannot be found",
1252 Location_Of
(Current_Item
));
1256 ("associative array value cannot be found",
1261 Orig_Element
:= Arrays
.Table
(Orig_Array
).Value
;
1263 -- Copy each array element
1265 while Orig_Element
/= No_Array_Element
loop
1267 -- Case of first element
1269 if Prev_Element
= No_Array_Element
then
1271 -- And there is no array element declared yet,
1272 -- create a new first array element.
1274 if Arrays
.Table
(New_Array
).Value
=
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
;
1282 -- Otherwise, the new element is the first
1285 New_Element
:= Arrays
.Table
(New_Array
).Value
;
1287 Array_Elements
.Table
(New_Element
).Next
;
1290 -- Otherwise, reuse an existing element, or create
1291 -- one if necessary.
1295 Array_Elements
.Table
(Prev_Element
).Next
;
1297 if Next_Element
= No_Array_Element
then
1298 Array_Elements
.Increment_Last
;
1299 New_Element
:= Array_Elements
.Last
;
1302 New_Element
:= Next_Element
;
1304 Array_Elements
.Table
(New_Element
).Next
;
1308 -- Copy the value of the element
1310 Array_Elements
.Table
(New_Element
) :=
1311 Array_Elements
.Table
(Orig_Element
);
1312 Array_Elements
.Table
(New_Element
).Value
.Project
:=
1315 -- Adjust the Next link
1317 Array_Elements
.Table
(New_Element
).Next
:=
1320 -- Adjust the previous id for the next element
1322 Prev_Element
:= New_Element
;
1324 -- Go to the next element in the original array
1327 Array_Elements
.Table
(Orig_Element
).Next
;
1330 -- Make sure that the array ends here, in case there
1331 -- previously a greater number of elements.
1333 Array_Elements
.Table
(New_Element
).Next
:=
1338 -- Declarations other that full associative arrays
1342 New_Value
: constant Variable_Value
:=
1344 (Project
=> Project
,
1345 From_Project_Node
=> From_Project_Node
,
1348 Tree
.First_Term
(Expression_Of
1351 Expression_Kind_Of
(Current_Item
));
1352 -- The expression value
1354 The_Variable
: Variable_Id
:= No_Variable
;
1356 Current_Item_Name
: constant Name_Id
:=
1357 Name_Of
(Current_Item
);
1360 -- Process a typed variable declaration
1363 Kind_Of
(Current_Item
) = N_Typed_Variable_Declaration
1365 -- Report an error for an empty string
1367 if New_Value
.Value
= Empty_String
then
1368 Error_Msg_Name_1
:= Name_Of
(Current_Item
);
1370 if Error_Report
= null then
1372 ("no value defined for %",
1373 Location_Of
(Current_Item
));
1377 ("no value defined for " &
1378 Get_Name_String
(Error_Msg_Name_1
),
1384 Current_String
: Project_Node_Id
:=
1385 First_Literal_String
1390 -- Loop through all the valid strings for
1391 -- the string type and compare to the string
1394 while Current_String
/= Empty_Node
1395 and then String_Value_Of
(Current_String
) /=
1399 Next_Literal_String
(Current_String
);
1402 -- Report an error if the string value is not
1403 -- one for the string type.
1405 if Current_String
= Empty_Node
then
1406 Error_Msg_Name_1
:= New_Value
.Value
;
1407 Error_Msg_Name_2
:= Name_Of
(Current_Item
);
1409 if Error_Report
= null then
1411 ("value { is illegal for typed string %",
1412 Location_Of
(Current_Item
));
1417 Get_Name_String
(Error_Msg_Name_1
) &
1418 """ is illegal for typed string """ &
1419 Get_Name_String
(Error_Msg_Name_2
) &
1428 if Kind_Of
(Current_Item
) /= N_Attribute_Declaration
1430 Associative_Array_Index_Of
(Current_Item
) = No_Name
1432 -- Case of a variable declaration or of a not
1433 -- associative array attribute.
1435 -- First, find the list where to find the variable
1439 Kind_Of
(Current_Item
) = N_Attribute_Declaration
1441 if Pkg
/= No_Package
then
1443 Packages
.Table
(Pkg
).Decl
.Attributes
;
1447 Projects
.Table
(Project
).Decl
.Attributes
;
1451 if Pkg
/= No_Package
then
1453 Packages
.Table
(Pkg
).Decl
.Variables
;
1457 Projects
.Table
(Project
).Decl
.Variables
;
1462 -- Loop through the list, to find if it has already
1466 The_Variable
/= No_Variable
1468 Variable_Elements
.Table
(The_Variable
).Name
/=
1472 Variable_Elements
.Table
(The_Variable
).Next
;
1475 -- If it has not been declared, create a new entry
1478 if The_Variable
= No_Variable
then
1479 -- All single string attribute should already have
1480 -- been declared with a default empty string value.
1483 (Kind_Of
(Current_Item
) /=
1484 N_Attribute_Declaration
,
1485 "illegal attribute declaration");
1487 Variable_Elements
.Increment_Last
;
1488 The_Variable
:= Variable_Elements
.Last
;
1490 -- Put the new variable in the appropriate list
1492 if Pkg
/= No_Package
then
1493 Variable_Elements
.Table
(The_Variable
) :=
1495 Packages
.Table
(Pkg
).Decl
.Variables
,
1496 Name
=> Current_Item_Name
,
1497 Value
=> New_Value
);
1498 Packages
.Table
(Pkg
).Decl
.Variables
:=
1502 Variable_Elements
.Table
(The_Variable
) :=
1504 Projects
.Table
(Project
).Decl
.Variables
,
1505 Name
=> Current_Item_Name
,
1506 Value
=> New_Value
);
1507 Projects
.Table
(Project
).Decl
.Variables
:=
1511 -- If the variable/attribute has already been
1512 -- declared, just change the value.
1515 Variable_Elements
.Table
(The_Variable
).Value
:=
1521 -- Associative array attribute
1523 -- Get the string index
1526 (Associative_Array_Index_Of
(Current_Item
));
1528 -- Put in lower case, if necessary
1530 if Case_Insensitive
(Current_Item
) then
1531 GNAT
.Case_Util
.To_Lower
1532 (Name_Buffer
(1 .. Name_Len
));
1536 The_Array
: Array_Id
;
1538 The_Array_Element
: Array_Element_Id
:=
1541 Index_Name
: constant Name_Id
:= Name_Find
;
1542 -- The name id of the index
1545 -- Look for the array in the appropriate list
1547 if Pkg
/= No_Package
then
1548 The_Array
:= Packages
.Table
(Pkg
).Decl
.Arrays
;
1551 The_Array
:= Projects
.Table
1552 (Project
).Decl
.Arrays
;
1556 The_Array
/= No_Array
1557 and then Arrays
.Table
(The_Array
).Name
/=
1560 The_Array
:= Arrays
.Table
(The_Array
).Next
;
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.
1568 if The_Array
= No_Array
then
1569 Arrays
.Increment_Last
;
1570 The_Array
:= Arrays
.Last
;
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
;
1580 Arrays
.Table
(The_Array
) :=
1581 (Name
=> Current_Item_Name
,
1582 Value
=> No_Array_Element
,
1584 Projects
.Table
(Project
).Decl
.Arrays
);
1585 Projects
.Table
(Project
).Decl
.Arrays
:=
1589 -- Otherwise, initialize The_Array_Element as the
1590 -- head of the element list.
1593 The_Array_Element
:=
1594 Arrays
.Table
(The_Array
).Value
;
1597 -- Look in the list, if any, to find an element
1598 -- with the same index.
1600 while The_Array_Element
/= No_Array_Element
1602 Array_Elements
.Table
(The_Array_Element
).Index
/=
1605 The_Array_Element
:=
1606 Array_Elements
.Table
(The_Array_Element
).Next
;
1609 -- If no such element were found, create a new
1610 -- one and insert it in the element list, with
1611 -- the propoer value.
1613 if The_Array_Element
= No_Array_Element
then
1614 Array_Elements
.Increment_Last
;
1615 The_Array_Element
:= Array_Elements
.Last
;
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
),
1623 Next
=> Arrays
.Table
(The_Array
).Value
);
1624 Arrays
.Table
(The_Array
).Value
:=
1627 -- An element with the same index already exists,
1628 -- just replace its value with the new one.
1631 Array_Elements
.Table
(The_Array_Element
).Value
:=
1639 when N_Case_Construction
=>
1641 The_Project
: Project_Id
:= Project
;
1642 -- The id of the project of the case variable
1644 The_Package
: Package_Id
:= Pkg
;
1645 -- The id of the package, if any, of the case variable
1647 The_Variable
: Variable_Value
:= Nil_Variable_Value
;
1648 -- The case variable
1650 Case_Value
: Name_Id
:= No_Name
;
1651 -- The case variable value
1653 Case_Item
: Project_Node_Id
:= Empty_Node
;
1654 Choice_String
: Project_Node_Id
:= Empty_Node
;
1655 Decl_Item
: Project_Node_Id
:= Empty_Node
;
1659 Variable_Node
: constant Project_Node_Id
:=
1660 Case_Variable_Reference_Of
1663 Var_Id
: Variable_Id
:= No_Variable
;
1664 Name
: Name_Id
:= No_Name
;
1667 -- If a project were specified for the case variable,
1670 if Project_Node_Of
(Variable_Node
) /= Empty_Node
then
1671 Name
:= Name_Of
(Project_Node_Of
(Variable_Node
));
1673 Imported_Or_Extended_Project_From
(Project
, Name
);
1676 -- If a package were specified for the case variable,
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
);
1684 Name
:= Name_Of
(Variable_Node
);
1686 -- First, look for the case variable into the package,
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
1694 Variable_Elements
.Table
(Var_Id
).Name
/= Name
1696 Var_Id
:= Variable_Elements
.Table
(Var_Id
).Next
;
1700 -- If not found in the package, or if there is no
1701 -- package, look at the project level.
1703 if Var_Id
= No_Variable
1704 and then Package_Node_Of
(Variable_Node
) = Empty_Node
1706 Var_Id
:= Projects
.Table
(The_Project
).Decl
.Variables
;
1707 while Var_Id
/= No_Variable
1709 Variable_Elements
.Table
(Var_Id
).Name
/= Name
1711 Var_Id
:= Variable_Elements
.Table
(Var_Id
).Next
;
1715 if Var_Id
= No_Variable
then
1717 -- Should never happen, because this has already been
1718 -- checked during parsing.
1720 Write_Line
("variable """ &
1721 Get_Name_String
(Name
) &
1723 raise Program_Error
;
1726 -- Get the case variable
1728 The_Variable
:= Variable_Elements
.Table
(Var_Id
).Value
;
1730 if The_Variable
.Kind
/= Single
then
1732 -- Should never happen, because this has already been
1733 -- checked during parsing.
1735 Write_Line
("variable""" &
1736 Get_Name_String
(Name
) &
1737 """ is not a single string variable");
1738 raise Program_Error
;
1741 -- Get the case variable value
1742 Case_Value
:= The_Variable
.Value
;
1745 -- Now look into all the case items of the case construction
1747 Case_Item
:= First_Case_Item_Of
(Current_Item
);
1749 while Case_Item
/= Empty_Node
loop
1750 Choice_String
:= First_Choice_Of
(Case_Item
);
1752 -- When Choice_String is nil, it means that it is
1753 -- the "when others =>" alternative.
1755 if Choice_String
= Empty_Node
then
1756 Decl_Item
:= First_Declarative_Item_Of
(Case_Item
);
1757 exit Case_Item_Loop
;
1760 -- Look into all the alternative of this case item
1763 while Choice_String
/= Empty_Node
loop
1765 Case_Value
= String_Value_Of
(Choice_String
)
1768 First_Declarative_Item_Of
(Case_Item
);
1769 exit Case_Item_Loop
;
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
;
1778 -- If there is an alternative, then we process it
1780 if Decl_Item
/= Empty_Node
then
1781 Process_Declarative_Items
1782 (Project
=> Project
,
1783 From_Project_Node
=> From_Project_Node
,
1791 -- Should never happen
1793 Write_Line
("Illegal declarative item: " &
1794 Project_Node_Kind
'Image (Kind_Of
(Current_Item
)));
1795 raise Program_Error
;
1798 end Process_Declarative_Items
;
1800 ---------------------
1801 -- Recursive_Check --
1802 ---------------------
1804 procedure Recursive_Check
1805 (Project
: Project_Id
;
1806 Follow_Links
: Boolean)
1808 Data
: Project_Data
;
1809 Imported_Project_List
: Project_List
:= Empty_Project_List
;
1812 -- Do nothing if Project is No_Project, or Project has already
1813 -- been marked as checked.
1815 if Project
/= No_Project
1816 and then not Projects
.Table
(Project
).Checked
1818 -- Mark project as checked, to avoid infinite recursion in
1819 -- ill-formed trees, where a project imports itself.
1821 Projects
.Table
(Project
).Checked
:= True;
1823 Data
:= Projects
.Table
(Project
);
1825 -- Call itself for a possible extended project.
1826 -- (if there is no extended project, then nothing happens).
1828 Recursive_Check
(Data
.Extends
, Follow_Links
);
1830 -- Call itself for all imported projects
1832 Imported_Project_List
:= Data
.Imported_Projects
;
1833 while Imported_Project_List
/= Empty_Project_List
loop
1835 (Project_Lists
.Table
(Imported_Project_List
).Project
,
1837 Imported_Project_List
:=
1838 Project_Lists
.Table
(Imported_Project_List
).Next
;
1841 if Opt
.Verbose_Mode
then
1842 Write_Str
("Checking project file """);
1843 Write_Str
(Get_Name_String
(Data
.Name
));
1847 Prj
.Nmsc
.Check
(Project
, Error_Report
, Follow_Links
);
1849 end Recursive_Check
;
1851 -----------------------
1852 -- Recursive_Process --
1853 -----------------------
1855 procedure Recursive_Process
1856 (Project
: out Project_Id
;
1857 From_Project_Node
: Project_Node_Id
;
1858 Extended_By
: Project_Id
)
1860 With_Clause
: Project_Node_Id
;
1863 if From_Project_Node
= Empty_Node
then
1864 Project
:= No_Project
;
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
);
1874 Project
:= Processed_Projects
.Get
(Name
);
1876 if Project
/= No_Project
then
1880 Projects
.Increment_Last
;
1881 Project
:= Projects
.Last
;
1882 Processed_Projects
.Set
(Name
, Project
);
1884 Processed_Data
.Name
:= Name
;
1886 Get_Name_String
(Name
);
1888 -- If name starts with the virtual prefix, flag the project as
1889 -- being a virtual extending project.
1891 if Name_Len
> Virtual_Prefix
'Length
1892 and then Name_Buffer
(1 .. Virtual_Prefix
'Length) =
1895 Processed_Data
.Virtual
:= True;
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
;
1904 Processed_Data
.Location
:= Location_Of
(From_Project_Node
);
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
;
1912 Processed_Data
.Extended_By
:= Extended_By
;
1913 Processed_Data
.Naming
:= Standard_Naming_Data
;
1915 Add_Attributes
(Project
, Processed_Data
.Decl
, Attribute_First
);
1916 With_Clause
:= First_With_Clause_Of
(From_Project_Node
);
1918 while With_Clause
/= Empty_Node
loop
1920 New_Project
: Project_Id
;
1921 New_Data
: Project_Data
;
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
);
1930 -- If we were the first project to import it,
1931 -- set First_Referred_By to us.
1933 if New_Data
.First_Referred_By
= No_Project
then
1934 New_Data
.First_Referred_By
:= Project
;
1935 Projects
.Table
(New_Project
) := New_Data
;
1938 -- Add this project to our list of imported projects
1940 Project_Lists
.Increment_Last
;
1941 Project_Lists
.Table
(Project_Lists
.Last
) :=
1942 (Project
=> New_Project
, Next
=> Empty_Project_List
);
1944 -- Imported is the id of the last imported project.
1945 -- If it is nil, then this imported project is our first.
1947 if Imported
= Empty_Project_List
then
1948 Processed_Data
.Imported_Projects
:= Project_Lists
.Last
;
1951 Project_Lists
.Table
(Imported
).Next
:= Project_Lists
.Last
;
1954 Imported
:= Project_Lists
.Last
;
1956 With_Clause
:= Next_With_Clause_Of
(With_Clause
);
1960 Declaration_Node
:= Project_Declaration_Of
(From_Project_Node
);
1963 (Project
=> Processed_Data
.Extends
,
1964 From_Project_Node
=> Extended_Project_Of
(Declaration_Node
),
1965 Extended_By
=> Project
);
1967 Projects
.Table
(Project
) := Processed_Data
;
1969 Process_Declarative_Items
1970 (Project
=> Project
,
1971 From_Project_Node
=> From_Project_Node
,
1973 Item
=> First_Declarative_Item_Of
1974 (Declaration_Node
));
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.
1981 if Processed_Data
.Extends
/= No_Project
then
1982 Processed_Data
:= Projects
.Table
(Project
);
1985 Extended_Pkg
: Package_Id
:=
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
;
1998 while Extended_Pkg
/= No_Package
loop
1999 Element
:= Packages
.Table
(Extended_Pkg
);
2001 Current_Pkg
:= First
;
2004 exit when Current_Pkg
= No_Package
2005 or else Packages
.Table
(Current_Pkg
).Name
2007 Current_Pkg
:= Packages
.Table
(Current_Pkg
).Next
;
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
;
2021 Extended_Pkg
:= Element
.Next
;
2024 -- Check if attribute Languages is declared in the
2025 -- extending project.
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
;
2034 if Attribute1
= No_Variable
or else
2035 Attr_Value1
.Value
.Default
2037 -- Attribute Languages is not declared in the extending
2038 -- project. Check if it is declared in the project being
2042 Projects
.Table
(Processed_Data
.Extends
).Decl
.Attributes
;
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
;
2050 if Attribute2
/= No_Variable
and then
2051 not Attr_Value2
.Value
.Default
2053 -- As attribute Languages is declared in the project
2054 -- being extended, copy its value for the extending
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
;
2064 Attr_Value1
.Name
:= Snames
.Name_Languages
;
2065 Attr_Value1
.Value
:= Attr_Value2
.Value
;
2066 Variable_Elements
.Table
(Attribute1
) := Attr_Value1
;
2071 Projects
.Table
(Project
) := Processed_Data
;
2075 end Recursive_Process
;