-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2007, 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- --
-- 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, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- 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 Prj.Tree; use Prj.Tree;
-with Scans; use Scans;
+with Err_Vars; use Err_Vars;
+with Prj.Attr; use Prj.Attr;
+with Prj.Err; use Prj.Err;
with Snames;
with Table;
-with Types; use Types;
-with Uintp; use Uintp;
+with Uintp; use Uintp;
package body Prj.Strt is
-- been used (to avoid duplicate case labels).
Choices_Initial : constant := 10;
- Choices_Increment : constant := 50;
+ Choices_Increment : constant := 100;
Choice_Node_Low_Bound : constant := 0;
Choice_Node_High_Bound : constant := 099_999_999;
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.
+ 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");
+ 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.
-- 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");
+ 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 one single names to table Names
procedure External_Reference
- (In_Tree : Project_Node_Tree_Ref;
- External_Value : out Project_Node_Id);
- -- Parse an external reference. Current token is "external".
+ (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;
First_Attribute : Attribute_Node_Id;
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id);
- -- Parse an attribute reference. Current token is an apostrophe.
+ -- Parse an attribute reference. Current token is an apostrophe
procedure Terms
(In_Tree : Project_Node_Tree_Ref;
if Current_Attribute = Empty_Attribute then
Error_Msg_Name_1 := Token_Name;
- Error_Msg ("unknown attribute %", Token_Ptr);
+ Error_Msg ("unknown attribute %%", Token_Ptr);
Reference := Empty_Node;
-- Scan past the attribute name
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);
+ Error_Msg ("?value %% is not used as label", Case_Location);
-- If several are not used, report a warning for each one of them
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);
+ Error_Msg ("\?%%", Case_Location);
end if;
end loop;
end if;
------------------------
procedure External_Reference
- (In_Tree : Project_Node_Tree_Ref;
- External_Value : out Project_Node_Id)
+ (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;
Scan (In_Tree);
- Expect (Tok_String_Literal, "literal string");
+ -- Get the string expression for the default
- -- Get the default
+ declare
+ Loc : constant Source_Ptr := Token_Ptr;
- 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_Default_Of
- (External_Value, In_Tree, To => Field_Id);
- Scan (In_Tree);
- Expect (Tok_Right_Paren, "`)`");
- end if;
+ 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;
-- case construction; report an error.
Error_Msg_Name_1 := Choice_String;
- Error_Msg ("duplicate case label {", Token_Ptr);
+ Error_Msg ("duplicate case label %%", Token_Ptr);
else
Choices.Table (Choice).Already_Used := True;
end if;
if not Found then
Error_Msg_Name_1 := Choice_String;
- Error_Msg ("illegal case label {", Token_Ptr);
+ Error_Msg ("illegal case label %%", Token_Ptr);
end if;
-- Scan past the label
-- This is a repetition, report an error
Error_Msg_Name_1 := String_Value;
- Error_Msg ("duplicate value { in type", Token_Ptr);
+ Error_Msg ("duplicate value %% in type", Token_Ptr);
exit;
end if;
end if;
External_Reference
- (In_Tree => In_Tree, External_Value => 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 =>
OSDN Git Service
