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