1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2003 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
;
37 package body Prj
.Strt
is
39 type Choice_String
is record
41 Already_Used
: Boolean := False;
43 -- The string of a case label, and an indication that it has already
44 -- been used (to avoid duplicate case labels).
46 Choices_Initial
: constant := 10;
47 Choices_Increment
: constant := 50;
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
;
60 new Table
.Table
(Table_Component_Type
=> Choice_String
,
61 Table_Index_Type
=> Choice_Node_Id
,
62 Table_Low_Bound
=> First_Choice_Node_Id
,
63 Table_Initial
=> Choices_Initial
,
64 Table_Increment
=> Choices_Increment
,
65 Table_Name
=> "Prj.Strt.Choices");
66 -- Used to store the case labels and check that there is no duplicate.
68 package Choice_Lasts
is
69 new Table
.Table
(Table_Component_Type
=> Choice_Node_Id
,
70 Table_Index_Type
=> Nat
,
73 Table_Increment
=> 100,
74 Table_Name
=> "Prj.Strt.Choice_Lasts");
75 -- Used to store the indices of the choices in table Choices,
76 -- to distinguish nested case constructions.
78 Choice_First
: Choice_Node_Id
:= 0;
79 -- Index in table Choices of the first case label of the current
80 -- case construction. Zero means no current case construction.
82 type Name_Location
is record
83 Name
: Name_Id
:= No_Name
;
84 Location
: Source_Ptr
:= No_Location
;
86 -- Store the identifier and the location of a simple name
89 new Table
.Table
(Table_Component_Type
=> Name_Location
,
90 Table_Index_Type
=> Nat
,
93 Table_Increment
=> 100,
94 Table_Name
=> "Prj.Strt.Names");
95 -- Used to accumulate the single names of a name
97 procedure Add
(This_String
: Name_Id
);
98 -- Add a string to the case label list, indicating that it has not
101 procedure Add_To_Names
(NL
: Name_Location
);
102 -- Add one single names to table Names
104 procedure External_Reference
(External_Value
: out Project_Node_Id
);
105 -- Parse an external reference. Current token is "external".
107 procedure Attribute_Reference
108 (Reference
: out Project_Node_Id
;
109 First_Attribute
: Attribute_Node_Id
;
110 Current_Project
: Project_Node_Id
;
111 Current_Package
: Project_Node_Id
);
112 -- Parse an attribute reference. Current token is an apostrophe.
115 (Term
: out Project_Node_Id
;
116 Expr_Kind
: in out Variable_Kind
;
117 Current_Project
: Project_Node_Id
;
118 Current_Package
: Project_Node_Id
);
119 -- Recursive procedure to parse one term or several terms concatenated
126 procedure Add
(This_String
: Name_Id
) is
128 Choices
.Increment_Last
;
129 Choices
.Table
(Choices
.Last
) :=
130 (The_String
=> This_String
,
131 Already_Used
=> False);
138 procedure Add_To_Names
(NL
: Name_Location
) is
140 Names
.Increment_Last
;
141 Names
.Table
(Names
.Last
) := NL
;
144 -------------------------
145 -- Attribute_Reference --
146 -------------------------
148 procedure Attribute_Reference
149 (Reference
: out Project_Node_Id
;
150 First_Attribute
: Attribute_Node_Id
;
151 Current_Project
: Project_Node_Id
;
152 Current_Package
: Project_Node_Id
)
154 Current_Attribute
: Attribute_Node_Id
:= First_Attribute
;
157 -- Declare the node of the attribute reference
159 Reference
:= Default_Project_Node
(Of_Kind
=> N_Attribute_Reference
);
160 Set_Location_Of
(Reference
, To
=> Token_Ptr
);
161 Scan
; -- past apostrophe
163 -- Body may be an attribute name
165 if Token
= Tok_Body
then
166 Token
:= Tok_Identifier
;
167 Token_Name
:= Snames
.Name_Body
;
170 Expect
(Tok_Identifier
, "identifier");
172 if Token
= Tok_Identifier
then
173 Set_Name_Of
(Reference
, To
=> Token_Name
);
175 -- Check if the identifier is one of the attribute identifiers in the
176 -- context (package or project level attributes).
178 while Current_Attribute
/= Empty_Attribute
180 Attributes
.Table
(Current_Attribute
).Name
/= Token_Name
182 Current_Attribute
:= Attributes
.Table
(Current_Attribute
).Next
;
185 -- If the identifier is not allowed, report an error
187 if Current_Attribute
= Empty_Attribute
then
188 Error_Msg_Name_1
:= Token_Name
;
189 Error_Msg
("unknown attribute %", Token_Ptr
);
190 Reference
:= Empty_Node
;
192 -- Scan past the attribute name
197 -- Give its characteristics to this attribute reference
199 Set_Project_Node_Of
(Reference
, To
=> Current_Project
);
200 Set_Package_Node_Of
(Reference
, To
=> Current_Package
);
201 Set_Expression_Kind_Of
202 (Reference
, To
=> Attributes
.Table
(Current_Attribute
).Kind_1
);
204 (Reference
, To
=> Attributes
.Table
(Current_Attribute
).Kind_2
=
205 Case_Insensitive_Associative_Array
);
207 -- Scan past the attribute name
211 -- If the attribute is an associative array, get the index
213 if Attributes
.Table
(Current_Attribute
).Kind_2
/= Single
then
214 Expect
(Tok_Left_Paren
, "`(`");
216 if Token
= Tok_Left_Paren
then
218 Expect
(Tok_String_Literal
, "literal string");
220 if Token
= Tok_String_Literal
then
221 Set_Associative_Array_Index_Of
222 (Reference
, To
=> Token_Name
);
224 Expect
(Tok_Right_Paren
, "`)`");
226 if Token
= Tok_Right_Paren
then
234 -- Change name of obsolete attributes
236 if Reference
/= Empty_Node
then
237 case Name_Of
(Reference
) is
238 when Snames
.Name_Specification
=>
239 Set_Name_Of
(Reference
, To
=> Snames
.Name_Spec
);
241 when Snames
.Name_Specification_Suffix
=>
242 Set_Name_Of
(Reference
, To
=> Snames
.Name_Spec_Suffix
);
244 when Snames
.Name_Implementation
=>
245 Set_Name_Of
(Reference
, To
=> Snames
.Name_Body
);
247 when Snames
.Name_Implementation_Suffix
=>
248 Set_Name_Of
(Reference
, To
=> Snames
.Name_Body_Suffix
);
255 end Attribute_Reference
;
257 ---------------------------
258 -- End_Case_Construction --
259 ---------------------------
261 procedure End_Case_Construction
is
263 -- If this is the only case construction, empty the tables
265 if Choice_Lasts
.Last
= 1 then
266 Choice_Lasts
.Set_Last
(0);
267 Choices
.Set_Last
(First_Choice_Node_Id
);
270 elsif Choice_Lasts
.Last
= 2 then
271 -- This is the second case onstruction, set the tables to the first
273 Choice_Lasts
.Set_Last
(1);
274 Choices
.Set_Last
(Choice_Lasts
.Table
(1));
278 -- This is the 3rd or more case construction, set the tables to the
281 Choice_Lasts
.Decrement_Last
;
282 Choices
.Set_Last
(Choice_Lasts
.Table
(Choice_Lasts
.Last
));
283 Choice_First
:= Choice_Lasts
.Table
(Choice_Lasts
.Last
- 1) + 1;
285 end End_Case_Construction
;
287 ------------------------
288 -- External_Reference --
289 ------------------------
291 procedure External_Reference
(External_Value
: out Project_Node_Id
) is
292 Field_Id
: Project_Node_Id
:= Empty_Node
;
296 Default_Project_Node
(Of_Kind
=> N_External_Value
,
297 And_Expr_Kind
=> Single
);
298 Set_Location_Of
(External_Value
, To
=> Token_Ptr
);
300 -- The current token is External
302 -- Get the left parenthesis
305 Expect
(Tok_Left_Paren
, "`(`");
307 -- Scan past the left parenthesis
309 if Token
= Tok_Left_Paren
then
313 -- Get the name of the external reference
315 Expect
(Tok_String_Literal
, "literal string");
317 if Token
= Tok_String_Literal
then
319 Default_Project_Node
(Of_Kind
=> N_Literal_String
,
320 And_Expr_Kind
=> Single
);
321 Set_String_Value_Of
(Field_Id
, To
=> Token_Name
);
322 Set_External_Reference_Of
(External_Value
, To
=> Field_Id
);
324 -- Scan past the first argument
330 when Tok_Right_Paren
=>
332 -- Scan past the right parenthesis
337 -- Scan past the comma
341 Expect
(Tok_String_Literal
, "literal string");
345 if Token
= Tok_String_Literal
then
347 Default_Project_Node
(Of_Kind
=> N_Literal_String
,
348 And_Expr_Kind
=> Single
);
349 Set_String_Value_Of
(Field_Id
, To
=> Token_Name
);
350 Set_External_Default_Of
(External_Value
, To
=> Field_Id
);
352 Expect
(Tok_Right_Paren
, "`)`");
355 -- Scan past the right parenthesis
356 if Token
= Tok_Right_Paren
then
361 Error_Msg
("`,` or `)` expected", Token_Ptr
);
364 end External_Reference
;
366 -----------------------
367 -- Parse_Choice_List --
368 -----------------------
370 procedure Parse_Choice_List
(First_Choice
: out Project_Node_Id
) is
371 Current_Choice
: Project_Node_Id
:= Empty_Node
;
372 Next_Choice
: Project_Node_Id
:= Empty_Node
;
373 Choice_String
: Name_Id
:= No_Name
;
374 Found
: Boolean := False;
377 -- Declare the node of the first choice
380 Default_Project_Node
(Of_Kind
=> N_Literal_String
,
381 And_Expr_Kind
=> Single
);
383 -- Initially Current_Choice is the same as First_Choice
385 Current_Choice
:= First_Choice
;
388 Expect
(Tok_String_Literal
, "literal string");
389 exit when Token
/= Tok_String_Literal
;
390 Set_Location_Of
(Current_Choice
, To
=> Token_Ptr
);
391 Choice_String
:= Token_Name
;
393 -- Give the string value to the current choice
395 Set_String_Value_Of
(Current_Choice
, To
=> Choice_String
);
397 -- Check if the label is part of the string type and if it has not
398 -- been already used.
401 for Choice
in Choice_First
.. Choices
.Last
loop
402 if Choices
.Table
(Choice
).The_String
= Choice_String
then
403 -- This label is part of the string type
407 if Choices
.Table
(Choice
).Already_Used
then
408 -- But it has already appeared in a choice list for this
409 -- case construction; report an error.
411 Error_Msg_Name_1
:= Choice_String
;
412 Error_Msg
("duplicate case label {", Token_Ptr
);
414 Choices
.Table
(Choice
).Already_Used
:= True;
421 -- If the label is not part of the string list, report an error
424 Error_Msg_Name_1
:= Choice_String
;
425 Error_Msg
("illegal case label {", Token_Ptr
);
428 -- Scan past the label
432 -- If there is no '|', we are done
434 if Token
= Tok_Vertical_Bar
then
435 -- Otherwise, declare the node of the next choice, link it to
436 -- Current_Choice and set Current_Choice to this new node.
439 Default_Project_Node
(Of_Kind
=> N_Literal_String
,
440 And_Expr_Kind
=> Single
);
441 Set_Next_Literal_String
(Current_Choice
, To
=> Next_Choice
);
442 Current_Choice
:= Next_Choice
;
448 end Parse_Choice_List
;
450 ----------------------
451 -- Parse_Expression --
452 ----------------------
454 procedure Parse_Expression
455 (Expression
: out Project_Node_Id
;
456 Current_Project
: Project_Node_Id
;
457 Current_Package
: Project_Node_Id
)
459 First_Term
: Project_Node_Id
:= Empty_Node
;
460 Expression_Kind
: Variable_Kind
:= Undefined
;
463 -- Declare the node of the expression
465 Expression
:= Default_Project_Node
(Of_Kind
=> N_Expression
);
466 Set_Location_Of
(Expression
, To
=> Token_Ptr
);
468 -- Parse the term or terms of the expression
470 Terms
(Term
=> First_Term
,
471 Expr_Kind
=> Expression_Kind
,
472 Current_Project
=> Current_Project
,
473 Current_Package
=> Current_Package
);
475 -- Set the first term and the expression kind
477 Set_First_Term
(Expression
, To
=> First_Term
);
478 Set_Expression_Kind_Of
(Expression
, To
=> Expression_Kind
);
479 end Parse_Expression
;
481 ----------------------------
482 -- Parse_String_Type_List --
483 ----------------------------
485 procedure Parse_String_Type_List
(First_String
: out Project_Node_Id
) is
486 Last_String
: Project_Node_Id
:= Empty_Node
;
487 Next_String
: Project_Node_Id
:= Empty_Node
;
488 String_Value
: Name_Id
:= No_Name
;
491 -- Declare the node of the first string
494 Default_Project_Node
(Of_Kind
=> N_Literal_String
,
495 And_Expr_Kind
=> Single
);
497 -- Initially, Last_String is the same as First_String
499 Last_String
:= First_String
;
502 Expect
(Tok_String_Literal
, "literal string");
503 exit when Token
/= Tok_String_Literal
;
504 String_Value
:= Token_Name
;
506 -- Give its string value to Last_String
508 Set_String_Value_Of
(Last_String
, To
=> String_Value
);
509 Set_Location_Of
(Last_String
, To
=> Token_Ptr
);
511 -- Now, check if the string is already part of the string type
514 Current
: Project_Node_Id
:= First_String
;
517 while Current
/= Last_String
loop
518 if String_Value_Of
(Current
) = String_Value
then
519 -- This is a repetition, report an error
521 Error_Msg_Name_1
:= String_Value
;
522 Error_Msg
("duplicate value { in type", Token_Ptr
);
526 Current
:= Next_Literal_String
(Current
);
530 -- Scan past the literal string
534 -- If there is no comma following the literal string, we are done
536 if Token
/= Tok_Comma
then
540 -- Declare the next string, link it to Last_String and set
541 -- Last_String to its node.
544 Default_Project_Node
(Of_Kind
=> N_Literal_String
,
545 And_Expr_Kind
=> Single
);
546 Set_Next_Literal_String
(Last_String
, To
=> Next_String
);
547 Last_String
:= Next_String
;
551 end Parse_String_Type_List
;
553 ------------------------------
554 -- Parse_Variable_Reference --
555 ------------------------------
557 procedure Parse_Variable_Reference
558 (Variable
: out Project_Node_Id
;
559 Current_Project
: Project_Node_Id
;
560 Current_Package
: Project_Node_Id
)
562 Current_Variable
: Project_Node_Id
:= Empty_Node
;
564 The_Package
: Project_Node_Id
:= Current_Package
;
565 The_Project
: Project_Node_Id
:= Current_Project
;
567 Specified_Project
: Project_Node_Id
:= Empty_Node
;
568 Specified_Package
: Project_Node_Id
:= Empty_Node
;
569 Look_For_Variable
: Boolean := True;
570 First_Attribute
: Attribute_Node_Id
:= Empty_Attribute
;
571 Variable_Name
: Name_Id
;
577 Expect
(Tok_Identifier
, "identifier");
579 if Token
/= Tok_Identifier
then
580 Look_For_Variable
:= False;
584 Add_To_Names
(NL
=> (Name
=> Token_Name
, Location
=> Token_Ptr
));
586 exit when Token
/= Tok_Dot
;
590 if Look_For_Variable
then
592 if Token
= Tok_Apostrophe
then
594 -- Attribute reference
604 -- This may be a project name or a package name.
605 -- Project name have precedence.
607 -- First, look if it can be a package name
609 for Index
in Package_First
.. Package_Attributes
.Last
loop
610 if Package_Attributes
.Table
(Index
).Name
=
614 Package_Attributes
.Table
(Index
).First_Attribute
;
619 -- Now, look if it can be a project name
621 The_Project
:= Imported_Or_Extended_Project_Of
622 (Current_Project
, Names
.Table
(1).Name
);
624 if The_Project
= Empty_Node
then
625 -- If it is neither a project name nor a package name,
628 if First_Attribute
= Empty_Attribute
then
629 Error_Msg_Name_1
:= Names
.Table
(1).Name
;
630 Error_Msg
("unknown project %",
631 Names
.Table
(1).Location
);
632 First_Attribute
:= Attribute_First
;
635 -- If it is a package name, check if the package
636 -- has already been declared in the current project.
638 The_Package
:= First_Package_Of
(Current_Project
);
640 while The_Package
/= Empty_Node
641 and then Name_Of
(The_Package
) /=
645 Next_Package_In_Project
(The_Package
);
648 -- If it has not been already declared, report an
651 if The_Package
= Empty_Node
then
652 Error_Msg_Name_1
:= Names
.Table
(1).Name
;
653 Error_Msg
("package % not yet defined",
654 Names
.Table
(1).Location
);
659 -- It is a project name
661 First_Attribute
:= Attribute_First
;
662 The_Package
:= Empty_Node
;
667 -- We have either a project name made of several simple
668 -- names (long project), or a project name (short project)
669 -- followed by a package name. The long project name has
673 Short_Project
: Name_Id
;
674 Long_Project
: Name_Id
;
681 -- Get the name of the short project
683 for Index
in 1 .. Names
.Last
- 1 loop
685 (Get_Name_String
(Names
.Table
(Index
).Name
));
687 if Index
/= Names
.Last
- 1 then
692 Name_Len
:= Buffer_Last
;
693 Name_Buffer
(1 .. Buffer_Last
) :=
694 Buffer
(1 .. Buffer_Last
);
695 Short_Project
:= Name_Find
;
697 -- Now, add the last simple name to get the name of the
702 (Get_Name_String
(Names
.Table
(Names
.Last
).Name
));
703 Name_Len
:= Buffer_Last
;
704 Name_Buffer
(1 .. Buffer_Last
) :=
705 Buffer
(1 .. Buffer_Last
);
706 Long_Project
:= Name_Find
;
708 -- Check if the long project is imported or extended
710 The_Project
:= Imported_Or_Extended_Project_Of
711 (Current_Project
, Long_Project
);
713 -- If the long project exists, then this is the prefix
716 if The_Project
/= Empty_Node
then
717 First_Attribute
:= Attribute_First
;
718 The_Package
:= Empty_Node
;
721 -- Otherwise, check if the short project is imported
724 The_Project
:= Imported_Or_Extended_Project_Of
725 (Current_Project
, Short_Project
);
727 -- If the short project does not exist, we report an
730 if The_Project
= Empty_Node
then
731 Error_Msg_Name_1
:= Long_Project
;
732 Error_Msg_Name_2
:= Short_Project
;
733 Error_Msg
("unknown projects % or %",
734 Names
.Table
(1).Location
);
735 The_Package
:= Empty_Node
;
736 First_Attribute
:= Attribute_First
;
739 -- Now, we check if the package has been declared
742 The_Package
:= First_Package_Of
(The_Project
);
743 while The_Package
/= Empty_Node
744 and then Name_Of
(The_Package
) /=
745 Names
.Table
(Names
.Last
).Name
748 Next_Package_In_Project
(The_Package
);
751 -- If it has not, then we report an error
753 if The_Package
= Empty_Node
then
755 Names
.Table
(Names
.Last
).Name
;
756 Error_Msg_Name_2
:= Short_Project
;
757 Error_Msg
("package % not declared in project %",
758 Names
.Table
(Names
.Last
).Location
);
759 First_Attribute
:= Attribute_First
;
762 -- Otherwise, we have the correct project and
766 Package_Attributes
.Table
767 (Package_Id_Of
(The_Package
)).First_Attribute
;
776 Current_Project
=> The_Project
,
777 Current_Package
=> The_Package
,
778 First_Attribute
=> First_Attribute
);
784 Default_Project_Node
(Of_Kind
=> N_Variable_Reference
);
786 if Look_For_Variable
then
796 -- Simple variable name
798 Set_Name_Of
(Variable
, To
=> Names
.Table
(1).Name
);
802 -- Variable name with a simple name prefix that can be
803 -- a project name or a package name. Project names have
804 -- priority over package names.
806 Set_Name_Of
(Variable
, To
=> Names
.Table
(2).Name
);
808 -- Check if it can be a package name
810 The_Package
:= First_Package_Of
(Current_Project
);
812 while The_Package
/= Empty_Node
813 and then Name_Of
(The_Package
) /= Names
.Table
(1).Name
815 The_Package
:= Next_Package_In_Project
(The_Package
);
818 -- Now look for a possible project name
820 The_Project
:= Imported_Or_Extended_Project_Of
821 (Current_Project
, Names
.Table
(1).Name
);
823 if The_Project
/= Empty_Node
then
824 Specified_Project
:= The_Project
;
826 elsif The_Package
= Empty_Node
then
827 Error_Msg_Name_1
:= Names
.Table
(1).Name
;
828 Error_Msg
("unknown package or project %",
829 Names
.Table
(1).Location
);
830 Look_For_Variable
:= False;
833 Specified_Package
:= The_Package
;
838 -- Variable name with a prefix that is either a project name
839 -- made of several simple names, or a project name followed
840 -- by a package name.
842 Set_Name_Of
(Variable
, To
=> Names
.Table
(Names
.Last
).Name
);
845 Short_Project
: Name_Id
;
846 Long_Project
: Name_Id
;
849 -- First, we get the two possible project names
855 -- Add all the simple names, except the last two
857 for Index
in 1 .. Names
.Last
- 2 loop
859 (Get_Name_String
(Names
.Table
(Index
).Name
));
861 if Index
/= Names
.Last
- 2 then
866 Name_Len
:= Buffer_Last
;
867 Name_Buffer
(1 .. Name_Len
) := Buffer
(1 .. Buffer_Last
);
868 Short_Project
:= Name_Find
;
870 -- Add the simple name before the name of the variable
874 (Get_Name_String
(Names
.Table
(Names
.Last
- 1).Name
));
875 Name_Len
:= Buffer_Last
;
876 Name_Buffer
(1 .. Name_Len
) := Buffer
(1 .. Buffer_Last
);
877 Long_Project
:= Name_Find
;
879 -- Check if the prefix is the name of an imported or
882 The_Project
:= Imported_Or_Extended_Project_Of
883 (Current_Project
, Long_Project
);
885 if The_Project
/= Empty_Node
then
886 Specified_Project
:= The_Project
;
889 -- Now check if the prefix may be a project name followed
890 -- by a package name.
892 -- First check for a possible project name
894 The_Project
:= Imported_Or_Extended_Project_Of
895 (Current_Project
, Short_Project
);
897 if The_Project
= Empty_Node
then
898 -- Unknown prefix, report an error
900 Error_Msg_Name_1
:= Long_Project
;
901 Error_Msg_Name_2
:= Short_Project
;
902 Error_Msg
("unknown projects % or %",
903 Names
.Table
(1).Location
);
904 Look_For_Variable
:= False;
907 Specified_Project
:= The_Project
;
909 -- Now look for the package in this project
911 The_Package
:= First_Package_Of
(The_Project
);
913 while The_Package
/= Empty_Node
914 and then Name_Of
(The_Package
) /=
915 Names
.Table
(Names
.Last
- 1).Name
918 Next_Package_In_Project
(The_Package
);
921 if The_Package
= Empty_Node
then
922 -- The package does not vexist, report an error
924 Error_Msg_Name_1
:= Names
.Table
(2).Name
;
925 Error_Msg
("unknown package %",
926 Names
.Table
(Names
.Last
- 1).Location
);
927 Look_For_Variable
:= False;
930 Specified_Package
:= The_Package
;
938 if Look_For_Variable
then
939 Variable_Name
:= Name_Of
(Variable
);
940 Set_Project_Node_Of
(Variable
, To
=> Specified_Project
);
941 Set_Package_Node_Of
(Variable
, To
=> Specified_Package
);
943 if Specified_Project
/= Empty_Node
then
944 The_Project
:= Specified_Project
;
947 The_Project
:= Current_Project
;
950 Current_Variable
:= Empty_Node
;
952 -- Look for this variable
954 -- If a package was specified, check if the variable has been
955 -- declared in this package.
957 if Specified_Package
/= Empty_Node
then
958 Current_Variable
:= First_Variable_Of
(Specified_Package
);
960 while Current_Variable
/= Empty_Node
962 Name_Of
(Current_Variable
) /= Variable_Name
964 Current_Variable
:= Next_Variable
(Current_Variable
);
968 -- Otherwise, if no project has been specified and we are in
969 -- a package, first check if the variable has been declared in
972 if Specified_Project
= Empty_Node
973 and then Current_Package
/= Empty_Node
975 Current_Variable
:= First_Variable_Of
(Current_Package
);
977 while Current_Variable
/= Empty_Node
978 and then Name_Of
(Current_Variable
) /= Variable_Name
980 Current_Variable
:= Next_Variable
(Current_Variable
);
984 -- If we have not found the variable in the package, check if the
985 -- variable has been declared in the project.
987 if Current_Variable
= Empty_Node
then
988 Current_Variable
:= First_Variable_Of
(The_Project
);
990 while Current_Variable
/= Empty_Node
991 and then Name_Of
(Current_Variable
) /= Variable_Name
993 Current_Variable
:= Next_Variable
(Current_Variable
);
998 -- If the variable was not found, report an error
1000 if Current_Variable
= Empty_Node
then
1001 Error_Msg_Name_1
:= Variable_Name
;
1003 ("unknown variable %", Names
.Table
(Names
.Last
).Location
);
1007 if Current_Variable
/= Empty_Node
then
1008 Set_Expression_Kind_Of
1009 (Variable
, To
=> Expression_Kind_Of
(Current_Variable
));
1011 if Kind_Of
(Current_Variable
) = N_Typed_Variable_Declaration
then
1013 (Variable
, To
=> String_Type_Of
(Current_Variable
));
1017 -- If the variable is followed by a left parenthesis, report an error
1018 -- but attempt to scan the index.
1020 if Token
= Tok_Left_Paren
then
1021 Error_Msg
("\variables cannot be associative arrays", Token_Ptr
);
1023 Expect
(Tok_String_Literal
, "literal string");
1025 if Token
= Tok_String_Literal
then
1027 Expect
(Tok_Right_Paren
, "`)`");
1029 if Token
= Tok_Right_Paren
then
1034 end Parse_Variable_Reference
;
1036 ---------------------------------
1037 -- Start_New_Case_Construction --
1038 ---------------------------------
1040 procedure Start_New_Case_Construction
(String_Type
: Project_Node_Id
) is
1041 Current_String
: Project_Node_Id
;
1044 -- Set Choice_First, depending on whether is the first case
1045 -- construction or not.
1047 if Choice_First
= 0 then
1049 Choices
.Set_Last
(First_Choice_Node_Id
);
1051 Choice_First
:= Choices
.Last
+ 1;
1054 -- Add to table Choices the literal of the string type
1056 if String_Type
/= Empty_Node
then
1057 Current_String
:= First_Literal_String
(String_Type
);
1059 while Current_String
/= Empty_Node
loop
1060 Add
(This_String
=> String_Value_Of
(Current_String
));
1061 Current_String
:= Next_Literal_String
(Current_String
);
1065 -- Set the value of the last choice in table Choice_Lasts
1067 Choice_Lasts
.Increment_Last
;
1068 Choice_Lasts
.Table
(Choice_Lasts
.Last
) := Choices
.Last
;
1070 end Start_New_Case_Construction
;
1077 (Term
: out Project_Node_Id
;
1078 Expr_Kind
: in out Variable_Kind
;
1079 Current_Project
: Project_Node_Id
;
1080 Current_Package
: Project_Node_Id
)
1082 Next_Term
: Project_Node_Id
:= Empty_Node
;
1083 Term_Id
: Project_Node_Id
:= Empty_Node
;
1084 Current_Expression
: Project_Node_Id
:= Empty_Node
;
1085 Next_Expression
: Project_Node_Id
:= Empty_Node
;
1086 Current_Location
: Source_Ptr
:= No_Location
;
1087 Reference
: Project_Node_Id
:= Empty_Node
;
1090 -- Declare a new node for the term
1092 Term
:= Default_Project_Node
(Of_Kind
=> N_Term
);
1093 Set_Location_Of
(Term
, To
=> Token_Ptr
);
1096 when Tok_Left_Paren
=>
1098 -- If we have a left parenthesis and we don't know the expression
1099 -- kind, then this is a string list.
1110 -- If we already know that this is a single string, report
1111 -- an error, but set the expression kind to string list to
1112 -- avoid several errors.
1116 ("literal string list cannot appear in a string",
1120 -- Declare a new node for this literal string list
1122 Term_Id
:= Default_Project_Node
1123 (Of_Kind
=> N_Literal_String_List
,
1124 And_Expr_Kind
=> List
);
1125 Set_Current_Term
(Term
, To
=> Term_Id
);
1126 Set_Location_Of
(Term
, To
=> Token_Ptr
);
1128 -- Scan past the left parenthesis
1132 -- If the left parenthesis is immediately followed by a right
1133 -- parenthesis, the literal string list is empty.
1135 if Token
= Tok_Right_Paren
then
1139 -- Otherwise, we parse the expression(s) in the literal string
1143 Current_Location
:= Token_Ptr
;
1144 Parse_Expression
(Expression
=> Next_Expression
,
1145 Current_Project
=> Current_Project
,
1146 Current_Package
=> Current_Package
);
1148 -- The expression kind is String list, report an error
1150 if Expression_Kind_Of
(Next_Expression
) = List
then
1151 Error_Msg
("single expression expected",
1155 -- If Current_Expression is empty, it means that the
1156 -- expression is the first in the string list.
1158 if Current_Expression
= Empty_Node
then
1159 Set_First_Expression_In_List
1160 (Term_Id
, To
=> Next_Expression
);
1162 Set_Next_Expression_In_List
1163 (Current_Expression
, To
=> Next_Expression
);
1166 Current_Expression
:= Next_Expression
;
1168 -- If there is a comma, continue with the next expression
1170 exit when Token
/= Tok_Comma
;
1171 Scan
; -- past the comma
1174 -- We expect a closing right parenthesis
1176 Expect
(Tok_Right_Paren
, "`)`");
1178 if Token
= Tok_Right_Paren
then
1183 when Tok_String_Literal
=>
1185 -- If we don't know the expression kind (first term), then it is
1188 if Expr_Kind
= Undefined
then
1189 Expr_Kind
:= Single
;
1192 -- Declare a new node for the string literal
1194 Term_Id
:= Default_Project_Node
(Of_Kind
=> N_Literal_String
);
1195 Set_Current_Term
(Term
, To
=> Term_Id
);
1196 Set_String_Value_Of
(Term_Id
, To
=> Token_Name
);
1198 -- Scan past the string literal
1202 when Tok_Identifier
=>
1203 Current_Location
:= Token_Ptr
;
1205 -- Get the variable or attribute reference
1207 Parse_Variable_Reference
1208 (Variable
=> Reference
,
1209 Current_Project
=> Current_Project
,
1210 Current_Package
=> Current_Package
);
1211 Set_Current_Term
(Term
, To
=> Reference
);
1213 if Reference
/= Empty_Node
then
1215 -- If we don't know the expression kind (first term), then it
1216 -- has the kind of the variable or attribute reference.
1218 if Expr_Kind
= Undefined
then
1219 Expr_Kind
:= Expression_Kind_Of
(Reference
);
1221 elsif Expr_Kind
= Single
1222 and then Expression_Kind_Of
(Reference
) = List
1224 -- If the expression is a single list, and the reference is
1225 -- a string list, report an error, and set the expression
1226 -- kind to string list to avoid multiple errors.
1230 ("list variable cannot appear in single string expression",
1237 -- project can appear in an expression as the prefix of an
1238 -- attribute reference of the current project.
1240 Current_Location
:= Token_Ptr
;
1242 Expect
(Tok_Apostrophe
, "`'`");
1244 if Token
= Tok_Apostrophe
then
1246 (Reference
=> Reference
,
1247 First_Attribute
=> Prj
.Attr
.Attribute_First
,
1248 Current_Project
=> Current_Project
,
1249 Current_Package
=> Empty_Node
);
1250 Set_Current_Term
(Term
, To
=> Reference
);
1253 -- Same checks as above for the expression kind
1255 if Reference
/= Empty_Node
then
1256 if Expr_Kind
= Undefined
then
1257 Expr_Kind
:= Expression_Kind_Of
(Reference
);
1259 elsif Expr_Kind
= Single
1260 and then Expression_Kind_Of
(Reference
) = List
1263 ("lists cannot appear in single string expression",
1268 when Tok_External
=>
1269 -- An external reference is always a single string
1271 if Expr_Kind
= Undefined
then
1272 Expr_Kind
:= Single
;
1275 External_Reference
(External_Value
=> Reference
);
1276 Set_Current_Term
(Term
, To
=> Reference
);
1279 Error_Msg
("cannot be part of an expression", Token_Ptr
);
1284 -- If there is an '&', call Terms recursively
1286 if Token
= Tok_Ampersand
then
1288 -- Scan past the '&'
1292 Terms
(Term
=> Next_Term
,
1293 Expr_Kind
=> Expr_Kind
,
1294 Current_Project
=> Current_Project
,
1295 Current_Package
=> Current_Package
);
1297 -- And link the next term to this term
1299 Set_Next_Term
(Term
, To
=> Next_Term
);