201 lines
6.4 KiB
Ada
201 lines
6.4 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT COMPILER COMPONENTS --
|
|
-- --
|
|
-- E X P _ T S S --
|
|
-- --
|
|
-- B o d y --
|
|
-- --
|
|
-- $Revision: 1.26 $
|
|
-- --
|
|
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
|
|
-- --
|
|
-- GNAT is free software; you can redistribute it and/or modify it under --
|
|
-- terms of the GNU General Public License as published by the Free Soft- --
|
|
-- ware Foundation; either version 2, or (at your option) any later ver- --
|
|
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
|
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
|
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
|
|
-- for more details. You should have received a copy of the GNU General --
|
|
-- Public License distributed with GNAT; see file COPYING. If not, write --
|
|
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
|
-- MA 02111-1307, USA. --
|
|
-- --
|
|
-- GNAT was originally developed by the GNAT team at New York University. --
|
|
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
|
-- --
|
|
------------------------------------------------------------------------------
|
|
|
|
with Atree; use Atree;
|
|
with Einfo; use Einfo;
|
|
with Elists; use Elists;
|
|
with Exp_Util; use Exp_Util;
|
|
with Lib; use Lib;
|
|
with Sem_Util; use Sem_Util;
|
|
with Sinfo; use Sinfo;
|
|
with Snames; use Snames;
|
|
|
|
package body Exp_Tss is
|
|
|
|
--------------------
|
|
-- Base_Init_Proc --
|
|
--------------------
|
|
|
|
function Base_Init_Proc (Typ : Entity_Id) return Entity_Id is
|
|
Full_Type : E;
|
|
Proc : Entity_Id;
|
|
|
|
begin
|
|
pragma Assert (Ekind (Typ) in Type_Kind);
|
|
|
|
if Is_Private_Type (Typ) then
|
|
Full_Type := Underlying_Type (Base_Type (Typ));
|
|
else
|
|
Full_Type := Typ;
|
|
end if;
|
|
|
|
if No (Full_Type) then
|
|
return Empty;
|
|
elsif Is_Concurrent_Type (Full_Type)
|
|
and then Present (Corresponding_Record_Type (Base_Type (Full_Type)))
|
|
then
|
|
return Init_Proc (Corresponding_Record_Type (Base_Type (Full_Type)));
|
|
|
|
else
|
|
Proc := Init_Proc (Base_Type (Full_Type));
|
|
|
|
if No (Proc)
|
|
and then Is_Composite_Type (Full_Type)
|
|
and then Is_Derived_Type (Full_Type)
|
|
then
|
|
return Init_Proc (Root_Type (Full_Type));
|
|
else
|
|
return Proc;
|
|
end if;
|
|
end if;
|
|
end Base_Init_Proc;
|
|
|
|
--------------
|
|
-- Copy_TSS --
|
|
--------------
|
|
|
|
-- Note: internally this routine is also used to initially set up
|
|
-- a TSS entry for a new type (case of being called from Set_TSS)
|
|
|
|
procedure Copy_TSS (TSS : Entity_Id; Typ : Entity_Id) is
|
|
FN : Node_Id;
|
|
|
|
begin
|
|
Ensure_Freeze_Node (Typ);
|
|
FN := Freeze_Node (Typ);
|
|
|
|
if No (TSS_Elist (FN)) then
|
|
Set_TSS_Elist (FN, New_Elmt_List);
|
|
end if;
|
|
|
|
-- We prepend here, so that a second call overrides the first, it
|
|
-- is not clear that this is required, but it seems reasonable.
|
|
|
|
Prepend_Elmt (TSS, TSS_Elist (FN));
|
|
end Copy_TSS;
|
|
|
|
---------------------------------
|
|
-- Has_Non_Null_Base_Init_Proc --
|
|
---------------------------------
|
|
|
|
function Has_Non_Null_Base_Init_Proc (Typ : Entity_Id) return Boolean is
|
|
BIP : constant Entity_Id := Base_Init_Proc (Typ);
|
|
|
|
begin
|
|
return Present (BIP) and then not Is_Null_Init_Proc (BIP);
|
|
end Has_Non_Null_Base_Init_Proc;
|
|
|
|
---------------
|
|
-- Init_Proc --
|
|
---------------
|
|
|
|
function Init_Proc (Typ : Entity_Id) return Entity_Id is
|
|
begin
|
|
return TSS (Typ, Name_uInit_Proc);
|
|
end Init_Proc;
|
|
|
|
-------------------
|
|
-- Set_Init_Proc --
|
|
-------------------
|
|
|
|
procedure Set_Init_Proc (Typ : Entity_Id; Init : Entity_Id) is
|
|
begin
|
|
Set_TSS (Typ, Init);
|
|
end Set_Init_Proc;
|
|
|
|
-------------
|
|
-- Set_TSS --
|
|
-------------
|
|
|
|
procedure Set_TSS (Typ : Entity_Id; TSS : Entity_Id) is
|
|
Subprog_Body : constant Node_Id := Unit_Declaration_Node (TSS);
|
|
|
|
begin
|
|
-- Case of insertion location is in unit defining the type
|
|
|
|
if In_Same_Code_Unit (Typ, TSS) then
|
|
Append_Freeze_Action (Typ, Subprog_Body);
|
|
|
|
-- Otherwise, we are using an already existing TSS in another unit
|
|
|
|
else
|
|
null;
|
|
end if;
|
|
|
|
Copy_TSS (TSS, Typ);
|
|
end Set_TSS;
|
|
|
|
---------
|
|
-- TSS --
|
|
---------
|
|
|
|
function TSS (Typ : Entity_Id; Nam : Name_Id) return Entity_Id is
|
|
FN : constant Node_Id := Freeze_Node (Typ);
|
|
Elmt : Elmt_Id;
|
|
Subp : Entity_Id;
|
|
|
|
begin
|
|
if No (FN) then
|
|
return Empty;
|
|
|
|
elsif No (TSS_Elist (FN)) then
|
|
return Empty;
|
|
|
|
else
|
|
Elmt := First_Elmt (TSS_Elist (FN));
|
|
|
|
while Present (Elmt) loop
|
|
if Chars (Node (Elmt)) = Nam then
|
|
Subp := Node (Elmt);
|
|
|
|
-- For stream subprograms, the TSS entity may be a renaming-
|
|
-- as-body of an already generated entity. Use that one rather
|
|
-- the one introduced by the renaming, which is an artifact of
|
|
-- current stream handling.
|
|
|
|
if Nkind (Parent (Parent (Subp))) =
|
|
N_Subprogram_Renaming_Declaration
|
|
and then
|
|
Present (Corresponding_Spec (Parent (Parent (Subp))))
|
|
then
|
|
return Corresponding_Spec (Parent (Parent (Subp)));
|
|
else
|
|
return Subp;
|
|
end if;
|
|
|
|
else
|
|
Next_Elmt (Elmt);
|
|
end if;
|
|
end loop;
|
|
end if;
|
|
|
|
return Empty;
|
|
end TSS;
|
|
|
|
end Exp_Tss;
|