Subversion Repositories openrisc

------------------------------------------------------------------------------

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                              P R J . D E C T                             --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 2001-2011, 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 Opt;         use Opt;

with Prj.Attr;    use Prj.Attr;

with Prj.Attr.PM; use Prj.Attr.PM;

with Prj.Err;     use Prj.Err;

with Prj.Strt;    use Prj.Strt;

with Prj.Tree;    use Prj.Tree;

with Snames;

with Uintp;       use Uintp;

with GNAT;                  use GNAT;

with GNAT.Case_Util;        use GNAT.Case_Util;

with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;

with GNAT.Strings;

package body Prj.Dect is

   type Zone is (In_Project, In_Package, In_Case_Construction);

   --  Used to indicate if we are parsing a package (In_Package), a case

   --  construction (In_Case_Construction) or none of those two (In_Project).

   procedure Rename_Obsolescent_Attributes

     (In_Tree         : Project_Node_Tree_Ref;

      Attribute       : Project_Node_Id;

      Current_Package : Project_Node_Id);

   --  Rename obsolescent attributes in the tree. When the attribute has been

   --  renamed since its initial introduction in the design of projects, we

   --  replace the old name in the tree with the new name, so that the code

   --  does not have to check both names forever.

   procedure Check_Attribute_Allowed

     (In_Tree   : Project_Node_Tree_Ref;

      Project   : Project_Node_Id;

      Attribute : Project_Node_Id;

      Flags     : Processing_Flags);

   --  Check whether the attribute is valid in this project. In particular,

   --  depending on the type of project (qualifier), some attributes might

   --  be disabled.

   procedure Check_Package_Allowed

     (In_Tree         : Project_Node_Tree_Ref;

      Project         : Project_Node_Id;

      Current_Package : Project_Node_Id;

      Flags           : Processing_Flags);

   --  Check whether the package is valid in this project

   procedure Parse_Attribute_Declaration

     (In_Tree           : Project_Node_Tree_Ref;

      Attribute         : out Project_Node_Id;

      First_Attribute   : Attribute_Node_Id;

      Current_Project   : Project_Node_Id;

      Current_Package   : Project_Node_Id;

      Packages_To_Check : String_List_Access;

      Flags             : Processing_Flags);

   --  Parse an attribute declaration

   procedure Parse_Case_Construction

     (In_Tree           : Project_Node_Tree_Ref;

      Case_Construction : out Project_Node_Id;

      First_Attribute   : Attribute_Node_Id;

      Current_Project   : Project_Node_Id;

      Current_Package   : Project_Node_Id;

      Packages_To_Check : String_List_Access;

      Is_Config_File    : Boolean;

      Flags             : Processing_Flags);

   --  Parse a case construction

   procedure Parse_Declarative_Items

     (In_Tree           : Project_Node_Tree_Ref;

      Declarations      : out Project_Node_Id;

      In_Zone           : Zone;

      First_Attribute   : Attribute_Node_Id;

      Current_Project   : Project_Node_Id;

      Current_Package   : Project_Node_Id;

      Packages_To_Check : String_List_Access;

      Is_Config_File    : Boolean;

      Flags             : Processing_Flags);

   --  Parse declarative items. Depending on In_Zone, some declarative items

   --  may be forbidden. Is_Config_File should be set to True if the project

   --  represents a config file (.cgpr) since some specific checks apply.

   procedure Parse_Package_Declaration

     (In_Tree             : Project_Node_Tree_Ref;

      Package_Declaration : out Project_Node_Id;

      Current_Project     : Project_Node_Id;

      Packages_To_Check   : String_List_Access;

      Is_Config_File      : Boolean;

      Flags               : Processing_Flags);

   --  Parse a package declaration.

   --  Is_Config_File should be set to True if the project represents a config

   --  file (.cgpr) since some specific checks apply.

   procedure Parse_String_Type_Declaration

     (In_Tree         : Project_Node_Tree_Ref;

      String_Type     : out Project_Node_Id;

      Current_Project : Project_Node_Id;

      Flags           : Processing_Flags);

   --  type <name> is ( <literal_string> { , <literal_string> } ) ;

   procedure Parse_Variable_Declaration

     (In_Tree         : Project_Node_Tree_Ref;

      Variable        : out Project_Node_Id;

      Current_Project : Project_Node_Id;

      Current_Package : Project_Node_Id;

      Flags           : Processing_Flags);

   --  Parse a variable assignment

   --  <variable_Name> := <expression>; OR

   --  <variable_Name> : <string_type_Name> := <string_expression>;

   -----------

   -- Parse --

   -----------

   procedure Parse

     (In_Tree           : Project_Node_Tree_Ref;

      Declarations      : out Project_Node_Id;

      Current_Project   : Project_Node_Id;

      Extends           : Project_Node_Id;

      Packages_To_Check : String_List_Access;

      Is_Config_File    : Boolean;

      Flags             : Processing_Flags)

   is

      First_Declarative_Item : Project_Node_Id := Empty_Node;

   begin

      Declarations :=

        Default_Project_Node

          (Of_Kind => N_Project_Declaration, In_Tree => In_Tree);

      Set_Location_Of (Declarations, In_Tree, To => Token_Ptr);

      Set_Extended_Project_Of (Declarations, In_Tree, To => Extends);

      Set_Project_Declaration_Of (Current_Project, In_Tree, Declarations);

      Parse_Declarative_Items

        (Declarations      => First_Declarative_Item,

         In_Tree           => In_Tree,

         In_Zone           => In_Project,

         First_Attribute   => Prj.Attr.Attribute_First,

         Current_Project   => Current_Project,

         Current_Package   => Empty_Node,

         Packages_To_Check => Packages_To_Check,

         Is_Config_File    => Is_Config_File,

         Flags             => Flags);

      Set_First_Declarative_Item_Of

        (Declarations, In_Tree, To => First_Declarative_Item);

   end Parse;

   -----------------------------------

   -- Rename_Obsolescent_Attributes --

   -----------------------------------

   procedure Rename_Obsolescent_Attributes

     (In_Tree         : Project_Node_Tree_Ref;

      Attribute       : Project_Node_Id;

      Current_Package : Project_Node_Id)

   is

   begin

      if Present (Current_Package)

        and then Expression_Kind_Of (Current_Package, In_Tree) /= Ignored

      then

         case Name_Of (Attribute, In_Tree) is

            when Snames.Name_Specification =>

               Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec);

            when Snames.Name_Specification_Suffix =>

               Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec_Suffix);

            when Snames.Name_Implementation =>

               Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body);

            when Snames.Name_Implementation_Suffix =>

               Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body_Suffix);

            when others =>

               null;

         end case;

      end if;

   end Rename_Obsolescent_Attributes;

   ---------------------------

   -- Check_Package_Allowed --

   ---------------------------

   procedure Check_Package_Allowed

     (In_Tree         : Project_Node_Tree_Ref;

      Project         : Project_Node_Id;

      Current_Package : Project_Node_Id;

      Flags           : Processing_Flags)

   is

      Qualif : constant Project_Qualifier :=

                 Project_Qualifier_Of (Project, In_Tree);

      Name   : constant Name_Id := Name_Of (Current_Package, In_Tree);

   begin

      if Qualif in Aggregate_Project

        and then Name /= Snames.Name_Builder

      then

         Error_Msg_Name_1 := Name;

         Error_Msg

           (Flags,

            "package %% is forbidden in aggregate projects",

            Location_Of (Current_Package, In_Tree));

      end if;

   end Check_Package_Allowed;

   -----------------------------

   -- Check_Attribute_Allowed --

   -----------------------------

   procedure Check_Attribute_Allowed

     (In_Tree   : Project_Node_Tree_Ref;

      Project   : Project_Node_Id;

      Attribute : Project_Node_Id;

      Flags     : Processing_Flags)

   is

      Qualif : constant Project_Qualifier :=

                 Project_Qualifier_Of (Project, In_Tree);

      Name   : constant Name_Id := Name_Of (Attribute, In_Tree);

   begin

      case Qualif is

         when Aggregate | Aggregate_Library =>

            if        Name = Snames.Name_Languages

              or else Name = Snames.Name_Source_Files

              or else Name = Snames.Name_Source_List_File

              or else Name = Snames.Name_Locally_Removed_Files

              or else Name = Snames.Name_Excluded_Source_Files

              or else Name = Snames.Name_Excluded_Source_List_File

              or else Name = Snames.Name_Interfaces

              or else Name = Snames.Name_Object_Dir

              or else Name = Snames.Name_Exec_Dir

              or else Name = Snames.Name_Source_Dirs

              or else Name = Snames.Name_Inherit_Source_Path

            then

               Error_Msg_Name_1 := Name;

               Error_Msg

                 (Flags,

                  "%% is not valid in aggregate projects",

                  Location_Of (Attribute, In_Tree));

            end if;

         when others =>

            if Name = Snames.Name_Project_Files

              or else Name = Snames.Name_Project_Path

              or else Name = Snames.Name_External

            then

               Error_Msg_Name_1 := Name;

               Error_Msg

                 (Flags,

                  "%% is only valid in aggregate projects",

                  Location_Of (Attribute, In_Tree));

            end if;

      end case;

   end Check_Attribute_Allowed;

   ---------------------------------

   -- Parse_Attribute_Declaration --

   ---------------------------------

   procedure Parse_Attribute_Declaration

     (In_Tree           : Project_Node_Tree_Ref;

      Attribute         : out Project_Node_Id;

      First_Attribute   : Attribute_Node_Id;

      Current_Project   : Project_Node_Id;

      Current_Package   : Project_Node_Id;

      Packages_To_Check : String_List_Access;

      Flags             : Processing_Flags)

   is

      Current_Attribute      : Attribute_Node_Id := First_Attribute;

      Full_Associative_Array : Boolean           := False;

      Attribute_Name         : Name_Id           := No_Name;

      Optional_Index         : Boolean           := False;

      Pkg_Id                 : Package_Node_Id   := Empty_Package;

      procedure Process_Attribute_Name;

      --  Read the name of the attribute, and check its type

      procedure Process_Associative_Array_Index;

      --  Read the index of the associative array and check its validity

      ----------------------------

      -- Process_Attribute_Name --

      ----------------------------

      procedure Process_Attribute_Name is

         Ignore : Boolean;

      begin

         Attribute_Name := Token_Name;

         Set_Name_Of (Attribute, In_Tree, To => Attribute_Name);

         Set_Location_Of (Attribute, In_Tree, To => Token_Ptr);

         --  Find the attribute

         Current_Attribute :=

           Attribute_Node_Id_Of (Attribute_Name, First_Attribute);

         --  If the attribute cannot be found, create the attribute if inside

         --  an unknown package.

         if Current_Attribute = Empty_Attribute then

            if Present (Current_Package)

              and then Expression_Kind_Of (Current_Package, In_Tree) = Ignored

            then

               Pkg_Id := Package_Id_Of (Current_Package, In_Tree);

               Add_Attribute (Pkg_Id, Token_Name, Current_Attribute);

            else

               --  If not a valid attribute name, issue an error if inside

               --  a package that need to be checked.

               Ignore := Present (Current_Package) and then

                          Packages_To_Check /= All_Packages;

               if Ignore then

                  --  Check that we are not in a package to check

                  Get_Name_String (Name_Of (Current_Package, In_Tree));

                  for Index in Packages_To_Check'Range loop

                     if Name_Buffer (1 .. Name_Len) =

                       Packages_To_Check (Index).all

                     then

                        Ignore := False;

                        exit;

                     end if;

                  end loop;

               end if;

               if not Ignore then

                  Error_Msg_Name_1 := Token_Name;

                  Error_Msg (Flags, "undefined attribute %%", Token_Ptr);

               end if;

            end if;

         --  Set, if appropriate the index case insensitivity flag

         else

            if Is_Read_Only (Current_Attribute) then

               Error_Msg_Name_1 := Token_Name;

               Error_Msg

                 (Flags, "read-only attribute %% cannot be given a value",

                  Token_Ptr);

            end if;

            if Attribute_Kind_Of (Current_Attribute) in

                 All_Case_Insensitive_Associative_Array

            then

               Set_Case_Insensitive (Attribute, In_Tree, To => True);

            end if;

         end if;

         Scan (In_Tree); --  past the attribute name

         --  Set the expression kind of the attribute

         if Current_Attribute /= Empty_Attribute then

            Set_Expression_Kind_Of

              (Attribute, In_Tree, To => Variable_Kind_Of (Current_Attribute));

            Optional_Index := Optional_Index_Of (Current_Attribute);

         end if;

      end Process_Attribute_Name;

      -------------------------------------

      -- Process_Associative_Array_Index --

      -------------------------------------

      procedure Process_Associative_Array_Index is

      begin

         --  If the attribute is not an associative array attribute, report

         --  an error. If this information is still unknown, set the kind

         --  to Associative_Array.

         if Current_Attribute /= Empty_Attribute

           and then Attribute_Kind_Of (Current_Attribute) = Single

         then

            Error_Msg (Flags,

                       "the attribute """ &

                       Get_Name_String (Attribute_Name_Of (Current_Attribute))

                       & """ cannot be an associative array",

                       Location_Of (Attribute, In_Tree));

         elsif Attribute_Kind_Of (Current_Attribute) = Unknown then

            Set_Attribute_Kind_Of (Current_Attribute, To => Associative_Array);

         end if;

         Scan (In_Tree); --  past the left parenthesis

         if Others_Allowed_For (Current_Attribute)

           and then Token = Tok_Others

         then

            Set_Associative_Array_Index_Of

              (Attribute, In_Tree, All_Other_Names);

            Scan (In_Tree); --  past others

         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

               Get_Name_String (Token_Name);

               if Case_Insensitive (Attribute, In_Tree) then

                  To_Lower (Name_Buffer (1 .. Name_Len));

               end if;

               Set_Associative_Array_Index_Of (Attribute, In_Tree, Name_Find);

               Scan (In_Tree); --  past the literal string index

               if Token = Tok_At then

                  case Attribute_Kind_Of (Current_Attribute) is

                  when Optional_Index_Associative_Array |

                       Optional_Index_Case_Insensitive_Associative_Array =>

                     Scan (In_Tree);

                     Expect (Tok_Integer_Literal, "integer literal");

                     if Token = Tok_Integer_Literal then

                        --  Set the source index value from given literal

                        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

                                (Attribute, In_Tree, To => Index);

                           end if;

                        end;

                        Scan (In_Tree);

                     end if;

                  when others =>

                     Error_Msg (Flags, "index not allowed here", Token_Ptr);

                     Scan (In_Tree);

                     if Token = Tok_Integer_Literal then

                        Scan (In_Tree);

                     end if;

                  end case;

               end if;

            end if;

         end if;

         Expect (Tok_Right_Paren, "`)`");

         if Token = Tok_Right_Paren then

            Scan (In_Tree); --  past the right parenthesis

         end if;

      end Process_Associative_Array_Index;

   begin

      Attribute :=

        Default_Project_Node

          (Of_Kind => N_Attribute_Declaration, In_Tree => In_Tree);

      Set_Location_Of (Attribute, In_Tree, To => Token_Ptr);

      Set_Previous_Line_Node (Attribute);

      --  Scan past "for"

      Scan (In_Tree);

      --  Body or External may be an attribute name

      if Token = Tok_Body then

         Token := Tok_Identifier;

         Token_Name := Snames.Name_Body;

      end if;

      if Token = Tok_External then

         Token := Tok_Identifier;

         Token_Name := Snames.Name_External;

      end if;

      Expect (Tok_Identifier, "identifier");

      Process_Attribute_Name;

      Rename_Obsolescent_Attributes (In_Tree, Attribute, Current_Package);

      Check_Attribute_Allowed (In_Tree, Current_Project, Attribute, Flags);

      --  Associative array attributes

      if Token = Tok_Left_Paren then

         Process_Associative_Array_Index;

      else

         --  If it is an associative array attribute and there are no left

         --  parenthesis, then this is a full associative array declaration.

         --  Flag it as such for later processing of its value.

         if Current_Attribute /= Empty_Attribute

           and then

             Attribute_Kind_Of (Current_Attribute) /= Single

         then

            if Attribute_Kind_Of (Current_Attribute) = Unknown then

               Set_Attribute_Kind_Of (Current_Attribute, To => Single);

            else

               Full_Associative_Array := True;

            end if;

         end if;

      end if;

      Expect (Tok_Use, "USE");

      if Token = Tok_Use then

         Scan (In_Tree);

         if Full_Associative_Array then

            --  Expect <project>'<same_attribute_name>, or

            --  <project>.<same_package_name>'<same_attribute_name>

            declare

               The_Project : Project_Node_Id := Empty_Node;

               --  The node of the project where the associative array is

               --  declared.

               The_Package : Project_Node_Id := Empty_Node;

               --  The node of the package where the associative array is

               --  declared, if any.

               Project_Name : Name_Id := No_Name;

               --  The name of the project where the associative array is

               --  declared.

               Location : Source_Ptr := No_Location;

               --  The location of the project name

            begin

               Expect (Tok_Identifier, "identifier");

               if Token = Tok_Identifier then

                  Location := Token_Ptr;

                  --  Find the project node in the imported project or

                  --  in the project being extended.

                  The_Project := Imported_Or_Extended_Project_Of

                                   (Current_Project, In_Tree, Token_Name);

                  if No (The_Project) then

                     Error_Msg (Flags, "unknown project", Location);

                     Scan (In_Tree); --  past the project name

                  else

                     Project_Name := Token_Name;

                     Scan (In_Tree); --  past the project name

                     --  If this is inside a package, a dot followed by the

                     --  name of the package must followed the project name.

                     if Present (Current_Package) then

                        Expect (Tok_Dot, "`.`");

                        if Token /= Tok_Dot then

                           The_Project := Empty_Node;

                        else

                           Scan (In_Tree); --  past the dot

                           Expect (Tok_Identifier, "identifier");

                           if Token /= Tok_Identifier then

                              The_Project := Empty_Node;

                           --  If it is not the same package name, issue error

                           elsif

                             Token_Name /= Name_Of (Current_Package, In_Tree)

                           then

                              The_Project := Empty_Node;

                              Error_Msg

                                (Flags, "not the same package as " &

                                 Get_Name_String

                                   (Name_Of (Current_Package, In_Tree)),

                                 Token_Ptr);

                           else

                              The_Package :=

                                First_Package_Of (The_Project, In_Tree);

                              --  Look for the package node

                              while Present (The_Package)

                                and then

                                Name_Of (The_Package, In_Tree) /= Token_Name

                              loop

                                 The_Package :=

                                   Next_Package_In_Project

                                     (The_Package, In_Tree);

                              end loop;

                              --  If the package cannot be found in the

                              --  project, issue an error.

                              if No (The_Package) then

                                 The_Project := Empty_Node;

                                 Error_Msg_Name_2 := Project_Name;

                                 Error_Msg_Name_1 := Token_Name;

                                 Error_Msg

                                   (Flags,

                                    "package % not declared in project %",

                                    Token_Ptr);

                              end if;

                              Scan (In_Tree); --  past the package name

                           end if;

                        end if;

                     end if;

                  end if;

               end if;

               if Present (The_Project) then

                  --  Looking for '<same attribute name>

                  Expect (Tok_Apostrophe, "`''`");

                  if Token /= Tok_Apostrophe then

                     The_Project := Empty_Node;

                  else

                     Scan (In_Tree); --  past the apostrophe

                     Expect (Tok_Identifier, "identifier");

                     if Token /= Tok_Identifier then

                        The_Project := Empty_Node;

                     else

                        --  If it is not the same attribute name, issue error

                        if Token_Name /= Attribute_Name then

                           The_Project := Empty_Node;

                           Error_Msg_Name_1 := Attribute_Name;

                           Error_Msg

                             (Flags, "invalid name, should be %", Token_Ptr);

                        end if;

                        Scan (In_Tree); --  past the attribute name

                     end if;

                  end if;

               end if;

               if No (The_Project) then

                  --  If there were any problem, set the attribute id to null,

                  --  so that the node will not be recorded.

                  Current_Attribute := Empty_Attribute;

               else

                  --  Set the appropriate field in the node.

                  --  Note that the index and the expression are nil. This

                  --  characterizes full associative array attribute

                  --  declarations.

                  Set_Associative_Project_Of (Attribute, In_Tree, The_Project);

                  Set_Associative_Package_Of (Attribute, In_Tree, The_Package);

               end if;

            end;

         --  Other attribute declarations (not full associative array)

         else

            declare

               Expression_Location : constant Source_Ptr := Token_Ptr;

               --  The location of the first token of the expression

               Expression          : Project_Node_Id     := Empty_Node;

               --  The expression, value for the attribute declaration

            begin

               --  Get the expression value and set it in the attribute node

               Parse_Expression

                 (In_Tree         => In_Tree,

                  Expression      => Expression,

                  Flags           => Flags,

                  Current_Project => Current_Project,

                  Current_Package => Current_Package,

                  Optional_Index  => Optional_Index);

               Set_Expression_Of (Attribute, In_Tree, To => Expression);

               --  If the expression is legal, but not of the right kind

               --  for the attribute, issue an error.

               if Current_Attribute /= Empty_Attribute

                 and then Present (Expression)

                 and then Variable_Kind_Of (Current_Attribute) /=

                 Expression_Kind_Of (Expression, In_Tree)

               then

                  if  Variable_Kind_Of (Current_Attribute) = Undefined then

                     Set_Variable_Kind_Of

                       (Current_Attribute,

                        To => Expression_Kind_Of (Expression, In_Tree));

                  else

                     Error_Msg

                       (Flags, "wrong expression kind for attribute """ &

                        Get_Name_String

                          (Attribute_Name_Of (Current_Attribute)) &

                        """",

                        Expression_Location);

                  end if;

               end if;

            end;

         end if;

      end if;

      --  If the attribute was not recognized, return an empty node.

      --  It may be that it is not in a package to check, and the node will

      --  not be added to the tree.

      if Current_Attribute = Empty_Attribute then

         Attribute := Empty_Node;

      end if;

      Set_End_Of_Line (Attribute);

      Set_Previous_Line_Node (Attribute);

   end Parse_Attribute_Declaration;

   -----------------------------

   -- Parse_Case_Construction --

   -----------------------------

   procedure Parse_Case_Construction

     (In_Tree           : Project_Node_Tree_Ref;

      Case_Construction : out Project_Node_Id;

      First_Attribute   : Attribute_Node_Id;

      Current_Project   : Project_Node_Id;

      Current_Package   : Project_Node_Id;

      Packages_To_Check : String_List_Access;

      Is_Config_File    : Boolean;

      Flags             : Processing_Flags)

   is

      Current_Item    : Project_Node_Id := Empty_Node;

      Next_Item       : Project_Node_Id := Empty_Node;

      First_Case_Item : Boolean := True;

      Variable_Location : Source_Ptr := No_Location;

      String_Type : Project_Node_Id := Empty_Node;

      Case_Variable : Project_Node_Id := Empty_Node;

      First_Declarative_Item : Project_Node_Id := Empty_Node;

      First_Choice           : Project_Node_Id := Empty_Node;

      When_Others            : Boolean := False;

      --  Set to True when there is a "when others =>" clause

   begin

      Case_Construction  :=

        Default_Project_Node

          (Of_Kind => N_Case_Construction, In_Tree => In_Tree);

      Set_Location_Of (Case_Construction, In_Tree, To => Token_Ptr);

      --  Scan past "case"

      Scan (In_Tree);

      --  Get the switch variable

      Expect (Tok_Identifier, "identifier");

      if Token = Tok_Identifier then

         Variable_Location := Token_Ptr;

         Parse_Variable_Reference

           (In_Tree         => In_Tree,

            Variable        => Case_Variable,

            Flags           => Flags,

            Current_Project => Current_Project,

            Current_Package => Current_Package);

         Set_Case_Variable_Reference_Of

           (Case_Construction, In_Tree, To => Case_Variable);

      else

         if Token /= Tok_Is then

            Scan (In_Tree);

         end if;