Subversion Repositories openrisc

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

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                             P R J . S T R T                              --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 2001-2009, 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 indices 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;

      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

                      Case_Insensitive_Associative_Array ..

                        Optional_Index_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);

                  Expect (Tok_String_Literal, "literal string");

                  if Token = Tok_String_Literal then

                     Set_Associative_Array_Index_Of

                       (Reference, In_Tree, To => Token_Name);

                     Scan (In_Tree);

                     Expect (Tok_Right_Paren, "`)`");

                     if Token = Tok_Right_Paren then

                        Scan (In_Tree);

                     end if;

                  end if;

               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;

      Flags           : Processing_Flags)

   is

      Field_Id : Project_Node_Id := Empty_Node;

   begin

      External_Value :=

        Default_Project_Node

          (Of_Kind       => N_External_Value,

           In_Tree       => In_Tree,

           And_Expr_Kind => Single);

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

      --  The current token is External

      --  Get the left parenthesis

      Scan (In_Tree);

      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 =>

               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 =>

               Error_Msg (Flags, "`,` or `)` expected", Token_Ptr);

         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);