annotate gcc/ada/exp_tss.adb @ 143:76e1cf5455ef

add cbc_gc test
author Shinji KONO <kono@ie.u-ryukyu.ac.jp>
date Sun, 23 Dec 2018 19:24:05 +0900
parents 84e7813d76e9
children 1830386684a0
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
111
kono
parents:
diff changeset
1 ------------------------------------------------------------------------------
kono
parents:
diff changeset
2 -- --
kono
parents:
diff changeset
3 -- GNAT COMPILER COMPONENTS --
kono
parents:
diff changeset
4 -- --
kono
parents:
diff changeset
5 -- E X P _ T S S --
kono
parents:
diff changeset
6 -- --
kono
parents:
diff changeset
7 -- B o d y --
kono
parents:
diff changeset
8 -- --
131
84e7813d76e9 gcc-8.2
mir3636
parents: 111
diff changeset
9 -- Copyright (C) 1992-2018, Free Software Foundation, Inc. --
111
kono
parents:
diff changeset
10 -- --
kono
parents:
diff changeset
11 -- GNAT is free software; you can redistribute it and/or modify it under --
kono
parents:
diff changeset
12 -- terms of the GNU General Public License as published by the Free Soft- --
kono
parents:
diff changeset
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
kono
parents:
diff changeset
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
kono
parents:
diff changeset
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
kono
parents:
diff changeset
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
kono
parents:
diff changeset
17 -- for more details. You should have received a copy of the GNU General --
kono
parents:
diff changeset
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
kono
parents:
diff changeset
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
kono
parents:
diff changeset
20 -- --
kono
parents:
diff changeset
21 -- GNAT was originally developed by the GNAT team at New York University. --
kono
parents:
diff changeset
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
kono
parents:
diff changeset
23 -- --
kono
parents:
diff changeset
24 ------------------------------------------------------------------------------
kono
parents:
diff changeset
25
kono
parents:
diff changeset
26 with Atree; use Atree;
kono
parents:
diff changeset
27 with Einfo; use Einfo;
kono
parents:
diff changeset
28 with Elists; use Elists;
kono
parents:
diff changeset
29 with Exp_Util; use Exp_Util;
kono
parents:
diff changeset
30 with Nlists; use Nlists;
kono
parents:
diff changeset
31 with Lib; use Lib;
kono
parents:
diff changeset
32 with Restrict; use Restrict;
kono
parents:
diff changeset
33 with Rident; use Rident;
kono
parents:
diff changeset
34 with Sem_Aux; use Sem_Aux;
kono
parents:
diff changeset
35 with Sem_Util; use Sem_Util;
kono
parents:
diff changeset
36 with Sinfo; use Sinfo;
kono
parents:
diff changeset
37
kono
parents:
diff changeset
38 package body Exp_Tss is
kono
parents:
diff changeset
39
kono
parents:
diff changeset
40 --------------------
kono
parents:
diff changeset
41 -- Base_Init_Proc --
kono
parents:
diff changeset
42 --------------------
kono
parents:
diff changeset
43
kono
parents:
diff changeset
44 function Base_Init_Proc
kono
parents:
diff changeset
45 (Typ : Entity_Id;
kono
parents:
diff changeset
46 Ref : Entity_Id := Empty) return Entity_Id
kono
parents:
diff changeset
47 is
kono
parents:
diff changeset
48 Full_Type : E;
kono
parents:
diff changeset
49 Proc : Entity_Id;
kono
parents:
diff changeset
50
kono
parents:
diff changeset
51 begin
kono
parents:
diff changeset
52 pragma Assert (Is_Type (Typ));
kono
parents:
diff changeset
53
kono
parents:
diff changeset
54 if Is_Private_Type (Typ) then
kono
parents:
diff changeset
55 Full_Type := Underlying_Type (Base_Type (Typ));
kono
parents:
diff changeset
56 else
kono
parents:
diff changeset
57 Full_Type := Typ;
kono
parents:
diff changeset
58 end if;
kono
parents:
diff changeset
59
kono
parents:
diff changeset
60 if No (Full_Type) then
kono
parents:
diff changeset
61 return Empty;
kono
parents:
diff changeset
62
kono
parents:
diff changeset
63 elsif Is_Concurrent_Type (Full_Type)
kono
parents:
diff changeset
64 and then Present (Corresponding_Record_Type (Base_Type (Full_Type)))
kono
parents:
diff changeset
65 then
kono
parents:
diff changeset
66 -- The initialization routine to be called is that of the base type
kono
parents:
diff changeset
67 -- of the corresponding record type, which may itself be a subtype
kono
parents:
diff changeset
68 -- and possibly an itype.
kono
parents:
diff changeset
69
kono
parents:
diff changeset
70 return Init_Proc
kono
parents:
diff changeset
71 (Base_Type (Corresponding_Record_Type (Base_Type (Full_Type))),
kono
parents:
diff changeset
72 Ref);
kono
parents:
diff changeset
73
kono
parents:
diff changeset
74 else
kono
parents:
diff changeset
75 Proc := Init_Proc (Base_Type (Full_Type), Ref);
kono
parents:
diff changeset
76
kono
parents:
diff changeset
77 if No (Proc)
kono
parents:
diff changeset
78 and then Is_Composite_Type (Full_Type)
kono
parents:
diff changeset
79 and then Is_Derived_Type (Full_Type)
kono
parents:
diff changeset
80 then
kono
parents:
diff changeset
81 return Init_Proc (Root_Type (Full_Type), Ref);
kono
parents:
diff changeset
82 else
kono
parents:
diff changeset
83 return Proc;
kono
parents:
diff changeset
84 end if;
kono
parents:
diff changeset
85 end if;
kono
parents:
diff changeset
86 end Base_Init_Proc;
kono
parents:
diff changeset
87
kono
parents:
diff changeset
88 --------------
kono
parents:
diff changeset
89 -- Copy_TSS --
kono
parents:
diff changeset
90 --------------
kono
parents:
diff changeset
91
kono
parents:
diff changeset
92 -- Note: internally this routine is also used to initially set up
kono
parents:
diff changeset
93 -- a TSS entry for a new type (case of being called from Set_TSS)
kono
parents:
diff changeset
94
kono
parents:
diff changeset
95 procedure Copy_TSS (TSS : Entity_Id; Typ : Entity_Id) is
kono
parents:
diff changeset
96 FN : Node_Id;
kono
parents:
diff changeset
97
kono
parents:
diff changeset
98 begin
kono
parents:
diff changeset
99 Ensure_Freeze_Node (Typ);
kono
parents:
diff changeset
100 FN := Freeze_Node (Typ);
kono
parents:
diff changeset
101
kono
parents:
diff changeset
102 if No (TSS_Elist (FN)) then
kono
parents:
diff changeset
103 Set_TSS_Elist (FN, New_Elmt_List);
kono
parents:
diff changeset
104 end if;
kono
parents:
diff changeset
105
kono
parents:
diff changeset
106 -- We prepend here, so that a second call overrides the first, it
kono
parents:
diff changeset
107 -- is not clear that this is required, but it seems reasonable.
kono
parents:
diff changeset
108
kono
parents:
diff changeset
109 Prepend_Elmt (TSS, TSS_Elist (FN));
kono
parents:
diff changeset
110 end Copy_TSS;
kono
parents:
diff changeset
111
kono
parents:
diff changeset
112 -------------------
kono
parents:
diff changeset
113 -- CPP_Init_Proc --
kono
parents:
diff changeset
114 -------------------
kono
parents:
diff changeset
115
kono
parents:
diff changeset
116 function CPP_Init_Proc (Typ : Entity_Id) return Entity_Id is
kono
parents:
diff changeset
117 FN : constant Node_Id := Freeze_Node (Typ);
kono
parents:
diff changeset
118 Elmt : Elmt_Id;
kono
parents:
diff changeset
119
kono
parents:
diff changeset
120 begin
kono
parents:
diff changeset
121 if not Is_CPP_Class (Root_Type (Typ))
kono
parents:
diff changeset
122 or else No (FN)
kono
parents:
diff changeset
123 or else No (TSS_Elist (FN))
kono
parents:
diff changeset
124 then
kono
parents:
diff changeset
125 return Empty;
kono
parents:
diff changeset
126
kono
parents:
diff changeset
127 else
kono
parents:
diff changeset
128 Elmt := First_Elmt (TSS_Elist (FN));
kono
parents:
diff changeset
129 while Present (Elmt) loop
kono
parents:
diff changeset
130 if Is_CPP_Init_Proc (Node (Elmt)) then
kono
parents:
diff changeset
131 return Node (Elmt);
kono
parents:
diff changeset
132 end if;
kono
parents:
diff changeset
133
kono
parents:
diff changeset
134 Next_Elmt (Elmt);
kono
parents:
diff changeset
135 end loop;
kono
parents:
diff changeset
136 end if;
kono
parents:
diff changeset
137
kono
parents:
diff changeset
138 return Empty;
kono
parents:
diff changeset
139 end CPP_Init_Proc;
kono
parents:
diff changeset
140
kono
parents:
diff changeset
141 ------------------------
kono
parents:
diff changeset
142 -- Find_Inherited_TSS --
kono
parents:
diff changeset
143 ------------------------
kono
parents:
diff changeset
144
kono
parents:
diff changeset
145 function Find_Inherited_TSS
kono
parents:
diff changeset
146 (Typ : Entity_Id;
kono
parents:
diff changeset
147 Nam : TSS_Name_Type) return Entity_Id
kono
parents:
diff changeset
148 is
kono
parents:
diff changeset
149 Btyp : Entity_Id := Typ;
kono
parents:
diff changeset
150 Proc : Entity_Id;
kono
parents:
diff changeset
151
kono
parents:
diff changeset
152 begin
kono
parents:
diff changeset
153 loop
kono
parents:
diff changeset
154 Btyp := Base_Type (Btyp);
kono
parents:
diff changeset
155 Proc := TSS (Btyp, Nam);
kono
parents:
diff changeset
156
kono
parents:
diff changeset
157 exit when Present (Proc)
kono
parents:
diff changeset
158 or else not Is_Derived_Type (Btyp);
kono
parents:
diff changeset
159
kono
parents:
diff changeset
160 -- If Typ is a derived type, it may inherit attributes from some
kono
parents:
diff changeset
161 -- ancestor.
kono
parents:
diff changeset
162
kono
parents:
diff changeset
163 Btyp := Etype (Btyp);
kono
parents:
diff changeset
164 end loop;
kono
parents:
diff changeset
165
kono
parents:
diff changeset
166 if No (Proc) then
kono
parents:
diff changeset
167
kono
parents:
diff changeset
168 -- If nothing else, use the TSS of the root type
kono
parents:
diff changeset
169
kono
parents:
diff changeset
170 Proc := TSS (Base_Type (Underlying_Type (Typ)), Nam);
kono
parents:
diff changeset
171 end if;
kono
parents:
diff changeset
172
kono
parents:
diff changeset
173 return Proc;
kono
parents:
diff changeset
174 end Find_Inherited_TSS;
kono
parents:
diff changeset
175
131
84e7813d76e9 gcc-8.2
mir3636
parents: 111
diff changeset
176 ------------------
84e7813d76e9 gcc-8.2
mir3636
parents: 111
diff changeset
177 -- Get_TSS_Name --
84e7813d76e9 gcc-8.2
mir3636
parents: 111
diff changeset
178 ------------------
111
kono
parents:
diff changeset
179
kono
parents:
diff changeset
180 function Get_TSS_Name (E : Entity_Id) return TSS_Name_Type is
kono
parents:
diff changeset
181 C1 : Character;
kono
parents:
diff changeset
182 C2 : Character;
kono
parents:
diff changeset
183 Nm : TSS_Name_Type;
kono
parents:
diff changeset
184
kono
parents:
diff changeset
185 begin
kono
parents:
diff changeset
186 Get_Last_Two_Chars (Chars (E), C1, C2);
kono
parents:
diff changeset
187
kono
parents:
diff changeset
188 if C1 in 'A' .. 'Z' and then C2 in 'A' .. 'Z' then
kono
parents:
diff changeset
189 Nm := (C1, C2);
kono
parents:
diff changeset
190
kono
parents:
diff changeset
191 for J in TSS_Names'Range loop
kono
parents:
diff changeset
192 if Nm = TSS_Names (J) then
kono
parents:
diff changeset
193 return Nm;
kono
parents:
diff changeset
194 end if;
kono
parents:
diff changeset
195 end loop;
kono
parents:
diff changeset
196 end if;
kono
parents:
diff changeset
197
kono
parents:
diff changeset
198 return TSS_Null;
kono
parents:
diff changeset
199 end Get_TSS_Name;
kono
parents:
diff changeset
200
kono
parents:
diff changeset
201 ---------------------------------
kono
parents:
diff changeset
202 -- Has_Non_Null_Base_Init_Proc --
kono
parents:
diff changeset
203 ---------------------------------
kono
parents:
diff changeset
204
kono
parents:
diff changeset
205 -- Note: if a base Init_Proc is present, and No_Default_Initialization is
kono
parents:
diff changeset
206 -- present, then we must avoid testing for a null init proc, since there
kono
parents:
diff changeset
207 -- is no init proc present in this case.
kono
parents:
diff changeset
208
kono
parents:
diff changeset
209 function Has_Non_Null_Base_Init_Proc (Typ : Entity_Id) return Boolean is
kono
parents:
diff changeset
210 BIP : constant Entity_Id := Base_Init_Proc (Typ);
kono
parents:
diff changeset
211 begin
kono
parents:
diff changeset
212 return Present (BIP)
kono
parents:
diff changeset
213 and then (Restriction_Active (No_Default_Initialization)
kono
parents:
diff changeset
214 or else not Is_Null_Init_Proc (BIP));
kono
parents:
diff changeset
215 end Has_Non_Null_Base_Init_Proc;
kono
parents:
diff changeset
216
kono
parents:
diff changeset
217 ---------------
kono
parents:
diff changeset
218 -- Init_Proc --
kono
parents:
diff changeset
219 ---------------
kono
parents:
diff changeset
220
kono
parents:
diff changeset
221 function Init_Proc
kono
parents:
diff changeset
222 (Typ : Entity_Id;
kono
parents:
diff changeset
223 Ref : Entity_Id := Empty) return Entity_Id
kono
parents:
diff changeset
224 is
kono
parents:
diff changeset
225 FN : constant Node_Id := Freeze_Node (Typ);
kono
parents:
diff changeset
226 Elmt : Elmt_Id;
kono
parents:
diff changeset
227 E1 : Entity_Id;
kono
parents:
diff changeset
228 E2 : Entity_Id;
kono
parents:
diff changeset
229
kono
parents:
diff changeset
230 begin
kono
parents:
diff changeset
231 if No (FN) then
kono
parents:
diff changeset
232 return Empty;
kono
parents:
diff changeset
233
kono
parents:
diff changeset
234 elsif No (TSS_Elist (FN)) then
kono
parents:
diff changeset
235 return Empty;
kono
parents:
diff changeset
236
kono
parents:
diff changeset
237 elsif No (Ref) then
kono
parents:
diff changeset
238 Elmt := First_Elmt (TSS_Elist (FN));
kono
parents:
diff changeset
239 while Present (Elmt) loop
kono
parents:
diff changeset
240 if Is_Init_Proc (Node (Elmt)) then
kono
parents:
diff changeset
241 if not Is_CPP_Class (Typ) then
kono
parents:
diff changeset
242 return Node (Elmt);
kono
parents:
diff changeset
243
kono
parents:
diff changeset
244 -- For CPP classes, we are looking for the default constructor,
kono
parents:
diff changeset
245 -- and so we must skip any non-default constructor.
kono
parents:
diff changeset
246
kono
parents:
diff changeset
247 elsif
kono
parents:
diff changeset
248 No (Next
kono
parents:
diff changeset
249 (First
kono
parents:
diff changeset
250 (Parameter_Specifications (Parent (Node (Elmt))))))
kono
parents:
diff changeset
251 then
kono
parents:
diff changeset
252 return Node (Elmt);
kono
parents:
diff changeset
253 end if;
kono
parents:
diff changeset
254 end if;
kono
parents:
diff changeset
255
kono
parents:
diff changeset
256 Next_Elmt (Elmt);
kono
parents:
diff changeset
257 end loop;
kono
parents:
diff changeset
258
kono
parents:
diff changeset
259 -- Non-default constructors are currently supported only in the context
kono
parents:
diff changeset
260 -- of interfacing with C++.
kono
parents:
diff changeset
261
kono
parents:
diff changeset
262 else pragma Assert (Is_CPP_Class (Typ));
kono
parents:
diff changeset
263
kono
parents:
diff changeset
264 -- Use the referenced function to locate the init_proc matching
kono
parents:
diff changeset
265 -- the C++ constructor.
kono
parents:
diff changeset
266
kono
parents:
diff changeset
267 Elmt := First_Elmt (TSS_Elist (FN));
kono
parents:
diff changeset
268 while Present (Elmt) loop
kono
parents:
diff changeset
269 if Is_Init_Proc (Node (Elmt)) then
kono
parents:
diff changeset
270 E1 := Next_Formal (First_Formal (Node (Elmt)));
kono
parents:
diff changeset
271 E2 := First_Formal (Ref);
kono
parents:
diff changeset
272 while Present (E1) and then Present (E2) loop
kono
parents:
diff changeset
273 if Chars (E1) /= Chars (E2)
kono
parents:
diff changeset
274 or else Ekind (E1) /= Ekind (E2)
kono
parents:
diff changeset
275 then
kono
parents:
diff changeset
276 exit;
kono
parents:
diff changeset
277
kono
parents:
diff changeset
278 elsif Ekind (Etype (E1)) /= E_Anonymous_Access_Type
kono
parents:
diff changeset
279 and then Ekind (Etype (E2)) /= E_Anonymous_Access_Type
kono
parents:
diff changeset
280 and then Etype (E1) /= Etype (E2)
kono
parents:
diff changeset
281 then
kono
parents:
diff changeset
282 exit;
kono
parents:
diff changeset
283
kono
parents:
diff changeset
284 elsif Ekind (Etype (E1)) = E_Anonymous_Access_Type
kono
parents:
diff changeset
285 and then Ekind (Etype (E2)) = E_Anonymous_Access_Type
kono
parents:
diff changeset
286 and then Directly_Designated_Type (Etype (E1))
kono
parents:
diff changeset
287 /= Directly_Designated_Type (Etype (E2))
kono
parents:
diff changeset
288 then
kono
parents:
diff changeset
289 exit;
kono
parents:
diff changeset
290 end if;
kono
parents:
diff changeset
291
kono
parents:
diff changeset
292 E1 := Next_Formal (E1);
kono
parents:
diff changeset
293 E2 := Next_Formal (E2);
kono
parents:
diff changeset
294 end loop;
kono
parents:
diff changeset
295
kono
parents:
diff changeset
296 if No (E1) and then No (E2) then
kono
parents:
diff changeset
297 return Node (Elmt);
kono
parents:
diff changeset
298 end if;
kono
parents:
diff changeset
299 end if;
kono
parents:
diff changeset
300
kono
parents:
diff changeset
301 Next_Elmt (Elmt);
kono
parents:
diff changeset
302 end loop;
kono
parents:
diff changeset
303 end if;
kono
parents:
diff changeset
304
kono
parents:
diff changeset
305 return Empty;
kono
parents:
diff changeset
306 end Init_Proc;
kono
parents:
diff changeset
307
kono
parents:
diff changeset
308 ----------------------
kono
parents:
diff changeset
309 -- Is_CPP_Init_Proc --
kono
parents:
diff changeset
310 ----------------------
kono
parents:
diff changeset
311
kono
parents:
diff changeset
312 function Is_CPP_Init_Proc (E : Entity_Id) return Boolean is
kono
parents:
diff changeset
313 C1 : Character;
kono
parents:
diff changeset
314 C2 : Character;
kono
parents:
diff changeset
315 begin
kono
parents:
diff changeset
316 Get_Last_Two_Chars (Chars (E), C1, C2);
kono
parents:
diff changeset
317 return C1 = TSS_CPP_Init_Proc (1) and then C2 = TSS_CPP_Init_Proc (2);
kono
parents:
diff changeset
318 end Is_CPP_Init_Proc;
kono
parents:
diff changeset
319
kono
parents:
diff changeset
320 ------------------
kono
parents:
diff changeset
321 -- Is_Init_Proc --
kono
parents:
diff changeset
322 ------------------
kono
parents:
diff changeset
323
kono
parents:
diff changeset
324 function Is_Init_Proc (E : Entity_Id) return Boolean is
kono
parents:
diff changeset
325 C1 : Character;
kono
parents:
diff changeset
326 C2 : Character;
kono
parents:
diff changeset
327 begin
kono
parents:
diff changeset
328 Get_Last_Two_Chars (Chars (E), C1, C2);
kono
parents:
diff changeset
329 return C1 = TSS_Init_Proc (1) and then C2 = TSS_Init_Proc (2);
kono
parents:
diff changeset
330 end Is_Init_Proc;
kono
parents:
diff changeset
331
kono
parents:
diff changeset
332 ------------
kono
parents:
diff changeset
333 -- Is_TSS --
kono
parents:
diff changeset
334 ------------
kono
parents:
diff changeset
335
kono
parents:
diff changeset
336 function Is_TSS (E : Entity_Id; Nam : TSS_Name_Type) return Boolean is
kono
parents:
diff changeset
337 C1 : Character;
kono
parents:
diff changeset
338 C2 : Character;
kono
parents:
diff changeset
339 begin
kono
parents:
diff changeset
340 Get_Last_Two_Chars (Chars (E), C1, C2);
kono
parents:
diff changeset
341 return C1 = Nam (1) and then C2 = Nam (2);
kono
parents:
diff changeset
342 end Is_TSS;
kono
parents:
diff changeset
343
kono
parents:
diff changeset
344 function Is_TSS (N : Name_Id; Nam : TSS_Name_Type) return Boolean is
kono
parents:
diff changeset
345 C1 : Character;
kono
parents:
diff changeset
346 C2 : Character;
kono
parents:
diff changeset
347 begin
kono
parents:
diff changeset
348 Get_Last_Two_Chars (N, C1, C2);
kono
parents:
diff changeset
349 return C1 = Nam (1) and then C2 = Nam (2);
kono
parents:
diff changeset
350 end Is_TSS;
kono
parents:
diff changeset
351
kono
parents:
diff changeset
352 -------------------------
kono
parents:
diff changeset
353 -- Make_Init_Proc_Name --
kono
parents:
diff changeset
354 -------------------------
kono
parents:
diff changeset
355
kono
parents:
diff changeset
356 function Make_Init_Proc_Name (Typ : Entity_Id) return Name_Id is
kono
parents:
diff changeset
357 begin
kono
parents:
diff changeset
358 return Make_TSS_Name (Typ, TSS_Init_Proc);
kono
parents:
diff changeset
359 end Make_Init_Proc_Name;
kono
parents:
diff changeset
360
kono
parents:
diff changeset
361 -------------------
kono
parents:
diff changeset
362 -- Make_TSS_Name --
kono
parents:
diff changeset
363 -------------------
kono
parents:
diff changeset
364
kono
parents:
diff changeset
365 function Make_TSS_Name
kono
parents:
diff changeset
366 (Typ : Entity_Id;
kono
parents:
diff changeset
367 Nam : TSS_Name_Type) return Name_Id
kono
parents:
diff changeset
368 is
kono
parents:
diff changeset
369 begin
kono
parents:
diff changeset
370 Get_Name_String (Chars (Typ));
kono
parents:
diff changeset
371 Add_Char_To_Name_Buffer (Nam (1));
kono
parents:
diff changeset
372 Add_Char_To_Name_Buffer (Nam (2));
kono
parents:
diff changeset
373 return Name_Find;
kono
parents:
diff changeset
374 end Make_TSS_Name;
kono
parents:
diff changeset
375
kono
parents:
diff changeset
376 -------------------------
kono
parents:
diff changeset
377 -- Make_TSS_Name_Local --
kono
parents:
diff changeset
378 -------------------------
kono
parents:
diff changeset
379
kono
parents:
diff changeset
380 function Make_TSS_Name_Local
kono
parents:
diff changeset
381 (Typ : Entity_Id;
kono
parents:
diff changeset
382 Nam : TSS_Name_Type) return Name_Id
kono
parents:
diff changeset
383 is
kono
parents:
diff changeset
384 begin
kono
parents:
diff changeset
385 Get_Name_String (Chars (Typ));
kono
parents:
diff changeset
386 Add_Char_To_Name_Buffer ('_');
kono
parents:
diff changeset
387 Add_Nat_To_Name_Buffer (Increment_Serial_Number);
kono
parents:
diff changeset
388 Add_Char_To_Name_Buffer (Nam (1));
kono
parents:
diff changeset
389 Add_Char_To_Name_Buffer (Nam (2));
kono
parents:
diff changeset
390 return Name_Find;
kono
parents:
diff changeset
391 end Make_TSS_Name_Local;
kono
parents:
diff changeset
392
kono
parents:
diff changeset
393 --------------
kono
parents:
diff changeset
394 -- Same_TSS --
kono
parents:
diff changeset
395 --------------
kono
parents:
diff changeset
396
kono
parents:
diff changeset
397 function Same_TSS (E1, E2 : Entity_Id) return Boolean is
kono
parents:
diff changeset
398 E1C1 : Character;
kono
parents:
diff changeset
399 E1C2 : Character;
kono
parents:
diff changeset
400 E2C1 : Character;
kono
parents:
diff changeset
401 E2C2 : Character;
kono
parents:
diff changeset
402
kono
parents:
diff changeset
403 begin
kono
parents:
diff changeset
404 Get_Last_Two_Chars (Chars (E1), E1C1, E1C2);
kono
parents:
diff changeset
405 Get_Last_Two_Chars (Chars (E2), E2C1, E2C2);
kono
parents:
diff changeset
406
kono
parents:
diff changeset
407 return
kono
parents:
diff changeset
408 E1C1 = E2C1
kono
parents:
diff changeset
409 and then
kono
parents:
diff changeset
410 E1C2 = E2C2
kono
parents:
diff changeset
411 and then
kono
parents:
diff changeset
412 E1C1 in 'A' .. 'Z'
kono
parents:
diff changeset
413 and then
kono
parents:
diff changeset
414 E1C2 in 'A' .. 'Z';
kono
parents:
diff changeset
415 end Same_TSS;
kono
parents:
diff changeset
416
kono
parents:
diff changeset
417 -------------------
kono
parents:
diff changeset
418 -- Set_Init_Proc --
kono
parents:
diff changeset
419 -------------------
kono
parents:
diff changeset
420
kono
parents:
diff changeset
421 procedure Set_Init_Proc (Typ : Entity_Id; Init : Entity_Id) is
kono
parents:
diff changeset
422 begin
kono
parents:
diff changeset
423 Set_TSS (Typ, Init);
kono
parents:
diff changeset
424 end Set_Init_Proc;
kono
parents:
diff changeset
425
kono
parents:
diff changeset
426 -------------
kono
parents:
diff changeset
427 -- Set_TSS --
kono
parents:
diff changeset
428 -------------
kono
parents:
diff changeset
429
kono
parents:
diff changeset
430 procedure Set_TSS (Typ : Entity_Id; TSS : Entity_Id) is
kono
parents:
diff changeset
431 begin
kono
parents:
diff changeset
432 -- Make sure body of subprogram is frozen
kono
parents:
diff changeset
433
kono
parents:
diff changeset
434 -- Skip this for Init_Proc with No_Default_Initialization, since the
kono
parents:
diff changeset
435 -- Init proc is a dummy void entity in this case to be ignored.
kono
parents:
diff changeset
436
kono
parents:
diff changeset
437 if (Is_Init_Proc (TSS) or else Is_CPP_Init_Proc (TSS))
kono
parents:
diff changeset
438 and then Restriction_Active (No_Default_Initialization)
kono
parents:
diff changeset
439 then
kono
parents:
diff changeset
440 null;
kono
parents:
diff changeset
441
kono
parents:
diff changeset
442 -- Skip this if not in the same code unit (since it means we are using
kono
parents:
diff changeset
443 -- an already existing TSS in another unit)
kono
parents:
diff changeset
444
kono
parents:
diff changeset
445 elsif not In_Same_Code_Unit (Typ, TSS) then
kono
parents:
diff changeset
446 null;
kono
parents:
diff changeset
447
kono
parents:
diff changeset
448 -- Otherwise make sure body is frozen
kono
parents:
diff changeset
449
kono
parents:
diff changeset
450 else
kono
parents:
diff changeset
451 Append_Freeze_Action (Typ, Unit_Declaration_Node (TSS));
kono
parents:
diff changeset
452 end if;
kono
parents:
diff changeset
453
kono
parents:
diff changeset
454 -- Set TSS entry
kono
parents:
diff changeset
455
kono
parents:
diff changeset
456 Copy_TSS (TSS, Typ);
kono
parents:
diff changeset
457 end Set_TSS;
kono
parents:
diff changeset
458
kono
parents:
diff changeset
459 ---------
kono
parents:
diff changeset
460 -- TSS --
kono
parents:
diff changeset
461 ---------
kono
parents:
diff changeset
462
kono
parents:
diff changeset
463 function TSS (Typ : Entity_Id; Nam : TSS_Name_Type) return Entity_Id is
kono
parents:
diff changeset
464 FN : constant Node_Id := Freeze_Node (Typ);
kono
parents:
diff changeset
465 Elmt : Elmt_Id;
kono
parents:
diff changeset
466 Subp : Entity_Id;
kono
parents:
diff changeset
467
kono
parents:
diff changeset
468 begin
kono
parents:
diff changeset
469 if No (FN) then
kono
parents:
diff changeset
470 return Empty;
kono
parents:
diff changeset
471
kono
parents:
diff changeset
472 elsif No (TSS_Elist (FN)) then
kono
parents:
diff changeset
473 return Empty;
kono
parents:
diff changeset
474
kono
parents:
diff changeset
475 else
kono
parents:
diff changeset
476 Elmt := First_Elmt (TSS_Elist (FN));
kono
parents:
diff changeset
477 while Present (Elmt) loop
kono
parents:
diff changeset
478 if Is_TSS (Node (Elmt), Nam) then
kono
parents:
diff changeset
479 Subp := Node (Elmt);
kono
parents:
diff changeset
480
kono
parents:
diff changeset
481 -- For stream subprograms, the TSS entity may be a renaming-
kono
parents:
diff changeset
482 -- as-body of an already generated entity. Use that one rather
kono
parents:
diff changeset
483 -- the one introduced by the renaming, which is an artifact of
kono
parents:
diff changeset
484 -- current stream handling.
kono
parents:
diff changeset
485
kono
parents:
diff changeset
486 if Nkind (Parent (Parent (Subp))) =
kono
parents:
diff changeset
487 N_Subprogram_Renaming_Declaration
kono
parents:
diff changeset
488 and then
kono
parents:
diff changeset
489 Present (Corresponding_Spec (Parent (Parent (Subp))))
kono
parents:
diff changeset
490 then
kono
parents:
diff changeset
491 return Corresponding_Spec (Parent (Parent (Subp)));
kono
parents:
diff changeset
492 else
kono
parents:
diff changeset
493 return Subp;
kono
parents:
diff changeset
494 end if;
kono
parents:
diff changeset
495
kono
parents:
diff changeset
496 else
kono
parents:
diff changeset
497 Next_Elmt (Elmt);
kono
parents:
diff changeset
498 end if;
kono
parents:
diff changeset
499 end loop;
kono
parents:
diff changeset
500 end if;
kono
parents:
diff changeset
501
kono
parents:
diff changeset
502 return Empty;
kono
parents:
diff changeset
503 end TSS;
kono
parents:
diff changeset
504
kono
parents:
diff changeset
505 function TSS (Typ : Entity_Id; Nam : Name_Id) return Entity_Id is
kono
parents:
diff changeset
506 FN : constant Node_Id := Freeze_Node (Typ);
kono
parents:
diff changeset
507 Elmt : Elmt_Id;
kono
parents:
diff changeset
508 Subp : Entity_Id;
kono
parents:
diff changeset
509
kono
parents:
diff changeset
510 begin
kono
parents:
diff changeset
511 if No (FN) then
kono
parents:
diff changeset
512 return Empty;
kono
parents:
diff changeset
513
kono
parents:
diff changeset
514 elsif No (TSS_Elist (FN)) then
kono
parents:
diff changeset
515 return Empty;
kono
parents:
diff changeset
516
kono
parents:
diff changeset
517 else
kono
parents:
diff changeset
518 Elmt := First_Elmt (TSS_Elist (FN));
kono
parents:
diff changeset
519 while Present (Elmt) loop
kono
parents:
diff changeset
520 if Chars (Node (Elmt)) = Nam then
kono
parents:
diff changeset
521 Subp := Node (Elmt);
kono
parents:
diff changeset
522
kono
parents:
diff changeset
523 -- For stream subprograms, the TSS entity may be a renaming-
kono
parents:
diff changeset
524 -- as-body of an already generated entity. Use that one rather
kono
parents:
diff changeset
525 -- the one introduced by the renaming, which is an artifact of
kono
parents:
diff changeset
526 -- current stream handling.
kono
parents:
diff changeset
527
kono
parents:
diff changeset
528 if Nkind (Parent (Parent (Subp))) =
kono
parents:
diff changeset
529 N_Subprogram_Renaming_Declaration
kono
parents:
diff changeset
530 and then
kono
parents:
diff changeset
531 Present (Corresponding_Spec (Parent (Parent (Subp))))
kono
parents:
diff changeset
532 then
kono
parents:
diff changeset
533 return Corresponding_Spec (Parent (Parent (Subp)));
kono
parents:
diff changeset
534 else
kono
parents:
diff changeset
535 return Subp;
kono
parents:
diff changeset
536 end if;
kono
parents:
diff changeset
537
kono
parents:
diff changeset
538 else
kono
parents:
diff changeset
539 Next_Elmt (Elmt);
kono
parents:
diff changeset
540 end if;
kono
parents:
diff changeset
541 end loop;
kono
parents:
diff changeset
542 end if;
kono
parents:
diff changeset
543
kono
parents:
diff changeset
544 return Empty;
kono
parents:
diff changeset
545 end TSS;
kono
parents:
diff changeset
546
kono
parents:
diff changeset
547 end Exp_Tss;