1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2005 Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Err_Vars
; use Err_Vars
;
28 with Namet
; use Namet
;
29 with Prj
.Attr
; use Prj
.Attr
;
30 with Prj
.Err
; use Prj
.Err
;
31 with Prj
.Tree
; use Prj
.Tree
;
32 with Scans
; use Scans
;
35 with Types
; use Types
;
36 with Uintp
; use Uintp
;
38 package body Prj
.Strt
is
40 Buffer
: String_Access
;
41 Buffer_Last
: Natural := 0;
43 type Choice_String
is record
45 Already_Used
: Boolean := False;
47 -- The string of a case label, and an indication that it has already
48 -- been used (to avoid duplicate case labels).
50 Choices_Initial
: constant := 10;
51 Choices_Increment
: constant := 50;
53 Choice_Node_Low_Bound
: constant := 0;
54 Choice_Node_High_Bound
: constant := 099_999_999
;
55 -- In practice, infinite
57 type Choice_Node_Id
is
58 range Choice_Node_Low_Bound
.. Choice_Node_High_Bound
;
60 First_Choice_Node_Id
: constant Choice_Node_Id
:=
61 Choice_Node_Low_Bound
;
64 new Table
.Table
(Table_Component_Type
=> Choice_String
,
65 Table_Index_Type
=> Choice_Node_Id
,
66 Table_Low_Bound
=> First_Choice_Node_Id
,
67 Table_Initial
=> Choices_Initial
,
68 Table_Increment
=> Choices_Increment
,
69 Table_Name
=> "Prj.Strt.Choices");
70 -- Used to store the case labels and check that there is no duplicate.
72 package Choice_Lasts
is
73 new Table
.Table
(Table_Component_Type
=> Choice_Node_Id
,
74 Table_Index_Type
=> Nat
,
77 Table_Increment
=> 100,
78 Table_Name
=> "Prj.Strt.Choice_Lasts");
79 -- Used to store the indices of the choices in table Choices,
80 -- to distinguish nested case constructions.
82 Choice_First
: Choice_Node_Id
:= 0;
83 -- Index in table Choices of the first case label of the current
84 -- case construction. Zero means no current case construction.
86 type Name_Location
is record
87 Name
: Name_Id
:= No_Name
;
88 Location
: Source_Ptr
:= No_Location
;
90 -- Store the identifier and the location of a simple name
93 new Table
.Table
(Table_Component_Type
=> Name_Location
,
94 Table_Index_Type
=> Nat
,
97 Table_Increment
=> 100,
98 Table_Name
=> "Prj.Strt.Names");
99 -- Used to accumulate the single names of a name
101 procedure Add
(This_String
: Name_Id
);
102 -- Add a string to the case label list, indicating that it has not
105 procedure Add_To_Names
(NL
: Name_Location
);
106 -- Add one single names to table Names
108 procedure External_Reference
109 (In_Tree
: Project_Node_Tree_Ref
;
110 Current_Project
: Project_Node_Id
;
111 Current_Package
: Project_Node_Id
;
112 External_Value
: out Project_Node_Id
);
113 -- Parse an external reference. Current token is "external".
115 procedure Attribute_Reference
116 (In_Tree
: Project_Node_Tree_Ref
;
117 Reference
: out Project_Node_Id
;
118 First_Attribute
: Attribute_Node_Id
;
119 Current_Project
: Project_Node_Id
;
120 Current_Package
: Project_Node_Id
);
121 -- Parse an attribute reference. Current token is an apostrophe.
124 (In_Tree
: Project_Node_Tree_Ref
;
125 Term
: out Project_Node_Id
;
126 Expr_Kind
: in out Variable_Kind
;
127 Current_Project
: Project_Node_Id
;
128 Current_Package
: Project_Node_Id
;
129 Optional_Index
: Boolean);
130 -- Recursive procedure to parse one term or several terms concatenated
137 procedure Add
(This_String
: Name_Id
) is
139 Choices
.Increment_Last
;
140 Choices
.Table
(Choices
.Last
) :=
141 (The_String
=> This_String
,
142 Already_Used
=> False);
149 procedure Add_To_Names
(NL
: Name_Location
) is
151 Names
.Increment_Last
;
152 Names
.Table
(Names
.Last
) := NL
;
155 -------------------------
156 -- Attribute_Reference --
157 -------------------------
159 procedure Attribute_Reference
160 (In_Tree
: Project_Node_Tree_Ref
;
161 Reference
: out Project_Node_Id
;
162 First_Attribute
: Attribute_Node_Id
;
163 Current_Project
: Project_Node_Id
;
164 Current_Package
: Project_Node_Id
)
166 Current_Attribute
: Attribute_Node_Id
:= First_Attribute
;
169 -- Declare the node of the attribute reference
173 (Of_Kind
=> N_Attribute_Reference
, In_Tree
=> In_Tree
);
174 Set_Location_Of
(Reference
, In_Tree
, To
=> Token_Ptr
);
175 Scan
(In_Tree
); -- past apostrophe
177 -- Body may be an attribute name
179 if Token
= Tok_Body
then
180 Token
:= Tok_Identifier
;
181 Token_Name
:= Snames
.Name_Body
;
184 Expect
(Tok_Identifier
, "identifier");
186 if Token
= Tok_Identifier
then
187 Set_Name_Of
(Reference
, In_Tree
, To
=> Token_Name
);
189 -- Check if the identifier is one of the attribute identifiers in the
190 -- context (package or project level attributes).
193 Attribute_Node_Id_Of
(Token_Name
, Starting_At
=> First_Attribute
);
195 -- If the identifier is not allowed, report an error
197 if Current_Attribute
= Empty_Attribute
then
198 Error_Msg_Name_1
:= Token_Name
;
199 Error_Msg
("unknown attribute %", Token_Ptr
);
200 Reference
:= Empty_Node
;
202 -- Scan past the attribute name
207 -- Give its characteristics to this attribute reference
209 Set_Project_Node_Of
(Reference
, In_Tree
, To
=> Current_Project
);
210 Set_Package_Node_Of
(Reference
, In_Tree
, To
=> Current_Package
);
211 Set_Expression_Kind_Of
212 (Reference
, In_Tree
, To
=> Variable_Kind_Of
(Current_Attribute
));
215 To
=> Attribute_Kind_Of
(Current_Attribute
) =
216 Case_Insensitive_Associative_Array
);
218 -- Scan past the attribute name
222 -- If the attribute is an associative array, get the index
224 if Attribute_Kind_Of
(Current_Attribute
) /= Single
then
225 Expect
(Tok_Left_Paren
, "`(`");
227 if Token
= Tok_Left_Paren
then
229 Expect
(Tok_String_Literal
, "literal string");
231 if Token
= Tok_String_Literal
then
232 Set_Associative_Array_Index_Of
233 (Reference
, In_Tree
, To
=> Token_Name
);
235 Expect
(Tok_Right_Paren
, "`)`");
237 if Token
= Tok_Right_Paren
then
245 -- Change name of obsolete attributes
247 if Reference
/= Empty_Node
then
248 case Name_Of
(Reference
, In_Tree
) is
249 when Snames
.Name_Specification
=>
250 Set_Name_Of
(Reference
, In_Tree
, To
=> Snames
.Name_Spec
);
252 when Snames
.Name_Specification_Suffix
=>
254 (Reference
, In_Tree
, To
=> Snames
.Name_Spec_Suffix
);
256 when Snames
.Name_Implementation
=>
257 Set_Name_Of
(Reference
, In_Tree
, To
=> Snames
.Name_Body
);
259 when Snames
.Name_Implementation_Suffix
=>
261 (Reference
, In_Tree
, To
=> Snames
.Name_Body_Suffix
);
268 end Attribute_Reference
;
270 ---------------------------
271 -- End_Case_Construction --
272 ---------------------------
274 procedure End_Case_Construction
275 (Check_All_Labels
: Boolean;
276 Case_Location
: Source_Ptr
)
278 Non_Used
: Natural := 0;
279 First_Non_Used
: Choice_Node_Id
:= First_Choice_Node_Id
;
281 -- First, if Check_All_Labels is True, check if all values
282 -- of the string type have been used.
284 if Check_All_Labels
then
285 for Choice
in Choice_First
.. Choices
.Last
loop
286 if not Choices
.Table
(Choice
).Already_Used
then
287 Non_Used
:= Non_Used
+ 1;
290 First_Non_Used
:= Choice
;
295 -- If only one is not used, report a single warning for this value
298 Error_Msg_Name_1
:= Choices
.Table
(First_Non_Used
).The_String
;
299 Error_Msg
("?value { is not used as label", Case_Location
);
301 -- If several are not used, report a warning for each one of them
303 elsif Non_Used
> 1 then
305 ("?the following values are not used as labels:",
308 for Choice
in First_Non_Used
.. Choices
.Last
loop
309 if not Choices
.Table
(Choice
).Already_Used
then
310 Error_Msg_Name_1
:= Choices
.Table
(Choice
).The_String
;
311 Error_Msg
("\?{", Case_Location
);
317 -- If this is the only case construction, empty the tables
319 if Choice_Lasts
.Last
= 1 then
320 Choice_Lasts
.Set_Last
(0);
321 Choices
.Set_Last
(First_Choice_Node_Id
);
324 elsif Choice_Lasts
.Last
= 2 then
325 -- This is the second case onstruction, set the tables to the first
327 Choice_Lasts
.Set_Last
(1);
328 Choices
.Set_Last
(Choice_Lasts
.Table
(1));
332 -- This is the 3rd or more case construction, set the tables to the
335 Choice_Lasts
.Decrement_Last
;
336 Choices
.Set_Last
(Choice_Lasts
.Table
(Choice_Lasts
.Last
));
337 Choice_First
:= Choice_Lasts
.Table
(Choice_Lasts
.Last
- 1) + 1;
339 end End_Case_Construction
;
341 ------------------------
342 -- External_Reference --
343 ------------------------
345 procedure External_Reference
346 (In_Tree
: Project_Node_Tree_Ref
;
347 Current_Project
: Project_Node_Id
;
348 Current_Package
: Project_Node_Id
;
349 External_Value
: out Project_Node_Id
)
351 Field_Id
: Project_Node_Id
:= Empty_Node
;
356 (Of_Kind
=> N_External_Value
,
358 And_Expr_Kind
=> Single
);
359 Set_Location_Of
(External_Value
, In_Tree
, To
=> Token_Ptr
);
361 -- The current token is External
363 -- Get the left parenthesis
366 Expect
(Tok_Left_Paren
, "`(`");
368 -- Scan past the left parenthesis
370 if Token
= Tok_Left_Paren
then
374 -- Get the name of the external reference
376 Expect
(Tok_String_Literal
, "literal string");
378 if Token
= Tok_String_Literal
then
381 (Of_Kind
=> N_Literal_String
,
383 And_Expr_Kind
=> Single
);
384 Set_String_Value_Of
(Field_Id
, In_Tree
, To
=> Token_Name
);
385 Set_External_Reference_Of
(External_Value
, In_Tree
, To
=> Field_Id
);
387 -- Scan past the first argument
393 when Tok_Right_Paren
=>
395 -- Scan past the right parenthesis
400 -- Scan past the comma
404 -- Get the string expression for the default
407 Loc
: constant Source_Ptr
:= Token_Ptr
;
412 Expression
=> Field_Id
,
413 Current_Project
=> Current_Project
,
414 Current_Package
=> Current_Package
,
415 Optional_Index
=> False);
417 if Expression_Kind_Of
(Field_Id
, In_Tree
) = List
then
418 Error_Msg
("expression must be a single string", Loc
);
420 Set_External_Default_Of
421 (External_Value
, In_Tree
, To
=> Field_Id
);
425 Expect
(Tok_Right_Paren
, "`)`");
427 -- Scan past the right parenthesis
429 if Token
= Tok_Right_Paren
then
434 Error_Msg
("`,` or `)` expected", Token_Ptr
);
437 end External_Reference
;
439 -----------------------
440 -- Parse_Choice_List --
441 -----------------------
443 procedure Parse_Choice_List
444 (In_Tree
: Project_Node_Tree_Ref
;
445 First_Choice
: out Project_Node_Id
)
447 Current_Choice
: Project_Node_Id
:= Empty_Node
;
448 Next_Choice
: Project_Node_Id
:= Empty_Node
;
449 Choice_String
: Name_Id
:= No_Name
;
450 Found
: Boolean := False;
453 -- Declare the node of the first choice
457 (Of_Kind
=> N_Literal_String
,
459 And_Expr_Kind
=> Single
);
461 -- Initially Current_Choice is the same as First_Choice
463 Current_Choice
:= First_Choice
;
466 Expect
(Tok_String_Literal
, "literal string");
467 exit when Token
/= Tok_String_Literal
;
468 Set_Location_Of
(Current_Choice
, In_Tree
, To
=> Token_Ptr
);
469 Choice_String
:= Token_Name
;
471 -- Give the string value to the current choice
473 Set_String_Value_Of
(Current_Choice
, In_Tree
, To
=> Choice_String
);
475 -- Check if the label is part of the string type and if it has not
476 -- been already used.
479 for Choice
in Choice_First
.. Choices
.Last
loop
480 if Choices
.Table
(Choice
).The_String
= Choice_String
then
481 -- This label is part of the string type
485 if Choices
.Table
(Choice
).Already_Used
then
486 -- But it has already appeared in a choice list for this
487 -- case construction; report an error.
489 Error_Msg_Name_1
:= Choice_String
;
490 Error_Msg
("duplicate case label {", Token_Ptr
);
492 Choices
.Table
(Choice
).Already_Used
:= True;
499 -- If the label is not part of the string list, report an error
502 Error_Msg_Name_1
:= Choice_String
;
503 Error_Msg
("illegal case label {", Token_Ptr
);
506 -- Scan past the label
510 -- If there is no '|', we are done
512 if Token
= Tok_Vertical_Bar
then
513 -- Otherwise, declare the node of the next choice, link it to
514 -- Current_Choice and set Current_Choice to this new node.
518 (Of_Kind
=> N_Literal_String
,
520 And_Expr_Kind
=> Single
);
521 Set_Next_Literal_String
522 (Current_Choice
, In_Tree
, To
=> Next_Choice
);
523 Current_Choice
:= Next_Choice
;
529 end Parse_Choice_List
;
531 ----------------------
532 -- Parse_Expression --
533 ----------------------
535 procedure Parse_Expression
536 (In_Tree
: Project_Node_Tree_Ref
;
537 Expression
: out Project_Node_Id
;
538 Current_Project
: Project_Node_Id
;
539 Current_Package
: Project_Node_Id
;
540 Optional_Index
: Boolean)
542 First_Term
: Project_Node_Id
:= Empty_Node
;
543 Expression_Kind
: Variable_Kind
:= Undefined
;
546 -- Declare the node of the expression
549 Default_Project_Node
(Of_Kind
=> N_Expression
, In_Tree
=> In_Tree
);
550 Set_Location_Of
(Expression
, In_Tree
, To
=> Token_Ptr
);
552 -- Parse the term or terms of the expression
554 Terms
(In_Tree
=> In_Tree
,
556 Expr_Kind
=> Expression_Kind
,
557 Current_Project
=> Current_Project
,
558 Current_Package
=> Current_Package
,
559 Optional_Index
=> Optional_Index
);
561 -- Set the first term and the expression kind
563 Set_First_Term
(Expression
, In_Tree
, To
=> First_Term
);
564 Set_Expression_Kind_Of
(Expression
, In_Tree
, To
=> Expression_Kind
);
565 end Parse_Expression
;
567 ----------------------------
568 -- Parse_String_Type_List --
569 ----------------------------
571 procedure Parse_String_Type_List
572 (In_Tree
: Project_Node_Tree_Ref
;
573 First_String
: out Project_Node_Id
)
575 Last_String
: Project_Node_Id
:= Empty_Node
;
576 Next_String
: Project_Node_Id
:= Empty_Node
;
577 String_Value
: Name_Id
:= No_Name
;
580 -- Declare the node of the first string
584 (Of_Kind
=> N_Literal_String
,
586 And_Expr_Kind
=> Single
);
588 -- Initially, Last_String is the same as First_String
590 Last_String
:= First_String
;
593 Expect
(Tok_String_Literal
, "literal string");
594 exit when Token
/= Tok_String_Literal
;
595 String_Value
:= Token_Name
;
597 -- Give its string value to Last_String
599 Set_String_Value_Of
(Last_String
, In_Tree
, To
=> String_Value
);
600 Set_Location_Of
(Last_String
, In_Tree
, To
=> Token_Ptr
);
602 -- Now, check if the string is already part of the string type
605 Current
: Project_Node_Id
:= First_String
;
608 while Current
/= Last_String
loop
609 if String_Value_Of
(Current
, In_Tree
) = String_Value
then
610 -- This is a repetition, report an error
612 Error_Msg_Name_1
:= String_Value
;
613 Error_Msg
("duplicate value { in type", Token_Ptr
);
617 Current
:= Next_Literal_String
(Current
, In_Tree
);
621 -- Scan past the literal string
625 -- If there is no comma following the literal string, we are done
627 if Token
/= Tok_Comma
then
631 -- Declare the next string, link it to Last_String and set
632 -- Last_String to its node.
636 (Of_Kind
=> N_Literal_String
,
638 And_Expr_Kind
=> Single
);
639 Set_Next_Literal_String
(Last_String
, In_Tree
, To
=> Next_String
);
640 Last_String
:= Next_String
;
644 end Parse_String_Type_List
;
646 ------------------------------
647 -- Parse_Variable_Reference --
648 ------------------------------
650 procedure Parse_Variable_Reference
651 (In_Tree
: Project_Node_Tree_Ref
;
652 Variable
: out Project_Node_Id
;
653 Current_Project
: Project_Node_Id
;
654 Current_Package
: Project_Node_Id
)
656 Current_Variable
: Project_Node_Id
:= Empty_Node
;
658 The_Package
: Project_Node_Id
:= Current_Package
;
659 The_Project
: Project_Node_Id
:= Current_Project
;
661 Specified_Project
: Project_Node_Id
:= Empty_Node
;
662 Specified_Package
: Project_Node_Id
:= Empty_Node
;
663 Look_For_Variable
: Boolean := True;
664 First_Attribute
: Attribute_Node_Id
:= Empty_Attribute
;
665 Variable_Name
: Name_Id
;
671 Expect
(Tok_Identifier
, "identifier");
673 if Token
/= Tok_Identifier
then
674 Look_For_Variable
:= False;
678 Add_To_Names
(NL
=> (Name
=> Token_Name
, Location
=> Token_Ptr
));
680 exit when Token
/= Tok_Dot
;
684 if Look_For_Variable
then
686 if Token
= Tok_Apostrophe
then
688 -- Attribute reference
698 -- This may be a project name or a package name.
699 -- Project name have precedence.
701 -- First, look if it can be a package name
705 (Package_Node_Id_Of
(Names
.Table
(1).Name
));
707 -- Now, look if it can be a project name
709 The_Project
:= Imported_Or_Extended_Project_Of
710 (Current_Project
, In_Tree
, Names
.Table
(1).Name
);
712 if The_Project
= Empty_Node
then
713 -- If it is neither a project name nor a package name,
716 if First_Attribute
= Empty_Attribute
then
717 Error_Msg_Name_1
:= Names
.Table
(1).Name
;
718 Error_Msg
("unknown project %",
719 Names
.Table
(1).Location
);
720 First_Attribute
:= Attribute_First
;
723 -- If it is a package name, check if the package
724 -- has already been declared in the current project.
727 First_Package_Of
(Current_Project
, In_Tree
);
729 while The_Package
/= Empty_Node
730 and then Name_Of
(The_Package
, In_Tree
) /=
734 Next_Package_In_Project
(The_Package
, In_Tree
);
737 -- If it has not been already declared, report an
740 if The_Package
= Empty_Node
then
741 Error_Msg_Name_1
:= Names
.Table
(1).Name
;
742 Error_Msg
("package % not yet defined",
743 Names
.Table
(1).Location
);
748 -- It is a project name
750 First_Attribute
:= Attribute_First
;
751 The_Package
:= Empty_Node
;
756 -- We have either a project name made of several simple
757 -- names (long project), or a project name (short project)
758 -- followed by a package name. The long project name has
762 Short_Project
: Name_Id
;
763 Long_Project
: Name_Id
;
770 -- Get the name of the short project
772 for Index
in 1 .. Names
.Last
- 1 loop
774 (Get_Name_String
(Names
.Table
(Index
).Name
),
775 Buffer
, Buffer_Last
);
777 if Index
/= Names
.Last
- 1 then
778 Add_To_Buffer
(".", Buffer
, Buffer_Last
);
782 Name_Len
:= Buffer_Last
;
783 Name_Buffer
(1 .. Buffer_Last
) :=
784 Buffer
(1 .. Buffer_Last
);
785 Short_Project
:= Name_Find
;
787 -- Now, add the last simple name to get the name of the
790 Add_To_Buffer
(".", Buffer
, Buffer_Last
);
792 (Get_Name_String
(Names
.Table
(Names
.Last
).Name
),
793 Buffer
, Buffer_Last
);
794 Name_Len
:= Buffer_Last
;
795 Name_Buffer
(1 .. Buffer_Last
) :=
796 Buffer
(1 .. Buffer_Last
);
797 Long_Project
:= Name_Find
;
799 -- Check if the long project is imported or extended
801 The_Project
:= Imported_Or_Extended_Project_Of
802 (Current_Project
, In_Tree
, Long_Project
);
804 -- If the long project exists, then this is the prefix
807 if The_Project
/= Empty_Node
then
808 First_Attribute
:= Attribute_First
;
809 The_Package
:= Empty_Node
;
812 -- Otherwise, check if the short project is imported
815 The_Project
:= Imported_Or_Extended_Project_Of
816 (Current_Project
, In_Tree
,
819 -- If the short project does not exist, we report an
822 if The_Project
= Empty_Node
then
823 Error_Msg_Name_1
:= Long_Project
;
824 Error_Msg_Name_2
:= Short_Project
;
825 Error_Msg
("unknown projects % or %",
826 Names
.Table
(1).Location
);
827 The_Package
:= Empty_Node
;
828 First_Attribute
:= Attribute_First
;
831 -- Now, we check if the package has been declared
835 First_Package_Of
(The_Project
, In_Tree
);
836 while The_Package
/= Empty_Node
837 and then Name_Of
(The_Package
, In_Tree
) /=
838 Names
.Table
(Names
.Last
).Name
841 Next_Package_In_Project
(The_Package
, In_Tree
);
844 -- If it has not, then we report an error
846 if The_Package
= Empty_Node
then
848 Names
.Table
(Names
.Last
).Name
;
849 Error_Msg_Name_2
:= Short_Project
;
850 Error_Msg
("package % not declared in project %",
851 Names
.Table
(Names
.Last
).Location
);
852 First_Attribute
:= Attribute_First
;
855 -- Otherwise, we have the correct project and
860 (Package_Id_Of
(The_Package
, In_Tree
));
870 Current_Project
=> The_Project
,
871 Current_Package
=> The_Package
,
872 First_Attribute
=> First_Attribute
);
879 (Of_Kind
=> N_Variable_Reference
, In_Tree
=> In_Tree
);
881 if Look_For_Variable
then
891 -- Simple variable name
893 Set_Name_Of
(Variable
, In_Tree
, To
=> Names
.Table
(1).Name
);
897 -- Variable name with a simple name prefix that can be
898 -- a project name or a package name. Project names have
899 -- priority over package names.
901 Set_Name_Of
(Variable
, In_Tree
, To
=> Names
.Table
(2).Name
);
903 -- Check if it can be a package name
905 The_Package
:= First_Package_Of
(Current_Project
, In_Tree
);
907 while The_Package
/= Empty_Node
908 and then Name_Of
(The_Package
, In_Tree
) /=
912 Next_Package_In_Project
(The_Package
, In_Tree
);
915 -- Now look for a possible project name
917 The_Project
:= Imported_Or_Extended_Project_Of
918 (Current_Project
, In_Tree
, Names
.Table
(1).Name
);
920 if The_Project
/= Empty_Node
then
921 Specified_Project
:= The_Project
;
923 elsif The_Package
= Empty_Node
then
924 Error_Msg_Name_1
:= Names
.Table
(1).Name
;
925 Error_Msg
("unknown package or project %",
926 Names
.Table
(1).Location
);
927 Look_For_Variable
:= False;
930 Specified_Package
:= The_Package
;
935 -- Variable name with a prefix that is either a project name
936 -- made of several simple names, or a project name followed
937 -- by a package name.
940 (Variable
, In_Tree
, To
=> Names
.Table
(Names
.Last
).Name
);
943 Short_Project
: Name_Id
;
944 Long_Project
: Name_Id
;
947 -- First, we get the two possible project names
953 -- Add all the simple names, except the last two
955 for Index
in 1 .. Names
.Last
- 2 loop
957 (Get_Name_String
(Names
.Table
(Index
).Name
),
958 Buffer
, Buffer_Last
);
960 if Index
/= Names
.Last
- 2 then
961 Add_To_Buffer
(".", Buffer
, Buffer_Last
);
965 Name_Len
:= Buffer_Last
;
966 Name_Buffer
(1 .. Name_Len
) := Buffer
(1 .. Buffer_Last
);
967 Short_Project
:= Name_Find
;
969 -- Add the simple name before the name of the variable
971 Add_To_Buffer
(".", Buffer
, Buffer_Last
);
973 (Get_Name_String
(Names
.Table
(Names
.Last
- 1).Name
),
974 Buffer
, Buffer_Last
);
975 Name_Len
:= Buffer_Last
;
976 Name_Buffer
(1 .. Name_Len
) := Buffer
(1 .. Buffer_Last
);
977 Long_Project
:= Name_Find
;
979 -- Check if the prefix is the name of an imported or
982 The_Project
:= Imported_Or_Extended_Project_Of
983 (Current_Project
, In_Tree
, Long_Project
);
985 if The_Project
/= Empty_Node
then
986 Specified_Project
:= The_Project
;
989 -- Now check if the prefix may be a project name followed
990 -- by a package name.
992 -- First check for a possible project name
994 The_Project
:= Imported_Or_Extended_Project_Of
995 (Current_Project
, In_Tree
, Short_Project
);
997 if The_Project
= Empty_Node
then
998 -- Unknown prefix, report an error
1000 Error_Msg_Name_1
:= Long_Project
;
1001 Error_Msg_Name_2
:= Short_Project
;
1002 Error_Msg
("unknown projects % or %",
1003 Names
.Table
(1).Location
);
1004 Look_For_Variable
:= False;
1007 Specified_Project
:= The_Project
;
1009 -- Now look for the package in this project
1011 The_Package
:= First_Package_Of
(The_Project
, In_Tree
);
1013 while The_Package
/= Empty_Node
1014 and then Name_Of
(The_Package
, In_Tree
) /=
1015 Names
.Table
(Names
.Last
- 1).Name
1018 Next_Package_In_Project
(The_Package
, In_Tree
);
1021 if The_Package
= Empty_Node
then
1022 -- The package does not vexist, report an error
1024 Error_Msg_Name_1
:= Names
.Table
(2).Name
;
1025 Error_Msg
("unknown package %",
1026 Names
.Table
(Names
.Last
- 1).Location
);
1027 Look_For_Variable
:= False;
1030 Specified_Package
:= The_Package
;
1038 if Look_For_Variable
then
1039 Variable_Name
:= Name_Of
(Variable
, In_Tree
);
1040 Set_Project_Node_Of
(Variable
, In_Tree
, To
=> Specified_Project
);
1041 Set_Package_Node_Of
(Variable
, In_Tree
, To
=> Specified_Package
);
1043 if Specified_Project
/= Empty_Node
then
1044 The_Project
:= Specified_Project
;
1047 The_Project
:= Current_Project
;
1050 Current_Variable
:= Empty_Node
;
1052 -- Look for this variable
1054 -- If a package was specified, check if the variable has been
1055 -- declared in this package.
1057 if Specified_Package
/= Empty_Node
then
1059 First_Variable_Of
(Specified_Package
, In_Tree
);
1061 while Current_Variable
/= Empty_Node
1063 Name_Of
(Current_Variable
, In_Tree
) /= Variable_Name
1065 Current_Variable
:= Next_Variable
(Current_Variable
, In_Tree
);
1069 -- Otherwise, if no project has been specified and we are in
1070 -- a package, first check if the variable has been declared in
1073 if Specified_Project
= Empty_Node
1074 and then Current_Package
/= Empty_Node
1077 First_Variable_Of
(Current_Package
, In_Tree
);
1079 while Current_Variable
/= Empty_Node
1080 and then Name_Of
(Current_Variable
, In_Tree
) /= Variable_Name
1083 Next_Variable
(Current_Variable
, In_Tree
);
1087 -- If we have not found the variable in the package, check if the
1088 -- variable has been declared in the project.
1090 if Current_Variable
= Empty_Node
then
1091 Current_Variable
:= First_Variable_Of
(The_Project
, In_Tree
);
1093 while Current_Variable
/= Empty_Node
1094 and then Name_Of
(Current_Variable
, In_Tree
) /= Variable_Name
1097 Next_Variable
(Current_Variable
, In_Tree
);
1102 -- If the variable was not found, report an error
1104 if Current_Variable
= Empty_Node
then
1105 Error_Msg_Name_1
:= Variable_Name
;
1107 ("unknown variable %", Names
.Table
(Names
.Last
).Location
);
1111 if Current_Variable
/= Empty_Node
then
1112 Set_Expression_Kind_Of
1114 To
=> Expression_Kind_Of
(Current_Variable
, In_Tree
));
1117 Kind_Of
(Current_Variable
, In_Tree
) = N_Typed_Variable_Declaration
1121 To
=> String_Type_Of
(Current_Variable
, In_Tree
));
1125 -- If the variable is followed by a left parenthesis, report an error
1126 -- but attempt to scan the index.
1128 if Token
= Tok_Left_Paren
then
1129 Error_Msg
("\variables cannot be associative arrays", Token_Ptr
);
1131 Expect
(Tok_String_Literal
, "literal string");
1133 if Token
= Tok_String_Literal
then
1135 Expect
(Tok_Right_Paren
, "`)`");
1137 if Token
= Tok_Right_Paren
then
1142 end Parse_Variable_Reference
;
1144 ---------------------------------
1145 -- Start_New_Case_Construction --
1146 ---------------------------------
1148 procedure Start_New_Case_Construction
1149 (In_Tree
: Project_Node_Tree_Ref
;
1150 String_Type
: Project_Node_Id
)
1152 Current_String
: Project_Node_Id
;
1155 -- Set Choice_First, depending on whether is the first case
1156 -- construction or not.
1158 if Choice_First
= 0 then
1160 Choices
.Set_Last
(First_Choice_Node_Id
);
1162 Choice_First
:= Choices
.Last
+ 1;
1165 -- Add to table Choices the literal of the string type
1167 if String_Type
/= Empty_Node
then
1168 Current_String
:= First_Literal_String
(String_Type
, In_Tree
);
1170 while Current_String
/= Empty_Node
loop
1171 Add
(This_String
=> String_Value_Of
(Current_String
, In_Tree
));
1172 Current_String
:= Next_Literal_String
(Current_String
, In_Tree
);
1176 -- Set the value of the last choice in table Choice_Lasts
1178 Choice_Lasts
.Increment_Last
;
1179 Choice_Lasts
.Table
(Choice_Lasts
.Last
) := Choices
.Last
;
1181 end Start_New_Case_Construction
;
1188 (In_Tree
: Project_Node_Tree_Ref
;
1189 Term
: out Project_Node_Id
;
1190 Expr_Kind
: in out Variable_Kind
;
1191 Current_Project
: Project_Node_Id
;
1192 Current_Package
: Project_Node_Id
;
1193 Optional_Index
: Boolean)
1195 Next_Term
: Project_Node_Id
:= Empty_Node
;
1196 Term_Id
: Project_Node_Id
:= Empty_Node
;
1197 Current_Expression
: Project_Node_Id
:= Empty_Node
;
1198 Next_Expression
: Project_Node_Id
:= Empty_Node
;
1199 Current_Location
: Source_Ptr
:= No_Location
;
1200 Reference
: Project_Node_Id
:= Empty_Node
;
1203 -- Declare a new node for the term
1205 Term
:= Default_Project_Node
(Of_Kind
=> N_Term
, In_Tree
=> In_Tree
);
1206 Set_Location_Of
(Term
, In_Tree
, To
=> Token_Ptr
);
1209 when Tok_Left_Paren
=>
1211 -- If we have a left parenthesis and we don't know the expression
1212 -- kind, then this is a string list.
1223 -- If we already know that this is a single string, report
1224 -- an error, but set the expression kind to string list to
1225 -- avoid several errors.
1229 ("literal string list cannot appear in a string",
1233 -- Declare a new node for this literal string list
1235 Term_Id
:= Default_Project_Node
1236 (Of_Kind
=> N_Literal_String_List
,
1238 And_Expr_Kind
=> List
);
1239 Set_Current_Term
(Term
, In_Tree
, To
=> Term_Id
);
1240 Set_Location_Of
(Term
, In_Tree
, To
=> Token_Ptr
);
1242 -- Scan past the left parenthesis
1246 -- If the left parenthesis is immediately followed by a right
1247 -- parenthesis, the literal string list is empty.
1249 if Token
= Tok_Right_Paren
then
1253 -- Otherwise, we parse the expression(s) in the literal string
1257 Current_Location
:= Token_Ptr
;
1259 (In_Tree
=> In_Tree
,
1260 Expression
=> Next_Expression
,
1261 Current_Project
=> Current_Project
,
1262 Current_Package
=> Current_Package
,
1263 Optional_Index
=> Optional_Index
);
1265 -- The expression kind is String list, report an error
1267 if Expression_Kind_Of
(Next_Expression
, In_Tree
) = List
then
1268 Error_Msg
("single expression expected",
1272 -- If Current_Expression is empty, it means that the
1273 -- expression is the first in the string list.
1275 if Current_Expression
= Empty_Node
then
1276 Set_First_Expression_In_List
1277 (Term_Id
, In_Tree
, To
=> Next_Expression
);
1279 Set_Next_Expression_In_List
1280 (Current_Expression
, In_Tree
, To
=> Next_Expression
);
1283 Current_Expression
:= Next_Expression
;
1285 -- If there is a comma, continue with the next expression
1287 exit when Token
/= Tok_Comma
;
1288 Scan
(In_Tree
); -- past the comma
1291 -- We expect a closing right parenthesis
1293 Expect
(Tok_Right_Paren
, "`)`");
1295 if Token
= Tok_Right_Paren
then
1300 when Tok_String_Literal
=>
1302 -- If we don't know the expression kind (first term), then it is
1305 if Expr_Kind
= Undefined
then
1306 Expr_Kind
:= Single
;
1309 -- Declare a new node for the string literal
1312 Default_Project_Node
1313 (Of_Kind
=> N_Literal_String
, In_Tree
=> In_Tree
);
1314 Set_Current_Term
(Term
, In_Tree
, To
=> Term_Id
);
1315 Set_String_Value_Of
(Term_Id
, In_Tree
, To
=> Token_Name
);
1317 -- Scan past the string literal
1321 -- Check for possible index expression
1323 if Token
= Tok_At
then
1324 if not Optional_Index
then
1325 Error_Msg
("index not allowed here", Token_Ptr
);
1328 if Token
= Tok_Integer_Literal
then
1332 -- Set the index value
1336 Expect
(Tok_Integer_Literal
, "integer literal");
1338 if Token
= Tok_Integer_Literal
then
1340 Index
: constant Int
:= UI_To_Int
(Int_Literal_Value
);
1343 Error_Msg
("index cannot be zero", Token_Ptr
);
1346 (Term_Id
, In_Tree
, To
=> Index
);
1355 when Tok_Identifier
=>
1356 Current_Location
:= Token_Ptr
;
1358 -- Get the variable or attribute reference
1360 Parse_Variable_Reference
1361 (In_Tree
=> In_Tree
,
1362 Variable
=> Reference
,
1363 Current_Project
=> Current_Project
,
1364 Current_Package
=> Current_Package
);
1365 Set_Current_Term
(Term
, In_Tree
, To
=> Reference
);
1367 if Reference
/= Empty_Node
then
1369 -- If we don't know the expression kind (first term), then it
1370 -- has the kind of the variable or attribute reference.
1372 if Expr_Kind
= Undefined
then
1373 Expr_Kind
:= Expression_Kind_Of
(Reference
, In_Tree
);
1375 elsif Expr_Kind
= Single
1376 and then Expression_Kind_Of
(Reference
, In_Tree
) = List
1378 -- If the expression is a single list, and the reference is
1379 -- a string list, report an error, and set the expression
1380 -- kind to string list to avoid multiple errors.
1384 ("list variable cannot appear in single string expression",
1391 -- project can appear in an expression as the prefix of an
1392 -- attribute reference of the current project.
1394 Current_Location
:= Token_Ptr
;
1396 Expect
(Tok_Apostrophe
, "`'`");
1398 if Token
= Tok_Apostrophe
then
1400 (In_Tree
=> In_Tree
,
1401 Reference
=> Reference
,
1402 First_Attribute
=> Prj
.Attr
.Attribute_First
,
1403 Current_Project
=> Current_Project
,
1404 Current_Package
=> Empty_Node
);
1405 Set_Current_Term
(Term
, In_Tree
, To
=> Reference
);
1408 -- Same checks as above for the expression kind
1410 if Reference
/= Empty_Node
then
1411 if Expr_Kind
= Undefined
then
1412 Expr_Kind
:= Expression_Kind_Of
(Reference
, In_Tree
);
1414 elsif Expr_Kind
= Single
1415 and then Expression_Kind_Of
(Reference
, In_Tree
) = List
1418 ("lists cannot appear in single string expression",
1423 when Tok_External
=>
1424 -- An external reference is always a single string
1426 if Expr_Kind
= Undefined
then
1427 Expr_Kind
:= Single
;
1431 (In_Tree
=> In_Tree
,
1432 Current_Project
=> Current_Project
,
1433 Current_Package
=> Current_Package
,
1434 External_Value
=> Reference
);
1435 Set_Current_Term
(Term
, In_Tree
, To
=> Reference
);
1438 Error_Msg
("cannot be part of an expression", Token_Ptr
);
1443 -- If there is an '&', call Terms recursively
1445 if Token
= Tok_Ampersand
then
1447 -- Scan past the '&'
1452 (In_Tree
=> In_Tree
,
1454 Expr_Kind
=> Expr_Kind
,
1455 Current_Project
=> Current_Project
,
1456 Current_Package
=> Current_Package
,
1457 Optional_Index
=> Optional_Index
);
1459 -- And link the next term to this term
1461 Set_Next_Term
(Term
, In_Tree
, To
=> Next_Term
);