]>
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 | -- -- | |
1f110335 | 9 | -- Copyright (C) 1992-2009, 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- -- | |
b5c84c3c | 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
70482933 RK |
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 -- | |
b5c84c3c RD |
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. -- | |
70482933 RK |
20 | -- -- |
21 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
71ff80dc | 22 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
70482933 RK |
23 | -- -- |
24 | ------------------------------------------------------------------------------ | |
25 | ||
26 | with Atree; use Atree; | |
53cc4a7a | 27 | with Checks; use Checks; |
70482933 | 28 | with Einfo; use Einfo; |
d239991f | 29 | with Elists; use Elists; |
70482933 | 30 | with Errout; use Errout; |
62548837 | 31 | with Exp_Atag; use Exp_Atag; |
70482933 RK |
32 | with Exp_Ch4; use Exp_Ch4; |
33 | with Exp_Ch7; use Exp_Ch7; | |
70482933 RK |
34 | with Exp_Ch11; use Exp_Ch11; |
35 | with Exp_Code; use Exp_Code; | |
36 | with Exp_Fixd; use Exp_Fixd; | |
37 | with Exp_Util; use Exp_Util; | |
191cab8d | 38 | with Freeze; use Freeze; |
70482933 RK |
39 | with Namet; use Namet; |
40 | with Nmake; use Nmake; | |
41 | with Nlists; use Nlists; | |
1f110335 | 42 | with Opt; use Opt; |
70482933 | 43 | with Restrict; use Restrict; |
62548837 | 44 | with Rident; use Rident; |
70482933 RK |
45 | with Rtsfind; use Rtsfind; |
46 | with Sem; use Sem; | |
47 | with Sem_Eval; use Sem_Eval; | |
48 | with Sem_Res; use Sem_Res; | |
ce2b6ba5 | 49 | with Sem_Type; use Sem_Type; |
70482933 RK |
50 | with Sem_Util; use Sem_Util; |
51 | with Sinfo; use Sinfo; | |
52 | with Sinput; use Sinput; | |
53 | with Snames; use Snames; | |
54 | with Stand; use Stand; | |
55 | with Stringt; use Stringt; | |
56 | with Tbuild; use Tbuild; | |
57 | with Uintp; use Uintp; | |
58 | with Urealp; use Urealp; | |
59 | ||
60 | package body Exp_Intr is | |
61 | ||
62 | ----------------------- | |
63 | -- Local Subprograms -- | |
64 | ----------------------- | |
65 | ||
66 | procedure Expand_Is_Negative (N : Node_Id); | |
67 | -- Expand a call to the intrinsic Is_Negative function | |
68 | ||
d239991f GD |
69 | procedure Expand_Dispatching_Constructor_Call (N : Node_Id); |
70 | -- Expand a call to an instantiation of Generic_Dispatching_Constructor | |
71 | -- into a dispatching call to the actual subprogram associated with the | |
72 | -- Constructor formal subprogram, passing it the Parameters actual of | |
73 | -- the call to the instantiation and dispatching based on call's Tag | |
74 | -- parameter. | |
75 | ||
70482933 RK |
76 | procedure Expand_Exception_Call (N : Node_Id; Ent : RE_Id); |
77 | -- Expand a call to Exception_Information/Message/Name. The first | |
78 | -- parameter, N, is the node for the function call, and Ent is the | |
79 | -- entity for the corresponding routine in the Ada.Exceptions package. | |
80 | ||
81 | procedure Expand_Import_Call (N : Node_Id); | |
82 | -- Expand a call to Import_Address/Longest_Integer/Value. The parameter | |
83 | -- N is the node for the function call. | |
84 | ||
85 | procedure Expand_Shift (N : Node_Id; E : Entity_Id; K : Node_Kind); | |
86 | -- Expand an intrinsic shift operation, N and E are from the call to | |
5453d5bd | 87 | -- Expand_Intrinsic_Call (call node and subprogram spec entity) and |
70482933 RK |
88 | -- K is the kind for the shift node |
89 | ||
90 | procedure Expand_Unc_Conversion (N : Node_Id; E : Entity_Id); | |
e14c931f | 91 | -- Expand a call to an instantiation of Unchecked_Conversion into a node |
70482933 RK |
92 | -- N_Unchecked_Type_Conversion. |
93 | ||
07fc65c4 | 94 | procedure Expand_Unc_Deallocation (N : Node_Id); |
70482933 RK |
95 | -- Expand a call to an instantiation of Unchecked_Deallocation into a node |
96 | -- N_Free_Statement and appropriate context. | |
97 | ||
fbf5a39b AC |
98 | procedure Expand_To_Address (N : Node_Id); |
99 | procedure Expand_To_Pointer (N : Node_Id); | |
100 | -- Expand a call to corresponding function, declared in an instance of | |
e14c931f | 101 | -- System.Address_To_Access_Conversions. |
fbf5a39b | 102 | |
07fc65c4 | 103 | procedure Expand_Source_Info (N : Node_Id; Nam : Name_Id); |
70482933 RK |
104 | -- Rewrite the node by the appropriate string or positive constant. |
105 | -- Nam can be one of the following: | |
106 | -- Name_File - expand string that is the name of source file | |
107 | -- Name_Line - expand integer line number | |
108 | -- Name_Source_Location - expand string of form file:line | |
109 | -- Name_Enclosing_Entity - expand string with name of enclosing entity | |
110 | ||
d239991f GD |
111 | ----------------------------------------- |
112 | -- Expand_Dispatching_Constructor_Call -- | |
113 | ----------------------------------------- | |
114 | ||
115 | -- Transform a call to an instantiation of Generic_Dispatching_Constructor | |
116 | -- of the form: | |
117 | ||
118 | -- GDC_Instance (The_Tag, Parameters'Access) | |
119 | ||
120 | -- to a class-wide conversion of a dispatching call to the actual | |
53cc4a7a JM |
121 | -- associated with the formal subprogram Construct, designating The_Tag |
122 | -- as the controlling tag of the call: | |
d239991f GD |
123 | |
124 | -- T'Class (Construct'Actual (Params)) -- Controlling tag is The_Tag | |
125 | ||
126 | -- which will eventually be expanded to the following: | |
127 | ||
128 | -- T'Class (The_Tag.all (Construct'Actual'Index).all (Params)) | |
129 | ||
53cc4a7a JM |
130 | -- A class-wide membership test is also generated, preceding the call, to |
131 | -- ensure that the controlling tag denotes a type in T'Class. | |
d239991f GD |
132 | |
133 | procedure Expand_Dispatching_Constructor_Call (N : Node_Id) is | |
134 | Loc : constant Source_Ptr := Sloc (N); | |
135 | Tag_Arg : constant Node_Id := First_Actual (N); | |
136 | Param_Arg : constant Node_Id := Next_Actual (Tag_Arg); | |
137 | Subp_Decl : constant Node_Id := Parent (Parent (Entity (Name (N)))); | |
138 | Inst_Pkg : constant Node_Id := Parent (Subp_Decl); | |
191cab8d TQ |
139 | Act_Rename : Node_Id; |
140 | Act_Constr : Entity_Id; | |
c8b92217 | 141 | Iface_Tag : Node_Id := Empty; |
d239991f | 142 | Cnstr_Call : Node_Id; |
c8b92217 | 143 | Result_Typ : Entity_Id; |
d239991f GD |
144 | |
145 | begin | |
191cab8d TQ |
146 | -- The subprogram is the third actual in the instantiation, and is |
147 | -- retrieved from the corresponding renaming declaration. However, | |
148 | -- freeze nodes may appear before, so we retrieve the declaration | |
149 | -- with an explicit loop. | |
150 | ||
151 | Act_Rename := First (Visible_Declarations (Inst_Pkg)); | |
152 | while Nkind (Act_Rename) /= N_Subprogram_Renaming_Declaration loop | |
153 | Next (Act_Rename); | |
154 | end loop; | |
155 | ||
156 | Act_Constr := Entity (Name (Act_Rename)); | |
157 | Result_Typ := Class_Wide_Type (Etype (Act_Constr)); | |
158 | ||
b545a0f6 JM |
159 | -- Ada 2005 (AI-251): If the result is an interface type, the function |
160 | -- returns a class-wide interface type (otherwise the resulting object | |
161 | -- would be abstract!) | |
162 | ||
163 | if Is_Interface (Etype (Act_Constr)) then | |
164 | Set_Etype (Act_Constr, Result_Typ); | |
c8b92217 JM |
165 | |
166 | -- If the result type is not parent of Tag_Arg then we need to | |
167 | -- locate the tag of the secondary dispatch table. | |
168 | ||
ce2b6ba5 | 169 | if not Is_Ancestor (Etype (Result_Typ), Etype (Tag_Arg)) then |
c8b92217 JM |
170 | pragma Assert (not Is_Interface (Etype (Tag_Arg))); |
171 | ||
172 | Iface_Tag := | |
173 | Make_Object_Declaration (Loc, | |
174 | Defining_Identifier => | |
175 | Make_Defining_Identifier (Loc, New_Internal_Name ('V')), | |
176 | Object_Definition => | |
177 | New_Reference_To (RTE (RE_Tag), Loc), | |
178 | Expression => | |
179 | Make_Function_Call (Loc, | |
180 | Name => New_Reference_To (RTE (RE_Secondary_Tag), Loc), | |
181 | Parameter_Associations => New_List ( | |
182 | Relocate_Node (Tag_Arg), | |
183 | New_Reference_To | |
184 | (Node (First_Elmt (Access_Disp_Table | |
185 | (Etype (Etype (Act_Constr))))), | |
186 | Loc)))); | |
187 | Insert_Action (N, Iface_Tag); | |
188 | end if; | |
b545a0f6 JM |
189 | end if; |
190 | ||
d239991f GD |
191 | -- Create the call to the actual Constructor function |
192 | ||
193 | Cnstr_Call := | |
194 | Make_Function_Call (Loc, | |
195 | Name => New_Occurrence_Of (Act_Constr, Loc), | |
196 | Parameter_Associations => New_List (Relocate_Node (Param_Arg))); | |
197 | ||
198 | -- Establish its controlling tag from the tag passed to the instance | |
62548837 RD |
199 | -- The tag may be given by a function call, in which case a temporary |
200 | -- should be generated now, to prevent out-of-order insertions during | |
201 | -- the expansion of that call when stack-checking is enabled. | |
d239991f | 202 | |
c8b92217 JM |
203 | if Present (Iface_Tag) then |
204 | Set_Controlling_Argument (Cnstr_Call, | |
205 | New_Occurrence_Of (Defining_Identifier (Iface_Tag), Loc)); | |
206 | else | |
207 | Remove_Side_Effects (Tag_Arg); | |
208 | Set_Controlling_Argument (Cnstr_Call, | |
209 | Relocate_Node (Tag_Arg)); | |
210 | end if; | |
d239991f GD |
211 | |
212 | -- Rewrite and analyze the call to the instance as a class-wide | |
213 | -- conversion of the call to the actual constructor. | |
214 | ||
215 | Rewrite (N, Convert_To (Result_Typ, Cnstr_Call)); | |
216 | Analyze_And_Resolve (N, Etype (Act_Constr)); | |
217 | ||
53cc4a7a | 218 | -- Do not generate a run-time check on the built object if tag |
c8b92217 | 219 | -- checks are suppressed for the result type or VM_Target /= No_VM |
53cc4a7a | 220 | |
c8b92217 | 221 | if Tag_Checks_Suppressed (Etype (Result_Typ)) |
1f110335 | 222 | or else not Tagged_Type_Expansion |
c8b92217 | 223 | then |
53cc4a7a JM |
224 | null; |
225 | ||
d239991f | 226 | -- Generate a class-wide membership test to ensure that the call's tag |
53cc4a7a JM |
227 | -- argument denotes a type within the class. We must keep separate the |
228 | -- case in which the Result_Type of the constructor function is a tagged | |
229 | -- type from the case in which it is an abstract interface because the | |
230 | -- run-time subprogram required to check these cases differ (and have | |
231 | -- one difference in their parameters profile). | |
232 | ||
233 | -- Call CW_Membership if the Result_Type is a tagged type to look for | |
234 | -- the tag in the table of ancestor tags. | |
235 | ||
236 | elsif not Is_Interface (Result_Typ) then | |
237 | Insert_Action (N, | |
238 | Make_Implicit_If_Statement (N, | |
239 | Condition => | |
240 | Make_Op_Not (Loc, | |
62548837 RD |
241 | Build_CW_Membership (Loc, |
242 | Obj_Tag_Node => Duplicate_Subexpr (Tag_Arg), | |
243 | Typ_Tag_Node => | |
244 | New_Reference_To ( | |
53cc4a7a | 245 | Node (First_Elmt (Access_Disp_Table ( |
62548837 | 246 | Root_Type (Result_Typ)))), Loc))), |
53cc4a7a JM |
247 | Then_Statements => |
248 | New_List (Make_Raise_Statement (Loc, | |
249 | New_Occurrence_Of (RTE (RE_Tag_Error), Loc))))); | |
250 | ||
251 | -- Call IW_Membership test if the Result_Type is an abstract interface | |
252 | -- to look for the tag in the table of interface tags. | |
253 | ||
254 | else | |
255 | Insert_Action (N, | |
256 | Make_Implicit_If_Statement (N, | |
257 | Condition => | |
258 | Make_Op_Not (Loc, | |
b545a0f6 JM |
259 | Make_Function_Call (Loc, |
260 | Name => New_Occurrence_Of (RTE (RE_IW_Membership), Loc), | |
261 | Parameter_Associations => New_List ( | |
53cc4a7a | 262 | Make_Attribute_Reference (Loc, |
c8b92217 | 263 | Prefix => Duplicate_Subexpr (Tag_Arg), |
53cc4a7a JM |
264 | Attribute_Name => Name_Address), |
265 | ||
266 | New_Reference_To ( | |
267 | Node (First_Elmt (Access_Disp_Table ( | |
268 | Root_Type (Result_Typ)))), Loc)))), | |
269 | Then_Statements => | |
270 | New_List ( | |
271 | Make_Raise_Statement (Loc, | |
272 | Name => New_Occurrence_Of (RTE (RE_Tag_Error), Loc))))); | |
273 | end if; | |
d239991f GD |
274 | end Expand_Dispatching_Constructor_Call; |
275 | ||
70482933 RK |
276 | --------------------------- |
277 | -- Expand_Exception_Call -- | |
278 | --------------------------- | |
279 | ||
62548837 RD |
280 | -- If the function call is not within an exception handler, then the call |
281 | -- is replaced by a null string. Otherwise the appropriate routine in | |
282 | -- Ada.Exceptions is called passing the choice parameter specification | |
70482933 RK |
283 | -- from the enclosing handler. If the enclosing handler lacks a choice |
284 | -- parameter, then one is supplied. | |
285 | ||
286 | procedure Expand_Exception_Call (N : Node_Id; Ent : RE_Id) is | |
287 | Loc : constant Source_Ptr := Sloc (N); | |
288 | P : Node_Id; | |
289 | E : Entity_Id; | |
70482933 RK |
290 | |
291 | begin | |
292 | -- Climb up parents to see if we are in exception handler | |
293 | ||
294 | P := Parent (N); | |
295 | loop | |
1d571f3b | 296 | -- Case of not in exception handler, replace by null string |
70482933 RK |
297 | |
298 | if No (P) then | |
70482933 RK |
299 | Rewrite (N, |
300 | Make_String_Literal (Loc, | |
1d571f3b | 301 | Strval => "")); |
70482933 RK |
302 | exit; |
303 | ||
304 | -- Case of in exception handler | |
305 | ||
306 | elsif Nkind (P) = N_Exception_Handler then | |
70482933 | 307 | |
62548837 RD |
308 | -- Handler cannot be used for a local raise, and furthermore, this |
309 | -- is a violation of the No_Exception_Propagation restriction. | |
310 | ||
311 | Set_Local_Raise_Not_OK (P); | |
312 | Check_Restriction (No_Exception_Propagation, N); | |
70482933 | 313 | |
62548837 RD |
314 | -- If no choice parameter present, then put one there. Note that |
315 | -- we do not need to put it on the entity chain, since no one will | |
316 | -- be referencing it by normal visibility methods. | |
317 | ||
318 | if No (Choice_Parameter (P)) then | |
70482933 RK |
319 | E := Make_Defining_Identifier (Loc, New_Internal_Name ('E')); |
320 | Set_Choice_Parameter (P, E); | |
321 | Set_Ekind (E, E_Variable); | |
322 | Set_Etype (E, RTE (RE_Exception_Occurrence)); | |
323 | Set_Scope (E, Current_Scope); | |
324 | end if; | |
325 | ||
326 | Rewrite (N, | |
327 | Make_Function_Call (Loc, | |
328 | Name => New_Occurrence_Of (RTE (Ent), Loc), | |
329 | Parameter_Associations => New_List ( | |
330 | New_Occurrence_Of (Choice_Parameter (P), Loc)))); | |
331 | exit; | |
332 | ||
333 | -- Keep climbing! | |
334 | ||
335 | else | |
336 | P := Parent (P); | |
337 | end if; | |
338 | end loop; | |
339 | ||
340 | Analyze_And_Resolve (N, Standard_String); | |
341 | end Expand_Exception_Call; | |
342 | ||
343 | ------------------------ | |
344 | -- Expand_Import_Call -- | |
345 | ------------------------ | |
346 | ||
347 | -- The function call must have a static string as its argument. We create | |
348 | -- a dummy variable which uses this string as the external name in an | |
349 | -- Import pragma. The result is then obtained as the address of this | |
350 | -- dummy variable, converted to the appropriate target type. | |
351 | ||
352 | procedure Expand_Import_Call (N : Node_Id) is | |
353 | Loc : constant Source_Ptr := Sloc (N); | |
354 | Ent : constant Entity_Id := Entity (Name (N)); | |
355 | Str : constant Node_Id := First_Actual (N); | |
356 | Dum : Entity_Id; | |
357 | ||
358 | begin | |
359 | Dum := Make_Defining_Identifier (Loc, New_Internal_Name ('D')); | |
360 | ||
361 | Insert_Actions (N, New_List ( | |
362 | Make_Object_Declaration (Loc, | |
363 | Defining_Identifier => Dum, | |
364 | Object_Definition => | |
365 | New_Occurrence_Of (Standard_Character, Loc)), | |
366 | ||
367 | Make_Pragma (Loc, | |
368 | Chars => Name_Import, | |
369 | Pragma_Argument_Associations => New_List ( | |
370 | Make_Pragma_Argument_Association (Loc, | |
371 | Expression => Make_Identifier (Loc, Name_Ada)), | |
372 | ||
373 | Make_Pragma_Argument_Association (Loc, | |
374 | Expression => Make_Identifier (Loc, Chars (Dum))), | |
375 | ||
376 | Make_Pragma_Argument_Association (Loc, | |
377 | Chars => Name_Link_Name, | |
378 | Expression => Relocate_Node (Str)))))); | |
379 | ||
380 | Rewrite (N, | |
381 | Unchecked_Convert_To (Etype (Ent), | |
382 | Make_Attribute_Reference (Loc, | |
c8b92217 JM |
383 | Prefix => Make_Identifier (Loc, Chars (Dum)), |
384 | Attribute_Name => Name_Address))); | |
70482933 RK |
385 | |
386 | Analyze_And_Resolve (N, Etype (Ent)); | |
387 | end Expand_Import_Call; | |
388 | ||
389 | --------------------------- | |
390 | -- Expand_Intrinsic_Call -- | |
391 | --------------------------- | |
392 | ||
393 | procedure Expand_Intrinsic_Call (N : Node_Id; E : Entity_Id) is | |
394 | Nam : Name_Id; | |
395 | ||
396 | begin | |
75a64833 AC |
397 | -- If an external name is specified for the intrinsic, it is handled |
398 | -- by the back-end: leave the call node unchanged for now. | |
399 | ||
400 | if Present (Interface_Name (E)) then | |
401 | return; | |
402 | end if; | |
403 | ||
7324bf49 | 404 | -- If the intrinsic subprogram is generic, gets its original name |
70482933 RK |
405 | |
406 | if Present (Parent (E)) | |
407 | and then Present (Generic_Parent (Parent (E))) | |
408 | then | |
409 | Nam := Chars (Generic_Parent (Parent (E))); | |
410 | else | |
411 | Nam := Chars (E); | |
412 | end if; | |
413 | ||
414 | if Nam = Name_Asm then | |
415 | Expand_Asm_Call (N); | |
416 | ||
417 | elsif Nam = Name_Divide then | |
418 | Expand_Decimal_Divide_Call (N); | |
419 | ||
420 | elsif Nam = Name_Exception_Information then | |
421 | Expand_Exception_Call (N, RE_Exception_Information); | |
422 | ||
423 | elsif Nam = Name_Exception_Message then | |
424 | Expand_Exception_Call (N, RE_Exception_Message); | |
425 | ||
426 | elsif Nam = Name_Exception_Name then | |
427 | Expand_Exception_Call (N, RE_Exception_Name_Simple); | |
428 | ||
d239991f GD |
429 | elsif Nam = Name_Generic_Dispatching_Constructor then |
430 | Expand_Dispatching_Constructor_Call (N); | |
431 | ||
70482933 RK |
432 | elsif Nam = Name_Import_Address |
433 | or else | |
434 | Nam = Name_Import_Largest_Value | |
435 | or else | |
436 | Nam = Name_Import_Value | |
437 | then | |
438 | Expand_Import_Call (N); | |
439 | ||
440 | elsif Nam = Name_Is_Negative then | |
441 | Expand_Is_Negative (N); | |
442 | ||
443 | elsif Nam = Name_Rotate_Left then | |
444 | Expand_Shift (N, E, N_Op_Rotate_Left); | |
445 | ||
446 | elsif Nam = Name_Rotate_Right then | |
447 | Expand_Shift (N, E, N_Op_Rotate_Right); | |
448 | ||
449 | elsif Nam = Name_Shift_Left then | |
450 | Expand_Shift (N, E, N_Op_Shift_Left); | |
451 | ||
452 | elsif Nam = Name_Shift_Right then | |
453 | Expand_Shift (N, E, N_Op_Shift_Right); | |
454 | ||
455 | elsif Nam = Name_Shift_Right_Arithmetic then | |
456 | Expand_Shift (N, E, N_Op_Shift_Right_Arithmetic); | |
457 | ||
458 | elsif Nam = Name_Unchecked_Conversion then | |
459 | Expand_Unc_Conversion (N, E); | |
460 | ||
461 | elsif Nam = Name_Unchecked_Deallocation then | |
07fc65c4 | 462 | Expand_Unc_Deallocation (N); |
70482933 | 463 | |
fbf5a39b AC |
464 | elsif Nam = Name_To_Address then |
465 | Expand_To_Address (N); | |
466 | ||
467 | elsif Nam = Name_To_Pointer then | |
468 | Expand_To_Pointer (N); | |
469 | ||
70482933 RK |
470 | elsif Nam = Name_File |
471 | or else Nam = Name_Line | |
472 | or else Nam = Name_Source_Location | |
473 | or else Nam = Name_Enclosing_Entity | |
474 | then | |
07fc65c4 | 475 | Expand_Source_Info (N, Nam); |
70482933 | 476 | |
98f01d53 AC |
477 | -- If we have a renaming, expand the call to the original operation, |
478 | -- which must itself be intrinsic, since renaming requires matching | |
479 | -- conventions and this has already been checked. | |
70482933 | 480 | |
98f01d53 | 481 | elsif Present (Alias (E)) then |
70482933 | 482 | Expand_Intrinsic_Call (N, Alias (E)); |
98f01d53 AC |
483 | |
484 | -- The only other case is where an external name was specified, | |
485 | -- since this is the only way that an otherwise unrecognized | |
486 | -- name could escape the checking in Sem_Prag. Nothing needs | |
487 | -- to be done in such a case, since we pass such a call to the | |
488 | -- back end unchanged. | |
489 | ||
490 | else | |
491 | null; | |
70482933 | 492 | end if; |
70482933 RK |
493 | end Expand_Intrinsic_Call; |
494 | ||
495 | ------------------------ | |
496 | -- Expand_Is_Negative -- | |
497 | ------------------------ | |
498 | ||
499 | procedure Expand_Is_Negative (N : Node_Id) is | |
500 | Loc : constant Source_Ptr := Sloc (N); | |
501 | Opnd : constant Node_Id := Relocate_Node (First_Actual (N)); | |
502 | ||
503 | begin | |
504 | ||
505 | -- We replace the function call by the following expression | |
506 | ||
507 | -- if Opnd < 0.0 then | |
508 | -- True | |
509 | -- else | |
510 | -- if Opnd > 0.0 then | |
511 | -- False; | |
512 | -- else | |
513 | -- Float_Unsigned!(Float (Opnd)) /= 0 | |
514 | -- end if; | |
515 | -- end if; | |
516 | ||
517 | Rewrite (N, | |
518 | Make_Conditional_Expression (Loc, | |
519 | Expressions => New_List ( | |
520 | Make_Op_Lt (Loc, | |
521 | Left_Opnd => Duplicate_Subexpr (Opnd), | |
522 | Right_Opnd => Make_Real_Literal (Loc, Ureal_0)), | |
523 | ||
524 | New_Occurrence_Of (Standard_True, Loc), | |
525 | ||
526 | Make_Conditional_Expression (Loc, | |
527 | Expressions => New_List ( | |
528 | Make_Op_Gt (Loc, | |
fbf5a39b | 529 | Left_Opnd => Duplicate_Subexpr_No_Checks (Opnd), |
70482933 RK |
530 | Right_Opnd => Make_Real_Literal (Loc, Ureal_0)), |
531 | ||
532 | New_Occurrence_Of (Standard_False, Loc), | |
533 | ||
534 | Make_Op_Ne (Loc, | |
535 | Left_Opnd => | |
fbf5a39b AC |
536 | Unchecked_Convert_To |
537 | (RTE (RE_Float_Unsigned), | |
538 | Convert_To | |
539 | (Standard_Float, | |
540 | Duplicate_Subexpr_No_Checks (Opnd))), | |
70482933 RK |
541 | Right_Opnd => |
542 | Make_Integer_Literal (Loc, 0))))))); | |
543 | ||
544 | Analyze_And_Resolve (N, Standard_Boolean); | |
545 | end Expand_Is_Negative; | |
546 | ||
547 | ------------------ | |
548 | -- Expand_Shift -- | |
549 | ------------------ | |
550 | ||
551 | -- This procedure is used to convert a call to a shift function to the | |
552 | -- corresponding operator node. This conversion is not done by the usual | |
553 | -- circuit for converting calls to operator functions (e.g. "+"(1,2)) to | |
554 | -- operator nodes, because shifts are not predefined operators. | |
555 | ||
556 | -- As a result, whenever a shift is used in the source program, it will | |
557 | -- remain as a call until converted by this routine to the operator node | |
558 | -- form which Gigi is expecting to see. | |
559 | ||
560 | -- Note: it is possible for the expander to generate shift operator nodes | |
561 | -- directly, which will be analyzed in the normal manner by calling Analyze | |
562 | -- and Resolve. Such shift operator nodes will not be seen by Expand_Shift. | |
563 | ||
564 | procedure Expand_Shift (N : Node_Id; E : Entity_Id; K : Node_Kind) is | |
565 | Loc : constant Source_Ptr := Sloc (N); | |
566 | Typ : constant Entity_Id := Etype (N); | |
567 | Left : constant Node_Id := First_Actual (N); | |
568 | Right : constant Node_Id := Next_Actual (Left); | |
569 | Ltyp : constant Node_Id := Etype (Left); | |
570 | Rtyp : constant Node_Id := Etype (Right); | |
571 | Snode : Node_Id; | |
572 | ||
573 | begin | |
574 | Snode := New_Node (K, Loc); | |
575 | Set_Left_Opnd (Snode, Relocate_Node (Left)); | |
576 | Set_Right_Opnd (Snode, Relocate_Node (Right)); | |
577 | Set_Chars (Snode, Chars (E)); | |
578 | Set_Etype (Snode, Base_Type (Typ)); | |
579 | Set_Entity (Snode, E); | |
580 | ||
581 | if Compile_Time_Known_Value (Type_High_Bound (Rtyp)) | |
582 | and then Expr_Value (Type_High_Bound (Rtyp)) < Esize (Ltyp) | |
583 | then | |
584 | Set_Shift_Count_OK (Snode, True); | |
585 | end if; | |
586 | ||
587 | -- Do the rewrite. Note that we don't call Analyze and Resolve on | |
588 | -- this node, because it already got analyzed and resolved when | |
589 | -- it was a function call! | |
590 | ||
591 | Rewrite (N, Snode); | |
592 | Set_Analyzed (N); | |
70482933 RK |
593 | end Expand_Shift; |
594 | ||
595 | ------------------------ | |
596 | -- Expand_Source_Info -- | |
597 | ------------------------ | |
598 | ||
07fc65c4 | 599 | procedure Expand_Source_Info (N : Node_Id; Nam : Name_Id) is |
70482933 RK |
600 | Loc : constant Source_Ptr := Sloc (N); |
601 | Ent : Entity_Id; | |
602 | ||
435d8e6b ES |
603 | procedure Write_Entity_Name (E : Entity_Id); |
604 | -- Recursive procedure to construct string for qualified name of | |
605 | -- enclosing program unit. The qualification stops at an enclosing | |
606 | -- scope has no source name (block or loop). If entity is a subprogram | |
607 | -- instance, skip enclosing wrapper package. | |
608 | ||
609 | ----------------------- | |
610 | -- Write_Entity_Name -- | |
611 | ----------------------- | |
612 | ||
613 | procedure Write_Entity_Name (E : Entity_Id) is | |
614 | SDef : Source_Ptr; | |
615 | TDef : constant Source_Buffer_Ptr := | |
616 | Source_Text (Get_Source_File_Index (Sloc (E))); | |
617 | ||
618 | begin | |
619 | -- Nothing to do if at outer level | |
620 | ||
621 | if Scope (E) = Standard_Standard then | |
622 | null; | |
623 | ||
624 | -- If scope comes from source, write its name | |
625 | ||
626 | elsif Comes_From_Source (Scope (E)) then | |
627 | Write_Entity_Name (Scope (E)); | |
628 | Add_Char_To_Name_Buffer ('.'); | |
629 | ||
630 | -- If in wrapper package skip past it | |
631 | ||
632 | elsif Is_Wrapper_Package (Scope (E)) then | |
633 | Write_Entity_Name (Scope (Scope (E))); | |
634 | Add_Char_To_Name_Buffer ('.'); | |
635 | ||
636 | -- Otherwise nothing to output (happens in unnamed block statements) | |
637 | ||
638 | else | |
639 | null; | |
640 | end if; | |
641 | ||
642 | -- Loop to output the name | |
643 | ||
644 | -- is this right wrt wide char encodings ??? (no!) | |
645 | ||
646 | SDef := Sloc (E); | |
647 | while TDef (SDef) in '0' .. '9' | |
648 | or else TDef (SDef) >= 'A' | |
649 | or else TDef (SDef) = ASCII.ESC | |
650 | loop | |
651 | Add_Char_To_Name_Buffer (TDef (SDef)); | |
652 | SDef := SDef + 1; | |
653 | end loop; | |
654 | end Write_Entity_Name; | |
655 | ||
656 | -- Start of processing for Expand_Source_Info | |
657 | ||
70482933 RK |
658 | begin |
659 | -- Integer cases | |
660 | ||
661 | if Nam = Name_Line then | |
662 | Rewrite (N, | |
663 | Make_Integer_Literal (Loc, | |
664 | Intval => UI_From_Int (Int (Get_Logical_Line_Number (Loc))))); | |
665 | Analyze_And_Resolve (N, Standard_Positive); | |
666 | ||
667 | -- String cases | |
668 | ||
669 | else | |
21d27997 RD |
670 | Name_Len := 0; |
671 | ||
70482933 RK |
672 | case Nam is |
673 | when Name_File => | |
674 | Get_Decoded_Name_String | |
675 | (Reference_Name (Get_Source_File_Index (Loc))); | |
676 | ||
677 | when Name_Source_Location => | |
678 | Build_Location_String (Loc); | |
679 | ||
680 | when Name_Enclosing_Entity => | |
70482933 | 681 | |
435d8e6b | 682 | -- Skip enclosing blocks to reach enclosing unit |
70482933 | 683 | |
21d27997 | 684 | Ent := Current_Scope; |
70482933 RK |
685 | while Present (Ent) loop |
686 | exit when Ekind (Ent) /= E_Block | |
687 | and then Ekind (Ent) /= E_Loop; | |
688 | Ent := Scope (Ent); | |
689 | end loop; | |
690 | ||
691 | -- Ent now points to the relevant defining entity | |
692 | ||
435d8e6b | 693 | Write_Entity_Name (Ent); |
70482933 RK |
694 | |
695 | when others => | |
696 | raise Program_Error; | |
697 | end case; | |
698 | ||
699 | Rewrite (N, | |
21d27997 RD |
700 | Make_String_Literal (Loc, |
701 | Strval => String_From_Name_Buffer)); | |
70482933 RK |
702 | Analyze_And_Resolve (N, Standard_String); |
703 | end if; | |
704 | ||
705 | Set_Is_Static_Expression (N); | |
706 | end Expand_Source_Info; | |
707 | ||
708 | --------------------------- | |
709 | -- Expand_Unc_Conversion -- | |
710 | --------------------------- | |
711 | ||
712 | procedure Expand_Unc_Conversion (N : Node_Id; E : Entity_Id) is | |
713 | Func : constant Entity_Id := Entity (Name (N)); | |
714 | Conv : Node_Id; | |
715 | Ftyp : Entity_Id; | |
b7cdaf8d | 716 | Ttyp : Entity_Id; |
70482933 RK |
717 | |
718 | begin | |
719 | -- Rewrite as unchecked conversion node. Note that we must convert | |
720 | -- the operand to the formal type of the input parameter of the | |
721 | -- function, so that the resulting N_Unchecked_Type_Conversion | |
722 | -- call indicates the correct types for Gigi. | |
723 | ||
724 | -- Right now, we only do this if a scalar type is involved. It is | |
725 | -- not clear if it is needed in other cases. If we do attempt to | |
726 | -- do the conversion unconditionally, it crashes 3411-018. To be | |
727 | -- investigated further ??? | |
728 | ||
729 | Conv := Relocate_Node (First_Actual (N)); | |
730 | Ftyp := Etype (First_Formal (Func)); | |
731 | ||
732 | if Is_Scalar_Type (Ftyp) then | |
733 | Conv := Convert_To (Ftyp, Conv); | |
734 | Set_Parent (Conv, N); | |
735 | Analyze_And_Resolve (Conv); | |
736 | end if; | |
737 | ||
b7cdaf8d ES |
738 | -- The instantiation of Unchecked_Conversion creates a wrapper package, |
739 | -- and the target type is declared as a subtype of the actual. Recover | |
740 | -- the actual, which is the subtype indic. in the subtype declaration | |
741 | -- for the target type. This is semantically correct, and avoids | |
742 | -- anomalies with access subtypes. For entities, leave type as is. | |
743 | ||
70482933 RK |
744 | -- We do the analysis here, because we do not want the compiler |
745 | -- to try to optimize or otherwise reorganize the unchecked | |
746 | -- conversion node. | |
747 | ||
b7cdaf8d ES |
748 | Ttyp := Etype (E); |
749 | ||
750 | if Is_Entity_Name (Conv) then | |
751 | null; | |
752 | ||
753 | elsif Nkind (Parent (Ttyp)) = N_Subtype_Declaration then | |
754 | Ttyp := Entity (Subtype_Indication (Parent (Etype (E)))); | |
755 | ||
756 | elsif Is_Itype (Ttyp) then | |
757 | Ttyp := | |
758 | Entity (Subtype_Indication (Associated_Node_For_Itype (Ttyp))); | |
759 | else | |
760 | raise Program_Error; | |
761 | end if; | |
762 | ||
763 | Rewrite (N, Unchecked_Convert_To (Ttyp, Conv)); | |
764 | Set_Etype (N, Ttyp); | |
70482933 RK |
765 | Set_Analyzed (N); |
766 | ||
767 | if Nkind (N) = N_Unchecked_Type_Conversion then | |
768 | Expand_N_Unchecked_Type_Conversion (N); | |
769 | end if; | |
770 | end Expand_Unc_Conversion; | |
771 | ||
772 | ----------------------------- | |
773 | -- Expand_Unc_Deallocation -- | |
774 | ----------------------------- | |
775 | ||
776 | -- Generate the following Code : | |
777 | ||
778 | -- if Arg /= null then | |
779 | -- <Finalize_Call> (.., T'Class(Arg.all), ..); -- for controlled types | |
780 | -- Free (Arg); | |
781 | -- Arg := Null; | |
782 | -- end if; | |
783 | ||
784 | -- For a task, we also generate a call to Free_Task to ensure that the | |
785 | -- task itself is freed if it is terminated, ditto for a simple protected | |
fbf5a39b AC |
786 | -- object, with a call to Finalize_Protection. For composite types that |
787 | -- have tasks or simple protected objects as components, we traverse the | |
788 | -- structures to find and terminate those components. | |
70482933 | 789 | |
07fc65c4 | 790 | procedure Expand_Unc_Deallocation (N : Node_Id) is |
70482933 RK |
791 | Loc : constant Source_Ptr := Sloc (N); |
792 | Arg : constant Node_Id := First_Actual (N); | |
793 | Typ : constant Entity_Id := Etype (Arg); | |
794 | Stmts : constant List_Id := New_List; | |
fbf5a39b AC |
795 | Rtyp : constant Entity_Id := Underlying_Type (Root_Type (Typ)); |
796 | Pool : constant Entity_Id := Associated_Storage_Pool (Rtyp); | |
70482933 | 797 | |
fbf5a39b | 798 | Desig_T : constant Entity_Id := Designated_Type (Typ); |
70482933 RK |
799 | Gen_Code : Node_Id; |
800 | Free_Node : Node_Id; | |
801 | Deref : Node_Id; | |
802 | Free_Arg : Node_Id; | |
803 | Free_Cod : List_Id; | |
804 | Blk : Node_Id; | |
805 | ||
dad9a816 RD |
806 | Arg_Known_Non_Null : constant Boolean := Known_Non_Null (N); |
807 | -- This captures whether we know the argument to be non-null so that | |
808 | -- we can avoid the test. The reason that we need to capture this is | |
809 | -- that we analyze some generated statements before properly attaching | |
810 | -- them to the tree, and that can disturb current value settings. | |
811 | ||
70482933 | 812 | begin |
fbf5a39b | 813 | if No_Pool_Assigned (Rtyp) then |
554846f3 | 814 | Error_Msg_N ("?deallocation from empty storage pool!", N); |
fbf5a39b | 815 | end if; |
70482933 | 816 | |
dad9a816 RD |
817 | -- Nothing to do if we know the argument is null |
818 | ||
819 | if Known_Null (N) then | |
820 | return; | |
821 | end if; | |
822 | ||
823 | -- Processing for pointer to controlled type | |
824 | ||
048e5cef | 825 | if Needs_Finalization (Desig_T) then |
fbf5a39b AC |
826 | Deref := |
827 | Make_Explicit_Dereference (Loc, | |
828 | Prefix => Duplicate_Subexpr_No_Checks (Arg)); | |
70482933 RK |
829 | |
830 | -- If the type is tagged, then we must force dispatching on the | |
831 | -- finalization call because the designated type may not be the | |
4a2ddf66 | 832 | -- actual type of the object. |
70482933 RK |
833 | |
834 | if Is_Tagged_Type (Desig_T) | |
835 | and then not Is_Class_Wide_Type (Desig_T) | |
836 | then | |
837 | Deref := Unchecked_Convert_To (Class_Wide_Type (Desig_T), Deref); | |
4a2ddf66 ES |
838 | |
839 | elsif not Is_Tagged_Type (Desig_T) then | |
840 | ||
841 | -- Set type of result, to force a conversion when needed (see | |
842 | -- exp_ch7, Convert_View), given that Deep_Finalize may be | |
843 | -- inherited from the parent type, and we need the type of the | |
844 | -- expression to see whether the conversion is in fact needed. | |
845 | ||
846 | Set_Etype (Deref, Desig_T); | |
70482933 RK |
847 | end if; |
848 | ||
849 | Free_Cod := | |
850 | Make_Final_Call | |
851 | (Ref => Deref, | |
852 | Typ => Desig_T, | |
853 | With_Detach => New_Reference_To (Standard_True, Loc)); | |
854 | ||
855 | if Abort_Allowed then | |
856 | Prepend_To (Free_Cod, | |
857 | Build_Runtime_Call (Loc, RE_Abort_Defer)); | |
858 | ||
859 | Blk := | |
860 | Make_Block_Statement (Loc, Handled_Statement_Sequence => | |
861 | Make_Handled_Sequence_Of_Statements (Loc, | |
862 | Statements => Free_Cod, | |
863 | At_End_Proc => | |
864 | New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc))); | |
865 | ||
866 | -- We now expand the exception (at end) handler. We set a | |
867 | -- temporary parent pointer since we have not attached Blk | |
868 | -- to the tree yet. | |
869 | ||
870 | Set_Parent (Blk, N); | |
871 | Analyze (Blk); | |
872 | Expand_At_End_Handler | |
873 | (Handled_Statement_Sequence (Blk), Entity (Identifier (Blk))); | |
874 | Append (Blk, Stmts); | |
875 | ||
dad9a816 RD |
876 | -- We kill saved current values, since analyzing statements not |
877 | -- properly attached to the tree can set wrong current values. | |
878 | ||
879 | Kill_Current_Values; | |
880 | ||
70482933 RK |
881 | else |
882 | Append_List_To (Stmts, Free_Cod); | |
883 | end if; | |
884 | end if; | |
885 | ||
fbf5a39b | 886 | -- For a task type, call Free_Task before freeing the ATCB |
70482933 RK |
887 | |
888 | if Is_Task_Type (Desig_T) then | |
70482933 RK |
889 | declare |
890 | Stat : Node_Id := Prev (N); | |
891 | Nam1 : Node_Id; | |
892 | Nam2 : Node_Id; | |
893 | ||
894 | begin | |
895 | -- An Abort followed by a Free will not do what the user | |
fbf5a39b AC |
896 | -- expects, because the abort is not immediate. This is |
897 | -- worth a friendly warning. | |
70482933 RK |
898 | |
899 | while Present (Stat) | |
900 | and then not Comes_From_Source (Original_Node (Stat)) | |
901 | loop | |
902 | Prev (Stat); | |
903 | end loop; | |
904 | ||
905 | if Present (Stat) | |
906 | and then Nkind (Original_Node (Stat)) = N_Abort_Statement | |
907 | then | |
908 | Stat := Original_Node (Stat); | |
909 | Nam1 := First (Names (Stat)); | |
910 | Nam2 := Original_Node (First (Parameter_Associations (N))); | |
911 | ||
912 | if Nkind (Nam1) = N_Explicit_Dereference | |
913 | and then Is_Entity_Name (Prefix (Nam1)) | |
914 | and then Is_Entity_Name (Nam2) | |
915 | and then Entity (Prefix (Nam1)) = Entity (Nam2) | |
916 | then | |
84f8ad69 | 917 | Error_Msg_N ("abort may take time to complete?", N); |
70482933 RK |
918 | Error_Msg_N ("\deallocation might have no effect?", N); |
919 | Error_Msg_N ("\safer to wait for termination.?", N); | |
920 | end if; | |
921 | end if; | |
922 | end; | |
923 | ||
fbf5a39b AC |
924 | Append_To |
925 | (Stmts, Cleanup_Task (N, Duplicate_Subexpr_No_Checks (Arg))); | |
926 | ||
927 | -- For composite types that contain tasks, recurse over the structure | |
928 | -- to build the selectors for the task subcomponents. | |
929 | ||
930 | elsif Has_Task (Desig_T) then | |
931 | if Is_Record_Type (Desig_T) then | |
932 | Append_List_To (Stmts, Cleanup_Record (N, Arg, Desig_T)); | |
933 | ||
934 | elsif Is_Array_Type (Desig_T) then | |
935 | Append_List_To (Stmts, Cleanup_Array (N, Arg, Desig_T)); | |
936 | end if; | |
70482933 RK |
937 | end if; |
938 | ||
fbf5a39b AC |
939 | -- Same for simple protected types. Eventually call Finalize_Protection |
940 | -- before freeing the PO for each protected component. | |
70482933 | 941 | |
fbf5a39b | 942 | if Is_Simple_Protected_Type (Desig_T) then |
70482933 | 943 | Append_To (Stmts, |
fbf5a39b AC |
944 | Cleanup_Protected_Object (N, Duplicate_Subexpr_No_Checks (Arg))); |
945 | ||
946 | elsif Has_Simple_Protected_Object (Desig_T) then | |
947 | if Is_Record_Type (Desig_T) then | |
948 | Append_List_To (Stmts, Cleanup_Record (N, Arg, Desig_T)); | |
949 | elsif Is_Array_Type (Desig_T) then | |
950 | Append_List_To (Stmts, Cleanup_Array (N, Arg, Desig_T)); | |
951 | end if; | |
70482933 RK |
952 | end if; |
953 | ||
954 | -- Normal processing for non-controlled types | |
955 | ||
fbf5a39b | 956 | Free_Arg := Duplicate_Subexpr_No_Checks (Arg); |
70482933 RK |
957 | Free_Node := Make_Free_Statement (Loc, Empty); |
958 | Append_To (Stmts, Free_Node); | |
959 | Set_Storage_Pool (Free_Node, Pool); | |
960 | ||
191cab8d TQ |
961 | -- Deal with storage pool |
962 | ||
963 | if Present (Pool) then | |
964 | ||
965 | -- Freeing the secondary stack is meaningless | |
966 | ||
967 | if Is_RTE (Pool, RE_SS_Pool) then | |
968 | null; | |
969 | ||
970 | elsif Is_Class_Wide_Type (Etype (Pool)) then | |
971 | ||
972 | -- Case of a class-wide pool type: make a dispatching call | |
973 | -- to Deallocate through the class-wide Deallocate_Any. | |
974 | ||
975 | Set_Procedure_To_Call (Free_Node, | |
976 | RTE (RE_Deallocate_Any)); | |
977 | ||
978 | else | |
979 | -- Case of a specific pool type: make a statically bound call | |
980 | ||
981 | Set_Procedure_To_Call (Free_Node, | |
982 | Find_Prim_Op (Etype (Pool), Name_Deallocate)); | |
983 | end if; | |
984 | end if; | |
985 | ||
986 | if Present (Procedure_To_Call (Free_Node)) then | |
987 | ||
988 | -- For all cases of a Deallocate call, the back-end needs to be | |
989 | -- able to compute the size of the object being freed. This may | |
990 | -- require some adjustments for objects of dynamic size. | |
991 | -- | |
992 | -- If the type is class wide, we generate an implicit type with the | |
993 | -- right dynamic size, so that the deallocate call gets the right | |
994 | -- size parameter computed by GIGI. Same for an access to | |
995 | -- unconstrained packed array. | |
996 | ||
997 | if Is_Class_Wide_Type (Desig_T) | |
998 | or else | |
999 | (Is_Array_Type (Desig_T) | |
1000 | and then not Is_Constrained (Desig_T) | |
1001 | and then Is_Packed (Desig_T)) | |
1002 | then | |
1003 | declare | |
1004 | Deref : constant Node_Id := | |
1005 | Make_Explicit_Dereference (Loc, | |
1006 | Duplicate_Subexpr_No_Checks (Arg)); | |
1007 | D_Subtyp : Node_Id; | |
1008 | D_Type : Entity_Id; | |
1009 | ||
1010 | begin | |
1011 | Set_Etype (Deref, Typ); | |
1012 | Set_Parent (Deref, Free_Node); | |
1013 | D_Subtyp := Make_Subtype_From_Expr (Deref, Desig_T); | |
1014 | ||
1015 | if Nkind (D_Subtyp) in N_Has_Entity then | |
1016 | D_Type := Entity (D_Subtyp); | |
1017 | ||
1018 | else | |
1019 | D_Type := Make_Defining_Identifier (Loc, | |
1020 | New_Internal_Name ('A')); | |
cbae498b | 1021 | Insert_Action (Deref, |
191cab8d TQ |
1022 | Make_Subtype_Declaration (Loc, |
1023 | Defining_Identifier => D_Type, | |
1024 | Subtype_Indication => D_Subtyp)); | |
191cab8d TQ |
1025 | |
1026 | end if; | |
1027 | ||
cbae498b EB |
1028 | -- Force freezing at the point of the dereference. For the |
1029 | -- class wide case, this avoids having the subtype frozen | |
1030 | -- before the equivalent type. | |
1031 | ||
1032 | Freeze_Itype (D_Type, Deref); | |
1033 | ||
191cab8d TQ |
1034 | Set_Actual_Designated_Subtype (Free_Node, D_Type); |
1035 | end; | |
1036 | ||
1037 | end if; | |
1038 | end if; | |
1039 | ||
b545a0f6 JM |
1040 | -- Ada 2005 (AI-251): In case of abstract interface type we must |
1041 | -- displace the pointer to reference the base of the object to | |
c8b92217 JM |
1042 | -- deallocate its memory, unless we're targetting a VM, in which case |
1043 | -- no special processing is required. | |
b545a0f6 JM |
1044 | |
1045 | -- Generate: | |
1046 | -- free (Base_Address (Obj_Ptr)) | |
1047 | ||
c8b92217 | 1048 | if Is_Interface (Directly_Designated_Type (Typ)) |
1f110335 | 1049 | and then Tagged_Type_Expansion |
c8b92217 | 1050 | then |
b545a0f6 JM |
1051 | Set_Expression (Free_Node, |
1052 | Unchecked_Convert_To (Typ, | |
1053 | Make_Function_Call (Loc, | |
1054 | Name => New_Reference_To (RTE (RE_Base_Address), Loc), | |
1055 | Parameter_Associations => New_List ( | |
1056 | Unchecked_Convert_To (RTE (RE_Address), Free_Arg))))); | |
1057 | ||
1058 | -- Generate: | |
1059 | -- free (Obj_Ptr) | |
1060 | ||
1061 | else | |
1062 | Set_Expression (Free_Node, Free_Arg); | |
1063 | end if; | |
191cab8d | 1064 | |
191cab8d TQ |
1065 | -- Only remaining step is to set result to null, or generate a |
1066 | -- raise of constraint error if the target object is "not null". | |
70482933 | 1067 | |
191cab8d TQ |
1068 | if Can_Never_Be_Null (Etype (Arg)) then |
1069 | Append_To (Stmts, | |
1070 | Make_Raise_Constraint_Error (Loc, | |
1071 | Reason => CE_Access_Check_Failed)); | |
70482933 | 1072 | |
191cab8d TQ |
1073 | else |
1074 | declare | |
1075 | Lhs : constant Node_Id := Duplicate_Subexpr_No_Checks (Arg); | |
1076 | begin | |
1077 | Set_Assignment_OK (Lhs); | |
1078 | Append_To (Stmts, | |
1079 | Make_Assignment_Statement (Loc, | |
1080 | Name => Lhs, | |
1081 | Expression => Make_Null (Loc))); | |
1082 | end; | |
70482933 RK |
1083 | end if; |
1084 | ||
dad9a816 RD |
1085 | -- If we know the argument is non-null, then make a block statement |
1086 | -- that contains the required statements, no need for a test. | |
1087 | ||
1088 | if Arg_Known_Non_Null then | |
1089 | Gen_Code := | |
1090 | Make_Block_Statement (Loc, | |
1091 | Handled_Statement_Sequence => | |
1092 | Make_Handled_Sequence_Of_Statements (Loc, | |
1093 | Statements => Stmts)); | |
1094 | ||
1095 | -- If the argument may be null, wrap the statements inside an IF that | |
1096 | -- does an explicit test to exclude the null case. | |
1097 | ||
1098 | else | |
1099 | Gen_Code := | |
1100 | Make_Implicit_If_Statement (N, | |
1101 | Condition => | |
1102 | Make_Op_Ne (Loc, | |
1103 | Left_Opnd => Duplicate_Subexpr (Arg), | |
1104 | Right_Opnd => Make_Null (Loc)), | |
1105 | Then_Statements => Stmts); | |
1106 | end if; | |
1107 | ||
191cab8d | 1108 | -- Rewrite the call |
70482933 RK |
1109 | |
1110 | Rewrite (N, Gen_Code); | |
1111 | Analyze (N); | |
1112 | end Expand_Unc_Deallocation; | |
1113 | ||
fbf5a39b AC |
1114 | ----------------------- |
1115 | -- Expand_To_Address -- | |
1116 | ----------------------- | |
1117 | ||
1118 | procedure Expand_To_Address (N : Node_Id) is | |
1119 | Loc : constant Source_Ptr := Sloc (N); | |
1120 | Arg : constant Node_Id := First_Actual (N); | |
1121 | Obj : Node_Id; | |
1122 | ||
1123 | begin | |
1124 | Remove_Side_Effects (Arg); | |
1125 | ||
1126 | Obj := Make_Explicit_Dereference (Loc, Relocate_Node (Arg)); | |
1127 | ||
1128 | Rewrite (N, | |
1129 | Make_Conditional_Expression (Loc, | |
1130 | Expressions => New_List ( | |
1131 | Make_Op_Eq (Loc, | |
1132 | Left_Opnd => New_Copy_Tree (Arg), | |
1133 | Right_Opnd => Make_Null (Loc)), | |
1134 | New_Occurrence_Of (RTE (RE_Null_Address), Loc), | |
1135 | Make_Attribute_Reference (Loc, | |
c8b92217 JM |
1136 | Prefix => Obj, |
1137 | Attribute_Name => Name_Address)))); | |
fbf5a39b AC |
1138 | |
1139 | Analyze_And_Resolve (N, RTE (RE_Address)); | |
1140 | end Expand_To_Address; | |
1141 | ||
1142 | ----------------------- | |
1143 | -- Expand_To_Pointer -- | |
1144 | ----------------------- | |
1145 | ||
1146 | procedure Expand_To_Pointer (N : Node_Id) is | |
1147 | Arg : constant Node_Id := First_Actual (N); | |
1148 | ||
1149 | begin | |
1150 | Rewrite (N, Unchecked_Convert_To (Etype (N), Arg)); | |
1151 | Analyze (N); | |
1152 | end Expand_To_Pointer; | |
1153 | ||
70482933 | 1154 | end Exp_Intr; |