1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2006, 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 Ignore
: 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
);
188 -- If not a valid attribute name, issue an error if inside
189 -- a package that need to be checked.
191 Ignore
:= Current_Package
/= Empty_Node
and then
192 Packages_To_Check
/= All_Packages
;
196 -- Check that we are not in a package to check
198 Get_Name_String
(Name_Of
(Current_Package
, In_Tree
));
200 for Index
in Packages_To_Check
'Range loop
201 if Name_Buffer
(1 .. Name_Len
) =
202 Packages_To_Check
(Index
).all
211 Error_Msg_Name_1
:= Token_Name
;
212 Error_Msg
("undefined attribute {", Token_Ptr
);
216 -- Set, if appropriate the index case insensitivity flag
218 elsif Attribute_Kind_Of
(Current_Attribute
) in
219 Case_Insensitive_Associative_Array
..
220 Optional_Index_Case_Insensitive_Associative_Array
222 Set_Case_Insensitive
(Attribute
, In_Tree
, To
=> True);
225 Scan
(In_Tree
); -- past the attribute name
228 -- Change obsolete names of attributes to the new names
230 if Current_Package
/= Empty_Node
231 and then Expression_Kind_Of
(Current_Package
, In_Tree
) /= Ignored
233 case Name_Of
(Attribute
, In_Tree
) is
234 when Snames
.Name_Specification
=>
235 Set_Name_Of
(Attribute
, In_Tree
, To
=> Snames
.Name_Spec
);
237 when Snames
.Name_Specification_Suffix
=>
238 Set_Name_Of
(Attribute
, In_Tree
, To
=> Snames
.Name_Spec_Suffix
);
240 when Snames
.Name_Implementation
=>
241 Set_Name_Of
(Attribute
, In_Tree
, To
=> Snames
.Name_Body
);
243 when Snames
.Name_Implementation_Suffix
=>
244 Set_Name_Of
(Attribute
, In_Tree
, To
=> Snames
.Name_Body_Suffix
);
251 -- Associative array attributes
253 if Token
= Tok_Left_Paren
then
255 -- If the attribute is not an associative array attribute, report
256 -- an error. If this information is still unknown, set the kind
257 -- to Associative_Array.
259 if Current_Attribute
/= Empty_Attribute
260 and then Attribute_Kind_Of
(Current_Attribute
) = Single
262 Error_Msg
("the attribute """ &
264 (Attribute_Name_Of
(Current_Attribute
)) &
265 """ cannot be an associative array",
266 Location_Of
(Attribute
, In_Tree
));
268 elsif Attribute_Kind_Of
(Current_Attribute
) = Unknown
then
269 Set_Attribute_Kind_Of
(Current_Attribute
, To
=> Associative_Array
);
272 Scan
(In_Tree
); -- past the left parenthesis
273 Expect
(Tok_String_Literal
, "literal string");
275 if Token
= Tok_String_Literal
then
276 Set_Associative_Array_Index_Of
(Attribute
, In_Tree
, Token_Name
);
277 Scan
(In_Tree
); -- past the literal string index
279 if Token
= Tok_At
then
280 case Attribute_Kind_Of
(Current_Attribute
) is
281 when Optional_Index_Associative_Array |
282 Optional_Index_Case_Insensitive_Associative_Array
=>
284 Expect
(Tok_Integer_Literal
, "integer literal");
286 if Token
= Tok_Integer_Literal
then
288 -- Set the source index value from given literal
291 Index
: constant Int
:=
292 UI_To_Int
(Int_Literal_Value
);
295 Error_Msg
("index cannot be zero", Token_Ptr
);
298 (Attribute
, In_Tree
, To
=> Index
);
306 Error_Msg
("index not allowed here", Token_Ptr
);
309 if Token
= Tok_Integer_Literal
then
316 Expect
(Tok_Right_Paren
, "`)`");
318 if Token
= Tok_Right_Paren
then
319 Scan
(In_Tree
); -- past the right parenthesis
323 -- If it is an associative array attribute and there are no left
324 -- parenthesis, then this is a full associative array declaration.
325 -- Flag it as such for later processing of its value.
327 if Current_Attribute
/= Empty_Attribute
329 Attribute_Kind_Of
(Current_Attribute
) /= Single
331 if Attribute_Kind_Of
(Current_Attribute
) = Unknown
then
332 Set_Attribute_Kind_Of
(Current_Attribute
, To
=> Single
);
335 Full_Associative_Array
:= True;
340 -- Set the expression kind of the attribute
342 if Current_Attribute
/= Empty_Attribute
then
343 Set_Expression_Kind_Of
344 (Attribute
, In_Tree
, To
=> Variable_Kind_Of
(Current_Attribute
));
345 Optional_Index
:= Optional_Index_Of
(Current_Attribute
);
348 Expect
(Tok_Use
, "USE");
350 if Token
= Tok_Use
then
353 if Full_Associative_Array
then
355 -- Expect <project>'<same_attribute_name>, or
356 -- <project>.<same_package_name>'<same_attribute_name>
359 The_Project
: Project_Node_Id
:= Empty_Node
;
360 -- The node of the project where the associative array is
363 The_Package
: Project_Node_Id
:= Empty_Node
;
364 -- The node of the package where the associative array is
367 Project_Name
: Name_Id
:= No_Name
;
368 -- The name of the project where the associative array is
371 Location
: Source_Ptr
:= No_Location
;
372 -- The location of the project name
375 Expect
(Tok_Identifier
, "identifier");
377 if Token
= Tok_Identifier
then
378 Location
:= Token_Ptr
;
380 -- Find the project node in the imported project or
381 -- in the project being extended.
383 The_Project
:= Imported_Or_Extended_Project_Of
384 (Current_Project
, In_Tree
, Token_Name
);
386 if The_Project
= Empty_Node
then
387 Error_Msg
("unknown project", Location
);
388 Scan
(In_Tree
); -- past the project name
391 Project_Name
:= Token_Name
;
392 Scan
(In_Tree
); -- past the project name
394 -- If this is inside a package, a dot followed by the
395 -- name of the package must followed the project name.
397 if Current_Package
/= Empty_Node
then
398 Expect
(Tok_Dot
, "`.`");
400 if Token
/= Tok_Dot
then
401 The_Project
:= Empty_Node
;
404 Scan
(In_Tree
); -- past the dot
405 Expect
(Tok_Identifier
, "identifier");
407 if Token
/= Tok_Identifier
then
408 The_Project
:= Empty_Node
;
410 -- If it is not the same package name, issue error
413 Token_Name
/= Name_Of
(Current_Package
, In_Tree
)
415 The_Project
:= Empty_Node
;
417 ("not the same package as " &
419 (Name_Of
(Current_Package
, In_Tree
)),
424 First_Package_Of
(The_Project
, In_Tree
);
426 -- Look for the package node
428 while The_Package
/= Empty_Node
430 Name_Of
(The_Package
, In_Tree
) /= Token_Name
433 Next_Package_In_Project
434 (The_Package
, In_Tree
);
437 -- If the package cannot be found in the
438 -- project, issue an error.
440 if The_Package
= Empty_Node
then
441 The_Project
:= Empty_Node
;
442 Error_Msg_Name_2
:= Project_Name
;
443 Error_Msg_Name_1
:= Token_Name
;
445 ("package % not declared in project %",
449 Scan
(In_Tree
); -- past the package name
456 if The_Project
/= Empty_Node
then
458 -- Looking for '<same attribute name>
460 Expect
(Tok_Apostrophe
, "`''`");
462 if Token
/= Tok_Apostrophe
then
463 The_Project
:= Empty_Node
;
466 Scan
(In_Tree
); -- past the apostrophe
467 Expect
(Tok_Identifier
, "identifier");
469 if Token
/= Tok_Identifier
then
470 The_Project
:= Empty_Node
;
473 -- If it is not the same attribute name, issue error
475 if Token_Name
/= Attribute_Name
then
476 The_Project
:= Empty_Node
;
477 Error_Msg_Name_1
:= Attribute_Name
;
478 Error_Msg
("invalid name, should be %", Token_Ptr
);
481 Scan
(In_Tree
); -- past the attribute name
486 if The_Project
= Empty_Node
then
488 -- If there were any problem, set the attribute id to null,
489 -- so that the node will not be recorded.
491 Current_Attribute
:= Empty_Attribute
;
494 -- Set the appropriate field in the node.
495 -- Note that the index and the expression are nil. This
496 -- characterizes full associative array attribute
499 Set_Associative_Project_Of
(Attribute
, In_Tree
, The_Project
);
500 Set_Associative_Package_Of
(Attribute
, In_Tree
, The_Package
);
504 -- Other attribute declarations (not full associative array)
508 Expression_Location
: constant Source_Ptr
:= Token_Ptr
;
509 -- The location of the first token of the expression
511 Expression
: Project_Node_Id
:= Empty_Node
;
512 -- The expression, value for the attribute declaration
515 -- Get the expression value and set it in the attribute node
519 Expression
=> Expression
,
520 Current_Project
=> Current_Project
,
521 Current_Package
=> Current_Package
,
522 Optional_Index
=> Optional_Index
);
523 Set_Expression_Of
(Attribute
, In_Tree
, To
=> Expression
);
525 -- If the expression is legal, but not of the right kind
526 -- for the attribute, issue an error.
528 if Current_Attribute
/= Empty_Attribute
529 and then Expression
/= Empty_Node
530 and then Variable_Kind_Of
(Current_Attribute
) /=
531 Expression_Kind_Of
(Expression
, In_Tree
)
533 if Variable_Kind_Of
(Current_Attribute
) = Undefined
then
536 To
=> Expression_Kind_Of
(Expression
, In_Tree
));
540 ("wrong expression kind for attribute """ &
542 (Attribute_Name_Of
(Current_Attribute
)) &
544 Expression_Location
);
551 -- If the attribute was not recognized, return an empty node.
552 -- It may be that it is not in a package to check, and the node will
553 -- not be added to the tree.
555 if Current_Attribute
= Empty_Attribute
then
556 Attribute
:= Empty_Node
;
559 Set_End_Of_Line
(Attribute
);
560 Set_Previous_Line_Node
(Attribute
);
561 end Parse_Attribute_Declaration
;
563 -----------------------------
564 -- Parse_Case_Construction --
565 -----------------------------
567 procedure Parse_Case_Construction
568 (In_Tree
: Project_Node_Tree_Ref
;
569 Case_Construction
: out Project_Node_Id
;
570 First_Attribute
: Attribute_Node_Id
;
571 Current_Project
: Project_Node_Id
;
572 Current_Package
: Project_Node_Id
;
573 Packages_To_Check
: String_List_Access
)
575 Current_Item
: Project_Node_Id
:= Empty_Node
;
576 Next_Item
: Project_Node_Id
:= Empty_Node
;
577 First_Case_Item
: Boolean := True;
579 Variable_Location
: Source_Ptr
:= No_Location
;
581 String_Type
: Project_Node_Id
:= Empty_Node
;
583 Case_Variable
: Project_Node_Id
:= Empty_Node
;
585 First_Declarative_Item
: Project_Node_Id
:= Empty_Node
;
587 First_Choice
: Project_Node_Id
:= Empty_Node
;
589 When_Others
: Boolean := False;
590 -- Set to True when there is a "when others =>" clause
595 (Of_Kind
=> N_Case_Construction
, In_Tree
=> In_Tree
);
596 Set_Location_Of
(Case_Construction
, In_Tree
, To
=> Token_Ptr
);
602 -- Get the switch variable
604 Expect
(Tok_Identifier
, "identifier");
606 if Token
= Tok_Identifier
then
607 Variable_Location
:= Token_Ptr
;
608 Parse_Variable_Reference
610 Variable
=> Case_Variable
,
611 Current_Project
=> Current_Project
,
612 Current_Package
=> Current_Package
);
613 Set_Case_Variable_Reference_Of
614 (Case_Construction
, In_Tree
, To
=> Case_Variable
);
617 if Token
/= Tok_Is
then
622 if Case_Variable
/= Empty_Node
then
623 String_Type
:= String_Type_Of
(Case_Variable
, In_Tree
);
625 if String_Type
= Empty_Node
then
626 Error_Msg
("variable """ &
627 Get_Name_String
(Name_Of
(Case_Variable
, In_Tree
)) &
633 Expect
(Tok_Is
, "IS");
635 if Token
= Tok_Is
then
636 Set_End_Of_Line
(Case_Construction
);
637 Set_Previous_Line_Node
(Case_Construction
);
638 Set_Next_End_Node
(Case_Construction
);
645 Start_New_Case_Construction
(In_Tree
, String_Type
);
649 while Token
= Tok_When
loop
651 if First_Case_Item
then
654 (Of_Kind
=> N_Case_Item
, In_Tree
=> In_Tree
);
655 Set_First_Case_Item_Of
656 (Case_Construction
, In_Tree
, To
=> Current_Item
);
657 First_Case_Item
:= False;
662 (Of_Kind
=> N_Case_Item
, In_Tree
=> In_Tree
);
663 Set_Next_Case_Item
(Current_Item
, In_Tree
, To
=> Next_Item
);
664 Current_Item
:= Next_Item
;
667 Set_Location_Of
(Current_Item
, In_Tree
, To
=> Token_Ptr
);
673 if Token
= Tok_Others
then
676 -- Scan past "others"
680 Expect
(Tok_Arrow
, "`=>`");
681 Set_End_Of_Line
(Current_Item
);
682 Set_Previous_Line_Node
(Current_Item
);
684 -- Empty_Node in Field1 of a Case_Item indicates
685 -- the "when others =>" branch.
687 Set_First_Choice_Of
(Current_Item
, In_Tree
, To
=> Empty_Node
);
689 Parse_Declarative_Items
691 Declarations
=> First_Declarative_Item
,
692 In_Zone
=> In_Case_Construction
,
693 First_Attribute
=> First_Attribute
,
694 Current_Project
=> Current_Project
,
695 Current_Package
=> Current_Package
,
696 Packages_To_Check
=> Packages_To_Check
);
698 -- "when others =>" must be the last branch, so save the
699 -- Case_Item and exit
701 Set_First_Declarative_Item_Of
702 (Current_Item
, In_Tree
, To
=> First_Declarative_Item
);
708 First_Choice
=> First_Choice
);
709 Set_First_Choice_Of
(Current_Item
, In_Tree
, To
=> First_Choice
);
711 Expect
(Tok_Arrow
, "`=>`");
712 Set_End_Of_Line
(Current_Item
);
713 Set_Previous_Line_Node
(Current_Item
);
715 Parse_Declarative_Items
717 Declarations
=> First_Declarative_Item
,
718 In_Zone
=> In_Case_Construction
,
719 First_Attribute
=> First_Attribute
,
720 Current_Project
=> Current_Project
,
721 Current_Package
=> Current_Package
,
722 Packages_To_Check
=> Packages_To_Check
);
724 Set_First_Declarative_Item_Of
725 (Current_Item
, In_Tree
, To
=> First_Declarative_Item
);
730 End_Case_Construction
731 (Check_All_Labels
=> not When_Others
and not Quiet_Output
,
732 Case_Location
=> Location_Of
(Case_Construction
, In_Tree
));
734 Expect
(Tok_End
, "`END CASE`");
735 Remove_Next_End_Node
;
737 if Token
= Tok_End
then
743 Expect
(Tok_Case
, "CASE");
751 Expect
(Tok_Semicolon
, "`;`");
752 Set_Previous_End_Node
(Case_Construction
);
754 end Parse_Case_Construction
;
756 -----------------------------
757 -- Parse_Declarative_Items --
758 -----------------------------
760 procedure Parse_Declarative_Items
761 (In_Tree
: Project_Node_Tree_Ref
;
762 Declarations
: out Project_Node_Id
;
764 First_Attribute
: Attribute_Node_Id
;
765 Current_Project
: Project_Node_Id
;
766 Current_Package
: Project_Node_Id
;
767 Packages_To_Check
: String_List_Access
)
769 Current_Declarative_Item
: Project_Node_Id
:= Empty_Node
;
770 Next_Declarative_Item
: Project_Node_Id
:= Empty_Node
;
771 Current_Declaration
: Project_Node_Id
:= Empty_Node
;
772 Item_Location
: Source_Ptr
:= No_Location
;
775 Declarations
:= Empty_Node
;
778 -- We are always positioned at the token that precedes
779 -- the first token of the declarative element.
784 Item_Location
:= Token_Ptr
;
787 when Tok_Identifier
=>
789 if In_Zone
= In_Case_Construction
then
790 Error_Msg
("a variable cannot be declared here",
794 Parse_Variable_Declaration
797 Current_Project
=> Current_Project
,
798 Current_Package
=> Current_Package
);
800 Set_End_Of_Line
(Current_Declaration
);
801 Set_Previous_Line_Node
(Current_Declaration
);
805 Parse_Attribute_Declaration
807 Attribute
=> Current_Declaration
,
808 First_Attribute
=> First_Attribute
,
809 Current_Project
=> Current_Project
,
810 Current_Package
=> Current_Package
,
811 Packages_To_Check
=> Packages_To_Check
);
813 Set_End_Of_Line
(Current_Declaration
);
814 Set_Previous_Line_Node
(Current_Declaration
);
818 Scan
(In_Tree
); -- past "null"
822 -- Package declaration
824 if In_Zone
/= In_Project
then
825 Error_Msg
("a package cannot be declared here", Token_Ptr
);
828 Parse_Package_Declaration
830 Package_Declaration
=> Current_Declaration
,
831 Current_Project
=> Current_Project
,
832 Packages_To_Check
=> Packages_To_Check
);
834 Set_Previous_End_Node
(Current_Declaration
);
838 -- Type String Declaration
840 if In_Zone
/= In_Project
then
841 Error_Msg
("a string type cannot be declared here",
845 Parse_String_Type_Declaration
847 String_Type
=> Current_Declaration
,
848 Current_Project
=> Current_Project
);
850 Set_End_Of_Line
(Current_Declaration
);
851 Set_Previous_Line_Node
(Current_Declaration
);
857 Parse_Case_Construction
859 Case_Construction
=> Current_Declaration
,
860 First_Attribute
=> First_Attribute
,
861 Current_Project
=> Current_Project
,
862 Current_Package
=> Current_Package
,
863 Packages_To_Check
=> Packages_To_Check
);
865 Set_Previous_End_Node
(Current_Declaration
);
870 -- We are leaving Parse_Declarative_Items positionned
871 -- at the first token after the list of declarative items.
872 -- It could be "end" (for a project, a package declaration or
873 -- a case construction) or "when" (for a case construction)
877 Expect
(Tok_Semicolon
, "`;` after declarative items");
879 -- Insert an N_Declarative_Item in the tree, but only if
880 -- Current_Declaration is not an empty node.
882 if Current_Declaration
/= Empty_Node
then
883 if Current_Declarative_Item
= Empty_Node
then
884 Current_Declarative_Item
:=
886 (Of_Kind
=> N_Declarative_Item
, In_Tree
=> In_Tree
);
887 Declarations
:= Current_Declarative_Item
;
890 Next_Declarative_Item
:=
892 (Of_Kind
=> N_Declarative_Item
, In_Tree
=> In_Tree
);
893 Set_Next_Declarative_Item
894 (Current_Declarative_Item
, In_Tree
,
895 To
=> Next_Declarative_Item
);
896 Current_Declarative_Item
:= Next_Declarative_Item
;
899 Set_Current_Item_Node
900 (Current_Declarative_Item
, In_Tree
,
901 To
=> Current_Declaration
);
903 (Current_Declarative_Item
, In_Tree
, To
=> Item_Location
);
906 end Parse_Declarative_Items
;
908 -------------------------------
909 -- Parse_Package_Declaration --
910 -------------------------------
912 procedure Parse_Package_Declaration
913 (In_Tree
: Project_Node_Tree_Ref
;
914 Package_Declaration
: out Project_Node_Id
;
915 Current_Project
: Project_Node_Id
;
916 Packages_To_Check
: String_List_Access
)
918 First_Attribute
: Attribute_Node_Id
:= Empty_Attribute
;
919 Current_Package
: Package_Node_Id
:= Empty_Package
;
920 First_Declarative_Item
: Project_Node_Id
:= Empty_Node
;
922 Package_Location
: constant Source_Ptr
:= Token_Ptr
;
925 Package_Declaration
:=
927 (Of_Kind
=> N_Package_Declaration
, In_Tree
=> In_Tree
);
928 Set_Location_Of
(Package_Declaration
, In_Tree
, To
=> Package_Location
);
930 -- Scan past "package"
933 Expect
(Tok_Identifier
, "identifier");
935 if Token
= Tok_Identifier
then
936 Set_Name_Of
(Package_Declaration
, In_Tree
, To
=> Token_Name
);
938 Current_Package
:= Package_Node_Id_Of
(Token_Name
);
940 if Current_Package
/= Empty_Package
then
941 First_Attribute
:= First_Attribute_Of
(Current_Package
);
944 if not Quiet_Output
then
947 (Name_Of
(Package_Declaration
, In_Tree
)) &
948 """ is not a known package name",
952 -- Set the package declaration to "ignored" so that it is not
953 -- processed by Prj.Proc.Process.
955 Set_Expression_Kind_Of
(Package_Declaration
, In_Tree
, Ignored
);
957 -- Add the unknown package in the list of packages
959 Add_Unknown_Package
(Token_Name
, Current_Package
);
963 (Package_Declaration
, In_Tree
, To
=> Current_Package
);
966 Current
: Project_Node_Id
:=
967 First_Package_Of
(Current_Project
, In_Tree
);
970 while Current
/= Empty_Node
971 and then Name_Of
(Current
, In_Tree
) /= Token_Name
973 Current
:= Next_Package_In_Project
(Current
, In_Tree
);
976 if Current
/= Empty_Node
then
979 Get_Name_String
(Name_Of
(Package_Declaration
, In_Tree
)) &
980 """ is declared twice in the same project",
984 -- Add the package to the project list
986 Set_Next_Package_In_Project
987 (Package_Declaration
, In_Tree
,
988 To
=> First_Package_Of
(Current_Project
, In_Tree
));
990 (Current_Project
, In_Tree
, To
=> Package_Declaration
);
994 -- Scan past the package name
999 if Token
= Tok_Renames
then
1001 -- Scan past "renames"
1005 Expect
(Tok_Identifier
, "identifier");
1007 if Token
= Tok_Identifier
then
1009 Project_Name
: constant Name_Id
:= Token_Name
;
1011 Clause
: Project_Node_Id
:=
1012 First_With_Clause_Of
(Current_Project
, In_Tree
);
1013 The_Project
: Project_Node_Id
:= Empty_Node
;
1014 Extended
: constant Project_Node_Id
:=
1016 (Project_Declaration_Of
1017 (Current_Project
, In_Tree
),
1020 while Clause
/= Empty_Node
loop
1021 -- Only non limited imported projects may be used in a
1022 -- renames declaration.
1025 Non_Limited_Project_Node_Of
(Clause
, In_Tree
);
1026 exit when The_Project
/= Empty_Node
1027 and then Name_Of
(The_Project
, In_Tree
) = Project_Name
;
1028 Clause
:= Next_With_Clause_Of
(Clause
, In_Tree
);
1031 if Clause
= Empty_Node
then
1032 -- As we have not found the project in the imports, we check
1033 -- if it's the name of an eventual extended project.
1035 if Extended
/= Empty_Node
1036 and then Name_Of
(Extended
, In_Tree
) = Project_Name
1038 Set_Project_Of_Renamed_Package_Of
1039 (Package_Declaration
, In_Tree
, To
=> Extended
);
1041 Error_Msg_Name_1
:= Project_Name
;
1043 ("% is not an imported or extended project", Token_Ptr
);
1046 Set_Project_Of_Renamed_Package_Of
1047 (Package_Declaration
, In_Tree
, To
=> The_Project
);
1052 Expect
(Tok_Dot
, "`.`");
1054 if Token
= Tok_Dot
then
1056 Expect
(Tok_Identifier
, "identifier");
1058 if Token
= Tok_Identifier
then
1059 if Name_Of
(Package_Declaration
, In_Tree
) /= Token_Name
then
1060 Error_Msg
("not the same package name", Token_Ptr
);
1062 Project_Of_Renamed_Package_Of
1063 (Package_Declaration
, In_Tree
) /= Empty_Node
1066 Current
: Project_Node_Id
:=
1068 (Project_Of_Renamed_Package_Of
1069 (Package_Declaration
, In_Tree
),
1073 while Current
/= Empty_Node
1074 and then Name_Of
(Current
, In_Tree
) /= Token_Name
1077 Next_Package_In_Project
(Current
, In_Tree
);
1080 if Current
= Empty_Node
then
1083 Get_Name_String
(Token_Name
) &
1084 """ is not a package declared by the project",
1095 Expect
(Tok_Semicolon
, "`;`");
1096 Set_End_Of_Line
(Package_Declaration
);
1097 Set_Previous_Line_Node
(Package_Declaration
);
1099 elsif Token
= Tok_Is
then
1100 Set_End_Of_Line
(Package_Declaration
);
1101 Set_Previous_Line_Node
(Package_Declaration
);
1102 Set_Next_End_Node
(Package_Declaration
);
1104 Parse_Declarative_Items
1105 (In_Tree
=> In_Tree
,
1106 Declarations
=> First_Declarative_Item
,
1107 In_Zone
=> In_Package
,
1108 First_Attribute
=> First_Attribute
,
1109 Current_Project
=> Current_Project
,
1110 Current_Package
=> Package_Declaration
,
1111 Packages_To_Check
=> Packages_To_Check
);
1113 Set_First_Declarative_Item_Of
1114 (Package_Declaration
, In_Tree
, To
=> First_Declarative_Item
);
1116 Expect
(Tok_End
, "END");
1118 if Token
= Tok_End
then
1125 -- We should have the name of the package after "end"
1127 Expect
(Tok_Identifier
, "identifier");
1129 if Token
= Tok_Identifier
1130 and then Name_Of
(Package_Declaration
, In_Tree
) /= No_Name
1131 and then Token_Name
/= Name_Of
(Package_Declaration
, In_Tree
)
1133 Error_Msg_Name_1
:= Name_Of
(Package_Declaration
, In_Tree
);
1134 Error_Msg
("expected {", Token_Ptr
);
1137 if Token
/= Tok_Semicolon
then
1139 -- Scan past the package name
1144 Expect
(Tok_Semicolon
, "`;`");
1145 Remove_Next_End_Node
;
1148 Error_Msg
("expected IS or RENAMES", Token_Ptr
);
1151 end Parse_Package_Declaration
;
1153 -----------------------------------
1154 -- Parse_String_Type_Declaration --
1155 -----------------------------------
1157 procedure Parse_String_Type_Declaration
1158 (In_Tree
: Project_Node_Tree_Ref
;
1159 String_Type
: out Project_Node_Id
;
1160 Current_Project
: Project_Node_Id
)
1162 Current
: Project_Node_Id
:= Empty_Node
;
1163 First_String
: Project_Node_Id
:= Empty_Node
;
1167 Default_Project_Node
1168 (Of_Kind
=> N_String_Type_Declaration
, In_Tree
=> In_Tree
);
1170 Set_Location_Of
(String_Type
, In_Tree
, To
=> Token_Ptr
);
1176 Expect
(Tok_Identifier
, "identifier");
1178 if Token
= Tok_Identifier
then
1179 Set_Name_Of
(String_Type
, In_Tree
, To
=> Token_Name
);
1181 Current
:= First_String_Type_Of
(Current_Project
, In_Tree
);
1182 while Current
/= Empty_Node
1184 Name_Of
(Current
, In_Tree
) /= Token_Name
1186 Current
:= Next_String_Type
(Current
, In_Tree
);
1189 if Current
/= Empty_Node
then
1190 Error_Msg
("duplicate string type name """ &
1191 Get_Name_String
(Token_Name
) &
1195 Current
:= First_Variable_Of
(Current_Project
, In_Tree
);
1196 while Current
/= Empty_Node
1197 and then Name_Of
(Current
, In_Tree
) /= Token_Name
1199 Current
:= Next_Variable
(Current
, In_Tree
);
1202 if Current
/= Empty_Node
then
1204 Get_Name_String
(Token_Name
) &
1205 """ is already a variable name", Token_Ptr
);
1207 Set_Next_String_Type
1208 (String_Type
, In_Tree
,
1209 To
=> First_String_Type_Of
(Current_Project
, In_Tree
));
1210 Set_First_String_Type_Of
1211 (Current_Project
, In_Tree
, To
=> String_Type
);
1215 -- Scan past the name
1220 Expect
(Tok_Is
, "IS");
1222 if Token
= Tok_Is
then
1226 Expect
(Tok_Left_Paren
, "`(`");
1228 if Token
= Tok_Left_Paren
then
1232 Parse_String_Type_List
1233 (In_Tree
=> In_Tree
, First_String
=> First_String
);
1234 Set_First_Literal_String
(String_Type
, In_Tree
, To
=> First_String
);
1236 Expect
(Tok_Right_Paren
, "`)`");
1238 if Token
= Tok_Right_Paren
then
1242 end Parse_String_Type_Declaration
;
1244 --------------------------------
1245 -- Parse_Variable_Declaration --
1246 --------------------------------
1248 procedure Parse_Variable_Declaration
1249 (In_Tree
: Project_Node_Tree_Ref
;
1250 Variable
: out Project_Node_Id
;
1251 Current_Project
: Project_Node_Id
;
1252 Current_Package
: Project_Node_Id
)
1254 Expression_Location
: Source_Ptr
;
1255 String_Type_Name
: Name_Id
:= No_Name
;
1256 Project_String_Type_Name
: Name_Id
:= No_Name
;
1257 Type_Location
: Source_Ptr
:= No_Location
;
1258 Project_Location
: Source_Ptr
:= No_Location
;
1259 Expression
: Project_Node_Id
:= Empty_Node
;
1260 Variable_Name
: constant Name_Id
:= Token_Name
;
1261 OK
: Boolean := True;
1265 Default_Project_Node
1266 (Of_Kind
=> N_Variable_Declaration
, In_Tree
=> In_Tree
);
1267 Set_Name_Of
(Variable
, In_Tree
, To
=> Variable_Name
);
1268 Set_Location_Of
(Variable
, In_Tree
, To
=> Token_Ptr
);
1270 -- Scan past the variable name
1274 if Token
= Tok_Colon
then
1276 -- Typed string variable declaration
1279 Set_Kind_Of
(Variable
, In_Tree
, N_Typed_Variable_Declaration
);
1280 Expect
(Tok_Identifier
, "identifier");
1282 OK
:= Token
= Tok_Identifier
;
1285 String_Type_Name
:= Token_Name
;
1286 Type_Location
:= Token_Ptr
;
1289 if Token
= Tok_Dot
then
1290 Project_String_Type_Name
:= String_Type_Name
;
1291 Project_Location
:= Type_Location
;
1293 -- Scan past the dot
1296 Expect
(Tok_Identifier
, "identifier");
1298 if Token
= Tok_Identifier
then
1299 String_Type_Name
:= Token_Name
;
1300 Type_Location
:= Token_Ptr
;
1309 Current
: Project_Node_Id
:=
1310 First_String_Type_Of
(Current_Project
, In_Tree
);
1313 if Project_String_Type_Name
/= No_Name
then
1315 The_Project_Name_And_Node
: constant
1316 Tree_Private_Part
.Project_Name_And_Node
:=
1317 Tree_Private_Part
.Projects_Htable
.Get
1318 (In_Tree
.Projects_HT
, Project_String_Type_Name
);
1320 use Tree_Private_Part
;
1323 if The_Project_Name_And_Node
=
1324 Tree_Private_Part
.No_Project_Name_And_Node
1326 Error_Msg
("unknown project """ &
1328 (Project_String_Type_Name
) &
1331 Current
:= Empty_Node
;
1334 First_String_Type_Of
1335 (The_Project_Name_And_Node
.Node
, In_Tree
);
1340 while Current
/= Empty_Node
1341 and then Name_Of
(Current
, In_Tree
) /= String_Type_Name
1343 Current
:= Next_String_Type
(Current
, In_Tree
);
1346 if Current
= Empty_Node
then
1347 Error_Msg
("unknown string type """ &
1348 Get_Name_String
(String_Type_Name
) &
1354 (Variable
, In_Tree
, To
=> Current
);
1361 Expect
(Tok_Colon_Equal
, "`:=`");
1363 OK
:= OK
and (Token
= Tok_Colon_Equal
);
1365 if Token
= Tok_Colon_Equal
then
1369 -- Get the single string or string list value
1371 Expression_Location
:= Token_Ptr
;
1374 (In_Tree
=> In_Tree
,
1375 Expression
=> Expression
,
1376 Current_Project
=> Current_Project
,
1377 Current_Package
=> Current_Package
,
1378 Optional_Index
=> False);
1379 Set_Expression_Of
(Variable
, In_Tree
, To
=> Expression
);
1381 if Expression
/= Empty_Node
then
1382 -- A typed string must have a single string value, not a list
1384 if Kind_Of
(Variable
, In_Tree
) = N_Typed_Variable_Declaration
1385 and then Expression_Kind_Of
(Expression
, In_Tree
) = List
1388 ("expression must be a single string", Expression_Location
);
1391 Set_Expression_Kind_Of
1393 To
=> Expression_Kind_Of
(Expression
, In_Tree
));
1398 The_Variable
: Project_Node_Id
:= Empty_Node
;
1401 if Current_Package
/= Empty_Node
then
1402 The_Variable
:= First_Variable_Of
(Current_Package
, In_Tree
);
1403 elsif Current_Project
/= Empty_Node
then
1404 The_Variable
:= First_Variable_Of
(Current_Project
, In_Tree
);
1407 while The_Variable
/= Empty_Node
1408 and then Name_Of
(The_Variable
, In_Tree
) /= Variable_Name
1410 The_Variable
:= Next_Variable
(The_Variable
, In_Tree
);
1413 if The_Variable
= Empty_Node
then
1414 if Current_Package
/= Empty_Node
then
1417 To
=> First_Variable_Of
(Current_Package
, In_Tree
));
1418 Set_First_Variable_Of
1419 (Current_Package
, In_Tree
, To
=> Variable
);
1421 elsif Current_Project
/= Empty_Node
then
1424 To
=> First_Variable_Of
(Current_Project
, In_Tree
));
1425 Set_First_Variable_Of
1426 (Current_Project
, In_Tree
, To
=> Variable
);
1430 if Expression_Kind_Of
(Variable
, In_Tree
) /= Undefined
then
1432 Expression_Kind_Of
(The_Variable
, In_Tree
) = Undefined
1434 Set_Expression_Kind_Of
1435 (The_Variable
, In_Tree
,
1436 To
=> Expression_Kind_Of
(Variable
, In_Tree
));
1439 if Expression_Kind_Of
(The_Variable
, In_Tree
) /=
1440 Expression_Kind_Of
(Variable
, In_Tree
)
1442 Error_Msg
("wrong expression kind for variable """ &
1444 (Name_Of
(The_Variable
, In_Tree
)) &
1446 Expression_Location
);
1454 end Parse_Variable_Declaration
;