1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
|
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- E X P _ T S S --
-- --
-- B o d y --
-- --
-- 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. --
-- 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 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;
|
