File : asis-data_decomposition-aux.adb


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--          A S I S . D A T A _ D E C O M P O S I T I O N . A U X           --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--            Copyright (c) 1995-1999, Free Software Foundation, Inc.       --
--                                                                          --
-- ASIS-for-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 --
-- Software Foundation;  either version 2,  or  (at your option)  any later --
-- version. ASIS-for-GNAT is distributed  in the hope  that it will be use- --
-- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- --
-- CHANTABILITY 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 ASIS-for-GNAT; see file     --
-- COPYING. If not, write to the Free Software Foundation,  59 Temple Place --
-- - Suite 330,  Boston, MA 02111-1307, USA.                                --
--                                                                          --
-- As a special exception,  if other files  instantiate  generics from this --
-- unit, or you link  this unit with other files  to produce an executable, --
-- this  unit  does not  by itself cause  the resulting  executable  to  be --
-- covered  by the  GNU  General  Public  License.  This exception does not --
-- however invalidate  any other reasons why  the executable file  might be --
-- covered by the  GNU Public License.                                      --
--                                                                          --
-- ASIS-for-GNAT was originally developed  by the ASIS-for-GNAT team at the --
-- Software  Engineering  Laboratory  of  the Swiss  Federal  Institute  of --
-- Technology (LGL-EPFL) in Lausanne,  Switzerland, in cooperation with the --
-- Scientific  Research  Computer  Center of  Moscow State University (SRCC --
-- MSU), Russia,  with funding partially provided  by grants from the Swiss --
-- National  Science  Foundation  and  the  Swiss  Academy  of  Engineering --
-- Sciences.  ASIS-for-GNAT is now maintained by  Ada Core Technologies Inc --
-- (http://www.gnat.com).                                                   --
--                                                                          --
------------------------------------------------------------------------------

with Asis.Exceptions;   use Asis.Exceptions;
with Asis.Elements;     use Asis.Elements;
with Asis.Declarations; use Asis.Declarations;
with Asis.Definitions;  use Asis.Definitions;
with Asis.Expressions;  use Asis.Expressions;
with Asis.Extensions;   use Asis.Extensions;
with Asis.Iterator;     use Asis.Iterator;

with Asis.Set_Get;      use Asis.Set_Get;

with A4G.Int_Knds;      use A4G.Int_Knds;
with A4G.Vcheck;        use A4G.Vcheck;

with Atree;             use Atree;
with Sinfo;             use Sinfo;
with Einfo;             use Einfo;

package body Asis.Data_Decomposition.Aux is

   Package_Name : constant String := "Asis.Data_Decomposition.Aux.";

   ------------------------------------------
   -- Build_Discrim_List_If_Data_Presented --
   ------------------------------------------

   function Build_Discrim_List_If_Data_Presented
     (Rec  : Entity_Id;
      Data : Asis.Data_Decomposition.Portable_Data)
      return Discrim_List
   is
   begin
      if Data = Nil_Portable_Data then
         return Null_Discrims;
      else
         return Build_Discrim_List (Rec, Data);
      end if;

   end Build_Discrim_List_If_Data_Presented;

   -------------------------------
   -- Component_Type_Definition --
   -------------------------------

   function Component_Type_Definition (E : Element) return Element is
      Result : Element := Nil_Element;
   begin
      case Int_Kind (E) is
         when A_Component_Declaration =>
            Result := Object_Declaration_View (E);
            Result := Component_Subtype_Indication (Result);
         when A_Subtype_Indication =>
            Result := E;
         when others =>
            pragma Assert (False);
            null;
      end case;

      Result := Asis.Definitions.Subtype_Mark (Result);

      if Int_Kind (Result) = A_Selected_Component then
         Result := Selector (Result);
      end if;

      Result := Corresponding_Name_Declaration (Result);

      Result := Corresponding_First_Subtype (Result);

      Result := Type_Declaration_View (Result);

      return Result;

   end Component_Type_Definition;

   ---------------------------
   -- Constraint_Model_Kind --
   ---------------------------

   function Constraint_Model_Kind
     (C : Element)
      return Constraint_Model_Kinds
   is
      Arg_Kind : Internal_Element_Kinds := Int_Kind (C);

      Result   : Constraint_Model_Kinds := Static_Constraint;
      --  We start from the most optimistic assumption

      Control : Traverse_Control := Continue;

      procedure Analyze_Constraint
        (Element : in     Asis.Element;
         Control : in out Traverse_Control;
         State   : in out Constraint_Model_Kinds);
      --  Checks the individual constraint and its components. Used as
      --  Pre-Operation

      procedure No_Op
        (Element : in     Asis.Element;
         Control : in out Traverse_Control;
         State   : in out Constraint_Model_Kinds);
      --  Placeholder for Post-Operation

      procedure Traverse_Constraint is new Traverse_Element (
         State_Information => Constraint_Model_Kinds,
         Pre_Operation     => Analyze_Constraint,
         Post_Operation    => No_Op);

      ------------------------
      -- Analyze_Constraint --
      -------------------------

      procedure Analyze_Constraint
        (Element : in     Asis.Element;
         Control : in out Traverse_Control;
         State   : in out Constraint_Model_Kinds)
      is
         Arg_Kind : Internal_Element_Kinds := Int_Kind (Element);
      begin

         if Arg_Kind = An_Identifier
           and then
            Int_Kind (Enclosing_Element (Element)) =
               A_Discriminant_Association
           and then
            not Is_Equal (Element,
                          Discriminant_Expression
                            (Enclosing_Element (Element)))
         then
            --  If we are here, Element is from discriminant selector names
            return;
         end if;

         case Arg_Kind is

            when A_Discrete_Subtype_Indication =>

               if Is_Nil (Subtype_Constraint (Element)) then
                  --  Here we are VERY pessimistic: if in an index constraint
                  --  we have a type mark with no explicit range constraint;
                  --  we do not perform any analysis of this type mark,
                  --  but just consider, that we are in completely dinamic
                  --  situation
                  State   := External;
                  Control := Terminate_Immediately;
               end if;

            when A_Discrete_Range_Attribute_Reference =>
               --  Here we are also very pessimistic: we do not analyze the
               --  range bounds, but just consider, that we are in completely
               --  dinamic situation
               State   := External;
               Control := Terminate_Immediately;

            when Internal_Expression_Kinds =>
               if Is_True_Expression (Element) then

                  if Is_Static (Element) then
                     --  Nothing to do, no need to change State
                     Control := Abandon_Children;
                  else

                     if Arg_Kind = An_Identifier and then
                        Int_Kind (Corresponding_Name_Declaration (Element)) =
                           A_Discriminant_Specification
                     then
                        --  See RM 95 3.8(12)
                        State   := Discriminated;
                        Control := Abandon_Children;
                     else
                        --  Completely dinamic situation for sure
                        State   := External;
                        Control := Terminate_Immediately;
                     end if;

                  end if;

               else
                  --  The only possibility for those Elements which are in
                  --  Internal_Expression_Kinds, but are not
                  --  Is_True_Expression is a type mark, and we do not have to
                  --  analyze it
                  Control := Abandon_Children;
               end if;

            when An_Index_Constraint                |
                 A_Discriminant_Constraint          |
                 A_Discrete_Simple_Expression_Range |
                 A_Discriminant_Association         |
                 A_Simple_Expression_Range =>

               --  Just go down:
               null;

            when others =>
               pragma Assert (False);
               null;
         end case;

      end Analyze_Constraint;

      -----------
      -- No_Op --
      -----------

      procedure No_Op
        (Element : in     Asis.Element;
         Control : in out Traverse_Control;
         State   : in out Constraint_Model_Kinds)
      is
      begin
         null;
      end No_Op;

   begin

      if Arg_Kind = An_Index_Constraint or else
         Arg_Kind = A_Discriminant_Constraint
      then
         Traverse_Constraint
           (Element => C,
            Control => Control,
            State   => Result);
      end if;

      return Result;

   exception

      when ASIS_Inappropriate_Element | ASIS_Failed =>
         Add_Call_Information
           (Outer_Call => Package_Name & "Constraint_Model_Kind");
         raise;
      when others =>
         Raise_ASIS_Failed
           (Diagnosis => Package_Name & "Constraint_Model_Kind");

   end Constraint_Model_Kind;

   ---------------------
   -- De_Linear_Index --
   ---------------------

   function De_Linear_Index
     (Index       : Asis.ASIS_Natural;
      D           : ASIS_Natural;
      Ind_Lengths : Dimention_Length;
      Conv        : Convention_Id := Convention_Ada)
      return Dimension_Indexes
   is
      Len     : Asis.ASIS_Natural := 1;
      Tmp_Ind : Asis.ASIS_Natural := Index;
      Tmp_Res : Asis.ASIS_Natural;
      Result  : Dimension_Indexes (1 .. D);
   begin

      for J in 1 .. D loop
         Len := Len * Ind_Lengths (J);
      end loop;

      --  For the normal case, we are row major

      if Conv /= Convention_Fortran then

         for J in Result'Range loop
            Len := Len / Ind_Lengths (J);

            Tmp_Res := Tmp_Ind / Len;

            if Tmp_Res * Len < Tmp_Ind then
               Tmp_Res := Tmp_Res + 1;
            end if;

            Result (J) := Tmp_Res;

            Tmp_Ind := Tmp_Ind - Len * (Result (J) - 1);
         end loop;

      --  For Fortran, we are column major

      else

         for J in reverse Result'Range loop
            Len := Len / Ind_Lengths (J);

            Tmp_Res := Tmp_Ind / Len;

            if Tmp_Res * Len < Tmp_Ind then
               Tmp_Res := Tmp_Res + 1;
            end if;

            Result (J) := Tmp_Res;

            Tmp_Ind := Tmp_Ind - Len * (Result (J) - 1);
         end loop;

      end if;

      return Result;
   end De_Linear_Index;

   --------------------------------------------
   -- Discriminant_Part_From_Type_Definition --
   --------------------------------------------

   function Discriminant_Part_From_Type_Definition
     (T : Element)
      return Element
   is
      Type_Entity   : Node_Id;
      Tmp_Element   : Element;
      Result        : Element := Nil_Element;
   begin

      Type_Entity := R_Node (T);
      Type_Entity := Sinfo.Defining_Identifier (Parent (Type_Entity));

      if Einfo.Has_Discriminants (Type_Entity) then

         Result := Enclosing_Element (T);

         Result := Discriminant_Part (Result);

         if Is_Nil (Result) then
            --  Here we already know, that the type defined by T has
            --  discriminants. The only possibility is that it is derived
            --  from a type with known discriminant part. So we have to
            --  traverse backward the derivation chain and return the first
            --  known discriminant part found
            Tmp_Element := Corresponding_Parent_Subtype (T);
            Tmp_Element := Corresponding_First_Subtype (Tmp_Element);

            loop
               Result := Discriminant_Part (Tmp_Element);

               exit when not Is_Nil (Result);

               Tmp_Element := Type_Declaration_View (Tmp_Element);
               Tmp_Element := Corresponding_Parent_Subtype (Tmp_Element);
               Tmp_Element := Corresponding_First_Subtype (Tmp_Element);

            end loop;

         end if;

      end if;

      return Result;

   end Discriminant_Part_From_Type_Definition;

--   -----------------------------
--   -- Has_Static_Index_Ranges --
--   -----------------------------

--   function Has_Static_Index_Ranges (A : Element) return Boolean is
--      Result : Boolean := False;

--   begin
--      return Has_Static_Index_Ranges (A);
--   end Has_Static_Index_Ranges;

   --------------
   -- Is_Array --
   --------------

   function Is_Array (N : Element) return Boolean is
      Result   : Boolean := False;
      Arg_Node : Node_Id := Node (N);
   begin
      Arg_Node := Entity (Arg_Node);

      if Present (Arg_Node) then
         Result := Is_Array_Type (Arg_Node);
      end if;

      return Result;
   end Is_Array;

   ----------------------------
   -- Is_Derived_From_Record --
   ----------------------------

   function Is_Derived_From_Record (TD : Element) return Boolean is
      Result           : Boolean := False;
      Type_Entity_Node : Node_Id;
   begin

      if Int_Kind (TD) = A_Derived_Type_Definition then
         Type_Entity_Node := R_Node (TD);
         Type_Entity_Node := Defining_Identifier (Parent (Type_Entity_Node));
         Result := Is_Record_Type (Type_Entity_Node);
      end if;

      return Result;
   end Is_Derived_From_Record;

   ---------------------------
   -- Is_Derived_From_Array --
   ---------------------------

   function Is_Derived_From_Array (TD : Element) return Boolean is
      Result           : Boolean := False;
      Type_Entity_Node : Node_Id;
   begin

      if Int_Kind (TD) = A_Derived_Type_Definition then
         Type_Entity_Node := R_Node (TD);
         Type_Entity_Node := Defining_Identifier (Parent (Type_Entity_Node));
         Result := Is_Array_Type (Type_Entity_Node);
      end if;

      return Result;
   end Is_Derived_From_Array;

   ---------------
   -- Is_Record --
   ---------------

   function Is_Record (N : Element) return Boolean is
      Result   : Boolean := False;
      Arg_Node : Node_Id := Node (N);
   begin
      Arg_Node := Entity (Arg_Node);

      if Present (Arg_Node) then
         Result := Is_Record_Type (Arg_Node);
      end if;

      return Result;
   end Is_Record;

   ------------------
   -- Linear_Index --
   ------------------

   function Linear_Index
     (Inds        : Dimension_Indexes;
      D           : ASIS_Natural;
      Ind_Lengths : Dimention_Length;
      Conv        : Convention_Id := Convention_Ada)
      return Asis.ASIS_Natural
   is
      Indx : Asis.ASIS_Natural := 0;
   begin
      --  For the normal case, we are row major

      if Conv /= Convention_Fortran then
         for J in Inds'Range loop
            Indx := Indx * Ind_Lengths (J) + Inds (J) - 1;
         end loop;

      --  For Fortran, we are column major

      else
         for J in reverse Inds'Range loop
            Indx := Indx * Ind_Lengths (J) + Inds (J) - 1;
         end loop;
      end if;

      return Indx + 1;
   end Linear_Index;

   -------------
   -- Max_Len --
   -------------

   function Max_Len (Component : Array_Component) return Asis.ASIS_Natural is
      Result : Asis.ASIS_Natural := 1;
   begin
      --  ??? Empty array are not taken into account!!!
      for J in Component.Length'Range loop
         exit when Component.Length (J) = 0;
         Result := Result * Component.Length (J);
      end loop;

      return Result;

   end Max_Len;

   -----------------------
   -- Record_Model_Kind --
   -----------------------

   function Record_Model_Kind (R : Element) return Type_Model_Kinds is
      Type_Entity : Node_Id;
      Result      : Type_Model_Kinds := Not_A_Type_Model;

      Control : Traverse_Control := Continue;

      procedure Analyze_Component_Definition
        (Element : in     Asis.Element;
         Control : in out Traverse_Control;
         State   : in out Type_Model_Kinds);
      --  Checks the individual component definition. Used as Pre-Operation.

      procedure No_Op
        (Element : in     Asis.Element;
         Control : in out Traverse_Control;
         State   : in out Type_Model_Kinds);
      --  Placeholder for Post-Operation

      procedure Traverse_Record_Definition is new Traverse_Element (
         State_Information => Type_Model_Kinds,
         Pre_Operation     => Analyze_Component_Definition,
         Post_Operation    => No_Op);

      ----------------------------------
      -- Analyze_Component_Definition --
      ----------------------------------

      procedure Analyze_Component_Definition
        (Element : in     Asis.Element;
         Control : in out Traverse_Control;
         State   : in out Type_Model_Kinds)
      is
      begin

         if Int_Kind (Element) = A_Component_Declaration then

            case Subtype_Model_Kind
                   (Component_Subtype_Indication
                      (Object_Declaration_View (Element)))
            is

               when A_Simple_Static_Model | A_Simple_Dynamic_Model =>
                  Control := Abandon_Children;

               when A_Complex_Dynamic_Model =>
                  Result  := A_Complex_Dynamic_Model;
                  Control := Terminate_Immediately;

               when Not_A_Type_Model =>
                  Result  := Not_A_Type_Model;
                  Control := Terminate_Immediately;

            end case;

         end if;

      end Analyze_Component_Definition;

      -----------
      -- No_Op --
      -----------

      procedure No_Op
        (Element : in     Asis.Element;
         Control : in out Traverse_Control;
         State   : in out Type_Model_Kinds)
      is
      begin
         null;
      end No_Op;

   begin
      Type_Entity := R_Node (Enclosing_Element (R));
      Type_Entity := Sinfo.Defining_Identifier (Type_Entity);

      if Size_Known_At_Compile_Time (Type_Entity) then
         Result := A_Simple_Static_Model;
      else
         --  We start from the most optimistic assumption
         Result := A_Simple_Dynamic_Model;

         Traverse_Record_Definition
           (Element => R,
            Control => Control,
            State   => Result);

      end if;

      return Result;
   end Record_Model_Kind;

   ---------------------------
   -- Root_Array_Definition --
   ---------------------------

   function Root_Array_Definition  (Type_Def : Element) return Element is
      Result : Element := Type_Def;
   begin

      if Is_Derived_From_Array (Type_Def) then
         Result := Corresponding_Root_Type (Type_Def);
         Result := Type_Declaration_View (Result);
      end if;

      return Result;

   end Root_Array_Definition;

   ----------------------------
   -- Root_Record_Definition --
   ----------------------------

   function Root_Record_Definition (Type_Def : Element) return Element is
      Result : Element := Type_Def;
   begin

      if Is_Derived_From_Record (Type_Def) then
         Result := Corresponding_Root_Type (Type_Def);
         Result := Type_Declaration_View (Result);
      end if;

      return Result;

   end Root_Record_Definition;

   ------------------------
   -- Subtype_Model_Kind --
   ------------------------

   function Subtype_Model_Kind (S : Element) return Type_Model_Kinds is
      Result         : Type_Model_Kinds := Not_A_Type_Model;

      Type_Mark_Elem : Element;
      Type_Mark_Def  : Element;
      Constr_Elem    : Element;

      Constraint_Model : Constraint_Model_Kinds := Not_A_Constraint_Model;

   begin

      pragma Assert (Int_Kind (S) = A_Subtype_Indication);

      Type_Mark_Elem := Asis.Definitions.Subtype_Mark (S);
      Constr_Elem    := Subtype_Constraint (S);

      if Int_Kind (Type_Mark_Elem) = A_Selected_Component then
         Type_Mark_Elem := Selector (Type_Mark_Elem);
      end if;

      Type_Mark_Def := Corresponding_Name_Declaration (Type_Mark_Elem);

      --  Type_Mark_Def can only be either type or subtype declaration

      Type_Mark_Def := Type_Declaration_View (Type_Mark_Def);

      case Int_Kind (Type_Mark_Def) is
         when Internal_Type_Kinds =>
            Result := Type_Model_Kind (Type_Mark_Def);

         when A_Subtype_Indication =>
            Result := Subtype_Model_Kind (Type_Mark_Def);

         when others =>
            Result := A_Complex_Dynamic_Model;
      end case;

      if Result in A_Simple_Static_Model .. A_Simple_Dynamic_Model then
         --  Here we have to chech if the constraint (if any) affects the
         --  result
         case Int_Kind (Constr_Elem) is

            when An_Index_Constraint |
                 A_Discriminant_Constraint =>
               Constraint_Model := Constraint_Model_Kind (Constr_Elem);

            when others =>
               --  We consider, that other kinds of the constraint can not
               --  affect the result
               null;
         end case;

         case Constraint_Model is
            when External =>
               Result := A_Complex_Dynamic_Model;

            when Discriminated =>
               Result := A_Simple_Dynamic_Model;

            when others =>
               null;
         end case;

      end if;

      return Result;

   exception

      when ASIS_Inappropriate_Element | ASIS_Failed =>

         Add_Call_Information
           (Outer_Call => Package_Name & "Subtype_Model_Kind");

         raise;

      when others =>
         Raise_ASIS_Failed
           (Diagnosis => Package_Name & "Subtype_Model_Kind");

   end Subtype_Model_Kind;

   ---------------------------------------
   -- Type_Definition_From_Subtype_Mark --
   ---------------------------------------

   function Type_Definition_From_Subtype_Mark (S : Element) return Element is
      Result : Element;
   begin

      if Int_Kind (S) = A_Selected_Component then
         Result := Selector (S);
      else
         Result := S;
      end if;

      Result := Corresponding_Name_Declaration (Result);
      Result := Corresponding_First_Subtype    (Result);
      Result := Type_Declaration_View          (Result);

      return Result;

   exception
      when ASIS_Inappropriate_Element | ASIS_Failed =>

         Add_Call_Information
           (Outer_Call => Package_Name & "Type_Definition_From_Subtype_Mark");

         raise;

      when others =>
         Raise_ASIS_Failed
           (Diagnosis => Package_Name & "Type_Definition_From_Subtype_Mark");

   end Type_Definition_From_Subtype_Mark;

   -------------------
   -- Wrong_Indexes --
   -------------------

   function Wrong_Indexes
     (Component : Array_Component;
      Indexes   : Dimension_Indexes)
      return Boolean
   is
      D      : ASIS_Natural := Component.Dimension;
      Result : Boolean := True;
   begin

      if D = Indexes'Length then
         Result := False;

         for J in 1 .. D loop
            if Indexes (J) > Component.Length (J) then
               Result := True;
               exit;
            end if;
         end loop;
      end if;

      return Result;
   end Wrong_Indexes;

end Asis.Data_Decomposition.Aux