]>
Commit | Line | Data |
---|---|---|
70482933 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- E X P _ I N T R -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
7324bf49 | 9 | -- Copyright (C) 1992-2004 Free Software Foundation, Inc. -- |
70482933 RK |
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 2, 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 COPYING. If not, write -- | |
19 | -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- | |
20 | -- MA 02111-1307, USA. -- | |
21 | -- -- | |
22 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
71ff80dc | 23 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
70482933 RK |
24 | -- -- |
25 | ------------------------------------------------------------------------------ | |
26 | ||
27 | with Atree; use Atree; | |
28 | with Einfo; use Einfo; | |
29 | with Errout; use Errout; | |
30 | with Exp_Ch4; use Exp_Ch4; | |
31 | with Exp_Ch7; use Exp_Ch7; | |
70482933 RK |
32 | with Exp_Ch11; use Exp_Ch11; |
33 | with Exp_Code; use Exp_Code; | |
34 | with Exp_Fixd; use Exp_Fixd; | |
35 | with Exp_Util; use Exp_Util; | |
36 | with Itypes; use Itypes; | |
37 | with Namet; use Namet; | |
38 | with Nmake; use Nmake; | |
39 | with Nlists; use Nlists; | |
40 | with Restrict; use Restrict; | |
41 | with Rtsfind; use Rtsfind; | |
42 | with Sem; use Sem; | |
43 | with Sem_Eval; use Sem_Eval; | |
44 | with Sem_Res; use Sem_Res; | |
45 | with Sem_Util; use Sem_Util; | |
46 | with Sinfo; use Sinfo; | |
47 | with Sinput; use Sinput; | |
48 | with Snames; use Snames; | |
49 | with Stand; use Stand; | |
50 | with Stringt; use Stringt; | |
51 | with Tbuild; use Tbuild; | |
52 | with Uintp; use Uintp; | |
53 | with Urealp; use Urealp; | |
54 | ||
55 | package body Exp_Intr is | |
56 | ||
57 | ----------------------- | |
58 | -- Local Subprograms -- | |
59 | ----------------------- | |
60 | ||
61 | procedure Expand_Is_Negative (N : Node_Id); | |
62 | -- Expand a call to the intrinsic Is_Negative function | |
63 | ||
64 | procedure Expand_Exception_Call (N : Node_Id; Ent : RE_Id); | |
65 | -- Expand a call to Exception_Information/Message/Name. The first | |
66 | -- parameter, N, is the node for the function call, and Ent is the | |
67 | -- entity for the corresponding routine in the Ada.Exceptions package. | |
68 | ||
69 | procedure Expand_Import_Call (N : Node_Id); | |
70 | -- Expand a call to Import_Address/Longest_Integer/Value. The parameter | |
71 | -- N is the node for the function call. | |
72 | ||
73 | procedure Expand_Shift (N : Node_Id; E : Entity_Id; K : Node_Kind); | |
74 | -- Expand an intrinsic shift operation, N and E are from the call to | |
5453d5bd | 75 | -- Expand_Intrinsic_Call (call node and subprogram spec entity) and |
70482933 RK |
76 | -- K is the kind for the shift node |
77 | ||
78 | procedure Expand_Unc_Conversion (N : Node_Id; E : Entity_Id); | |
79 | -- Expand a call to an instantiation of Unchecked_Convertion into a node | |
80 | -- N_Unchecked_Type_Conversion. | |
81 | ||
07fc65c4 | 82 | procedure Expand_Unc_Deallocation (N : Node_Id); |
70482933 RK |
83 | -- Expand a call to an instantiation of Unchecked_Deallocation into a node |
84 | -- N_Free_Statement and appropriate context. | |
85 | ||
fbf5a39b AC |
86 | procedure Expand_To_Address (N : Node_Id); |
87 | procedure Expand_To_Pointer (N : Node_Id); | |
88 | -- Expand a call to corresponding function, declared in an instance of | |
89 | -- System.Addess_To_Access_Conversions. | |
90 | ||
07fc65c4 | 91 | procedure Expand_Source_Info (N : Node_Id; Nam : Name_Id); |
70482933 RK |
92 | -- Rewrite the node by the appropriate string or positive constant. |
93 | -- Nam can be one of the following: | |
94 | -- Name_File - expand string that is the name of source file | |
95 | -- Name_Line - expand integer line number | |
96 | -- Name_Source_Location - expand string of form file:line | |
97 | -- Name_Enclosing_Entity - expand string with name of enclosing entity | |
98 | ||
99 | --------------------------- | |
100 | -- Expand_Exception_Call -- | |
101 | --------------------------- | |
102 | ||
103 | -- If the function call is not within an exception handler, then the | |
104 | -- call is replaced by a null string. Otherwise the appropriate routine | |
105 | -- in Ada.Exceptions is called passing the choice parameter specification | |
106 | -- from the enclosing handler. If the enclosing handler lacks a choice | |
107 | -- parameter, then one is supplied. | |
108 | ||
109 | procedure Expand_Exception_Call (N : Node_Id; Ent : RE_Id) is | |
110 | Loc : constant Source_Ptr := Sloc (N); | |
111 | P : Node_Id; | |
112 | E : Entity_Id; | |
113 | S : String_Id; | |
114 | ||
115 | begin | |
116 | -- Climb up parents to see if we are in exception handler | |
117 | ||
118 | P := Parent (N); | |
119 | loop | |
120 | -- Case of not in exception handler | |
121 | ||
122 | if No (P) then | |
123 | Start_String; | |
124 | S := End_String; | |
125 | Rewrite (N, | |
126 | Make_String_Literal (Loc, | |
127 | Strval => S)); | |
128 | exit; | |
129 | ||
130 | -- Case of in exception handler | |
131 | ||
132 | elsif Nkind (P) = N_Exception_Handler then | |
133 | if No (Choice_Parameter (P)) then | |
134 | ||
135 | -- If no choice parameter present, then put one there. Note | |
136 | -- that we do not need to put it on the entity chain, since | |
137 | -- no one will be referencing it by normal visibility methods. | |
138 | ||
139 | E := Make_Defining_Identifier (Loc, New_Internal_Name ('E')); | |
140 | Set_Choice_Parameter (P, E); | |
141 | Set_Ekind (E, E_Variable); | |
142 | Set_Etype (E, RTE (RE_Exception_Occurrence)); | |
143 | Set_Scope (E, Current_Scope); | |
144 | end if; | |
145 | ||
146 | Rewrite (N, | |
147 | Make_Function_Call (Loc, | |
148 | Name => New_Occurrence_Of (RTE (Ent), Loc), | |
149 | Parameter_Associations => New_List ( | |
150 | New_Occurrence_Of (Choice_Parameter (P), Loc)))); | |
151 | exit; | |
152 | ||
153 | -- Keep climbing! | |
154 | ||
155 | else | |
156 | P := Parent (P); | |
157 | end if; | |
158 | end loop; | |
159 | ||
160 | Analyze_And_Resolve (N, Standard_String); | |
161 | end Expand_Exception_Call; | |
162 | ||
163 | ------------------------ | |
164 | -- Expand_Import_Call -- | |
165 | ------------------------ | |
166 | ||
167 | -- The function call must have a static string as its argument. We create | |
168 | -- a dummy variable which uses this string as the external name in an | |
169 | -- Import pragma. The result is then obtained as the address of this | |
170 | -- dummy variable, converted to the appropriate target type. | |
171 | ||
172 | procedure Expand_Import_Call (N : Node_Id) is | |
173 | Loc : constant Source_Ptr := Sloc (N); | |
174 | Ent : constant Entity_Id := Entity (Name (N)); | |
175 | Str : constant Node_Id := First_Actual (N); | |
176 | Dum : Entity_Id; | |
177 | ||
178 | begin | |
179 | Dum := Make_Defining_Identifier (Loc, New_Internal_Name ('D')); | |
180 | ||
181 | Insert_Actions (N, New_List ( | |
182 | Make_Object_Declaration (Loc, | |
183 | Defining_Identifier => Dum, | |
184 | Object_Definition => | |
185 | New_Occurrence_Of (Standard_Character, Loc)), | |
186 | ||
187 | Make_Pragma (Loc, | |
188 | Chars => Name_Import, | |
189 | Pragma_Argument_Associations => New_List ( | |
190 | Make_Pragma_Argument_Association (Loc, | |
191 | Expression => Make_Identifier (Loc, Name_Ada)), | |
192 | ||
193 | Make_Pragma_Argument_Association (Loc, | |
194 | Expression => Make_Identifier (Loc, Chars (Dum))), | |
195 | ||
196 | Make_Pragma_Argument_Association (Loc, | |
197 | Chars => Name_Link_Name, | |
198 | Expression => Relocate_Node (Str)))))); | |
199 | ||
200 | Rewrite (N, | |
201 | Unchecked_Convert_To (Etype (Ent), | |
202 | Make_Attribute_Reference (Loc, | |
203 | Attribute_Name => Name_Address, | |
204 | Prefix => Make_Identifier (Loc, Chars (Dum))))); | |
205 | ||
206 | Analyze_And_Resolve (N, Etype (Ent)); | |
207 | end Expand_Import_Call; | |
208 | ||
209 | --------------------------- | |
210 | -- Expand_Intrinsic_Call -- | |
211 | --------------------------- | |
212 | ||
213 | procedure Expand_Intrinsic_Call (N : Node_Id; E : Entity_Id) is | |
214 | Nam : Name_Id; | |
215 | ||
216 | begin | |
7324bf49 | 217 | -- If the intrinsic subprogram is generic, gets its original name |
70482933 RK |
218 | |
219 | if Present (Parent (E)) | |
220 | and then Present (Generic_Parent (Parent (E))) | |
221 | then | |
222 | Nam := Chars (Generic_Parent (Parent (E))); | |
223 | else | |
224 | Nam := Chars (E); | |
225 | end if; | |
226 | ||
227 | if Nam = Name_Asm then | |
228 | Expand_Asm_Call (N); | |
229 | ||
230 | elsif Nam = Name_Divide then | |
231 | Expand_Decimal_Divide_Call (N); | |
232 | ||
233 | elsif Nam = Name_Exception_Information then | |
234 | Expand_Exception_Call (N, RE_Exception_Information); | |
235 | ||
236 | elsif Nam = Name_Exception_Message then | |
237 | Expand_Exception_Call (N, RE_Exception_Message); | |
238 | ||
239 | elsif Nam = Name_Exception_Name then | |
240 | Expand_Exception_Call (N, RE_Exception_Name_Simple); | |
241 | ||
242 | elsif Nam = Name_Import_Address | |
243 | or else | |
244 | Nam = Name_Import_Largest_Value | |
245 | or else | |
246 | Nam = Name_Import_Value | |
247 | then | |
248 | Expand_Import_Call (N); | |
249 | ||
250 | elsif Nam = Name_Is_Negative then | |
251 | Expand_Is_Negative (N); | |
252 | ||
253 | elsif Nam = Name_Rotate_Left then | |
254 | Expand_Shift (N, E, N_Op_Rotate_Left); | |
255 | ||
256 | elsif Nam = Name_Rotate_Right then | |
257 | Expand_Shift (N, E, N_Op_Rotate_Right); | |
258 | ||
259 | elsif Nam = Name_Shift_Left then | |
260 | Expand_Shift (N, E, N_Op_Shift_Left); | |
261 | ||
262 | elsif Nam = Name_Shift_Right then | |
263 | Expand_Shift (N, E, N_Op_Shift_Right); | |
264 | ||
265 | elsif Nam = Name_Shift_Right_Arithmetic then | |
266 | Expand_Shift (N, E, N_Op_Shift_Right_Arithmetic); | |
267 | ||
268 | elsif Nam = Name_Unchecked_Conversion then | |
269 | Expand_Unc_Conversion (N, E); | |
270 | ||
271 | elsif Nam = Name_Unchecked_Deallocation then | |
07fc65c4 | 272 | Expand_Unc_Deallocation (N); |
70482933 | 273 | |
fbf5a39b AC |
274 | elsif Nam = Name_To_Address then |
275 | Expand_To_Address (N); | |
276 | ||
277 | elsif Nam = Name_To_Pointer then | |
278 | Expand_To_Pointer (N); | |
279 | ||
70482933 RK |
280 | elsif Nam = Name_File |
281 | or else Nam = Name_Line | |
282 | or else Nam = Name_Source_Location | |
283 | or else Nam = Name_Enclosing_Entity | |
284 | then | |
07fc65c4 | 285 | Expand_Source_Info (N, Nam); |
70482933 RK |
286 | |
287 | else | |
288 | -- Only other possibility is a renaming, in which case we expand | |
289 | -- the call to the original operation (which must be intrinsic). | |
290 | ||
291 | pragma Assert (Present (Alias (E))); | |
292 | Expand_Intrinsic_Call (N, Alias (E)); | |
293 | end if; | |
70482933 RK |
294 | end Expand_Intrinsic_Call; |
295 | ||
296 | ------------------------ | |
297 | -- Expand_Is_Negative -- | |
298 | ------------------------ | |
299 | ||
300 | procedure Expand_Is_Negative (N : Node_Id) is | |
301 | Loc : constant Source_Ptr := Sloc (N); | |
302 | Opnd : constant Node_Id := Relocate_Node (First_Actual (N)); | |
303 | ||
304 | begin | |
305 | ||
306 | -- We replace the function call by the following expression | |
307 | ||
308 | -- if Opnd < 0.0 then | |
309 | -- True | |
310 | -- else | |
311 | -- if Opnd > 0.0 then | |
312 | -- False; | |
313 | -- else | |
314 | -- Float_Unsigned!(Float (Opnd)) /= 0 | |
315 | -- end if; | |
316 | -- end if; | |
317 | ||
318 | Rewrite (N, | |
319 | Make_Conditional_Expression (Loc, | |
320 | Expressions => New_List ( | |
321 | Make_Op_Lt (Loc, | |
322 | Left_Opnd => Duplicate_Subexpr (Opnd), | |
323 | Right_Opnd => Make_Real_Literal (Loc, Ureal_0)), | |
324 | ||
325 | New_Occurrence_Of (Standard_True, Loc), | |
326 | ||
327 | Make_Conditional_Expression (Loc, | |
328 | Expressions => New_List ( | |
329 | Make_Op_Gt (Loc, | |
fbf5a39b | 330 | Left_Opnd => Duplicate_Subexpr_No_Checks (Opnd), |
70482933 RK |
331 | Right_Opnd => Make_Real_Literal (Loc, Ureal_0)), |
332 | ||
333 | New_Occurrence_Of (Standard_False, Loc), | |
334 | ||
335 | Make_Op_Ne (Loc, | |
336 | Left_Opnd => | |
fbf5a39b AC |
337 | Unchecked_Convert_To |
338 | (RTE (RE_Float_Unsigned), | |
339 | Convert_To | |
340 | (Standard_Float, | |
341 | Duplicate_Subexpr_No_Checks (Opnd))), | |
70482933 RK |
342 | Right_Opnd => |
343 | Make_Integer_Literal (Loc, 0))))))); | |
344 | ||
345 | Analyze_And_Resolve (N, Standard_Boolean); | |
346 | end Expand_Is_Negative; | |
347 | ||
348 | ------------------ | |
349 | -- Expand_Shift -- | |
350 | ------------------ | |
351 | ||
352 | -- This procedure is used to convert a call to a shift function to the | |
353 | -- corresponding operator node. This conversion is not done by the usual | |
354 | -- circuit for converting calls to operator functions (e.g. "+"(1,2)) to | |
355 | -- operator nodes, because shifts are not predefined operators. | |
356 | ||
357 | -- As a result, whenever a shift is used in the source program, it will | |
358 | -- remain as a call until converted by this routine to the operator node | |
359 | -- form which Gigi is expecting to see. | |
360 | ||
361 | -- Note: it is possible for the expander to generate shift operator nodes | |
362 | -- directly, which will be analyzed in the normal manner by calling Analyze | |
363 | -- and Resolve. Such shift operator nodes will not be seen by Expand_Shift. | |
364 | ||
365 | procedure Expand_Shift (N : Node_Id; E : Entity_Id; K : Node_Kind) is | |
366 | Loc : constant Source_Ptr := Sloc (N); | |
367 | Typ : constant Entity_Id := Etype (N); | |
368 | Left : constant Node_Id := First_Actual (N); | |
369 | Right : constant Node_Id := Next_Actual (Left); | |
370 | Ltyp : constant Node_Id := Etype (Left); | |
371 | Rtyp : constant Node_Id := Etype (Right); | |
372 | Snode : Node_Id; | |
373 | ||
374 | begin | |
375 | Snode := New_Node (K, Loc); | |
376 | Set_Left_Opnd (Snode, Relocate_Node (Left)); | |
377 | Set_Right_Opnd (Snode, Relocate_Node (Right)); | |
378 | Set_Chars (Snode, Chars (E)); | |
379 | Set_Etype (Snode, Base_Type (Typ)); | |
380 | Set_Entity (Snode, E); | |
381 | ||
382 | if Compile_Time_Known_Value (Type_High_Bound (Rtyp)) | |
383 | and then Expr_Value (Type_High_Bound (Rtyp)) < Esize (Ltyp) | |
384 | then | |
385 | Set_Shift_Count_OK (Snode, True); | |
386 | end if; | |
387 | ||
388 | -- Do the rewrite. Note that we don't call Analyze and Resolve on | |
389 | -- this node, because it already got analyzed and resolved when | |
390 | -- it was a function call! | |
391 | ||
392 | Rewrite (N, Snode); | |
393 | Set_Analyzed (N); | |
70482933 RK |
394 | end Expand_Shift; |
395 | ||
396 | ------------------------ | |
397 | -- Expand_Source_Info -- | |
398 | ------------------------ | |
399 | ||
07fc65c4 | 400 | procedure Expand_Source_Info (N : Node_Id; Nam : Name_Id) is |
70482933 RK |
401 | Loc : constant Source_Ptr := Sloc (N); |
402 | Ent : Entity_Id; | |
403 | ||
404 | begin | |
405 | -- Integer cases | |
406 | ||
407 | if Nam = Name_Line then | |
408 | Rewrite (N, | |
409 | Make_Integer_Literal (Loc, | |
410 | Intval => UI_From_Int (Int (Get_Logical_Line_Number (Loc))))); | |
411 | Analyze_And_Resolve (N, Standard_Positive); | |
412 | ||
413 | -- String cases | |
414 | ||
415 | else | |
416 | case Nam is | |
417 | when Name_File => | |
418 | Get_Decoded_Name_String | |
419 | (Reference_Name (Get_Source_File_Index (Loc))); | |
420 | ||
421 | when Name_Source_Location => | |
422 | Build_Location_String (Loc); | |
423 | ||
424 | when Name_Enclosing_Entity => | |
425 | Name_Len := 0; | |
426 | ||
427 | Ent := Current_Scope; | |
428 | ||
429 | -- Skip enclosing blocks to reach enclosing unit. | |
430 | ||
431 | while Present (Ent) loop | |
432 | exit when Ekind (Ent) /= E_Block | |
433 | and then Ekind (Ent) /= E_Loop; | |
434 | Ent := Scope (Ent); | |
435 | end loop; | |
436 | ||
437 | -- Ent now points to the relevant defining entity | |
438 | ||
439 | declare | |
440 | SDef : Source_Ptr := Sloc (Ent); | |
441 | TDef : Source_Buffer_Ptr; | |
442 | ||
443 | begin | |
444 | TDef := Source_Text (Get_Source_File_Index (SDef)); | |
445 | Name_Len := 0; | |
446 | ||
447 | while TDef (SDef) in '0' .. '9' | |
448 | or else TDef (SDef) >= 'A' | |
449 | or else TDef (SDef) = ASCII.ESC | |
450 | loop | |
451 | Add_Char_To_Name_Buffer (TDef (SDef)); | |
452 | SDef := SDef + 1; | |
453 | end loop; | |
454 | end; | |
455 | ||
456 | when others => | |
457 | raise Program_Error; | |
458 | end case; | |
459 | ||
460 | Rewrite (N, | |
461 | Make_String_Literal (Loc, Strval => String_From_Name_Buffer)); | |
462 | Analyze_And_Resolve (N, Standard_String); | |
463 | end if; | |
464 | ||
465 | Set_Is_Static_Expression (N); | |
466 | end Expand_Source_Info; | |
467 | ||
468 | --------------------------- | |
469 | -- Expand_Unc_Conversion -- | |
470 | --------------------------- | |
471 | ||
472 | procedure Expand_Unc_Conversion (N : Node_Id; E : Entity_Id) is | |
473 | Func : constant Entity_Id := Entity (Name (N)); | |
474 | Conv : Node_Id; | |
475 | Ftyp : Entity_Id; | |
476 | ||
477 | begin | |
478 | -- Rewrite as unchecked conversion node. Note that we must convert | |
479 | -- the operand to the formal type of the input parameter of the | |
480 | -- function, so that the resulting N_Unchecked_Type_Conversion | |
481 | -- call indicates the correct types for Gigi. | |
482 | ||
483 | -- Right now, we only do this if a scalar type is involved. It is | |
484 | -- not clear if it is needed in other cases. If we do attempt to | |
485 | -- do the conversion unconditionally, it crashes 3411-018. To be | |
486 | -- investigated further ??? | |
487 | ||
488 | Conv := Relocate_Node (First_Actual (N)); | |
489 | Ftyp := Etype (First_Formal (Func)); | |
490 | ||
491 | if Is_Scalar_Type (Ftyp) then | |
492 | Conv := Convert_To (Ftyp, Conv); | |
493 | Set_Parent (Conv, N); | |
494 | Analyze_And_Resolve (Conv); | |
495 | end if; | |
496 | ||
497 | -- We do the analysis here, because we do not want the compiler | |
498 | -- to try to optimize or otherwise reorganize the unchecked | |
499 | -- conversion node. | |
500 | ||
501 | Rewrite (N, Unchecked_Convert_To (Etype (E), Conv)); | |
502 | Set_Etype (N, Etype (E)); | |
503 | Set_Analyzed (N); | |
504 | ||
505 | if Nkind (N) = N_Unchecked_Type_Conversion then | |
506 | Expand_N_Unchecked_Type_Conversion (N); | |
507 | end if; | |
508 | end Expand_Unc_Conversion; | |
509 | ||
510 | ----------------------------- | |
511 | -- Expand_Unc_Deallocation -- | |
512 | ----------------------------- | |
513 | ||
514 | -- Generate the following Code : | |
515 | ||
516 | -- if Arg /= null then | |
517 | -- <Finalize_Call> (.., T'Class(Arg.all), ..); -- for controlled types | |
518 | -- Free (Arg); | |
519 | -- Arg := Null; | |
520 | -- end if; | |
521 | ||
522 | -- For a task, we also generate a call to Free_Task to ensure that the | |
523 | -- task itself is freed if it is terminated, ditto for a simple protected | |
fbf5a39b AC |
524 | -- object, with a call to Finalize_Protection. For composite types that |
525 | -- have tasks or simple protected objects as components, we traverse the | |
526 | -- structures to find and terminate those components. | |
70482933 | 527 | |
07fc65c4 | 528 | procedure Expand_Unc_Deallocation (N : Node_Id) is |
70482933 RK |
529 | Loc : constant Source_Ptr := Sloc (N); |
530 | Arg : constant Node_Id := First_Actual (N); | |
531 | Typ : constant Entity_Id := Etype (Arg); | |
532 | Stmts : constant List_Id := New_List; | |
fbf5a39b AC |
533 | Rtyp : constant Entity_Id := Underlying_Type (Root_Type (Typ)); |
534 | Pool : constant Entity_Id := Associated_Storage_Pool (Rtyp); | |
70482933 | 535 | |
fbf5a39b | 536 | Desig_T : constant Entity_Id := Designated_Type (Typ); |
70482933 RK |
537 | Gen_Code : Node_Id; |
538 | Free_Node : Node_Id; | |
539 | Deref : Node_Id; | |
540 | Free_Arg : Node_Id; | |
541 | Free_Cod : List_Id; | |
542 | Blk : Node_Id; | |
543 | ||
544 | begin | |
fbf5a39b AC |
545 | if No_Pool_Assigned (Rtyp) then |
546 | Error_Msg_N ("?deallocation from empty storage pool", N); | |
547 | end if; | |
70482933 | 548 | |
fbf5a39b AC |
549 | if Controlled_Type (Desig_T) then |
550 | Deref := | |
551 | Make_Explicit_Dereference (Loc, | |
552 | Prefix => Duplicate_Subexpr_No_Checks (Arg)); | |
70482933 RK |
553 | |
554 | -- If the type is tagged, then we must force dispatching on the | |
555 | -- finalization call because the designated type may not be the | |
556 | -- actual type of the object | |
557 | ||
558 | if Is_Tagged_Type (Desig_T) | |
559 | and then not Is_Class_Wide_Type (Desig_T) | |
560 | then | |
561 | Deref := Unchecked_Convert_To (Class_Wide_Type (Desig_T), Deref); | |
562 | end if; | |
563 | ||
564 | Free_Cod := | |
565 | Make_Final_Call | |
566 | (Ref => Deref, | |
567 | Typ => Desig_T, | |
568 | With_Detach => New_Reference_To (Standard_True, Loc)); | |
569 | ||
570 | if Abort_Allowed then | |
571 | Prepend_To (Free_Cod, | |
572 | Build_Runtime_Call (Loc, RE_Abort_Defer)); | |
573 | ||
574 | Blk := | |
575 | Make_Block_Statement (Loc, Handled_Statement_Sequence => | |
576 | Make_Handled_Sequence_Of_Statements (Loc, | |
577 | Statements => Free_Cod, | |
578 | At_End_Proc => | |
579 | New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc))); | |
580 | ||
581 | -- We now expand the exception (at end) handler. We set a | |
582 | -- temporary parent pointer since we have not attached Blk | |
583 | -- to the tree yet. | |
584 | ||
585 | Set_Parent (Blk, N); | |
586 | Analyze (Blk); | |
587 | Expand_At_End_Handler | |
588 | (Handled_Statement_Sequence (Blk), Entity (Identifier (Blk))); | |
589 | Append (Blk, Stmts); | |
590 | ||
591 | else | |
592 | Append_List_To (Stmts, Free_Cod); | |
593 | end if; | |
594 | end if; | |
595 | ||
fbf5a39b | 596 | -- For a task type, call Free_Task before freeing the ATCB |
70482933 RK |
597 | |
598 | if Is_Task_Type (Desig_T) then | |
70482933 RK |
599 | declare |
600 | Stat : Node_Id := Prev (N); | |
601 | Nam1 : Node_Id; | |
602 | Nam2 : Node_Id; | |
603 | ||
604 | begin | |
605 | -- An Abort followed by a Free will not do what the user | |
fbf5a39b AC |
606 | -- expects, because the abort is not immediate. This is |
607 | -- worth a friendly warning. | |
70482933 RK |
608 | |
609 | while Present (Stat) | |
610 | and then not Comes_From_Source (Original_Node (Stat)) | |
611 | loop | |
612 | Prev (Stat); | |
613 | end loop; | |
614 | ||
615 | if Present (Stat) | |
616 | and then Nkind (Original_Node (Stat)) = N_Abort_Statement | |
617 | then | |
618 | Stat := Original_Node (Stat); | |
619 | Nam1 := First (Names (Stat)); | |
620 | Nam2 := Original_Node (First (Parameter_Associations (N))); | |
621 | ||
622 | if Nkind (Nam1) = N_Explicit_Dereference | |
623 | and then Is_Entity_Name (Prefix (Nam1)) | |
624 | and then Is_Entity_Name (Nam2) | |
625 | and then Entity (Prefix (Nam1)) = Entity (Nam2) | |
626 | then | |
627 | Error_Msg_N ("Abort may take time to complete?", N); | |
628 | Error_Msg_N ("\deallocation might have no effect?", N); | |
629 | Error_Msg_N ("\safer to wait for termination.?", N); | |
630 | end if; | |
631 | end if; | |
632 | end; | |
633 | ||
fbf5a39b AC |
634 | Append_To |
635 | (Stmts, Cleanup_Task (N, Duplicate_Subexpr_No_Checks (Arg))); | |
636 | ||
637 | -- For composite types that contain tasks, recurse over the structure | |
638 | -- to build the selectors for the task subcomponents. | |
639 | ||
640 | elsif Has_Task (Desig_T) then | |
641 | if Is_Record_Type (Desig_T) then | |
642 | Append_List_To (Stmts, Cleanup_Record (N, Arg, Desig_T)); | |
643 | ||
644 | elsif Is_Array_Type (Desig_T) then | |
645 | Append_List_To (Stmts, Cleanup_Array (N, Arg, Desig_T)); | |
646 | end if; | |
70482933 RK |
647 | end if; |
648 | ||
fbf5a39b AC |
649 | -- Same for simple protected types. Eventually call Finalize_Protection |
650 | -- before freeing the PO for each protected component. | |
70482933 | 651 | |
fbf5a39b | 652 | if Is_Simple_Protected_Type (Desig_T) then |
70482933 | 653 | Append_To (Stmts, |
fbf5a39b AC |
654 | Cleanup_Protected_Object (N, Duplicate_Subexpr_No_Checks (Arg))); |
655 | ||
656 | elsif Has_Simple_Protected_Object (Desig_T) then | |
657 | if Is_Record_Type (Desig_T) then | |
658 | Append_List_To (Stmts, Cleanup_Record (N, Arg, Desig_T)); | |
659 | elsif Is_Array_Type (Desig_T) then | |
660 | Append_List_To (Stmts, Cleanup_Array (N, Arg, Desig_T)); | |
661 | end if; | |
70482933 RK |
662 | end if; |
663 | ||
664 | -- Normal processing for non-controlled types | |
665 | ||
fbf5a39b | 666 | Free_Arg := Duplicate_Subexpr_No_Checks (Arg); |
70482933 RK |
667 | Free_Node := Make_Free_Statement (Loc, Empty); |
668 | Append_To (Stmts, Free_Node); | |
669 | Set_Storage_Pool (Free_Node, Pool); | |
670 | ||
671 | -- Make implicit if statement. We omit this if we are the then part | |
672 | -- of a test of the form: | |
673 | ||
674 | -- if not (Arg = null) then | |
675 | ||
676 | -- i.e. if the test is explicit in the source. Arg must be a simple | |
677 | -- identifier for the purposes of this special test. Note that the | |
678 | -- use of /= in the source is always transformed into the above form. | |
679 | ||
680 | declare | |
681 | Test_Needed : Boolean := True; | |
682 | P : constant Node_Id := Parent (N); | |
683 | C : Node_Id; | |
684 | ||
685 | begin | |
686 | if Nkind (Arg) = N_Identifier | |
687 | and then Nkind (P) = N_If_Statement | |
688 | and then First (Then_Statements (P)) = N | |
689 | then | |
690 | if Nkind (Condition (P)) = N_Op_Not then | |
691 | C := Right_Opnd (Condition (P)); | |
692 | ||
693 | if Nkind (C) = N_Op_Eq | |
694 | and then Nkind (Left_Opnd (C)) = N_Identifier | |
695 | and then Chars (Arg) = Chars (Left_Opnd (C)) | |
696 | and then Nkind (Right_Opnd (C)) = N_Null | |
697 | then | |
698 | Test_Needed := False; | |
699 | end if; | |
700 | end if; | |
701 | end if; | |
702 | ||
703 | -- Generate If_Statement if needed | |
704 | ||
705 | if Test_Needed then | |
706 | Gen_Code := | |
707 | Make_Implicit_If_Statement (N, | |
708 | Condition => | |
709 | Make_Op_Ne (Loc, | |
710 | Left_Opnd => Duplicate_Subexpr (Arg), | |
711 | Right_Opnd => Make_Null (Loc)), | |
712 | Then_Statements => Stmts); | |
713 | ||
714 | else | |
715 | Gen_Code := | |
716 | Make_Block_Statement (Loc, | |
717 | Handled_Statement_Sequence => | |
718 | Make_Handled_Sequence_Of_Statements (Loc, | |
719 | Statements => Stmts)); | |
720 | end if; | |
721 | end; | |
722 | ||
723 | -- Deal with storage pool | |
724 | ||
725 | if Present (Pool) then | |
726 | ||
727 | -- Freeing the secondary stack is meaningless | |
728 | ||
729 | if Is_RTE (Pool, RE_SS_Pool) then | |
730 | null; | |
731 | ||
fbf5a39b AC |
732 | elsif Is_Class_Wide_Type (Etype (Pool)) then |
733 | Set_Procedure_To_Call (Free_Node, | |
734 | RTE (RE_Deallocate_Any)); | |
70482933 RK |
735 | else |
736 | Set_Procedure_To_Call (Free_Node, | |
737 | Find_Prim_Op (Etype (Pool), Name_Deallocate)); | |
738 | ||
739 | -- If the type is class wide, we generate an implicit type | |
740 | -- with the right dynamic size, so that the deallocate call | |
741 | -- gets the right size parameter computed by gigi | |
742 | ||
743 | if Is_Class_Wide_Type (Desig_T) then | |
744 | declare | |
745 | Acc_Type : constant Entity_Id := | |
746 | Create_Itype (E_Access_Type, N); | |
747 | Deref : constant Node_Id := | |
748 | Make_Explicit_Dereference (Loc, | |
fbf5a39b | 749 | Duplicate_Subexpr_No_Checks (Arg)); |
70482933 RK |
750 | |
751 | begin | |
752 | Set_Etype (Deref, Typ); | |
753 | Set_Parent (Deref, Free_Node); | |
754 | ||
755 | Set_Etype (Acc_Type, Acc_Type); | |
756 | Set_Size_Info (Acc_Type, Typ); | |
757 | Set_Directly_Designated_Type | |
758 | (Acc_Type, Entity (Make_Subtype_From_Expr | |
759 | (Deref, Desig_T))); | |
760 | ||
761 | Free_Arg := Unchecked_Convert_To (Acc_Type, Free_Arg); | |
762 | end; | |
763 | end if; | |
764 | end if; | |
765 | end if; | |
766 | ||
767 | Set_Expression (Free_Node, Free_Arg); | |
768 | ||
769 | declare | |
fbf5a39b | 770 | Lhs : constant Node_Id := Duplicate_Subexpr_No_Checks (Arg); |
70482933 RK |
771 | |
772 | begin | |
773 | Set_Assignment_OK (Lhs); | |
774 | Append_To (Stmts, | |
775 | Make_Assignment_Statement (Loc, | |
776 | Name => Lhs, | |
777 | Expression => Make_Null (Loc))); | |
778 | end; | |
779 | ||
780 | Rewrite (N, Gen_Code); | |
781 | Analyze (N); | |
782 | end Expand_Unc_Deallocation; | |
783 | ||
fbf5a39b AC |
784 | ----------------------- |
785 | -- Expand_To_Address -- | |
786 | ----------------------- | |
787 | ||
788 | procedure Expand_To_Address (N : Node_Id) is | |
789 | Loc : constant Source_Ptr := Sloc (N); | |
790 | Arg : constant Node_Id := First_Actual (N); | |
791 | Obj : Node_Id; | |
792 | ||
793 | begin | |
794 | Remove_Side_Effects (Arg); | |
795 | ||
796 | Obj := Make_Explicit_Dereference (Loc, Relocate_Node (Arg)); | |
797 | ||
798 | Rewrite (N, | |
799 | Make_Conditional_Expression (Loc, | |
800 | Expressions => New_List ( | |
801 | Make_Op_Eq (Loc, | |
802 | Left_Opnd => New_Copy_Tree (Arg), | |
803 | Right_Opnd => Make_Null (Loc)), | |
804 | New_Occurrence_Of (RTE (RE_Null_Address), Loc), | |
805 | Make_Attribute_Reference (Loc, | |
806 | Attribute_Name => Name_Address, | |
807 | Prefix => Obj)))); | |
808 | ||
809 | Analyze_And_Resolve (N, RTE (RE_Address)); | |
810 | end Expand_To_Address; | |
811 | ||
812 | ----------------------- | |
813 | -- Expand_To_Pointer -- | |
814 | ----------------------- | |
815 | ||
816 | procedure Expand_To_Pointer (N : Node_Id) is | |
817 | Arg : constant Node_Id := First_Actual (N); | |
818 | ||
819 | begin | |
820 | Rewrite (N, Unchecked_Convert_To (Etype (N), Arg)); | |
821 | Analyze (N); | |
822 | end Expand_To_Pointer; | |
823 | ||
70482933 | 824 | end Exp_Intr; |