with Errout; use Errout;
with Namet; use Namet;
with Prj.Strt; use Prj.Strt;
with Prj.Tree; use Prj.Tree;
with Scans; use Scans;
with Sinfo; use Sinfo;
with Types; use Types;
with Prj.Attr; use Prj.Attr;
package body Prj.Dect is
type Zone is (In_Project, In_Package, In_Case_Construction);
procedure Parse_Attribute_Declaration
(Attribute : out Project_Node_Id;
First_Attribute : Attribute_Node_Id;
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id);
procedure Parse_Case_Construction
(Case_Construction : out Project_Node_Id;
First_Attribute : Attribute_Node_Id;
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id);
procedure Parse_Declarative_Items
(Declarations : out Project_Node_Id;
In_Zone : Zone;
First_Attribute : Attribute_Node_Id;
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id);
procedure Parse_Package_Declaration
(Package_Declaration : out Project_Node_Id;
Current_Project : Project_Node_Id);
procedure Parse_String_Type_Declaration
(String_Type : out Project_Node_Id;
Current_Project : Project_Node_Id);
procedure Parse_Variable_Declaration
(Variable : out Project_Node_Id;
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id);
procedure Parse
(Declarations : out Project_Node_Id;
Current_Project : Project_Node_Id;
Extends : Project_Node_Id)
is
First_Declarative_Item : Project_Node_Id := Empty_Node;
begin
Declarations := Default_Project_Node (Of_Kind => N_Project_Declaration);
Set_Location_Of (Declarations, To => Token_Ptr);
Set_Modified_Project_Of (Declarations, To => Extends);
Set_Project_Declaration_Of (Current_Project, Declarations);
Parse_Declarative_Items
(Declarations => First_Declarative_Item,
In_Zone => In_Project,
First_Attribute => Prj.Attr.Attribute_First,
Current_Project => Current_Project,
Current_Package => Empty_Node);
Set_First_Declarative_Item_Of
(Declarations, To => First_Declarative_Item);
end Parse;
procedure Parse_Attribute_Declaration
(Attribute : out Project_Node_Id;
First_Attribute : Attribute_Node_Id;
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id)
is
Current_Attribute : Attribute_Node_Id := First_Attribute;
begin
Attribute := Default_Project_Node (Of_Kind => N_Attribute_Declaration);
Set_Location_Of (Attribute, To => Token_Ptr);
Scan;
Expect (Tok_Identifier, "identifier");
if Token = Tok_Identifier then
Set_Name_Of (Attribute, To => Token_Name);
Set_Location_Of (Attribute, To => Token_Ptr);
while Current_Attribute /= Empty_Attribute
and then
Attributes.Table (Current_Attribute).Name /= Token_Name
loop
Current_Attribute := Attributes.Table (Current_Attribute).Next;
end loop;
if Current_Attribute = Empty_Attribute then
Error_Msg ("undefined attribute """ &
Get_Name_String (Name_Of (Attribute)) &
"""",
Token_Ptr);
elsif Attributes.Table (Current_Attribute).Kind_2 =
Case_Insensitive_Associative_Array
then
Set_Case_Insensitive (Attribute, To => True);
end if;
Scan;
end if;
if Token = Tok_Left_Paren then
if Current_Attribute /= Empty_Attribute
and then Attributes.Table (Current_Attribute).Kind_2 = Single
then
Error_Msg ("the attribute """ &
Get_Name_String
(Attributes.Table (Current_Attribute).Name) &
""" cannot be an associative array",
Location_Of (Attribute));
end if;
Scan;
Expect (Tok_String_Literal, "literal string");
if Token = Tok_String_Literal then
Set_Associative_Array_Index_Of (Attribute, Strval (Token_Node));
Scan;
end if;
Expect (Tok_Right_Paren, ")");
if Token = Tok_Right_Paren then
Scan;
end if;
else
if Current_Attribute /= Empty_Attribute
and then
Attributes.Table (Current_Attribute).Kind_2 /= Single
then
Error_Msg ("the attribute """ &
Get_Name_String
(Attributes.Table (Current_Attribute).Name) &
""" needs to be an associative array",
Location_Of (Attribute));
end if;
end if;
if Current_Attribute /= Empty_Attribute then
Set_Expression_Kind_Of
(Attribute, To => Attributes.Table (Current_Attribute).Kind_1);
end if;
Expect (Tok_Use, "use");
if Token = Tok_Use then
Scan;
declare
Expression_Location : constant Source_Ptr := Token_Ptr;
Expression : Project_Node_Id := Empty_Node;
begin
Parse_Expression
(Expression => Expression,
Current_Project => Current_Project,
Current_Package => Current_Package);
Set_Expression_Of (Attribute, To => Expression);
if Current_Attribute /= Empty_Attribute
and then Expression /= Empty_Node
and then Attributes.Table (Current_Attribute).Kind_1 /=
Expression_Kind_Of (Expression)
then
Error_Msg
("wrong expression kind for attribute """ &
Get_Name_String
(Attributes.Table (Current_Attribute).Name) &
"""",
Expression_Location);
end if;
end;
end if;
end Parse_Attribute_Declaration;
procedure Parse_Case_Construction
(Case_Construction : out Project_Node_Id;
First_Attribute : Attribute_Node_Id;
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id)
is
Current_Item : Project_Node_Id := Empty_Node;
Next_Item : Project_Node_Id := Empty_Node;
First_Case_Item : Boolean := True;
Variable_Location : Source_Ptr := No_Location;
String_Type : Project_Node_Id := Empty_Node;
Case_Variable : Project_Node_Id := Empty_Node;
First_Declarative_Item : Project_Node_Id := Empty_Node;
First_Choice : Project_Node_Id := Empty_Node;
begin
Case_Construction :=
Default_Project_Node (Of_Kind => N_Case_Construction);
Set_Location_Of (Case_Construction, To => Token_Ptr);
Scan;
Expect (Tok_Identifier, "identifier");
if Token = Tok_Identifier then
Variable_Location := Token_Ptr;
Parse_Variable_Reference
(Variable => Case_Variable,
Current_Project => Current_Project,
Current_Package => Current_Package);
Set_Case_Variable_Reference_Of
(Case_Construction, To => Case_Variable);
else
if Token /= Tok_Is then
Scan;
end if;
end if;
if Case_Variable /= Empty_Node then
String_Type := String_Type_Of (Case_Variable);
if String_Type = Empty_Node then
Error_Msg ("variable """ &
Get_Name_String (Name_Of (Case_Variable)) &
""" is not typed",
Variable_Location);
end if;
end if;
Expect (Tok_Is, "is");
if Token = Tok_Is then
Scan;
end if;
Start_New_Case_Construction (String_Type);
When_Loop :
while Token = Tok_When loop
if First_Case_Item then
Current_Item := Default_Project_Node (Of_Kind => N_Case_Item);
Set_First_Case_Item_Of (Case_Construction, To => Current_Item);
First_Case_Item := False;
else
Next_Item := Default_Project_Node (Of_Kind => N_Case_Item);
Set_Next_Case_Item (Current_Item, To => Next_Item);
Current_Item := Next_Item;
end if;
Set_Location_Of (Current_Item, To => Token_Ptr);
Scan;
if Token = Tok_Others then
Scan;
Expect (Tok_Arrow, "=>");
Set_First_Choice_Of (Current_Item, To => Empty_Node);
Parse_Declarative_Items
(Declarations => First_Declarative_Item,
In_Zone => In_Case_Construction,
First_Attribute => First_Attribute,
Current_Project => Current_Project,
Current_Package => Current_Package);
Set_First_Declarative_Item_Of
(Current_Item, To => First_Declarative_Item);
exit When_Loop;
else
Parse_Choice_List (First_Choice => First_Choice);
Set_First_Choice_Of (Current_Item, To => First_Choice);
Expect (Tok_Arrow, "=>");
Parse_Declarative_Items
(Declarations => First_Declarative_Item,
In_Zone => In_Case_Construction,
First_Attribute => First_Attribute,
Current_Project => Current_Project,
Current_Package => Current_Package);
Set_First_Declarative_Item_Of
(Current_Item, To => First_Declarative_Item);
end if;
end loop When_Loop;
End_Case_Construction;
Expect (Tok_End, "end case");
if Token = Tok_End then
Scan;
Expect (Tok_Case, "case");
end if;
Scan;
Expect (Tok_Semicolon, ";");
end Parse_Case_Construction;
procedure Parse_Declarative_Items
(Declarations : out Project_Node_Id;
In_Zone : Zone;
First_Attribute : Attribute_Node_Id;
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id)
is
Current_Declarative_Item : Project_Node_Id := Empty_Node;
Next_Declarative_Item : Project_Node_Id := Empty_Node;
Current_Declaration : Project_Node_Id := Empty_Node;
Item_Location : Source_Ptr := No_Location;
begin
Declarations := Empty_Node;
loop
Scan;
Item_Location := Token_Ptr;
case Token is
when Tok_Identifier =>
if In_Zone = In_Case_Construction then
Error_Msg ("a variable cannot be declared here",
Token_Ptr);
end if;
Parse_Variable_Declaration
(Current_Declaration,
Current_Project => Current_Project,
Current_Package => Current_Package);
when Tok_For =>
Parse_Attribute_Declaration
(Attribute => Current_Declaration,
First_Attribute => First_Attribute,
Current_Project => Current_Project,
Current_Package => Current_Package);
when Tok_Package =>
if In_Zone /= In_Project then
Error_Msg ("a package cannot be declared here", Token_Ptr);
end if;
Parse_Package_Declaration
(Package_Declaration => Current_Declaration,
Current_Project => Current_Project);
when Tok_Type =>
if In_Zone /= In_Project then
Error_Msg ("a string type cannot be declared here",
Token_Ptr);
end if;
Parse_String_Type_Declaration
(String_Type => Current_Declaration,
Current_Project => Current_Project);
when Tok_Case =>
Parse_Case_Construction
(Case_Construction => Current_Declaration,
First_Attribute => First_Attribute,
Current_Project => Current_Project,
Current_Package => Current_Package);
when others =>
exit;
end case;
Expect (Tok_Semicolon, "; after declarative items");
if Current_Declarative_Item = Empty_Node then
Current_Declarative_Item :=
Default_Project_Node (Of_Kind => N_Declarative_Item);
Declarations := Current_Declarative_Item;
else
Next_Declarative_Item :=
Default_Project_Node (Of_Kind => N_Declarative_Item);
Set_Next_Declarative_Item
(Current_Declarative_Item, To => Next_Declarative_Item);
Current_Declarative_Item := Next_Declarative_Item;
end if;
Set_Current_Item_Node
(Current_Declarative_Item, To => Current_Declaration);
Set_Location_Of (Current_Declarative_Item, To => Item_Location);
end loop;
end Parse_Declarative_Items;
procedure Parse_Package_Declaration
(Package_Declaration : out Project_Node_Id;
Current_Project : Project_Node_Id)
is
First_Attribute : Attribute_Node_Id := Empty_Attribute;
Current_Package : Package_Node_Id := Empty_Package;
First_Declarative_Item : Project_Node_Id := Empty_Node;
begin
Package_Declaration :=
Default_Project_Node (Of_Kind => N_Package_Declaration);
Set_Location_Of (Package_Declaration, To => Token_Ptr);
Scan;
Expect (Tok_Identifier, "identifier");
if Token = Tok_Identifier then
Set_Name_Of (Package_Declaration, To => Token_Name);
for Index in Package_Attributes.First .. Package_Attributes.Last loop
if Token_Name = Package_Attributes.Table (Index).Name then
First_Attribute :=
Package_Attributes.Table (Index).First_Attribute;
Current_Package := Index;
exit;
end if;
end loop;
if Current_Package = Empty_Package then
Error_Msg ("""" &
Get_Name_String (Name_Of (Package_Declaration)) &
""" is not an allowed package name",
Token_Ptr);
else
Set_Package_Id_Of (Package_Declaration, To => Current_Package);
declare
Current : Project_Node_Id := First_Package_Of (Current_Project);
begin
while Current /= Empty_Node
and then Name_Of (Current) /= Token_Name
loop
Current := Next_Package_In_Project (Current);
end loop;
if Current /= Empty_Node then
Error_Msg
("package """ &
Get_Name_String (Name_Of (Package_Declaration)) &
""" is declared twice in the same project",
Token_Ptr);
else
Set_Next_Package_In_Project
(Package_Declaration,
To => First_Package_Of (Current_Project));
Set_First_Package_Of
(Current_Project, To => Package_Declaration);
end if;
end;
end if;
Scan;
end if;
if Token = Tok_Renames then
Scan;
Expect (Tok_Identifier, "identifier");
if Token = Tok_Identifier then
declare
Project_Name : Name_Id := Token_Name;
Clause : Project_Node_Id :=
First_With_Clause_Of (Current_Project);
The_Project : Project_Node_Id := Empty_Node;
begin
while Clause /= Empty_Node loop
The_Project := Project_Node_Of (Clause);
exit when Name_Of (The_Project) = Project_Name;
Clause := Next_With_Clause_Of (Clause);
end loop;
if Clause = Empty_Node then
Error_Msg ("""" &
Get_Name_String (Project_Name) &
""" is not an imported project", Token_Ptr);
else
Set_Project_Of_Renamed_Package_Of
(Package_Declaration, To => The_Project);
end if;
end;
Scan;
Expect (Tok_Dot, ".");
if Token = Tok_Dot then
Scan;
Expect (Tok_Identifier, "identifier");
if Token = Tok_Identifier then
if Name_Of (Package_Declaration) /= Token_Name then
Error_Msg ("not the same package name", Token_Ptr);
elsif
Project_Of_Renamed_Package_Of (Package_Declaration)
/= Empty_Node
then
declare
Current : Project_Node_Id :=
First_Package_Of
(Project_Of_Renamed_Package_Of
(Package_Declaration));
begin
while Current /= Empty_Node
and then Name_Of (Current) /= Token_Name
loop
Current := Next_Package_In_Project (Current);
end loop;
if Current = Empty_Node then
Error_Msg
("""" &
Get_Name_String (Token_Name) &
""" is not a package declared by the project",
Token_Ptr);
end if;
end;
end if;
Scan;
end if;
end if;
end if;
Expect (Tok_Semicolon, ";");
elsif Token = Tok_Is then
Parse_Declarative_Items
(Declarations => First_Declarative_Item,
In_Zone => In_Package,
First_Attribute => First_Attribute,
Current_Project => Current_Project,
Current_Package => Package_Declaration);
Set_First_Declarative_Item_Of
(Package_Declaration, To => First_Declarative_Item);
Expect (Tok_End, "end");
if Token = Tok_End then
Scan;
end if;
Expect (Tok_Identifier, "identifier");
if Token = Tok_Identifier
and then Name_Of (Package_Declaration) /= No_Name
and then Token_Name /= Name_Of (Package_Declaration)
then
Error_Msg_Name_1 := Name_Of (Package_Declaration);
Error_Msg ("expected {", Token_Ptr);
end if;
if Token /= Tok_Semicolon then
Scan;
end if;
Expect (Tok_Semicolon, ";");
else
Error_Msg ("expected ""is"" or ""renames""", Token_Ptr);
end if;
end Parse_Package_Declaration;
procedure Parse_String_Type_Declaration
(String_Type : out Project_Node_Id;
Current_Project : Project_Node_Id)
is
Current : Project_Node_Id := Empty_Node;
First_String : Project_Node_Id := Empty_Node;
begin
String_Type :=
Default_Project_Node (Of_Kind => N_String_Type_Declaration);
Set_Location_Of (String_Type, To => Token_Ptr);
Scan;
Expect (Tok_Identifier, "identifier");
if Token = Tok_Identifier then
Set_Name_Of (String_Type, To => Token_Name);
Current := First_String_Type_Of (Current_Project);
while Current /= Empty_Node
and then
Name_Of (Current) /= Token_Name
loop
Current := Next_String_Type (Current);
end loop;
if Current /= Empty_Node then
Error_Msg ("duplicate string type name """ &
Get_Name_String (Token_Name) &
"""",
Token_Ptr);
else
Current := First_Variable_Of (Current_Project);
while Current /= Empty_Node
and then Name_Of (Current) /= Token_Name
loop
Current := Next_Variable (Current);
end loop;
if Current /= Empty_Node then
Error_Msg ("""" &
Get_Name_String (Token_Name) &
""" is already a variable name", Token_Ptr);
else
Set_Next_String_Type
(String_Type, To => First_String_Type_Of (Current_Project));
Set_First_String_Type_Of (Current_Project, To => String_Type);
end if;
end if;
Scan;
end if;
Expect (Tok_Is, "is");
if Token = Tok_Is then
Scan;
end if;
Expect (Tok_Left_Paren, "(");
if Token = Tok_Left_Paren then
Scan;
end if;
Parse_String_Type_List (First_String => First_String);
Set_First_Literal_String (String_Type, To => First_String);
Expect (Tok_Right_Paren, ")");
if Token = Tok_Right_Paren then
Scan;
end if;
end Parse_String_Type_Declaration;
procedure Parse_Variable_Declaration
(Variable : out Project_Node_Id;
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id)
is
Expression_Location : Source_Ptr;
String_Type_Name : Name_Id := No_Name;
Project_String_Type_Name : Name_Id := No_Name;
Type_Location : Source_Ptr := No_Location;
Project_Location : Source_Ptr := No_Location;
Expression : Project_Node_Id := Empty_Node;
Variable_Name : constant Name_Id := Token_Name;
begin
Variable :=
Default_Project_Node (Of_Kind => N_Variable_Declaration);
Set_Name_Of (Variable, To => Variable_Name);
Set_Location_Of (Variable, To => Token_Ptr);
Scan;
if Token = Tok_Colon then
Scan;
Set_Kind_Of (Variable, N_Typed_Variable_Declaration);
Expect (Tok_Identifier, "identifier");
if Token = Tok_Identifier then
String_Type_Name := Token_Name;
Type_Location := Token_Ptr;
Scan;
if Token = Tok_Dot then
Project_String_Type_Name := String_Type_Name;
Project_Location := Type_Location;
Scan;
Expect (Tok_Identifier, "identifier");
if Token = Tok_Identifier then
String_Type_Name := Token_Name;
Type_Location := Token_Ptr;
Scan;
else
String_Type_Name := No_Name;
end if;
end if;
if String_Type_Name /= No_Name then
declare
Current : Project_Node_Id :=
First_String_Type_Of (Current_Project);
begin
if Project_String_Type_Name /= No_Name then
declare
The_Project_Name_And_Node : constant
Tree_Private_Part.Project_Name_And_Node :=
Tree_Private_Part.Projects_Htable.Get
(Project_String_Type_Name);
use Tree_Private_Part;
begin
if The_Project_Name_And_Node =
Tree_Private_Part.No_Project_Name_And_Node
then
Error_Msg ("unknown project """ &
Get_Name_String
(Project_String_Type_Name) &
"""",
Project_Location);
Current := Empty_Node;
else
Current :=
First_String_Type_Of
(The_Project_Name_And_Node.Node);
end if;
end;
end if;
while Current /= Empty_Node
and then Name_Of (Current) /= String_Type_Name
loop
Current := Next_String_Type (Current);
end loop;
if Current = Empty_Node then
Error_Msg ("unknown string type """ &
Get_Name_String (String_Type_Name) &
"""",
Type_Location);
else
Set_String_Type_Of
(Variable, To => Current);
end if;
end;
end if;
end if;
end if;
Expect (Tok_Colon_Equal, ":=");
if Token = Tok_Colon_Equal then
Scan;
end if;
Expression_Location := Token_Ptr;
Parse_Expression
(Expression => Expression,
Current_Project => Current_Project,
Current_Package => Current_Package);
Set_Expression_Of (Variable, To => Expression);
if Expression /= Empty_Node then
Set_Expression_Kind_Of
(Variable, To => Expression_Kind_Of (Expression));
end if;
declare
The_Variable : Project_Node_Id := Empty_Node;
begin
if Current_Package /= Empty_Node then
The_Variable := First_Variable_Of (Current_Package);
elsif Current_Project /= Empty_Node then
The_Variable := First_Variable_Of (Current_Project);
end if;
while The_Variable /= Empty_Node
and then Name_Of (The_Variable) /= Variable_Name
loop
The_Variable := Next_Variable (The_Variable);
end loop;
if The_Variable = Empty_Node then
if Current_Package /= Empty_Node then
Set_Next_Variable
(Variable, To => First_Variable_Of (Current_Package));
Set_First_Variable_Of (Current_Package, To => Variable);
elsif Current_Project /= Empty_Node then
Set_Next_Variable
(Variable, To => First_Variable_Of (Current_Project));
Set_First_Variable_Of (Current_Project, To => Variable);
end if;
else
if Expression_Kind_Of (Variable) /= Undefined then
if Expression_Kind_Of (The_Variable) = Undefined then
Set_Expression_Kind_Of
(The_Variable, To => Expression_Kind_Of (Variable));
else
if Expression_Kind_Of (The_Variable) /=
Expression_Kind_Of (Variable)
then
Error_Msg ("wrong expression kind for variable """ &
Get_Name_String (Name_Of (The_Variable)) &
"""",
Expression_Location);
end if;
end if;
end if;
end if;
end;
end Parse_Variable_Declaration;
end Prj.Dect;