1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2005, 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, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, 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 Prj.Err; use Prj.Err;
31 with Prj.Strt; use Prj.Strt;
32 with Prj.Tree; use Prj.Tree;
34 with Prj.Attr; use Prj.Attr;
35 with Prj.Attr.PM; use Prj.Attr.PM;
36 with Uintp; use Uintp;
38 package body Prj.Dect is
40 type Zone is (In_Project, In_Package, In_Case_Construction);
41 -- Used to indicate if we are parsing a package (In_Package),
42 -- a case construction (In_Case_Construction) or none of those two
45 procedure Parse_Attribute_Declaration
46 (In_Tree : Project_Node_Tree_Ref;
47 Attribute : out Project_Node_Id;
48 First_Attribute : Attribute_Node_Id;
49 Current_Project : Project_Node_Id;
50 Current_Package : Project_Node_Id;
51 Packages_To_Check : String_List_Access);
52 -- Parse an attribute declaration
54 procedure Parse_Case_Construction
55 (In_Tree : Project_Node_Tree_Ref;
56 Case_Construction : out Project_Node_Id;
57 First_Attribute : Attribute_Node_Id;
58 Current_Project : Project_Node_Id;
59 Current_Package : Project_Node_Id;
60 Packages_To_Check : String_List_Access);
61 -- Parse a case construction
63 procedure Parse_Declarative_Items
64 (In_Tree : Project_Node_Tree_Ref;
65 Declarations : out Project_Node_Id;
67 First_Attribute : Attribute_Node_Id;
68 Current_Project : Project_Node_Id;
69 Current_Package : Project_Node_Id;
70 Packages_To_Check : String_List_Access);
71 -- Parse declarative items. Depending on In_Zone, some declarative
72 -- items may be forbiden.
74 procedure Parse_Package_Declaration
75 (In_Tree : Project_Node_Tree_Ref;
76 Package_Declaration : out Project_Node_Id;
77 Current_Project : Project_Node_Id;
78 Packages_To_Check : String_List_Access);
79 -- Parse a package declaration
81 procedure Parse_String_Type_Declaration
82 (In_Tree : Project_Node_Tree_Ref;
83 String_Type : out Project_Node_Id;
84 Current_Project : Project_Node_Id);
85 -- type <name> is ( <literal_string> { , <literal_string> } ) ;
87 procedure Parse_Variable_Declaration
88 (In_Tree : Project_Node_Tree_Ref;
89 Variable : out Project_Node_Id;
90 Current_Project : Project_Node_Id;
91 Current_Package : Project_Node_Id);
92 -- Parse a variable assignment
93 -- <variable_Name> := <expression>; OR
94 -- <variable_Name> : <string_type_Name> := <string_expression>;
101 (In_Tree : Project_Node_Tree_Ref;
102 Declarations : out Project_Node_Id;
103 Current_Project : Project_Node_Id;
104 Extends : Project_Node_Id;
105 Packages_To_Check : String_List_Access)
107 First_Declarative_Item : Project_Node_Id := Empty_Node;
112 (Of_Kind => N_Project_Declaration, In_Tree => In_Tree);
113 Set_Location_Of (Declarations, In_Tree, To => Token_Ptr);
114 Set_Extended_Project_Of (Declarations, In_Tree, To => Extends);
115 Set_Project_Declaration_Of (Current_Project, In_Tree, Declarations);
116 Parse_Declarative_Items
117 (Declarations => First_Declarative_Item,
119 In_Zone => In_Project,
120 First_Attribute => Prj.Attr.Attribute_First,
121 Current_Project => Current_Project,
122 Current_Package => Empty_Node,
123 Packages_To_Check => Packages_To_Check);
124 Set_First_Declarative_Item_Of
125 (Declarations, In_Tree, To => First_Declarative_Item);
128 ---------------------------------
129 -- Parse_Attribute_Declaration --
130 ---------------------------------
132 procedure Parse_Attribute_Declaration
133 (In_Tree : Project_Node_Tree_Ref;
134 Attribute : out Project_Node_Id;
135 First_Attribute : Attribute_Node_Id;
136 Current_Project : Project_Node_Id;
137 Current_Package : Project_Node_Id;
138 Packages_To_Check : String_List_Access)
140 Current_Attribute : Attribute_Node_Id := First_Attribute;
141 Full_Associative_Array : Boolean := False;
142 Attribute_Name : Name_Id := No_Name;
143 Optional_Index : Boolean := False;
144 Pkg_Id : Package_Node_Id := Empty_Package;
145 Warning : Boolean := False;
150 (Of_Kind => N_Attribute_Declaration, In_Tree => In_Tree);
151 Set_Location_Of (Attribute, In_Tree, To => Token_Ptr);
152 Set_Previous_Line_Node (Attribute);
158 -- Body may be an attribute name
160 if Token = Tok_Body then
161 Token := Tok_Identifier;
162 Token_Name := Snames.Name_Body;
165 Expect (Tok_Identifier, "identifier");
167 if Token = Tok_Identifier then
168 Attribute_Name := Token_Name;
169 Set_Name_Of (Attribute, In_Tree, To => Token_Name);
170 Set_Location_Of (Attribute, In_Tree, To => Token_Ptr);
172 -- Find the attribute
175 Attribute_Node_Id_Of (Token_Name, First_Attribute);
177 -- If the attribute cannot be found, create the attribute if inside
178 -- an unknown package.
180 if Current_Attribute = Empty_Attribute then
181 if Current_Package /= Empty_Node
182 and then Expression_Kind_Of (Current_Package, In_Tree) = Ignored
184 Pkg_Id := Package_Id_Of (Current_Package, In_Tree);
185 Add_Attribute (Pkg_Id, Token_Name, Current_Attribute);
186 Error_Msg_Name_1 := Token_Name;
187 Error_Msg ("?unknown attribute {", Token_Ptr);
190 -- If not a valid attribute name, issue an error, or a warning
191 -- if inside a package that does not need to be checked.
193 Warning := Current_Package /= Empty_Node and then
194 Packages_To_Check /= All_Packages;
198 -- Check that we are not in a package to check
200 Get_Name_String (Name_Of (Current_Package, In_Tree));
202 for Index in Packages_To_Check'Range loop
203 if Name_Buffer (1 .. Name_Len) =
204 Packages_To_Check (Index).all
212 Error_Msg_Name_1 := Token_Name;
213 Error_Msg_Warn := Warning;
214 Error_Msg ("<undefined attribute {", Token_Ptr);
217 -- Set, if appropriate the index case insensitivity flag
219 elsif Attribute_Kind_Of (Current_Attribute) in
220 Case_Insensitive_Associative_Array ..
221 Optional_Index_Case_Insensitive_Associative_Array
223 Set_Case_Insensitive (Attribute, In_Tree, To => True);
226 Scan (In_Tree); -- past the attribute name
229 -- Change obsolete names of attributes to the new names
231 if Current_Package /= Empty_Node
232 and then Expression_Kind_Of (Current_Package, In_Tree) /= Ignored
234 case Name_Of (Attribute, In_Tree) is
235 when Snames.Name_Specification =>
236 Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec);
238 when Snames.Name_Specification_Suffix =>
239 Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec_Suffix);
241 when Snames.Name_Implementation =>
242 Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body);
244 when Snames.Name_Implementation_Suffix =>
245 Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body_Suffix);
252 -- Associative array attributes
254 if Token = Tok_Left_Paren then
256 -- If the attribute is not an associative array attribute, report
257 -- an error. If this information is still unknown, set the kind
258 -- to Associative_Array.
260 if Current_Attribute /= Empty_Attribute
261 and then Attribute_Kind_Of (Current_Attribute) = Single
263 Error_Msg ("the attribute """ &
265 (Attribute_Name_Of (Current_Attribute)) &
266 """ cannot be an associative array",
267 Location_Of (Attribute, In_Tree));
269 elsif Attribute_Kind_Of (Current_Attribute) = Unknown then
270 Set_Attribute_Kind_Of (Current_Attribute, To => Associative_Array);
273 Scan (In_Tree); -- past the left parenthesis
274 Expect (Tok_String_Literal, "literal string");
276 if Token = Tok_String_Literal then
277 Set_Associative_Array_Index_Of (Attribute, In_Tree, Token_Name);
278 Scan (In_Tree); -- past the literal string index
280 if Token = Tok_At then
281 case Attribute_Kind_Of (Current_Attribute) is
282 when Optional_Index_Associative_Array |
283 Optional_Index_Case_Insensitive_Associative_Array =>
285 Expect (Tok_Integer_Literal, "integer literal");
287 if Token = Tok_Integer_Literal then
289 -- Set the source index value from given literal
292 Index : constant Int :=
293 UI_To_Int (Int_Literal_Value);
296 Error_Msg ("index cannot be zero", Token_Ptr);
299 (Attribute, In_Tree, To => Index);
307 Error_Msg ("index not allowed here", Token_Ptr);
310 if Token = Tok_Integer_Literal then
317 Expect (Tok_Right_Paren, "`)`");
319 if Token = Tok_Right_Paren then
320 Scan (In_Tree); -- past the right parenthesis
324 -- If it is an associative array attribute and there are no left
325 -- parenthesis, then this is a full associative array declaration.
326 -- Flag it as such for later processing of its value.
328 if Current_Attribute /= Empty_Attribute
330 Attribute_Kind_Of (Current_Attribute) /= Single
332 if Attribute_Kind_Of (Current_Attribute) = Unknown then
333 Set_Attribute_Kind_Of (Current_Attribute, To => Single);
336 Full_Associative_Array := True;
341 -- Set the expression kind of the attribute
343 if Current_Attribute /= Empty_Attribute then
344 Set_Expression_Kind_Of
345 (Attribute, In_Tree, To => Variable_Kind_Of (Current_Attribute));
346 Optional_Index := Optional_Index_Of (Current_Attribute);
349 Expect (Tok_Use, "USE");
351 if Token = Tok_Use then
354 if Full_Associative_Array then
356 -- Expect <project>'<same_attribute_name>, or
357 -- <project>.<same_package_name>'<same_attribute_name>
360 The_Project : Project_Node_Id := Empty_Node;
361 -- The node of the project where the associative array is
364 The_Package : Project_Node_Id := Empty_Node;
365 -- The node of the package where the associative array is
368 Project_Name : Name_Id := No_Name;
369 -- The name of the project where the associative array is
372 Location : Source_Ptr := No_Location;
373 -- The location of the project name
376 Expect (Tok_Identifier, "identifier");
378 if Token = Tok_Identifier then
379 Location := Token_Ptr;
381 -- Find the project node in the imported project or
382 -- in the project being extended.
384 The_Project := Imported_Or_Extended_Project_Of
385 (Current_Project, In_Tree, Token_Name);
387 if The_Project = Empty_Node then
388 Error_Msg ("unknown project", Location);
389 Scan (In_Tree); -- past the project name
392 Project_Name := Token_Name;
393 Scan (In_Tree); -- past the project name
395 -- If this is inside a package, a dot followed by the
396 -- name of the package must followed the project name.
398 if Current_Package /= Empty_Node then
399 Expect (Tok_Dot, "`.`");
401 if Token /= Tok_Dot then
402 The_Project := Empty_Node;
405 Scan (In_Tree); -- past the dot
406 Expect (Tok_Identifier, "identifier");
408 if Token /= Tok_Identifier then
409 The_Project := Empty_Node;
411 -- If it is not the same package name, issue error
414 Token_Name /= Name_Of (Current_Package, In_Tree)
416 The_Project := Empty_Node;
418 ("not the same package as " &
420 (Name_Of (Current_Package, In_Tree)),
425 First_Package_Of (The_Project, In_Tree);
427 -- Look for the package node
429 while The_Package /= Empty_Node
431 Name_Of (The_Package, In_Tree) /= Token_Name
434 Next_Package_In_Project
435 (The_Package, In_Tree);
438 -- If the package cannot be found in the
439 -- project, issue an error.
441 if The_Package = Empty_Node then
442 The_Project := Empty_Node;
443 Error_Msg_Name_2 := Project_Name;
444 Error_Msg_Name_1 := Token_Name;
446 ("package % not declared in project %",
450 Scan (In_Tree); -- past the package name
457 if The_Project /= Empty_Node then
459 -- Looking for '<same attribute name>
461 Expect (Tok_Apostrophe, "`''`");
463 if Token /= Tok_Apostrophe then
464 The_Project := Empty_Node;
467 Scan (In_Tree); -- past the apostrophe
468 Expect (Tok_Identifier, "identifier");
470 if Token /= Tok_Identifier then
471 The_Project := Empty_Node;
474 -- If it is not the same attribute name, issue error
476 if Token_Name /= Attribute_Name then
477 The_Project := Empty_Node;
478 Error_Msg_Name_1 := Attribute_Name;
479 Error_Msg ("invalid name, should be %", Token_Ptr);
482 Scan (In_Tree); -- past the attribute name
487 if The_Project = Empty_Node then
489 -- If there were any problem, set the attribute id to null,
490 -- so that the node will not be recorded.
492 Current_Attribute := Empty_Attribute;
495 -- Set the appropriate field in the node.
496 -- Note that the index and the expression are nil. This
497 -- characterizes full associative array attribute
500 Set_Associative_Project_Of (Attribute, In_Tree, The_Project);
501 Set_Associative_Package_Of (Attribute, In_Tree, The_Package);
505 -- Other attribute declarations (not full associative array)
509 Expression_Location : constant Source_Ptr := Token_Ptr;
510 -- The location of the first token of the expression
512 Expression : Project_Node_Id := Empty_Node;
513 -- The expression, value for the attribute declaration
516 -- Get the expression value and set it in the attribute node
520 Expression => Expression,
521 Current_Project => Current_Project,
522 Current_Package => Current_Package,
523 Optional_Index => Optional_Index);
524 Set_Expression_Of (Attribute, In_Tree, To => Expression);
526 -- If the expression is legal, but not of the right kind
527 -- for the attribute, issue an error.
529 if Current_Attribute /= Empty_Attribute
530 and then Expression /= Empty_Node
531 and then Variable_Kind_Of (Current_Attribute) /=
532 Expression_Kind_Of (Expression, In_Tree)
534 if Variable_Kind_Of (Current_Attribute) = Undefined then
537 To => Expression_Kind_Of (Expression, In_Tree));
541 ("wrong expression kind for attribute """ &
543 (Attribute_Name_Of (Current_Attribute)) &
545 Expression_Location);
552 -- If the attribute was not recognized, return an empty node.
553 -- It may be that it is not in a package to check, and the node will
554 -- not be added to the tree.
556 if Current_Attribute = Empty_Attribute then
557 Attribute := Empty_Node;
560 Set_End_Of_Line (Attribute);
561 Set_Previous_Line_Node (Attribute);
562 end Parse_Attribute_Declaration;
564 -----------------------------
565 -- Parse_Case_Construction --
566 -----------------------------
568 procedure Parse_Case_Construction
569 (In_Tree : Project_Node_Tree_Ref;
570 Case_Construction : out Project_Node_Id;
571 First_Attribute : Attribute_Node_Id;
572 Current_Project : Project_Node_Id;
573 Current_Package : Project_Node_Id;
574 Packages_To_Check : String_List_Access)
576 Current_Item : Project_Node_Id := Empty_Node;
577 Next_Item : Project_Node_Id := Empty_Node;
578 First_Case_Item : Boolean := True;
580 Variable_Location : Source_Ptr := No_Location;
582 String_Type : Project_Node_Id := Empty_Node;
584 Case_Variable : Project_Node_Id := Empty_Node;
586 First_Declarative_Item : Project_Node_Id := Empty_Node;
588 First_Choice : Project_Node_Id := Empty_Node;
590 When_Others : Boolean := False;
591 -- Set to True when there is a "when others =>" clause
596 (Of_Kind => N_Case_Construction, In_Tree => In_Tree);
597 Set_Location_Of (Case_Construction, In_Tree, To => Token_Ptr);
603 -- Get the switch variable
605 Expect (Tok_Identifier, "identifier");
607 if Token = Tok_Identifier then
608 Variable_Location := Token_Ptr;
609 Parse_Variable_Reference
611 Variable => Case_Variable,
612 Current_Project => Current_Project,
613 Current_Package => Current_Package);
614 Set_Case_Variable_Reference_Of
615 (Case_Construction, In_Tree, To => Case_Variable);
618 if Token /= Tok_Is then
623 if Case_Variable /= Empty_Node then
624 String_Type := String_Type_Of (Case_Variable, In_Tree);
626 if String_Type = Empty_Node then
627 Error_Msg ("variable """ &
628 Get_Name_String (Name_Of (Case_Variable, In_Tree)) &
634 Expect (Tok_Is, "IS");
636 if Token = Tok_Is then
637 Set_End_Of_Line (Case_Construction);
638 Set_Previous_Line_Node (Case_Construction);
639 Set_Next_End_Node (Case_Construction);
646 Start_New_Case_Construction (In_Tree, String_Type);
650 while Token = Tok_When loop
652 if First_Case_Item then
655 (Of_Kind => N_Case_Item, In_Tree => In_Tree);
656 Set_First_Case_Item_Of
657 (Case_Construction, In_Tree, To => Current_Item);
658 First_Case_Item := False;
663 (Of_Kind => N_Case_Item, In_Tree => In_Tree);
664 Set_Next_Case_Item (Current_Item, In_Tree, To => Next_Item);
665 Current_Item := Next_Item;
668 Set_Location_Of (Current_Item, In_Tree, To => Token_Ptr);
674 if Token = Tok_Others then
677 -- Scan past "others"
681 Expect (Tok_Arrow, "`=>`");
682 Set_End_Of_Line (Current_Item);
683 Set_Previous_Line_Node (Current_Item);
685 -- Empty_Node in Field1 of a Case_Item indicates
686 -- the "when others =>" branch.
688 Set_First_Choice_Of (Current_Item, In_Tree, To => Empty_Node);
690 Parse_Declarative_Items
692 Declarations => First_Declarative_Item,
693 In_Zone => In_Case_Construction,
694 First_Attribute => First_Attribute,
695 Current_Project => Current_Project,
696 Current_Package => Current_Package,
697 Packages_To_Check => Packages_To_Check);
699 -- "when others =>" must be the last branch, so save the
700 -- Case_Item and exit
702 Set_First_Declarative_Item_Of
703 (Current_Item, In_Tree, To => First_Declarative_Item);
709 First_Choice => First_Choice);
710 Set_First_Choice_Of (Current_Item, In_Tree, To => First_Choice);
712 Expect (Tok_Arrow, "`=>`");
713 Set_End_Of_Line (Current_Item);
714 Set_Previous_Line_Node (Current_Item);
716 Parse_Declarative_Items
718 Declarations => First_Declarative_Item,
719 In_Zone => In_Case_Construction,
720 First_Attribute => First_Attribute,
721 Current_Project => Current_Project,
722 Current_Package => Current_Package,
723 Packages_To_Check => Packages_To_Check);
725 Set_First_Declarative_Item_Of
726 (Current_Item, In_Tree, To => First_Declarative_Item);
731 End_Case_Construction
732 (Check_All_Labels => not When_Others and not Quiet_Output,
733 Case_Location => Location_Of (Case_Construction, In_Tree));
735 Expect (Tok_End, "`END CASE`");
736 Remove_Next_End_Node;
738 if Token = Tok_End then
744 Expect (Tok_Case, "CASE");
752 Expect (Tok_Semicolon, "`;`");
753 Set_Previous_End_Node (Case_Construction);
755 end Parse_Case_Construction;
757 -----------------------------
758 -- Parse_Declarative_Items --
759 -----------------------------
761 procedure Parse_Declarative_Items
762 (In_Tree : Project_Node_Tree_Ref;
763 Declarations : out Project_Node_Id;
765 First_Attribute : Attribute_Node_Id;
766 Current_Project : Project_Node_Id;
767 Current_Package : Project_Node_Id;
768 Packages_To_Check : String_List_Access)
770 Current_Declarative_Item : Project_Node_Id := Empty_Node;
771 Next_Declarative_Item : Project_Node_Id := Empty_Node;
772 Current_Declaration : Project_Node_Id := Empty_Node;
773 Item_Location : Source_Ptr := No_Location;
776 Declarations := Empty_Node;
779 -- We are always positioned at the token that precedes
780 -- the first token of the declarative element.
785 Item_Location := Token_Ptr;
788 when Tok_Identifier =>
790 if In_Zone = In_Case_Construction then
791 Error_Msg ("a variable cannot be declared here",
795 Parse_Variable_Declaration
798 Current_Project => Current_Project,
799 Current_Package => Current_Package);
801 Set_End_Of_Line (Current_Declaration);
802 Set_Previous_Line_Node (Current_Declaration);
806 Parse_Attribute_Declaration
808 Attribute => Current_Declaration,
809 First_Attribute => First_Attribute,
810 Current_Project => Current_Project,
811 Current_Package => Current_Package,
812 Packages_To_Check => Packages_To_Check);
814 Set_End_Of_Line (Current_Declaration);
815 Set_Previous_Line_Node (Current_Declaration);
819 Scan (In_Tree); -- past "null"
823 -- Package declaration
825 if In_Zone /= In_Project then
826 Error_Msg ("a package cannot be declared here", Token_Ptr);
829 Parse_Package_Declaration
831 Package_Declaration => Current_Declaration,
832 Current_Project => Current_Project,
833 Packages_To_Check => Packages_To_Check);
835 Set_Previous_End_Node (Current_Declaration);
839 -- Type String Declaration
841 if In_Zone /= In_Project then
842 Error_Msg ("a string type cannot be declared here",
846 Parse_String_Type_Declaration
848 String_Type => Current_Declaration,
849 Current_Project => Current_Project);
851 Set_End_Of_Line (Current_Declaration);
852 Set_Previous_Line_Node (Current_Declaration);
858 Parse_Case_Construction
860 Case_Construction => Current_Declaration,
861 First_Attribute => First_Attribute,
862 Current_Project => Current_Project,
863 Current_Package => Current_Package,
864 Packages_To_Check => Packages_To_Check);
866 Set_Previous_End_Node (Current_Declaration);
871 -- We are leaving Parse_Declarative_Items positionned
872 -- at the first token after the list of declarative items.
873 -- It could be "end" (for a project, a package declaration or
874 -- a case construction) or "when" (for a case construction)
878 Expect (Tok_Semicolon, "`;` after declarative items");
880 -- Insert an N_Declarative_Item in the tree, but only if
881 -- Current_Declaration is not an empty node.
883 if Current_Declaration /= Empty_Node then
884 if Current_Declarative_Item = Empty_Node then
885 Current_Declarative_Item :=
887 (Of_Kind => N_Declarative_Item, In_Tree => In_Tree);
888 Declarations := Current_Declarative_Item;
891 Next_Declarative_Item :=
893 (Of_Kind => N_Declarative_Item, In_Tree => In_Tree);
894 Set_Next_Declarative_Item
895 (Current_Declarative_Item, In_Tree,
896 To => Next_Declarative_Item);
897 Current_Declarative_Item := Next_Declarative_Item;
900 Set_Current_Item_Node
901 (Current_Declarative_Item, In_Tree,
902 To => Current_Declaration);
904 (Current_Declarative_Item, In_Tree, To => Item_Location);
907 end Parse_Declarative_Items;
909 -------------------------------
910 -- Parse_Package_Declaration --
911 -------------------------------
913 procedure Parse_Package_Declaration
914 (In_Tree : Project_Node_Tree_Ref;
915 Package_Declaration : out Project_Node_Id;
916 Current_Project : Project_Node_Id;
917 Packages_To_Check : String_List_Access)
919 First_Attribute : Attribute_Node_Id := Empty_Attribute;
920 Current_Package : Package_Node_Id := Empty_Package;
921 First_Declarative_Item : Project_Node_Id := Empty_Node;
924 Package_Declaration :=
926 (Of_Kind => N_Package_Declaration, In_Tree => In_Tree);
927 Set_Location_Of (Package_Declaration, In_Tree, To => Token_Ptr);
929 -- Scan past "package"
932 Expect (Tok_Identifier, "identifier");
934 if Token = Tok_Identifier then
935 Set_Name_Of (Package_Declaration, In_Tree, To => Token_Name);
937 Current_Package := Package_Node_Id_Of (Token_Name);
939 if Current_Package /= Empty_Package then
940 First_Attribute := First_Attribute_Of (Current_Package);
945 (Name_Of (Package_Declaration, In_Tree)) &
946 """ is not a known package name",
949 -- Set the package declaration to "ignored" so that it is not
950 -- processed by Prj.Proc.Process.
952 Set_Expression_Kind_Of (Package_Declaration, In_Tree, Ignored);
954 -- Add the unknown package in the list of packages
956 Add_Unknown_Package (Token_Name, Current_Package);
960 (Package_Declaration, In_Tree, To => Current_Package);
963 Current : Project_Node_Id :=
964 First_Package_Of (Current_Project, In_Tree);
967 while Current /= Empty_Node
968 and then Name_Of (Current, In_Tree) /= Token_Name
970 Current := Next_Package_In_Project (Current, In_Tree);
973 if Current /= Empty_Node then
976 Get_Name_String (Name_Of (Package_Declaration, In_Tree)) &
977 """ is declared twice in the same project",
981 -- Add the package to the project list
983 Set_Next_Package_In_Project
984 (Package_Declaration, In_Tree,
985 To => First_Package_Of (Current_Project, In_Tree));
987 (Current_Project, In_Tree, To => Package_Declaration);
991 -- Scan past the package name
996 if Token = Tok_Renames then
998 -- Scan past "renames"
1002 Expect (Tok_Identifier, "identifier");
1004 if Token = Tok_Identifier then
1006 Project_Name : constant Name_Id := Token_Name;
1007 Clause : Project_Node_Id :=
1008 First_With_Clause_Of (Current_Project, In_Tree);
1009 The_Project : Project_Node_Id := Empty_Node;
1010 Extended : constant Project_Node_Id :=
1012 (Project_Declaration_Of
1013 (Current_Project, In_Tree),
1016 while Clause /= Empty_Node loop
1017 -- Only non limited imported projects may be used in a
1018 -- renames declaration.
1021 Non_Limited_Project_Node_Of (Clause, In_Tree);
1022 exit when The_Project /= Empty_Node
1023 and then Name_Of (The_Project, In_Tree) = Project_Name;
1024 Clause := Next_With_Clause_Of (Clause, In_Tree);
1027 if Clause = Empty_Node then
1028 -- As we have not found the project in the imports, we check
1029 -- if it's the name of an eventual extended project.
1031 if Extended /= Empty_Node
1032 and then Name_Of (Extended, In_Tree) = Project_Name
1034 Set_Project_Of_Renamed_Package_Of
1035 (Package_Declaration, In_Tree, To => Extended);
1037 Error_Msg_Name_1 := Project_Name;
1039 ("% is not an imported or extended project", Token_Ptr);
1042 Set_Project_Of_Renamed_Package_Of
1043 (Package_Declaration, In_Tree, To => The_Project);
1048 Expect (Tok_Dot, "`.`");
1050 if Token = Tok_Dot then
1052 Expect (Tok_Identifier, "identifier");
1054 if Token = Tok_Identifier then
1055 if Name_Of (Package_Declaration, In_Tree) /= Token_Name then
1056 Error_Msg ("not the same package name", Token_Ptr);
1058 Project_Of_Renamed_Package_Of
1059 (Package_Declaration, In_Tree) /= Empty_Node
1062 Current : Project_Node_Id :=
1064 (Project_Of_Renamed_Package_Of
1065 (Package_Declaration, In_Tree),
1069 while Current /= Empty_Node
1070 and then Name_Of (Current, In_Tree) /= Token_Name
1073 Next_Package_In_Project (Current, In_Tree);
1076 if Current = Empty_Node then
1079 Get_Name_String (Token_Name) &
1080 """ is not a package declared by the project",
1091 Expect (Tok_Semicolon, "`;`");
1092 Set_End_Of_Line (Package_Declaration);
1093 Set_Previous_Line_Node (Package_Declaration);
1095 elsif Token = Tok_Is then
1096 Set_End_Of_Line (Package_Declaration);
1097 Set_Previous_Line_Node (Package_Declaration);
1098 Set_Next_End_Node (Package_Declaration);
1100 Parse_Declarative_Items
1101 (In_Tree => In_Tree,
1102 Declarations => First_Declarative_Item,
1103 In_Zone => In_Package,
1104 First_Attribute => First_Attribute,
1105 Current_Project => Current_Project,
1106 Current_Package => Package_Declaration,
1107 Packages_To_Check => Packages_To_Check);
1109 Set_First_Declarative_Item_Of
1110 (Package_Declaration, In_Tree, To => First_Declarative_Item);
1112 Expect (Tok_End, "END");
1114 if Token = Tok_End then
1121 -- We should have the name of the package after "end"
1123 Expect (Tok_Identifier, "identifier");
1125 if Token = Tok_Identifier
1126 and then Name_Of (Package_Declaration, In_Tree) /= No_Name
1127 and then Token_Name /= Name_Of (Package_Declaration, In_Tree)
1129 Error_Msg_Name_1 := Name_Of (Package_Declaration, In_Tree);
1130 Error_Msg ("expected {", Token_Ptr);
1133 if Token /= Tok_Semicolon then
1135 -- Scan past the package name
1140 Expect (Tok_Semicolon, "`;`");
1141 Remove_Next_End_Node;
1144 Error_Msg ("expected IS or RENAMES", Token_Ptr);
1147 end Parse_Package_Declaration;
1149 -----------------------------------
1150 -- Parse_String_Type_Declaration --
1151 -----------------------------------
1153 procedure Parse_String_Type_Declaration
1154 (In_Tree : Project_Node_Tree_Ref;
1155 String_Type : out Project_Node_Id;
1156 Current_Project : Project_Node_Id)
1158 Current : Project_Node_Id := Empty_Node;
1159 First_String : Project_Node_Id := Empty_Node;
1163 Default_Project_Node
1164 (Of_Kind => N_String_Type_Declaration, In_Tree => In_Tree);
1166 Set_Location_Of (String_Type, In_Tree, To => Token_Ptr);
1172 Expect (Tok_Identifier, "identifier");
1174 if Token = Tok_Identifier then
1175 Set_Name_Of (String_Type, In_Tree, To => Token_Name);
1177 Current := First_String_Type_Of (Current_Project, In_Tree);
1178 while Current /= Empty_Node
1180 Name_Of (Current, In_Tree) /= Token_Name
1182 Current := Next_String_Type (Current, In_Tree);
1185 if Current /= Empty_Node then
1186 Error_Msg ("duplicate string type name """ &
1187 Get_Name_String (Token_Name) &
1191 Current := First_Variable_Of (Current_Project, In_Tree);
1192 while Current /= Empty_Node
1193 and then Name_Of (Current, In_Tree) /= Token_Name
1195 Current := Next_Variable (Current, In_Tree);
1198 if Current /= Empty_Node then
1200 Get_Name_String (Token_Name) &
1201 """ is already a variable name", Token_Ptr);
1203 Set_Next_String_Type
1204 (String_Type, In_Tree,
1205 To => First_String_Type_Of (Current_Project, In_Tree));
1206 Set_First_String_Type_Of
1207 (Current_Project, In_Tree, To => String_Type);
1211 -- Scan past the name
1216 Expect (Tok_Is, "IS");
1218 if Token = Tok_Is then
1222 Expect (Tok_Left_Paren, "`(`");
1224 if Token = Tok_Left_Paren then
1228 Parse_String_Type_List
1229 (In_Tree => In_Tree, First_String => First_String);
1230 Set_First_Literal_String (String_Type, In_Tree, To => First_String);
1232 Expect (Tok_Right_Paren, "`)`");
1234 if Token = Tok_Right_Paren then
1238 end Parse_String_Type_Declaration;
1240 --------------------------------
1241 -- Parse_Variable_Declaration --
1242 --------------------------------
1244 procedure Parse_Variable_Declaration
1245 (In_Tree : Project_Node_Tree_Ref;
1246 Variable : out Project_Node_Id;
1247 Current_Project : Project_Node_Id;
1248 Current_Package : Project_Node_Id)
1250 Expression_Location : Source_Ptr;
1251 String_Type_Name : Name_Id := No_Name;
1252 Project_String_Type_Name : Name_Id := No_Name;
1253 Type_Location : Source_Ptr := No_Location;
1254 Project_Location : Source_Ptr := No_Location;
1255 Expression : Project_Node_Id := Empty_Node;
1256 Variable_Name : constant Name_Id := Token_Name;
1257 OK : Boolean := True;
1261 Default_Project_Node
1262 (Of_Kind => N_Variable_Declaration, In_Tree => In_Tree);
1263 Set_Name_Of (Variable, In_Tree, To => Variable_Name);
1264 Set_Location_Of (Variable, In_Tree, To => Token_Ptr);
1266 -- Scan past the variable name
1270 if Token = Tok_Colon then
1272 -- Typed string variable declaration
1275 Set_Kind_Of (Variable, In_Tree, N_Typed_Variable_Declaration);
1276 Expect (Tok_Identifier, "identifier");
1278 OK := Token = Tok_Identifier;
1281 String_Type_Name := Token_Name;
1282 Type_Location := Token_Ptr;
1285 if Token = Tok_Dot then
1286 Project_String_Type_Name := String_Type_Name;
1287 Project_Location := Type_Location;
1289 -- Scan past the dot
1292 Expect (Tok_Identifier, "identifier");
1294 if Token = Tok_Identifier then
1295 String_Type_Name := Token_Name;
1296 Type_Location := Token_Ptr;
1305 Current : Project_Node_Id :=
1306 First_String_Type_Of (Current_Project, In_Tree);
1309 if Project_String_Type_Name /= No_Name then
1311 The_Project_Name_And_Node : constant
1312 Tree_Private_Part.Project_Name_And_Node :=
1313 Tree_Private_Part.Projects_Htable.Get
1314 (In_Tree.Projects_HT, Project_String_Type_Name);
1316 use Tree_Private_Part;
1319 if The_Project_Name_And_Node =
1320 Tree_Private_Part.No_Project_Name_And_Node
1322 Error_Msg ("unknown project """ &
1324 (Project_String_Type_Name) &
1327 Current := Empty_Node;
1330 First_String_Type_Of
1331 (The_Project_Name_And_Node.Node, In_Tree);
1336 while Current /= Empty_Node
1337 and then Name_Of (Current, In_Tree) /= String_Type_Name
1339 Current := Next_String_Type (Current, In_Tree);
1342 if Current = Empty_Node then
1343 Error_Msg ("unknown string type """ &
1344 Get_Name_String (String_Type_Name) &
1350 (Variable, In_Tree, To => Current);
1357 Expect (Tok_Colon_Equal, "`:=`");
1359 OK := OK and (Token = Tok_Colon_Equal);
1361 if Token = Tok_Colon_Equal then
1365 -- Get the single string or string list value
1367 Expression_Location := Token_Ptr;
1370 (In_Tree => In_Tree,
1371 Expression => Expression,
1372 Current_Project => Current_Project,
1373 Current_Package => Current_Package,
1374 Optional_Index => False);
1375 Set_Expression_Of (Variable, In_Tree, To => Expression);
1377 if Expression /= Empty_Node then
1378 -- A typed string must have a single string value, not a list
1380 if Kind_Of (Variable, In_Tree) = N_Typed_Variable_Declaration
1381 and then Expression_Kind_Of (Expression, In_Tree) = List
1384 ("expression must be a single string", Expression_Location);
1387 Set_Expression_Kind_Of
1389 To => Expression_Kind_Of (Expression, In_Tree));
1394 The_Variable : Project_Node_Id := Empty_Node;
1397 if Current_Package /= Empty_Node then
1398 The_Variable := First_Variable_Of (Current_Package, In_Tree);
1399 elsif Current_Project /= Empty_Node then
1400 The_Variable := First_Variable_Of (Current_Project, In_Tree);
1403 while The_Variable /= Empty_Node
1404 and then Name_Of (The_Variable, In_Tree) /= Variable_Name
1406 The_Variable := Next_Variable (The_Variable, In_Tree);
1409 if The_Variable = Empty_Node then
1410 if Current_Package /= Empty_Node then
1413 To => First_Variable_Of (Current_Package, In_Tree));
1414 Set_First_Variable_Of
1415 (Current_Package, In_Tree, To => Variable);
1417 elsif Current_Project /= Empty_Node then
1420 To => First_Variable_Of (Current_Project, In_Tree));
1421 Set_First_Variable_Of
1422 (Current_Project, In_Tree, To => Variable);
1426 if Expression_Kind_Of (Variable, In_Tree) /= Undefined then
1428 Expression_Kind_Of (The_Variable, In_Tree) = Undefined
1430 Set_Expression_Kind_Of
1431 (The_Variable, In_Tree,
1432 To => Expression_Kind_Of (Variable, In_Tree));
1435 if Expression_Kind_Of (The_Variable, In_Tree) /=
1436 Expression_Kind_Of (Variable, In_Tree)
1438 Error_Msg ("wrong expression kind for variable """ &
1440 (Name_Of (The_Variable, In_Tree)) &
1442 Expression_Location);
1450 end Parse_Variable_Declaration;