1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2007, 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 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Err_Vars; use Err_Vars;
28 with GNAT.Case_Util; use GNAT.Case_Util;
31 with Prj.Attr; use Prj.Attr;
32 with Prj.Attr.PM; use Prj.Attr.PM;
33 with Prj.Err; use Prj.Err;
34 with Prj.Strt; use Prj.Strt;
35 with Prj.Tree; use Prj.Tree;
37 with Uintp; use Uintp;
39 package body Prj.Dect is
41 type Zone is (In_Project, In_Package, In_Case_Construction);
42 -- Used to indicate if we are parsing a package (In_Package),
43 -- a case construction (In_Case_Construction) or none of those two
46 procedure Parse_Attribute_Declaration
47 (In_Tree : Project_Node_Tree_Ref;
48 Attribute : out Project_Node_Id;
49 First_Attribute : Attribute_Node_Id;
50 Current_Project : Project_Node_Id;
51 Current_Package : Project_Node_Id;
52 Packages_To_Check : String_List_Access);
53 -- Parse an attribute declaration
55 procedure Parse_Case_Construction
56 (In_Tree : Project_Node_Tree_Ref;
57 Case_Construction : out Project_Node_Id;
58 First_Attribute : Attribute_Node_Id;
59 Current_Project : Project_Node_Id;
60 Current_Package : Project_Node_Id;
61 Packages_To_Check : String_List_Access);
62 -- Parse a case construction
64 procedure Parse_Declarative_Items
65 (In_Tree : Project_Node_Tree_Ref;
66 Declarations : out Project_Node_Id;
68 First_Attribute : Attribute_Node_Id;
69 Current_Project : Project_Node_Id;
70 Current_Package : Project_Node_Id;
71 Packages_To_Check : String_List_Access);
72 -- Parse declarative items. Depending on In_Zone, some declarative
73 -- items may be forbiden.
75 procedure Parse_Package_Declaration
76 (In_Tree : Project_Node_Tree_Ref;
77 Package_Declaration : out Project_Node_Id;
78 Current_Project : Project_Node_Id;
79 Packages_To_Check : String_List_Access);
80 -- Parse a package declaration
82 procedure Parse_String_Type_Declaration
83 (In_Tree : Project_Node_Tree_Ref;
84 String_Type : out Project_Node_Id;
85 Current_Project : Project_Node_Id);
86 -- type <name> is ( <literal_string> { , <literal_string> } ) ;
88 procedure Parse_Variable_Declaration
89 (In_Tree : Project_Node_Tree_Ref;
90 Variable : out Project_Node_Id;
91 Current_Project : Project_Node_Id;
92 Current_Package : Project_Node_Id);
93 -- Parse a variable assignment
94 -- <variable_Name> := <expression>; OR
95 -- <variable_Name> : <string_type_Name> := <string_expression>;
102 (In_Tree : Project_Node_Tree_Ref;
103 Declarations : out Project_Node_Id;
104 Current_Project : Project_Node_Id;
105 Extends : Project_Node_Id;
106 Packages_To_Check : String_List_Access)
108 First_Declarative_Item : Project_Node_Id := Empty_Node;
113 (Of_Kind => N_Project_Declaration, In_Tree => In_Tree);
114 Set_Location_Of (Declarations, In_Tree, To => Token_Ptr);
115 Set_Extended_Project_Of (Declarations, In_Tree, To => Extends);
116 Set_Project_Declaration_Of (Current_Project, In_Tree, Declarations);
117 Parse_Declarative_Items
118 (Declarations => First_Declarative_Item,
120 In_Zone => In_Project,
121 First_Attribute => Prj.Attr.Attribute_First,
122 Current_Project => Current_Project,
123 Current_Package => Empty_Node,
124 Packages_To_Check => Packages_To_Check);
125 Set_First_Declarative_Item_Of
126 (Declarations, In_Tree, To => First_Declarative_Item);
129 ---------------------------------
130 -- Parse_Attribute_Declaration --
131 ---------------------------------
133 procedure Parse_Attribute_Declaration
134 (In_Tree : Project_Node_Tree_Ref;
135 Attribute : out Project_Node_Id;
136 First_Attribute : Attribute_Node_Id;
137 Current_Project : Project_Node_Id;
138 Current_Package : Project_Node_Id;
139 Packages_To_Check : String_List_Access)
141 Current_Attribute : Attribute_Node_Id := First_Attribute;
142 Full_Associative_Array : Boolean := False;
143 Attribute_Name : Name_Id := No_Name;
144 Optional_Index : Boolean := False;
145 Pkg_Id : Package_Node_Id := Empty_Package;
146 Ignore : Boolean := False;
151 (Of_Kind => N_Attribute_Declaration, In_Tree => In_Tree);
152 Set_Location_Of (Attribute, In_Tree, To => Token_Ptr);
153 Set_Previous_Line_Node (Attribute);
159 -- Body may be an attribute name
161 if Token = Tok_Body then
162 Token := Tok_Identifier;
163 Token_Name := Snames.Name_Body;
166 Expect (Tok_Identifier, "identifier");
168 if Token = Tok_Identifier then
169 Attribute_Name := Token_Name;
170 Set_Name_Of (Attribute, In_Tree, To => Token_Name);
171 Set_Location_Of (Attribute, In_Tree, To => Token_Ptr);
173 -- Find the attribute
176 Attribute_Node_Id_Of (Token_Name, First_Attribute);
178 -- If the attribute cannot be found, create the attribute if inside
179 -- an unknown package.
181 if Current_Attribute = Empty_Attribute then
182 if Current_Package /= Empty_Node
183 and then Expression_Kind_Of (Current_Package, In_Tree) = Ignored
185 Pkg_Id := Package_Id_Of (Current_Package, In_Tree);
186 Add_Attribute (Pkg_Id, Token_Name, Current_Attribute);
189 -- If not a valid attribute name, issue an error if inside
190 -- a package that need to be checked.
192 Ignore := Current_Package /= Empty_Node and then
193 Packages_To_Check /= All_Packages;
197 -- Check that we are not in a package to check
199 Get_Name_String (Name_Of (Current_Package, In_Tree));
201 for Index in Packages_To_Check'Range loop
202 if Name_Buffer (1 .. Name_Len) =
203 Packages_To_Check (Index).all
212 Error_Msg_Name_1 := Token_Name;
213 Error_Msg ("undefined attribute %%", Token_Ptr);
217 -- Set, if appropriate the index case insensitivity flag
220 if Is_Read_Only (Current_Attribute) then
222 ("read-only attribute cannot be given a value",
226 if Attribute_Kind_Of (Current_Attribute) in
227 Case_Insensitive_Associative_Array ..
228 Optional_Index_Case_Insensitive_Associative_Array
230 Set_Case_Insensitive (Attribute, In_Tree, To => True);
234 Scan (In_Tree); -- past the attribute name
237 -- Change obsolete names of attributes to the new names
239 if Current_Package /= Empty_Node
240 and then Expression_Kind_Of (Current_Package, In_Tree) /= Ignored
242 case Name_Of (Attribute, In_Tree) is
243 when Snames.Name_Specification =>
244 Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec);
246 when Snames.Name_Specification_Suffix =>
247 Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec_Suffix);
249 when Snames.Name_Implementation =>
250 Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body);
252 when Snames.Name_Implementation_Suffix =>
253 Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body_Suffix);
260 -- Associative array attributes
262 if Token = Tok_Left_Paren then
264 -- If the attribute is not an associative array attribute, report
265 -- an error. If this information is still unknown, set the kind
266 -- to Associative_Array.
268 if Current_Attribute /= Empty_Attribute
269 and then Attribute_Kind_Of (Current_Attribute) = Single
271 Error_Msg ("the attribute """ &
273 (Attribute_Name_Of (Current_Attribute)) &
274 """ cannot be an associative array",
275 Location_Of (Attribute, In_Tree));
277 elsif Attribute_Kind_Of (Current_Attribute) = Unknown then
278 Set_Attribute_Kind_Of (Current_Attribute, To => Associative_Array);
281 Scan (In_Tree); -- past the left parenthesis
282 Expect (Tok_String_Literal, "literal string");
284 if Token = Tok_String_Literal then
285 Get_Name_String (Token_Name);
287 if Case_Insensitive (Attribute, In_Tree) then
288 To_Lower (Name_Buffer (1 .. Name_Len));
291 Set_Associative_Array_Index_Of (Attribute, In_Tree, Name_Find);
292 Scan (In_Tree); -- past the literal string index
294 if Token = Tok_At then
295 case Attribute_Kind_Of (Current_Attribute) is
296 when Optional_Index_Associative_Array |
297 Optional_Index_Case_Insensitive_Associative_Array =>
299 Expect (Tok_Integer_Literal, "integer literal");
301 if Token = Tok_Integer_Literal then
303 -- Set the source index value from given literal
306 Index : constant Int :=
307 UI_To_Int (Int_Literal_Value);
310 Error_Msg ("index cannot be zero", Token_Ptr);
313 (Attribute, In_Tree, To => Index);
321 Error_Msg ("index not allowed here", Token_Ptr);
324 if Token = Tok_Integer_Literal then
331 Expect (Tok_Right_Paren, "`)`");
333 if Token = Tok_Right_Paren then
334 Scan (In_Tree); -- past the right parenthesis
338 -- If it is an associative array attribute and there are no left
339 -- parenthesis, then this is a full associative array declaration.
340 -- Flag it as such for later processing of its value.
342 if Current_Attribute /= Empty_Attribute
344 Attribute_Kind_Of (Current_Attribute) /= Single
346 if Attribute_Kind_Of (Current_Attribute) = Unknown then
347 Set_Attribute_Kind_Of (Current_Attribute, To => Single);
350 Full_Associative_Array := True;
355 -- Set the expression kind of the attribute
357 if Current_Attribute /= Empty_Attribute then
358 Set_Expression_Kind_Of
359 (Attribute, In_Tree, To => Variable_Kind_Of (Current_Attribute));
360 Optional_Index := Optional_Index_Of (Current_Attribute);
363 Expect (Tok_Use, "USE");
365 if Token = Tok_Use then
368 if Full_Associative_Array then
370 -- Expect <project>'<same_attribute_name>, or
371 -- <project>.<same_package_name>'<same_attribute_name>
374 The_Project : Project_Node_Id := Empty_Node;
375 -- The node of the project where the associative array is
378 The_Package : Project_Node_Id := Empty_Node;
379 -- The node of the package where the associative array is
382 Project_Name : Name_Id := No_Name;
383 -- The name of the project where the associative array is
386 Location : Source_Ptr := No_Location;
387 -- The location of the project name
390 Expect (Tok_Identifier, "identifier");
392 if Token = Tok_Identifier then
393 Location := Token_Ptr;
395 -- Find the project node in the imported project or
396 -- in the project being extended.
398 The_Project := Imported_Or_Extended_Project_Of
399 (Current_Project, In_Tree, Token_Name);
401 if The_Project = Empty_Node then
402 Error_Msg ("unknown project", Location);
403 Scan (In_Tree); -- past the project name
406 Project_Name := Token_Name;
407 Scan (In_Tree); -- past the project name
409 -- If this is inside a package, a dot followed by the
410 -- name of the package must followed the project name.
412 if Current_Package /= Empty_Node then
413 Expect (Tok_Dot, "`.`");
415 if Token /= Tok_Dot then
416 The_Project := Empty_Node;
419 Scan (In_Tree); -- past the dot
420 Expect (Tok_Identifier, "identifier");
422 if Token /= Tok_Identifier then
423 The_Project := Empty_Node;
425 -- If it is not the same package name, issue error
428 Token_Name /= Name_Of (Current_Package, In_Tree)
430 The_Project := Empty_Node;
432 ("not the same package as " &
434 (Name_Of (Current_Package, In_Tree)),
439 First_Package_Of (The_Project, In_Tree);
441 -- Look for the package node
443 while The_Package /= Empty_Node
445 Name_Of (The_Package, In_Tree) /= Token_Name
448 Next_Package_In_Project
449 (The_Package, In_Tree);
452 -- If the package cannot be found in the
453 -- project, issue an error.
455 if The_Package = Empty_Node then
456 The_Project := Empty_Node;
457 Error_Msg_Name_2 := Project_Name;
458 Error_Msg_Name_1 := Token_Name;
460 ("package % not declared in project %",
464 Scan (In_Tree); -- past the package name
471 if The_Project /= Empty_Node then
473 -- Looking for '<same attribute name>
475 Expect (Tok_Apostrophe, "`''`");
477 if Token /= Tok_Apostrophe then
478 The_Project := Empty_Node;
481 Scan (In_Tree); -- past the apostrophe
482 Expect (Tok_Identifier, "identifier");
484 if Token /= Tok_Identifier then
485 The_Project := Empty_Node;
488 -- If it is not the same attribute name, issue error
490 if Token_Name /= Attribute_Name then
491 The_Project := Empty_Node;
492 Error_Msg_Name_1 := Attribute_Name;
493 Error_Msg ("invalid name, should be %", Token_Ptr);
496 Scan (In_Tree); -- past the attribute name
501 if The_Project = Empty_Node then
503 -- If there were any problem, set the attribute id to null,
504 -- so that the node will not be recorded.
506 Current_Attribute := Empty_Attribute;
509 -- Set the appropriate field in the node.
510 -- Note that the index and the expression are nil. This
511 -- characterizes full associative array attribute
514 Set_Associative_Project_Of (Attribute, In_Tree, The_Project);
515 Set_Associative_Package_Of (Attribute, In_Tree, The_Package);
519 -- Other attribute declarations (not full associative array)
523 Expression_Location : constant Source_Ptr := Token_Ptr;
524 -- The location of the first token of the expression
526 Expression : Project_Node_Id := Empty_Node;
527 -- The expression, value for the attribute declaration
530 -- Get the expression value and set it in the attribute node
534 Expression => Expression,
535 Current_Project => Current_Project,
536 Current_Package => Current_Package,
537 Optional_Index => Optional_Index);
538 Set_Expression_Of (Attribute, In_Tree, To => Expression);
540 -- If the expression is legal, but not of the right kind
541 -- for the attribute, issue an error.
543 if Current_Attribute /= Empty_Attribute
544 and then Expression /= Empty_Node
545 and then Variable_Kind_Of (Current_Attribute) /=
546 Expression_Kind_Of (Expression, In_Tree)
548 if Variable_Kind_Of (Current_Attribute) = Undefined then
551 To => Expression_Kind_Of (Expression, In_Tree));
555 ("wrong expression kind for attribute """ &
557 (Attribute_Name_Of (Current_Attribute)) &
559 Expression_Location);
566 -- If the attribute was not recognized, return an empty node.
567 -- It may be that it is not in a package to check, and the node will
568 -- not be added to the tree.
570 if Current_Attribute = Empty_Attribute then
571 Attribute := Empty_Node;
574 Set_End_Of_Line (Attribute);
575 Set_Previous_Line_Node (Attribute);
576 end Parse_Attribute_Declaration;
578 -----------------------------
579 -- Parse_Case_Construction --
580 -----------------------------
582 procedure Parse_Case_Construction
583 (In_Tree : Project_Node_Tree_Ref;
584 Case_Construction : out Project_Node_Id;
585 First_Attribute : Attribute_Node_Id;
586 Current_Project : Project_Node_Id;
587 Current_Package : Project_Node_Id;
588 Packages_To_Check : String_List_Access)
590 Current_Item : Project_Node_Id := Empty_Node;
591 Next_Item : Project_Node_Id := Empty_Node;
592 First_Case_Item : Boolean := True;
594 Variable_Location : Source_Ptr := No_Location;
596 String_Type : Project_Node_Id := Empty_Node;
598 Case_Variable : Project_Node_Id := Empty_Node;
600 First_Declarative_Item : Project_Node_Id := Empty_Node;
602 First_Choice : Project_Node_Id := Empty_Node;
604 When_Others : Boolean := False;
605 -- Set to True when there is a "when others =>" clause
610 (Of_Kind => N_Case_Construction, In_Tree => In_Tree);
611 Set_Location_Of (Case_Construction, In_Tree, To => Token_Ptr);
617 -- Get the switch variable
619 Expect (Tok_Identifier, "identifier");
621 if Token = Tok_Identifier then
622 Variable_Location := Token_Ptr;
623 Parse_Variable_Reference
625 Variable => Case_Variable,
626 Current_Project => Current_Project,
627 Current_Package => Current_Package);
628 Set_Case_Variable_Reference_Of
629 (Case_Construction, In_Tree, To => Case_Variable);
632 if Token /= Tok_Is then
637 if Case_Variable /= Empty_Node then
638 String_Type := String_Type_Of (Case_Variable, In_Tree);
640 if String_Type = Empty_Node then
641 Error_Msg ("variable """ &
642 Get_Name_String (Name_Of (Case_Variable, In_Tree)) &
648 Expect (Tok_Is, "IS");
650 if Token = Tok_Is then
651 Set_End_Of_Line (Case_Construction);
652 Set_Previous_Line_Node (Case_Construction);
653 Set_Next_End_Node (Case_Construction);
660 Start_New_Case_Construction (In_Tree, String_Type);
664 while Token = Tok_When loop
666 if First_Case_Item then
669 (Of_Kind => N_Case_Item, In_Tree => In_Tree);
670 Set_First_Case_Item_Of
671 (Case_Construction, In_Tree, To => Current_Item);
672 First_Case_Item := False;
677 (Of_Kind => N_Case_Item, In_Tree => In_Tree);
678 Set_Next_Case_Item (Current_Item, In_Tree, To => Next_Item);
679 Current_Item := Next_Item;
682 Set_Location_Of (Current_Item, In_Tree, To => Token_Ptr);
688 if Token = Tok_Others then
691 -- Scan past "others"
695 Expect (Tok_Arrow, "`=>`");
696 Set_End_Of_Line (Current_Item);
697 Set_Previous_Line_Node (Current_Item);
699 -- Empty_Node in Field1 of a Case_Item indicates
700 -- the "when others =>" branch.
702 Set_First_Choice_Of (Current_Item, In_Tree, To => Empty_Node);
704 Parse_Declarative_Items
706 Declarations => First_Declarative_Item,
707 In_Zone => In_Case_Construction,
708 First_Attribute => First_Attribute,
709 Current_Project => Current_Project,
710 Current_Package => Current_Package,
711 Packages_To_Check => Packages_To_Check);
713 -- "when others =>" must be the last branch, so save the
714 -- Case_Item and exit
716 Set_First_Declarative_Item_Of
717 (Current_Item, In_Tree, To => First_Declarative_Item);
723 First_Choice => First_Choice);
724 Set_First_Choice_Of (Current_Item, In_Tree, To => First_Choice);
726 Expect (Tok_Arrow, "`=>`");
727 Set_End_Of_Line (Current_Item);
728 Set_Previous_Line_Node (Current_Item);
730 Parse_Declarative_Items
732 Declarations => First_Declarative_Item,
733 In_Zone => In_Case_Construction,
734 First_Attribute => First_Attribute,
735 Current_Project => Current_Project,
736 Current_Package => Current_Package,
737 Packages_To_Check => Packages_To_Check);
739 Set_First_Declarative_Item_Of
740 (Current_Item, In_Tree, To => First_Declarative_Item);
745 End_Case_Construction
746 (Check_All_Labels => not When_Others and not Quiet_Output,
747 Case_Location => Location_Of (Case_Construction, In_Tree));
749 Expect (Tok_End, "`END CASE`");
750 Remove_Next_End_Node;
752 if Token = Tok_End then
758 Expect (Tok_Case, "CASE");
766 Expect (Tok_Semicolon, "`;`");
767 Set_Previous_End_Node (Case_Construction);
769 end Parse_Case_Construction;
771 -----------------------------
772 -- Parse_Declarative_Items --
773 -----------------------------
775 procedure Parse_Declarative_Items
776 (In_Tree : Project_Node_Tree_Ref;
777 Declarations : out Project_Node_Id;
779 First_Attribute : Attribute_Node_Id;
780 Current_Project : Project_Node_Id;
781 Current_Package : Project_Node_Id;
782 Packages_To_Check : String_List_Access)
784 Current_Declarative_Item : Project_Node_Id := Empty_Node;
785 Next_Declarative_Item : Project_Node_Id := Empty_Node;
786 Current_Declaration : Project_Node_Id := Empty_Node;
787 Item_Location : Source_Ptr := No_Location;
790 Declarations := Empty_Node;
793 -- We are always positioned at the token that precedes the first
794 -- token of the declarative element. Scan past it.
798 Item_Location := Token_Ptr;
801 when Tok_Identifier =>
803 if In_Zone = In_Case_Construction then
805 -- Check if the variable has already been declared
808 The_Variable : Project_Node_Id := Empty_Node;
811 if Current_Package /= Empty_Node then
813 First_Variable_Of (Current_Package, In_Tree);
814 elsif Current_Project /= Empty_Node then
816 First_Variable_Of (Current_Project, In_Tree);
819 while The_Variable /= Empty_Node
820 and then Name_Of (The_Variable, In_Tree) /=
823 The_Variable := Next_Variable (The_Variable, In_Tree);
826 -- It is an error to declare a variable in a case
827 -- construction for the first time.
829 if The_Variable = Empty_Node then
831 ("a variable cannot be declared " &
832 "for the first time here",
838 Parse_Variable_Declaration
841 Current_Project => Current_Project,
842 Current_Package => Current_Package);
844 Set_End_Of_Line (Current_Declaration);
845 Set_Previous_Line_Node (Current_Declaration);
849 Parse_Attribute_Declaration
851 Attribute => Current_Declaration,
852 First_Attribute => First_Attribute,
853 Current_Project => Current_Project,
854 Current_Package => Current_Package,
855 Packages_To_Check => Packages_To_Check);
857 Set_End_Of_Line (Current_Declaration);
858 Set_Previous_Line_Node (Current_Declaration);
862 Scan (In_Tree); -- past "null"
866 -- Package declaration
868 if In_Zone /= In_Project then
869 Error_Msg ("a package cannot be declared here", Token_Ptr);
872 Parse_Package_Declaration
874 Package_Declaration => Current_Declaration,
875 Current_Project => Current_Project,
876 Packages_To_Check => Packages_To_Check);
878 Set_Previous_End_Node (Current_Declaration);
882 -- Type String Declaration
884 if In_Zone /= In_Project then
885 Error_Msg ("a string type cannot be declared here",
889 Parse_String_Type_Declaration
891 String_Type => Current_Declaration,
892 Current_Project => Current_Project);
894 Set_End_Of_Line (Current_Declaration);
895 Set_Previous_Line_Node (Current_Declaration);
901 Parse_Case_Construction
903 Case_Construction => Current_Declaration,
904 First_Attribute => First_Attribute,
905 Current_Project => Current_Project,
906 Current_Package => Current_Package,
907 Packages_To_Check => Packages_To_Check);
909 Set_Previous_End_Node (Current_Declaration);
914 -- We are leaving Parse_Declarative_Items positionned
915 -- at the first token after the list of declarative items.
916 -- It could be "end" (for a project, a package declaration or
917 -- a case construction) or "when" (for a case construction)
921 Expect (Tok_Semicolon, "`;` after declarative items");
923 -- Insert an N_Declarative_Item in the tree, but only if
924 -- Current_Declaration is not an empty node.
926 if Current_Declaration /= Empty_Node then
927 if Current_Declarative_Item = Empty_Node then
928 Current_Declarative_Item :=
930 (Of_Kind => N_Declarative_Item, In_Tree => In_Tree);
931 Declarations := Current_Declarative_Item;
934 Next_Declarative_Item :=
936 (Of_Kind => N_Declarative_Item, In_Tree => In_Tree);
937 Set_Next_Declarative_Item
938 (Current_Declarative_Item, In_Tree,
939 To => Next_Declarative_Item);
940 Current_Declarative_Item := Next_Declarative_Item;
943 Set_Current_Item_Node
944 (Current_Declarative_Item, In_Tree,
945 To => Current_Declaration);
947 (Current_Declarative_Item, In_Tree, To => Item_Location);
950 end Parse_Declarative_Items;
952 -------------------------------
953 -- Parse_Package_Declaration --
954 -------------------------------
956 procedure Parse_Package_Declaration
957 (In_Tree : Project_Node_Tree_Ref;
958 Package_Declaration : out Project_Node_Id;
959 Current_Project : Project_Node_Id;
960 Packages_To_Check : String_List_Access)
962 First_Attribute : Attribute_Node_Id := Empty_Attribute;
963 Current_Package : Package_Node_Id := Empty_Package;
964 First_Declarative_Item : Project_Node_Id := Empty_Node;
966 Package_Location : constant Source_Ptr := Token_Ptr;
969 Package_Declaration :=
971 (Of_Kind => N_Package_Declaration, In_Tree => In_Tree);
972 Set_Location_Of (Package_Declaration, In_Tree, To => Package_Location);
974 -- Scan past "package"
977 Expect (Tok_Identifier, "identifier");
979 if Token = Tok_Identifier then
980 Set_Name_Of (Package_Declaration, In_Tree, To => Token_Name);
982 Current_Package := Package_Node_Id_Of (Token_Name);
984 if Current_Package /= Empty_Package then
985 First_Attribute := First_Attribute_Of (Current_Package);
988 if not Quiet_Output then
991 (Name_Of (Package_Declaration, In_Tree)) &
992 """ is not a known package name",
996 -- Set the package declaration to "ignored" so that it is not
997 -- processed by Prj.Proc.Process.
999 Set_Expression_Kind_Of (Package_Declaration, In_Tree, Ignored);
1001 -- Add the unknown package in the list of packages
1003 Add_Unknown_Package (Token_Name, Current_Package);
1007 (Package_Declaration, In_Tree, To => Current_Package);
1010 Current : Project_Node_Id :=
1011 First_Package_Of (Current_Project, In_Tree);
1014 while Current /= Empty_Node
1015 and then Name_Of (Current, In_Tree) /= Token_Name
1017 Current := Next_Package_In_Project (Current, In_Tree);
1020 if Current /= Empty_Node then
1023 Get_Name_String (Name_Of (Package_Declaration, In_Tree)) &
1024 """ is declared twice in the same project",
1028 -- Add the package to the project list
1030 Set_Next_Package_In_Project
1031 (Package_Declaration, In_Tree,
1032 To => First_Package_Of (Current_Project, In_Tree));
1033 Set_First_Package_Of
1034 (Current_Project, In_Tree, To => Package_Declaration);
1038 -- Scan past the package name
1043 if Token = Tok_Renames then
1044 if In_Configuration then
1046 ("no package renames in configuration projects", Token_Ptr);
1049 -- Scan past "renames"
1053 Expect (Tok_Identifier, "identifier");
1055 if Token = Tok_Identifier then
1057 Project_Name : constant Name_Id := Token_Name;
1059 Clause : Project_Node_Id :=
1060 First_With_Clause_Of (Current_Project, In_Tree);
1061 The_Project : Project_Node_Id := Empty_Node;
1062 Extended : constant Project_Node_Id :=
1064 (Project_Declaration_Of
1065 (Current_Project, In_Tree),
1068 while Clause /= Empty_Node loop
1069 -- Only non limited imported projects may be used in a
1070 -- renames declaration.
1073 Non_Limited_Project_Node_Of (Clause, In_Tree);
1074 exit when The_Project /= Empty_Node
1075 and then Name_Of (The_Project, In_Tree) = Project_Name;
1076 Clause := Next_With_Clause_Of (Clause, In_Tree);
1079 if Clause = Empty_Node then
1080 -- As we have not found the project in the imports, we check
1081 -- if it's the name of an eventual extended project.
1083 if Extended /= Empty_Node
1084 and then Name_Of (Extended, In_Tree) = Project_Name
1086 Set_Project_Of_Renamed_Package_Of
1087 (Package_Declaration, In_Tree, To => Extended);
1089 Error_Msg_Name_1 := Project_Name;
1091 ("% is not an imported or extended project", Token_Ptr);
1094 Set_Project_Of_Renamed_Package_Of
1095 (Package_Declaration, In_Tree, To => The_Project);
1100 Expect (Tok_Dot, "`.`");
1102 if Token = Tok_Dot then
1104 Expect (Tok_Identifier, "identifier");
1106 if Token = Tok_Identifier then
1107 if Name_Of (Package_Declaration, In_Tree) /= Token_Name then
1108 Error_Msg ("not the same package name", Token_Ptr);
1110 Project_Of_Renamed_Package_Of
1111 (Package_Declaration, In_Tree) /= Empty_Node
1114 Current : Project_Node_Id :=
1116 (Project_Of_Renamed_Package_Of
1117 (Package_Declaration, In_Tree),
1121 while Current /= Empty_Node
1122 and then Name_Of (Current, In_Tree) /= Token_Name
1125 Next_Package_In_Project (Current, In_Tree);
1128 if Current = Empty_Node then
1131 Get_Name_String (Token_Name) &
1132 """ is not a package declared by the project",
1143 Expect (Tok_Semicolon, "`;`");
1144 Set_End_Of_Line (Package_Declaration);
1145 Set_Previous_Line_Node (Package_Declaration);
1147 elsif Token = Tok_Is then
1148 Set_End_Of_Line (Package_Declaration);
1149 Set_Previous_Line_Node (Package_Declaration);
1150 Set_Next_End_Node (Package_Declaration);
1152 Parse_Declarative_Items
1153 (In_Tree => In_Tree,
1154 Declarations => First_Declarative_Item,
1155 In_Zone => In_Package,
1156 First_Attribute => First_Attribute,
1157 Current_Project => Current_Project,
1158 Current_Package => Package_Declaration,
1159 Packages_To_Check => Packages_To_Check);
1161 Set_First_Declarative_Item_Of
1162 (Package_Declaration, In_Tree, To => First_Declarative_Item);
1164 Expect (Tok_End, "END");
1166 if Token = Tok_End then
1173 -- We should have the name of the package after "end"
1175 Expect (Tok_Identifier, "identifier");
1177 if Token = Tok_Identifier
1178 and then Name_Of (Package_Declaration, In_Tree) /= No_Name
1179 and then Token_Name /= Name_Of (Package_Declaration, In_Tree)
1181 Error_Msg_Name_1 := Name_Of (Package_Declaration, In_Tree);
1182 Error_Msg ("expected %%", Token_Ptr);
1185 if Token /= Tok_Semicolon then
1187 -- Scan past the package name
1192 Expect (Tok_Semicolon, "`;`");
1193 Remove_Next_End_Node;
1196 Error_Msg ("expected IS or RENAMES", Token_Ptr);
1199 end Parse_Package_Declaration;
1201 -----------------------------------
1202 -- Parse_String_Type_Declaration --
1203 -----------------------------------
1205 procedure Parse_String_Type_Declaration
1206 (In_Tree : Project_Node_Tree_Ref;
1207 String_Type : out Project_Node_Id;
1208 Current_Project : Project_Node_Id)
1210 Current : Project_Node_Id := Empty_Node;
1211 First_String : Project_Node_Id := Empty_Node;
1215 Default_Project_Node
1216 (Of_Kind => N_String_Type_Declaration, In_Tree => In_Tree);
1218 Set_Location_Of (String_Type, In_Tree, To => Token_Ptr);
1224 Expect (Tok_Identifier, "identifier");
1226 if Token = Tok_Identifier then
1227 Set_Name_Of (String_Type, In_Tree, To => Token_Name);
1229 Current := First_String_Type_Of (Current_Project, In_Tree);
1230 while Current /= Empty_Node
1232 Name_Of (Current, In_Tree) /= Token_Name
1234 Current := Next_String_Type (Current, In_Tree);
1237 if Current /= Empty_Node then
1238 Error_Msg ("duplicate string type name """ &
1239 Get_Name_String (Token_Name) &
1243 Current := First_Variable_Of (Current_Project, In_Tree);
1244 while Current /= Empty_Node
1245 and then Name_Of (Current, In_Tree) /= Token_Name
1247 Current := Next_Variable (Current, In_Tree);
1250 if Current /= Empty_Node then
1252 Get_Name_String (Token_Name) &
1253 """ is already a variable name", Token_Ptr);
1255 Set_Next_String_Type
1256 (String_Type, In_Tree,
1257 To => First_String_Type_Of (Current_Project, In_Tree));
1258 Set_First_String_Type_Of
1259 (Current_Project, In_Tree, To => String_Type);
1263 -- Scan past the name
1268 Expect (Tok_Is, "IS");
1270 if Token = Tok_Is then
1274 Expect (Tok_Left_Paren, "`(`");
1276 if Token = Tok_Left_Paren then
1280 Parse_String_Type_List
1281 (In_Tree => In_Tree, First_String => First_String);
1282 Set_First_Literal_String (String_Type, In_Tree, To => First_String);
1284 Expect (Tok_Right_Paren, "`)`");
1286 if Token = Tok_Right_Paren then
1290 end Parse_String_Type_Declaration;
1292 --------------------------------
1293 -- Parse_Variable_Declaration --
1294 --------------------------------
1296 procedure Parse_Variable_Declaration
1297 (In_Tree : Project_Node_Tree_Ref;
1298 Variable : out Project_Node_Id;
1299 Current_Project : Project_Node_Id;
1300 Current_Package : Project_Node_Id)
1302 Expression_Location : Source_Ptr;
1303 String_Type_Name : Name_Id := No_Name;
1304 Project_String_Type_Name : Name_Id := No_Name;
1305 Type_Location : Source_Ptr := No_Location;
1306 Project_Location : Source_Ptr := No_Location;
1307 Expression : Project_Node_Id := Empty_Node;
1308 Variable_Name : constant Name_Id := Token_Name;
1309 OK : Boolean := True;
1313 Default_Project_Node
1314 (Of_Kind => N_Variable_Declaration, In_Tree => In_Tree);
1315 Set_Name_Of (Variable, In_Tree, To => Variable_Name);
1316 Set_Location_Of (Variable, In_Tree, To => Token_Ptr);
1318 -- Scan past the variable name
1322 if Token = Tok_Colon then
1324 -- Typed string variable declaration
1327 Set_Kind_Of (Variable, In_Tree, N_Typed_Variable_Declaration);
1328 Expect (Tok_Identifier, "identifier");
1330 OK := Token = Tok_Identifier;
1333 String_Type_Name := Token_Name;
1334 Type_Location := Token_Ptr;
1337 if Token = Tok_Dot then
1338 Project_String_Type_Name := String_Type_Name;
1339 Project_Location := Type_Location;
1341 -- Scan past the dot
1344 Expect (Tok_Identifier, "identifier");
1346 if Token = Tok_Identifier then
1347 String_Type_Name := Token_Name;
1348 Type_Location := Token_Ptr;
1357 Current : Project_Node_Id :=
1358 First_String_Type_Of (Current_Project, In_Tree);
1361 if Project_String_Type_Name /= No_Name then
1363 The_Project_Name_And_Node : constant
1364 Tree_Private_Part.Project_Name_And_Node :=
1365 Tree_Private_Part.Projects_Htable.Get
1366 (In_Tree.Projects_HT, Project_String_Type_Name);
1368 use Tree_Private_Part;
1371 if The_Project_Name_And_Node =
1372 Tree_Private_Part.No_Project_Name_And_Node
1374 Error_Msg ("unknown project """ &
1376 (Project_String_Type_Name) &
1379 Current := Empty_Node;
1382 First_String_Type_Of
1383 (The_Project_Name_And_Node.Node, In_Tree);
1388 while Current /= Empty_Node
1389 and then Name_Of (Current, In_Tree) /= String_Type_Name
1391 Current := Next_String_Type (Current, In_Tree);
1394 if Current = Empty_Node then
1395 Error_Msg ("unknown string type """ &
1396 Get_Name_String (String_Type_Name) &
1402 (Variable, In_Tree, To => Current);
1409 Expect (Tok_Colon_Equal, "`:=`");
1411 OK := OK and (Token = Tok_Colon_Equal);
1413 if Token = Tok_Colon_Equal then
1417 -- Get the single string or string list value
1419 Expression_Location := Token_Ptr;
1422 (In_Tree => In_Tree,
1423 Expression => Expression,
1424 Current_Project => Current_Project,
1425 Current_Package => Current_Package,
1426 Optional_Index => False);
1427 Set_Expression_Of (Variable, In_Tree, To => Expression);
1429 if Expression /= Empty_Node then
1430 -- A typed string must have a single string value, not a list
1432 if Kind_Of (Variable, In_Tree) = N_Typed_Variable_Declaration
1433 and then Expression_Kind_Of (Expression, In_Tree) = List
1436 ("expression must be a single string", Expression_Location);
1439 Set_Expression_Kind_Of
1441 To => Expression_Kind_Of (Expression, In_Tree));
1446 The_Variable : Project_Node_Id := Empty_Node;
1449 if Current_Package /= Empty_Node then
1450 The_Variable := First_Variable_Of (Current_Package, In_Tree);
1451 elsif Current_Project /= Empty_Node then
1452 The_Variable := First_Variable_Of (Current_Project, In_Tree);
1455 while The_Variable /= Empty_Node
1456 and then Name_Of (The_Variable, In_Tree) /= Variable_Name
1458 The_Variable := Next_Variable (The_Variable, In_Tree);
1461 if The_Variable = Empty_Node then
1462 if Current_Package /= Empty_Node then
1465 To => First_Variable_Of (Current_Package, In_Tree));
1466 Set_First_Variable_Of
1467 (Current_Package, In_Tree, To => Variable);
1469 elsif Current_Project /= Empty_Node then
1472 To => First_Variable_Of (Current_Project, In_Tree));
1473 Set_First_Variable_Of
1474 (Current_Project, In_Tree, To => Variable);
1478 if Expression_Kind_Of (Variable, In_Tree) /= Undefined then
1480 Expression_Kind_Of (The_Variable, In_Tree) = Undefined
1482 Set_Expression_Kind_Of
1483 (The_Variable, In_Tree,
1484 To => Expression_Kind_Of (Variable, In_Tree));
1487 if Expression_Kind_Of (The_Variable, In_Tree) /=
1488 Expression_Kind_Of (Variable, In_Tree)
1490 Error_Msg ("wrong expression kind for variable """ &
1492 (Name_Of (The_Variable, In_Tree)) &
1494 Expression_Location);
1502 end Parse_Variable_Declaration;