1598 lines
54 KiB
Ada
1598 lines
54 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT COMPILER COMPONENTS --
|
|
-- --
|
|
-- P R J . S T R T --
|
|
-- --
|
|
-- B o d y --
|
|
-- --
|
|
-- Copyright (C) 2001-2016, Free Software Foundation, Inc. --
|
|
-- --
|
|
-- GNAT is free software; you can redistribute it and/or modify it under --
|
|
-- terms of the GNU General Public License as published by the Free Soft- --
|
|
-- ware Foundation; either version 3, or (at your option) any later ver- --
|
|
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
|
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
|
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
|
|
-- for more details. You should have received a copy of the GNU General --
|
|
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
|
|
-- http://www.gnu.org/licenses for a complete copy of the license. --
|
|
-- --
|
|
-- GNAT was originally developed by the GNAT team at New York University. --
|
|
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
-- --
|
|
------------------------------------------------------------------------------
|
|
|
|
with Err_Vars; use Err_Vars;
|
|
with Prj.Attr; use Prj.Attr;
|
|
with Prj.Err; use Prj.Err;
|
|
with Snames;
|
|
with Table;
|
|
with Uintp; use Uintp;
|
|
|
|
package body Prj.Strt is
|
|
|
|
Buffer : String_Access;
|
|
Buffer_Last : Natural := 0;
|
|
|
|
type Choice_String is record
|
|
The_String : Name_Id;
|
|
Already_Used : Boolean := False;
|
|
end record;
|
|
-- The string of a case label, and an indication that it has already
|
|
-- been used (to avoid duplicate case labels).
|
|
|
|
Choices_Initial : constant := 10;
|
|
Choices_Increment : constant := 100;
|
|
-- These should be in alloc.ads
|
|
|
|
Choice_Node_Low_Bound : constant := 0;
|
|
Choice_Node_High_Bound : constant := 099_999_999;
|
|
-- In practice, infinite
|
|
|
|
type Choice_Node_Id is
|
|
range Choice_Node_Low_Bound .. Choice_Node_High_Bound;
|
|
|
|
First_Choice_Node_Id : constant Choice_Node_Id :=
|
|
Choice_Node_Low_Bound;
|
|
|
|
package Choices is
|
|
new Table.Table
|
|
(Table_Component_Type => Choice_String,
|
|
Table_Index_Type => Choice_Node_Id'Base,
|
|
Table_Low_Bound => First_Choice_Node_Id,
|
|
Table_Initial => Choices_Initial,
|
|
Table_Increment => Choices_Increment,
|
|
Table_Name => "Prj.Strt.Choices");
|
|
-- Used to store the case labels and check that there is no duplicate
|
|
|
|
package Choice_Lasts is
|
|
new Table.Table
|
|
(Table_Component_Type => Choice_Node_Id,
|
|
Table_Index_Type => Nat,
|
|
Table_Low_Bound => 1,
|
|
Table_Initial => 10,
|
|
Table_Increment => 100,
|
|
Table_Name => "Prj.Strt.Choice_Lasts");
|
|
-- Used to store the indexes of the choices in table Choices, to
|
|
-- distinguish nested case constructions.
|
|
|
|
Choice_First : Choice_Node_Id := 0;
|
|
-- Index in table Choices of the first case label of the current
|
|
-- case construction. Zero means no current case construction.
|
|
|
|
type Name_Location is record
|
|
Name : Name_Id := No_Name;
|
|
Location : Source_Ptr := No_Location;
|
|
end record;
|
|
-- Store the identifier and the location of a simple name
|
|
|
|
package Names is
|
|
new Table.Table
|
|
(Table_Component_Type => Name_Location,
|
|
Table_Index_Type => Nat,
|
|
Table_Low_Bound => 1,
|
|
Table_Initial => 10,
|
|
Table_Increment => 100,
|
|
Table_Name => "Prj.Strt.Names");
|
|
-- Used to accumulate the single names of a name
|
|
|
|
procedure Add (This_String : Name_Id);
|
|
-- Add a string to the case label list, indicating that it has not
|
|
-- yet been used.
|
|
|
|
procedure Add_To_Names (NL : Name_Location);
|
|
-- Add one single names to table Names
|
|
|
|
procedure External_Reference
|
|
(In_Tree : Project_Node_Tree_Ref;
|
|
Current_Project : Project_Node_Id;
|
|
Current_Package : Project_Node_Id;
|
|
External_Value : out Project_Node_Id;
|
|
Expr_Kind : in out Variable_Kind;
|
|
Flags : Processing_Flags);
|
|
-- Parse an external reference. Current token is "external"
|
|
|
|
procedure Attribute_Reference
|
|
(In_Tree : Project_Node_Tree_Ref;
|
|
Reference : out Project_Node_Id;
|
|
First_Attribute : Attribute_Node_Id;
|
|
Current_Project : Project_Node_Id;
|
|
Current_Package : Project_Node_Id;
|
|
Flags : Processing_Flags);
|
|
-- Parse an attribute reference. Current token is an apostrophe
|
|
|
|
procedure Terms
|
|
(In_Tree : Project_Node_Tree_Ref;
|
|
Term : out Project_Node_Id;
|
|
Expr_Kind : in out Variable_Kind;
|
|
Current_Project : Project_Node_Id;
|
|
Current_Package : Project_Node_Id;
|
|
Optional_Index : Boolean;
|
|
Flags : Processing_Flags);
|
|
-- Recursive procedure to parse one term or several terms concatenated
|
|
-- using "&".
|
|
|
|
---------
|
|
-- Add --
|
|
---------
|
|
|
|
procedure Add (This_String : Name_Id) is
|
|
begin
|
|
Choices.Increment_Last;
|
|
Choices.Table (Choices.Last) :=
|
|
(The_String => This_String,
|
|
Already_Used => False);
|
|
end Add;
|
|
|
|
------------------
|
|
-- Add_To_Names --
|
|
------------------
|
|
|
|
procedure Add_To_Names (NL : Name_Location) is
|
|
begin
|
|
Names.Increment_Last;
|
|
Names.Table (Names.Last) := NL;
|
|
end Add_To_Names;
|
|
|
|
-------------------------
|
|
-- Attribute_Reference --
|
|
-------------------------
|
|
|
|
procedure Attribute_Reference
|
|
(In_Tree : Project_Node_Tree_Ref;
|
|
Reference : out Project_Node_Id;
|
|
First_Attribute : Attribute_Node_Id;
|
|
Current_Project : Project_Node_Id;
|
|
Current_Package : Project_Node_Id;
|
|
Flags : Processing_Flags)
|
|
is
|
|
Current_Attribute : Attribute_Node_Id := First_Attribute;
|
|
|
|
begin
|
|
-- Declare the node of the attribute reference
|
|
|
|
Reference :=
|
|
Default_Project_Node
|
|
(Of_Kind => N_Attribute_Reference, In_Tree => In_Tree);
|
|
Set_Location_Of (Reference, In_Tree, To => Token_Ptr);
|
|
Scan (In_Tree); -- past apostrophe
|
|
|
|
-- Body may be an attribute name
|
|
|
|
if Token = Tok_Body then
|
|
Token := Tok_Identifier;
|
|
Token_Name := Snames.Name_Body;
|
|
end if;
|
|
|
|
Expect (Tok_Identifier, "identifier");
|
|
|
|
if Token = Tok_Identifier then
|
|
Set_Name_Of (Reference, In_Tree, To => Token_Name);
|
|
|
|
-- Check if the identifier is one of the attribute identifiers in the
|
|
-- context (package or project level attributes).
|
|
|
|
Current_Attribute :=
|
|
Attribute_Node_Id_Of (Token_Name, Starting_At => First_Attribute);
|
|
|
|
-- If the identifier is not allowed, report an error
|
|
|
|
if Current_Attribute = Empty_Attribute then
|
|
Error_Msg_Name_1 := Token_Name;
|
|
Error_Msg (Flags, "unknown attribute %%", Token_Ptr);
|
|
Reference := Empty_Node;
|
|
|
|
-- Scan past the attribute name
|
|
|
|
Scan (In_Tree);
|
|
|
|
-- Skip a possible index for an associative array
|
|
|
|
if Token = Tok_Left_Paren then
|
|
Scan (In_Tree);
|
|
|
|
if Token = Tok_String_Literal then
|
|
Scan (In_Tree);
|
|
|
|
if Token = Tok_Right_Paren then
|
|
Scan (In_Tree);
|
|
end if;
|
|
end if;
|
|
end if;
|
|
|
|
else
|
|
-- Give its characteristics to this attribute reference
|
|
|
|
Set_Project_Node_Of (Reference, In_Tree, To => Current_Project);
|
|
Set_Package_Node_Of (Reference, In_Tree, To => Current_Package);
|
|
Set_Expression_Kind_Of
|
|
(Reference, In_Tree, To => Variable_Kind_Of (Current_Attribute));
|
|
Set_Case_Insensitive
|
|
(Reference, In_Tree,
|
|
To => Attribute_Kind_Of (Current_Attribute) in
|
|
All_Case_Insensitive_Associative_Array);
|
|
Set_Default_Of
|
|
(Reference, In_Tree,
|
|
To => Attribute_Default_Of (Current_Attribute));
|
|
|
|
-- Scan past the attribute name
|
|
|
|
Scan (In_Tree);
|
|
|
|
-- If the attribute is an associative array, get the index
|
|
|
|
if Attribute_Kind_Of (Current_Attribute) /= Single then
|
|
Expect (Tok_Left_Paren, "`(`");
|
|
|
|
if Token = Tok_Left_Paren then
|
|
Scan (In_Tree);
|
|
|
|
if Others_Allowed_For (Current_Attribute)
|
|
and then Token = Tok_Others
|
|
then
|
|
Set_Associative_Array_Index_Of
|
|
(Reference, In_Tree, To => All_Other_Names);
|
|
Scan (In_Tree);
|
|
|
|
else
|
|
if Others_Allowed_For (Current_Attribute) then
|
|
Expect
|
|
(Tok_String_Literal, "literal string or others");
|
|
else
|
|
Expect (Tok_String_Literal, "literal string");
|
|
end if;
|
|
|
|
if Token = Tok_String_Literal then
|
|
Set_Associative_Array_Index_Of
|
|
(Reference, In_Tree, To => Token_Name);
|
|
Scan (In_Tree);
|
|
end if;
|
|
end if;
|
|
end if;
|
|
|
|
Expect (Tok_Right_Paren, "`)`");
|
|
|
|
if Token = Tok_Right_Paren then
|
|
Scan (In_Tree);
|
|
end if;
|
|
end if;
|
|
end if;
|
|
|
|
-- Change name of obsolete attributes
|
|
|
|
if Present (Reference) then
|
|
case Name_Of (Reference, In_Tree) is
|
|
when Snames.Name_Specification =>
|
|
Set_Name_Of (Reference, In_Tree, To => Snames.Name_Spec);
|
|
|
|
when Snames.Name_Specification_Suffix =>
|
|
Set_Name_Of
|
|
(Reference, In_Tree, To => Snames.Name_Spec_Suffix);
|
|
|
|
when Snames.Name_Implementation =>
|
|
Set_Name_Of (Reference, In_Tree, To => Snames.Name_Body);
|
|
|
|
when Snames.Name_Implementation_Suffix =>
|
|
Set_Name_Of
|
|
(Reference, In_Tree, To => Snames.Name_Body_Suffix);
|
|
|
|
when others =>
|
|
null;
|
|
end case;
|
|
end if;
|
|
end if;
|
|
end Attribute_Reference;
|
|
|
|
---------------------------
|
|
-- End_Case_Construction --
|
|
---------------------------
|
|
|
|
procedure End_Case_Construction
|
|
(Check_All_Labels : Boolean;
|
|
Case_Location : Source_Ptr;
|
|
Flags : Processing_Flags;
|
|
String_Type : Boolean)
|
|
is
|
|
Non_Used : Natural := 0;
|
|
First_Non_Used : Choice_Node_Id := First_Choice_Node_Id;
|
|
|
|
begin
|
|
-- First, if Check_All_Labels is True, check if all values of the string
|
|
-- type have been used.
|
|
|
|
if Check_All_Labels then
|
|
if String_Type then
|
|
for Choice in Choice_First .. Choices.Last loop
|
|
if not Choices.Table (Choice).Already_Used then
|
|
Non_Used := Non_Used + 1;
|
|
|
|
if Non_Used = 1 then
|
|
First_Non_Used := Choice;
|
|
end if;
|
|
end if;
|
|
end loop;
|
|
|
|
-- If only one is not used, report a single warning for this value
|
|
|
|
if Non_Used = 1 then
|
|
Error_Msg_Name_1 := Choices.Table (First_Non_Used).The_String;
|
|
Error_Msg
|
|
(Flags, "?value %% is not used as label", Case_Location);
|
|
|
|
-- If several are not used, report a warning for each one of them
|
|
|
|
elsif Non_Used > 1 then
|
|
Error_Msg
|
|
(Flags, "?the following values are not used as labels:",
|
|
Case_Location);
|
|
|
|
for Choice in First_Non_Used .. Choices.Last loop
|
|
if not Choices.Table (Choice).Already_Used then
|
|
Error_Msg_Name_1 := Choices.Table (Choice).The_String;
|
|
Error_Msg (Flags, "\?%%", Case_Location);
|
|
end if;
|
|
end loop;
|
|
end if;
|
|
else
|
|
Error_Msg
|
|
(Flags,
|
|
"?no when others for this case construction",
|
|
Case_Location);
|
|
end if;
|
|
end if;
|
|
|
|
-- If this is the only case construction, empty the tables
|
|
|
|
if Choice_Lasts.Last = 1 then
|
|
Choice_Lasts.Set_Last (0);
|
|
Choices.Set_Last (First_Choice_Node_Id);
|
|
Choice_First := 0;
|
|
|
|
-- Second case construction, set the tables to the first
|
|
|
|
elsif Choice_Lasts.Last = 2 then
|
|
Choice_Lasts.Set_Last (1);
|
|
Choices.Set_Last (Choice_Lasts.Table (1));
|
|
Choice_First := 1;
|
|
|
|
-- Third or more case construction, set the tables to the previous one
|
|
else
|
|
Choice_Lasts.Decrement_Last;
|
|
Choices.Set_Last (Choice_Lasts.Table (Choice_Lasts.Last));
|
|
Choice_First := Choice_Lasts.Table (Choice_Lasts.Last - 1) + 1;
|
|
end if;
|
|
end End_Case_Construction;
|
|
|
|
------------------------
|
|
-- External_Reference --
|
|
------------------------
|
|
|
|
procedure External_Reference
|
|
(In_Tree : Project_Node_Tree_Ref;
|
|
Current_Project : Project_Node_Id;
|
|
Current_Package : Project_Node_Id;
|
|
External_Value : out Project_Node_Id;
|
|
Expr_Kind : in out Variable_Kind;
|
|
Flags : Processing_Flags)
|
|
is
|
|
Field_Id : Project_Node_Id := Empty_Node;
|
|
Ext_List : Boolean := False;
|
|
|
|
begin
|
|
External_Value :=
|
|
Default_Project_Node
|
|
(Of_Kind => N_External_Value,
|
|
In_Tree => In_Tree);
|
|
Set_Location_Of (External_Value, In_Tree, To => Token_Ptr);
|
|
|
|
-- The current token is either external or external_as_list
|
|
|
|
Ext_List := Token = Tok_External_As_List;
|
|
Scan (In_Tree);
|
|
|
|
if Ext_List then
|
|
Set_Expression_Kind_Of (External_Value, In_Tree, To => List);
|
|
else
|
|
Set_Expression_Kind_Of (External_Value, In_Tree, To => Single);
|
|
end if;
|
|
|
|
if Expr_Kind = Undefined then
|
|
if Ext_List then
|
|
Expr_Kind := List;
|
|
else
|
|
Expr_Kind := Single;
|
|
end if;
|
|
end if;
|
|
|
|
Expect (Tok_Left_Paren, "`(`");
|
|
|
|
-- Scan past the left parenthesis
|
|
|
|
if Token = Tok_Left_Paren then
|
|
Scan (In_Tree);
|
|
end if;
|
|
|
|
-- Get the name of the external reference
|
|
|
|
Expect (Tok_String_Literal, "literal string");
|
|
|
|
if Token = Tok_String_Literal then
|
|
Field_Id :=
|
|
Default_Project_Node
|
|
(Of_Kind => N_Literal_String,
|
|
In_Tree => In_Tree,
|
|
And_Expr_Kind => Single);
|
|
Set_String_Value_Of (Field_Id, In_Tree, To => Token_Name);
|
|
Set_External_Reference_Of (External_Value, In_Tree, To => Field_Id);
|
|
|
|
-- Scan past the first argument
|
|
|
|
Scan (In_Tree);
|
|
|
|
case Token is
|
|
when Tok_Right_Paren =>
|
|
if Ext_List then
|
|
Error_Msg (Flags, "`,` expected", Token_Ptr);
|
|
end if;
|
|
|
|
Scan (In_Tree); -- scan past right paren
|
|
|
|
when Tok_Comma =>
|
|
Scan (In_Tree); -- scan past comma
|
|
|
|
-- Get the string expression for the default
|
|
|
|
declare
|
|
Loc : constant Source_Ptr := Token_Ptr;
|
|
|
|
begin
|
|
Parse_Expression
|
|
(In_Tree => In_Tree,
|
|
Expression => Field_Id,
|
|
Flags => Flags,
|
|
Current_Project => Current_Project,
|
|
Current_Package => Current_Package,
|
|
Optional_Index => False);
|
|
|
|
if Expression_Kind_Of (Field_Id, In_Tree) = List then
|
|
Error_Msg
|
|
(Flags, "expression must be a single string", Loc);
|
|
else
|
|
Set_External_Default_Of
|
|
(External_Value, In_Tree, To => Field_Id);
|
|
end if;
|
|
end;
|
|
|
|
Expect (Tok_Right_Paren, "`)`");
|
|
|
|
if Token = Tok_Right_Paren then
|
|
Scan (In_Tree); -- scan past right paren
|
|
end if;
|
|
|
|
when others =>
|
|
if Ext_List then
|
|
Error_Msg (Flags, "`,` expected", Token_Ptr);
|
|
else
|
|
Error_Msg (Flags, "`,` or `)` expected", Token_Ptr);
|
|
end if;
|
|
end case;
|
|
end if;
|
|
end External_Reference;
|
|
|
|
-----------------------
|
|
-- Parse_Choice_List --
|
|
-----------------------
|
|
|
|
procedure Parse_Choice_List
|
|
(In_Tree : Project_Node_Tree_Ref;
|
|
First_Choice : out Project_Node_Id;
|
|
Flags : Processing_Flags;
|
|
String_Type : Boolean := True)
|
|
is
|
|
Current_Choice : Project_Node_Id := Empty_Node;
|
|
Next_Choice : Project_Node_Id := Empty_Node;
|
|
Choice_String : Name_Id := No_Name;
|
|
Found : Boolean := False;
|
|
|
|
begin
|
|
-- Declare the node of the first choice
|
|
|
|
First_Choice :=
|
|
Default_Project_Node
|
|
(Of_Kind => N_Literal_String,
|
|
In_Tree => In_Tree,
|
|
And_Expr_Kind => Single);
|
|
|
|
-- Initially Current_Choice is the same as First_Choice
|
|
|
|
Current_Choice := First_Choice;
|
|
|
|
loop
|
|
Expect (Tok_String_Literal, "literal string");
|
|
exit when Token /= Tok_String_Literal;
|
|
Set_Location_Of (Current_Choice, In_Tree, To => Token_Ptr);
|
|
Choice_String := Token_Name;
|
|
|
|
-- Give the string value to the current choice
|
|
|
|
Set_String_Value_Of (Current_Choice, In_Tree, To => Choice_String);
|
|
|
|
if String_Type then
|
|
|
|
-- Check if the label is part of the string type and if it has not
|
|
-- been already used.
|
|
|
|
Found := False;
|
|
for Choice in Choice_First .. Choices.Last loop
|
|
if Choices.Table (Choice).The_String = Choice_String then
|
|
|
|
-- This label is part of the string type
|
|
|
|
Found := True;
|
|
|
|
if Choices.Table (Choice).Already_Used then
|
|
|
|
-- But it has already appeared in a choice list for this
|
|
-- case construction so report an error.
|
|
|
|
Error_Msg_Name_1 := Choice_String;
|
|
Error_Msg (Flags, "duplicate case label %%", Token_Ptr);
|
|
|
|
else
|
|
Choices.Table (Choice).Already_Used := True;
|
|
end if;
|
|
|
|
exit;
|
|
end if;
|
|
end loop;
|
|
|
|
-- If the label is not part of the string list, report an error
|
|
|
|
if not Found then
|
|
Error_Msg_Name_1 := Choice_String;
|
|
Error_Msg (Flags, "illegal case label %%", Token_Ptr);
|
|
end if;
|
|
end if;
|
|
|
|
-- Scan past the label
|
|
|
|
Scan (In_Tree);
|
|
|
|
-- If there is no '|', we are done
|
|
|
|
if Token = Tok_Vertical_Bar then
|
|
|
|
-- Otherwise, declare the node of the next choice, link it to
|
|
-- Current_Choice and set Current_Choice to this new node.
|
|
|
|
Next_Choice :=
|
|
Default_Project_Node
|
|
(Of_Kind => N_Literal_String,
|
|
In_Tree => In_Tree,
|
|
And_Expr_Kind => Single);
|
|
Set_Next_Literal_String
|
|
(Current_Choice, In_Tree, To => Next_Choice);
|
|
Current_Choice := Next_Choice;
|
|
Scan (In_Tree);
|
|
else
|
|
exit;
|
|
end if;
|
|
end loop;
|
|
end Parse_Choice_List;
|
|
|
|
----------------------
|
|
-- Parse_Expression --
|
|
----------------------
|
|
|
|
procedure Parse_Expression
|
|
(In_Tree : Project_Node_Tree_Ref;
|
|
Expression : out Project_Node_Id;
|
|
Current_Project : Project_Node_Id;
|
|
Current_Package : Project_Node_Id;
|
|
Optional_Index : Boolean;
|
|
Flags : Processing_Flags)
|
|
is
|
|
First_Term : Project_Node_Id := Empty_Node;
|
|
Expression_Kind : Variable_Kind := Undefined;
|
|
|
|
begin
|
|
-- Declare the node of the expression
|
|
|
|
Expression :=
|
|
Default_Project_Node (Of_Kind => N_Expression, In_Tree => In_Tree);
|
|
Set_Location_Of (Expression, In_Tree, To => Token_Ptr);
|
|
|
|
-- Parse the term or terms of the expression
|
|
|
|
Terms (In_Tree => In_Tree,
|
|
Term => First_Term,
|
|
Expr_Kind => Expression_Kind,
|
|
Flags => Flags,
|
|
Current_Project => Current_Project,
|
|
Current_Package => Current_Package,
|
|
Optional_Index => Optional_Index);
|
|
|
|
-- Set the first term and the expression kind
|
|
|
|
Set_First_Term (Expression, In_Tree, To => First_Term);
|
|
Set_Expression_Kind_Of (Expression, In_Tree, To => Expression_Kind);
|
|
end Parse_Expression;
|
|
|
|
----------------------------
|
|
-- Parse_String_Type_List --
|
|
----------------------------
|
|
|
|
procedure Parse_String_Type_List
|
|
(In_Tree : Project_Node_Tree_Ref;
|
|
First_String : out Project_Node_Id;
|
|
Flags : Processing_Flags)
|
|
is
|
|
Last_String : Project_Node_Id := Empty_Node;
|
|
Next_String : Project_Node_Id := Empty_Node;
|
|
String_Value : Name_Id := No_Name;
|
|
|
|
begin
|
|
-- Declare the node of the first string
|
|
|
|
First_String :=
|
|
Default_Project_Node
|
|
(Of_Kind => N_Literal_String,
|
|
In_Tree => In_Tree,
|
|
And_Expr_Kind => Single);
|
|
|
|
-- Initially, Last_String is the same as First_String
|
|
|
|
Last_String := First_String;
|
|
|
|
loop
|
|
Expect (Tok_String_Literal, "literal string");
|
|
exit when Token /= Tok_String_Literal;
|
|
String_Value := Token_Name;
|
|
|
|
-- Give its string value to Last_String
|
|
|
|
Set_String_Value_Of (Last_String, In_Tree, To => String_Value);
|
|
Set_Location_Of (Last_String, In_Tree, To => Token_Ptr);
|
|
|
|
-- Now, check if the string is already part of the string type
|
|
|
|
declare
|
|
Current : Project_Node_Id := First_String;
|
|
|
|
begin
|
|
while Current /= Last_String loop
|
|
if String_Value_Of (Current, In_Tree) = String_Value then
|
|
|
|
-- This is a repetition, report an error
|
|
|
|
Error_Msg_Name_1 := String_Value;
|
|
Error_Msg (Flags, "duplicate value %% in type", Token_Ptr);
|
|
exit;
|
|
end if;
|
|
|
|
Current := Next_Literal_String (Current, In_Tree);
|
|
end loop;
|
|
end;
|
|
|
|
-- Scan past the literal string
|
|
|
|
Scan (In_Tree);
|
|
|
|
-- If there is no comma following the literal string, we are done
|
|
|
|
if Token /= Tok_Comma then
|
|
exit;
|
|
|
|
else
|
|
-- Declare the next string, link it to Last_String and set
|
|
-- Last_String to its node.
|
|
|
|
Next_String :=
|
|
Default_Project_Node
|
|
(Of_Kind => N_Literal_String,
|
|
In_Tree => In_Tree,
|
|
And_Expr_Kind => Single);
|
|
Set_Next_Literal_String (Last_String, In_Tree, To => Next_String);
|
|
Last_String := Next_String;
|
|
Scan (In_Tree);
|
|
end if;
|
|
end loop;
|
|
end Parse_String_Type_List;
|
|
|
|
------------------------------
|
|
-- Parse_Variable_Reference --
|
|
------------------------------
|
|
|
|
procedure Parse_Variable_Reference
|
|
(In_Tree : Project_Node_Tree_Ref;
|
|
Variable : out Project_Node_Id;
|
|
Current_Project : Project_Node_Id;
|
|
Current_Package : Project_Node_Id;
|
|
Flags : Processing_Flags)
|
|
is
|
|
Current_Variable : Project_Node_Id := Empty_Node;
|
|
|
|
The_Package : Project_Node_Id := Current_Package;
|
|
The_Project : Project_Node_Id := Current_Project;
|
|
|
|
Specified_Project : Project_Node_Id := Empty_Node;
|
|
Specified_Package : Project_Node_Id := Empty_Node;
|
|
Look_For_Variable : Boolean := True;
|
|
First_Attribute : Attribute_Node_Id := Empty_Attribute;
|
|
Variable_Name : Name_Id;
|
|
|
|
begin
|
|
Names.Init;
|
|
|
|
loop
|
|
Expect (Tok_Identifier, "identifier");
|
|
|
|
if Token /= Tok_Identifier then
|
|
Look_For_Variable := False;
|
|
exit;
|
|
end if;
|
|
|
|
Add_To_Names (NL => (Name => Token_Name, Location => Token_Ptr));
|
|
Scan (In_Tree);
|
|
exit when Token /= Tok_Dot;
|
|
Scan (In_Tree);
|
|
end loop;
|
|
|
|
if Look_For_Variable then
|
|
|
|
if Token = Tok_Apostrophe then
|
|
|
|
-- Attribute reference
|
|
|
|
case Names.Last is
|
|
when 0 =>
|
|
|
|
-- Cannot happen
|
|
|
|
null;
|
|
|
|
when 1 =>
|
|
-- This may be a project name or a package name.
|
|
-- Project name have precedence.
|
|
|
|
-- First, look if it can be a package name
|
|
|
|
First_Attribute :=
|
|
First_Attribute_Of
|
|
(Package_Node_Id_Of (Names.Table (1).Name));
|
|
|
|
-- Now, look if it can be a project name
|
|
|
|
if Names.Table (1).Name =
|
|
Name_Of (Current_Project, In_Tree)
|
|
then
|
|
The_Project := Current_Project;
|
|
|
|
else
|
|
The_Project :=
|
|
Imported_Or_Extended_Project_Of
|
|
(Current_Project, In_Tree, Names.Table (1).Name);
|
|
end if;
|
|
|
|
if No (The_Project) then
|
|
|
|
-- If it is neither a project name nor a package name,
|
|
-- report an error.
|
|
|
|
if First_Attribute = Empty_Attribute then
|
|
Error_Msg_Name_1 := Names.Table (1).Name;
|
|
Error_Msg (Flags, "unknown project %",
|
|
Names.Table (1).Location);
|
|
First_Attribute := Attribute_First;
|
|
|
|
else
|
|
-- If it is a package name, check if the package has
|
|
-- already been declared in the current project.
|
|
|
|
The_Package :=
|
|
First_Package_Of (Current_Project, In_Tree);
|
|
|
|
while Present (The_Package)
|
|
and then Name_Of (The_Package, In_Tree) /=
|
|
Names.Table (1).Name
|
|
loop
|
|
The_Package :=
|
|
Next_Package_In_Project (The_Package, In_Tree);
|
|
end loop;
|
|
|
|
-- If it has not been already declared, report an
|
|
-- error.
|
|
|
|
if No (The_Package) then
|
|
Error_Msg_Name_1 := Names.Table (1).Name;
|
|
Error_Msg (Flags, "package % not yet defined",
|
|
Names.Table (1).Location);
|
|
end if;
|
|
end if;
|
|
|
|
else
|
|
-- It is a project name
|
|
|
|
First_Attribute := Attribute_First;
|
|
The_Package := Empty_Node;
|
|
end if;
|
|
|
|
when others =>
|
|
|
|
-- We have either a project name made of several simple
|
|
-- names (long project), or a project name (short project)
|
|
-- followed by a package name. The long project name has
|
|
-- precedence.
|
|
|
|
declare
|
|
Short_Project : Name_Id;
|
|
Long_Project : Name_Id;
|
|
|
|
begin
|
|
-- Clear the Buffer
|
|
|
|
Buffer_Last := 0;
|
|
|
|
-- Get the name of the short project
|
|
|
|
for Index in 1 .. Names.Last - 1 loop
|
|
Add_To_Buffer
|
|
(Get_Name_String (Names.Table (Index).Name),
|
|
Buffer, Buffer_Last);
|
|
|
|
if Index /= Names.Last - 1 then
|
|
Add_To_Buffer (".", Buffer, Buffer_Last);
|
|
end if;
|
|
end loop;
|
|
|
|
Name_Len := Buffer_Last;
|
|
Name_Buffer (1 .. Buffer_Last) :=
|
|
Buffer (1 .. Buffer_Last);
|
|
Short_Project := Name_Find;
|
|
|
|
-- Now, add the last simple name to get the name of the
|
|
-- long project.
|
|
|
|
Add_To_Buffer (".", Buffer, Buffer_Last);
|
|
Add_To_Buffer
|
|
(Get_Name_String (Names.Table (Names.Last).Name),
|
|
Buffer, Buffer_Last);
|
|
Name_Len := Buffer_Last;
|
|
Name_Buffer (1 .. Buffer_Last) :=
|
|
Buffer (1 .. Buffer_Last);
|
|
Long_Project := Name_Find;
|
|
|
|
-- Check if the long project is imported or extended
|
|
|
|
if Long_Project = Name_Of (Current_Project, In_Tree) then
|
|
The_Project := Current_Project;
|
|
|
|
else
|
|
The_Project :=
|
|
Imported_Or_Extended_Project_Of
|
|
(Current_Project,
|
|
In_Tree,
|
|
Long_Project);
|
|
end if;
|
|
|
|
-- If the long project exists, then this is the prefix
|
|
-- of the attribute.
|
|
|
|
if Present (The_Project) then
|
|
First_Attribute := Attribute_First;
|
|
The_Package := Empty_Node;
|
|
|
|
else
|
|
-- Otherwise, check if the short project is imported
|
|
-- or extended.
|
|
|
|
if Short_Project =
|
|
Name_Of (Current_Project, In_Tree)
|
|
then
|
|
The_Project := Current_Project;
|
|
|
|
else
|
|
The_Project := Imported_Or_Extended_Project_Of
|
|
(Current_Project, In_Tree,
|
|
Short_Project);
|
|
end if;
|
|
|
|
-- If short project does not exist, report an error
|
|
|
|
if No (The_Project) then
|
|
Error_Msg_Name_1 := Long_Project;
|
|
Error_Msg_Name_2 := Short_Project;
|
|
Error_Msg (Flags, "unknown projects % or %",
|
|
Names.Table (1).Location);
|
|
The_Package := Empty_Node;
|
|
First_Attribute := Attribute_First;
|
|
|
|
else
|
|
-- Now, we check if the package has been declared
|
|
-- in this project.
|
|
|
|
The_Package :=
|
|
First_Package_Of (The_Project, In_Tree);
|
|
while Present (The_Package)
|
|
and then Name_Of (The_Package, In_Tree) /=
|
|
Names.Table (Names.Last).Name
|
|
loop
|
|
The_Package :=
|
|
Next_Package_In_Project (The_Package, In_Tree);
|
|
end loop;
|
|
|
|
-- If it has not, then we report an error
|
|
|
|
if No (The_Package) then
|
|
Error_Msg_Name_1 :=
|
|
Names.Table (Names.Last).Name;
|
|
Error_Msg_Name_2 := Short_Project;
|
|
Error_Msg (Flags,
|
|
"package % not declared in project %",
|
|
Names.Table (Names.Last).Location);
|
|
First_Attribute := Attribute_First;
|
|
|
|
else
|
|
-- Otherwise, we have the correct project and
|
|
-- package.
|
|
|
|
First_Attribute :=
|
|
First_Attribute_Of
|
|
(Package_Id_Of (The_Package, In_Tree));
|
|
end if;
|
|
end if;
|
|
end if;
|
|
end;
|
|
end case;
|
|
|
|
Attribute_Reference
|
|
(In_Tree,
|
|
Variable,
|
|
Flags => Flags,
|
|
Current_Project => The_Project,
|
|
Current_Package => The_Package,
|
|
First_Attribute => First_Attribute);
|
|
return;
|
|
end if;
|
|
end if;
|
|
|
|
Variable :=
|
|
Default_Project_Node
|
|
(Of_Kind => N_Variable_Reference, In_Tree => In_Tree);
|
|
|
|
if Look_For_Variable then
|
|
case Names.Last is
|
|
when 0 =>
|
|
|
|
-- Cannot happen (so why null instead of raise PE???)
|
|
|
|
null;
|
|
|
|
when 1 =>
|
|
|
|
-- Simple variable name
|
|
|
|
Set_Name_Of (Variable, In_Tree, To => Names.Table (1).Name);
|
|
|
|
when 2 =>
|
|
|
|
-- Variable name with a simple name prefix that can be
|
|
-- a project name or a package name. Project names have
|
|
-- priority over package names.
|
|
|
|
Set_Name_Of (Variable, In_Tree, To => Names.Table (2).Name);
|
|
|
|
-- Check if it can be a package name
|
|
|
|
The_Package := First_Package_Of (Current_Project, In_Tree);
|
|
|
|
while Present (The_Package)
|
|
and then Name_Of (The_Package, In_Tree) /=
|
|
Names.Table (1).Name
|
|
loop
|
|
The_Package :=
|
|
Next_Package_In_Project (The_Package, In_Tree);
|
|
end loop;
|
|
|
|
-- Now look for a possible project name
|
|
|
|
The_Project := Imported_Or_Extended_Project_Of
|
|
(Current_Project, In_Tree, Names.Table (1).Name);
|
|
|
|
if Present (The_Project) then
|
|
Specified_Project := The_Project;
|
|
|
|
elsif No (The_Package) then
|
|
Error_Msg_Name_1 := Names.Table (1).Name;
|
|
Error_Msg (Flags, "unknown package or project %",
|
|
Names.Table (1).Location);
|
|
Look_For_Variable := False;
|
|
|
|
else
|
|
Specified_Package := The_Package;
|
|
end if;
|
|
|
|
when others =>
|
|
|
|
-- Variable name with a prefix that is either a project name
|
|
-- made of several simple names, or a project name followed
|
|
-- by a package name.
|
|
|
|
Set_Name_Of
|
|
(Variable, In_Tree, To => Names.Table (Names.Last).Name);
|
|
|
|
declare
|
|
Short_Project : Name_Id;
|
|
Long_Project : Name_Id;
|
|
|
|
begin
|
|
-- First, we get the two possible project names
|
|
|
|
-- Clear the buffer
|
|
|
|
Buffer_Last := 0;
|
|
|
|
-- Add all the simple names, except the last two
|
|
|
|
for Index in 1 .. Names.Last - 2 loop
|
|
Add_To_Buffer
|
|
(Get_Name_String (Names.Table (Index).Name),
|
|
Buffer, Buffer_Last);
|
|
|
|
if Index /= Names.Last - 2 then
|
|
Add_To_Buffer (".", Buffer, Buffer_Last);
|
|
end if;
|
|
end loop;
|
|
|
|
Name_Len := Buffer_Last;
|
|
Name_Buffer (1 .. Name_Len) := Buffer (1 .. Buffer_Last);
|
|
Short_Project := Name_Find;
|
|
|
|
-- Add the simple name before the name of the variable
|
|
|
|
Add_To_Buffer (".", Buffer, Buffer_Last);
|
|
Add_To_Buffer
|
|
(Get_Name_String (Names.Table (Names.Last - 1).Name),
|
|
Buffer, Buffer_Last);
|
|
Name_Len := Buffer_Last;
|
|
Name_Buffer (1 .. Name_Len) := Buffer (1 .. Buffer_Last);
|
|
Long_Project := Name_Find;
|
|
|
|
-- Check if the prefix is the name of an imported or
|
|
-- extended project.
|
|
|
|
The_Project := Imported_Or_Extended_Project_Of
|
|
(Current_Project, In_Tree, Long_Project);
|
|
|
|
if Present (The_Project) then
|
|
Specified_Project := The_Project;
|
|
|
|
else
|
|
-- Now check if the prefix may be a project name followed
|
|
-- by a package name.
|
|
|
|
-- First check for a possible project name
|
|
|
|
The_Project :=
|
|
Imported_Or_Extended_Project_Of
|
|
(Current_Project, In_Tree, Short_Project);
|
|
|
|
if No (The_Project) then
|
|
-- Unknown prefix, report an error
|
|
|
|
Error_Msg_Name_1 := Long_Project;
|
|
Error_Msg_Name_2 := Short_Project;
|
|
Error_Msg
|
|
(Flags, "unknown projects % or %",
|
|
Names.Table (1).Location);
|
|
Look_For_Variable := False;
|
|
|
|
else
|
|
Specified_Project := The_Project;
|
|
|
|
-- Now look for the package in this project
|
|
|
|
The_Package := First_Package_Of (The_Project, In_Tree);
|
|
|
|
while Present (The_Package)
|
|
and then Name_Of (The_Package, In_Tree) /=
|
|
Names.Table (Names.Last - 1).Name
|
|
loop
|
|
The_Package :=
|
|
Next_Package_In_Project (The_Package, In_Tree);
|
|
end loop;
|
|
|
|
if No (The_Package) then
|
|
|
|
-- The package does not exist, report an error
|
|
|
|
Error_Msg_Name_1 := Names.Table (2).Name;
|
|
Error_Msg (Flags, "unknown package %",
|
|
Names.Table (Names.Last - 1).Location);
|
|
Look_For_Variable := False;
|
|
|
|
else
|
|
Specified_Package := The_Package;
|
|
end if;
|
|
end if;
|
|
end if;
|
|
end;
|
|
end case;
|
|
end if;
|
|
|
|
if Look_For_Variable then
|
|
Variable_Name := Name_Of (Variable, In_Tree);
|
|
Set_Project_Node_Of (Variable, In_Tree, To => Specified_Project);
|
|
Set_Package_Node_Of (Variable, In_Tree, To => Specified_Package);
|
|
|
|
if Present (Specified_Project) then
|
|
The_Project := Specified_Project;
|
|
else
|
|
The_Project := Current_Project;
|
|
end if;
|
|
|
|
Current_Variable := Empty_Node;
|
|
|
|
-- Look for this variable
|
|
|
|
-- If a package was specified, check if the variable has been
|
|
-- declared in this package.
|
|
|
|
if Present (Specified_Package) then
|
|
Current_Variable :=
|
|
First_Variable_Of (Specified_Package, In_Tree);
|
|
while Present (Current_Variable)
|
|
and then
|
|
Name_Of (Current_Variable, In_Tree) /= Variable_Name
|
|
loop
|
|
Current_Variable := Next_Variable (Current_Variable, In_Tree);
|
|
end loop;
|
|
|
|
else
|
|
-- Otherwise, if no project has been specified and we are in
|
|
-- a package, first check if the variable has been declared in
|
|
-- the package.
|
|
|
|
if No (Specified_Project)
|
|
and then Present (Current_Package)
|
|
then
|
|
Current_Variable :=
|
|
First_Variable_Of (Current_Package, In_Tree);
|
|
while Present (Current_Variable)
|
|
and then Name_Of (Current_Variable, In_Tree) /= Variable_Name
|
|
loop
|
|
Current_Variable :=
|
|
Next_Variable (Current_Variable, In_Tree);
|
|
end loop;
|
|
end if;
|
|
|
|
-- If we have not found the variable in the package, check if the
|
|
-- variable has been declared in the project, or in any of its
|
|
-- ancestors, or in any of the project it extends.
|
|
|
|
if No (Current_Variable) then
|
|
declare
|
|
Proj : Project_Node_Id := The_Project;
|
|
|
|
begin
|
|
loop
|
|
Current_Variable := First_Variable_Of (Proj, In_Tree);
|
|
while
|
|
Present (Current_Variable)
|
|
and then
|
|
Name_Of (Current_Variable, In_Tree) /= Variable_Name
|
|
loop
|
|
Current_Variable :=
|
|
Next_Variable (Current_Variable, In_Tree);
|
|
end loop;
|
|
|
|
exit when Present (Current_Variable);
|
|
|
|
-- If the current project is a child project, check if
|
|
-- the variable is declared in its parent. Otherwise, if
|
|
-- the current project extends another project, check if
|
|
-- the variable is declared in one of the projects the
|
|
-- current project extends.
|
|
|
|
if No (Parent_Project_Of (Proj, In_Tree)) then
|
|
Proj :=
|
|
Extended_Project_Of
|
|
(Project_Declaration_Of (Proj, In_Tree), In_Tree);
|
|
else
|
|
Proj := Parent_Project_Of (Proj, In_Tree);
|
|
end if;
|
|
|
|
Set_Project_Node_Of (Variable, In_Tree, To => Proj);
|
|
|
|
exit when No (Proj);
|
|
end loop;
|
|
end;
|
|
end if;
|
|
end if;
|
|
|
|
-- If the variable was not found, report an error
|
|
|
|
if No (Current_Variable) then
|
|
Error_Msg_Name_1 := Variable_Name;
|
|
Error_Msg
|
|
(Flags, "unknown variable %", Names.Table (Names.Last).Location);
|
|
end if;
|
|
end if;
|
|
|
|
if Present (Current_Variable) then
|
|
Set_Expression_Kind_Of
|
|
(Variable, In_Tree,
|
|
To => Expression_Kind_Of (Current_Variable, In_Tree));
|
|
|
|
if Kind_Of (Current_Variable, In_Tree) =
|
|
N_Typed_Variable_Declaration
|
|
then
|
|
Set_String_Type_Of
|
|
(Variable, In_Tree,
|
|
To => String_Type_Of (Current_Variable, In_Tree));
|
|
end if;
|
|
end if;
|
|
|
|
-- If the variable is followed by a left parenthesis, report an error
|
|
-- but attempt to scan the index.
|
|
|
|
if Token = Tok_Left_Paren then
|
|
Error_Msg
|
|
(Flags, "\variables cannot be associative arrays", Token_Ptr);
|
|
Scan (In_Tree);
|
|
Expect (Tok_String_Literal, "literal string");
|
|
|
|
if Token = Tok_String_Literal then
|
|
Scan (In_Tree);
|
|
Expect (Tok_Right_Paren, "`)`");
|
|
|
|
if Token = Tok_Right_Paren then
|
|
Scan (In_Tree);
|
|
end if;
|
|
end if;
|
|
end if;
|
|
end Parse_Variable_Reference;
|
|
|
|
---------------------------------
|
|
-- Start_New_Case_Construction --
|
|
---------------------------------
|
|
|
|
procedure Start_New_Case_Construction
|
|
(In_Tree : Project_Node_Tree_Ref;
|
|
String_Type : Project_Node_Id)
|
|
is
|
|
Current_String : Project_Node_Id;
|
|
|
|
begin
|
|
-- Set Choice_First, depending on whether this is the first case
|
|
-- construction or not.
|
|
|
|
if Choice_First = 0 then
|
|
Choice_First := 1;
|
|
Choices.Set_Last (First_Choice_Node_Id);
|
|
else
|
|
Choice_First := Choices.Last + 1;
|
|
end if;
|
|
|
|
-- Add the literal of the string type to the Choices table
|
|
|
|
if Present (String_Type) then
|
|
Current_String := First_Literal_String (String_Type, In_Tree);
|
|
while Present (Current_String) loop
|
|
Add (This_String => String_Value_Of (Current_String, In_Tree));
|
|
Current_String := Next_Literal_String (Current_String, In_Tree);
|
|
end loop;
|
|
end if;
|
|
|
|
-- Set the value of the last choice in table Choice_Lasts
|
|
|
|
Choice_Lasts.Increment_Last;
|
|
Choice_Lasts.Table (Choice_Lasts.Last) := Choices.Last;
|
|
end Start_New_Case_Construction;
|
|
|
|
-----------
|
|
-- Terms --
|
|
-----------
|
|
|
|
procedure Terms
|
|
(In_Tree : Project_Node_Tree_Ref;
|
|
Term : out Project_Node_Id;
|
|
Expr_Kind : in out Variable_Kind;
|
|
Current_Project : Project_Node_Id;
|
|
Current_Package : Project_Node_Id;
|
|
Optional_Index : Boolean;
|
|
Flags : Processing_Flags)
|
|
is
|
|
Next_Term : Project_Node_Id := Empty_Node;
|
|
Term_Id : Project_Node_Id := Empty_Node;
|
|
Current_Expression : Project_Node_Id := Empty_Node;
|
|
Next_Expression : Project_Node_Id := Empty_Node;
|
|
Current_Location : Source_Ptr := No_Location;
|
|
Reference : Project_Node_Id := Empty_Node;
|
|
|
|
begin
|
|
-- Declare a new node for the term
|
|
|
|
Term := Default_Project_Node (Of_Kind => N_Term, In_Tree => In_Tree);
|
|
Set_Location_Of (Term, In_Tree, To => Token_Ptr);
|
|
|
|
case Token is
|
|
when Tok_Left_Paren =>
|
|
|
|
-- If we have a left parenthesis and we don't know the expression
|
|
-- kind, then this is a string list.
|
|
|
|
case Expr_Kind is
|
|
when Undefined =>
|
|
Expr_Kind := List;
|
|
|
|
when List =>
|
|
null;
|
|
|
|
when Single =>
|
|
|
|
-- If we already know that this is a single string, report
|
|
-- an error, but set the expression kind to string list to
|
|
-- avoid several errors.
|
|
|
|
Expr_Kind := List;
|
|
Error_Msg
|
|
(Flags, "literal string list cannot appear in a string",
|
|
Token_Ptr);
|
|
end case;
|
|
|
|
-- Declare a new node for this literal string list
|
|
|
|
Term_Id := Default_Project_Node
|
|
(Of_Kind => N_Literal_String_List,
|
|
In_Tree => In_Tree,
|
|
And_Expr_Kind => List);
|
|
Set_Current_Term (Term, In_Tree, To => Term_Id);
|
|
Set_Location_Of (Term, In_Tree, To => Token_Ptr);
|
|
|
|
-- Scan past the left parenthesis
|
|
|
|
Scan (In_Tree);
|
|
|
|
-- If the left parenthesis is immediately followed by a right
|
|
-- parenthesis, the literal string list is empty.
|
|
|
|
if Token = Tok_Right_Paren then
|
|
Scan (In_Tree);
|
|
|
|
else
|
|
-- Otherwise parse the expression(s) in the literal string list
|
|
|
|
loop
|
|
Current_Location := Token_Ptr;
|
|
Parse_Expression
|
|
(In_Tree => In_Tree,
|
|
Expression => Next_Expression,
|
|
Flags => Flags,
|
|
Current_Project => Current_Project,
|
|
Current_Package => Current_Package,
|
|
Optional_Index => Optional_Index);
|
|
|
|
-- The expression kind is String list, report an error
|
|
|
|
if Expression_Kind_Of (Next_Expression, In_Tree) = List then
|
|
Error_Msg (Flags, "single expression expected",
|
|
Current_Location);
|
|
end if;
|
|
|
|
-- If Current_Expression is empty, it means that the
|
|
-- expression is the first in the string list.
|
|
|
|
if No (Current_Expression) then
|
|
Set_First_Expression_In_List
|
|
(Term_Id, In_Tree, To => Next_Expression);
|
|
else
|
|
Set_Next_Expression_In_List
|
|
(Current_Expression, In_Tree, To => Next_Expression);
|
|
end if;
|
|
|
|
Current_Expression := Next_Expression;
|
|
|
|
-- If there is a comma, continue with the next expression
|
|
|
|
exit when Token /= Tok_Comma;
|
|
Scan (In_Tree); -- past the comma
|
|
end loop;
|
|
|
|
-- We expect a closing right parenthesis
|
|
|
|
Expect (Tok_Right_Paren, "`)`");
|
|
|
|
if Token = Tok_Right_Paren then
|
|
Scan (In_Tree);
|
|
end if;
|
|
end if;
|
|
|
|
when Tok_String_Literal =>
|
|
|
|
-- If we don't know the expression kind (first term), then it is
|
|
-- a simple string.
|
|
|
|
if Expr_Kind = Undefined then
|
|
Expr_Kind := Single;
|
|
end if;
|
|
|
|
-- Declare a new node for the string literal
|
|
|
|
Term_Id :=
|
|
Default_Project_Node
|
|
(Of_Kind => N_Literal_String, In_Tree => In_Tree);
|
|
Set_Current_Term (Term, In_Tree, To => Term_Id);
|
|
Set_String_Value_Of (Term_Id, In_Tree, To => Token_Name);
|
|
|
|
-- Scan past the string literal
|
|
|
|
Scan (In_Tree);
|
|
|
|
-- Check for possible index expression
|
|
|
|
if Token = Tok_At then
|
|
if not Optional_Index then
|
|
Error_Msg (Flags, "index not allowed here", Token_Ptr);
|
|
Scan (In_Tree);
|
|
|
|
if Token = Tok_Integer_Literal then
|
|
Scan (In_Tree);
|
|
end if;
|
|
|
|
-- Set the index value
|
|
|
|
else
|
|
Scan (In_Tree);
|
|
Expect (Tok_Integer_Literal, "integer literal");
|
|
|
|
if Token = Tok_Integer_Literal then
|
|
declare
|
|
Index : constant Int := UI_To_Int (Int_Literal_Value);
|
|
begin
|
|
if Index = 0 then
|
|
Error_Msg
|
|
(Flags, "index cannot be zero", Token_Ptr);
|
|
else
|
|
Set_Source_Index_Of
|
|
(Term_Id, In_Tree, To => Index);
|
|
end if;
|
|
end;
|
|
|
|
Scan (In_Tree);
|
|
end if;
|
|
end if;
|
|
end if;
|
|
|
|
when Tok_Identifier =>
|
|
Current_Location := Token_Ptr;
|
|
|
|
-- Get the variable or attribute reference
|
|
|
|
Parse_Variable_Reference
|
|
(In_Tree => In_Tree,
|
|
Variable => Reference,
|
|
Flags => Flags,
|
|
Current_Project => Current_Project,
|
|
Current_Package => Current_Package);
|
|
Set_Current_Term (Term, In_Tree, To => Reference);
|
|
|
|
if Present (Reference) then
|
|
|
|
-- If we don't know the expression kind (first term), then it
|
|
-- has the kind of the variable or attribute reference.
|
|
|
|
if Expr_Kind = Undefined then
|
|
Expr_Kind := Expression_Kind_Of (Reference, In_Tree);
|
|
|
|
elsif Expr_Kind = Single
|
|
and then Expression_Kind_Of (Reference, In_Tree) = List
|
|
then
|
|
-- If the expression is a single list, and the reference is
|
|
-- a string list, report an error, and set the expression
|
|
-- kind to string list to avoid multiple errors.
|
|
|
|
Expr_Kind := List;
|
|
Error_Msg
|
|
(Flags,
|
|
"list variable cannot appear in single string expression",
|
|
Current_Location);
|
|
end if;
|
|
end if;
|
|
|
|
when Tok_Project =>
|
|
|
|
-- Project can appear in an expression as the prefix of an
|
|
-- attribute reference of the current project.
|
|
|
|
Current_Location := Token_Ptr;
|
|
Scan (In_Tree);
|
|
Expect (Tok_Apostrophe, "`'`");
|
|
|
|
if Token = Tok_Apostrophe then
|
|
Attribute_Reference
|
|
(In_Tree => In_Tree,
|
|
Reference => Reference,
|
|
Flags => Flags,
|
|
First_Attribute => Prj.Attr.Attribute_First,
|
|
Current_Project => Current_Project,
|
|
Current_Package => Empty_Node);
|
|
Set_Current_Term (Term, In_Tree, To => Reference);
|
|
end if;
|
|
|
|
-- Same checks as above for the expression kind
|
|
|
|
if Present (Reference) then
|
|
if Expr_Kind = Undefined then
|
|
Expr_Kind := Expression_Kind_Of (Reference, In_Tree);
|
|
|
|
elsif Expr_Kind = Single
|
|
and then Expression_Kind_Of (Reference, In_Tree) = List
|
|
then
|
|
Error_Msg
|
|
(Flags, "lists cannot appear in single string expression",
|
|
Current_Location);
|
|
end if;
|
|
end if;
|
|
|
|
when Tok_External
|
|
| Tok_External_As_List
|
|
=>
|
|
External_Reference
|
|
(In_Tree => In_Tree,
|
|
Flags => Flags,
|
|
Current_Project => Current_Project,
|
|
Current_Package => Current_Package,
|
|
Expr_Kind => Expr_Kind,
|
|
External_Value => Reference);
|
|
Set_Current_Term (Term, In_Tree, To => Reference);
|
|
|
|
when others =>
|
|
Error_Msg (Flags, "cannot be part of an expression", Token_Ptr);
|
|
Term := Empty_Node;
|
|
return;
|
|
end case;
|
|
|
|
-- If there is an '&', call Terms recursively
|
|
|
|
if Token = Tok_Ampersand then
|
|
Scan (In_Tree); -- scan past ampersand
|
|
|
|
Terms
|
|
(In_Tree => In_Tree,
|
|
Term => Next_Term,
|
|
Expr_Kind => Expr_Kind,
|
|
Flags => Flags,
|
|
Current_Project => Current_Project,
|
|
Current_Package => Current_Package,
|
|
Optional_Index => Optional_Index);
|
|
|
|
-- And link the next term to this term
|
|
|
|
Set_Next_Term (Term, In_Tree, To => Next_Term);
|
|
end if;
|
|
end Terms;
|
|
|
|
end Prj.Strt;
|