OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [lib-xref-alfa.adb] - Rev 706

Compare with Previous | Blame | View Log

------------------------------------------------------------------------------
--                                                                          --
--                         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 --
            ---------------------
 
            function Get_Entity_Type (E : Entity_Id) return Character is
               C : Character;
            begin
               case Ekind (E) is
                  when E_Out_Parameter    => C := '<';
                  when E_In_Out_Parameter => C := '=';
                  when E_In_Parameter     => C := '>';
                  when others             => C := '*';
               end case;
               return C;
            end Get_Entity_Type;
 
            ----------------------------
            -- Is_Future_Scope_Entity --
            ----------------------------
 
            function Is_Future_Scope_Entity (E : Entity_Id) return Boolean is
            begin
               for J in Cur_Scope_Idx .. Alfa_Scope_Table.Last loop
                  if E = Alfa_Scope_Table.Table (J).Scope_Entity then
                     return True;
                  end if;
               end loop;
 
               --  If this assertion fails, this means that the scope which we
               --  are looking for has been treated already, which reveals a
               --  problem in the order of cross-references.
 
               pragma Assert (not Is_Past_Scope_Entity (E));
 
               return False;
            end Is_Future_Scope_Entity;
 
            --------------------------
            -- Is_Past_Scope_Entity --
            --------------------------
 
            function Is_Past_Scope_Entity (E : Entity_Id) return Boolean is
            begin
               for J in Alfa_Scope_Table.First .. Cur_Scope_Idx - 1 loop
                  if E = Alfa_Scope_Table.Table (J).Scope_Entity then
                     return True;
                  end if;
               end loop;
 
               return False;
            end Is_Past_Scope_Entity;
 
            ---------------------
            -- Local Variables --
            ---------------------
 
            XE  : Xref_Entry renames Xrefs.Table (Rnums (Refno));
 
         begin
            --  If this assertion fails, the scope which we are looking for is
            --  not in Alfa scope table, which reveals either a problem in the
            --  construction of the scope table, or an erroneous scope for the
            --  current cross-reference.
 
            pragma Assert (Is_Future_Scope_Entity (XE.Key.Ent_Scope));
 
            --  Update the range of cross references to which the current scope
            --  refers to. This may be the empty range only for the first scope
            --  considered.
 
            if XE.Key.Ent_Scope /= Cur_Scope then
               Alfa_Scope_Table.Table (Cur_Scope_Idx).From_Xref :=
                 From_Xref_Idx;
               Alfa_Scope_Table.Table (Cur_Scope_Idx).To_Xref :=
                 Alfa_Xref_Table.Last;
               From_Xref_Idx := Alfa_Xref_Table.Last + 1;
            end if;
 
            while XE.Key.Ent_Scope /= Cur_Scope loop
               Cur_Scope_Idx := Cur_Scope_Idx + 1;
               pragma Assert (Cur_Scope_Idx <= Alfa_Scope_Table.Last);
            end loop;
 
            if XE.Key.Ent /= Cur_Entity then
               Cur_Entity_Name :=
                 new String'(Unique_Name (XE.Key.Ent));
            end if;
 
            if XE.Key.Ent = Heap then
               Alfa_Xref_Table.Append (
                 (Entity_Name => Cur_Entity_Name,
                  Entity_Line => 0,
                  Etype       => Get_Entity_Type (XE.Key.Ent),
                  Entity_Col  => 0,
                  File_Num    => Dependency_Num (XE.Key.Lun),
                  Scope_Num   => Get_Scope_Num (XE.Key.Ref_Scope),
                  Line        => Int (Get_Logical_Line_Number (XE.Key.Loc)),
                  Rtype       => XE.Key.Typ,
                  Col         => Int (Get_Column_Number (XE.Key.Loc))));
 
            else
               Alfa_Xref_Table.Append (
                 (Entity_Name => Cur_Entity_Name,
                  Entity_Line => Int (Get_Logical_Line_Number (XE.Def)),
                  Etype       => Get_Entity_Type (XE.Key.Ent),
                  Entity_Col  => Int (Get_Column_Number (XE.Def)),
                  File_Num    => Dependency_Num (XE.Key.Lun),
                  Scope_Num   => Get_Scope_Num (XE.Key.Ref_Scope),
                  Line        => Int (Get_Logical_Line_Number (XE.Key.Loc)),
                  Rtype       => XE.Key.Typ,
                  Col         => Int (Get_Column_Number (XE.Key.Loc))));
            end if;
         end Add_One_Xref;
      end loop;
 
      --  Update the range of cross references to which the scope refers to
 
      Alfa_Scope_Table.Table (Cur_Scope_Idx).From_Xref := From_Xref_Idx;
      Alfa_Scope_Table.Table (Cur_Scope_Idx).To_Xref   := Alfa_Xref_Table.Last;
   end Add_Alfa_Xrefs;
 
   ------------------
   -- Collect_Alfa --
   ------------------
 
   procedure Collect_Alfa (Sdep_Table : Unit_Ref_Table; Num_Sdep : Nat) is
   begin
      --  Cross-references should have been computed first
 
      pragma Assert (Xrefs.Last /= 0);
 
      Initialize_Alfa_Tables;
 
      --  Generate file and scope Alfa information
 
      for D in 1 .. Num_Sdep loop
         Add_Alfa_File (U => Sdep_Table (D), D => D);
      end loop;
 
      --  Fill in the spec information when relevant
 
      declare
         package Entity_Hash_Table is new
           GNAT.HTable.Simple_HTable
             (Header_Num => Entity_Hashed_Range,
              Element    => Scope_Index,
              No_Element => 0,
              Key        => Entity_Id,
              Hash       => Entity_Hash,
              Equal      => "=");
 
      begin
         --  Fill in the hash-table
 
         for S in Alfa_Scope_Table.First .. Alfa_Scope_Table.Last loop
            declare
               Srec : Alfa_Scope_Record renames Alfa_Scope_Table.Table (S);
            begin
               Entity_Hash_Table.Set (Srec.Scope_Entity, S);
            end;
         end loop;
 
         --  Use the hash-table to locate spec entities
 
         for S in Alfa_Scope_Table.First .. Alfa_Scope_Table.Last loop
            declare
               Srec : Alfa_Scope_Record renames Alfa_Scope_Table.Table (S);
 
               Spec_Entity : constant Entity_Id :=
                               Unique_Entity (Srec.Scope_Entity);
               Spec_Scope  : constant Scope_Index :=
                               Entity_Hash_Table.Get (Spec_Entity);
 
            begin
               --  Spec of generic may be missing, in which case Spec_Scope is
               --  zero.
 
               if Spec_Entity /= Srec.Scope_Entity
                 and then Spec_Scope /= 0
               then
                  Srec.Spec_File_Num :=
                    Alfa_Scope_Table.Table (Spec_Scope).File_Num;
                  Srec.Spec_Scope_Num :=
                    Alfa_Scope_Table.Table (Spec_Scope).Scope_Num;
               end if;
            end;
         end loop;
      end;
 
      --  Generate cross reference Alfa information
 
      Add_Alfa_Xrefs;
   end Collect_Alfa;
 
   -------------------------------
   -- Detect_And_Add_Alfa_Scope --
   -------------------------------
 
   procedure Detect_And_Add_Alfa_Scope (N : Node_Id) is
   begin
      if Nkind_In (N, N_Subprogram_Declaration,
                      N_Subprogram_Body,
                      N_Subprogram_Body_Stub,
                      N_Package_Declaration,
                      N_Package_Body)
      then
         Add_Alfa_Scope (N);
      end if;
   end Detect_And_Add_Alfa_Scope;
 
   -------------------------------------
   -- Enclosing_Subprogram_Or_Package --
   -------------------------------------
 
   function Enclosing_Subprogram_Or_Package (N : Node_Id) return Entity_Id is
      Result : Entity_Id;
 
   begin
      --  If N is the defining identifier for a subprogram, then return the
      --  enclosing subprogram or package, not this subprogram.
 
      if Nkind_In (N, N_Defining_Identifier, N_Defining_Operator_Symbol)
        and then Nkind (Parent (N)) in N_Subprogram_Specification
      then
         Result := Parent (Parent (Parent (N)));
      else
         Result := N;
      end if;
 
      loop
         exit when No (Result);
 
         case Nkind (Result) is
            when N_Package_Specification =>
               Result := Defining_Unit_Name (Result);
               exit;
 
            when N_Package_Body =>
               Result := Defining_Unit_Name (Result);
               exit;
 
            when N_Subprogram_Specification =>
               Result := Defining_Unit_Name (Result);
               exit;
 
            when N_Subprogram_Declaration =>
               Result := Defining_Unit_Name (Specification (Result));
               exit;
 
            when N_Subprogram_Body =>
               Result := Defining_Unit_Name (Specification (Result));
               exit;
 
            --  The enclosing subprogram for a pre- or postconditions should be
            --  the subprogram to which the pragma is attached. This is not
            --  always the case in the AST, as the pragma may be declared after
            --  the declaration of the subprogram. Return Empty in this case.
 
            when N_Pragma =>
               if Get_Pragma_Id (Result) = Pragma_Precondition
                    or else
                  Get_Pragma_Id (Result) = Pragma_Postcondition
               then
                  return Empty;
               else
                  Result := Parent (Result);
               end if;
 
            when others =>
               Result := Parent (Result);
         end case;
      end loop;
 
      if Nkind (Result) = N_Defining_Program_Unit_Name then
         Result := Defining_Identifier (Result);
      end if;
 
      --  Do no return a scope without a proper location
 
      if Present (Result)
        and then Sloc (Result) = No_Location
      then
         return Empty;
      end if;
 
      return Result;
   end Enclosing_Subprogram_Or_Package;
 
   -----------------
   -- Entity_Hash --
   -----------------
 
   function Entity_Hash (E : Entity_Id) return Entity_Hashed_Range is
   begin
      return
        Entity_Hashed_Range (E mod (Entity_Id (Entity_Hashed_Range'Last) + 1));
   end Entity_Hash;
 
   --------------------------
   -- Generate_Dereference --
   --------------------------
 
   procedure Generate_Dereference
     (N   : Node_Id;
      Typ : Character := 'r')
   is
      Indx      : Nat;
      Ref       : Source_Ptr;
      Ref_Scope : Entity_Id;
 
   begin
      Ref := Original_Location (Sloc (N));
 
      if Ref > No_Location then
         Drefs.Increment_Last;
         Indx := Drefs.Last;
 
         Ref_Scope := Enclosing_Subprogram_Or_Package (N);
 
         --  Entity is filled later on with the special "Heap" variable
 
         Drefs.Table (Indx).Key.Ent := Empty;
 
         Drefs.Table (Indx).Def := No_Location;
         Drefs.Table (Indx).Key.Loc := Ref;
         Drefs.Table (Indx).Key.Typ := Typ;
 
         --  It is as if the special "Heap" was defined in every scope where it
         --  is referenced.
 
         Drefs.Table (Indx).Key.Eun := Get_Source_Unit (Ref);
         Drefs.Table (Indx).Key.Lun := Get_Source_Unit (Ref);
 
         Drefs.Table (Indx).Key.Ref_Scope := Ref_Scope;
         Drefs.Table (Indx).Key.Ent_Scope := Ref_Scope;
         Drefs.Table (Indx).Ent_Scope_File := Get_Source_Unit (Ref_Scope);
      end if;
   end Generate_Dereference;
 
   ------------------------------------
   -- Traverse_All_Compilation_Units --
   ------------------------------------
 
   procedure Traverse_All_Compilation_Units (Process : Node_Processing) is
   begin
      for U in Units.First .. Last_Unit loop
         Traverse_Compilation_Unit (Cunit (U), Process, Inside_Stubs => False);
      end loop;
   end Traverse_All_Compilation_Units;
 
   -------------------------------
   -- Traverse_Compilation_Unit --
   -------------------------------
 
   procedure Traverse_Compilation_Unit
     (CU           : Node_Id;
      Process      : Node_Processing;
      Inside_Stubs : Boolean)
   is
      Lu : Node_Id;
 
   begin
      --  Get Unit (checking case of subunit)
 
      Lu := Unit (CU);
 
      if Nkind (Lu) = N_Subunit then
         Lu := Proper_Body (Lu);
      end if;
 
      --  Call Process on all declarations
 
      if Nkind (Lu) in N_Declaration
        or else Nkind (Lu) in N_Later_Decl_Item
      then
         Process (Lu);
      end if;
 
      --  Traverse the unit
 
      if Nkind (Lu) = N_Subprogram_Body then
         Traverse_Subprogram_Body (Lu, Process, Inside_Stubs);
 
      elsif Nkind (Lu) = N_Subprogram_Declaration then
         null;
 
      elsif Nkind (Lu) = N_Package_Declaration then
         Traverse_Package_Declaration (Lu, Process, Inside_Stubs);
 
      elsif Nkind (Lu) = N_Package_Body then
         Traverse_Package_Body (Lu, Process, Inside_Stubs);
 
      --  ??? TBD
 
      elsif Nkind (Lu) = N_Generic_Package_Declaration then
         null;
 
      --  ??? TBD
 
      elsif Nkind (Lu) in N_Generic_Instantiation then
         null;
 
      --  All other cases of compilation units (e.g. renamings), are not
      --  declarations.
 
      else
         null;
      end if;
   end Traverse_Compilation_Unit;
 
   -----------------------------------------
   -- Traverse_Declarations_Or_Statements --
   -----------------------------------------
 
   procedure Traverse_Declarations_Or_Statements
     (L            : List_Id;
      Process      : Node_Processing;
      Inside_Stubs : Boolean)
   is
      N : Node_Id;
 
   begin
      --  Loop through statements or declarations
 
      N := First (L);
      while Present (N) loop
         --  Call Process on all declarations
 
         if Nkind (N) in N_Declaration
              or else
            Nkind (N) in N_Later_Decl_Item
         then
            Process (N);
         end if;
 
         case Nkind (N) is
 
            --  Package declaration
 
            when N_Package_Declaration =>
               Traverse_Package_Declaration (N, Process, Inside_Stubs);
 
            --  Generic package declaration ??? TBD
 
            when N_Generic_Package_Declaration =>
               null;
 
            --  Package body
 
            when N_Package_Body =>
               if Ekind (Defining_Entity (N)) /= E_Generic_Package then
                  Traverse_Package_Body (N, Process, Inside_Stubs);
               end if;
 
            when N_Package_Body_Stub =>
               if Present (Library_Unit (N)) then
                  declare
                     Body_N : constant Node_Id := Get_Body_From_Stub (N);
                  begin
                     if Inside_Stubs
                       and then
                         Ekind (Defining_Entity (Body_N)) /= E_Generic_Package
                     then
                        Traverse_Package_Body (Body_N, Process, Inside_Stubs);
                     end if;
                  end;
               end if;
 
            --  Subprogram declaration
 
            when N_Subprogram_Declaration =>
               null;
 
            --  Generic subprogram declaration ??? TBD
 
            when N_Generic_Subprogram_Declaration =>
               null;
 
            --  Subprogram body
 
            when N_Subprogram_Body =>
               if not Is_Generic_Subprogram (Defining_Entity (N)) then
                  Traverse_Subprogram_Body (N, Process, Inside_Stubs);
               end if;
 
            when N_Subprogram_Body_Stub =>
               if Present (Library_Unit (N)) then
                  declare
                     Body_N : constant Node_Id := Get_Body_From_Stub (N);
                  begin
                     if Inside_Stubs
                       and then
                         not Is_Generic_Subprogram (Defining_Entity (Body_N))
                     then
                        Traverse_Subprogram_Body
                          (Body_N, Process, Inside_Stubs);
                     end if;
                  end;
               end if;
 
            --  Block statement
 
            when N_Block_Statement =>
               Traverse_Declarations_Or_Statements
                 (Declarations (N), Process, Inside_Stubs);
               Traverse_Handled_Statement_Sequence
                 (Handled_Statement_Sequence (N), Process, Inside_Stubs);
 
            when N_If_Statement =>
 
               --  Traverse the statements in the THEN part
 
               Traverse_Declarations_Or_Statements
                 (Then_Statements (N), Process, Inside_Stubs);
 
               --  Loop through ELSIF parts if present
 
               if Present (Elsif_Parts (N)) then
                  declare
                     Elif : Node_Id := First (Elsif_Parts (N));
 
                  begin
                     while Present (Elif) loop
                        Traverse_Declarations_Or_Statements
                          (Then_Statements (Elif), Process, Inside_Stubs);
                        Next (Elif);
                     end loop;
                  end;
               end if;
 
               --  Finally traverse the ELSE statements if present
 
               Traverse_Declarations_Or_Statements
                 (Else_Statements (N), Process, Inside_Stubs);
 
            --  Case statement
 
            when N_Case_Statement =>
 
               --  Process case branches
 
               declare
                  Alt : Node_Id;
               begin
                  Alt := First (Alternatives (N));
                  while Present (Alt) loop
                     Traverse_Declarations_Or_Statements
                       (Statements (Alt), Process, Inside_Stubs);
                     Next (Alt);
                  end loop;
               end;
 
            --  Extended return statement
 
            when N_Extended_Return_Statement =>
               Traverse_Handled_Statement_Sequence
                 (Handled_Statement_Sequence (N), Process, Inside_Stubs);
 
            --  Loop
 
            when N_Loop_Statement =>
               Traverse_Declarations_Or_Statements
                 (Statements (N), Process, Inside_Stubs);
 
            when others =>
               null;
         end case;
 
         Next (N);
      end loop;
   end Traverse_Declarations_Or_Statements;
 
   -----------------------------------------
   -- Traverse_Handled_Statement_Sequence --
   -----------------------------------------
 
   procedure Traverse_Handled_Statement_Sequence
     (N            : Node_Id;
      Process      : Node_Processing;
      Inside_Stubs : Boolean)
   is
      Handler : Node_Id;
 
   begin
      if Present (N) then
         Traverse_Declarations_Or_Statements
           (Statements (N), Process, Inside_Stubs);
 
         if Present (Exception_Handlers (N)) then
            Handler := First (Exception_Handlers (N));
            while Present (Handler) loop
               Traverse_Declarations_Or_Statements
                 (Statements (Handler), Process, Inside_Stubs);
               Next (Handler);
            end loop;
         end if;
      end if;
   end Traverse_Handled_Statement_Sequence;
 
   ---------------------------
   -- Traverse_Package_Body --
   ---------------------------
 
   procedure Traverse_Package_Body
     (N            : Node_Id;
      Process      : Node_Processing;
      Inside_Stubs : Boolean) is
   begin
      Traverse_Declarations_Or_Statements
        (Declarations (N), Process, Inside_Stubs);
      Traverse_Handled_Statement_Sequence
        (Handled_Statement_Sequence (N), Process, Inside_Stubs);
   end Traverse_Package_Body;
 
   ----------------------------------
   -- Traverse_Package_Declaration --
   ----------------------------------
 
   procedure Traverse_Package_Declaration
     (N            : Node_Id;
      Process      : Node_Processing;
      Inside_Stubs : Boolean)
   is
      Spec : constant Node_Id := Specification (N);
   begin
      Traverse_Declarations_Or_Statements
        (Visible_Declarations (Spec), Process, Inside_Stubs);
      Traverse_Declarations_Or_Statements
        (Private_Declarations (Spec), Process, Inside_Stubs);
   end Traverse_Package_Declaration;
 
   ------------------------------
   -- Traverse_Subprogram_Body --
   ------------------------------
 
   procedure Traverse_Subprogram_Body
     (N            : Node_Id;
      Process      : Node_Processing;
      Inside_Stubs : Boolean) is
   begin
      Traverse_Declarations_Or_Statements
        (Declarations (N), Process, Inside_Stubs);
      Traverse_Handled_Statement_Sequence
        (Handled_Statement_Sequence (N), Process, Inside_Stubs);
   end Traverse_Subprogram_Body;
 
end Alfa;
 

Compare with Previous | Blame | View Log

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.