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