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