Mercurial > hg > CbC > CbC_gcc
comparison gcc/ada/exp_tss.adb @ 111:04ced10e8804
gcc 7
author | kono |
---|---|
date | Fri, 27 Oct 2017 22:46:09 +0900 |
parents | |
children | 84e7813d76e9 |
comparison
equal
deleted
inserted
replaced
68:561a7518be6b | 111:04ced10e8804 |
---|---|
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; |