1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2015, 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
;
27 with Prj
.Attr
; use Prj
.Attr
;
28 with Prj
.Err
; use Prj
.Err
;
31 with Uintp
; use Uintp
;
33 package body Prj
.Strt
is
35 Buffer
: String_Access
;
36 Buffer_Last
: Natural := 0;
38 type Choice_String
is record
40 Already_Used
: Boolean := False;
42 -- The string of a case label, and an indication that it has already
43 -- been used (to avoid duplicate case labels).
45 Choices_Initial
: constant := 10;
46 Choices_Increment
: constant := 100;
47 -- These should be in alloc.ads
49 Choice_Node_Low_Bound
: constant := 0;
50 Choice_Node_High_Bound
: constant := 099_999_999
;
51 -- In practice, infinite
53 type Choice_Node_Id
is
54 range Choice_Node_Low_Bound
.. Choice_Node_High_Bound
;
56 First_Choice_Node_Id
: constant Choice_Node_Id
:=
57 Choice_Node_Low_Bound
;
61 (Table_Component_Type
=> Choice_String
,
62 Table_Index_Type
=> Choice_Node_Id
'Base,
63 Table_Low_Bound
=> First_Choice_Node_Id
,
64 Table_Initial
=> Choices_Initial
,
65 Table_Increment
=> Choices_Increment
,
66 Table_Name
=> "Prj.Strt.Choices");
67 -- Used to store the case labels and check that there is no duplicate
69 package Choice_Lasts
is
71 (Table_Component_Type
=> Choice_Node_Id
,
72 Table_Index_Type
=> Nat
,
75 Table_Increment
=> 100,
76 Table_Name
=> "Prj.Strt.Choice_Lasts");
77 -- Used to store the indexes of the choices in table Choices, to
78 -- distinguish nested case constructions.
80 Choice_First
: Choice_Node_Id
:= 0;
81 -- Index in table Choices of the first case label of the current
82 -- case construction. Zero means no current case construction.
84 type Name_Location
is record
85 Name
: Name_Id
:= No_Name
;
86 Location
: Source_Ptr
:= No_Location
;
88 -- Store the identifier and the location of a simple name
92 (Table_Component_Type
=> Name_Location
,
93 Table_Index_Type
=> Nat
,
96 Table_Increment
=> 100,
97 Table_Name
=> "Prj.Strt.Names");
98 -- Used to accumulate the single names of a name
100 procedure Add
(This_String
: Name_Id
);
101 -- Add a string to the case label list, indicating that it has not
104 procedure Add_To_Names
(NL
: Name_Location
);
105 -- Add one single names to table Names
107 procedure External_Reference
108 (In_Tree
: Project_Node_Tree_Ref
;
109 Current_Project
: Project_Node_Id
;
110 Current_Package
: Project_Node_Id
;
111 External_Value
: out Project_Node_Id
;
112 Expr_Kind
: in out Variable_Kind
;
113 Flags
: Processing_Flags
);
114 -- Parse an external reference. Current token is "external"
116 procedure Attribute_Reference
117 (In_Tree
: Project_Node_Tree_Ref
;
118 Reference
: out Project_Node_Id
;
119 First_Attribute
: Attribute_Node_Id
;
120 Current_Project
: Project_Node_Id
;
121 Current_Package
: Project_Node_Id
;
122 Flags
: Processing_Flags
);
123 -- Parse an attribute reference. Current token is an apostrophe
126 (In_Tree
: Project_Node_Tree_Ref
;
127 Term
: out Project_Node_Id
;
128 Expr_Kind
: in out Variable_Kind
;
129 Current_Project
: Project_Node_Id
;
130 Current_Package
: Project_Node_Id
;
131 Optional_Index
: Boolean;
132 Flags
: Processing_Flags
);
133 -- Recursive procedure to parse one term or several terms concatenated
140 procedure Add
(This_String
: Name_Id
) is
142 Choices
.Increment_Last
;
143 Choices
.Table
(Choices
.Last
) :=
144 (The_String
=> This_String
,
145 Already_Used
=> False);
152 procedure Add_To_Names
(NL
: Name_Location
) is
154 Names
.Increment_Last
;
155 Names
.Table
(Names
.Last
) := NL
;
158 -------------------------
159 -- Attribute_Reference --
160 -------------------------
162 procedure Attribute_Reference
163 (In_Tree
: Project_Node_Tree_Ref
;
164 Reference
: out Project_Node_Id
;
165 First_Attribute
: Attribute_Node_Id
;
166 Current_Project
: Project_Node_Id
;
167 Current_Package
: Project_Node_Id
;
168 Flags
: Processing_Flags
)
170 Current_Attribute
: Attribute_Node_Id
:= First_Attribute
;
173 -- Declare the node of the attribute reference
177 (Of_Kind
=> N_Attribute_Reference
, In_Tree
=> In_Tree
);
178 Set_Location_Of
(Reference
, In_Tree
, To
=> Token_Ptr
);
179 Scan
(In_Tree
); -- past apostrophe
181 -- Body may be an attribute name
183 if Token
= Tok_Body
then
184 Token
:= Tok_Identifier
;
185 Token_Name
:= Snames
.Name_Body
;
188 Expect
(Tok_Identifier
, "identifier");
190 if Token
= Tok_Identifier
then
191 Set_Name_Of
(Reference
, In_Tree
, To
=> Token_Name
);
193 -- Check if the identifier is one of the attribute identifiers in the
194 -- context (package or project level attributes).
197 Attribute_Node_Id_Of
(Token_Name
, Starting_At
=> First_Attribute
);
199 -- If the identifier is not allowed, report an error
201 if Current_Attribute
= Empty_Attribute
then
202 Error_Msg_Name_1
:= Token_Name
;
203 Error_Msg
(Flags
, "unknown attribute %%", Token_Ptr
);
204 Reference
:= Empty_Node
;
206 -- Scan past the attribute name
210 -- Skip a possible index for an associative array
212 if Token
= Tok_Left_Paren
then
215 if Token
= Tok_String_Literal
then
218 if Token
= Tok_Right_Paren
then
225 -- Give its characteristics to this attribute reference
227 Set_Project_Node_Of
(Reference
, In_Tree
, To
=> Current_Project
);
228 Set_Package_Node_Of
(Reference
, In_Tree
, To
=> Current_Package
);
229 Set_Expression_Kind_Of
230 (Reference
, In_Tree
, To
=> Variable_Kind_Of
(Current_Attribute
));
233 To
=> Attribute_Kind_Of
(Current_Attribute
) in
234 All_Case_Insensitive_Associative_Array
);
237 To
=> Attribute_Default_Of
(Current_Attribute
));
239 -- Scan past the attribute name
243 -- If the attribute is an associative array, get the index
245 if Attribute_Kind_Of
(Current_Attribute
) /= Single
then
246 Expect
(Tok_Left_Paren
, "`(`");
248 if Token
= Tok_Left_Paren
then
251 if Others_Allowed_For
(Current_Attribute
)
252 and then Token
= Tok_Others
254 Set_Associative_Array_Index_Of
255 (Reference
, In_Tree
, To
=> All_Other_Names
);
259 if Others_Allowed_For
(Current_Attribute
) then
261 (Tok_String_Literal
, "literal string or others");
263 Expect
(Tok_String_Literal
, "literal string");
266 if Token
= Tok_String_Literal
then
267 Set_Associative_Array_Index_Of
268 (Reference
, In_Tree
, To
=> Token_Name
);
274 Expect
(Tok_Right_Paren
, "`)`");
276 if Token
= Tok_Right_Paren
then
282 -- Change name of obsolete attributes
284 if Present
(Reference
) then
285 case Name_Of
(Reference
, In_Tree
) is
286 when Snames
.Name_Specification
=>
287 Set_Name_Of
(Reference
, In_Tree
, To
=> Snames
.Name_Spec
);
289 when Snames
.Name_Specification_Suffix
=>
291 (Reference
, In_Tree
, To
=> Snames
.Name_Spec_Suffix
);
293 when Snames
.Name_Implementation
=>
294 Set_Name_Of
(Reference
, In_Tree
, To
=> Snames
.Name_Body
);
296 when Snames
.Name_Implementation_Suffix
=>
298 (Reference
, In_Tree
, To
=> Snames
.Name_Body_Suffix
);
305 end Attribute_Reference
;
307 ---------------------------
308 -- End_Case_Construction --
309 ---------------------------
311 procedure End_Case_Construction
312 (Check_All_Labels
: Boolean;
313 Case_Location
: Source_Ptr
;
314 Flags
: Processing_Flags
;
315 String_Type
: Boolean)
317 Non_Used
: Natural := 0;
318 First_Non_Used
: Choice_Node_Id
:= First_Choice_Node_Id
;
321 -- First, if Check_All_Labels is True, check if all values of the string
322 -- type have been used.
324 if Check_All_Labels
then
326 for Choice
in Choice_First
.. Choices
.Last
loop
327 if not Choices
.Table
(Choice
).Already_Used
then
328 Non_Used
:= Non_Used
+ 1;
331 First_Non_Used
:= Choice
;
336 -- If only one is not used, report a single warning for this value
339 Error_Msg_Name_1
:= Choices
.Table
(First_Non_Used
).The_String
;
341 (Flags
, "?value %% is not used as label", Case_Location
);
343 -- If several are not used, report a warning for each one of them
345 elsif Non_Used
> 1 then
347 (Flags
, "?the following values are not used as labels:",
350 for Choice
in First_Non_Used
.. Choices
.Last
loop
351 if not Choices
.Table
(Choice
).Already_Used
then
352 Error_Msg_Name_1
:= Choices
.Table
(Choice
).The_String
;
353 Error_Msg
(Flags
, "\?%%", Case_Location
);
360 "?no when others for this case construction",
365 -- If this is the only case construction, empty the tables
367 if Choice_Lasts
.Last
= 1 then
368 Choice_Lasts
.Set_Last
(0);
369 Choices
.Set_Last
(First_Choice_Node_Id
);
372 -- Second case construction, set the tables to the first
374 elsif Choice_Lasts
.Last
= 2 then
375 Choice_Lasts
.Set_Last
(1);
376 Choices
.Set_Last
(Choice_Lasts
.Table
(1));
379 -- Third or more case construction, set the tables to the previous one
381 Choice_Lasts
.Decrement_Last
;
382 Choices
.Set_Last
(Choice_Lasts
.Table
(Choice_Lasts
.Last
));
383 Choice_First
:= Choice_Lasts
.Table
(Choice_Lasts
.Last
- 1) + 1;
385 end End_Case_Construction
;
387 ------------------------
388 -- External_Reference --
389 ------------------------
391 procedure External_Reference
392 (In_Tree
: Project_Node_Tree_Ref
;
393 Current_Project
: Project_Node_Id
;
394 Current_Package
: Project_Node_Id
;
395 External_Value
: out Project_Node_Id
;
396 Expr_Kind
: in out Variable_Kind
;
397 Flags
: Processing_Flags
)
399 Field_Id
: Project_Node_Id
:= Empty_Node
;
400 Ext_List
: Boolean := False;
405 (Of_Kind
=> N_External_Value
,
407 Set_Location_Of
(External_Value
, In_Tree
, To
=> Token_Ptr
);
409 -- The current token is either external or external_as_list
411 Ext_List
:= Token
= Tok_External_As_List
;
415 Set_Expression_Kind_Of
(External_Value
, In_Tree
, To
=> List
);
417 Set_Expression_Kind_Of
(External_Value
, In_Tree
, To
=> Single
);
420 if Expr_Kind
= Undefined
then
428 Expect
(Tok_Left_Paren
, "`(`");
430 -- Scan past the left parenthesis
432 if Token
= Tok_Left_Paren
then
436 -- Get the name of the external reference
438 Expect
(Tok_String_Literal
, "literal string");
440 if Token
= Tok_String_Literal
then
443 (Of_Kind
=> N_Literal_String
,
445 And_Expr_Kind
=> Single
);
446 Set_String_Value_Of
(Field_Id
, In_Tree
, To
=> Token_Name
);
447 Set_External_Reference_Of
(External_Value
, In_Tree
, To
=> Field_Id
);
449 -- Scan past the first argument
454 when Tok_Right_Paren
=>
456 Error_Msg
(Flags
, "`,` expected", Token_Ptr
);
459 Scan
(In_Tree
); -- scan past right paren
462 Scan
(In_Tree
); -- scan past comma
464 -- Get the string expression for the default
467 Loc
: constant Source_Ptr
:= Token_Ptr
;
472 Expression
=> Field_Id
,
474 Current_Project
=> Current_Project
,
475 Current_Package
=> Current_Package
,
476 Optional_Index
=> False);
478 if Expression_Kind_Of
(Field_Id
, In_Tree
) = List
then
480 (Flags
, "expression must be a single string", Loc
);
482 Set_External_Default_Of
483 (External_Value
, In_Tree
, To
=> Field_Id
);
487 Expect
(Tok_Right_Paren
, "`)`");
489 if Token
= Tok_Right_Paren
then
490 Scan
(In_Tree
); -- scan past right paren
495 Error_Msg
(Flags
, "`,` expected", Token_Ptr
);
497 Error_Msg
(Flags
, "`,` or `)` expected", Token_Ptr
);
501 end External_Reference
;
503 -----------------------
504 -- Parse_Choice_List --
505 -----------------------
507 procedure Parse_Choice_List
508 (In_Tree
: Project_Node_Tree_Ref
;
509 First_Choice
: out Project_Node_Id
;
510 Flags
: Processing_Flags
;
511 String_Type
: Boolean := True)
513 Current_Choice
: Project_Node_Id
:= Empty_Node
;
514 Next_Choice
: Project_Node_Id
:= Empty_Node
;
515 Choice_String
: Name_Id
:= No_Name
;
516 Found
: Boolean := False;
519 -- Declare the node of the first choice
523 (Of_Kind
=> N_Literal_String
,
525 And_Expr_Kind
=> Single
);
527 -- Initially Current_Choice is the same as First_Choice
529 Current_Choice
:= First_Choice
;
532 Expect
(Tok_String_Literal
, "literal string");
533 exit when Token
/= Tok_String_Literal
;
534 Set_Location_Of
(Current_Choice
, In_Tree
, To
=> Token_Ptr
);
535 Choice_String
:= Token_Name
;
537 -- Give the string value to the current choice
539 Set_String_Value_Of
(Current_Choice
, In_Tree
, To
=> Choice_String
);
543 -- Check if the label is part of the string type and if it has not
544 -- been already used.
547 for Choice
in Choice_First
.. Choices
.Last
loop
548 if Choices
.Table
(Choice
).The_String
= Choice_String
then
550 -- This label is part of the string type
554 if Choices
.Table
(Choice
).Already_Used
then
556 -- But it has already appeared in a choice list for this
557 -- case construction so report an error.
559 Error_Msg_Name_1
:= Choice_String
;
560 Error_Msg
(Flags
, "duplicate case label %%", Token_Ptr
);
563 Choices
.Table
(Choice
).Already_Used
:= True;
570 -- If the label is not part of the string list, report an error
573 Error_Msg_Name_1
:= Choice_String
;
574 Error_Msg
(Flags
, "illegal case label %%", Token_Ptr
);
578 -- Scan past the label
582 -- If there is no '|', we are done
584 if Token
= Tok_Vertical_Bar
then
586 -- Otherwise, declare the node of the next choice, link it to
587 -- Current_Choice and set Current_Choice to this new node.
591 (Of_Kind
=> N_Literal_String
,
593 And_Expr_Kind
=> Single
);
594 Set_Next_Literal_String
595 (Current_Choice
, In_Tree
, To
=> Next_Choice
);
596 Current_Choice
:= Next_Choice
;
602 end Parse_Choice_List
;
604 ----------------------
605 -- Parse_Expression --
606 ----------------------
608 procedure Parse_Expression
609 (In_Tree
: Project_Node_Tree_Ref
;
610 Expression
: out Project_Node_Id
;
611 Current_Project
: Project_Node_Id
;
612 Current_Package
: Project_Node_Id
;
613 Optional_Index
: Boolean;
614 Flags
: Processing_Flags
)
616 First_Term
: Project_Node_Id
:= Empty_Node
;
617 Expression_Kind
: Variable_Kind
:= Undefined
;
620 -- Declare the node of the expression
623 Default_Project_Node
(Of_Kind
=> N_Expression
, In_Tree
=> In_Tree
);
624 Set_Location_Of
(Expression
, In_Tree
, To
=> Token_Ptr
);
626 -- Parse the term or terms of the expression
628 Terms
(In_Tree
=> In_Tree
,
630 Expr_Kind
=> Expression_Kind
,
632 Current_Project
=> Current_Project
,
633 Current_Package
=> Current_Package
,
634 Optional_Index
=> Optional_Index
);
636 -- Set the first term and the expression kind
638 Set_First_Term
(Expression
, In_Tree
, To
=> First_Term
);
639 Set_Expression_Kind_Of
(Expression
, In_Tree
, To
=> Expression_Kind
);
640 end Parse_Expression
;
642 ----------------------------
643 -- Parse_String_Type_List --
644 ----------------------------
646 procedure Parse_String_Type_List
647 (In_Tree
: Project_Node_Tree_Ref
;
648 First_String
: out Project_Node_Id
;
649 Flags
: Processing_Flags
)
651 Last_String
: Project_Node_Id
:= Empty_Node
;
652 Next_String
: Project_Node_Id
:= Empty_Node
;
653 String_Value
: Name_Id
:= No_Name
;
656 -- Declare the node of the first string
660 (Of_Kind
=> N_Literal_String
,
662 And_Expr_Kind
=> Single
);
664 -- Initially, Last_String is the same as First_String
666 Last_String
:= First_String
;
669 Expect
(Tok_String_Literal
, "literal string");
670 exit when Token
/= Tok_String_Literal
;
671 String_Value
:= Token_Name
;
673 -- Give its string value to Last_String
675 Set_String_Value_Of
(Last_String
, In_Tree
, To
=> String_Value
);
676 Set_Location_Of
(Last_String
, In_Tree
, To
=> Token_Ptr
);
678 -- Now, check if the string is already part of the string type
681 Current
: Project_Node_Id
:= First_String
;
684 while Current
/= Last_String
loop
685 if String_Value_Of
(Current
, In_Tree
) = String_Value
then
687 -- This is a repetition, report an error
689 Error_Msg_Name_1
:= String_Value
;
690 Error_Msg
(Flags
, "duplicate value %% in type", Token_Ptr
);
694 Current
:= Next_Literal_String
(Current
, In_Tree
);
698 -- Scan past the literal string
702 -- If there is no comma following the literal string, we are done
704 if Token
/= Tok_Comma
then
708 -- Declare the next string, link it to Last_String and set
709 -- Last_String to its node.
713 (Of_Kind
=> N_Literal_String
,
715 And_Expr_Kind
=> Single
);
716 Set_Next_Literal_String
(Last_String
, In_Tree
, To
=> Next_String
);
717 Last_String
:= Next_String
;
721 end Parse_String_Type_List
;
723 ------------------------------
724 -- Parse_Variable_Reference --
725 ------------------------------
727 procedure Parse_Variable_Reference
728 (In_Tree
: Project_Node_Tree_Ref
;
729 Variable
: out Project_Node_Id
;
730 Current_Project
: Project_Node_Id
;
731 Current_Package
: Project_Node_Id
;
732 Flags
: Processing_Flags
)
734 Current_Variable
: Project_Node_Id
:= Empty_Node
;
736 The_Package
: Project_Node_Id
:= Current_Package
;
737 The_Project
: Project_Node_Id
:= Current_Project
;
739 Specified_Project
: Project_Node_Id
:= Empty_Node
;
740 Specified_Package
: Project_Node_Id
:= Empty_Node
;
741 Look_For_Variable
: Boolean := True;
742 First_Attribute
: Attribute_Node_Id
:= Empty_Attribute
;
743 Variable_Name
: Name_Id
;
749 Expect
(Tok_Identifier
, "identifier");
751 if Token
/= Tok_Identifier
then
752 Look_For_Variable
:= False;
756 Add_To_Names
(NL
=> (Name
=> Token_Name
, Location
=> Token_Ptr
));
758 exit when Token
/= Tok_Dot
;
762 if Look_For_Variable
then
764 if Token
= Tok_Apostrophe
then
766 -- Attribute reference
776 -- This may be a project name or a package name.
777 -- Project name have precedence.
779 -- First, look if it can be a package name
783 (Package_Node_Id_Of
(Names
.Table
(1).Name
));
785 -- Now, look if it can be a project name
787 if Names
.Table
(1).Name
=
788 Name_Of
(Current_Project
, In_Tree
)
790 The_Project
:= Current_Project
;
794 Imported_Or_Extended_Project_Of
795 (Current_Project
, In_Tree
, Names
.Table
(1).Name
);
798 if No
(The_Project
) then
800 -- If it is neither a project name nor a package name,
803 if First_Attribute
= Empty_Attribute
then
804 Error_Msg_Name_1
:= Names
.Table
(1).Name
;
805 Error_Msg
(Flags
, "unknown project %",
806 Names
.Table
(1).Location
);
807 First_Attribute
:= Attribute_First
;
810 -- If it is a package name, check if the package has
811 -- already been declared in the current project.
814 First_Package_Of
(Current_Project
, In_Tree
);
816 while Present
(The_Package
)
817 and then Name_Of
(The_Package
, In_Tree
) /=
821 Next_Package_In_Project
(The_Package
, In_Tree
);
824 -- If it has not been already declared, report an
827 if No
(The_Package
) then
828 Error_Msg_Name_1
:= Names
.Table
(1).Name
;
829 Error_Msg
(Flags
, "package % not yet defined",
830 Names
.Table
(1).Location
);
835 -- It is a project name
837 First_Attribute
:= Attribute_First
;
838 The_Package
:= Empty_Node
;
843 -- We have either a project name made of several simple
844 -- names (long project), or a project name (short project)
845 -- followed by a package name. The long project name has
849 Short_Project
: Name_Id
;
850 Long_Project
: Name_Id
;
857 -- Get the name of the short project
859 for Index
in 1 .. Names
.Last
- 1 loop
861 (Get_Name_String
(Names
.Table
(Index
).Name
),
862 Buffer
, Buffer_Last
);
864 if Index
/= Names
.Last
- 1 then
865 Add_To_Buffer
(".", Buffer
, Buffer_Last
);
869 Name_Len
:= Buffer_Last
;
870 Name_Buffer
(1 .. Buffer_Last
) :=
871 Buffer
(1 .. Buffer_Last
);
872 Short_Project
:= Name_Find
;
874 -- Now, add the last simple name to get the name of the
877 Add_To_Buffer
(".", Buffer
, Buffer_Last
);
879 (Get_Name_String
(Names
.Table
(Names
.Last
).Name
),
880 Buffer
, Buffer_Last
);
881 Name_Len
:= Buffer_Last
;
882 Name_Buffer
(1 .. Buffer_Last
) :=
883 Buffer
(1 .. Buffer_Last
);
884 Long_Project
:= Name_Find
;
886 -- Check if the long project is imported or extended
888 if Long_Project
= Name_Of
(Current_Project
, In_Tree
) then
889 The_Project
:= Current_Project
;
893 Imported_Or_Extended_Project_Of
899 -- If the long project exists, then this is the prefix
902 if Present
(The_Project
) then
903 First_Attribute
:= Attribute_First
;
904 The_Package
:= Empty_Node
;
907 -- Otherwise, check if the short project is imported
911 Name_Of
(Current_Project
, In_Tree
)
913 The_Project
:= Current_Project
;
916 The_Project
:= Imported_Or_Extended_Project_Of
917 (Current_Project
, In_Tree
,
921 -- If short project does not exist, report an error
923 if No
(The_Project
) then
924 Error_Msg_Name_1
:= Long_Project
;
925 Error_Msg_Name_2
:= Short_Project
;
926 Error_Msg
(Flags
, "unknown projects % or %",
927 Names
.Table
(1).Location
);
928 The_Package
:= Empty_Node
;
929 First_Attribute
:= Attribute_First
;
932 -- Now, we check if the package has been declared
936 First_Package_Of
(The_Project
, In_Tree
);
937 while Present
(The_Package
)
938 and then Name_Of
(The_Package
, In_Tree
) /=
939 Names
.Table
(Names
.Last
).Name
942 Next_Package_In_Project
(The_Package
, In_Tree
);
945 -- If it has not, then we report an error
947 if No
(The_Package
) then
949 Names
.Table
(Names
.Last
).Name
;
950 Error_Msg_Name_2
:= Short_Project
;
952 "package % not declared in project %",
953 Names
.Table
(Names
.Last
).Location
);
954 First_Attribute
:= Attribute_First
;
957 -- Otherwise, we have the correct project and
962 (Package_Id_Of
(The_Package
, In_Tree
));
973 Current_Project
=> The_Project
,
974 Current_Package
=> The_Package
,
975 First_Attribute
=> First_Attribute
);
982 (Of_Kind
=> N_Variable_Reference
, In_Tree
=> In_Tree
);
984 if Look_For_Variable
then
988 -- Cannot happen (so why null instead of raise PE???)
994 -- Simple variable name
996 Set_Name_Of
(Variable
, In_Tree
, To
=> Names
.Table
(1).Name
);
1000 -- Variable name with a simple name prefix that can be
1001 -- a project name or a package name. Project names have
1002 -- priority over package names.
1004 Set_Name_Of
(Variable
, In_Tree
, To
=> Names
.Table
(2).Name
);
1006 -- Check if it can be a package name
1008 The_Package
:= First_Package_Of
(Current_Project
, In_Tree
);
1010 while Present
(The_Package
)
1011 and then Name_Of
(The_Package
, In_Tree
) /=
1012 Names
.Table
(1).Name
1015 Next_Package_In_Project
(The_Package
, In_Tree
);
1018 -- Now look for a possible project name
1020 The_Project
:= Imported_Or_Extended_Project_Of
1021 (Current_Project
, In_Tree
, Names
.Table
(1).Name
);
1023 if Present
(The_Project
) then
1024 Specified_Project
:= The_Project
;
1026 elsif No
(The_Package
) then
1027 Error_Msg_Name_1
:= Names
.Table
(1).Name
;
1028 Error_Msg
(Flags
, "unknown package or project %",
1029 Names
.Table
(1).Location
);
1030 Look_For_Variable
:= False;
1033 Specified_Package
:= The_Package
;
1038 -- Variable name with a prefix that is either a project name
1039 -- made of several simple names, or a project name followed
1040 -- by a package name.
1043 (Variable
, In_Tree
, To
=> Names
.Table
(Names
.Last
).Name
);
1046 Short_Project
: Name_Id
;
1047 Long_Project
: Name_Id
;
1050 -- First, we get the two possible project names
1056 -- Add all the simple names, except the last two
1058 for Index
in 1 .. Names
.Last
- 2 loop
1060 (Get_Name_String
(Names
.Table
(Index
).Name
),
1061 Buffer
, Buffer_Last
);
1063 if Index
/= Names
.Last
- 2 then
1064 Add_To_Buffer
(".", Buffer
, Buffer_Last
);
1068 Name_Len
:= Buffer_Last
;
1069 Name_Buffer
(1 .. Name_Len
) := Buffer
(1 .. Buffer_Last
);
1070 Short_Project
:= Name_Find
;
1072 -- Add the simple name before the name of the variable
1074 Add_To_Buffer
(".", Buffer
, Buffer_Last
);
1076 (Get_Name_String
(Names
.Table
(Names
.Last
- 1).Name
),
1077 Buffer
, Buffer_Last
);
1078 Name_Len
:= Buffer_Last
;
1079 Name_Buffer
(1 .. Name_Len
) := Buffer
(1 .. Buffer_Last
);
1080 Long_Project
:= Name_Find
;
1082 -- Check if the prefix is the name of an imported or
1083 -- extended project.
1085 The_Project
:= Imported_Or_Extended_Project_Of
1086 (Current_Project
, In_Tree
, Long_Project
);
1088 if Present
(The_Project
) then
1089 Specified_Project
:= The_Project
;
1092 -- Now check if the prefix may be a project name followed
1093 -- by a package name.
1095 -- First check for a possible project name
1098 Imported_Or_Extended_Project_Of
1099 (Current_Project
, In_Tree
, Short_Project
);
1101 if No
(The_Project
) then
1102 -- Unknown prefix, report an error
1104 Error_Msg_Name_1
:= Long_Project
;
1105 Error_Msg_Name_2
:= Short_Project
;
1107 (Flags
, "unknown projects % or %",
1108 Names
.Table
(1).Location
);
1109 Look_For_Variable
:= False;
1112 Specified_Project
:= The_Project
;
1114 -- Now look for the package in this project
1116 The_Package
:= First_Package_Of
(The_Project
, In_Tree
);
1118 while Present
(The_Package
)
1119 and then Name_Of
(The_Package
, In_Tree
) /=
1120 Names
.Table
(Names
.Last
- 1).Name
1123 Next_Package_In_Project
(The_Package
, In_Tree
);
1126 if No
(The_Package
) then
1128 -- The package does not exist, report an error
1130 Error_Msg_Name_1
:= Names
.Table
(2).Name
;
1131 Error_Msg
(Flags
, "unknown package %",
1132 Names
.Table
(Names
.Last
- 1).Location
);
1133 Look_For_Variable
:= False;
1136 Specified_Package
:= The_Package
;
1144 if Look_For_Variable
then
1145 Variable_Name
:= Name_Of
(Variable
, In_Tree
);
1146 Set_Project_Node_Of
(Variable
, In_Tree
, To
=> Specified_Project
);
1147 Set_Package_Node_Of
(Variable
, In_Tree
, To
=> Specified_Package
);
1149 if Present
(Specified_Project
) then
1150 The_Project
:= Specified_Project
;
1152 The_Project
:= Current_Project
;
1155 Current_Variable
:= Empty_Node
;
1157 -- Look for this variable
1159 -- If a package was specified, check if the variable has been
1160 -- declared in this package.
1162 if Present
(Specified_Package
) then
1164 First_Variable_Of
(Specified_Package
, In_Tree
);
1165 while Present
(Current_Variable
)
1167 Name_Of
(Current_Variable
, In_Tree
) /= Variable_Name
1169 Current_Variable
:= Next_Variable
(Current_Variable
, In_Tree
);
1173 -- Otherwise, if no project has been specified and we are in
1174 -- a package, first check if the variable has been declared in
1177 if No
(Specified_Project
)
1178 and then Present
(Current_Package
)
1181 First_Variable_Of
(Current_Package
, In_Tree
);
1182 while Present
(Current_Variable
)
1183 and then Name_Of
(Current_Variable
, In_Tree
) /= Variable_Name
1186 Next_Variable
(Current_Variable
, In_Tree
);
1190 -- If we have not found the variable in the package, check if the
1191 -- variable has been declared in the project, or in any of its
1192 -- ancestors, or in any of the project it extends.
1194 if No
(Current_Variable
) then
1196 Proj
: Project_Node_Id
:= The_Project
;
1200 Current_Variable
:= First_Variable_Of
(Proj
, In_Tree
);
1202 Present
(Current_Variable
)
1204 Name_Of
(Current_Variable
, In_Tree
) /= Variable_Name
1207 Next_Variable
(Current_Variable
, In_Tree
);
1210 exit when Present
(Current_Variable
);
1212 -- If the current project is a child project, check if
1213 -- the variable is declared in its parent. Otherwise, if
1214 -- the current project extends another project, check if
1215 -- the variable is declared in one of the projects the
1216 -- current project extends.
1218 if No
(Parent_Project_Of
(Proj
, In_Tree
)) then
1221 (Project_Declaration_Of
(Proj
, In_Tree
), In_Tree
);
1223 Proj
:= Parent_Project_Of
(Proj
, In_Tree
);
1226 Set_Project_Node_Of
(Variable
, In_Tree
, To
=> Proj
);
1228 exit when No
(Proj
);
1234 -- If the variable was not found, report an error
1236 if No
(Current_Variable
) then
1237 Error_Msg_Name_1
:= Variable_Name
;
1239 (Flags
, "unknown variable %", Names
.Table
(Names
.Last
).Location
);
1243 if Present
(Current_Variable
) then
1244 Set_Expression_Kind_Of
1246 To
=> Expression_Kind_Of
(Current_Variable
, In_Tree
));
1248 if Kind_Of
(Current_Variable
, In_Tree
) =
1249 N_Typed_Variable_Declaration
1253 To
=> String_Type_Of
(Current_Variable
, In_Tree
));
1257 -- If the variable is followed by a left parenthesis, report an error
1258 -- but attempt to scan the index.
1260 if Token
= Tok_Left_Paren
then
1262 (Flags
, "\variables cannot be associative arrays", Token_Ptr
);
1264 Expect
(Tok_String_Literal
, "literal string");
1266 if Token
= Tok_String_Literal
then
1268 Expect
(Tok_Right_Paren
, "`)`");
1270 if Token
= Tok_Right_Paren
then
1275 end Parse_Variable_Reference
;
1277 ---------------------------------
1278 -- Start_New_Case_Construction --
1279 ---------------------------------
1281 procedure Start_New_Case_Construction
1282 (In_Tree
: Project_Node_Tree_Ref
;
1283 String_Type
: Project_Node_Id
)
1285 Current_String
: Project_Node_Id
;
1288 -- Set Choice_First, depending on whether this is the first case
1289 -- construction or not.
1291 if Choice_First
= 0 then
1293 Choices
.Set_Last
(First_Choice_Node_Id
);
1295 Choice_First
:= Choices
.Last
+ 1;
1298 -- Add the literal of the string type to the Choices table
1300 if Present
(String_Type
) then
1301 Current_String
:= First_Literal_String
(String_Type
, In_Tree
);
1302 while Present
(Current_String
) loop
1303 Add
(This_String
=> String_Value_Of
(Current_String
, In_Tree
));
1304 Current_String
:= Next_Literal_String
(Current_String
, In_Tree
);
1308 -- Set the value of the last choice in table Choice_Lasts
1310 Choice_Lasts
.Increment_Last
;
1311 Choice_Lasts
.Table
(Choice_Lasts
.Last
) := Choices
.Last
;
1312 end Start_New_Case_Construction
;
1319 (In_Tree
: Project_Node_Tree_Ref
;
1320 Term
: out Project_Node_Id
;
1321 Expr_Kind
: in out Variable_Kind
;
1322 Current_Project
: Project_Node_Id
;
1323 Current_Package
: Project_Node_Id
;
1324 Optional_Index
: Boolean;
1325 Flags
: Processing_Flags
)
1327 Next_Term
: Project_Node_Id
:= Empty_Node
;
1328 Term_Id
: Project_Node_Id
:= Empty_Node
;
1329 Current_Expression
: Project_Node_Id
:= Empty_Node
;
1330 Next_Expression
: Project_Node_Id
:= Empty_Node
;
1331 Current_Location
: Source_Ptr
:= No_Location
;
1332 Reference
: Project_Node_Id
:= Empty_Node
;
1335 -- Declare a new node for the term
1337 Term
:= Default_Project_Node
(Of_Kind
=> N_Term
, In_Tree
=> In_Tree
);
1338 Set_Location_Of
(Term
, In_Tree
, To
=> Token_Ptr
);
1341 when Tok_Left_Paren
=>
1343 -- If we have a left parenthesis and we don't know the expression
1344 -- kind, then this is a string list.
1355 -- If we already know that this is a single string, report
1356 -- an error, but set the expression kind to string list to
1357 -- avoid several errors.
1361 (Flags
, "literal string list cannot appear in a string",
1365 -- Declare a new node for this literal string list
1367 Term_Id
:= Default_Project_Node
1368 (Of_Kind
=> N_Literal_String_List
,
1370 And_Expr_Kind
=> List
);
1371 Set_Current_Term
(Term
, In_Tree
, To
=> Term_Id
);
1372 Set_Location_Of
(Term
, In_Tree
, To
=> Token_Ptr
);
1374 -- Scan past the left parenthesis
1378 -- If the left parenthesis is immediately followed by a right
1379 -- parenthesis, the literal string list is empty.
1381 if Token
= Tok_Right_Paren
then
1385 -- Otherwise parse the expression(s) in the literal string list
1388 Current_Location
:= Token_Ptr
;
1390 (In_Tree
=> In_Tree
,
1391 Expression
=> Next_Expression
,
1393 Current_Project
=> Current_Project
,
1394 Current_Package
=> Current_Package
,
1395 Optional_Index
=> Optional_Index
);
1397 -- The expression kind is String list, report an error
1399 if Expression_Kind_Of
(Next_Expression
, In_Tree
) = List
then
1400 Error_Msg
(Flags
, "single expression expected",
1404 -- If Current_Expression is empty, it means that the
1405 -- expression is the first in the string list.
1407 if No
(Current_Expression
) then
1408 Set_First_Expression_In_List
1409 (Term_Id
, In_Tree
, To
=> Next_Expression
);
1411 Set_Next_Expression_In_List
1412 (Current_Expression
, In_Tree
, To
=> Next_Expression
);
1415 Current_Expression
:= Next_Expression
;
1417 -- If there is a comma, continue with the next expression
1419 exit when Token
/= Tok_Comma
;
1420 Scan
(In_Tree
); -- past the comma
1423 -- We expect a closing right parenthesis
1425 Expect
(Tok_Right_Paren
, "`)`");
1427 if Token
= Tok_Right_Paren
then
1432 when Tok_String_Literal
=>
1434 -- If we don't know the expression kind (first term), then it is
1437 if Expr_Kind
= Undefined
then
1438 Expr_Kind
:= Single
;
1441 -- Declare a new node for the string literal
1444 Default_Project_Node
1445 (Of_Kind
=> N_Literal_String
, In_Tree
=> In_Tree
);
1446 Set_Current_Term
(Term
, In_Tree
, To
=> Term_Id
);
1447 Set_String_Value_Of
(Term_Id
, In_Tree
, To
=> Token_Name
);
1449 -- Scan past the string literal
1453 -- Check for possible index expression
1455 if Token
= Tok_At
then
1456 if not Optional_Index
then
1457 Error_Msg
(Flags
, "index not allowed here", Token_Ptr
);
1460 if Token
= Tok_Integer_Literal
then
1464 -- Set the index value
1468 Expect
(Tok_Integer_Literal
, "integer literal");
1470 if Token
= Tok_Integer_Literal
then
1472 Index
: constant Int
:= UI_To_Int
(Int_Literal_Value
);
1476 (Flags
, "index cannot be zero", Token_Ptr
);
1479 (Term_Id
, In_Tree
, To
=> Index
);
1488 when Tok_Identifier
=>
1489 Current_Location
:= Token_Ptr
;
1491 -- Get the variable or attribute reference
1493 Parse_Variable_Reference
1494 (In_Tree
=> In_Tree
,
1495 Variable
=> Reference
,
1497 Current_Project
=> Current_Project
,
1498 Current_Package
=> Current_Package
);
1499 Set_Current_Term
(Term
, In_Tree
, To
=> Reference
);
1501 if Present
(Reference
) then
1503 -- If we don't know the expression kind (first term), then it
1504 -- has the kind of the variable or attribute reference.
1506 if Expr_Kind
= Undefined
then
1507 Expr_Kind
:= Expression_Kind_Of
(Reference
, In_Tree
);
1509 elsif Expr_Kind
= Single
1510 and then Expression_Kind_Of
(Reference
, In_Tree
) = List
1512 -- If the expression is a single list, and the reference is
1513 -- a string list, report an error, and set the expression
1514 -- kind to string list to avoid multiple errors.
1519 "list variable cannot appear in single string expression",
1526 -- Project can appear in an expression as the prefix of an
1527 -- attribute reference of the current project.
1529 Current_Location
:= Token_Ptr
;
1531 Expect
(Tok_Apostrophe
, "`'`");
1533 if Token
= Tok_Apostrophe
then
1535 (In_Tree
=> In_Tree
,
1536 Reference
=> Reference
,
1538 First_Attribute
=> Prj
.Attr
.Attribute_First
,
1539 Current_Project
=> Current_Project
,
1540 Current_Package
=> Empty_Node
);
1541 Set_Current_Term
(Term
, In_Tree
, To
=> Reference
);
1544 -- Same checks as above for the expression kind
1546 if Present
(Reference
) then
1547 if Expr_Kind
= Undefined
then
1548 Expr_Kind
:= Expression_Kind_Of
(Reference
, In_Tree
);
1550 elsif Expr_Kind
= Single
1551 and then Expression_Kind_Of
(Reference
, In_Tree
) = List
1554 (Flags
, "lists cannot appear in single string expression",
1559 when Tok_External | Tok_External_As_List
=>
1561 (In_Tree
=> In_Tree
,
1563 Current_Project
=> Current_Project
,
1564 Current_Package
=> Current_Package
,
1565 Expr_Kind
=> Expr_Kind
,
1566 External_Value
=> Reference
);
1567 Set_Current_Term
(Term
, In_Tree
, To
=> Reference
);
1570 Error_Msg
(Flags
, "cannot be part of an expression", Token_Ptr
);
1575 -- If there is an '&', call Terms recursively
1577 if Token
= Tok_Ampersand
then
1578 Scan
(In_Tree
); -- scan past ampersand
1581 (In_Tree
=> In_Tree
,
1583 Expr_Kind
=> Expr_Kind
,
1585 Current_Project
=> Current_Project
,
1586 Current_Package
=> Current_Package
,
1587 Optional_Index
=> Optional_Index
);
1589 -- And link the next term to this term
1591 Set_Next_Term
(Term
, In_Tree
, To
=> Next_Term
);