]>
Commit | Line | Data |
---|---|---|
9c41193c JM |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- E X P _ C G -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
1d005acc | 9 | -- Copyright (C) 2010-2019, Free Software Foundation, Inc. -- |
9c41193c JM |
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; | |
9c41193c JM |
27 | with Einfo; use Einfo; |
28 | with Elists; use Elists; | |
008f6fd3 | 29 | with Exp_Dbug; use Exp_Dbug; |
9c41193c | 30 | with Exp_Tss; use Exp_Tss; |
9c41193c JM |
31 | with Lib; use Lib; |
32 | with Namet; use Namet; | |
33 | with Opt; use Opt; | |
34 | with Output; use Output; | |
bb10b891 | 35 | with Sem_Aux; use Sem_Aux; |
9c41193c JM |
36 | with Sem_Disp; use Sem_Disp; |
37 | with Sem_Type; use Sem_Type; | |
38 | with Sem_Util; use Sem_Util; | |
39 | with Sinfo; use Sinfo; | |
40 | with Sinput; use Sinput; | |
41 | with Snames; use Snames; | |
c88f5c49 | 42 | with System; use System; |
9c41193c JM |
43 | with Table; |
44 | with Uintp; use Uintp; | |
45 | ||
46 | package body Exp_CG is | |
47 | ||
c88f5c49 JM |
48 | -- We duplicate here some declarations from packages Interfaces.C and |
49 | -- Interfaces.C_Streams because adding their dependence to the frontend | |
50 | -- causes bootstrapping problems with old versions of the compiler. | |
51 | ||
52 | subtype FILEs is System.Address; | |
53 | -- Corresponds to the C type FILE* | |
54 | ||
55 | subtype C_chars is System.Address; | |
56 | -- Pointer to null-terminated array of characters | |
57 | ||
58 | function fputs (Strng : C_chars; Stream : FILEs) return Integer; | |
59 | pragma Import (C, fputs, "fputs"); | |
60 | ||
61 | -- Import the file stream associated with the "ci" output file. Done to | |
62 | -- generate the output in the file created and left opened by routine | |
63 | -- toplev.c before calling gnat1drv. | |
64 | ||
65 | Callgraph_Info_File : FILEs; | |
66 | pragma Import (C, Callgraph_Info_File); | |
9c41193c JM |
67 | |
68 | package Call_Graph_Nodes is new Table.Table ( | |
69 | Table_Component_Type => Node_Id, | |
70 | Table_Index_Type => Natural, | |
71 | Table_Low_Bound => 1, | |
72 | Table_Initial => 50, | |
73 | Table_Increment => 100, | |
74 | Table_Name => "Call_Graph_Nodes"); | |
c88f5c49 JM |
75 | -- This table records nodes associated with dispatching calls and tagged |
76 | -- type declarations found in the main compilation unit. Used as an | |
77 | -- auxiliary storage because the call-graph output requires fully qualified | |
78 | -- names and they are not available until the backend is called. | |
9c41193c JM |
79 | |
80 | function Is_Predefined_Dispatching_Operation (E : Entity_Id) return Boolean; | |
81 | -- Determines if E is a predefined primitive operation. | |
82 | -- Note: This routine should replace the routine with the same name that is | |
83 | -- currently available in exp_disp because it extends its functionality to | |
84 | -- handle fully qualified names ??? | |
85 | ||
86 | function Slot_Number (Prim : Entity_Id) return Uint; | |
87 | -- Returns the slot number associated with Prim. For predefined primitives | |
88 | -- the slot is returned as a negative number. | |
89 | ||
90 | procedure Write_Output (Str : String); | |
91 | -- Used to print a line in the output file (this is used as the | |
92 | -- argument for a call to Set_Special_Output in package Output). | |
93 | ||
94 | procedure Write_Call_Info (Call : Node_Id); | |
95 | -- Subsidiary of Generate_CG_Output that generates the output associated | |
96 | -- with a dispatching call. | |
97 | ||
98 | procedure Write_Type_Info (Typ : Entity_Id); | |
99 | -- Subsidiary of Generate_CG_Output that generates the output associated | |
100 | -- with a tagged type declaration. | |
101 | ||
102 | ------------------------ | |
103 | -- Generate_CG_Output -- | |
104 | ------------------------ | |
105 | ||
106 | procedure Generate_CG_Output is | |
107 | N : Node_Id; | |
108 | ||
109 | begin | |
c88f5c49 | 110 | -- No output if the "ci" output file has not been previously opened |
1c218ac3 | 111 | -- by toplev.c |
c88f5c49 | 112 | |
1c218ac3 | 113 | if Callgraph_Info_File = Null_Address then |
9c41193c JM |
114 | return; |
115 | end if; | |
116 | ||
117 | -- Setup write routine, create the output file and generate the output | |
118 | ||
119 | Set_Special_Output (Write_Output'Access); | |
120 | ||
121 | for J in Call_Graph_Nodes.First .. Call_Graph_Nodes.Last loop | |
122 | N := Call_Graph_Nodes.Table (J); | |
123 | ||
dc88759c JM |
124 | -- No action needed for subprogram calls removed by the expander |
125 | -- (for example, calls to ignored ghost entities). | |
126 | ||
127 | if Nkind (N) = N_Null_Statement then | |
128 | pragma Assert (Nkind (Original_Node (N)) in N_Subprogram_Call); | |
129 | null; | |
130 | ||
131 | elsif Nkind (N) in N_Subprogram_Call then | |
9c41193c JM |
132 | Write_Call_Info (N); |
133 | ||
134 | else pragma Assert (Nkind (N) = N_Defining_Identifier); | |
cd9909a0 AC |
135 | |
136 | -- The type may be a private untagged type whose completion is | |
137 | -- tagged, in which case we must use the full tagged view. | |
138 | ||
139 | if not Is_Tagged_Type (N) and then Is_Private_Type (N) then | |
140 | N := Full_View (N); | |
141 | end if; | |
142 | ||
9c41193c JM |
143 | pragma Assert (Is_Tagged_Type (N)); |
144 | ||
145 | Write_Type_Info (N); | |
146 | end if; | |
147 | end loop; | |
0b33adf1 | 148 | |
e3548b69 | 149 | Cancel_Special_Output; |
9c41193c JM |
150 | end Generate_CG_Output; |
151 | ||
152 | ---------------- | |
153 | -- Initialize -- | |
154 | ---------------- | |
155 | ||
156 | procedure Initialize is | |
157 | begin | |
158 | Call_Graph_Nodes.Init; | |
159 | end Initialize; | |
160 | ||
161 | ----------------------------------------- | |
162 | -- Is_Predefined_Dispatching_Operation -- | |
163 | ----------------------------------------- | |
164 | ||
165 | function Is_Predefined_Dispatching_Operation | |
166 | (E : Entity_Id) return Boolean | |
167 | is | |
168 | function Homonym_Suffix_Length (E : Entity_Id) return Natural; | |
169 | -- Returns the length of the homonym suffix corresponding to E. | |
170 | -- Note: This routine relies on the functionality provided by routines | |
171 | -- of Exp_Dbug. Further work needed here to decide if it should be | |
172 | -- located in that package??? | |
173 | ||
174 | --------------------------- | |
175 | -- Homonym_Suffix_Length -- | |
176 | --------------------------- | |
177 | ||
178 | function Homonym_Suffix_Length (E : Entity_Id) return Natural is | |
39eb6542 AC |
179 | Prefix_Length : constant := 2; |
180 | -- Length of prefix "__" | |
9c41193c JM |
181 | |
182 | H : Entity_Id; | |
183 | Nr : Nat := 1; | |
184 | ||
185 | begin | |
186 | if not Has_Homonym (E) then | |
187 | return 0; | |
188 | ||
189 | else | |
190 | H := Homonym (E); | |
191 | while Present (H) loop | |
192 | if Scope (H) = Scope (E) then | |
193 | Nr := Nr + 1; | |
194 | end if; | |
195 | ||
196 | H := Homonym (H); | |
197 | end loop; | |
198 | ||
199 | if Nr = 1 then | |
200 | return 0; | |
201 | ||
202 | -- Prefix "__" followed by number | |
203 | ||
9c41193c | 204 | else |
d4fc0fb4 AC |
205 | declare |
206 | Result : Natural := Prefix_Length + 1; | |
39eb6542 | 207 | |
d4fc0fb4 | 208 | begin |
a7c764a9 | 209 | while Nr >= 10 loop |
d4fc0fb4 AC |
210 | Result := Result + 1; |
211 | Nr := Nr / 10; | |
212 | end loop; | |
39eb6542 | 213 | |
d4fc0fb4 AC |
214 | return Result; |
215 | end; | |
9c41193c JM |
216 | end if; |
217 | end if; | |
218 | end Homonym_Suffix_Length; | |
219 | ||
220 | -- Local variables | |
221 | ||
9db0b232 | 222 | Full_Name : constant String := Get_Name_String (Chars (E)); |
39eb6542 | 223 | Suffix_Length : Natural; |
9db0b232 | 224 | TSS_Name : TSS_Name_Type; |
9c41193c JM |
225 | |
226 | -- Start of processing for Is_Predefined_Dispatching_Operation | |
227 | ||
228 | begin | |
229 | if not Is_Dispatching_Operation (E) then | |
230 | return False; | |
231 | end if; | |
232 | ||
9db0b232 AC |
233 | -- Search for and strip suffix for body-nested package entities |
234 | ||
39eb6542 | 235 | Suffix_Length := Homonym_Suffix_Length (E); |
9db0b232 AC |
236 | for J in reverse Full_Name'First + 2 .. Full_Name'Last loop |
237 | if Full_Name (J) = 'X' then | |
238 | ||
239 | -- Include the "X", "Xb", "Xn", ... in the part of the | |
240 | -- suffix to be removed. | |
241 | ||
242 | Suffix_Length := Suffix_Length + Full_Name'Last - J + 1; | |
243 | exit; | |
244 | end if; | |
245 | ||
246 | exit when Full_Name (J) /= 'b' and then Full_Name (J) /= 'n'; | |
247 | end loop; | |
248 | ||
9c41193c JM |
249 | -- Most predefined primitives have internally generated names. Equality |
250 | -- must be treated differently; the predefined operation is recognized | |
251 | -- as a homogeneous binary operator that returns Boolean. | |
252 | ||
253 | if Full_Name'Length > TSS_Name_Type'Length then | |
254 | TSS_Name := | |
9db0b232 AC |
255 | TSS_Name_Type |
256 | (Full_Name | |
257 | (Full_Name'Last - TSS_Name'Length - Suffix_Length + 1 | |
258 | .. Full_Name'Last - Suffix_Length)); | |
9c41193c JM |
259 | |
260 | if TSS_Name = TSS_Stream_Read | |
261 | or else TSS_Name = TSS_Stream_Write | |
262 | or else TSS_Name = TSS_Stream_Input | |
263 | or else TSS_Name = TSS_Stream_Output | |
264 | or else TSS_Name = TSS_Deep_Adjust | |
265 | or else TSS_Name = TSS_Deep_Finalize | |
266 | then | |
267 | return True; | |
268 | ||
269 | elsif not Has_Fully_Qualified_Name (E) then | |
b69cd36a | 270 | if Nam_In (Chars (E), Name_uSize, Name_uAlignment, Name_uAssign) |
9c41193c JM |
271 | or else |
272 | (Chars (E) = Name_Op_Eq | |
b69cd36a | 273 | and then Etype (First_Formal (E)) = Etype (Last_Formal (E))) |
9c41193c JM |
274 | or else Is_Predefined_Interface_Primitive (E) |
275 | then | |
276 | return True; | |
277 | end if; | |
278 | ||
279 | -- Handle fully qualified names | |
280 | ||
281 | else | |
282 | declare | |
283 | type Names_Table is array (Positive range <>) of Name_Id; | |
284 | ||
285 | Predef_Names_95 : constant Names_Table := | |
286 | (Name_uSize, | |
287 | Name_uAlignment, | |
288 | Name_Op_Eq, | |
289 | Name_uAssign); | |
290 | ||
291 | Predef_Names_05 : constant Names_Table := | |
292 | (Name_uDisp_Asynchronous_Select, | |
293 | Name_uDisp_Conditional_Select, | |
294 | Name_uDisp_Get_Prim_Op_Kind, | |
295 | Name_uDisp_Get_Task_Id, | |
296 | Name_uDisp_Requeue, | |
297 | Name_uDisp_Timed_Select); | |
298 | ||
9c41193c JM |
299 | begin |
300 | for J in Predef_Names_95'Range loop | |
301 | Get_Name_String (Predef_Names_95 (J)); | |
302 | ||
08564036 AC |
303 | -- The predefined primitive operations are identified by the |
304 | -- names "_size", "_alignment", etc. If we try a pattern | |
305 | -- matching against this string, we can wrongly match other | |
306 | -- primitive operations like "get_size". To avoid this, we | |
307 | -- add the "__" scope separator, which can only prepend | |
308 | -- predefined primitive operations because other primitive | |
309 | -- operations can neither start with an underline nor | |
310 | -- contain two consecutive underlines in its name. | |
311 | ||
312 | if Full_Name'Last - Suffix_Length > Name_Len + 2 | |
9c41193c JM |
313 | and then |
314 | Full_Name | |
08564036 | 315 | (Full_Name'Last - Name_Len - 2 - Suffix_Length + 1 |
9c41193c | 316 | .. Full_Name'Last - Suffix_Length) = |
08564036 | 317 | "__" & Name_Buffer (1 .. Name_Len) |
9c41193c JM |
318 | then |
319 | -- For the equality operator the type of the two operands | |
320 | -- must also match. | |
321 | ||
322 | return Predef_Names_95 (J) /= Name_Op_Eq | |
323 | or else | |
ea7f928b | 324 | Etype (First_Formal (E)) = Etype (Last_Formal (E)); |
9c41193c JM |
325 | end if; |
326 | end loop; | |
327 | ||
0791fbe9 | 328 | if Ada_Version >= Ada_2005 then |
9c41193c JM |
329 | for J in Predef_Names_05'Range loop |
330 | Get_Name_String (Predef_Names_05 (J)); | |
331 | ||
08564036 | 332 | if Full_Name'Last - Suffix_Length > Name_Len + 2 |
9c41193c JM |
333 | and then |
334 | Full_Name | |
08564036 | 335 | (Full_Name'Last - Name_Len - 2 - Suffix_Length + 1 |
9c41193c | 336 | .. Full_Name'Last - Suffix_Length) = |
08564036 | 337 | "__" & Name_Buffer (1 .. Name_Len) |
9c41193c JM |
338 | then |
339 | return True; | |
340 | end if; | |
341 | end loop; | |
342 | end if; | |
343 | end; | |
344 | end if; | |
345 | end if; | |
346 | ||
347 | return False; | |
348 | end Is_Predefined_Dispatching_Operation; | |
349 | ||
350 | ---------------------- | |
351 | -- Register_CG_Node -- | |
352 | ---------------------- | |
353 | ||
354 | procedure Register_CG_Node (N : Node_Id) is | |
355 | begin | |
d3b00ce3 | 356 | if Nkind (N) in N_Subprogram_Call then |
9c41193c JM |
357 | if Current_Scope = Main_Unit_Entity |
358 | or else Entity_Is_In_Main_Unit (Current_Scope) | |
359 | then | |
360 | -- Register a copy of the dispatching call node. Needed since the | |
308e6f3a RW |
361 | -- node containing a dispatching call is rewritten by the |
362 | -- expander. | |
9c41193c JM |
363 | |
364 | declare | |
365 | Copy : constant Node_Id := New_Copy (N); | |
a7c764a9 | 366 | Par : Node_Id; |
9c41193c JM |
367 | |
368 | begin | |
a7c764a9 AC |
369 | -- Determine the enclosing scope to use when generating the |
370 | -- call graph. This must be done now to avoid problems with | |
371 | -- control structures that may be rewritten during expansion. | |
372 | ||
373 | Par := Parent (N); | |
374 | while Nkind (Par) /= N_Subprogram_Body | |
375 | and then Nkind (Parent (Par)) /= N_Compilation_Unit | |
376 | loop | |
377 | Par := Parent (Par); | |
378 | pragma Assert (Present (Par)); | |
379 | end loop; | |
9c41193c | 380 | |
a7c764a9 | 381 | Set_Parent (Copy, Par); |
9c41193c JM |
382 | Call_Graph_Nodes.Append (Copy); |
383 | end; | |
384 | end if; | |
385 | ||
386 | else pragma Assert (Nkind (N) = N_Defining_Identifier); | |
387 | if Entity_Is_In_Main_Unit (N) then | |
388 | Call_Graph_Nodes.Append (N); | |
389 | end if; | |
390 | end if; | |
391 | end Register_CG_Node; | |
392 | ||
393 | ----------------- | |
394 | -- Slot_Number -- | |
395 | ----------------- | |
396 | ||
397 | function Slot_Number (Prim : Entity_Id) return Uint is | |
1c218ac3 | 398 | E : constant Entity_Id := Ultimate_Alias (Prim); |
9c41193c | 399 | begin |
1c218ac3 AC |
400 | if Is_Predefined_Dispatching_Operation (E) then |
401 | return -DT_Position (E); | |
9c41193c | 402 | else |
1c218ac3 | 403 | return DT_Position (E); |
9c41193c JM |
404 | end if; |
405 | end Slot_Number; | |
406 | ||
407 | ------------------ | |
408 | -- Write_Output -- | |
409 | ------------------ | |
410 | ||
9c41193c | 411 | procedure Write_Output (Str : String) is |
c88f5c49 JM |
412 | Nul : constant Character := Character'First; |
413 | Line : String (Str'First .. Str'Last + 1); | |
414 | Errno : Integer; | |
d69cf005 | 415 | |
9c41193c | 416 | begin |
c88f5c49 JM |
417 | -- Add the null character to the string as required by fputs |
418 | ||
419 | Line := Str & Nul; | |
420 | Errno := fputs (Line'Address, Callgraph_Info_File); | |
421 | pragma Assert (Errno >= 0); | |
9c41193c JM |
422 | end Write_Output; |
423 | ||
424 | --------------------- | |
425 | -- Write_Call_Info -- | |
426 | --------------------- | |
427 | ||
428 | procedure Write_Call_Info (Call : Node_Id) is | |
429 | Ctrl_Arg : constant Node_Id := Controlling_Argument (Call); | |
430 | Ctrl_Typ : constant Entity_Id := Base_Type (Etype (Ctrl_Arg)); | |
431 | Prim : constant Entity_Id := Entity (Sinfo.Name (Call)); | |
a7c764a9 | 432 | P : constant Node_Id := Parent (Call); |
9c41193c JM |
433 | |
434 | begin | |
9c41193c JM |
435 | Write_Str ("edge: { sourcename: "); |
436 | Write_Char ('"'); | |
e1d9659d AC |
437 | |
438 | -- The parent node is the construct that contains the call: subprogram | |
439 | -- body or library-level package. Display the qualified name of the | |
440 | -- entity of the construct. For a subprogram, it is the entity of the | |
441 | -- spec, which carries a homonym counter when it is overloaded. | |
442 | ||
e7c0dd39 AC |
443 | if Nkind (P) = N_Subprogram_Body |
444 | and then not Acts_As_Spec (P) | |
445 | then | |
93582885 | 446 | Get_External_Name (Corresponding_Spec (P)); |
e1d9659d AC |
447 | |
448 | else | |
93582885 | 449 | Get_External_Name (Defining_Entity (P)); |
e1d9659d AC |
450 | end if; |
451 | ||
008f6fd3 | 452 | Write_Str (Name_Buffer (1 .. Name_Len)); |
9c41193c JM |
453 | |
454 | if Nkind (P) = N_Package_Declaration then | |
455 | Write_Str ("___elabs"); | |
456 | ||
457 | elsif Nkind (P) = N_Package_Body then | |
458 | Write_Str ("___elabb"); | |
459 | end if; | |
460 | ||
461 | Write_Char ('"'); | |
462 | Write_Eol; | |
463 | ||
464 | -- The targetname is a triple: | |
465 | -- N: the index in a vtable used for dispatch | |
466 | -- V: the type who's vtable is used | |
467 | -- S: the static type of the expression | |
468 | ||
469 | Write_Str (" targetname: "); | |
470 | Write_Char ('"'); | |
471 | ||
472 | pragma Assert (No (Interface_Alias (Prim))); | |
473 | ||
474 | -- The check on Is_Ancestor is done here to avoid problems with | |
475 | -- renamings of primitives. For example: | |
476 | ||
477 | -- type Root is tagged ... | |
478 | -- procedure Base (Obj : Root); | |
479 | -- procedure Base2 (Obj : Root) renames Base; | |
480 | ||
481 | if Present (Alias (Prim)) | |
482 | and then | |
483 | Is_Ancestor | |
484 | (Find_Dispatching_Type (Ultimate_Alias (Prim)), | |
4ac2477e JM |
485 | Root_Type (Ctrl_Typ), |
486 | Use_Full_View => True) | |
9c41193c | 487 | then |
9db0b232 AC |
488 | -- This is a special case in which we generate in the ci file the |
489 | -- slot number of the renaming primitive (i.e. Base2) but instead of | |
490 | -- generating the name of this renaming entity we reference directly | |
491 | -- the renamed entity (i.e. Base). | |
492 | ||
493 | Write_Int (UI_To_Int (Slot_Number (Prim))); | |
9c41193c JM |
494 | Write_Char (':'); |
495 | Write_Name | |
496 | (Chars (Find_Dispatching_Type (Ultimate_Alias (Prim)))); | |
497 | else | |
498 | Write_Int (UI_To_Int (Slot_Number (Prim))); | |
499 | Write_Char (':'); | |
500 | Write_Name (Chars (Root_Type (Ctrl_Typ))); | |
501 | end if; | |
502 | ||
503 | Write_Char (','); | |
504 | Write_Name (Chars (Root_Type (Ctrl_Typ))); | |
505 | ||
506 | Write_Char ('"'); | |
507 | Write_Eol; | |
508 | ||
509 | Write_Str (" label: "); | |
510 | Write_Char ('"'); | |
511 | Write_Location (Sloc (Call)); | |
512 | Write_Char ('"'); | |
513 | Write_Eol; | |
514 | ||
515 | Write_Char ('}'); | |
516 | Write_Eol; | |
517 | end Write_Call_Info; | |
518 | ||
519 | --------------------- | |
520 | -- Write_Type_Info -- | |
521 | --------------------- | |
522 | ||
523 | procedure Write_Type_Info (Typ : Entity_Id) is | |
524 | Elmt : Elmt_Id; | |
525 | Prim : Node_Id; | |
526 | ||
527 | Parent_Typ : Entity_Id; | |
528 | Separator_Needed : Boolean := False; | |
529 | ||
530 | begin | |
531 | -- Initialize Parent_Typ handling private types | |
532 | ||
533 | Parent_Typ := Etype (Typ); | |
534 | ||
535 | if Present (Full_View (Parent_Typ)) then | |
536 | Parent_Typ := Full_View (Parent_Typ); | |
537 | end if; | |
538 | ||
539 | Write_Str ("class {"); | |
540 | Write_Eol; | |
541 | ||
542 | Write_Str (" classname: "); | |
543 | Write_Char ('"'); | |
544 | Write_Name (Chars (Typ)); | |
545 | Write_Char ('"'); | |
546 | Write_Eol; | |
547 | ||
548 | Write_Str (" label: "); | |
549 | Write_Char ('"'); | |
550 | Write_Name (Chars (Typ)); | |
551 | Write_Char ('\'); | |
552 | Write_Location (Sloc (Typ)); | |
553 | Write_Char ('"'); | |
554 | Write_Eol; | |
555 | ||
556 | if Parent_Typ /= Typ then | |
557 | Write_Str (" parent: "); | |
558 | Write_Char ('"'); | |
559 | Write_Name (Chars (Parent_Typ)); | |
560 | ||
561 | -- Note: Einfo prefix not needed if this routine is moved to | |
562 | -- exp_disp??? | |
563 | ||
564 | if Present (Einfo.Interfaces (Typ)) | |
565 | and then not Is_Empty_Elmt_List (Einfo.Interfaces (Typ)) | |
566 | then | |
567 | Elmt := First_Elmt (Einfo.Interfaces (Typ)); | |
568 | while Present (Elmt) loop | |
569 | Write_Str (", "); | |
570 | Write_Name (Chars (Node (Elmt))); | |
571 | Next_Elmt (Elmt); | |
572 | end loop; | |
573 | end if; | |
574 | ||
575 | Write_Char ('"'); | |
576 | Write_Eol; | |
577 | end if; | |
578 | ||
579 | Write_Str (" virtuals: "); | |
580 | Write_Char ('"'); | |
581 | ||
582 | Elmt := First_Elmt (Primitive_Operations (Typ)); | |
583 | while Present (Elmt) loop | |
584 | Prim := Node (Elmt); | |
585 | ||
9db0b232 | 586 | -- Skip internal entities associated with overridden interface |
f5d96d00 | 587 | -- primitives, and also inherited primitives. |
9c41193c | 588 | |
f5d96d00 AC |
589 | if Present (Interface_Alias (Prim)) |
590 | or else | |
d69cf005 AC |
591 | (Present (Alias (Prim)) |
592 | and then Find_Dispatching_Type (Prim) /= | |
593 | Find_Dispatching_Type (Alias (Prim))) | |
f5d96d00 | 594 | then |
9c41193c JM |
595 | goto Continue; |
596 | end if; | |
597 | ||
598 | -- Do not generate separator for output of first primitive | |
599 | ||
600 | if Separator_Needed then | |
601 | Write_Str ("\n"); | |
602 | Write_Eol; | |
603 | Write_Str (" "); | |
604 | else | |
605 | Separator_Needed := True; | |
606 | end if; | |
607 | ||
608 | Write_Int (UI_To_Int (Slot_Number (Prim))); | |
609 | Write_Char (':'); | |
9db0b232 AC |
610 | |
611 | -- Handle renamed primitives | |
612 | ||
613 | if Present (Alias (Prim)) then | |
614 | Write_Name (Chars (Ultimate_Alias (Prim))); | |
615 | else | |
616 | Write_Name (Chars (Prim)); | |
617 | end if; | |
9c41193c JM |
618 | |
619 | -- Display overriding of parent primitives | |
620 | ||
621 | if Present (Overridden_Operation (Prim)) | |
622 | and then | |
623 | Is_Ancestor | |
4ac2477e JM |
624 | (Find_Dispatching_Type (Overridden_Operation (Prim)), Typ, |
625 | Use_Full_View => True) | |
9c41193c JM |
626 | then |
627 | Write_Char (','); | |
628 | Write_Int | |
629 | (UI_To_Int (Slot_Number (Overridden_Operation (Prim)))); | |
630 | Write_Char (':'); | |
631 | Write_Name | |
632 | (Chars (Find_Dispatching_Type (Overridden_Operation (Prim)))); | |
633 | end if; | |
634 | ||
635 | -- Display overriding of interface primitives | |
636 | ||
637 | if Has_Interfaces (Typ) then | |
638 | declare | |
639 | Prim_Elmt : Elmt_Id; | |
640 | Prim_Op : Node_Id; | |
641 | Int_Alias : Entity_Id; | |
642 | ||
643 | begin | |
644 | Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); | |
645 | while Present (Prim_Elmt) loop | |
646 | Prim_Op := Node (Prim_Elmt); | |
647 | Int_Alias := Interface_Alias (Prim_Op); | |
648 | ||
b4d7b435 | 649 | if Present (Int_Alias) |
d69cf005 | 650 | and then |
4ac2477e JM |
651 | not Is_Ancestor (Find_Dispatching_Type (Int_Alias), Typ, |
652 | Use_Full_View => True) | |
b4d7b435 AC |
653 | and then (Alias (Prim_Op)) = Prim |
654 | then | |
9c41193c JM |
655 | Write_Char (','); |
656 | Write_Int (UI_To_Int (Slot_Number (Int_Alias))); | |
657 | Write_Char (':'); | |
658 | Write_Name (Chars (Find_Dispatching_Type (Int_Alias))); | |
659 | end if; | |
660 | ||
661 | Next_Elmt (Prim_Elmt); | |
662 | end loop; | |
663 | end; | |
664 | end if; | |
665 | ||
666 | <<Continue>> | |
667 | Next_Elmt (Elmt); | |
668 | end loop; | |
669 | ||
670 | Write_Char ('"'); | |
671 | Write_Eol; | |
672 | ||
673 | Write_Char ('}'); | |
674 | Write_Eol; | |
675 | end Write_Type_Info; | |
676 | ||
677 | end Exp_CG; |