1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
10 -- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- GNAT was originally developed by the GNAT team at New York University. --
24 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
26 ------------------------------------------------------------------------------
28 with Atree; use Atree;
29 with Einfo; use Einfo;
30 with Elists; use Elists;
31 with Exp_Util; use Exp_Util;
33 with Sem_Util; use Sem_Util;
34 with Sinfo; use Sinfo;
35 with Snames; use Snames;
37 package body Exp_Tss is
43 function Base_Init_Proc (Typ : Entity_Id) return Entity_Id is
48 pragma Assert (Ekind (Typ) in Type_Kind);
50 if Is_Private_Type (Typ) then
51 Full_Type := Underlying_Type (Base_Type (Typ));
56 if No (Full_Type) then
58 elsif Is_Concurrent_Type (Full_Type)
59 and then Present (Corresponding_Record_Type (Base_Type (Full_Type)))
61 return Init_Proc (Corresponding_Record_Type (Base_Type (Full_Type)));
64 Proc := Init_Proc (Base_Type (Full_Type));
67 and then Is_Composite_Type (Full_Type)
68 and then Is_Derived_Type (Full_Type)
70 return Init_Proc (Root_Type (Full_Type));
81 -- Note: internally this routine is also used to initially set up
82 -- a TSS entry for a new type (case of being called from Set_TSS)
84 procedure Copy_TSS (TSS : Entity_Id; Typ : Entity_Id) is
88 Ensure_Freeze_Node (Typ);
89 FN := Freeze_Node (Typ);
91 if No (TSS_Elist (FN)) then
92 Set_TSS_Elist (FN, New_Elmt_List);
95 -- We prepend here, so that a second call overrides the first, it
96 -- is not clear that this is required, but it seems reasonable.
98 Prepend_Elmt (TSS, TSS_Elist (FN));
101 ---------------------------------
102 -- Has_Non_Null_Base_Init_Proc --
103 ---------------------------------
105 function Has_Non_Null_Base_Init_Proc (Typ : Entity_Id) return Boolean is
106 BIP : constant Entity_Id := Base_Init_Proc (Typ);
109 return Present (BIP) and then not Is_Null_Init_Proc (BIP);
110 end Has_Non_Null_Base_Init_Proc;
116 function Init_Proc (Typ : Entity_Id) return Entity_Id is
118 return TSS (Typ, Name_uInit_Proc);
125 procedure Set_Init_Proc (Typ : Entity_Id; Init : Entity_Id) is
134 procedure Set_TSS (Typ : Entity_Id; TSS : Entity_Id) is
135 Subprog_Body : constant Node_Id := Unit_Declaration_Node (TSS);
138 -- Case of insertion location is in unit defining the type
140 if In_Same_Code_Unit (Typ, TSS) then
141 Append_Freeze_Action (Typ, Subprog_Body);
143 -- Otherwise, we are using an already existing TSS in another unit
156 function TSS (Typ : Entity_Id; Nam : Name_Id) return Entity_Id is
157 FN : constant Node_Id := Freeze_Node (Typ);
165 elsif No (TSS_Elist (FN)) then
169 Elmt := First_Elmt (TSS_Elist (FN));
171 while Present (Elmt) loop
172 if Chars (Node (Elmt)) = Nam then
175 -- For stream subprograms, the TSS entity may be a renaming-
176 -- as-body of an already generated entity. Use that one rather
177 -- the one introduced by the renaming, which is an artifact of
178 -- current stream handling.
180 if Nkind (Parent (Parent (Subp))) =
181 N_Subprogram_Renaming_Declaration
183 Present (Corresponding_Spec (Parent (Parent (Subp))))
185 return Corresponding_Spec (Parent (Parent (Subp)));