111
|
1 ------------------------------------------------------------------------------
|
|
2 -- --
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
4 -- --
|
|
5 -- E X P _ T S S --
|
|
6 -- --
|
|
7 -- B o d y --
|
|
8 -- --
|
131
|
9 -- Copyright (C) 1992-2018, Free Software Foundation, Inc. --
|
111
|
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
|
131
|
176 ------------------
|
|
177 -- Get_TSS_Name --
|
|
178 ------------------
|
111
|
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;
|