| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- P R J . S T R T -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 2001-2015, 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; |
