URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [prj-strt.adb] - Rev 706
Compare with Previous | Blame | View Log
------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- P R J . S T R T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2010, 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); 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); -- 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) 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 (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; 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 construction, 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; 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) 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 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; -- 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. 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); Proj := Parent_Project_Of (Proj, In_Tree); 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;