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 if not Quiet_Output
then
988 (Name_Of
(Package_Declaration
, In_Tree
)) &
989 """ is not a known package name",
993 -- Set the package declaration to "ignored" so that it is not
994 -- processed by Prj.Proc.Process.
996 Set_Expression_Kind_Of
(Package_Declaration
, In_Tree
, Ignored
);
998 -- Add the unknown package in the list of packages
1000 Add_Unknown_Package
(Token_Name
, Current_Package
);
1002 elsif Current_Package
= Unknown_Package
then
1004 -- Set the package declaration to "ignored" so that it is not
1005 -- processed by Prj.Proc.Process.
1007 Set_Expression_Kind_Of
(Package_Declaration
, In_Tree
, Ignored
);
1010 First_Attribute
:= First_Attribute_Of
(Current_Package
);
1014 (Package_Declaration
, In_Tree
, To
=> Current_Package
);
1017 Current
: Project_Node_Id
:=
1018 First_Package_Of
(Current_Project
, In_Tree
);
1021 while Current
/= Empty_Node
1022 and then Name_Of
(Current
, In_Tree
) /= Token_Name
1024 Current
:= Next_Package_In_Project
(Current
, In_Tree
);
1027 if Current
/= Empty_Node
then
1030 Get_Name_String
(Name_Of
(Package_Declaration
, In_Tree
)) &
1031 """ is declared twice in the same project",
1035 -- Add the package to the project list
1037 Set_Next_Package_In_Project
1038 (Package_Declaration
, In_Tree
,
1039 To
=> First_Package_Of
(Current_Project
, In_Tree
));
1040 Set_First_Package_Of
1041 (Current_Project
, In_Tree
, To
=> Package_Declaration
);
1045 -- Scan past the package name
1050 if Token
= Tok_Renames
then
1051 if In_Configuration
then
1053 ("no package renames in configuration projects", Token_Ptr
);
1056 -- Scan past "renames"
1060 Expect
(Tok_Identifier
, "identifier");
1062 if Token
= Tok_Identifier
then
1064 Project_Name
: constant Name_Id
:= Token_Name
;
1066 Clause
: Project_Node_Id
:=
1067 First_With_Clause_Of
(Current_Project
, In_Tree
);
1068 The_Project
: Project_Node_Id
:= Empty_Node
;
1069 Extended
: constant Project_Node_Id
:=
1071 (Project_Declaration_Of
1072 (Current_Project
, In_Tree
),
1075 while Clause
/= Empty_Node
loop
1076 -- Only non limited imported projects may be used in a
1077 -- renames declaration.
1080 Non_Limited_Project_Node_Of
(Clause
, In_Tree
);
1081 exit when The_Project
/= Empty_Node
1082 and then Name_Of
(The_Project
, In_Tree
) = Project_Name
;
1083 Clause
:= Next_With_Clause_Of
(Clause
, In_Tree
);
1086 if Clause
= Empty_Node
then
1087 -- As we have not found the project in the imports, we check
1088 -- if it's the name of an eventual extended project.
1090 if Extended
/= Empty_Node
1091 and then Name_Of
(Extended
, In_Tree
) = Project_Name
1093 Set_Project_Of_Renamed_Package_Of
1094 (Package_Declaration
, In_Tree
, To
=> Extended
);
1096 Error_Msg_Name_1
:= Project_Name
;
1098 ("% is not an imported or extended project", Token_Ptr
);
1101 Set_Project_Of_Renamed_Package_Of
1102 (Package_Declaration
, In_Tree
, To
=> The_Project
);
1107 Expect
(Tok_Dot
, "`.`");
1109 if Token
= Tok_Dot
then
1111 Expect
(Tok_Identifier
, "identifier");
1113 if Token
= Tok_Identifier
then
1114 if Name_Of
(Package_Declaration
, In_Tree
) /= Token_Name
then
1115 Error_Msg
("not the same package name", Token_Ptr
);
1117 Project_Of_Renamed_Package_Of
1118 (Package_Declaration
, In_Tree
) /= Empty_Node
1121 Current
: Project_Node_Id
:=
1123 (Project_Of_Renamed_Package_Of
1124 (Package_Declaration
, In_Tree
),
1128 while Current
/= Empty_Node
1129 and then Name_Of
(Current
, In_Tree
) /= Token_Name
1132 Next_Package_In_Project
(Current
, In_Tree
);
1135 if Current
= Empty_Node
then
1138 Get_Name_String
(Token_Name
) &
1139 """ is not a package declared by the project",
1150 Expect
(Tok_Semicolon
, "`;`");
1151 Set_End_Of_Line
(Package_Declaration
);
1152 Set_Previous_Line_Node
(Package_Declaration
);
1154 elsif Token
= Tok_Is
then
1155 Set_End_Of_Line
(Package_Declaration
);
1156 Set_Previous_Line_Node
(Package_Declaration
);
1157 Set_Next_End_Node
(Package_Declaration
);
1159 Parse_Declarative_Items
1160 (In_Tree
=> In_Tree
,
1161 Declarations
=> First_Declarative_Item
,
1162 In_Zone
=> In_Package
,
1163 First_Attribute
=> First_Attribute
,
1164 Current_Project
=> Current_Project
,
1165 Current_Package
=> Package_Declaration
,
1166 Packages_To_Check
=> Packages_To_Check
);
1168 Set_First_Declarative_Item_Of
1169 (Package_Declaration
, In_Tree
, To
=> First_Declarative_Item
);
1171 Expect
(Tok_End
, "END");
1173 if Token
= Tok_End
then
1180 -- We should have the name of the package after "end"
1182 Expect
(Tok_Identifier
, "identifier");
1184 if Token
= Tok_Identifier
1185 and then Name_Of
(Package_Declaration
, In_Tree
) /= No_Name
1186 and then Token_Name
/= Name_Of
(Package_Declaration
, In_Tree
)
1188 Error_Msg_Name_1
:= Name_Of
(Package_Declaration
, In_Tree
);
1189 Error_Msg
("expected %%", Token_Ptr
);
1192 if Token
/= Tok_Semicolon
then
1194 -- Scan past the package name
1199 Expect
(Tok_Semicolon
, "`;`");
1200 Remove_Next_End_Node
;
1203 Error_Msg
("expected IS or RENAMES", Token_Ptr
);
1206 end Parse_Package_Declaration
;
1208 -----------------------------------
1209 -- Parse_String_Type_Declaration --
1210 -----------------------------------
1212 procedure Parse_String_Type_Declaration
1213 (In_Tree
: Project_Node_Tree_Ref
;
1214 String_Type
: out Project_Node_Id
;
1215 Current_Project
: Project_Node_Id
)
1217 Current
: Project_Node_Id
:= Empty_Node
;
1218 First_String
: Project_Node_Id
:= Empty_Node
;
1222 Default_Project_Node
1223 (Of_Kind
=> N_String_Type_Declaration
, In_Tree
=> In_Tree
);
1225 Set_Location_Of
(String_Type
, In_Tree
, To
=> Token_Ptr
);
1231 Expect
(Tok_Identifier
, "identifier");
1233 if Token
= Tok_Identifier
then
1234 Set_Name_Of
(String_Type
, In_Tree
, To
=> Token_Name
);
1236 Current
:= First_String_Type_Of
(Current_Project
, In_Tree
);
1237 while Current
/= Empty_Node
1239 Name_Of
(Current
, In_Tree
) /= Token_Name
1241 Current
:= Next_String_Type
(Current
, In_Tree
);
1244 if Current
/= Empty_Node
then
1245 Error_Msg
("duplicate string type name """ &
1246 Get_Name_String
(Token_Name
) &
1250 Current
:= First_Variable_Of
(Current_Project
, In_Tree
);
1251 while Current
/= Empty_Node
1252 and then Name_Of
(Current
, In_Tree
) /= Token_Name
1254 Current
:= Next_Variable
(Current
, In_Tree
);
1257 if Current
/= Empty_Node
then
1259 Get_Name_String
(Token_Name
) &
1260 """ is already a variable name", Token_Ptr
);
1262 Set_Next_String_Type
1263 (String_Type
, In_Tree
,
1264 To
=> First_String_Type_Of
(Current_Project
, In_Tree
));
1265 Set_First_String_Type_Of
1266 (Current_Project
, In_Tree
, To
=> String_Type
);
1270 -- Scan past the name
1275 Expect
(Tok_Is
, "IS");
1277 if Token
= Tok_Is
then
1281 Expect
(Tok_Left_Paren
, "`(`");
1283 if Token
= Tok_Left_Paren
then
1287 Parse_String_Type_List
1288 (In_Tree
=> In_Tree
, First_String
=> First_String
);
1289 Set_First_Literal_String
(String_Type
, In_Tree
, To
=> First_String
);
1291 Expect
(Tok_Right_Paren
, "`)`");
1293 if Token
= Tok_Right_Paren
then
1297 end Parse_String_Type_Declaration
;
1299 --------------------------------
1300 -- Parse_Variable_Declaration --
1301 --------------------------------
1303 procedure Parse_Variable_Declaration
1304 (In_Tree
: Project_Node_Tree_Ref
;
1305 Variable
: out Project_Node_Id
;
1306 Current_Project
: Project_Node_Id
;
1307 Current_Package
: Project_Node_Id
)
1309 Expression_Location
: Source_Ptr
;
1310 String_Type_Name
: Name_Id
:= No_Name
;
1311 Project_String_Type_Name
: Name_Id
:= No_Name
;
1312 Type_Location
: Source_Ptr
:= No_Location
;
1313 Project_Location
: Source_Ptr
:= No_Location
;
1314 Expression
: Project_Node_Id
:= Empty_Node
;
1315 Variable_Name
: constant Name_Id
:= Token_Name
;
1316 OK
: Boolean := True;
1320 Default_Project_Node
1321 (Of_Kind
=> N_Variable_Declaration
, In_Tree
=> In_Tree
);
1322 Set_Name_Of
(Variable
, In_Tree
, To
=> Variable_Name
);
1323 Set_Location_Of
(Variable
, In_Tree
, To
=> Token_Ptr
);
1325 -- Scan past the variable name
1329 if Token
= Tok_Colon
then
1331 -- Typed string variable declaration
1334 Set_Kind_Of
(Variable
, In_Tree
, N_Typed_Variable_Declaration
);
1335 Expect
(Tok_Identifier
, "identifier");
1337 OK
:= Token
= Tok_Identifier
;
1340 String_Type_Name
:= Token_Name
;
1341 Type_Location
:= Token_Ptr
;
1344 if Token
= Tok_Dot
then
1345 Project_String_Type_Name
:= String_Type_Name
;
1346 Project_Location
:= Type_Location
;
1348 -- Scan past the dot
1351 Expect
(Tok_Identifier
, "identifier");
1353 if Token
= Tok_Identifier
then
1354 String_Type_Name
:= Token_Name
;
1355 Type_Location
:= Token_Ptr
;
1364 Current
: Project_Node_Id
:=
1365 First_String_Type_Of
(Current_Project
, In_Tree
);
1368 if Project_String_Type_Name
/= No_Name
then
1370 The_Project_Name_And_Node
: constant
1371 Tree_Private_Part
.Project_Name_And_Node
:=
1372 Tree_Private_Part
.Projects_Htable
.Get
1373 (In_Tree
.Projects_HT
, Project_String_Type_Name
);
1375 use Tree_Private_Part
;
1378 if The_Project_Name_And_Node
=
1379 Tree_Private_Part
.No_Project_Name_And_Node
1381 Error_Msg
("unknown project """ &
1383 (Project_String_Type_Name
) &
1386 Current
:= Empty_Node
;
1389 First_String_Type_Of
1390 (The_Project_Name_And_Node
.Node
, In_Tree
);
1395 while Current
/= Empty_Node
1396 and then Name_Of
(Current
, In_Tree
) /= String_Type_Name
1398 Current
:= Next_String_Type
(Current
, In_Tree
);
1401 if Current
= Empty_Node
then
1402 Error_Msg
("unknown string type """ &
1403 Get_Name_String
(String_Type_Name
) &
1409 (Variable
, In_Tree
, To
=> Current
);
1416 Expect
(Tok_Colon_Equal
, "`:=`");
1418 OK
:= OK
and (Token
= Tok_Colon_Equal
);
1420 if Token
= Tok_Colon_Equal
then
1424 -- Get the single string or string list value
1426 Expression_Location
:= Token_Ptr
;
1429 (In_Tree
=> In_Tree
,
1430 Expression
=> Expression
,
1431 Current_Project
=> Current_Project
,
1432 Current_Package
=> Current_Package
,
1433 Optional_Index
=> False);
1434 Set_Expression_Of
(Variable
, In_Tree
, To
=> Expression
);
1436 if Expression
/= Empty_Node
then
1437 -- A typed string must have a single string value, not a list
1439 if Kind_Of
(Variable
, In_Tree
) = N_Typed_Variable_Declaration
1440 and then Expression_Kind_Of
(Expression
, In_Tree
) = List
1443 ("expression must be a single string", Expression_Location
);
1446 Set_Expression_Kind_Of
1448 To
=> Expression_Kind_Of
(Expression
, In_Tree
));
1453 The_Variable
: Project_Node_Id
:= Empty_Node
;
1456 if Current_Package
/= Empty_Node
then
1457 The_Variable
:= First_Variable_Of
(Current_Package
, In_Tree
);
1458 elsif Current_Project
/= Empty_Node
then
1459 The_Variable
:= First_Variable_Of
(Current_Project
, In_Tree
);
1462 while The_Variable
/= Empty_Node
1463 and then Name_Of
(The_Variable
, In_Tree
) /= Variable_Name
1465 The_Variable
:= Next_Variable
(The_Variable
, In_Tree
);
1468 if The_Variable
= Empty_Node
then
1469 if Current_Package
/= Empty_Node
then
1472 To
=> First_Variable_Of
(Current_Package
, In_Tree
));
1473 Set_First_Variable_Of
1474 (Current_Package
, In_Tree
, To
=> Variable
);
1476 elsif Current_Project
/= Empty_Node
then
1479 To
=> First_Variable_Of
(Current_Project
, In_Tree
));
1480 Set_First_Variable_Of
1481 (Current_Project
, In_Tree
, To
=> Variable
);
1485 if Expression_Kind_Of
(Variable
, In_Tree
) /= Undefined
then
1487 Expression_Kind_Of
(The_Variable
, In_Tree
) = Undefined
1489 Set_Expression_Kind_Of
1490 (The_Variable
, In_Tree
,
1491 To
=> Expression_Kind_Of
(Variable
, In_Tree
));
1494 if Expression_Kind_Of
(The_Variable
, In_Tree
) /=
1495 Expression_Kind_Of
(Variable
, In_Tree
)
1497 Error_Msg
("wrong expression kind for variable """ &
1499 (Name_Of
(The_Variable
, In_Tree
)) &
1501 Expression_Location
);
1509 end Parse_Variable_Declaration
;