aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.8.1/gcc/ada/prj-strt.adb
diff options
context:
space:
mode:
authorDan Albert <danalbert@google.com>2016-01-14 16:43:34 -0800
committerDan Albert <danalbert@google.com>2016-01-22 14:51:24 -0800
commit3186be22b6598fbd467b126347d1c7f48ccb7f71 (patch)
tree2b176d3ce027fa5340160978effeb88ec9054aaa /gcc-4.8.1/gcc/ada/prj-strt.adb
parenta45222a0e5951558bd896b0513bf638eb376e086 (diff)
downloadtoolchain_gcc-3186be22b6598fbd467b126347d1c7f48ccb7f71.tar.gz
toolchain_gcc-3186be22b6598fbd467b126347d1c7f48ccb7f71.tar.bz2
toolchain_gcc-3186be22b6598fbd467b126347d1c7f48ccb7f71.zip
Check in a pristine copy of GCC 4.8.1.
The copy of GCC that we use for Android is still not working for mingw. Rather than finding all the differences that have crept into our GCC, just check in a copy from ftp://ftp.gnu.org/gnu/gcc/gcc-4.9.3/gcc-4.8.1.tar.bz2. GCC 4.8.1 was chosen because it is what we have been using for mingw thus far, and the emulator doesn't yet work when upgrading to 4.9. Bug: http://b/26523949 Change-Id: Iedc0f05243d4332cc27ccd46b8a4b203c88dcaa3
Diffstat (limited to 'gcc-4.8.1/gcc/ada/prj-strt.adb')
-rw-r--r--gcc-4.8.1/gcc/ada/prj-strt.adb1556
1 files changed, 1556 insertions, 0 deletions
diff --git a/gcc-4.8.1/gcc/ada/prj-strt.adb b/gcc-4.8.1/gcc/ada/prj-strt.adb
new file mode 100644
index 000000000..271a913e7
--- /dev/null
+++ b/gcc-4.8.1/gcc/ada/prj-strt.adb
@@ -0,0 +1,1556 @@
+------------------------------------------------------------------------------
+-- --
+-- 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;