File : asis-data_decomposition-set_get.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 . S E T _ G E T --
-- --
-- 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 Asis.Iterator; use Asis.Iterator;
with Asis.Elements; use Asis.Elements;
with Asis.Extensions; use Asis.Extensions;
with Asis.Set_Get; use Asis.Set_Get;
with Asis.Data_Decomposition.Aux; use Asis.Data_Decomposition.Aux;
with A4G.Int_Knds; use A4G.Int_Knds;
with A4G.Contt; use A4G.Contt;
with Atree; use Atree;
with Sinfo; use Sinfo;
with Einfo; use Einfo;
with Nlists; use Nlists;
with Uintp; use Uintp;
with Repinfo; use Repinfo;
package body Asis.Data_Decomposition.Set_Get is
---------------------------
-- Parent_Component_Name --
---------------------------
function Parent_Component_Name (Comp : AC) return Asis.Defining_Name is
begin
return Comp.Parent_Component_Name;
end Parent_Component_Name;
--------------------
-- Component_Name --
--------------------
function Component_Name (Comp : RC) return Asis.Defining_Name is
begin
return Comp.Component_Name;
end Component_Name;
---------------
-- Dimension --
---------------
function Dimension (Comp : AC) return ASIS_Natural
is
begin
return Comp.Dimension;
end Dimension;
---------------
-- First_Bit --
---------------
function First_Bit (Comp : RC) return ASIS_Natural is
begin
return Comp.First_Bit;
end First_Bit;
---------------
-- First_Bit --
---------------
function First_Bit (Comp : AC) return ASIS_Natural is
begin
return Comp.First_Bit;
end First_Bit;
---------------------------
-- Get_Array_Type_Entity --
---------------------------
function Get_Array_Type_Entity (Comp : AC) return Entity_Id is
Result : Entity_Id;
begin
-- ???!!! This is a trick needed to reset the right tree!
-- ???!!! Should be replaced by a proper tree handling for
-- ???!!! array components
Result := Node (Comp.Parent_Array_Type);
Result := Comp.Array_Type_Entity;
return Result;
end Get_Array_Type_Entity;
---------------------
-- Get_Comp_Entity --
---------------------
function Get_Comp_Entity (Comp : RC) return Entity_Id is
begin
return R_Node (Component_Name (Comp));
end Get_Comp_Entity;
-----------------------
-- Get_Record_Entity --
-----------------------
function Get_Record_Entity (Comp : RC) return Entity_Id is
Result : Entity_Id;
begin
Result := R_Node (Parent_Record_Type (Comp));
while Nkind (Result) /= N_Full_Type_Declaration loop
Result := Parent (Result);
end loop;
Result := Defining_Identifier (Result);
return Result;
end Get_Record_Entity;
---------------------
-- Get_Type_Entity --
---------------------
function Get_Type_Entity (Comp : RC) return Node_Id is
begin
return Etype (R_Node (Component_Name (Comp)));
end Get_Type_Entity;
-------------------
-- Is_Array_Comp --
-------------------
function Is_Array_Comp (Comp : AC) return Boolean is
begin
return Comp.Is_Array_Comp;
end Is_Array_Comp;
function Is_Array_Comp (Comp : RC) return Boolean is
begin
return Comp.Is_Array_Comp;
end Is_Array_Comp;
--------------------
-- Is_Record_Comp --
--------------------
function Is_Record_Comp (Comp : AC) return Boolean is
begin
return Comp.Is_Record_Comp;
end Is_Record_Comp;
function Is_Record_Comp (Comp : RC) return Boolean is
begin
return Comp.Is_Record_Comp;
end Is_Record_Comp;
--------------
-- Last_Bit --
--------------
function Last_Bit (Comp : RC) return ASIS_Natural is
begin
return Comp.Last_Bit;
end Last_Bit;
--------------
-- Last_Bit --
--------------
function Last_Bit (Comp : AC) return ASIS_Natural is
begin
return Comp.Last_Bit;
end Last_Bit;
--------------
-- Obtained --
--------------
function Obtained (Comp : RC) return ASIS_OS_Time is
begin
return Comp.Obtained;
end Obtained;
--------------
-- Obtained --
--------------
function Obtained (Comp : AC) return ASIS_OS_Time is
begin
return Comp.Obtained;
end Obtained;
--------------------
-- Parent_Context --
--------------------
function Parent_Context (Comp : RC) return Context_Id is
begin
return Comp.Parent_Context;
end Parent_Context;
-----------------------
-- Parent_Array_Type --
-----------------------
function Parent_Array_Type (Comp : AC) return Asis.Declaration is
begin
return Comp.Parent_Array_Type;
end Parent_Array_Type;
--------------------
-- Parent_Context --
--------------------
function Parent_Context (Comp : AC) return Context_Id is
begin
return Comp.Parent_Context;
end Parent_Context;
---------------------
-- Parent_Discrims --
---------------------
function Parent_Discrims (Comp : AC) return Discrim_List is
begin
if Comp.Parent_Discrims = null then
return Null_Discrims;
else
return Comp.Parent_Discrims.all;
end if;
end Parent_Discrims;
function Parent_Discrims (Comp : RC) return Discrim_List is
begin
if Comp.Parent_Discrims = null then
return Null_Discrims;
else
return Comp.Parent_Discrims.all;
end if;
end Parent_Discrims;
------------------------
-- Parent_Record_Type --
------------------------
function Parent_Record_Type (Comp : RC) return Asis.Declaration is
begin
return Comp.Parent_Record_Type;
end Parent_Record_Type;
--------------
-- Position --
--------------
function Position (Comp : RC) return ASIS_Natural is
begin
return Comp.Position;
end Position;
--------------
-- Position --
--------------
function Position (Comp : AC) return ASIS_Natural is
begin
return Comp.Position;
end Position;
-------------------------
-- Set_Array_Componnet --
-------------------------
function Set_Array_Componnet
(Array_Type_Definition : Element;
Enclosing_Record_Component : Record_Component := Nil_Record_Component;
Parent_Indication : Element := Nil_Element;
Parent_Discriminants : Discrim_List := Null_Discrims;
Parent_First_Bit_Offset : ASIS_Natural := 0)
return Array_Component
is
Comp_Node : Node_Id;
Comp_Type_Entity : Node_Id;
Result : Array_Component := Nil_Array_Component;
Enclosing_Array_Type : Element;
Array_Entity : Entity_Id;
-- This should be a type entity defining the enclosed
-- array type. This may be an implicit type created by the compiler,
-- but the point is that in should contain real ranges for
-- this component
Dim : Asis.ASIS_Positive;
Tmp_Node : Node_Id;
Comp_Size : ASIS_Natural;
begin
Result.Parent_Array_Type := Array_Type_Definition;
Result.Parent_Component_Name :=
Component_Name (Enclosing_Record_Component);
Comp_Node := Node (Array_Type_Definition);
Comp_Type_Entity := Defining_Identifier (Parent (Comp_Node));
Comp_Type_Entity := Component_Type (Comp_Type_Entity);
Result.Is_Record_Comp := Is_Record_Type (Comp_Type_Entity);
Result.Is_Array_Comp := Is_Array_Type (Comp_Type_Entity);
if not Is_Nil (Enclosing_Record_Component) then
Array_Entity := R_Node (Enclosing_Record_Component.Component_Name);
Array_Entity := Etype (Array_Entity);
elsif not Is_Nil (Parent_Indication) then
Enclosing_Array_Type := Enclosing_Element (Parent_Indication);
Enclosing_Array_Type := Enclosing_Element (Enclosing_Array_Type);
Enclosing_Array_Type := Enclosing_Element (Enclosing_Array_Type);
Array_Entity := Defining_Identifier (R_Node (Enclosing_Array_Type));
Array_Entity := Component_Type (Array_Entity);
else
Enclosing_Array_Type := Enclosing_Element (Array_Type_Definition);
Array_Entity := Defining_Identifier (R_Node (Enclosing_Array_Type));
end if;
Result.Array_Type_Entity := Array_Entity;
-- Computing dimentions and lengths:
Tmp_Node := First_Index (Array_Entity);
Dim := ASIS_Positive (List_Length (List_Containing (Tmp_Node)));
Result.Dimension := Dim;
Result.Length := (others => 0);
for I in 1 .. Dim loop
Result.Length (I) := Get_Length (Typ => Array_Entity,
Sub => I,
Discs => Parent_Discriminants);
end loop;
Comp_Size := ASIS_Natural (UI_To_Int (
Get_Component_Size (Array_Entity)));
Result.Position := Parent_First_Bit_Offset / Storage_Unit;
Result.First_Bit := Parent_First_Bit_Offset mod Storage_Unit;
Result.Last_Bit := Result.First_Bit + Comp_Size - 1;
Result.Size := Comp_Size;
Set_Parent_Discrims (Result, Parent_Discriminants);
Result.Parent_Context := Get_Current_Cont;
Result.Obtained := A_OS_Time;
return Result;
end Set_Array_Componnet;
------------------------------
-- Set_All_Named_Components --
------------------------------
procedure Set_All_Named_Components (E : Element) is
Discr_Part : Element;
Root_Type : Element;
begin
Discr_Part := Discriminant_Part_From_Type_Definition (E);
Root_Type := Root_Record_Definition (E);
Set_Named_Components (Discr_Part, New_List);
Set_Named_Components (Root_Type, Append);
end Set_All_Named_Components;
--------------------------
-- Set_Named_Components --
--------------------------
procedure Set_Named_Components (E : Element; List_Kind : List_Kinds) is
Control : Traverse_Control := Continue;
State : No_State := Not_Used;
New_Name : Asis.List_Index;
procedure Set_Def_Name
(Element : Asis.Element;
Control : in out Traverse_Control;
State : in out No_State);
-- If Element is of A_Defining_Identifier kind, this procedure stores
-- it in the Asis Element Table. Used as Pre-Operation
procedure Set_Def_Name
(Element : Asis.Element;
Control : in out Traverse_Control;
State : in out No_State)
is
begin
if Int_Kind (Element) /= A_Defining_Identifier then
return;
end if;
New_Name := Asis_Element_Table.Allocate;
Def_N_Table (New_Name) := Element;
end Set_Def_Name;
procedure Create_Name_List is new Traverse_Element (
State_Information => No_State,
Pre_Operation => Set_Def_Name,
Post_Operation => No_Op);
begin
if List_Kind = New_List then
Asis_Element_Table.Init;
end if;
if Is_Nil (E) then
return;
end if;
Create_Name_List
(Element => E,
Control => Control,
State => State);
end Set_Named_Components;
-------------------------
-- Set_Parent_Discrims --
-------------------------
procedure Set_Parent_Discrims (Comp : in out AC; Discs : Discrim_List) is
begin
if Discs = Null_Discrims then
Comp.Parent_Discrims := null;
else
Comp.Parent_Discrims := new Discrim_List'(Discs);
end if;
end Set_Parent_Discrims;
--------------------------------
-- Set_Parent_Type_Definition --
--------------------------------
procedure Set_Parent_Type_Definition (E : Element) is
begin
Parent_Type_Definition := E;
end Set_Parent_Type_Definition;
--------------------------------------
-- Set_Record_Components_From_Names --
--------------------------------------
procedure Set_Record_Components_From_Names
(Data_Stream : Portable_Data := Nil_Portable_Data;
Parent_First_Bit_Offset : ASIS_Natural := 0)
is
New_Comp : Asis.List_Index;
Component_Name : Element;
Comp_Entity : Node_Id;
Rec_Entity : Node_Id :=
Defining_Identifier (Parent (R_Node (Parent_Type_Definition)));
Discs : Discrim_List :=
Build_Discrim_List_If_Data_Presented
(Rec => Rec_Entity,
Data => Data_Stream);
Comp_Type_Entity : Node_Id;
Comp_First_Bit_Offset : ASIS_Natural;
Comp_Size : ASIS_Natural;
begin
Record_Component_Table.Init;
for I in 1 .. Asis_Element_Table.Last loop
Component_Name := Def_N_Table (I);
Comp_Entity := Node (Component_Name);
if Discs = Null_Discrims or else
Component_Present (Comp_Entity, Discs)
then
New_Comp := Record_Component_Table.Allocate;
RC_Table (New_Comp).Parent_Record_Type := Parent_Type_Definition;
RC_Table (New_Comp).Component_Name := Component_Name;
Comp_Type_Entity := Etype (Comp_Entity);
RC_Table (New_Comp).Is_Record_Comp :=
Is_Record_Type (Comp_Type_Entity);
RC_Table (New_Comp).Is_Array_Comp :=
Is_Array_Type (Comp_Type_Entity);
if Discs = Null_Discrims then
RC_Table (New_Comp).Parent_Discrims := null;
else
RC_Table (New_Comp).Parent_Discrims :=
new Discrim_List'(Discs);
end if;
Comp_First_Bit_Offset :=
Parent_First_Bit_Offset +
ASIS_Natural (UI_To_Int (
Get_Component_First_Bit (Comp_Entity, Discs)));
Comp_Size := ASIS_Natural (UI_To_Int
(Get_Esize (Comp_Entity, Discs)));
RC_Table (New_Comp).First_Bit_Offset := Comp_First_Bit_Offset;
RC_Table (New_Comp).Position :=
Comp_First_Bit_Offset / Storage_Unit;
RC_Table (New_Comp).First_Bit :=
Comp_First_Bit_Offset mod Storage_Unit;
RC_Table (New_Comp).Last_Bit :=
RC_Table (New_Comp).First_Bit + Comp_Size - 1;
RC_Table (New_Comp).Size := Comp_Size;
RC_Table (New_Comp).Parent_Context := Get_Current_Cont;
RC_Table (New_Comp).Obtained := A_OS_Time;
end if;
end loop;
end Set_Record_Components_From_Names;
----------
-- Size --
----------
function Size (Comp : RC) return ASIS_Natural is
begin
return Comp.Size;
end Size;
----------
-- Size --
----------
function Size (Comp : AC) return ASIS_Natural is
begin
return Comp.Size;
end Size;
end Asis.Data_Decomposition.Set_Get