Subversion Repositories openrisc

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

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                              P R J . P R O C                             --

--                                                                          --

--                                 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 Opt;      use Opt;

with Osint;    use Osint;

with Output;   use Output;

with Prj.Attr; use Prj.Attr;

with Prj.Err;  use Prj.Err;

with Prj.Ext;  use Prj.Ext;

with Prj.Nmsc; use Prj.Nmsc;

with Snames;

with GNAT.Case_Util; use GNAT.Case_Util;

with GNAT.HTable;

package body Prj.Proc is

   package Processed_Projects is new GNAT.HTable.Simple_HTable

     (Header_Num => Header_Num,

      Element    => Project_Id,

      No_Element => No_Project,

      Key        => Name_Id,

      Hash       => Hash,

      Equal      => "=");

   --  This hash table contains all processed projects

   package Unit_Htable is new GNAT.HTable.Simple_HTable

     (Header_Num => Header_Num,

      Element    => Source_Id,

      No_Element => No_Source,

      Key        => Name_Id,

      Hash       => Hash,

      Equal      => "=");

   --  This hash table contains all processed projects

   procedure Add (To_Exp : in out Name_Id; Str : Name_Id);

   --  Concatenate two strings and returns another string if both

   --  arguments are not null string.

   --  In the following procedures, we are expected to guess the meaning of

   --  the parameters from their names, this is never a good idea, comments

   --  should be added precisely defining every formal ???

   procedure Add_Attributes

     (Project       : Project_Id;

      Project_Name  : Name_Id;

      Project_Dir   : Name_Id;

      In_Tree       : Project_Tree_Ref;

      Decl          : in out Declarations;

      First         : Attribute_Node_Id;

      Project_Level : Boolean);

   --  Add all attributes, starting with First, with their default values to

   --  the package or project with declarations Decl.

   procedure Check

     (In_Tree : Project_Tree_Ref;

      Project : Project_Id;

      Flags   : Processing_Flags);

   --  Set all projects to not checked, then call Recursive_Check for the

   --  main project Project. Project is set to No_Project if errors occurred.

   --  Current_Dir is for optimization purposes, avoiding extra system calls.

   --  If Allow_Duplicate_Basenames, then files with the same base names are

   --  authorized within a project for source-based languages (never for unit

   --  based languages)

   procedure Copy_Package_Declarations

     (From              : Declarations;

      To                : in out Declarations;

      New_Loc           : Source_Ptr;

      Naming_Restricted : Boolean;

      In_Tree           : Project_Tree_Ref);

   --  Copy a package declaration From to To for a renamed package. Change the

   --  locations of all the attributes to New_Loc. When Naming_Restricted is

   --  True, do not copy attributes Body, Spec, Implementation and

   --  Specification.

   function Expression

     (Project                : Project_Id;

      In_Tree                : Project_Tree_Ref;

      Flags                  : Processing_Flags;

      From_Project_Node      : Project_Node_Id;

      From_Project_Node_Tree : Project_Node_Tree_Ref;

      Pkg                    : Package_Id;

      First_Term             : Project_Node_Id;

      Kind                   : Variable_Kind) return Variable_Value;

   --  From N_Expression project node From_Project_Node, compute the value

   --  of an expression and return it as a Variable_Value.

   function Imported_Or_Extended_Project_From

     (Project   : Project_Id;

      With_Name : Name_Id) return Project_Id;

   --  Find an imported or extended project of Project whose name is With_Name

   function Package_From

     (Project   : Project_Id;

      In_Tree   : Project_Tree_Ref;

      With_Name : Name_Id) return Package_Id;

   --  Find the package of Project whose name is With_Name

   procedure Process_Declarative_Items

     (Project                : Project_Id;

      In_Tree                : Project_Tree_Ref;

      Flags                  : Processing_Flags;

      From_Project_Node      : Project_Node_Id;

      From_Project_Node_Tree : Project_Node_Tree_Ref;

      Pkg                    : Package_Id;

      Item                   : Project_Node_Id);

   --  Process declarative items starting with From_Project_Node, and put them

   --  in declarations Decl. This is a recursive procedure; it calls itself for

   --  a package declaration or a case construction.

   procedure Recursive_Process

     (In_Tree                : Project_Tree_Ref;

      Project                : out Project_Id;

      Flags                  : Processing_Flags;

      From_Project_Node      : Project_Node_Id;

      From_Project_Node_Tree : Project_Node_Tree_Ref;

      Extended_By            : Project_Id);

   --  Process project with node From_Project_Node in the tree. Do nothing if

   --  From_Project_Node is Empty_Node. If project has already been processed,

   --  simply return its project id. Otherwise create a new project id, mark it

   --  as processed, call itself recursively for all imported projects and a

   --  extended project, if any. Then process the declarative items of the

   --  project.

   function Get_Attribute_Index

     (Tree  : Project_Node_Tree_Ref;

      Attr  : Project_Node_Id;

      Index : Name_Id) return Name_Id;

   --  Copy the index of the attribute into Name_Buffer, converting to lower

   --  case if the attribute is case-insensitive.

   ---------

   -- Add --

   ---------

   procedure Add (To_Exp : in out Name_Id; Str : Name_Id) is

   begin

      if To_Exp = No_Name or else To_Exp = Empty_String then

         --  To_Exp is nil or empty. The result is Str

         To_Exp := Str;

      --  If Str is nil, then do not change To_Ext

      elsif Str /= No_Name and then Str /= Empty_String then

         declare

            S : constant String := Get_Name_String (Str);

         begin

            Get_Name_String (To_Exp);

            Add_Str_To_Name_Buffer (S);

            To_Exp := Name_Find;

         end;

      end if;

   end Add;

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

   -- Add_Attributes --

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

   procedure Add_Attributes

     (Project       : Project_Id;

      Project_Name  : Name_Id;

      Project_Dir   : Name_Id;

      In_Tree       : Project_Tree_Ref;

      Decl          : in out Declarations;

      First         : Attribute_Node_Id;

      Project_Level : Boolean)

   is

      The_Attribute  : Attribute_Node_Id := First;

   begin

      while The_Attribute /= Empty_Attribute loop

         if Attribute_Kind_Of (The_Attribute) = Single then

            declare

               New_Attribute : Variable_Value;

            begin

               case Variable_Kind_Of (The_Attribute) is

                  --  Undefined should not happen

                  when Undefined =>

                     pragma Assert

                       (False, "attribute with an undefined kind");

                     raise Program_Error;

                  --  Single attributes have a default value of empty string

                  when Single =>

                     New_Attribute :=

                       (Project  => Project,

                        Kind     => Single,

                        Location => No_Location,

                        Default  => True,

                        Value    => Empty_String,

                        Index    => 0);

                     --  Special cases of <project>'Name and

                     --  <project>'Project_Dir.

                     if Project_Level then

                        if Attribute_Name_Of (The_Attribute) =

                          Snames.Name_Name

                        then

                           New_Attribute.Value := Project_Name;

                        elsif Attribute_Name_Of (The_Attribute) =

                          Snames.Name_Project_Dir

                        then

                           New_Attribute.Value := Project_Dir;

                        end if;

                     end if;

                  --  List attributes have a default value of nil list

                  when List =>

                     New_Attribute :=

                       (Project  => Project,

                        Kind     => List,

                        Location => No_Location,

                        Default  => True,

                        Values   => Nil_String);

               end case;

               Variable_Element_Table.Increment_Last

                 (In_Tree.Variable_Elements);

               In_Tree.Variable_Elements.Table

                 (Variable_Element_Table.Last

                   (In_Tree.Variable_Elements)) :=

                 (Next  => Decl.Attributes,

                  Name  => Attribute_Name_Of (The_Attribute),

                  Value => New_Attribute);

               Decl.Attributes := Variable_Element_Table.Last

                 (In_Tree.Variable_Elements);

            end;

         end if;

         The_Attribute := Next_Attribute (After => The_Attribute);

      end loop;

   end Add_Attributes;

   -----------

   -- Check --

   -----------

   procedure Check

     (In_Tree : Project_Tree_Ref;

      Project : Project_Id;

      Flags   : Processing_Flags)

   is

   begin

      Process_Naming_Scheme (In_Tree, Project, Flags);

      --  Set the Other_Part field for the units

      declare

         Source1 : Source_Id;

         Name    : Name_Id;

         Source2 : Source_Id;

         Iter    : Source_Iterator;

      begin

         Unit_Htable.Reset;

         Iter := For_Each_Source (In_Tree);

         loop

            Source1 := Prj.Element (Iter);

            exit when Source1 = No_Source;

            if Source1.Unit /= No_Unit_Index then

               Name := Source1.Unit.Name;

               Source2 := Unit_Htable.Get (Name);

               if Source2 = No_Source then

                  Unit_Htable.Set (K => Name, E => Source1);

               else

                  Unit_Htable.Remove (Name);

               end if;

            end if;

            Next (Iter);

         end loop;

      end;

   end Check;

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

   -- Copy_Package_Declarations --

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

   procedure Copy_Package_Declarations

     (From              : Declarations;

      To                : in out Declarations;

      New_Loc           : Source_Ptr;

      Naming_Restricted : Boolean;

      In_Tree           : Project_Tree_Ref)

   is

      V1  : Variable_Id;

      V2  : Variable_Id      := No_Variable;

      Var : Variable;

      A1  : Array_Id;

      A2  : Array_Id         := No_Array;

      Arr : Array_Data;

      E1  : Array_Element_Id;

      E2  : Array_Element_Id := No_Array_Element;

      Elm : Array_Element;

   begin

      --  To avoid references in error messages to attribute declarations in

      --  an original package that has been renamed, copy all the attribute

      --  declarations of the package and change all locations to New_Loc,

      --  the location of the renamed package.

      --  First single attributes

      V1 := From.Attributes;

      while V1 /= No_Variable loop

         --  Copy the attribute

         Var := In_Tree.Variable_Elements.Table (V1);

         V1  := Var.Next;

         --  Remove the Next component

         Var.Next := No_Variable;

         --  Change the location to New_Loc

         Var.Value.Location := New_Loc;

         Variable_Element_Table.Increment_Last (In_Tree.Variable_Elements);

         --  Put in new declaration

         if To.Attributes = No_Variable then

            To.Attributes :=

              Variable_Element_Table.Last (In_Tree.Variable_Elements);

         else

            In_Tree.Variable_Elements.Table (V2).Next :=

              Variable_Element_Table.Last (In_Tree.Variable_Elements);

         end if;

         V2 := Variable_Element_Table.Last (In_Tree.Variable_Elements);

         In_Tree.Variable_Elements.Table (V2) := Var;

      end loop;

      --  Then the associated array attributes

      A1 := From.Arrays;

      while A1 /= No_Array loop

         Arr := In_Tree.Arrays.Table (A1);

         A1  := Arr.Next;

         if not Naming_Restricted or else

           (Arr.Name /= Snames.Name_Body

             and then Arr.Name /= Snames.Name_Spec

             and then Arr.Name /= Snames.Name_Implementation

             and then Arr.Name /= Snames.Name_Specification)

         then

            --  Remove the Next component

            Arr.Next := No_Array;

            Array_Table.Increment_Last (In_Tree.Arrays);

            --  Create new Array declaration

            if To.Arrays = No_Array then

               To.Arrays := Array_Table.Last (In_Tree.Arrays);

            else

               In_Tree.Arrays.Table (A2).Next :=

                 Array_Table.Last (In_Tree.Arrays);

            end if;

            A2 := Array_Table.Last (In_Tree.Arrays);

            --  Don't store the array as its first element has not been set yet

            --  Copy the array elements of the array

            E1 := Arr.Value;

            Arr.Value := No_Array_Element;

            while E1 /= No_Array_Element loop

               --  Copy the array element

               Elm := In_Tree.Array_Elements.Table (E1);

               E1 := Elm.Next;

               --  Remove the Next component

               Elm.Next := No_Array_Element;

               --  Change the location

               Elm.Value.Location := New_Loc;

               Array_Element_Table.Increment_Last (In_Tree.Array_Elements);

               --  Create new array element

               if Arr.Value = No_Array_Element then

                  Arr.Value :=

                    Array_Element_Table.Last (In_Tree.Array_Elements);

               else

                  In_Tree.Array_Elements.Table (E2).Next :=

                    Array_Element_Table.Last (In_Tree.Array_Elements);

               end if;

               E2 := Array_Element_Table.Last (In_Tree.Array_Elements);

               In_Tree.Array_Elements.Table (E2) := Elm;

            end loop;

            --  Finally, store the new array

            In_Tree.Arrays.Table (A2) := Arr;

         end if;

      end loop;

   end Copy_Package_Declarations;

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

   -- Get_Attribute_Index --

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

   function Get_Attribute_Index

     (Tree  : Project_Node_Tree_Ref;

      Attr  : Project_Node_Id;

      Index : Name_Id) return Name_Id

   is

      Lower : Boolean;

   begin

      Get_Name_String (Index);

      Lower := Case_Insensitive (Attr, Tree);

      --  The index is always case insensitive if it does not include any dot.

      --  ??? Why not use the properties from prj-attr, simply, maybe because

      --  we don't know whether we have a file as an index?

      if not Lower then

         Lower := True;

         for J in 1 .. Name_Len loop

            if Name_Buffer (J) = '.' then

               Lower := False;

               exit;

            end if;

         end loop;

      end if;

      if Lower then

         To_Lower (Name_Buffer (1 .. Name_Len));

         return Name_Find;

      else

         return Index;

      end if;

   end Get_Attribute_Index;

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

   -- Expression --

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

   function Expression

     (Project                : Project_Id;

      In_Tree                : Project_Tree_Ref;

      Flags                  : Processing_Flags;

      From_Project_Node      : Project_Node_Id;

      From_Project_Node_Tree : Project_Node_Tree_Ref;

      Pkg                    : Package_Id;

      First_Term             : Project_Node_Id;

      Kind                   : Variable_Kind) return Variable_Value

   is

      The_Term : Project_Node_Id;

      --  The term in the expression list

      The_Current_Term : Project_Node_Id := Empty_Node;

      --  The current term node id

      Result : Variable_Value (Kind => Kind);

      --  The returned result

      Last : String_List_Id := Nil_String;

      --  Reference to the last string elements in Result, when Kind is List

   begin

      Result.Project := Project;

      Result.Location := Location_Of (First_Term, From_Project_Node_Tree);

      --  Process each term of the expression, starting with First_Term

      The_Term := First_Term;

      while Present (The_Term) loop

         The_Current_Term := Current_Term (The_Term, From_Project_Node_Tree);

         case Kind_Of (The_Current_Term, From_Project_Node_Tree) is

            when N_Literal_String =>

               case Kind is

                  when Undefined =>

                     --  Should never happen

                     pragma Assert (False, "Undefined expression kind");

                     raise Program_Error;

                  when Single =>

                     Add (Result.Value,

                          String_Value_Of

                            (The_Current_Term, From_Project_Node_Tree));

                     Result.Index :=

                       Source_Index_Of

                         (The_Current_Term, From_Project_Node_Tree);

                  when List =>

                     String_Element_Table.Increment_Last

                       (In_Tree.String_Elements);

                     if Last = Nil_String then

                        --  This can happen in an expression like () & "toto"

                        Result.Values := String_Element_Table.Last

                          (In_Tree.String_Elements);

                     else

                        In_Tree.String_Elements.Table

                          (Last).Next := String_Element_Table.Last

                                       (In_Tree.String_Elements);

                     end if;

                     Last := String_Element_Table.Last

                               (In_Tree.String_Elements);

                     In_Tree.String_Elements.Table (Last) :=

                       (Value         => String_Value_Of

                                           (The_Current_Term,

                                            From_Project_Node_Tree),

                        Index         => Source_Index_Of

                                           (The_Current_Term,

                                            From_Project_Node_Tree),

                        Display_Value => No_Name,

                        Location      => Location_Of

                                           (The_Current_Term,

                                            From_Project_Node_Tree),

                        Flag          => False,

                        Next          => Nil_String);

               end case;

            when N_Literal_String_List =>

               declare

                  String_Node : Project_Node_Id :=

                                  First_Expression_In_List

                                    (The_Current_Term,

                                     From_Project_Node_Tree);

                  Value : Variable_Value;

               begin

                  if Present (String_Node) then

                     --  If String_Node is nil, it is an empty list, there is

                     --  nothing to do

                     Value := Expression

                       (Project                => Project,

                        In_Tree                => In_Tree,

                        Flags                  => Flags,

                        From_Project_Node      => From_Project_Node,

                        From_Project_Node_Tree => From_Project_Node_Tree,

                        Pkg                    => Pkg,

                        First_Term             =>

                          Tree.First_Term

                            (String_Node, From_Project_Node_Tree),

                        Kind                   => Single);

                     String_Element_Table.Increment_Last

                       (In_Tree.String_Elements);

                     if Result.Values = Nil_String then

                        --  This literal string list is the first term in a

                        --  string list expression

                        Result.Values :=

                          String_Element_Table.Last (In_Tree.String_Elements);

                     else

                        In_Tree.String_Elements.Table

                          (Last).Next :=

                          String_Element_Table.Last (In_Tree.String_Elements);

                     end if;

                     Last :=

                       String_Element_Table.Last (In_Tree.String_Elements);

                     In_Tree.String_Elements.Table (Last) :=

                       (Value    => Value.Value,

                        Display_Value => No_Name,

                        Location => Value.Location,

                        Flag     => False,

                        Next     => Nil_String,

                        Index    => Value.Index);

                     loop

                        --  Add the other element of the literal string list

                        --  one after the other

                        String_Node :=

                          Next_Expression_In_List

                            (String_Node, From_Project_Node_Tree);

                        exit when No (String_Node);

                        Value :=

                          Expression

                            (Project                => Project,

                             In_Tree                => In_Tree,

                             Flags                  => Flags,

                             From_Project_Node      => From_Project_Node,

                             From_Project_Node_Tree => From_Project_Node_Tree,

                             Pkg                    => Pkg,

                             First_Term             =>

                               Tree.First_Term

                                 (String_Node, From_Project_Node_Tree),

                             Kind                   => Single);

                        String_Element_Table.Increment_Last

                          (In_Tree.String_Elements);

                        In_Tree.String_Elements.Table

                          (Last).Next := String_Element_Table.Last

                                        (In_Tree.String_Elements);

                        Last := String_Element_Table.Last

                          (In_Tree.String_Elements);

                        In_Tree.String_Elements.Table (Last) :=

                          (Value    => Value.Value,

                           Display_Value => No_Name,

                           Location => Value.Location,

                           Flag     => False,

                           Next     => Nil_String,

                           Index    => Value.Index);

                     end loop;

                  end if;

               end;

            when N_Variable_Reference | N_Attribute_Reference =>

               declare

                  The_Project     : Project_Id  := Project;

                  The_Package     : Package_Id  := Pkg;

                  The_Name        : Name_Id     := No_Name;

                  The_Variable_Id : Variable_Id := No_Variable;

                  The_Variable    : Variable_Value;

                  Term_Project    : constant Project_Node_Id :=

                                      Project_Node_Of

                                        (The_Current_Term,

                                         From_Project_Node_Tree);

                  Term_Package    : constant Project_Node_Id :=

                                      Package_Node_Of

                                        (The_Current_Term,

                                         From_Project_Node_Tree);

                  Index           : Name_Id := No_Name;

               begin

                  if Present (Term_Project) and then

                     Term_Project /= From_Project_Node

                  then

                     --  This variable or attribute comes from another project

                     The_Name :=

                       Name_Of (Term_Project, From_Project_Node_Tree);

                     The_Project := Imported_Or_Extended_Project_From

                                      (Project   => Project,

                                       With_Name => The_Name);

                  end if;

                  if Present (Term_Package) then

                     --  This is an attribute of a package

                     The_Name :=

                       Name_Of (Term_Package, From_Project_Node_Tree);

                     The_Package := The_Project.Decl.Packages;

                     while The_Package /= No_Package

                       and then In_Tree.Packages.Table

                                  (The_Package).Name /= The_Name

                     loop

                        The_Package :=

                          In_Tree.Packages.Table

                            (The_Package).Next;

                     end loop;

                     pragma Assert

                       (The_Package /= No_Package,

                        "package not found.");

                  elsif Kind_Of (The_Current_Term, From_Project_Node_Tree) =

                          N_Attribute_Reference

                  then

                     The_Package := No_Package;

                  end if;

                  The_Name :=

                    Name_Of (The_Current_Term, From_Project_Node_Tree);

                  if Kind_Of (The_Current_Term, From_Project_Node_Tree) =

                       N_Attribute_Reference

                  then

                     Index :=

                       Associative_Array_Index_Of

                         (The_Current_Term, From_Project_Node_Tree);

                  end if;

                  --  If it is not an associative array attribute

                  if Index = No_Name then

                     --  It is not an associative array attribute

                     if The_Package /= No_Package then

                        --  First, if there is a package, look into the package

                        if Kind_Of (The_Current_Term, From_Project_Node_Tree) =

                             N_Variable_Reference

                        then

                           The_Variable_Id :=

                             In_Tree.Packages.Table

                               (The_Package).Decl.Variables;

                        else

                           The_Variable_Id :=

                             In_Tree.Packages.Table

                               (The_Package).Decl.Attributes;

                        end if;

                        while The_Variable_Id /= No_Variable

                          and then

                            In_Tree.Variable_Elements.Table

                              (The_Variable_Id).Name /= The_Name

                        loop

                           The_Variable_Id :=

                             In_Tree.Variable_Elements.Table

                               (The_Variable_Id).Next;

                        end loop;

                     end if;

                     if The_Variable_Id = No_Variable then

                        --  If we have not found it, look into the project

                        if Kind_Of (The_Current_Term, From_Project_Node_Tree) =

                             N_Variable_Reference

                        then

                           The_Variable_Id := The_Project.Decl.Variables;

                        else

                           The_Variable_Id := The_Project.Decl.Attributes;

                        end if;

                        while The_Variable_Id /= No_Variable

                          and then

                          In_Tree.Variable_Elements.Table

                            (The_Variable_Id).Name /= The_Name

                        loop

                           The_Variable_Id :=

                             In_Tree.Variable_Elements.Table

                               (The_Variable_Id).Next;

                        end loop;

                     end if;

                     pragma Assert (The_Variable_Id /= No_Variable,

                                      "variable or attribute not found");

                     The_Variable :=

                       In_Tree.Variable_Elements.Table

                                                    (The_Variable_Id).Value;

                  else

                     --  It is an associative array attribute

                     declare