| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- P R J . S T R T -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 2001-2005, 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 2, 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 COPYING. If not, write -- |
| -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- |
| -- Boston, MA 02110-1301, USA. -- |
| -- -- |
| -- 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 Namet; use Namet; |
| 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 := 50; |
| |
| 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, |
| 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 indices 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); |
| -- 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); |
| -- 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); |
| -- 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) |
| 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 ("unknown attribute %", Token_Ptr); |
| Reference := Empty_Node; |
| |
| -- Scan past the attribute name |
| |
| Scan (In_Tree); |
| |
| 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) = |
| Case_Insensitive_Associative_Array); |
| |
| -- 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); |
| Expect (Tok_String_Literal, "literal string"); |
| |
| if Token = Tok_String_Literal then |
| Set_Associative_Array_Index_Of |
| (Reference, In_Tree, To => Token_Name); |
| Scan (In_Tree); |
| Expect (Tok_Right_Paren, "`)`"); |
| |
| if Token = Tok_Right_Paren then |
| Scan (In_Tree); |
| end if; |
| end if; |
| end if; |
| end if; |
| end if; |
| |
| -- Change name of obsolete attributes |
| |
| if Reference /= Empty_Node 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) |
| 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 |
| 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 ("?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 |
| ("?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 ("\?{", Case_Location); |
| end if; |
| end loop; |
| 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; |
| |
| elsif Choice_Lasts.Last = 2 then |
| -- This is the second case onstruction, set the tables to the first |
| |
| Choice_Lasts.Set_Last (1); |
| Choices.Set_Last (Choice_Lasts.Table (1)); |
| Choice_First := 1; |
| |
| else |
| -- This is the 3rd or more case construction, set the tables to the |
| -- previous one. |
| |
| 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) |
| is |
| Field_Id : Project_Node_Id := Empty_Node; |
| |
| begin |
| External_Value := |
| Default_Project_Node |
| (Of_Kind => N_External_Value, |
| In_Tree => In_Tree, |
| And_Expr_Kind => Single); |
| Set_Location_Of (External_Value, In_Tree, To => Token_Ptr); |
| |
| -- The current token is External |
| |
| -- Get the left parenthesis |
| |
| Scan (In_Tree); |
| 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 => |
| |
| -- Scan past the right parenthesis |
| Scan (In_Tree); |
| |
| when Tok_Comma => |
| |
| -- Scan past the comma |
| |
| Scan (In_Tree); |
| |
| -- Get the string expression for the default |
| |
| declare |
| Loc : constant Source_Ptr := Token_Ptr; |
| |
| begin |
| Parse_Expression |
| (In_Tree => In_Tree, |
| Expression => Field_Id, |
| Current_Project => Current_Project, |
| Current_Package => Current_Package, |
| Optional_Index => False); |
| |
| if Expression_Kind_Of (Field_Id, In_Tree) = List then |
| Error_Msg ("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, "`)`"); |
| |
| -- Scan past the right parenthesis |
| |
| if Token = Tok_Right_Paren then |
| Scan (In_Tree); |
| end if; |
| |
| when others => |
| Error_Msg ("`,` or `)` expected", Token_Ptr); |
| 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) |
| 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); |
| |
| -- 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; report an error. |
| |
| Error_Msg_Name_1 := Choice_String; |
| Error_Msg ("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 ("illegal case label {", Token_Ptr); |
| 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) |
| 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, |
| 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) |
| 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 ("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) |
| 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 |
| |
| The_Project := Imported_Or_Extended_Project_Of |
| (Current_Project, In_Tree, Names.Table (1).Name); |
| |
| if The_Project = Empty_Node 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 ("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 The_Package /= Empty_Node |
| 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 The_Package = Empty_Node then |
| Error_Msg_Name_1 := Names.Table (1).Name; |
| Error_Msg ("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 |
| |
| The_Project := Imported_Or_Extended_Project_Of |
| (Current_Project, In_Tree, Long_Project); |
| |
| -- If the long project exists, then this is the prefix |
| -- of the attribute. |
| |
| if The_Project /= Empty_Node then |
| First_Attribute := Attribute_First; |
| The_Package := Empty_Node; |
| |
| else |
| -- Otherwise, check if the short project is imported |
| -- or extended. |
| |
| The_Project := Imported_Or_Extended_Project_Of |
| (Current_Project, In_Tree, |
| Short_Project); |
| |
| -- If the short project does not exist, we report an |
| -- error. |
| |
| if The_Project = Empty_Node then |
| Error_Msg_Name_1 := Long_Project; |
| Error_Msg_Name_2 := Short_Project; |
| Error_Msg ("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 The_Package /= Empty_Node |
| 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 The_Package = Empty_Node then |
| Error_Msg_Name_1 := |
| Names.Table (Names.Last).Name; |
| Error_Msg_Name_2 := Short_Project; |
| Error_Msg ("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, |
| 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 |
| |
| 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 The_Package /= Empty_Node |
| 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 The_Project /= Empty_Node then |
| Specified_Project := The_Project; |
| |
| elsif The_Package = Empty_Node then |
| Error_Msg_Name_1 := Names.Table (1).Name; |
| Error_Msg ("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 The_Project /= Empty_Node 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 The_Project = Empty_Node then |
| -- Unknown prefix, report an error |
| |
| Error_Msg_Name_1 := Long_Project; |
| Error_Msg_Name_2 := Short_Project; |
| Error_Msg ("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 The_Package /= Empty_Node |
| 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 The_Package = Empty_Node then |
| -- The package does not vexist, report an error |
| |
| Error_Msg_Name_1 := Names.Table (2).Name; |
| Error_Msg ("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 Specified_Project /= Empty_Node 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 Specified_Package /= Empty_Node then |
| Current_Variable := |
| First_Variable_Of (Specified_Package, In_Tree); |
| |
| while Current_Variable /= Empty_Node |
| 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 Specified_Project = Empty_Node |
| and then Current_Package /= Empty_Node |
| then |
| Current_Variable := |
| First_Variable_Of (Current_Package, In_Tree); |
| |
| while Current_Variable /= Empty_Node |
| 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. |
| |
| if Current_Variable = Empty_Node then |
| Current_Variable := First_Variable_Of (The_Project, In_Tree); |
| |
| while Current_Variable /= Empty_Node |
| and then Name_Of (Current_Variable, In_Tree) /= Variable_Name |
| loop |
| Current_Variable := |
| Next_Variable (Current_Variable, In_Tree); |
| end loop; |
| end if; |
| end if; |
| |
| -- If the variable was not found, report an error |
| |
| if Current_Variable = Empty_Node then |
| Error_Msg_Name_1 := Variable_Name; |
| Error_Msg |
| ("unknown variable %", Names.Table (Names.Last).Location); |
| end if; |
| end if; |
| |
| if Current_Variable /= Empty_Node 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 ("\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 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 to table Choices the literal of the string type |
| |
| if String_Type /= Empty_Node then |
| Current_String := First_Literal_String (String_Type, In_Tree); |
| |
| while Current_String /= Empty_Node 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) |
| 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 |
| ("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, we parse the expression(s) in the literal string |
| -- list. |
| |
| loop |
| Current_Location := Token_Ptr; |
| Parse_Expression |
| (In_Tree => In_Tree, |
| Expression => Next_Expression, |
| 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 ("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 Current_Expression = Empty_Node 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 ("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 ("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, |
| Current_Project => Current_Project, |
| Current_Package => Current_Package); |
| Set_Current_Term (Term, In_Tree, To => Reference); |
| |
| if Reference /= Empty_Node 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 |
| ("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, |
| 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 Reference /= Empty_Node 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 |
| ("lists cannot appear in single string expression", |
| Current_Location); |
| end if; |
| end if; |
| |
| when Tok_External => |
| -- An external reference is always a single string |
| |
| if Expr_Kind = Undefined then |
| Expr_Kind := Single; |
| end if; |
| |
| External_Reference |
| (In_Tree => In_Tree, |
| Current_Project => Current_Project, |
| Current_Package => Current_Package, |
| External_Value => Reference); |
| Set_Current_Term (Term, In_Tree, To => Reference); |
| |
| when others => |
| Error_Msg ("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 past the '&' |
| |
| Scan (In_Tree); |
| |
| Terms |
| (In_Tree => In_Tree, |
| Term => Next_Term, |
| Expr_Kind => Expr_Kind, |
| 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; |
