507 lines
14 KiB
Ada
507 lines
14 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT COMPILER COMPONENTS --
|
|
-- --
|
|
-- E X P _ T S S --
|
|
-- --
|
|
-- B o d y --
|
|
-- --
|
|
-- Copyright (C) 1992-2009, 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 3, 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 COPYING3. If not, go to --
|
|
-- http://www.gnu.org/licenses for a complete copy of the license. --
|
|
-- --
|
|
-- GNAT was originally developed by the GNAT team at New York University. --
|
|
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
-- --
|
|
------------------------------------------------------------------------------
|
|
|
|
with Atree; use Atree;
|
|
with Einfo; use Einfo;
|
|
with Elists; use Elists;
|
|
with Exp_Util; use Exp_Util;
|
|
with Nlists; use Nlists;
|
|
with Lib; use Lib;
|
|
with Restrict; use Restrict;
|
|
with Rident; use Rident;
|
|
with Sem_Aux; use Sem_Aux;
|
|
with Sem_Util; use Sem_Util;
|
|
with Sinfo; use Sinfo;
|
|
|
|
package body Exp_Tss is
|
|
|
|
--------------------
|
|
-- Base_Init_Proc --
|
|
--------------------
|
|
|
|
function Base_Init_Proc
|
|
(Typ : Entity_Id;
|
|
Ref : Entity_Id := Empty) return Entity_Id
|
|
is
|
|
Full_Type : E;
|
|
Proc : Entity_Id;
|
|
|
|
begin
|
|
pragma Assert (Is_Type (Typ));
|
|
|
|
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
|
|
-- The initialization routine to be called is that of the base type
|
|
-- of the corresponding record type, which may itself be a subtype
|
|
-- and possibly an itype.
|
|
|
|
return Init_Proc
|
|
(Base_Type (Corresponding_Record_Type (Base_Type (Full_Type))),
|
|
Ref);
|
|
|
|
else
|
|
Proc := Init_Proc (Base_Type (Full_Type), Ref);
|
|
|
|
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), Ref);
|
|
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;
|
|
|
|
------------------------
|
|
-- Find_Inherited_TSS --
|
|
------------------------
|
|
|
|
function Find_Inherited_TSS
|
|
(Typ : Entity_Id;
|
|
Nam : TSS_Name_Type) return Entity_Id
|
|
is
|
|
Btyp : Entity_Id := Typ;
|
|
Proc : Entity_Id;
|
|
|
|
begin
|
|
loop
|
|
Btyp := Base_Type (Btyp);
|
|
Proc := TSS (Btyp, Nam);
|
|
|
|
exit when Present (Proc)
|
|
or else not Is_Derived_Type (Btyp);
|
|
|
|
-- If Typ is a derived type, it may inherit attributes from some
|
|
-- ancestor.
|
|
|
|
Btyp := Etype (Btyp);
|
|
end loop;
|
|
|
|
if No (Proc) then
|
|
|
|
-- If nothing else, use the TSS of the root type
|
|
|
|
Proc := TSS (Base_Type (Underlying_Type (Typ)), Nam);
|
|
end if;
|
|
|
|
return Proc;
|
|
end Find_Inherited_TSS;
|
|
|
|
-----------------------
|
|
-- Get_TSS_Name_Type --
|
|
-----------------------
|
|
|
|
function Get_TSS_Name (E : Entity_Id) return TSS_Name_Type is
|
|
C1 : Character;
|
|
C2 : Character;
|
|
Nm : TSS_Name_Type;
|
|
|
|
begin
|
|
Get_Last_Two_Chars (Chars (E), C1, C2);
|
|
|
|
if C1 in 'A' .. 'Z' and then C2 in 'A' .. 'Z' then
|
|
Nm := (C1, C2);
|
|
|
|
for J in TSS_Names'Range loop
|
|
if Nm = TSS_Names (J) then
|
|
return Nm;
|
|
end if;
|
|
end loop;
|
|
end if;
|
|
|
|
return TSS_Null;
|
|
end Get_TSS_Name;
|
|
|
|
---------------------------------
|
|
-- Has_Non_Null_Base_Init_Proc --
|
|
---------------------------------
|
|
|
|
-- Note: if a base Init_Proc is present, and No_Default_Initialization is
|
|
-- present, then we must avoid testing for a null init proc, since there
|
|
-- is no init proc present in this case.
|
|
|
|
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 (Restriction_Active (No_Default_Initialization)
|
|
or else not Is_Null_Init_Proc (BIP));
|
|
end Has_Non_Null_Base_Init_Proc;
|
|
|
|
---------------
|
|
-- Init_Proc --
|
|
---------------
|
|
|
|
function Init_Proc
|
|
(Typ : Entity_Id;
|
|
Ref : Entity_Id := Empty) return Entity_Id
|
|
is
|
|
FN : constant Node_Id := Freeze_Node (Typ);
|
|
Elmt : Elmt_Id;
|
|
E1 : Entity_Id;
|
|
E2 : Entity_Id;
|
|
|
|
begin
|
|
if No (FN) then
|
|
return Empty;
|
|
|
|
elsif No (TSS_Elist (FN)) then
|
|
return Empty;
|
|
|
|
elsif No (Ref) then
|
|
Elmt := First_Elmt (TSS_Elist (FN));
|
|
while Present (Elmt) loop
|
|
if Is_Init_Proc (Node (Elmt)) then
|
|
if not Is_CPP_Class (Typ) then
|
|
return Node (Elmt);
|
|
|
|
-- For CPP classes, we are looking for the default constructor,
|
|
-- and so we must skip any non-default constructor.
|
|
|
|
elsif
|
|
No (Next
|
|
(First
|
|
(Parameter_Specifications (Parent (Node (Elmt))))))
|
|
then
|
|
return Node (Elmt);
|
|
end if;
|
|
end if;
|
|
|
|
Next_Elmt (Elmt);
|
|
end loop;
|
|
|
|
-- Non-default constructors are currently supported only in the context
|
|
-- of interfacing with C++.
|
|
|
|
else pragma Assert (Is_CPP_Class (Typ));
|
|
|
|
-- Use the referenced function to locate the init_proc matching
|
|
-- the C++ constructor.
|
|
|
|
Elmt := First_Elmt (TSS_Elist (FN));
|
|
while Present (Elmt) loop
|
|
if Is_Init_Proc (Node (Elmt)) then
|
|
E1 := Next_Formal (First_Formal (Node (Elmt)));
|
|
E2 := First_Formal (Ref);
|
|
while Present (E1) and then Present (E2) loop
|
|
if Chars (E1) /= Chars (E2)
|
|
or else Ekind (E1) /= Ekind (E2)
|
|
then
|
|
exit;
|
|
|
|
elsif Ekind (Etype (E1)) /= E_Anonymous_Access_Type
|
|
and then Ekind (Etype (E2)) /= E_Anonymous_Access_Type
|
|
and then Etype (E1) /= Etype (E2)
|
|
then
|
|
exit;
|
|
|
|
elsif Ekind (Etype (E1)) = E_Anonymous_Access_Type
|
|
and then Ekind (Etype (E2)) = E_Anonymous_Access_Type
|
|
and then Directly_Designated_Type (Etype (E1))
|
|
/= Directly_Designated_Type (Etype (E2))
|
|
then
|
|
exit;
|
|
end if;
|
|
|
|
E1 := Next_Formal (E1);
|
|
E2 := Next_Formal (E2);
|
|
end loop;
|
|
|
|
if No (E1) and then No (E2) then
|
|
return Node (Elmt);
|
|
end if;
|
|
end if;
|
|
|
|
Next_Elmt (Elmt);
|
|
end loop;
|
|
end if;
|
|
|
|
return Empty;
|
|
end Init_Proc;
|
|
|
|
------------------
|
|
-- Is_Init_Proc --
|
|
------------------
|
|
|
|
function Is_Init_Proc (E : Entity_Id) return Boolean is
|
|
C1 : Character;
|
|
C2 : Character;
|
|
begin
|
|
Get_Last_Two_Chars (Chars (E), C1, C2);
|
|
return C1 = TSS_Init_Proc (1) and then C2 = TSS_Init_Proc (2);
|
|
end Is_Init_Proc;
|
|
|
|
------------
|
|
-- Is_TSS --
|
|
------------
|
|
|
|
function Is_TSS (E : Entity_Id; Nam : TSS_Name_Type) return Boolean is
|
|
C1 : Character;
|
|
C2 : Character;
|
|
begin
|
|
Get_Last_Two_Chars (Chars (E), C1, C2);
|
|
return C1 = Nam (1) and then C2 = Nam (2);
|
|
end Is_TSS;
|
|
|
|
function Is_TSS (N : Name_Id; Nam : TSS_Name_Type) return Boolean is
|
|
C1 : Character;
|
|
C2 : Character;
|
|
begin
|
|
Get_Last_Two_Chars (N, C1, C2);
|
|
return C1 = Nam (1) and then C2 = Nam (2);
|
|
end Is_TSS;
|
|
|
|
-------------------------
|
|
-- Make_Init_Proc_Name --
|
|
-------------------------
|
|
|
|
function Make_Init_Proc_Name (Typ : Entity_Id) return Name_Id is
|
|
begin
|
|
return Make_TSS_Name (Typ, TSS_Init_Proc);
|
|
end Make_Init_Proc_Name;
|
|
|
|
-------------------
|
|
-- Make_TSS_Name --
|
|
-------------------
|
|
|
|
function Make_TSS_Name
|
|
(Typ : Entity_Id;
|
|
Nam : TSS_Name_Type) return Name_Id
|
|
is
|
|
begin
|
|
Get_Name_String (Chars (Typ));
|
|
Add_Char_To_Name_Buffer (Nam (1));
|
|
Add_Char_To_Name_Buffer (Nam (2));
|
|
return Name_Find;
|
|
end Make_TSS_Name;
|
|
|
|
-------------------------
|
|
-- Make_TSS_Name_Local --
|
|
-------------------------
|
|
|
|
function Make_TSS_Name_Local
|
|
(Typ : Entity_Id;
|
|
Nam : TSS_Name_Type) return Name_Id
|
|
is
|
|
begin
|
|
Get_Name_String (Chars (Typ));
|
|
Add_Char_To_Name_Buffer ('_');
|
|
Add_Nat_To_Name_Buffer (Increment_Serial_Number);
|
|
Add_Char_To_Name_Buffer (Nam (1));
|
|
Add_Char_To_Name_Buffer (Nam (2));
|
|
return Name_Find;
|
|
end Make_TSS_Name_Local;
|
|
|
|
--------------
|
|
-- Same_TSS --
|
|
--------------
|
|
|
|
function Same_TSS (E1, E2 : Entity_Id) return Boolean is
|
|
E1C1 : Character;
|
|
E1C2 : Character;
|
|
E2C1 : Character;
|
|
E2C2 : Character;
|
|
|
|
begin
|
|
Get_Last_Two_Chars (Chars (E1), E1C1, E1C2);
|
|
Get_Last_Two_Chars (Chars (E2), E2C1, E2C2);
|
|
|
|
return
|
|
E1C1 = E2C1
|
|
and then
|
|
E1C2 = E2C2
|
|
and then
|
|
E1C1 in 'A' .. 'Z'
|
|
and then
|
|
E1C2 in 'A' .. 'Z';
|
|
end Same_TSS;
|
|
|
|
-------------------
|
|
-- 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
|
|
begin
|
|
-- Make sure body of subprogram is frozen
|
|
|
|
-- Skip this for Init_Proc with No_Default_Initialization, since the
|
|
-- Init proc is a dummy void entity in this case to be ignored.
|
|
|
|
if Is_Init_Proc (TSS)
|
|
and then Restriction_Active (No_Default_Initialization)
|
|
then
|
|
null;
|
|
|
|
-- Skip this if not in the same code unit (since it means we are using
|
|
-- an already existing TSS in another unit)
|
|
|
|
elsif not In_Same_Code_Unit (Typ, TSS) then
|
|
null;
|
|
|
|
-- Otherwise make sure body is frozen
|
|
|
|
else
|
|
Append_Freeze_Action (Typ, Unit_Declaration_Node (TSS));
|
|
end if;
|
|
|
|
-- Set TSS entry
|
|
|
|
Copy_TSS (TSS, Typ);
|
|
end Set_TSS;
|
|
|
|
---------
|
|
-- TSS --
|
|
---------
|
|
|
|
function TSS (Typ : Entity_Id; Nam : TSS_Name_Type) 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 Is_TSS (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;
|
|
|
|
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;
|