File : asis-data_decomposition.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 --
-- --
-- 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 System; use System;
with Ada.Unchecked_Conversion;
with Asis.Exceptions; use Asis.Exceptions;
with Asis.Errors; use Asis.Errors;
with Asis.Elements; use Asis.Elements;
with Asis.Definitions; use Asis.Definitions;
with Asis.Declarations; use Asis.Declarations;
with Asis.Set_Get; use Asis.Set_Get;
with Asis.Data_Decomposition.Set_Get; use Asis.Data_Decomposition.Set_Get;
with Asis.Data_Decomposition.Aux; use Asis.Data_Decomposition.Aux;
with Asis.Data_Decomposition.Vcheck; use Asis.Data_Decomposition.Vcheck;
with A4G.Int_Knds; use A4G.Int_Knds;
with A4G.Vcheck; use A4G.Vcheck;
with A4G.DDA_Aux; use A4G.DDA_Aux;
with Atree; use Atree;
with Sinfo; use Sinfo;
with Einfo; use Einfo;
with Uintp; use Uintp;
package body Asis.Data_Decomposition is
Package_Name : constant String := "Asis.Data_Decomposition.";
Nil_Dimension_Indexes : Dimension_Indexes (1 .. 0);
--------------------------
-- All_Named_Components --
--------------------------
function All_Named_Components
(Type_Definition : in Asis.Type_Definition)
return Asis.Defining_Name_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Type_Definition);
Discr_Part : Element;
Root_Type : Element;
begin
Check_Validity
(Type_Definition, Package_Name & "All_Named_Components");
if not (Arg_Kind = A_Record_Type_Definition or else
Is_Derived_From_Record (Type_Definition))
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => Package_Name & "All_Named_Components");
end if;
Discr_Part := Discriminant_Part_From_Type_Definition (Type_Definition);
Root_Type := Root_Record_Definition (Type_Definition);
Set_Named_Components (Discr_Part, New_List);
Set_Named_Components (Root_Type, Append);
return Asis.Defining_Name_List (
Def_N_Table (1 .. Asis_Element_Table.Last));
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Type_Definition,
Outer_Call => Package_Name & "All_Named_Components");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Type_Definition,
Diagnosis => Package_Name & "All_Named_Components");
end All_Named_Components;
---------------------------------------------
-- Array_Components (from Array_Component) --
---------------------------------------------
function Array_Components
(Component : in Array_Component)
return Array_Component
is
Arg_Type_Model_Kind : Type_Model_Kinds :=
Type_Model_Kind (Component);
Res_Type_Definition : Element;
Comp_Ind : Element;
begin
Check_Validity
(Component,
Package_Name & "Array_Components (from Array_Component)");
if not Is_Array (Component) and then
Arg_Type_Model_Kind = A_Simple_Static_Model
-- or else Arg_Type_Model_Kind = A_Simple_Dynamic_Model))
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => Package_Name &
"Array_Components (from Array_Component)");
end if;
-- In the current implementation, we can extract array components
-- only from array components of A_Simple_Static_Model.
Comp_Ind := Component_Indication (Component);
Res_Type_Definition := Component_Type_Definition (Comp_Ind);
pragma Assert (
Int_Kind (Res_Type_Definition) = An_Unconstrained_Array_Definition
or else
Int_Kind (Res_Type_Definition) = A_Constrained_Array_Definition
or else
Is_Derived_From_Array (Res_Type_Definition));
return Set_Array_Componnet
(Array_Type_Definition => Res_Type_Definition,
Enclosing_Record_Component => Nil_Record_Component,
Parent_Indication => Comp_Ind,
Parent_First_Bit_Offset => 0);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Outer_Call => Package_Name &
"Array_Components (from Array_Component)");
raise;
when others =>
Raise_ASIS_Failed (
Diagnosis => Package_Name &
"Array_Components (from Array_Component)");
end Array_Components;
----------------------------------------------
-- Array_Components (from Record_Component) --
----------------------------------------------
function Array_Components
(Component : in Record_Component)
return Array_Component
is
Arg_Type_Model_Kind : Type_Model_Kinds :=
Type_Model_Kind (Component);
Res_Type_Definition : Element;
begin
Check_Validity
(Component,
Package_Name & "Array_Components (from Record_Component)");
if not (Is_Array (Component) and then
(Arg_Type_Model_Kind = A_Simple_Static_Model or else
Arg_Type_Model_Kind = A_Simple_Dynamic_Model))
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => Package_Name &
"Array_Components (from Record_Component)");
end if;
Res_Type_Definition := Component_Declaration (Component);
Res_Type_Definition := Component_Type_Definition (Res_Type_Definition);
return Set_Array_Componnet
(Array_Type_Definition => Res_Type_Definition,
Enclosing_Record_Component => Component,
Parent_Indication => Nil_Element,
Parent_Discriminants => Parent_Discrims (Component),
Parent_First_Bit_Offset => Component.First_Bit_Offset);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Outer_Call => Package_Name &
"Array_Components (from Record_Component)");
raise;
when others =>
Raise_ASIS_Failed (
Diagnosis => Package_Name &
"Array_Components (from Record_Component)");
end Array_Components;
---------------------------------------------
-- Array_Components (from Type_Definition) --
---------------------------------------------
function Array_Components
(Type_Definition : in Asis.Type_Definition)
return Array_Component
is
Arg_Kind : Internal_Element_Kinds :=
Int_Kind (Type_Definition);
Arg_Type_Model_Kind : Type_Model_Kinds :=
Type_Model_Kind (Type_Definition);
begin
Check_Validity
(Type_Definition,
Package_Name & "Array_Components (from Type_Definition)");
if not ((Arg_Kind = An_Unconstrained_Array_Definition or else
Arg_Kind = A_Constrained_Array_Definition or else
Is_Derived_From_Array (Type_Definition))
and then
(Arg_Type_Model_Kind = A_Simple_Static_Model or else
Arg_Type_Model_Kind = A_Simple_Dynamic_Model))
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => Package_Name &
"Array_Components (from Type_Definition)");
end if;
return Set_Array_Componnet
(Array_Type_Definition => Type_Definition,
Enclosing_Record_Component => Nil_Record_Component,
Parent_Indication => Nil_Element,
Parent_First_Bit_Offset => 0);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Type_Definition,
Outer_Call => Package_Name &
"Array_Components (from Type_Definition)");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Type_Definition,
Diagnosis => Package_Name &
"Array_Components (from Type_Definition)");
end Array_Components;
------------------------------
-- Array_Index (linearized) --
------------------------------
function Array_Index
(Iterator : in Array_Component_Iterator)
return Asis.ASIS_Natural
is
begin
if Is_Nil (Iterator.Component) or else Done (Iterator) then
Raise_ASIS_Inappropriate_Element
(Diagnosis => Package_Name & "Array_Index (linearized)",
Status => Data_Error);
end if;
return Iterator.Index;
end Array_Index;
------------------------------------
-- Array_Indexes (non-linearized) --
------------------------------------
function Array_Indexes
(Iterator : in Array_Component_Iterator)
return Dimension_Indexes
is
Linear_Index : Asis.ASIS_Natural;
Result : Dimension_Indexes (1 .. Iterator.Component.Dimension);
begin
if Is_Nil (Iterator.Component) or else Done (Iterator) then
Raise_ASIS_Inappropriate_Element
(Diagnosis => Package_Name & "Array_Index (linearized)",
Status => Data_Error);
end if;
Linear_Index := Iterator.Index;
-- ???!!! FORTRAN arrays should be taken ito account
Result := De_Linear_Index
(Index => Linear_Index,
D => Iterator.Component.Dimension,
Ind_Lengths => Iterator.Component.Length);
return Result;
end Array_Indexes;
--------------------
-- Array_Iterator --
--------------------
function Array_Iterator
(Component : in Array_Component)
return Array_Component_Iterator
is
Result : Array_Component_Iterator := Nil_Array_Component_Iterator;
begin
-- ??? Validity checks should be added!!!
Result.Component := Component;
Result.Max_Len := Max_Len (Component);
Result.Index := 1;
return Result;
end Array_Iterator;
-----------------------------------------
-- Array_Length (from Array_Component) --
-----------------------------------------
function Array_Length
(Component : in Array_Component)
return Asis.ASIS_Natural
is
Result : Asis.ASIS_Natural := 1;
begin
Check_Validity
(Component,
Package_Name & "Array_Length (from Array_Component)");
if not Is_Array (Component) then
Raise_ASIS_Inappropriate_Element (Diagnosis =>
Package_Name &
"Array_Length (from Array_Component)");
end if;
for J in 1 .. Component.Dimension loop
Result := Result * Component.Length (J);
end loop;
return Result;
end Array_Length;
-------------------------------------------------------
-- Array_Length (from Array_Component and Dimension) --
-------------------------------------------------------
function Array_Length
(Component : in Array_Component;
Dimension : in Asis.ASIS_Natural)
return Asis.ASIS_Natural
is
begin
Check_Validity
(Component,
Package_Name &
"Array_Length (from Array_Component and Dimension)");
if not Is_Array (Component) then
Raise_ASIS_Inappropriate_Element (
Diagnosis => Package_Name &
"Array_Length (from Array_Component and Dimension)");
elsif Dimension > Component.Dimension then
-- ??? is it correct
Raise_ASIS_Inappropriate_Element (
Diagnosis => Package_Name &
"Array_Length (from Array_Component and Dimension)",
Status => Data_Error);
end if;
return Component.Length (Dimension);
end Array_Length;
------------------------------------------
-- Array_Length (from Record_Component) --
------------------------------------------
function Array_Length
(Component : in Record_Component)
return Asis.ASIS_Natural
is
Array_Entity : Node_Id;
D : ASIS_Natural;
Result : Asis.ASIS_Natural := 1;
begin
Check_Validity
(Component,
Package_Name & "Array_Length (from Record_Component)");
if not Is_Array (Component) then
Raise_ASIS_Inappropriate_Element (Diagnosis =>
Package_Name &
"Array_Length (from Record_Component)");
end if;
Array_Entity := Get_Type_Entity (Component);
D := ASIS_Natural (Number_Dimensions (Array_Entity));
for J in 1 .. D loop
Result := Result *
Get_Length (Array_Entity, J, Parent_Discrims (Component));
end loop;
return Result;
exception
when ASIS_Inappropriate_Element =>
raise;
when others =>
Raise_ASIS_Failed (Diagnosis =>
Package_Name &
"Array_Length (from Record_Component)");
end Array_Length;
--------------------------------------------------------
-- Array_Length (from Record_Component and Dimension) --
--------------------------------------------------------
function Array_Length
(Component : in Record_Component;
Dimension : in Asis.ASIS_Natural)
return Asis.ASIS_Natural
is
Array_Entity : Node_Id;
D : ASIS_Natural;
begin
Check_Validity
(Component,
Package_Name &
"Array_Length (from Record_Component and Dimension)");
if not Is_Array (Component) then
Raise_ASIS_Inappropriate_Element (Diagnosis =>
Package_Name &
"Array_Length (from Record_Component and Dimension)");
end if;
Array_Entity := Get_Type_Entity (Component);
D := ASIS_Natural (Number_Dimensions (Array_Entity));
if Dimension > D then
-- ??? is it correct
Raise_ASIS_Inappropriate_Element (
Diagnosis => Package_Name &
"Array_Length (from Record_Component and Dimension)",
Status => Data_Error);
end if;
return Get_Length (Array_Entity, Dimension, Parent_Discrims (Component));
exception
when ASIS_Inappropriate_Element =>
raise;
when others =>
Raise_ASIS_Failed (Diagnosis =>
Package_Name &
"Array_Length (from Record_Component and Dimension)");
end Array_Length;
---------------------------------------------------
-- Component_Data_Stream (from Record_Component) --
---------------------------------------------------
function Component_Data_Stream
(Component : in Record_Component;
Data_Stream : in Portable_Data)
return Portable_Data
is
Rec_Entity : Entity_Id;
Comp_Entity : Entity_Id;
begin
Check_Validity
(Component,
Package_Name &
"Component_Data_Stream (from Record_Component)");
if Is_Nil (Component) then
Raise_ASIS_Inappropriate_Element (Diagnosis =>
Package_Name &
"Component_Data_Stream (from Record_Component) - Nil Component");
end if;
Comp_Entity := Get_Comp_Entity (Component);
Rec_Entity := Get_Record_Entity (Component);
declare
Parent_Discs : Discrim_List := Parent_Discrims (Component);
-- A list of discriminants stored as a part of the argument
-- record component
Data_Discs : Discrim_List :=
Build_Discrim_List
(Rec => Rec_Entity,
Data => Data_Stream);
-- A list of discriminants ecxtracted from the argument Data_Stream
Result : Portable_Data := Extract_Record_Component
(Data => Data_Stream,
Comp => Comp_Entity,
Discs => Data_Discs);
begin
if not (Parent_Discs = Data_Discs) then
Raise_ASIS_Inappropriate_Element (Diagnosis =>
Package_Name &
"Component_Data_Stream (from Record_Component) - " &
"Component and data_Stream are incompatible");
else
return Result;
end if;
end;
exception
when ASIS_Inappropriate_Element =>
raise;
when No_Component =>
Raise_ASIS_Inappropriate_Element (Diagnosis =>
Package_Name &
"Component_Data_Stream (from Record_Component) - " &
"Component does not exist");
when Variable_Rep_Info =>
Raise_ASIS_Failed (Diagnosis =>
Package_Name &
"Component_Data_Stream (from Record_Component) - " &
"Complex dynamic case");
when others =>
Raise_ASIS_Failed (Diagnosis =>
Package_Name &
"Component_Data_Stream (from Record_Component) - " &
"bad data stream?");
end Component_Data_Stream;
------------------------------------------------------------
-- Component_Data_Stream (from Array_Component and Index) --
------------------------------------------------------------
function Component_Data_Stream
(Component : in Array_Component;
Index : in Asis.ASIS_Positive;
Data_Stream : in Portable_Data)
return Portable_Data
is
Parent_Discs : Discrim_List := Parent_Discrims (Component);
Array_Typ : Entity_Id;
begin
Check_Validity
(Component,
Package_Name &
"Component_Data_Stream (by Index)");
if Is_Nil (Component) then
Raise_ASIS_Inappropriate_Element (Diagnosis =>
Package_Name &
"Component_Data_Stream (by Index) - Nil Component");
elsif Index > Max_Len (Component) then
Raise_ASIS_Inappropriate_Element (Diagnosis =>
Package_Name &
"Component_Data_Stream (by Index) - Index is too big");
end if;
Array_Typ := Get_Array_Type_Entity (Component);
declare
Indexes : Dimension_Indexes :=
De_Linear_Index
(Index => Index,
D => Dimension (Component),
Ind_Lengths => Component.Length);
-- ??? Fortran convention???
-- ??? De_Linear_Index should be simplified
Result : Portable_Data := Extract_Array_Component
(Typ => Array_Typ,
Data => Data_Stream,
Subs => Indexes,
Discs => Parent_Discs);
begin
return Result;
end;
exception
when ASIS_Inappropriate_Element =>
raise;
when No_Component =>
Raise_ASIS_Inappropriate_Element (Diagnosis =>
Package_Name &
"Component_Data_Stream (by Index) - " &
"Component does not exist");
when Variable_Rep_Info =>
Raise_ASIS_Failed (Diagnosis =>
Package_Name &
"Component_Data_Stream (by Index) - " &
"Complex dynamic case");
when others =>
Raise_ASIS_Failed (Diagnosis =>
Package_Name &
"Component_Data_Stream (by Index) - " &
"bad data stream?");
end Component_Data_Stream;
--------------------------------------------------------------
-- Component_Data_Stream (from Array_Component and Indexes) --
--------------------------------------------------------------
function Component_Data_Stream
(Component : in Array_Component;
Indexes : in Dimension_Indexes;
Data_Stream : in Portable_Data)
return Portable_Data
is
Parent_Discs : Discrim_List := Parent_Discrims (Component);
Array_Typ : Entity_Id;
begin
Check_Validity
(Component,
Package_Name &
"Component_Data_Stream (by Indexes)");
if Is_Nil (Component) then
Raise_ASIS_Inappropriate_Element (Diagnosis =>
Package_Name &
"Component_Data_Stream (by Indexes) - Nil Component");
elsif Wrong_Indexes (Component, Indexes) then
Raise_ASIS_Inappropriate_Element (Diagnosis =>
Package_Name &
"Component_Data_Stream (by Index) - Indexes out of ranges");
end if;
Array_Typ := Get_Array_Type_Entity (Component);
declare
Result : Portable_Data := Extract_Array_Component
(Typ => Array_Typ,
Data => Data_Stream,
Subs => Indexes,
Discs => Parent_Discs);
begin
return Result;
end;
exception
when ASIS_Inappropriate_Element =>
raise;
when No_Component =>
Raise_ASIS_Inappropriate_Element (Diagnosis =>
Package_Name &
"Component_Data_Stream (by Indexes) - " &
"Component does not exist");
when Variable_Rep_Info =>
Raise_ASIS_Failed (Diagnosis =>
Package_Name &
"Component_Data_Stream (by Indexes) - " &
"Complex dynamic case");
when others =>
Raise_ASIS_Failed (Diagnosis =>
Package_Name &
"Component_Data_Stream (by Indexes) - " &
"bad data stream?");
end Component_Data_Stream;
-----------------------------------------------------------
-- Component_Data_Stream from (Array_Component_Iterator) --
-----------------------------------------------------------
function Component_Data_Stream
(Iterator : in Array_Component_Iterator;
Data_Stream : in Portable_Data)
return Portable_Data
is
Parent_Discs : Discrim_List := Parent_Discrims (Iterator.Component);
Array_Typ : Entity_Id;
begin
Check_Validity
(Iterator.Component,
Package_Name &
"Component_Data_Stream (by Iterator)");
if Done (Iterator) then
Raise_ASIS_Inappropriate_Element (Diagnosis =>
Package_Name &
"Component_Data_Stream (by Iterator) - Iterator is Done");
end if;
if Iterator = Nil_Array_Component_Iterator then
Raise_ASIS_Inappropriate_Element (Diagnosis =>
Package_Name &
"Component_Data_Stream (by Iterator) - Nil Iterator");
elsif Done (Iterator) then
Raise_ASIS_Inappropriate_Element (Diagnosis =>
Package_Name &
"Component_Data_Stream (by Iterator) - Iterator is Done");
end if;
Array_Typ := Get_Array_Type_Entity (Iterator.Component);
declare
Indexes : Dimension_Indexes := Array_Indexes (Iterator);
Result : Portable_Data := Extract_Array_Component
(Typ => Array_Typ,
Data => Data_Stream,
Subs => Indexes,
Discs => Parent_Discs);
begin
return Result;
end;
exception
when ASIS_Inappropriate_Element =>
raise;
when No_Component =>
Raise_ASIS_Inappropriate_Element (Diagnosis =>
Package_Name &
"Component_Data_Stream (by Iterator) - " &
"Component does not exist");
when Variable_Rep_Info =>
Raise_ASIS_Failed (Diagnosis =>
Package_Name &
"Component_Data_Stream (by Iterator) - " &
"Complex dynamic case");
when others =>
Raise_ASIS_Failed (Diagnosis =>
Package_Name &
"Component_Data_Stream (by Iterator) - " &
"bad data stream?");
end Component_Data_Stream;
---------------------------
-- Component_Declaration --
---------------------------
function Component_Declaration
(Component : in Record_Component)
return Asis.Declaration
is
Result : Asis.Element;
begin
if Is_Nil (Component) then
Raise_ASIS_Inappropriate_Component
(Diagnosis => Package_Name & "Component_Declaration",
Component_Kind => Rec);
end if;
Result := Component_Name (Component);
Result := Enclosing_Element (Result);
return Result;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information
(Outer_Call => Package_Name & "Component_Declaration");
raise;
when others =>
Raise_ASIS_Failed
(Diagnosis => Package_Name & "Component_Declaration");
end Component_Declaration;
--------------------------
-- Component_Indication --
--------------------------
function Component_Indication
(Component : in Array_Component)
return Asis.Subtype_Indication
is
Result : Asis.Element;
begin
if Is_Nil (Component) then
Raise_ASIS_Inappropriate_Component
(Diagnosis => Package_Name & "Component_Indication",
Component_Kind => Arr);
end if;
Result := Parent_Array_Type (Component);
Result := Root_Array_Definition (Result);
Result := Array_Component_Definition (Result);
Result := Component_Subtype_Indication (Result);
return Result;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information
(Outer_Call => Package_Name & "Component_Indication");
raise;
when others =>
Raise_ASIS_Failed
(Diagnosis => Package_Name & "Component_Indication");
end Component_Indication;
--------------------------------------
-- Construct_Artificial_Data_Stream --
--------------------------------------
function Construct_Artificial_Data_Stream
(Type_Definition : in Asis.Type_Definition;
Data_Stream : in Portable_Data;
Discriminant : in Record_Component;
Value : in Portable_Data)
return Portable_Data
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Type_Definition);
Type_Element : Asis.Element;
Tmp_Element : Asis.Element;
Disc_Entity : Entity_Id;
Disc_Typ : Entity_Id;
Disc_Val : Uint;
begin
Check_Validity
(Type_Definition,
Package_Name & "Construct_Artificial_Data_Stream");
if not (Arg_Kind = A_Record_Type_Definition or else
Is_Derived_From_Record (Type_Definition))
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => Package_Name &
"Construct_Artificial_Data_Stream (wrong Type_Definition)");
end if;
Check_Validity
(Discriminant,
Package_Name & "Construct_Artificial_Data_Stream");
if Is_Nil (Discriminant) then
Raise_ASIS_Inappropriate_Element
(Diagnosis => Package_Name &
"Construct_Artificial_Data_Stream (Nil Discriminant component)");
end if;
-- We have also to check if Discriminant is a discriminant of a given
-- type
Type_Element := Enclosing_Element (Type_Definition);
Tmp_Element := Component_Declaration (Discriminant);
Tmp_Element := Enclosing_Element (Enclosing_Element (Tmp_Element));
if not Is_Equal (Type_Element, Tmp_Element) then
Raise_ASIS_Inappropriate_Element
(Diagnosis => Package_Name &
"Construct_Artificial_Data_Stream " &
"(Discriminant is from another type)");
end if;
-- And now we can create the result stream:
Disc_Entity := R_Node (Component_Name (Discriminant));
Disc_Typ := Etype (Disc_Entity);
Disc_Val := Decode_Scalar_Value (Disc_Typ, Value);
declare
Result : Portable_Data := Set_Discriminant
(Data => Data_Stream,
Disc => Disc_Entity,
Val => Disc_Val);
begin
return Result;
end;
exception
when ASIS_Inappropriate_Element =>
raise;
when Invalid_Data =>
Raise_ASIS_Inappropriate_Element
(Diagnosis => Package_Name & "Construct_Artificial_Data_Stream",
Status => Data_Error);
when ASIS_Failed =>
Add_Call_Information (Outer_Call =>
Package_Name & "Construct_Artificial_Data_Stream");
raise;
when others =>
Raise_ASIS_Failed (Diagnosis =>
Package_Name & "Construct_Artificial_Data_Stream");
end Construct_Artificial_Data_Stream;
-----------------------------------------------
-- Discriminant_Components (Array_Component) --
-----------------------------------------------
function Discriminant_Components
(Component : in Array_Component)
return Record_Component_List
is
Discr_Part : Asis.Element;
Type_Def : Asis.Element;
begin
Check_Validity
(Component,
Package_Name & "Discriminant_Components (from Array_Component)");
if not Is_Record (Component) then
Raise_ASIS_Inappropriate_Component
(Diagnosis => Package_Name &
"Discriminant_Components (from Array_Component)",
Component_Kind => Arr);
end if;
Type_Def := Component_Indication (Component);
Type_Def := Asis.Definitions.Subtype_Mark (Type_Def);
Type_Def := Type_Definition_From_Subtype_Mark (Type_Def);
Discr_Part := Discriminant_Part_From_Type_Definition (Type_Def);
Set_Named_Components (Discr_Part, New_List);
Set_Parent_Type_Definition (Type_Def);
Set_Record_Components_From_Names;
return Record_Component_List (
RC_Table (1 .. Record_Component_Table.Last));
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (Outer_Call =>
Package_Name & "Discriminant_Components (from Array_Component)");
raise;
when others =>
Raise_ASIS_Failed (Diagnosis =>
Package_Name & "Discriminant_Components (from Array_Component)");
end Discriminant_Components;
-----------------------------------------------------
-- Discriminant_Components (from Record_Component) --
-----------------------------------------------------
function Discriminant_Components
(Component : in Record_Component)
return Record_Component_List
is
Discr_Part : Asis.Element;
Type_Def : Asis.Element;
begin
Check_Validity
(Component,
Package_Name & "Discriminant_Components (from Record_Component)");
if not Is_Record (Component) then
Raise_ASIS_Inappropriate_Component
(Diagnosis => Package_Name &
"Discriminant_Components (from Record_Component)",
Component_Kind => Rec);
end if;
Type_Def := Component_Declaration (Component);
Type_Def := Object_Declaration_View (Type_Def);
Type_Def := Asis.Definitions.Subtype_Mark (Type_Def);
Type_Def := Type_Definition_From_Subtype_Mark (Type_Def);
Discr_Part := Discriminant_Part_From_Type_Definition (Type_Def);
Set_Named_Components (Discr_Part, New_List);
Set_Parent_Type_Definition (Type_Def);
Set_Record_Components_From_Names;
return Record_Component_List (
RC_Table (1 .. Record_Component_Table.Last));
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (Outer_Call =>
Package_Name & "Discriminant_Components (from Record_Component)");
raise;
when others =>
Raise_ASIS_Failed (Diagnosis =>
Package_Name & "Discriminant_Components (from Record_Component)");
end Discriminant_Components;
---------------------------------------------------
-- Discriminant_Components (from Type_Definition)--
---------------------------------------------------
function Discriminant_Components
(Type_Definition : in Asis.Type_Definition)
return Record_Component_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Type_Definition);
Discr_Part : Element;
begin
Check_Validity
(Type_Definition,
Package_Name & "Discriminant_Components (from Type_Definition)");
if not (Arg_Kind = A_Record_Type_Definition or else
Is_Derived_From_Record (Type_Definition))
then
Raise_ASIS_Inappropriate_Element (Diagnosis =>
Package_Name & "Discriminant_Components (from Type_Definition)");
end if;
Discr_Part := Discriminant_Part_From_Type_Definition (Type_Definition);
Set_Named_Components (Discr_Part, New_List);
Set_Parent_Type_Definition (Type_Definition);
Set_Record_Components_From_Names;
return Record_Component_List (
RC_Table (1 .. Record_Component_Table.Last));
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Type_Definition,
Outer_Call => Package_Name &
"Discriminant_Components (from Type_Definition)");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Type_Definition,
Diagnosis => Package_Name &
"Discriminant_Components (from Type_Definition)");
end Discriminant_Components;
----------
-- Done --
----------
function Done (Iterator : in Array_Component_Iterator) return Boolean is
begin
return Iterator.Index > Iterator.Max_Len or else
Is_Nil (Iterator.Component);
end Done;
------------------------------------------------
-- First_Bit (from Array_Component and Index) --
------------------------------------------------
function First_Bit
(Component : in Array_Component;
Index : in Asis.ASIS_Positive)
return Asis.ASIS_Natural
is
Result : Asis.ASIS_Natural;
begin
if Is_Nil (Component) or else
Index > Max_Len (Component)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => Package_Name &
"First_Bit (from Array_Component and Index)",
Status => Data_Error);
end if;
Result := Component.First_Bit;
Result := Result + Component.Size * (Index - 1);
Result := Result mod Storage_Unit;
return Result;
-- ??? exception handler???
end First_Bit;
--------------------------------------------------
-- First_Bit (from Array_Component and Indexes) --
--------------------------------------------------
function First_Bit
(Component : in Array_Component;
Indexes : in Dimension_Indexes)
return Asis.ASIS_Natural
is
Ind : Asis.ASIS_Positive;
Dim : ASIS_Natural := Component.Dimension;
begin
if Is_Nil (Component) or else
Wrong_Indexes (Component, Indexes)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => Package_Name &
"First_Bit (from Array_Component and Indexes)",
Status => Data_Error);
end if;
-- ??? FORTRAN convention shoule be taken into account
Ind := Linear_Index (Inds => Indexes,
D => Dim,
Ind_Lengths => Component.Length);
return First_Bit (Component, Ind);
-- ??? exception handler???
end First_Bit;
-------------------------------
-- First_Bit (from Iterator) --
-------------------------------
function First_Bit
(Iterator : in Array_Component_Iterator)
return Asis.ASIS_Natural
is
Component : Array_Component;
Index : Asis.ASIS_Positive;
begin
if Done (Iterator) then
Raise_ASIS_Inappropriate_Element
(Diagnosis => Package_Name &
"First_Bit (from Iterator)",
Status => Data_Error);
end if;
Component := Iterator.Component;
Index := Array_Index (Iterator);
return First_Bit (Component, Index);
-- ??? exception handler???
end First_Bit;
---------------------------------------
-- First_Bit (from Record_Component) --
---------------------------------------
function First_Bit
(Component : in Record_Component)
return Asis.ASIS_Natural
is
begin
if Is_Nil (Component) then
Raise_ASIS_Inappropriate_Element
(Diagnosis => Package_Name &
"First_Bit (from Record_Component)",
Status => Data_Error);
end if;
return Component.First_Bit;
end First_Bit;
--------------------------------
-- Is_Array (Array_Component) --
--------------------------------
function Is_Array (Component : in Array_Component) return Boolean is
begin
return Is_Array_Comp (Component);
end Is_Array;
---------------------------------
-- Is_Array (Record_Component) --
---------------------------------
function Is_Array (Component : in Record_Component) return Boolean is
begin
return Component.Is_Array_Comp;
end Is_Array;
--------------------------------
-- Is_Equal (Array_Component) --
--------------------------------
function Is_Equal
(Left : in Array_Component;
Right : in Array_Component)
return Boolean
is
begin
-- Is this check really enough?
return
Is_Equal (Left.Parent_Array_Type, Right.Parent_Array_Type) and then
Is_Equal (Left.Parent_Component_Name,
Right.Parent_Component_Name) and then
Left.Position = Right.Position and then
Left.First_Bit = Right.First_Bit and then
Left.Last_Bit = Right.Last_Bit and then
Left.Size = Right.Size;
end Is_Equal;
---------------------------------
-- Is_Equal (Record_Component) --
---------------------------------
function Is_Equal
(Left : in Record_Component;
Right : in Record_Component)
return Boolean
is
begin
-- Is this check really enough?
return
Is_Equal (Left.Parent_Record_Type, Right.Parent_Record_Type) and then
Is_Equal (Left.Component_Name, Right.Component_Name) and then
Left.Position = Right.Position and then
Left.First_Bit = Right.First_Bit and then
Left.Last_Bit = Right.Last_Bit and then
Left.Size = Right.Size;
end Is_Equal;
------------------------------------
-- Is_Identical (Array_Component) --
------------------------------------
function Is_Identical
(Left : in Array_Component;
Right : in Array_Component)
return Boolean
is
begin
-- Is this check really enough?
return
Is_Identical (Left.Parent_Array_Type, Right.Parent_Array_Type)
and then
Is_Identical (Left.Parent_Component_Name, Right.Parent_Component_Name)
and then
Left.Position = Right.Position
and then
Left.First_Bit = Right.First_Bit
and then
Left.Last_Bit = Right.Last_Bit
and then
Left.Size = Right.Size
and then
Left.Parent_Context = Right.Parent_Context;
end Is_Identical;
-------------------------------------
-- Is_Identical (Record_Component) --
-------------------------------------
function Is_Identical
(Left : in Record_Component;
Right : in Record_Component)
return Boolean
is
begin
-- Is this check really enough?
return
Is_Identical (Left.Parent_Record_Type, Right.Parent_Record_Type)
and then
Is_Identical (Left.Component_Name, Right.Component_Name)
and then
Left.Position = Right.Position
and then
Left.First_Bit = Right.First_Bit
and then
Left.Last_Bit = Right.Last_Bit
and then
Left.Size = Right.Size
and then
Left.Parent_Context = Right.Parent_Context;
end Is_Identical;
------------------------------
-- Is_Nil (Array_Component) --
------------------------------
function Is_Nil (Right : in Array_Component) return Boolean is
begin
-- This should be enough to decide, that the argument is nil
return Is_Nil (Right.Parent_Array_Type);
end Is_Nil;
-------------------------------
-- Is_Nil (Record_Component) --
-------------------------------
function Is_Nil (Right : in Record_Component) return Boolean is
begin
-- This should be enough to decide, that the argument is nil
return Is_Nil (Right.Parent_Record_Type);
end Is_Nil;
---------------------------------
-- Is_Record (Array_Component) --
---------------------------------
function Is_Record (Component : in Array_Component) return Boolean is
begin
return Is_Record_Comp (Component);
end Is_Record;
----------------------------------
-- Is_Record (Record_Component) --
----------------------------------
function Is_Record (Component : in Record_Component) return Boolean is
begin
return Is_Record_Comp (Component);
end Is_Record;
-----------------------------------------------
-- Last_Bit (from Array_Component and Index) --
-----------------------------------------------
function Last_Bit
(Component : in Array_Component;
Index : in Asis.ASIS_Positive)
return Asis.ASIS_Natural
is
Result : Asis.ASIS_Natural;
begin
if Is_Nil (Component) or else
Index > Max_Len (Component)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => Package_Name &
"Last_Bit (from Array_Component and Index)",
Status => Data_Error);
end if;
Result := First_Bit (Component, Index) + Component.Size - 1;
return Result;
-- ??? exception handler???
end Last_Bit;
-------------------------------------------------
-- Last_Bit (from Array_Component and Indexes) --
-------------------------------------------------
function Last_Bit
(Component : in Array_Component;
Indexes : in Dimension_Indexes)
return Asis.ASIS_Natural
is
Ind : Asis.ASIS_Positive;
Dim : ASIS_Natural := Component.Dimension;
begin
if Is_Nil (Component) or else
Wrong_Indexes (Component, Indexes)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => Package_Name &
"Last_Bit (from Array_Component and Indexes)",
Status => Data_Error);
end if;
-- ??? FORTRAN convention shoule be taken into account
Ind := Linear_Index (Inds => Indexes,
D => Dim,
Ind_Lengths => Component.Length);
return Last_Bit (Component, Ind);
-- ??? exception handler???
end Last_Bit;
------------------------------
-- Last_Bit (from Iterator) --
------------------------------
function Last_Bit
(Iterator : in Array_Component_Iterator)
return Asis.ASIS_Natural
is
Component : Array_Component;
Index : Asis.ASIS_Positive;
begin
if Done (Iterator) then
Raise_ASIS_Inappropriate_Element
(Diagnosis => Package_Name &
"Last_Bit (from Iterator)",
Status => Data_Error);
end if;
Component := Iterator.Component;
Index := Array_Index (Iterator);
return Last_Bit (Component, Index);
-- ??? exception handler???
end Last_Bit;
--------------------------------------
-- Last_Bit (from Record_Component) --
--------------------------------------
function Last_Bit
(Component : in Record_Component)
return Asis.ASIS_Natural
is
begin
if Is_Nil (Component) then
Raise_ASIS_Inappropriate_Element
(Diagnosis => Package_Name &
"Last_Bit (from Record_Component)",
Status => Data_Error);
end if;
return Component.Last_Bit;
end Last_Bit;
----------
-- Next --
----------
procedure Next (Iterator : in out Array_Component_Iterator) is
begin
if Iterator.Index <= Iterator.Max_Len then
Iterator.Index := Iterator.Index + 1;
end if;
end Next;
----------------------------------
-- Portable_Constrained_Subtype --
----------------------------------
function Portable_Constrained_Subtype
(Data_Stream : in Portable_Data)
return Constrained_Subtype
is
type Constrained_Subtype_Access is access Constrained_Subtype;
function To_Constrained_Subtype_Access is new
Ada.Unchecked_Conversion (Address, Constrained_Subtype_Access);
Result : Constrained_Subtype_Access :=
To_Constrained_Subtype_Access (Data_Stream'Address);
begin
return Result.all;
end Portable_Constrained_Subtype;
-----------------------------------------------
-- Position (from Array_Component and Index) --
-----------------------------------------------
function Position
(Component : in Array_Component;
Index : in Asis.ASIS_Positive)
return Asis.ASIS_Natural
is
Result : Asis.ASIS_Natural;
begin
if Is_Nil (Component) or else
Index > Max_Len (Component)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => Package_Name &
"Position (from Array_Component and Index)",
Status => Data_Error);
end if;
Result := Component.First_Bit;
Result := Result + Component.Size * (Index - 1);
Result := Result / Storage_Unit;
return Result;
-- ??? exception handler???
end Position;
-------------------------------------------------
-- Position (from Array_Component and Indexes) --
-------------------------------------------------
function Position
(Component : in Array_Component;
Indexes : in Dimension_Indexes)
return Asis.ASIS_Natural
is
Ind : Asis.ASIS_Positive;
Dim : ASIS_Natural := Component.Dimension;
begin
if Is_Nil (Component) or else
Wrong_Indexes (Component, Indexes)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => Package_Name &
"Position (from Array_Component and Indexes)",
Status => Data_Error);
end if;
-- ??? FORTRAN convention shoule be taken into account
Ind := Linear_Index (Inds => Indexes,
D => Dim,
Ind_Lengths => Component.Length);
return Position (Component, Ind);
-- ??? exception handler???
end Position;
------------------------------
-- Position (from Iterator) --
------------------------------
function Position
(Iterator : in Array_Component_Iterator)
return Asis.ASIS_Natural
is
Component : Array_Component;
Index : Asis.ASIS_Positive;
begin
if Done (Iterator) then
Raise_ASIS_Inappropriate_Element
(Diagnosis => Package_Name &
"Position (from Iterator)",
Status => Data_Error);
end if;
Component := Iterator.Component;
Index := Array_Index (Iterator);
return Position (Component, Index);
-- ??? exception handler???
end Position;
--------------------------------------
-- Position (from Record_Component) --
--------------------------------------
function Position
(Component : in Record_Component)
return Asis.ASIS_Natural
is
begin
if Is_Nil (Component) then
Raise_ASIS_Inappropriate_Element
(Diagnosis => Package_Name &
"Position (from Record_Component)",
Status => Data_Error);
end if;
return Component.Position;
end Position;
----------------------------------------------
-- Record_Components (from Array_Component) --
----------------------------------------------
function Record_Components
(Component : in Array_Component)
return Record_Component_List
is
Comp_Type : Element;
begin
Check_Validity
(Component,
Package_Name & "Record_Components (from Array_Component)");
if not (Is_Record (Component) and then
Type_Model_Kind (Component) = A_Simple_Static_Model)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => Package_Name &
"Record_Components (from Array_Component)");
end if;
Comp_Type := Component_Indication (Component);
Comp_Type := Component_Type_Definition (Comp_Type);
pragma Assert (Int_Kind (Comp_Type) = A_Record_Type_Definition or else
Is_Derived_From_Record (Comp_Type));
Set_All_Named_Components (Comp_Type);
Set_Parent_Type_Definition (Comp_Type);
Set_Record_Components_From_Names;
return Record_Component_List (
RC_Table (1 .. Record_Component_Table.Last));
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information
(Outer_Call => Package_Name &
"Record_Components (from Array_Component)");
raise;
when others =>
Raise_ASIS_Failed (
Diagnosis => Package_Name &
"Record_Components (from Array_Component)");
end Record_Components;
--------------------------------------------------------------
-- Record_Components (from Array_Component and Data_Stream) --
--------------------------------------------------------------
function Record_Components
(Component : in Array_Component;
Data_Stream : in Portable_Data)
return Record_Component_List
is
Comp_Type : Element;
Type_Model : Type_Model_Kinds := Type_Model_Kind (Component);
begin
Check_Validity
(Component,
Package_Name &
"Record_Components (from Array_Component and Data_Stream)");
if not (Is_Record (Component) and then
(Type_Model = A_Simple_Static_Model
or else
Type_Model = A_Simple_Dynamic_Model))
then
Raise_ASIS_Inappropriate_Element (Diagnosis =>
Package_Name &
"Record_Components (from Array_Component and Data_Stream)");
end if;
Comp_Type := Component_Indication (Component);
Comp_Type := Component_Type_Definition (Comp_Type);
pragma Assert (Int_Kind (Comp_Type) = A_Record_Type_Definition or else
Is_Derived_From_Record (Comp_Type));
Set_All_Named_Components (Comp_Type);
Set_Parent_Type_Definition (Comp_Type);
Set_Record_Components_From_Names (Data_Stream);
return Record_Component_List (
RC_Table (1 .. Record_Component_Table.Last));
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (Outer_Call =>
Package_Name &
"Record_Components (from Array_Component and Data_Stream)");
raise;
when others =>
Raise_ASIS_Failed (Diagnosis =>
Package_Name &
"Record_Components (from Array_Component and Data_Stream)");
end Record_Components;
-----------------------------------------------
-- Record_Components (from Record_Component) --
-----------------------------------------------
function Record_Components
(Component : in Record_Component)
return Record_Component_List
is
Comp_Type : Element;
begin
Check_Validity
(Component,
Package_Name & "Record_Components (from Record_Component)");
if not (Is_Record (Component) and then
Type_Model_Kind (Component) = A_Simple_Static_Model)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => Package_Name &
"Record_Components (from Record_Component)");
end if;
Comp_Type := Component_Declaration (Component);
Comp_Type := Component_Type_Definition (Comp_Type);
Set_All_Named_Components (Comp_Type);
Set_Parent_Type_Definition (Comp_Type);
Set_Record_Components_From_Names
(Parent_First_Bit_Offset => Component.First_Bit_Offset);
return Record_Component_List (
RC_Table (1 .. Record_Component_Table.Last));
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Outer_Call => Package_Name &
"Record_Components (from Record_Component)");
raise;
when others =>
Raise_ASIS_Failed (
Diagnosis => Package_Name &
"Record_Components (from Record_Component)");
end Record_Components;
---------------------------------------------------------------
-- Record_Components (from Record_Component and Data_Stream) --
---------------------------------------------------------------
function Record_Components
(Component : in Record_Component;
Data_Stream : in Portable_Data)
return Record_Component_List
is
Comp_Type : Element;
Type_Model : Type_Model_Kinds;
begin
Check_Validity
(Component,
Package_Name &
"Record_Components (from Record_Component and Data_Stream)");
Type_Model := Type_Model_Kind (Component);
if not (Is_Record (Component) and then
(Type_Model = A_Simple_Static_Model
or else
Type_Model = A_Simple_Dynamic_Model))
then
Raise_ASIS_Inappropriate_Element (Diagnosis =>
Package_Name &
"Record_Components (from Record_Component and Data_Stream)");
end if;
Comp_Type := Component_Declaration (Component);
Comp_Type := Component_Type_Definition (Comp_Type);
Set_All_Named_Components (Comp_Type);
Set_Parent_Type_Definition (Comp_Type);
Set_Record_Components_From_Names
(Parent_First_Bit_Offset => Component.First_Bit_Offset,
Data_Stream => Data_Stream);
return Record_Component_List (
RC_Table (1 .. Record_Component_Table.Last));
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (Outer_Call =>
Package_Name &
"Record_Components (from Record_Component and Data_Stream)");
raise;
when others =>
Raise_ASIS_Failed (Diagnosis =>
Package_Name &
"Record_Components (from Record_Component and Data_Stream)");
end Record_Components;
----------------------------------------------
-- Record_Components (from Type_Definition) --
----------------------------------------------
function Record_Components
(Type_Definition : in Asis.Type_Definition)
return Record_Component_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Type_Definition);
begin
Check_Validity
(Type_Definition,
Package_Name & "Record_Components (from Type_Definition)");
if not ((Arg_Kind = A_Record_Type_Definition or else
Is_Derived_From_Record (Type_Definition))
and then
Type_Model_Kind (Type_Definition) = A_Simple_Static_Model)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => Package_Name &
"Record_Components (from Type_Definition)");
end if;
Set_All_Named_Components (Type_Definition);
Set_Parent_Type_Definition (Type_Definition);
Set_Record_Components_From_Names;
return Record_Component_List (
RC_Table (1 .. Record_Component_Table.Last));
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Type_Definition,
Outer_Call => Package_Name &
"Record_Components (from Type_Definition)");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Type_Definition,
Diagnosis => Package_Name &
"Record_Components (from Type_Definition)");
end Record_Components;
--------------------------------------------------------------
-- Record_Components (from Type_Definition and Data_Stream) --
--------------------------------------------------------------
function Record_Components
(Type_Definition : in Asis.Type_Definition;
Data_Stream : in Portable_Data)
return Record_Component_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Type_Definition);
Type_Model : Type_Model_Kinds;
begin
Check_Validity
(Type_Definition,
Package_Name &
"Record_Components (from Type_Definition and Data_Stream)");
Type_Model := Type_Model_Kind (Type_Definition);
if not ((Arg_Kind = A_Record_Type_Definition or else
Is_Derived_From_Record (Type_Definition))
and then
(Type_Model = A_Simple_Static_Model or else
Type_Model = A_Simple_Dynamic_Model))
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => Package_Name &
"Record_Components (from Type_Definition and Data_Stream)");
end if;
Set_All_Named_Components (Type_Definition);
Set_Parent_Type_Definition (Type_Definition);
Set_Record_Components_From_Names (Data_Stream => Data_Stream);
return Record_Component_List (
RC_Table (1 .. Record_Component_Table.Last));
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Type_Definition,
Outer_Call =>
Package_Name &
"Record_Components (from Type_Definition and Data_Stream)");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Type_Definition,
Diagnosis =>
Package_Name &
"Record_Components (from Type_Definition and Data_Stream)");
end Record_Components;
-----------
-- Reset --
-----------
procedure Reset (Iterator : in out Array_Component_Iterator) is
begin
-- ??? what about checking for being not-null???
Iterator.Index := 0;
end Reset;
---------------------------------
-- Size (from Array_Component) --
---------------------------------
function Size
(Component : in Array_Component)
return Asis.ASIS_Natural
is
begin
Check_Validity
(Component,
Package_Name & "Size (from Array_Component)");
if Is_Nil (Component) then
Raise_ASIS_Inappropriate_Element
(Diagnosis => Package_Name &
"end (from Array_Component)");
end if;
return Component.Size;
end Size;
----------------------------------
-- Size (from Record_Component) --
----------------------------------
function Size
(Component : in Record_Component)
return Asis.ASIS_Natural
is
begin
Check_Validity
(Component,
Package_Name & "Size (from Record_Component)");
if Is_Nil (Component) then
Raise_ASIS_Inappropriate_Element
(Diagnosis => Package_Name &
"end (from Record_Component)");
end if;
return Component.Size;
end Size;
-------------------------------------------------
-- Size (from Type_Definition and Data_Stream) --
-------------------------------------------------
function Size
(Type_Definition : in Asis.Type_Definition;
Data_Stream : in Portable_Data)
return Asis.ASIS_Natural
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Type_Definition);
Type_Mod : Type_Model_Kinds := Type_Model_Kind (Type_Definition);
Type_Ent : Node_Id;
Result : Asis.ASIS_Natural;
begin
Check_Validity
(Type_Definition,
Package_Name & "Size (from Type_Definition and Data_Stream)");
if not (Arg_Kind in Internal_Type_Kinds and then
(Type_Mod = A_Simple_Static_Model
or else
Type_Mod = A_Simple_Dynamic_Model))
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => Package_Name &
"Size (from Type_Definition and Data_Stream)");
end if;
Type_Ent := R_Node (Type_Definition);
Type_Ent := Defining_Identifier (Parent (Type_Ent));
declare
Discs : Discrim_List :=
Build_Discrim_List_If_Data_Presented (Type_Ent, Data_Stream);
begin
Result := UI_To_Aint (Get_Esize (Type_Ent, Discs));
end;
return Result;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Type_Definition,
Outer_Call => Package_Name &
"Size (from Type_Definition and Data_Stream)");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Type_Definition,
Diagnosis => Package_Name &
"Size (from Type_Definition and Data_Stream)");
end Size;
---------------------------------
-- Size (from Type_Definition) --
---------------------------------
function Size
(Type_Definition : in Asis.Type_Definition)
return Asis.ASIS_Natural
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Type_Definition);
Type_Ent : Node_Id;
begin
Check_Validity
(Type_Definition,
Package_Name & "Size (from Type_Definition)");
if not (Arg_Kind in Internal_Type_Kinds and then
Type_Model_Kind (Type_Definition) = A_Simple_Static_Model)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => Package_Name &
"Size (from Type_Definition)");
end if;
Type_Ent := R_Node (Type_Definition);
Type_Ent := Defining_Identifier (Parent (Type_Ent));
return ASIS_Natural (UI_To_Int (Get_Esize (Type_Ent)));
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Type_Definition,
Outer_Call => Package_Name &
"Size (from Type_Definition)");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Type_Definition,
Diagnosis => Package_Name &
"Size (from Type_Definition");
end Size;
--------------------------------------------
-- Type_Model_Kind (from Array_Component) --
--------------------------------------------
function Type_Model_Kind
(Component : in Array_Component)
return Type_Model_Kinds
is
Component_Subtype_Indication : Asis.Element;
Result : Type_Model_Kinds := Not_A_Type_Model;
begin
if not Is_Nil (Component) then
Component_Subtype_Indication := Component_Indication (Component);
Result := Subtype_Model_Kind (Component_Subtype_Indication);
end if;
return Result;
exception
when ASIS_Inappropriate_Element | ASIS_Failed =>
Add_Call_Information (Outer_Call =>
Package_Name & "Type_Model_Kind (from array component)");
raise;
when others =>
Raise_ASIS_Failed (Diagnosis =>
Package_Name & "Type_Model_Kind (from array component)");
end Type_Model_Kind;
---------------------------------------------
-- Type_Model_Kind (from Record_Component) --
---------------------------------------------
function Type_Model_Kind
(Component : in Record_Component)
return Type_Model_Kinds
is
Comp_Constraint : Asis.Element;
Comp_Entity : Entity_Id;
Result : Type_Model_Kinds := Not_A_Type_Model;
begin
if not Is_Nil (Component) then
Comp_Entity := R_Node (Component_Name (Component));
Comp_Constraint := Component_Declaration (Component);
if Einfo.Size_Known_At_Compile_Time (Comp_Entity) or else
Int_Kind (Comp_Constraint) = A_Discriminant_Specification or else
Einfo.Esize (Comp_Entity) > 0
then
Result := A_Simple_Static_Model;
elsif Is_Record (Component) or else Is_Array (Component) then
-- Here we can have an index or a discriminant constraint which
-- may give us A_Simple_Static_Model, if the constraint depends
-- on discriminants only
Comp_Constraint := Object_Declaration_View (Comp_Constraint);
Comp_Constraint := Component_Subtype_Indication (Comp_Constraint);
Comp_Constraint := Subtype_Constraint (Comp_Constraint);
if Constraint_Model_Kind (Comp_Constraint) = External then
Result := A_Complex_Dynamic_Model;
else
Result := A_Simple_Dynamic_Model;
end if;
else
Result := A_Complex_Dynamic_Model;
end if;
end if;
return Result;
exception
when ASIS_Inappropriate_Element | ASIS_Failed =>
Add_Call_Information (Outer_Call =>
Package_Name & "Type_Model_Kind (from record component)");
raise;
when others =>
Raise_ASIS_Failed (Diagnosis =>
Package_Name & "Type_Model_Kind (from record component)");
end Type_Model_Kind;
--------------------------------------------
-- Type_Model_Kind (from Type_Definition) --
--------------------------------------------
function Type_Model_Kind
(Type_Definition : in Asis.Type_Definition)
return Type_Model_Kinds
is
Type_Entity : Node_Id;
Result : Type_Model_Kinds := Not_A_Type_Model;
Arg_Kind : Internal_Element_Kinds := Int_Kind (Type_Definition);
begin
Check_Validity
(Type_Definition, Package_Name & "Type_Model_Kind");
case Arg_Kind is
when A_Derived_Type_Definition =>
Result := Subtype_Model_Kind
(Parent_Subtype_Indication (Type_Definition)); -- ???
when An_Enumeration_Type_Definition |
A_Signed_Integer_Type_Definition |
A_Modular_Type_Definition |
A_Floating_Point_Definition |
An_Ordinary_Fixed_Point_Definition |
A_Decimal_Fixed_Point_Definition |
A_Root_Integer_Definition |
A_Root_Real_Definition |
A_Universal_Integer_Definition |
A_Universal_Real_Definition |
A_Universal_Fixed_Definition |
A_Pool_Specific_Access_To_Variable |
An_Access_To_Variable |
An_Access_To_Constant |
An_Access_To_Procedure |
An_Access_To_Protected_Procedure |
An_Access_To_Function |
An_Access_To_Protected_Function =>
Result := A_Simple_Static_Model;
when An_Unconstrained_Array_Definition =>
Result := A_Complex_Dynamic_Model;
-- We are considering any unconstrained array as being of
-- A_Complex_Dynamic_Model. The old code, currently commented
-- out, considered them as being of A_Simple_Dynamic_Model in
-- case if components are atatic, but it does not seem to
-- make sense
-- Result := Subtype_Model_Kind
-- (Component_Subtype_Indication
-- (Array_Component_Definition (Type_Definition)));
-- if Result = A_Simple_Static_Model then
-- Result := A_Simple_Dynamic_Model;
-- end if;
when A_Constrained_Array_Definition =>
-- Actually, for A_Constrained_Array_Definition we have only
-- two possibilities: either A_Simple_Static_Model or
-- A_Complex_Dynamic_Model, because in DDA no Data Stream
-- can be supplied to the query extracting array components
-- from A_Constrained_Array_Definition
Type_Entity := R_Node (Type_Definition);
Type_Entity := Sinfo.Defining_Identifier (Parent (Type_Entity));
if Einfo.Size_Known_At_Compile_Time (Type_Entity) then
Result := A_Simple_Static_Model;
else
Result := A_Complex_Dynamic_Model;
end if;
-- Just in case, we keep the old code (commented out) which did
-- more sophisticated analysis of A_Constrained_Array_Definition
-- Result := Subtype_Model_Kind
-- (Component_Subtype_Indication
-- (Array_Component_Definition (Type_Definition)));
--
-- if Result = A_Simple_Static_Model then
-- -- Here we have to check if the whole type is also static
--
-- Type_Entity := R_Node (Type_Definition);
-- Type_Entity :=
-- Sinfo.Defining_Identifier (Parent (Type_Entity));
--
-- if not Einfo.Size_Known_At_Compile_Time (Type_Entity) then
-- Result := A_Simple_Dynamic_Model;
-- end if;
--
-- end if;
when A_Record_Type_Definition =>
Result := Record_Model_Kind (Type_Definition);
when A_Derived_Record_Extension_Definition |
A_Tagged_Record_Type_Definition =>
-- We consider tagged types as too complex for DDA without any
-- further analysis
Result := A_Complex_Dynamic_Model;
when others =>
null;
end case;
return Result;
exception
when ASIS_Inappropriate_Element | ASIS_Failed =>
Add_Call_Information (Outer_Call =>
Package_Name & "Type_Model_Kind (from type definition)");
raise;
when others =>
Raise_ASIS_Failed (Diagnosis =>
Package_Name & "Type_Model_Kind (from type definition)");
end Type_Model_Kind;
end Asis.Data_Decomposition