Subversion Repositories openrisc

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

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                        L I B . X R E F . A L F A                         --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--             Copyright (C) 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 Alfa;     use Alfa;

with Einfo;    use Einfo;

with Nmake;    use Nmake;

with Put_Alfa;

with GNAT.HTable;

separate (Lib.Xref)

package body Alfa is

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

   -- Local Constants --

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

   --  Table of Alfa_Entities, True for each entity kind used in Alfa

   Alfa_Entities : constant array (Entity_Kind) of Boolean :=

     (E_Void                                       => False,

      E_Variable                                   => True,

      E_Component                                  => False,

      E_Constant                                   => True,

      E_Discriminant                               => False,

      E_Loop_Parameter                             => True,

      E_In_Parameter                               => True,

      E_Out_Parameter                              => True,

      E_In_Out_Parameter                           => True,

      E_Generic_In_Out_Parameter                   => False,

      E_Generic_In_Parameter                       => False,

      E_Named_Integer                              => False,

      E_Named_Real                                 => False,

      E_Enumeration_Type                           => False,

      E_Enumeration_Subtype                        => False,

      E_Signed_Integer_Type                        => False,

      E_Signed_Integer_Subtype                     => False,

      E_Modular_Integer_Type                       => False,

      E_Modular_Integer_Subtype                    => False,

      E_Ordinary_Fixed_Point_Type                  => False,

      E_Ordinary_Fixed_Point_Subtype               => False,

      E_Decimal_Fixed_Point_Type                   => False,

      E_Decimal_Fixed_Point_Subtype                => False,

      E_Floating_Point_Type                        => False,

      E_Floating_Point_Subtype                     => False,

      E_Access_Type                                => False,

      E_Access_Subtype                             => False,

      E_Access_Attribute_Type                      => False,

      E_Allocator_Type                             => False,

      E_General_Access_Type                        => False,

      E_Access_Subprogram_Type                     => False,

      E_Access_Protected_Subprogram_Type           => False,

      E_Anonymous_Access_Subprogram_Type           => False,

      E_Anonymous_Access_Protected_Subprogram_Type => False,

      E_Anonymous_Access_Type                      => False,

      E_Array_Type                                 => False,

      E_Array_Subtype                              => False,

      E_String_Type                                => False,

      E_String_Subtype                             => False,

      E_String_Literal_Subtype                     => False,

      E_Class_Wide_Type                            => False,

      E_Class_Wide_Subtype                         => False,

      E_Record_Type                                => False,

      E_Record_Subtype                             => False,

      E_Record_Type_With_Private                   => False,

      E_Record_Subtype_With_Private                => False,

      E_Private_Type                               => False,

      E_Private_Subtype                            => False,

      E_Limited_Private_Type                       => False,

      E_Limited_Private_Subtype                    => False,

      E_Incomplete_Type                            => False,

      E_Incomplete_Subtype                         => False,

      E_Task_Type                                  => False,

      E_Task_Subtype                               => False,

      E_Protected_Type                             => False,

      E_Protected_Subtype                          => False,

      E_Exception_Type                             => False,

      E_Subprogram_Type                            => False,

      E_Enumeration_Literal                        => False,

      E_Function                                   => True,

      E_Operator                                   => True,

      E_Procedure                                  => True,

      E_Entry                                      => False,

      E_Entry_Family                               => False,

      E_Block                                      => False,

      E_Entry_Index_Parameter                      => False,

      E_Exception                                  => False,

      E_Generic_Function                           => False,

      E_Generic_Package                            => False,

      E_Generic_Procedure                          => False,

      E_Label                                      => False,

      E_Loop                                       => False,

      E_Return_Statement                           => False,

      E_Package                                    => False,

      E_Package_Body                               => False,

      E_Protected_Object                           => False,

      E_Protected_Body                             => False,

      E_Task_Body                                  => False,

      E_Subprogram_Body                            => False);

   --  True for each reference type used in Alfa

   Alfa_References : constant array (Character) of Boolean :=

     ('m' => True,

      'r' => True,

      's' => True,

      others => False);

   type Entity_Hashed_Range is range 0 .. 255;

   --  Size of hash table headers

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

   -- Local Variables --

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

   package Drefs is new Table.Table (

     Table_Component_Type => Xref_Entry,

     Table_Index_Type     => Xref_Entry_Number,

     Table_Low_Bound      => 1,

     Table_Initial        => Alloc.Xrefs_Initial,

     Table_Increment      => Alloc.Xrefs_Increment,

     Table_Name           => "Drefs");

   --  Table of cross-references for reads and writes through explicit

   --  dereferences, that are output as reads/writes to the special variable

   --  "Heap". These references are added to the regular references when

   --  computing Alfa cross-references.

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

   -- Local Subprograms --

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

   procedure Add_Alfa_File (U : Unit_Number_Type; D : Nat);

   --  Add file U and all scopes in U to the tables Alfa_File_Table and

   --  Alfa_Scope_Table.

   procedure Add_Alfa_Scope (N : Node_Id);

   --  Add scope N to the table Alfa_Scope_Table

   procedure Add_Alfa_Xrefs;

   --  Filter table Xrefs to add all references used in Alfa to the table

   --  Alfa_Xref_Table.

   procedure Detect_And_Add_Alfa_Scope (N : Node_Id);

   --  Call Add_Alfa_Scope on scopes

   function Entity_Hash (E : Entity_Id) return Entity_Hashed_Range;

   --  Hash function for hash table

   procedure Traverse_Declarations_Or_Statements

     (L            : List_Id;

      Process      : Node_Processing;

      Inside_Stubs : Boolean);

   procedure Traverse_Handled_Statement_Sequence

     (N            : Node_Id;

      Process      : Node_Processing;

      Inside_Stubs : Boolean);

   procedure Traverse_Package_Body

     (N            : Node_Id;

      Process      : Node_Processing;

      Inside_Stubs : Boolean);

   procedure Traverse_Package_Declaration

     (N            : Node_Id;

      Process      : Node_Processing;

      Inside_Stubs : Boolean);

   procedure Traverse_Subprogram_Body

     (N            : Node_Id;

      Process      : Node_Processing;

      Inside_Stubs : Boolean);

   --  Traverse the corresponding constructs, calling Process on all

   --  declarations.

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

   -- Add_Alfa_File --

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

   procedure Add_Alfa_File (U : Unit_Number_Type; D : Nat) is

      From : Scope_Index;

      S : constant Source_File_Index := Source_Index (U);

   begin

      --  Source file could be inexistant as a result of an error, if option

      --  gnatQ is used.

      if S = No_Source_File then

         return;

      end if;

      From := Alfa_Scope_Table.Last + 1;

      Traverse_Compilation_Unit (Cunit (U), Detect_And_Add_Alfa_Scope'Access,

                                 Inside_Stubs => False);

      --  Update scope numbers

      declare

         Count : Nat;

      begin

         Count := 1;

         for S in From .. Alfa_Scope_Table.Last loop

            declare

               E : Entity_Id renames Alfa_Scope_Table.Table (S).Scope_Entity;

            begin

               if Lib.Get_Source_Unit (E) = U then

                  Alfa_Scope_Table.Table (S).Scope_Num := Count;

                  Alfa_Scope_Table.Table (S).File_Num  := D;

                  Count                                := Count + 1;

               else

                  --  Mark for removal a scope S which is not located in unit

                  --  U, for example for scope inside generics that get

                  --  instantiated.

                  Alfa_Scope_Table.Table (S).Scope_Num := 0;

               end if;

            end;

         end loop;

      end;

      declare

         Snew : Scope_Index;

      begin

         Snew := From;

         for S in From .. Alfa_Scope_Table.Last loop

            --  Remove those scopes previously marked for removal

            if Alfa_Scope_Table.Table (S).Scope_Num /= 0 then

               Alfa_Scope_Table.Table (Snew) := Alfa_Scope_Table.Table (S);

               Snew := Snew + 1;

            end if;

         end loop;

         Alfa_Scope_Table.Set_Last (Snew - 1);

      end;

      --  Make entry for new file in file table

      Get_Name_String (Reference_Name (S));

      Alfa_File_Table.Append (

        (File_Name  => new String'(Name_Buffer (1 .. Name_Len)),

         File_Num   => D,

         From_Scope => From,

         To_Scope   => Alfa_Scope_Table.Last));

   end Add_Alfa_File;

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

   -- Add_Alfa_Scope --

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

   procedure Add_Alfa_Scope (N : Node_Id) is

      E   : constant Entity_Id  := Defining_Entity (N);

      Loc : constant Source_Ptr := Sloc (E);

      Typ : Character;

   begin

      --  Ignore scopes without a proper location

      if Sloc (N) = No_Location then

         return;

      end if;

      case Ekind (E) is

         when E_Function | E_Generic_Function =>

            Typ := 'V';

         when E_Procedure | E_Generic_Procedure =>

            Typ := 'U';

         when E_Subprogram_Body =>

            declare

               Spec : Node_Id;

            begin

               Spec := Parent (E);

               if Nkind (Spec) = N_Defining_Program_Unit_Name then

                  Spec := Parent (Spec);

               end if;

               if Nkind (Spec) = N_Function_Specification then

                  Typ := 'V';

               else

                  pragma Assert

                    (Nkind (Spec) = N_Procedure_Specification);

                  Typ := 'U';

               end if;

            end;

         when E_Package | E_Package_Body | E_Generic_Package =>

            Typ := 'K';

         when E_Void =>

            --  Compilation of prj-attr.adb with -gnatn creates a node with

            --  entity E_Void for the package defined at a-charac.ads16:13

            --  ??? TBD

            return;

         when others =>

            raise Program_Error;

      end case;

      --  File_Num and Scope_Num are filled later. From_Xref and To_Xref are

      --  filled even later, but are initialized to represent an empty range.

      Alfa_Scope_Table.Append (

        (Scope_Name     => new String'(Unique_Name (E)),

         File_Num       => 0,

         Scope_Num      => 0,

         Spec_File_Num  => 0,

         Spec_Scope_Num => 0,

         Line           => Nat (Get_Logical_Line_Number (Loc)),

         Stype          => Typ,

         Col            => Nat (Get_Column_Number (Loc)),

         From_Xref      => 1,

         To_Xref        => 0,

         Scope_Entity   => E));

   end Add_Alfa_Scope;

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

   -- Add_Alfa_Xrefs --

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

   procedure Add_Alfa_Xrefs is

      Cur_Scope_Idx   : Scope_Index;

      From_Xref_Idx   : Xref_Index;

      Cur_Entity      : Entity_Id;

      Cur_Entity_Name : String_Ptr;

      package Scopes is

         No_Scope : constant Nat := 0;

         function Get_Scope_Num (N : Entity_Id) return Nat;

         procedure Set_Scope_Num (N : Entity_Id; Num : Nat);

      end Scopes;

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

      -- Scopes --

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

      package body Scopes is

         type Scope is record

            Num    : Nat;

            Entity : Entity_Id;

         end record;

         package Scopes is new GNAT.HTable.Simple_HTable

           (Header_Num => Entity_Hashed_Range,

            Element    => Scope,

            No_Element => (Num => No_Scope, Entity => Empty),

            Key        => Entity_Id,

            Hash       => Entity_Hash,

            Equal      => "=");

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

         -- Get_Scope_Num --

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

         function Get_Scope_Num (N : Entity_Id) return Nat is

         begin

            return Scopes.Get (N).Num;

         end Get_Scope_Num;

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

         -- Set_Scope_Num --

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

         procedure Set_Scope_Num (N : Entity_Id; Num : Nat) is

         begin

            Scopes.Set (K => N, E => Scope'(Num => Num, Entity => N));

         end Set_Scope_Num;

      end Scopes;

      use Scopes;

      Nrefs : Nat := Xrefs.Last;

      --  Number of references in table. This value may get reset (reduced)

      --  when we eliminate duplicate reference entries as well as references

      --  not suitable for local cross-references.

      Nrefs_Add : constant Nat := Drefs.Last;

      Rnums : array (0 .. Nrefs + Nrefs_Add) of Nat;

      --  This array contains numbers of references in the Xrefs table. This

      --  list is sorted in output order. The extra 0'th entry is convenient

      --  for the call to sort. When we sort the table, we move the entries in

      --  Rnums around, but we do not move the original table entries.

      function Lt (Op1, Op2 : Natural) return Boolean;

      --  Comparison function for Sort call

      procedure Move (From : Natural; To : Natural);

      --  Move procedure for Sort call

      package Sorting is new GNAT.Heap_Sort_G (Move, Lt);

      --------

      -- Lt --

      --------

      function Lt (Op1, Op2 : Natural) return Boolean is

         T1 : constant Xref_Entry := Xrefs.Table (Rnums (Nat (Op1)));

         T2 : constant Xref_Entry := Xrefs.Table (Rnums (Nat (Op2)));

      begin

         --  First test: if entity is in different unit, sort by unit. Note:

         --  that we use Ent_Scope_File rather than Eun, as Eun may refer to

         --  the file where the generic scope is defined, which may differ from

         --  the file where the enclosing scope is defined. It is the latter

         --  which matters for a correct order here.

         if T1.Ent_Scope_File /= T2.Ent_Scope_File then

            return Dependency_Num (T1.Ent_Scope_File) <

              Dependency_Num (T2.Ent_Scope_File);

         --  Second test: within same unit, sort by location of the scope of

         --  the entity definition.

         elsif Get_Scope_Num (T1.Key.Ent_Scope) /=

               Get_Scope_Num (T2.Key.Ent_Scope)

         then

            return Get_Scope_Num (T1.Key.Ent_Scope) <

              Get_Scope_Num (T2.Key.Ent_Scope);

         --  Third test: within same unit and scope, sort by location of

         --  entity definition.

         elsif T1.Def /= T2.Def then

            return T1.Def < T2.Def;

         --  Fourth test: if reference is in same unit as entity definition,

         --  sort first.

         elsif

           T1.Key.Lun /= T2.Key.Lun and then T1.Ent_Scope_File = T1.Key.Lun

         then

            return True;

         elsif

           T1.Key.Lun /= T2.Key.Lun and then T2.Ent_Scope_File = T2.Key.Lun

         then

            return False;

         --  Fifth test: if reference is in same unit and same scope as entity

         --  definition, sort first.

         elsif T1.Ent_Scope_File = T1.Key.Lun

           and then T1.Key.Ref_Scope /= T2.Key.Ref_Scope

           and then T1.Key.Ent_Scope = T1.Key.Ref_Scope

         then

            return True;

         elsif T1.Ent_Scope_File = T1.Key.Lun

           and then T1.Key.Ref_Scope /= T2.Key.Ref_Scope

           and then T2.Key.Ent_Scope = T2.Key.Ref_Scope

         then

            return False;

         --  Sixth test: for same entity, sort by reference location unit

         elsif T1.Key.Lun /= T2.Key.Lun then

            return Dependency_Num (T1.Key.Lun) < Dependency_Num (T2.Key.Lun);

         --  Seventh test: for same entity, sort by reference location scope

         elsif Get_Scope_Num (T1.Key.Ref_Scope) /=

               Get_Scope_Num (T2.Key.Ref_Scope)

         then

            return Get_Scope_Num (T1.Key.Ref_Scope) <

              Get_Scope_Num (T2.Key.Ref_Scope);

         --  Eighth test: order of location within referencing unit

         elsif T1.Key.Loc /= T2.Key.Loc then

            return T1.Key.Loc < T2.Key.Loc;

         --  Finally, for two locations at the same address prefer the one that

         --  does NOT have the type 'r', so that a modification or extension

         --  takes preference, when there are more than one reference at the

         --  same location. As a result, in the case of entities that are

         --  in-out actuals, the read reference follows the modify reference.

         else

            return T2.Key.Typ = 'r';

         end if;

      end Lt;

      ----------

      -- Move --

      ----------

      procedure Move (From : Natural; To : Natural) is

      begin

         Rnums (Nat (To)) := Rnums (Nat (From));

      end Move;

      Heap : Entity_Id;

   --  Start of processing for Add_Alfa_Xrefs

   begin

      for J in Alfa_Scope_Table.First .. Alfa_Scope_Table.Last loop

         Set_Scope_Num (N   => Alfa_Scope_Table.Table (J).Scope_Entity,

                        Num => Alfa_Scope_Table.Table (J).Scope_Num);

      end loop;

      --  Set up the pointer vector for the sort

      for J in 1 .. Nrefs loop

         Rnums (J) := J;

      end loop;

      --  Add dereferences to the set of regular references, by creating a

      --  special "Heap" variable for these special references.

      Name_Len := Name_Of_Heap_Variable'Length;

      Name_Buffer (1 .. Name_Len) := Name_Of_Heap_Variable;

      Atree.Unlock;

      Nlists.Unlock;

      Heap := Make_Defining_Identifier (Standard_Location, Name_Enter);

      Atree.Lock;

      Nlists.Lock;

      Set_Ekind         (Heap, E_Variable);

      Set_Is_Internal   (Heap, True);

      Set_Has_Fully_Qualified_Name (Heap);

      for J in Drefs.First .. Drefs.Last loop

         Xrefs.Append (Drefs.Table (J));

         --  Set entity at this point with newly created "Heap" variable

         Xrefs.Table (Xrefs.Last).Key.Ent := Heap;

         Nrefs         := Nrefs + 1;

         Rnums (Nrefs) := Xrefs.Last;

      end loop;

      --  Eliminate entries not appropriate for Alfa. Done prior to sorting

      --  cross-references, as it discards useless references which do not have

      --  a proper format for the comparison function (like no location).

      Eliminate_Before_Sort : declare

         NR : Nat;

         function Is_Alfa_Reference

           (E   : Entity_Id;

            Typ : Character) return Boolean;

         --  Return whether entity reference E meets Alfa requirements. Typ

         --  is the reference type.

         function Is_Alfa_Scope (E : Entity_Id) return Boolean;

         --  Return whether the entity or reference scope meets requirements

         --  for being an Alfa scope.

         function Is_Global_Constant (E : Entity_Id) return Boolean;

         --  Return True if E is a global constant for which we should ignore

         --  reads in Alfa.

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

         -- Is_Alfa_Reference --

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

         function Is_Alfa_Reference

           (E   : Entity_Id;

            Typ : Character) return Boolean

         is

         begin

            --  The only references of interest on callable entities are calls.

            --  On non-callable entities, the only references of interest are

            --  reads and writes.

            if Ekind (E) in Overloadable_Kind then

               return Typ = 's';

            --  References to constant objects are not considered in Alfa

            --  section, as these will be translated as constants in the

            --  intermediate language for formal verification, and should

            --  therefore never appear in frame conditions.

            elsif Is_Constant_Object (E) then

                  return False;

            --  Objects of Task type or protected type are not Alfa references

            elsif Present (Etype (E))

              and then Ekind (Etype (E)) in Concurrent_Kind

            then

               return False;

            --  In all other cases, result is true for reference/modify cases,

            --  and false for all other cases.

            else

               return Typ = 'r' or else Typ = 'm';

            end if;

         end Is_Alfa_Reference;

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

         -- Is_Alfa_Scope --

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

         function Is_Alfa_Scope (E : Entity_Id) return Boolean is

         begin

            return Present (E)

              and then not Is_Generic_Unit (E)

              and then Renamed_Entity (E) = Empty

              and then Get_Scope_Num (E) /= No_Scope;

         end Is_Alfa_Scope;

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

         -- Is_Global_Constant --

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

         function Is_Global_Constant (E : Entity_Id) return Boolean is

         begin

            return Ekind (E) = E_Constant

              and then Ekind_In (Scope (E), E_Package, E_Package_Body);

         end Is_Global_Constant;

      --  Start of processing for Eliminate_Before_Sort

      begin

         NR    := Nrefs;

         Nrefs := 0;

         for J in 1 .. NR loop

            if Alfa_Entities (Ekind (Xrefs.Table (Rnums (J)).Key.Ent))

              and then Alfa_References (Xrefs.Table (Rnums (J)).Key.Typ)

              and then Is_Alfa_Scope (Xrefs.Table (Rnums (J)).Key.Ent_Scope)

              and then Is_Alfa_Scope (Xrefs.Table (Rnums (J)).Key.Ref_Scope)

              and then not Is_Global_Constant (Xrefs.Table (Rnums (J)).Key.Ent)

              and then Is_Alfa_Reference (Xrefs.Table (Rnums (J)).Key.Ent,

                                          Xrefs.Table (Rnums (J)).Key.Typ)

            then

               Nrefs         := Nrefs + 1;

               Rnums (Nrefs) := Rnums (J);

            end if;

         end loop;

      end Eliminate_Before_Sort;

      --  Sort the references

      Sorting.Sort (Integer (Nrefs));

      Eliminate_After_Sort : declare

         NR : Nat;

         Crloc : Source_Ptr;

         --  Current reference location

         Prevt : Character;

         --  reference kind of previous reference

      begin

         --  Eliminate duplicate entries

         --  We need this test for NR because if we force ALI file generation

         --  in case of errors detected, it may be the case that Nrefs is 0, so

         --  we should not reset it here

         if Nrefs >= 2 then

            NR    := Nrefs;

            Nrefs := 1;

            for J in 2 .. NR loop

               if Xrefs.Table (Rnums (J)) /=

                 Xrefs.Table (Rnums (Nrefs))

               then

                  Nrefs := Nrefs + 1;

                  Rnums (Nrefs) := Rnums (J);

               end if;

            end loop;

         end if;

         --  Eliminate the reference if it is at the same location as the

         --  previous one, unless it is a read-reference indicating that the

         --  entity is an in-out actual in a call.

         NR    := Nrefs;

         Nrefs := 0;

         Crloc := No_Location;

         Prevt := 'm';

         for J in 1 .. NR loop

            if Xrefs.Table (Rnums (J)).Key.Loc /= Crloc

              or else (Prevt = 'm'

                        and then Xrefs.Table (Rnums (J)).Key.Typ = 'r')

            then

               Crloc         := Xrefs.Table (Rnums (J)).Key.Loc;

               Prevt         := Xrefs.Table (Rnums (J)).Key.Typ;

               Nrefs         := Nrefs + 1;

               Rnums (Nrefs) := Rnums (J);

            end if;

         end loop;

      end Eliminate_After_Sort;

      --  Initialize loop

      Cur_Scope_Idx  := 1;

      From_Xref_Idx  := 1;

      Cur_Entity     := Empty;

      if Alfa_Scope_Table.Last = 0 then

         return;

      end if;

      --  Loop to output references

      for Refno in 1 .. Nrefs loop

         Add_One_Xref : declare

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

            -- Local Subprograms --

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

            function Cur_Scope return Node_Id;

            --  Return scope entity which corresponds to index Cur_Scope_Idx in

            --  table Alfa_Scope_Table.

            function Get_Entity_Type (E : Entity_Id) return Character;

            --  Return a character representing the type of entity

            function Is_Future_Scope_Entity (E : Entity_Id) return Boolean;

            --  Check whether entity E is in Alfa_Scope_Table at index

            --  Cur_Scope_Idx or higher.

            function Is_Past_Scope_Entity (E : Entity_Id) return Boolean;

            --  Check whether entity E is in Alfa_Scope_Table at index strictly

            --  lower than Cur_Scope_Idx.

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

            -- Cur_Scope --

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

            function Cur_Scope return Node_Id is

            begin

               return Alfa_Scope_Table.Table (Cur_Scope_Idx).Scope_Entity;

            end Cur_Scope;

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

            -- Get_Entity_Type --