1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2013, 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 Prj
.Attr
; use Prj
.Attr
;
29 with Prj
.Attr
.PM
; use Prj
.Attr
.PM
;
30 with Prj
.Err
; use Prj
.Err
;
31 with Prj
.Strt
; use Prj
.Strt
;
32 with Prj
.Tree
; use Prj
.Tree
;
34 with Uintp
; use Uintp
;
37 with GNAT
.Case_Util
; use GNAT
.Case_Util
;
38 with GNAT
.Spelling_Checker
; use GNAT
.Spelling_Checker
;
41 package body Prj
.Dect
is
43 type Zone
is (In_Project
, In_Package
, In_Case_Construction
);
44 -- Used to indicate if we are parsing a package (In_Package), a case
45 -- construction (In_Case_Construction) or none of those two (In_Project).
47 procedure Rename_Obsolescent_Attributes
48 (In_Tree
: Project_Node_Tree_Ref
;
49 Attribute
: Project_Node_Id
;
50 Current_Package
: Project_Node_Id
);
51 -- Rename obsolescent attributes in the tree. When the attribute has been
52 -- renamed since its initial introduction in the design of projects, we
53 -- replace the old name in the tree with the new name, so that the code
54 -- does not have to check both names forever.
56 procedure Check_Attribute_Allowed
57 (In_Tree
: Project_Node_Tree_Ref
;
58 Project
: Project_Node_Id
;
59 Attribute
: Project_Node_Id
;
60 Flags
: Processing_Flags
);
61 -- Check whether the attribute is valid in this project. In particular,
62 -- depending on the type of project (qualifier), some attributes might
65 procedure Check_Package_Allowed
66 (In_Tree
: Project_Node_Tree_Ref
;
67 Project
: Project_Node_Id
;
68 Current_Package
: Project_Node_Id
;
69 Flags
: Processing_Flags
);
70 -- Check whether the package is valid in this project
72 procedure Parse_Attribute_Declaration
73 (In_Tree
: Project_Node_Tree_Ref
;
74 Attribute
: out Project_Node_Id
;
75 First_Attribute
: Attribute_Node_Id
;
76 Current_Project
: Project_Node_Id
;
77 Current_Package
: Project_Node_Id
;
78 Packages_To_Check
: String_List_Access
;
79 Flags
: Processing_Flags
);
80 -- Parse an attribute declaration
82 procedure Parse_Case_Construction
83 (In_Tree
: Project_Node_Tree_Ref
;
84 Case_Construction
: out Project_Node_Id
;
85 First_Attribute
: Attribute_Node_Id
;
86 Current_Project
: Project_Node_Id
;
87 Current_Package
: Project_Node_Id
;
88 Packages_To_Check
: String_List_Access
;
89 Is_Config_File
: Boolean;
90 Flags
: Processing_Flags
);
91 -- Parse a case construction
93 procedure Parse_Declarative_Items
94 (In_Tree
: Project_Node_Tree_Ref
;
95 Declarations
: out Project_Node_Id
;
97 First_Attribute
: Attribute_Node_Id
;
98 Current_Project
: Project_Node_Id
;
99 Current_Package
: Project_Node_Id
;
100 Packages_To_Check
: String_List_Access
;
101 Is_Config_File
: Boolean;
102 Flags
: Processing_Flags
);
103 -- Parse declarative items. Depending on In_Zone, some declarative items
104 -- may be forbidden. Is_Config_File should be set to True if the project
105 -- represents a config file (.cgpr) since some specific checks apply.
107 procedure Parse_Package_Declaration
108 (In_Tree
: Project_Node_Tree_Ref
;
109 Package_Declaration
: out Project_Node_Id
;
110 Current_Project
: Project_Node_Id
;
111 Packages_To_Check
: String_List_Access
;
112 Is_Config_File
: Boolean;
113 Flags
: Processing_Flags
);
114 -- Parse a package declaration.
115 -- Is_Config_File should be set to True if the project represents a config
116 -- file (.cgpr) since some specific checks apply.
118 procedure Parse_String_Type_Declaration
119 (In_Tree
: Project_Node_Tree_Ref
;
120 String_Type
: out Project_Node_Id
;
121 Current_Project
: Project_Node_Id
;
122 Flags
: Processing_Flags
);
123 -- type <name> is ( <literal_string> { , <literal_string> } ) ;
125 procedure Parse_Variable_Declaration
126 (In_Tree
: Project_Node_Tree_Ref
;
127 Variable
: out Project_Node_Id
;
128 Current_Project
: Project_Node_Id
;
129 Current_Package
: Project_Node_Id
;
130 Flags
: Processing_Flags
);
131 -- Parse a variable assignment
132 -- <variable_Name> := <expression>; OR
133 -- <variable_Name> : <string_type_Name> := <string_expression>;
140 (In_Tree
: Project_Node_Tree_Ref
;
141 Declarations
: out Project_Node_Id
;
142 Current_Project
: Project_Node_Id
;
143 Extends
: Project_Node_Id
;
144 Packages_To_Check
: String_List_Access
;
145 Is_Config_File
: Boolean;
146 Flags
: Processing_Flags
)
148 First_Declarative_Item
: Project_Node_Id
:= Empty_Node
;
153 (Of_Kind
=> N_Project_Declaration
, In_Tree
=> In_Tree
);
154 Set_Location_Of
(Declarations
, In_Tree
, To
=> Token_Ptr
);
155 Set_Extended_Project_Of
(Declarations
, In_Tree
, To
=> Extends
);
156 Set_Project_Declaration_Of
(Current_Project
, In_Tree
, Declarations
);
157 Parse_Declarative_Items
158 (Declarations
=> First_Declarative_Item
,
160 In_Zone
=> In_Project
,
161 First_Attribute
=> Prj
.Attr
.Attribute_First
,
162 Current_Project
=> Current_Project
,
163 Current_Package
=> Empty_Node
,
164 Packages_To_Check
=> Packages_To_Check
,
165 Is_Config_File
=> Is_Config_File
,
167 Set_First_Declarative_Item_Of
168 (Declarations
, In_Tree
, To
=> First_Declarative_Item
);
171 -----------------------------------
172 -- Rename_Obsolescent_Attributes --
173 -----------------------------------
175 procedure Rename_Obsolescent_Attributes
176 (In_Tree
: Project_Node_Tree_Ref
;
177 Attribute
: Project_Node_Id
;
178 Current_Package
: Project_Node_Id
)
181 if Present
(Current_Package
)
182 and then Expression_Kind_Of
(Current_Package
, In_Tree
) /= Ignored
184 case Name_Of
(Attribute
, In_Tree
) is
185 when Snames
.Name_Specification
=>
186 Set_Name_Of
(Attribute
, In_Tree
, To
=> Snames
.Name_Spec
);
188 when Snames
.Name_Specification_Suffix
=>
189 Set_Name_Of
(Attribute
, In_Tree
, To
=> Snames
.Name_Spec_Suffix
);
191 when Snames
.Name_Implementation
=>
192 Set_Name_Of
(Attribute
, In_Tree
, To
=> Snames
.Name_Body
);
194 when Snames
.Name_Implementation_Suffix
=>
195 Set_Name_Of
(Attribute
, In_Tree
, To
=> Snames
.Name_Body_Suffix
);
201 end Rename_Obsolescent_Attributes
;
203 ---------------------------
204 -- Check_Package_Allowed --
205 ---------------------------
207 procedure Check_Package_Allowed
208 (In_Tree
: Project_Node_Tree_Ref
;
209 Project
: Project_Node_Id
;
210 Current_Package
: Project_Node_Id
;
211 Flags
: Processing_Flags
)
213 Qualif
: constant Project_Qualifier
:=
214 Project_Qualifier_Of
(Project
, In_Tree
);
215 Name
: constant Name_Id
:= Name_Of
(Current_Package
, In_Tree
);
217 if Qualif
in Aggregate_Project
218 and then Name
/= Snames
.Name_Builder
220 Error_Msg_Name_1
:= Name
;
223 "package %% is forbidden in aggregate projects",
224 Location_Of
(Current_Package
, In_Tree
));
226 end Check_Package_Allowed
;
228 -----------------------------
229 -- Check_Attribute_Allowed --
230 -----------------------------
232 procedure Check_Attribute_Allowed
233 (In_Tree
: Project_Node_Tree_Ref
;
234 Project
: Project_Node_Id
;
235 Attribute
: Project_Node_Id
;
236 Flags
: Processing_Flags
)
238 Qualif
: constant Project_Qualifier
:=
239 Project_Qualifier_Of
(Project
, In_Tree
);
240 Name
: constant Name_Id
:= Name_Of
(Attribute
, In_Tree
);
244 when Aggregate | Aggregate_Library
=>
245 if Name
= Snames
.Name_Languages
246 or else Name
= Snames
.Name_Source_Files
247 or else Name
= Snames
.Name_Source_List_File
248 or else Name
= Snames
.Name_Locally_Removed_Files
249 or else Name
= Snames
.Name_Excluded_Source_Files
250 or else Name
= Snames
.Name_Excluded_Source_List_File
251 or else Name
= Snames
.Name_Interfaces
252 or else Name
= Snames
.Name_Object_Dir
253 or else Name
= Snames
.Name_Exec_Dir
254 or else Name
= Snames
.Name_Source_Dirs
255 or else Name
= Snames
.Name_Inherit_Source_Path
257 (Qualif
= Aggregate
and then Name
= Snames
.Name_Library_Dir
)
259 (Qualif
= Aggregate
and then Name
= Snames
.Name_Library_Name
)
260 or else Name
= Snames
.Name_Main
261 or else Name
= Snames
.Name_Roots
262 or else Name
= Snames
.Name_Externally_Built
263 or else Name
= Snames
.Name_Executable
264 or else Name
= Snames
.Name_Executable_Suffix
265 or else Name
= Snames
.Name_Default_Switches
267 Error_Msg_Name_1
:= Name
;
270 "%% is not valid in aggregate projects",
271 Location_Of
(Attribute
, In_Tree
));
275 if Name
= Snames
.Name_Project_Files
276 or else Name
= Snames
.Name_Project_Path
277 or else Name
= Snames
.Name_External
279 Error_Msg_Name_1
:= Name
;
282 "%% is only valid in aggregate projects",
283 Location_Of
(Attribute
, In_Tree
));
286 end Check_Attribute_Allowed
;
288 ---------------------------------
289 -- Parse_Attribute_Declaration --
290 ---------------------------------
292 procedure Parse_Attribute_Declaration
293 (In_Tree
: Project_Node_Tree_Ref
;
294 Attribute
: out Project_Node_Id
;
295 First_Attribute
: Attribute_Node_Id
;
296 Current_Project
: Project_Node_Id
;
297 Current_Package
: Project_Node_Id
;
298 Packages_To_Check
: String_List_Access
;
299 Flags
: Processing_Flags
)
301 Current_Attribute
: Attribute_Node_Id
:= First_Attribute
;
302 Full_Associative_Array
: Boolean := False;
303 Attribute_Name
: Name_Id
:= No_Name
;
304 Optional_Index
: Boolean := False;
305 Pkg_Id
: Package_Node_Id
:= Empty_Package
;
307 procedure Process_Attribute_Name
;
308 -- Read the name of the attribute, and check its type
310 procedure Process_Associative_Array_Index
;
311 -- Read the index of the associative array and check its validity
313 ----------------------------
314 -- Process_Attribute_Name --
315 ----------------------------
317 procedure Process_Attribute_Name
is
321 Attribute_Name
:= Token_Name
;
322 Set_Name_Of
(Attribute
, In_Tree
, To
=> Attribute_Name
);
323 Set_Location_Of
(Attribute
, In_Tree
, To
=> Token_Ptr
);
325 -- Find the attribute
328 Attribute_Node_Id_Of
(Attribute_Name
, First_Attribute
);
330 -- If the attribute cannot be found, create the attribute if inside
331 -- an unknown package.
333 if Current_Attribute
= Empty_Attribute
then
334 if Present
(Current_Package
)
335 and then Expression_Kind_Of
(Current_Package
, In_Tree
) = Ignored
337 Pkg_Id
:= Package_Id_Of
(Current_Package
, In_Tree
);
338 Add_Attribute
(Pkg_Id
, Token_Name
, Current_Attribute
);
341 -- If not a valid attribute name, issue an error if inside
342 -- a package that need to be checked.
344 Ignore
:= Present
(Current_Package
) and then
345 Packages_To_Check
/= All_Packages
;
349 -- Check that we are not in a package to check
351 Get_Name_String
(Name_Of
(Current_Package
, In_Tree
));
353 for Index
in Packages_To_Check
'Range loop
354 if Name_Buffer
(1 .. Name_Len
) =
355 Packages_To_Check
(Index
).all
364 Error_Msg_Name_1
:= Token_Name
;
365 Error_Msg
(Flags
, "undefined attribute %%", Token_Ptr
);
369 -- Set, if appropriate the index case insensitivity flag
372 if Is_Read_Only
(Current_Attribute
) then
373 Error_Msg_Name_1
:= Token_Name
;
375 (Flags
, "read-only attribute %% cannot be given a value",
379 if Attribute_Kind_Of
(Current_Attribute
) in
380 All_Case_Insensitive_Associative_Array
382 Set_Case_Insensitive
(Attribute
, In_Tree
, To
=> True);
386 Scan
(In_Tree
); -- past the attribute name
388 -- Set the expression kind of the attribute
390 if Current_Attribute
/= Empty_Attribute
then
391 Set_Expression_Kind_Of
392 (Attribute
, In_Tree
, To
=> Variable_Kind_Of
(Current_Attribute
));
393 Optional_Index
:= Optional_Index_Of
(Current_Attribute
);
395 end Process_Attribute_Name
;
397 -------------------------------------
398 -- Process_Associative_Array_Index --
399 -------------------------------------
401 procedure Process_Associative_Array_Index
is
403 -- If the attribute is not an associative array attribute, report
404 -- an error. If this information is still unknown, set the kind
405 -- to Associative_Array.
407 if Current_Attribute
/= Empty_Attribute
408 and then Attribute_Kind_Of
(Current_Attribute
) = Single
412 Get_Name_String
(Attribute_Name_Of
(Current_Attribute
))
413 & """ cannot be an associative array",
414 Location_Of
(Attribute
, In_Tree
));
416 elsif Attribute_Kind_Of
(Current_Attribute
) = Unknown
then
417 Set_Attribute_Kind_Of
(Current_Attribute
, To
=> Associative_Array
);
420 Scan
(In_Tree
); -- past the left parenthesis
422 if Others_Allowed_For
(Current_Attribute
)
423 and then Token
= Tok_Others
425 Set_Associative_Array_Index_Of
426 (Attribute
, In_Tree
, All_Other_Names
);
427 Scan
(In_Tree
); -- past others
430 if Others_Allowed_For
(Current_Attribute
) then
431 Expect
(Tok_String_Literal
, "literal string or others");
433 Expect
(Tok_String_Literal
, "literal string");
436 if Token
= Tok_String_Literal
then
437 Get_Name_String
(Token_Name
);
439 if Case_Insensitive
(Attribute
, In_Tree
) then
440 To_Lower
(Name_Buffer
(1 .. Name_Len
));
443 Set_Associative_Array_Index_Of
(Attribute
, In_Tree
, Name_Find
);
444 Scan
(In_Tree
); -- past the literal string index
446 if Token
= Tok_At
then
447 case Attribute_Kind_Of
(Current_Attribute
) is
448 when Optional_Index_Associative_Array |
449 Optional_Index_Case_Insensitive_Associative_Array
=>
451 Expect
(Tok_Integer_Literal
, "integer literal");
453 if Token
= Tok_Integer_Literal
then
455 -- Set the source index value from given literal
458 Index
: constant Int
:=
459 UI_To_Int
(Int_Literal_Value
);
463 (Flags
, "index cannot be zero", Token_Ptr
);
466 (Attribute
, In_Tree
, To
=> Index
);
474 Error_Msg
(Flags
, "index not allowed here", Token_Ptr
);
477 if Token
= Tok_Integer_Literal
then
485 Expect
(Tok_Right_Paren
, "`)`");
487 if Token
= Tok_Right_Paren
then
488 Scan
(In_Tree
); -- past the right parenthesis
490 end Process_Associative_Array_Index
;
495 (Of_Kind
=> N_Attribute_Declaration
, In_Tree
=> In_Tree
);
496 Set_Location_Of
(Attribute
, In_Tree
, To
=> Token_Ptr
);
497 Set_Previous_Line_Node
(Attribute
);
503 -- Body or External may be an attribute name
505 if Token
= Tok_Body
then
506 Token
:= Tok_Identifier
;
507 Token_Name
:= Snames
.Name_Body
;
510 if Token
= Tok_External
then
511 Token
:= Tok_Identifier
;
512 Token_Name
:= Snames
.Name_External
;
515 Expect
(Tok_Identifier
, "identifier");
516 Process_Attribute_Name
;
517 Rename_Obsolescent_Attributes
(In_Tree
, Attribute
, Current_Package
);
518 Check_Attribute_Allowed
(In_Tree
, Current_Project
, Attribute
, Flags
);
520 -- Associative array attributes
522 if Token
= Tok_Left_Paren
then
523 Process_Associative_Array_Index
;
526 -- If it is an associative array attribute and there are no left
527 -- parenthesis, then this is a full associative array declaration.
528 -- Flag it as such for later processing of its value.
530 if Current_Attribute
/= Empty_Attribute
532 Attribute_Kind_Of
(Current_Attribute
) /= Single
534 if Attribute_Kind_Of
(Current_Attribute
) = Unknown
then
535 Set_Attribute_Kind_Of
(Current_Attribute
, To
=> Single
);
538 Full_Associative_Array
:= True;
543 Expect
(Tok_Use
, "USE");
545 if Token
= Tok_Use
then
548 if Full_Associative_Array
then
550 -- Expect <project>'<same_attribute_name>, or
551 -- <project>.<same_package_name>'<same_attribute_name>
554 The_Project
: Project_Node_Id
:= Empty_Node
;
555 -- The node of the project where the associative array is
558 The_Package
: Project_Node_Id
:= Empty_Node
;
559 -- The node of the package where the associative array is
562 Project_Name
: Name_Id
:= No_Name
;
563 -- The name of the project where the associative array is
566 Location
: Source_Ptr
:= No_Location
;
567 -- The location of the project name
570 Expect
(Tok_Identifier
, "identifier");
572 if Token
= Tok_Identifier
then
573 Location
:= Token_Ptr
;
575 -- Find the project node in the imported project or
576 -- in the project being extended.
578 The_Project
:= Imported_Or_Extended_Project_Of
579 (Current_Project
, In_Tree
, Token_Name
);
581 if No
(The_Project
) then
582 Error_Msg
(Flags
, "unknown project", Location
);
583 Scan
(In_Tree
); -- past the project name
586 Project_Name
:= Token_Name
;
587 Scan
(In_Tree
); -- past the project name
589 -- If this is inside a package, a dot followed by the
590 -- name of the package must followed the project name.
592 if Present
(Current_Package
) then
593 Expect
(Tok_Dot
, "`.`");
595 if Token
/= Tok_Dot
then
596 The_Project
:= Empty_Node
;
599 Scan
(In_Tree
); -- past the dot
600 Expect
(Tok_Identifier
, "identifier");
602 if Token
/= Tok_Identifier
then
603 The_Project
:= Empty_Node
;
605 -- If it is not the same package name, issue error
608 Token_Name
/= Name_Of
(Current_Package
, In_Tree
)
610 The_Project
:= Empty_Node
;
612 (Flags
, "not the same package as " &
614 (Name_Of
(Current_Package
, In_Tree
)),
619 First_Package_Of
(The_Project
, In_Tree
);
621 -- Look for the package node
623 while Present
(The_Package
)
625 Name_Of
(The_Package
, In_Tree
) /= Token_Name
628 Next_Package_In_Project
629 (The_Package
, In_Tree
);
632 -- If the package cannot be found in the
633 -- project, issue an error.
635 if No
(The_Package
) then
636 The_Project
:= Empty_Node
;
637 Error_Msg_Name_2
:= Project_Name
;
638 Error_Msg_Name_1
:= Token_Name
;
641 "package % not declared in project %",
645 Scan
(In_Tree
); -- past the package name
652 if Present
(The_Project
) then
654 -- Looking for '<same attribute name>
656 Expect
(Tok_Apostrophe
, "`''`");
658 if Token
/= Tok_Apostrophe
then
659 The_Project
:= Empty_Node
;
662 Scan
(In_Tree
); -- past the apostrophe
663 Expect
(Tok_Identifier
, "identifier");
665 if Token
/= Tok_Identifier
then
666 The_Project
:= Empty_Node
;
669 -- If it is not the same attribute name, issue error
671 if Token_Name
/= Attribute_Name
then
672 The_Project
:= Empty_Node
;
673 Error_Msg_Name_1
:= Attribute_Name
;
675 (Flags
, "invalid name, should be %", Token_Ptr
);
678 Scan
(In_Tree
); -- past the attribute name
683 if No
(The_Project
) then
685 -- If there were any problem, set the attribute id to null,
686 -- so that the node will not be recorded.
688 Current_Attribute
:= Empty_Attribute
;
691 -- Set the appropriate field in the node.
692 -- Note that the index and the expression are nil. This
693 -- characterizes full associative array attribute
696 Set_Associative_Project_Of
(Attribute
, In_Tree
, The_Project
);
697 Set_Associative_Package_Of
(Attribute
, In_Tree
, The_Package
);
701 -- Other attribute declarations (not full associative array)
705 Expression_Location
: constant Source_Ptr
:= Token_Ptr
;
706 -- The location of the first token of the expression
708 Expression
: Project_Node_Id
:= Empty_Node
;
709 -- The expression, value for the attribute declaration
712 -- Get the expression value and set it in the attribute node
716 Expression
=> Expression
,
718 Current_Project
=> Current_Project
,
719 Current_Package
=> Current_Package
,
720 Optional_Index
=> Optional_Index
);
721 Set_Expression_Of
(Attribute
, In_Tree
, To
=> Expression
);
723 -- If the expression is legal, but not of the right kind
724 -- for the attribute, issue an error.
726 if Current_Attribute
/= Empty_Attribute
727 and then Present
(Expression
)
728 and then Variable_Kind_Of
(Current_Attribute
) /=
729 Expression_Kind_Of
(Expression
, In_Tree
)
731 if Variable_Kind_Of
(Current_Attribute
) = Undefined
then
734 To
=> Expression_Kind_Of
(Expression
, In_Tree
));
738 (Flags
, "wrong expression kind for attribute """ &
740 (Attribute_Name_Of
(Current_Attribute
)) &
742 Expression_Location
);
749 -- If the attribute was not recognized, return an empty node.
750 -- It may be that it is not in a package to check, and the node will
751 -- not be added to the tree.
753 if Current_Attribute
= Empty_Attribute
then
754 Attribute
:= Empty_Node
;
757 Set_End_Of_Line
(Attribute
);
758 Set_Previous_Line_Node
(Attribute
);
759 end Parse_Attribute_Declaration
;
761 -----------------------------
762 -- Parse_Case_Construction --
763 -----------------------------
765 procedure Parse_Case_Construction
766 (In_Tree
: Project_Node_Tree_Ref
;
767 Case_Construction
: out Project_Node_Id
;
768 First_Attribute
: Attribute_Node_Id
;
769 Current_Project
: Project_Node_Id
;
770 Current_Package
: Project_Node_Id
;
771 Packages_To_Check
: String_List_Access
;
772 Is_Config_File
: Boolean;
773 Flags
: Processing_Flags
)
775 Current_Item
: Project_Node_Id
:= Empty_Node
;
776 Next_Item
: Project_Node_Id
:= Empty_Node
;
777 First_Case_Item
: Boolean := True;
779 Variable_Location
: Source_Ptr
:= No_Location
;
781 String_Type
: Project_Node_Id
:= Empty_Node
;
783 Case_Variable
: Project_Node_Id
:= Empty_Node
;
785 First_Declarative_Item
: Project_Node_Id
:= Empty_Node
;
787 First_Choice
: Project_Node_Id
:= Empty_Node
;
789 When_Others
: Boolean := False;
790 -- Set to True when there is a "when others =>" clause
795 (Of_Kind
=> N_Case_Construction
, In_Tree
=> In_Tree
);
796 Set_Location_Of
(Case_Construction
, In_Tree
, To
=> Token_Ptr
);
802 -- Get the switch variable
804 Expect
(Tok_Identifier
, "identifier");
806 if Token
= Tok_Identifier
then
807 Variable_Location
:= Token_Ptr
;
808 Parse_Variable_Reference
810 Variable
=> Case_Variable
,
812 Current_Project
=> Current_Project
,
813 Current_Package
=> Current_Package
);
814 Set_Case_Variable_Reference_Of
815 (Case_Construction
, In_Tree
, To
=> Case_Variable
);
818 if Token
/= Tok_Is
then
823 if Present
(Case_Variable
) then
824 String_Type
:= String_Type_Of
(Case_Variable
, In_Tree
);
826 if No
(String_Type
) then
829 Get_Name_String
(Name_Of
(Case_Variable
, In_Tree
)) &
835 Expect
(Tok_Is
, "IS");
837 if Token
= Tok_Is
then
838 Set_End_Of_Line
(Case_Construction
);
839 Set_Previous_Line_Node
(Case_Construction
);
840 Set_Next_End_Node
(Case_Construction
);
847 Start_New_Case_Construction
(In_Tree
, String_Type
);
851 while Token
= Tok_When
loop
853 if First_Case_Item
then
856 (Of_Kind
=> N_Case_Item
, In_Tree
=> In_Tree
);
857 Set_First_Case_Item_Of
858 (Case_Construction
, In_Tree
, To
=> Current_Item
);
859 First_Case_Item
:= False;
864 (Of_Kind
=> N_Case_Item
, In_Tree
=> In_Tree
);
865 Set_Next_Case_Item
(Current_Item
, In_Tree
, To
=> Next_Item
);
866 Current_Item
:= Next_Item
;
869 Set_Location_Of
(Current_Item
, In_Tree
, To
=> Token_Ptr
);
875 if Token
= Tok_Others
then
878 -- Scan past "others"
882 Expect
(Tok_Arrow
, "`=>`");
883 Set_End_Of_Line
(Current_Item
);
884 Set_Previous_Line_Node
(Current_Item
);
886 -- Empty_Node in Field1 of a Case_Item indicates
887 -- the "when others =>" branch.
889 Set_First_Choice_Of
(Current_Item
, In_Tree
, To
=> Empty_Node
);
891 Parse_Declarative_Items
893 Declarations
=> First_Declarative_Item
,
894 In_Zone
=> In_Case_Construction
,
895 First_Attribute
=> First_Attribute
,
896 Current_Project
=> Current_Project
,
897 Current_Package
=> Current_Package
,
898 Packages_To_Check
=> Packages_To_Check
,
899 Is_Config_File
=> Is_Config_File
,
902 -- "when others =>" must be the last branch, so save the
903 -- Case_Item and exit
905 Set_First_Declarative_Item_Of
906 (Current_Item
, In_Tree
, To
=> First_Declarative_Item
);
912 First_Choice
=> First_Choice
,
914 Set_First_Choice_Of
(Current_Item
, In_Tree
, To
=> First_Choice
);
916 Expect
(Tok_Arrow
, "`=>`");
917 Set_End_Of_Line
(Current_Item
);
918 Set_Previous_Line_Node
(Current_Item
);
920 Parse_Declarative_Items
922 Declarations
=> First_Declarative_Item
,
923 In_Zone
=> In_Case_Construction
,
924 First_Attribute
=> First_Attribute
,
925 Current_Project
=> Current_Project
,
926 Current_Package
=> Current_Package
,
927 Packages_To_Check
=> Packages_To_Check
,
928 Is_Config_File
=> Is_Config_File
,
931 Set_First_Declarative_Item_Of
932 (Current_Item
, In_Tree
, To
=> First_Declarative_Item
);
937 End_Case_Construction
938 (Check_All_Labels
=> not When_Others
and not Quiet_Output
,
939 Case_Location
=> Location_Of
(Case_Construction
, In_Tree
),
942 Expect
(Tok_End
, "`END CASE`");
943 Remove_Next_End_Node
;
945 if Token
= Tok_End
then
951 Expect
(Tok_Case
, "CASE");
959 Expect
(Tok_Semicolon
, "`;`");
960 Set_Previous_End_Node
(Case_Construction
);
962 end Parse_Case_Construction
;
964 -----------------------------
965 -- Parse_Declarative_Items --
966 -----------------------------
968 procedure Parse_Declarative_Items
969 (In_Tree
: Project_Node_Tree_Ref
;
970 Declarations
: out Project_Node_Id
;
972 First_Attribute
: Attribute_Node_Id
;
973 Current_Project
: Project_Node_Id
;
974 Current_Package
: Project_Node_Id
;
975 Packages_To_Check
: String_List_Access
;
976 Is_Config_File
: Boolean;
977 Flags
: Processing_Flags
)
979 Current_Declarative_Item
: Project_Node_Id
:= Empty_Node
;
980 Next_Declarative_Item
: Project_Node_Id
:= Empty_Node
;
981 Current_Declaration
: Project_Node_Id
:= Empty_Node
;
982 Item_Location
: Source_Ptr
:= No_Location
;
985 Declarations
:= Empty_Node
;
988 -- We are always positioned at the token that precedes the first
989 -- token of the declarative element. Scan past it.
993 Item_Location
:= Token_Ptr
;
996 when Tok_Identifier
=>
998 if In_Zone
= In_Case_Construction
then
1000 -- Check if the variable has already been declared
1003 The_Variable
: Project_Node_Id
:= Empty_Node
;
1006 if Present
(Current_Package
) then
1008 First_Variable_Of
(Current_Package
, In_Tree
);
1009 elsif Present
(Current_Project
) then
1011 First_Variable_Of
(Current_Project
, In_Tree
);
1014 while Present
(The_Variable
)
1015 and then Name_Of
(The_Variable
, In_Tree
) /=
1018 The_Variable
:= Next_Variable
(The_Variable
, In_Tree
);
1021 -- It is an error to declare a variable in a case
1022 -- construction for the first time.
1024 if No
(The_Variable
) then
1027 "a variable cannot be declared " &
1028 "for the first time here",
1034 Parse_Variable_Declaration
1036 Current_Declaration
,
1037 Current_Project
=> Current_Project
,
1038 Current_Package
=> Current_Package
,
1041 Set_End_Of_Line
(Current_Declaration
);
1042 Set_Previous_Line_Node
(Current_Declaration
);
1046 Parse_Attribute_Declaration
1047 (In_Tree
=> In_Tree
,
1048 Attribute
=> Current_Declaration
,
1049 First_Attribute
=> First_Attribute
,
1050 Current_Project
=> Current_Project
,
1051 Current_Package
=> Current_Package
,
1052 Packages_To_Check
=> Packages_To_Check
,
1055 Set_End_Of_Line
(Current_Declaration
);
1056 Set_Previous_Line_Node
(Current_Declaration
);
1060 Scan
(In_Tree
); -- past "null"
1064 -- Package declaration
1066 if In_Zone
/= In_Project
then
1068 (Flags
, "a package cannot be declared here", Token_Ptr
);
1071 Parse_Package_Declaration
1072 (In_Tree
=> In_Tree
,
1073 Package_Declaration
=> Current_Declaration
,
1074 Current_Project
=> Current_Project
,
1075 Packages_To_Check
=> Packages_To_Check
,
1076 Is_Config_File
=> Is_Config_File
,
1079 Set_Previous_End_Node
(Current_Declaration
);
1083 -- Type String Declaration
1085 if In_Zone
/= In_Project
then
1087 "a string type cannot be declared here",
1091 Parse_String_Type_Declaration
1092 (In_Tree
=> In_Tree
,
1093 String_Type
=> Current_Declaration
,
1094 Current_Project
=> Current_Project
,
1097 Set_End_Of_Line
(Current_Declaration
);
1098 Set_Previous_Line_Node
(Current_Declaration
);
1102 -- Case construction
1104 Parse_Case_Construction
1105 (In_Tree
=> In_Tree
,
1106 Case_Construction
=> Current_Declaration
,
1107 First_Attribute
=> First_Attribute
,
1108 Current_Project
=> Current_Project
,
1109 Current_Package
=> Current_Package
,
1110 Packages_To_Check
=> Packages_To_Check
,
1111 Is_Config_File
=> Is_Config_File
,
1114 Set_Previous_End_Node
(Current_Declaration
);
1119 -- We are leaving Parse_Declarative_Items positioned
1120 -- at the first token after the list of declarative items.
1121 -- It could be "end" (for a project, a package declaration or
1122 -- a case construction) or "when" (for a case construction)
1126 Expect
(Tok_Semicolon
, "`;` after declarative items");
1128 -- Insert an N_Declarative_Item in the tree, but only if
1129 -- Current_Declaration is not an empty node.
1131 if Present
(Current_Declaration
) then
1132 if No
(Current_Declarative_Item
) then
1133 Current_Declarative_Item
:=
1134 Default_Project_Node
1135 (Of_Kind
=> N_Declarative_Item
, In_Tree
=> In_Tree
);
1136 Declarations
:= Current_Declarative_Item
;
1139 Next_Declarative_Item
:=
1140 Default_Project_Node
1141 (Of_Kind
=> N_Declarative_Item
, In_Tree
=> In_Tree
);
1142 Set_Next_Declarative_Item
1143 (Current_Declarative_Item
, In_Tree
,
1144 To
=> Next_Declarative_Item
);
1145 Current_Declarative_Item
:= Next_Declarative_Item
;
1148 Set_Current_Item_Node
1149 (Current_Declarative_Item
, In_Tree
,
1150 To
=> Current_Declaration
);
1152 (Current_Declarative_Item
, In_Tree
, To
=> Item_Location
);
1155 end Parse_Declarative_Items
;
1157 -------------------------------
1158 -- Parse_Package_Declaration --
1159 -------------------------------
1161 procedure Parse_Package_Declaration
1162 (In_Tree
: Project_Node_Tree_Ref
;
1163 Package_Declaration
: out Project_Node_Id
;
1164 Current_Project
: Project_Node_Id
;
1165 Packages_To_Check
: String_List_Access
;
1166 Is_Config_File
: Boolean;
1167 Flags
: Processing_Flags
)
1169 First_Attribute
: Attribute_Node_Id
:= Empty_Attribute
;
1170 Current_Package
: Package_Node_Id
:= Empty_Package
;
1171 First_Declarative_Item
: Project_Node_Id
:= Empty_Node
;
1172 Package_Location
: constant Source_Ptr
:= Token_Ptr
;
1173 Renaming
: Boolean := False;
1174 Extending
: Boolean := False;
1177 Package_Declaration
:=
1178 Default_Project_Node
1179 (Of_Kind
=> N_Package_Declaration
, In_Tree
=> In_Tree
);
1180 Set_Location_Of
(Package_Declaration
, In_Tree
, To
=> Package_Location
);
1182 -- Scan past "package"
1185 Expect
(Tok_Identifier
, "identifier");
1187 if Token
= Tok_Identifier
then
1188 Set_Name_Of
(Package_Declaration
, In_Tree
, To
=> Token_Name
);
1190 Current_Package
:= Package_Node_Id_Of
(Token_Name
);
1192 if Current_Package
= Empty_Package
then
1193 if not Quiet_Output
then
1195 List
: constant Strings
.String_List
:= Package_Name_List
;
1197 Name
: constant String := Get_Name_String
(Token_Name
);
1200 -- Check for possible misspelling of a known package name
1204 if Index
>= List
'Last then
1211 GNAT
.Spelling_Checker
.Is_Bad_Spelling_Of
1212 (Name
, List
(Index
).all);
1215 -- Issue warning(s) in verbose mode or when a possible
1216 -- misspelling has been found.
1218 if Verbose_Mode
or else Index
/= 0 then
1222 (Name_Of
(Package_Declaration
, In_Tree
)) &
1223 """ is not a known package name",
1228 Error_Msg
-- CODEFIX
1230 "\?possible misspelling of """ &
1231 List
(Index
).all & """", Token_Ptr
);
1236 -- Set the package declaration to "ignored" so that it is not
1237 -- processed by Prj.Proc.Process.
1239 Set_Expression_Kind_Of
(Package_Declaration
, In_Tree
, Ignored
);
1241 -- Add the unknown package in the list of packages
1243 Add_Unknown_Package
(Token_Name
, Current_Package
);
1245 elsif Current_Package
= Unknown_Package
then
1247 -- Set the package declaration to "ignored" so that it is not
1248 -- processed by Prj.Proc.Process.
1250 Set_Expression_Kind_Of
(Package_Declaration
, In_Tree
, Ignored
);
1253 First_Attribute
:= First_Attribute_Of
(Current_Package
);
1257 (Package_Declaration
, In_Tree
, To
=> Current_Package
);
1260 Current
: Project_Node_Id
:=
1261 First_Package_Of
(Current_Project
, In_Tree
);
1264 while Present
(Current
)
1265 and then Name_Of
(Current
, In_Tree
) /= Token_Name
1267 Current
:= Next_Package_In_Project
(Current
, In_Tree
);
1270 if Present
(Current
) then
1274 Get_Name_String
(Name_Of
(Package_Declaration
, In_Tree
)) &
1275 """ is declared twice in the same project",
1279 -- Add the package to the project list
1281 Set_Next_Package_In_Project
1282 (Package_Declaration
, In_Tree
,
1283 To
=> First_Package_Of
(Current_Project
, In_Tree
));
1284 Set_First_Package_Of
1285 (Current_Project
, In_Tree
, To
=> Package_Declaration
);
1289 -- Scan past the package name
1294 Check_Package_Allowed
1295 (In_Tree
, Current_Project
, Package_Declaration
, Flags
);
1297 if Token
= Tok_Renames
then
1299 elsif Token
= Tok_Extends
then
1303 if Renaming
or else Extending
then
1304 if Is_Config_File
then
1307 "no package rename or extension in configuration projects",
1311 -- Scan past "renames" or "extends"
1315 Expect
(Tok_Identifier
, "identifier");
1317 if Token
= Tok_Identifier
then
1319 Project_Name
: constant Name_Id
:= Token_Name
;
1321 Clause
: Project_Node_Id
:=
1322 First_With_Clause_Of
(Current_Project
, In_Tree
);
1323 The_Project
: Project_Node_Id
:= Empty_Node
;
1324 Extended
: constant Project_Node_Id
:=
1326 (Project_Declaration_Of
1327 (Current_Project
, In_Tree
),
1330 while Present
(Clause
) loop
1331 -- Only non limited imported projects may be used in a
1332 -- renames declaration.
1335 Non_Limited_Project_Node_Of
(Clause
, In_Tree
);
1336 exit when Present
(The_Project
)
1337 and then Name_Of
(The_Project
, In_Tree
) = Project_Name
;
1338 Clause
:= Next_With_Clause_Of
(Clause
, In_Tree
);
1342 -- As we have not found the project in the imports, we check
1343 -- if it's the name of an eventual extended project.
1345 if Present
(Extended
)
1346 and then Name_Of
(Extended
, In_Tree
) = Project_Name
1348 Set_Project_Of_Renamed_Package_Of
1349 (Package_Declaration
, In_Tree
, To
=> Extended
);
1351 Error_Msg_Name_1
:= Project_Name
;
1354 "% is not an imported or extended project", Token_Ptr
);
1357 Set_Project_Of_Renamed_Package_Of
1358 (Package_Declaration
, In_Tree
, To
=> The_Project
);
1363 Expect
(Tok_Dot
, "`.`");
1365 if Token
= Tok_Dot
then
1367 Expect
(Tok_Identifier
, "identifier");
1369 if Token
= Tok_Identifier
then
1370 if Name_Of
(Package_Declaration
, In_Tree
) /= Token_Name
then
1371 Error_Msg
(Flags
, "not the same package name", Token_Ptr
);
1373 Present
(Project_Of_Renamed_Package_Of
1374 (Package_Declaration
, In_Tree
))
1377 Current
: Project_Node_Id
:=
1379 (Project_Of_Renamed_Package_Of
1380 (Package_Declaration
, In_Tree
),
1384 while Present
(Current
)
1385 and then Name_Of
(Current
, In_Tree
) /= Token_Name
1388 Next_Package_In_Project
(Current
, In_Tree
);
1391 if No
(Current
) then
1394 Get_Name_String
(Token_Name
) &
1395 """ is not a package declared by the project",
1408 Expect
(Tok_Semicolon
, "`;`");
1409 Set_End_Of_Line
(Package_Declaration
);
1410 Set_Previous_Line_Node
(Package_Declaration
);
1412 elsif Token
= Tok_Is
then
1413 Set_End_Of_Line
(Package_Declaration
);
1414 Set_Previous_Line_Node
(Package_Declaration
);
1415 Set_Next_End_Node
(Package_Declaration
);
1417 Parse_Declarative_Items
1418 (In_Tree
=> In_Tree
,
1419 Declarations
=> First_Declarative_Item
,
1420 In_Zone
=> In_Package
,
1421 First_Attribute
=> First_Attribute
,
1422 Current_Project
=> Current_Project
,
1423 Current_Package
=> Package_Declaration
,
1424 Packages_To_Check
=> Packages_To_Check
,
1425 Is_Config_File
=> Is_Config_File
,
1428 Set_First_Declarative_Item_Of
1429 (Package_Declaration
, In_Tree
, To
=> First_Declarative_Item
);
1431 Expect
(Tok_End
, "END");
1433 if Token
= Tok_End
then
1440 -- We should have the name of the package after "end"
1442 Expect
(Tok_Identifier
, "identifier");
1444 if Token
= Tok_Identifier
1445 and then Name_Of
(Package_Declaration
, In_Tree
) /= No_Name
1446 and then Token_Name
/= Name_Of
(Package_Declaration
, In_Tree
)
1448 Error_Msg_Name_1
:= Name_Of
(Package_Declaration
, In_Tree
);
1449 Error_Msg
(Flags
, "expected %%", Token_Ptr
);
1452 if Token
/= Tok_Semicolon
then
1454 -- Scan past the package name
1459 Expect
(Tok_Semicolon
, "`;`");
1460 Remove_Next_End_Node
;
1463 Error_Msg
(Flags
, "expected IS", Token_Ptr
);
1466 end Parse_Package_Declaration
;
1468 -----------------------------------
1469 -- Parse_String_Type_Declaration --
1470 -----------------------------------
1472 procedure Parse_String_Type_Declaration
1473 (In_Tree
: Project_Node_Tree_Ref
;
1474 String_Type
: out Project_Node_Id
;
1475 Current_Project
: Project_Node_Id
;
1476 Flags
: Processing_Flags
)
1478 Current
: Project_Node_Id
:= Empty_Node
;
1479 First_String
: Project_Node_Id
:= Empty_Node
;
1483 Default_Project_Node
1484 (Of_Kind
=> N_String_Type_Declaration
, In_Tree
=> In_Tree
);
1486 Set_Location_Of
(String_Type
, In_Tree
, To
=> Token_Ptr
);
1492 Expect
(Tok_Identifier
, "identifier");
1494 if Token
= Tok_Identifier
then
1495 Set_Name_Of
(String_Type
, In_Tree
, To
=> Token_Name
);
1497 Current
:= First_String_Type_Of
(Current_Project
, In_Tree
);
1498 while Present
(Current
)
1500 Name_Of
(Current
, In_Tree
) /= Token_Name
1502 Current
:= Next_String_Type
(Current
, In_Tree
);
1505 if Present
(Current
) then
1507 "duplicate string type name """ &
1508 Get_Name_String
(Token_Name
) &
1512 Current
:= First_Variable_Of
(Current_Project
, In_Tree
);
1513 while Present
(Current
)
1514 and then Name_Of
(Current
, In_Tree
) /= Token_Name
1516 Current
:= Next_Variable
(Current
, In_Tree
);
1519 if Present
(Current
) then
1522 Get_Name_String
(Token_Name
) &
1523 """ is already a variable name", Token_Ptr
);
1525 Set_Next_String_Type
1526 (String_Type
, In_Tree
,
1527 To
=> First_String_Type_Of
(Current_Project
, In_Tree
));
1528 Set_First_String_Type_Of
1529 (Current_Project
, In_Tree
, To
=> String_Type
);
1533 -- Scan past the name
1538 Expect
(Tok_Is
, "IS");
1540 if Token
= Tok_Is
then
1544 Expect
(Tok_Left_Paren
, "`(`");
1546 if Token
= Tok_Left_Paren
then
1550 Parse_String_Type_List
1551 (In_Tree
=> In_Tree
, First_String
=> First_String
, Flags
=> Flags
);
1552 Set_First_Literal_String
(String_Type
, In_Tree
, To
=> First_String
);
1554 Expect
(Tok_Right_Paren
, "`)`");
1556 if Token
= Tok_Right_Paren
then
1560 end Parse_String_Type_Declaration
;
1562 --------------------------------
1563 -- Parse_Variable_Declaration --
1564 --------------------------------
1566 procedure Parse_Variable_Declaration
1567 (In_Tree
: Project_Node_Tree_Ref
;
1568 Variable
: out Project_Node_Id
;
1569 Current_Project
: Project_Node_Id
;
1570 Current_Package
: Project_Node_Id
;
1571 Flags
: Processing_Flags
)
1573 Expression_Location
: Source_Ptr
;
1574 String_Type_Name
: Name_Id
:= No_Name
;
1575 Project_String_Type_Name
: Name_Id
:= No_Name
;
1576 Type_Location
: Source_Ptr
:= No_Location
;
1577 Project_Location
: Source_Ptr
:= No_Location
;
1578 Expression
: Project_Node_Id
:= Empty_Node
;
1579 Variable_Name
: constant Name_Id
:= Token_Name
;
1580 OK
: Boolean := True;
1584 Default_Project_Node
1585 (Of_Kind
=> N_Variable_Declaration
, In_Tree
=> In_Tree
);
1586 Set_Name_Of
(Variable
, In_Tree
, To
=> Variable_Name
);
1587 Set_Location_Of
(Variable
, In_Tree
, To
=> Token_Ptr
);
1589 -- Scan past the variable name
1593 if Token
= Tok_Colon
then
1595 -- Typed string variable declaration
1598 Set_Kind_Of
(Variable
, In_Tree
, N_Typed_Variable_Declaration
);
1599 Expect
(Tok_Identifier
, "identifier");
1601 OK
:= Token
= Tok_Identifier
;
1604 String_Type_Name
:= Token_Name
;
1605 Type_Location
:= Token_Ptr
;
1608 if Token
= Tok_Dot
then
1609 Project_String_Type_Name
:= String_Type_Name
;
1610 Project_Location
:= Type_Location
;
1612 -- Scan past the dot
1615 Expect
(Tok_Identifier
, "identifier");
1617 if Token
= Tok_Identifier
then
1618 String_Type_Name
:= Token_Name
;
1619 Type_Location
:= Token_Ptr
;
1628 Proj
: Project_Node_Id
:= Current_Project
;
1629 Current
: Project_Node_Id
:= Empty_Node
;
1632 if Project_String_Type_Name
/= No_Name
then
1634 The_Project_Name_And_Node
: constant
1635 Tree_Private_Part
.Project_Name_And_Node
:=
1636 Tree_Private_Part
.Projects_Htable
.Get
1637 (In_Tree
.Projects_HT
, Project_String_Type_Name
);
1639 use Tree_Private_Part
;
1642 if The_Project_Name_And_Node
=
1643 Tree_Private_Part
.No_Project_Name_And_Node
1646 "unknown project """ &
1648 (Project_String_Type_Name
) &
1651 Current
:= Empty_Node
;
1654 First_String_Type_Of
1655 (The_Project_Name_And_Node
.Node
, In_Tree
);
1659 Name_Of
(Current
, In_Tree
) /= String_Type_Name
1661 Current
:= Next_String_Type
(Current
, In_Tree
);
1667 -- Look for a string type with the correct name in this
1668 -- project or in any of its ancestors.
1672 First_String_Type_Of
(Proj
, In_Tree
);
1676 Name_Of
(Current
, In_Tree
) /= String_Type_Name
1678 Current
:= Next_String_Type
(Current
, In_Tree
);
1681 exit when Present
(Current
);
1683 Proj
:= Parent_Project_Of
(Proj
, In_Tree
);
1684 exit when No
(Proj
);
1688 if No
(Current
) then
1690 "unknown string type """ &
1691 Get_Name_String
(String_Type_Name
) &
1698 (Variable
, In_Tree
, To
=> Current
);
1705 Expect
(Tok_Colon_Equal
, "`:=`");
1707 OK
:= OK
and then Token
= Tok_Colon_Equal
;
1709 if Token
= Tok_Colon_Equal
then
1713 -- Get the single string or string list value
1715 Expression_Location
:= Token_Ptr
;
1718 (In_Tree
=> In_Tree
,
1719 Expression
=> Expression
,
1721 Current_Project
=> Current_Project
,
1722 Current_Package
=> Current_Package
,
1723 Optional_Index
=> False);
1724 Set_Expression_Of
(Variable
, In_Tree
, To
=> Expression
);
1726 if Present
(Expression
) then
1727 -- A typed string must have a single string value, not a list
1729 if Kind_Of
(Variable
, In_Tree
) = N_Typed_Variable_Declaration
1730 and then Expression_Kind_Of
(Expression
, In_Tree
) = List
1734 "expression must be a single string", Expression_Location
);
1737 Set_Expression_Kind_Of
1739 To
=> Expression_Kind_Of
(Expression
, In_Tree
));
1744 The_Variable
: Project_Node_Id
:= Empty_Node
;
1747 if Present
(Current_Package
) then
1748 The_Variable
:= First_Variable_Of
(Current_Package
, In_Tree
);
1749 elsif Present
(Current_Project
) then
1750 The_Variable
:= First_Variable_Of
(Current_Project
, In_Tree
);
1753 while Present
(The_Variable
)
1754 and then Name_Of
(The_Variable
, In_Tree
) /= Variable_Name
1756 The_Variable
:= Next_Variable
(The_Variable
, In_Tree
);
1759 if No
(The_Variable
) then
1760 if Present
(Current_Package
) then
1763 To
=> First_Variable_Of
(Current_Package
, In_Tree
));
1764 Set_First_Variable_Of
1765 (Current_Package
, In_Tree
, To
=> Variable
);
1767 elsif Present
(Current_Project
) then
1770 To
=> First_Variable_Of
(Current_Project
, In_Tree
));
1771 Set_First_Variable_Of
1772 (Current_Project
, In_Tree
, To
=> Variable
);
1776 if Expression_Kind_Of
(Variable
, In_Tree
) /= Undefined
then
1777 if Expression_Kind_Of
(The_Variable
, In_Tree
) =
1780 Set_Expression_Kind_Of
1781 (The_Variable
, In_Tree
,
1782 To
=> Expression_Kind_Of
(Variable
, In_Tree
));
1785 if Expression_Kind_Of
(The_Variable
, In_Tree
) /=
1786 Expression_Kind_Of
(Variable
, In_Tree
)
1789 "wrong expression kind for variable """ &
1791 (Name_Of
(The_Variable
, In_Tree
)) &
1793 Expression_Location
);
1800 end Parse_Variable_Declaration
;