File : exp_intr.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- E X P _ I N T R --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
25
26 with Atree; use Atree;
27 with Checks; use Checks;
28 with Einfo; use Einfo;
29 with Elists; use Elists;
30 with Errout; use Errout;
31 with Expander; use Expander;
32 with Exp_Atag; use Exp_Atag;
33 with Exp_Ch4; use Exp_Ch4;
34 with Exp_Ch7; use Exp_Ch7;
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;
39 with Freeze; use Freeze;
40 with Inline; use Inline;
41 with Nmake; use Nmake;
42 with Nlists; use Nlists;
43 with Opt; use Opt;
44 with Restrict; use Restrict;
45 with Rident; use Rident;
46 with Rtsfind; use Rtsfind;
47 with Sem; use Sem;
48 with Sem_Aux; use Sem_Aux;
49 with Sem_Eval; use Sem_Eval;
50 with Sem_Res; use Sem_Res;
51 with Sem_Type; use Sem_Type;
52 with Sem_Util; use Sem_Util;
53 with Sinfo; use Sinfo;
54 with Sinput; use Sinput;
55 with Snames; use Snames;
56 with Stand; use Stand;
57 with Tbuild; use Tbuild;
58 with Uintp; use Uintp;
59 with Urealp; use Urealp;
60
61 package body Exp_Intr is
62
63 -----------------------
64 -- Local Subprograms --
65 -----------------------
66
67 procedure Expand_Binary_Operator_Call (N : Node_Id);
68 -- Expand a call to an intrinsic arithmetic operator when the operand
69 -- types or sizes are not identical.
70
71 procedure Expand_Is_Negative (N : Node_Id);
72 -- Expand a call to the intrinsic Is_Negative function
73
74 procedure Expand_Dispatching_Constructor_Call (N : Node_Id);
75 -- Expand a call to an instantiation of Generic_Dispatching_Constructor
76 -- into a dispatching call to the actual subprogram associated with the
77 -- Constructor formal subprogram, passing it the Parameters actual of
78 -- the call to the instantiation and dispatching based on call's Tag
79 -- parameter.
80
81 procedure Expand_Exception_Call (N : Node_Id; Ent : RE_Id);
82 -- Expand a call to Exception_Information/Message/Name. The first
83 -- parameter, N, is the node for the function call, and Ent is the
84 -- entity for the corresponding routine in the Ada.Exceptions package.
85
86 procedure Expand_Import_Call (N : Node_Id);
87 -- Expand a call to Import_Address/Longest_Integer/Value. The parameter
88 -- N is the node for the function call.
89
90 procedure Expand_Shift (N : Node_Id; E : Entity_Id; K : Node_Kind);
91 -- Expand an intrinsic shift operation, N and E are from the call to
92 -- Expand_Intrinsic_Call (call node and subprogram spec entity) and
93 -- K is the kind for the shift node
94
95 procedure Expand_Unc_Conversion (N : Node_Id; E : Entity_Id);
96 -- Expand a call to an instantiation of Unchecked_Conversion into a node
97 -- N_Unchecked_Type_Conversion.
98
99 procedure Expand_Unc_Deallocation (N : Node_Id);
100 -- Expand a call to an instantiation of Unchecked_Deallocation into a node
101 -- N_Free_Statement and appropriate context.
102
103 procedure Expand_To_Address (N : Node_Id);
104 procedure Expand_To_Pointer (N : Node_Id);
105 -- Expand a call to corresponding function, declared in an instance of
106 -- System.Address_To_Access_Conversions.
107
108 procedure Expand_Source_Info (N : Node_Id; Nam : Name_Id);
109 -- Rewrite the node as the appropriate string literal or positive
110 -- constant. Nam is the name of one of the intrinsics declared in
111 -- GNAT.Source_Info; see g-souinf.ads for documentation of these
112 -- intrinsics.
113
114 procedure Append_Entity_Name (Buf : in out Bounded_String; E : Entity_Id);
115 -- Recursive procedure to construct string for qualified name of enclosing
116 -- program unit. The qualification stops at an enclosing scope has no
117 -- source name (block or loop). If entity is a subprogram instance, skip
118 -- enclosing wrapper package. The name is appended to Buf.
119
120 ---------------------
121 -- Add_Source_Info --
122 ---------------------
123
124 procedure Add_Source_Info
125 (Buf : in out Bounded_String;
126 Loc : Source_Ptr;
127 Nam : Name_Id)
128 is
129 begin
130 case Nam is
131 when Name_Line =>
132 Append (Buf, Nat (Get_Logical_Line_Number (Loc)));
133
134 when Name_File =>
135 Append_Decoded (Buf, Reference_Name (Get_Source_File_Index (Loc)));
136
137 when Name_Source_Location =>
138 Build_Location_String (Buf, Loc);
139
140 when Name_Enclosing_Entity =>
141
142 -- Skip enclosing blocks to reach enclosing unit
143
144 declare
145 Ent : Entity_Id := Current_Scope;
146 begin
147 while Present (Ent) loop
148 exit when not Ekind_In (Ent, E_Block, E_Loop);
149 Ent := Scope (Ent);
150 end loop;
151
152 -- Ent now points to the relevant defining entity
153
154 Append_Entity_Name (Buf, Ent);
155 end;
156
157 when Name_Compilation_ISO_Date =>
158 Append (Buf, Opt.Compilation_Time (1 .. 10));
159
160 when Name_Compilation_Date =>
161 declare
162 subtype S13 is String (1 .. 3);
163 Months : constant array (1 .. 12) of S13 :=
164 ("Jan", "Feb", "Mar", "Apr", "May", "Jun",
165 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec");
166
167 M1 : constant Character := Opt.Compilation_Time (6);
168 M2 : constant Character := Opt.Compilation_Time (7);
169
170 MM : constant Natural range 1 .. 12 :=
171 (Character'Pos (M1) - Character'Pos ('0')) * 10 +
172 (Character'Pos (M2) - Character'Pos ('0'));
173
174 begin
175 -- Reformat ISO date into MMM DD YYYY (__DATE__) format
176
177 Append (Buf, Months (MM));
178 Append (Buf, ' ');
179 Append (Buf, Opt.Compilation_Time (9 .. 10));
180 Append (Buf, ' ');
181 Append (Buf, Opt.Compilation_Time (1 .. 4));
182 end;
183
184 when Name_Compilation_Time =>
185 Append (Buf, Opt.Compilation_Time (12 .. 19));
186
187 when others =>
188 raise Program_Error;
189 end case;
190 end Add_Source_Info;
191
192 -----------------------
193 -- Append_Entity_Name --
194 -----------------------
195
196 procedure Append_Entity_Name (Buf : in out Bounded_String; E : Entity_Id) is
197 Temp : Bounded_String;
198
199 procedure Inner (E : Entity_Id);
200 -- Inner recursive routine, keep outer routine nonrecursive to ease
201 -- debugging when we get strange results from this routine.
202
203 -----------
204 -- Inner --
205 -----------
206
207 procedure Inner (E : Entity_Id) is
208 begin
209 -- If entity has an internal name, skip by it, and print its scope.
210 -- Note that we strip a final R from the name before the test; this
211 -- is needed for some cases of instantiations.
212
213 declare
214 E_Name : Bounded_String;
215
216 begin
217 Append (E_Name, Chars (E));
218
219 if E_Name.Chars (E_Name.Length) = 'R' then
220 E_Name.Length := E_Name.Length - 1;
221 end if;
222
223 if Is_Internal_Name (E_Name) then
224 Inner (Scope (E));
225 return;
226 end if;
227 end;
228
229 -- Just print entity name if its scope is at the outer level
230
231 if Scope (E) = Standard_Standard then
232 null;
233
234 -- If scope comes from source, write scope and entity
235
236 elsif Comes_From_Source (Scope (E)) then
237 Append_Entity_Name (Temp, Scope (E));
238 Append (Temp, '.');
239
240 -- If in wrapper package skip past it
241
242 elsif Is_Wrapper_Package (Scope (E)) then
243 Append_Entity_Name (Temp, Scope (Scope (E)));
244 Append (Temp, '.');
245
246 -- Otherwise nothing to output (happens in unnamed block statements)
247
248 else
249 null;
250 end if;
251
252 -- Output the name
253
254 declare
255 E_Name : Bounded_String;
256
257 begin
258 Append_Unqualified_Decoded (E_Name, Chars (E));
259
260 -- Remove trailing upper-case letters from the name (useful for
261 -- dealing with some cases of internal names generated in the case
262 -- of references from within a generic).
263
264 while E_Name.Length > 1
265 and then E_Name.Chars (E_Name.Length) in 'A' .. 'Z'
266 loop
267 E_Name.Length := E_Name.Length - 1;
268 end loop;
269
270 -- Adjust casing appropriately (gets name from source if possible)
271
272 Adjust_Name_Case (E_Name, Sloc (E));
273 Append (Temp, E_Name);
274 end;
275 end Inner;
276
277 -- Start of processing for Append_Entity_Name
278
279 begin
280 Inner (E);
281 Append (Buf, Temp);
282 end Append_Entity_Name;
283
284 ---------------------------------
285 -- Expand_Binary_Operator_Call --
286 ---------------------------------
287
288 procedure Expand_Binary_Operator_Call (N : Node_Id) is
289 T1 : constant Entity_Id := Underlying_Type (Etype (Left_Opnd (N)));
290 T2 : constant Entity_Id := Underlying_Type (Etype (Right_Opnd (N)));
291 TR : constant Entity_Id := Etype (N);
292 T3 : Entity_Id;
293 Res : Node_Id;
294
295 Siz : constant Uint := UI_Max (RM_Size (T1), RM_Size (T2));
296 -- Maximum of operand sizes
297
298 begin
299 -- Nothing to do if the operands have the same modular type
300
301 if Base_Type (T1) = Base_Type (T2)
302 and then Is_Modular_Integer_Type (T1)
303 then
304 return;
305 end if;
306
307 -- Use Unsigned_32 for sizes of 32 or below, else Unsigned_64
308
309 if Siz > 32 then
310 T3 := RTE (RE_Unsigned_64);
311 else
312 T3 := RTE (RE_Unsigned_32);
313 end if;
314
315 -- Copy operator node, and reset type and entity fields, for
316 -- subsequent reanalysis.
317
318 Res := New_Copy (N);
319 Set_Etype (Res, T3);
320
321 case Nkind (N) is
322 when N_Op_And =>
323 Set_Entity (Res, Standard_Op_And);
324 when N_Op_Or =>
325 Set_Entity (Res, Standard_Op_Or);
326 when N_Op_Xor =>
327 Set_Entity (Res, Standard_Op_Xor);
328 when others =>
329 raise Program_Error;
330 end case;
331
332 -- Convert operands to large enough intermediate type
333
334 Set_Left_Opnd (Res,
335 Unchecked_Convert_To (T3, Relocate_Node (Left_Opnd (N))));
336 Set_Right_Opnd (Res,
337 Unchecked_Convert_To (T3, Relocate_Node (Right_Opnd (N))));
338
339 -- Analyze and resolve result formed by conversion to target type
340
341 Rewrite (N, Unchecked_Convert_To (TR, Res));
342 Analyze_And_Resolve (N, TR);
343 end Expand_Binary_Operator_Call;
344
345 -----------------------------------------
346 -- Expand_Dispatching_Constructor_Call --
347 -----------------------------------------
348
349 -- Transform a call to an instantiation of Generic_Dispatching_Constructor
350 -- of the form:
351
352 -- GDC_Instance (The_Tag, Parameters'Access)
353
354 -- to a class-wide conversion of a dispatching call to the actual
355 -- associated with the formal subprogram Construct, designating The_Tag
356 -- as the controlling tag of the call:
357
358 -- T'Class (Construct'Actual (Params)) -- Controlling tag is The_Tag
359
360 -- which will eventually be expanded to the following:
361
362 -- T'Class (The_Tag.all (Construct'Actual'Index).all (Params))
363
364 -- A class-wide membership test is also generated, preceding the call, to
365 -- ensure that the controlling tag denotes a type in T'Class.
366
367 procedure Expand_Dispatching_Constructor_Call (N : Node_Id) is
368 Loc : constant Source_Ptr := Sloc (N);
369 Tag_Arg : constant Node_Id := First_Actual (N);
370 Param_Arg : constant Node_Id := Next_Actual (Tag_Arg);
371 Subp_Decl : constant Node_Id := Parent (Parent (Entity (Name (N))));
372 Inst_Pkg : constant Node_Id := Parent (Subp_Decl);
373 Act_Rename : Node_Id;
374 Act_Constr : Entity_Id;
375 Iface_Tag : Node_Id := Empty;
376 Cnstr_Call : Node_Id;
377 Result_Typ : Entity_Id;
378
379 begin
380 -- Remove side effects from tag argument early, before rewriting
381 -- the dispatching constructor call, as Remove_Side_Effects relies
382 -- on Tag_Arg's Parent link properly attached to the tree (once the
383 -- call is rewritten, the Parent is inconsistent as it points to the
384 -- rewritten node, which is not the syntactic parent of the Tag_Arg
385 -- anymore).
386
387 Remove_Side_Effects (Tag_Arg);
388
389 -- Check that we have a proper tag
390
391 Insert_Action (N,
392 Make_Implicit_If_Statement (N,
393 Condition => Make_Op_Eq (Loc,
394 Left_Opnd => New_Copy_Tree (Tag_Arg),
395 Right_Opnd => New_Occurrence_Of (RTE (RE_No_Tag), Loc)),
396
397 Then_Statements => New_List (
398 Make_Raise_Statement (Loc,
399 New_Occurrence_Of (RTE (RE_Tag_Error), Loc)))));
400
401 -- Check that it is not the tag of an abstract type
402
403 Insert_Action (N,
404 Make_Implicit_If_Statement (N,
405 Condition => Make_Function_Call (Loc,
406 Name =>
407 New_Occurrence_Of (RTE (RE_Type_Is_Abstract), Loc),
408 Parameter_Associations => New_List (New_Copy_Tree (Tag_Arg))),
409
410 Then_Statements => New_List (
411 Make_Raise_Statement (Loc,
412 New_Occurrence_Of (RTE (RE_Tag_Error), Loc)))));
413
414 -- The subprogram is the third actual in the instantiation, and is
415 -- retrieved from the corresponding renaming declaration. However,
416 -- freeze nodes may appear before, so we retrieve the declaration
417 -- with an explicit loop.
418
419 Act_Rename := First (Visible_Declarations (Inst_Pkg));
420 while Nkind (Act_Rename) /= N_Subprogram_Renaming_Declaration loop
421 Next (Act_Rename);
422 end loop;
423
424 Act_Constr := Entity (Name (Act_Rename));
425 Result_Typ := Class_Wide_Type (Etype (Act_Constr));
426
427 -- Check that the accessibility level of the tag is no deeper than that
428 -- of the constructor function.
429
430 Insert_Action (N,
431 Make_Implicit_If_Statement (N,
432 Condition =>
433 Make_Op_Gt (Loc,
434 Left_Opnd =>
435 Build_Get_Access_Level (Loc, New_Copy_Tree (Tag_Arg)),
436 Right_Opnd =>
437 Make_Integer_Literal (Loc, Scope_Depth (Act_Constr))),
438
439 Then_Statements => New_List (
440 Make_Raise_Statement (Loc,
441 New_Occurrence_Of (RTE (RE_Tag_Error), Loc)))));
442
443 if Is_Interface (Etype (Act_Constr)) then
444
445 -- If the result type is not known to be a parent of Tag_Arg then we
446 -- need to locate the tag of the secondary dispatch table.
447
448 if not Is_Ancestor (Etype (Result_Typ), Etype (Tag_Arg),
449 Use_Full_View => True)
450 and then Tagged_Type_Expansion
451 then
452 -- Obtain the reference to the Ada.Tags service before generating
453 -- the Object_Declaration node to ensure that if this service is
454 -- not available in the runtime then we generate a clear error.
455
456 declare
457 Fname : constant Node_Id :=
458 New_Occurrence_Of (RTE (RE_Secondary_Tag), Loc);
459
460 begin
461 pragma Assert (not Is_Interface (Etype (Tag_Arg)));
462
463 -- The tag is the first entry in the dispatch table of the
464 -- return type of the constructor.
465
466 Iface_Tag :=
467 Make_Object_Declaration (Loc,
468 Defining_Identifier => Make_Temporary (Loc, 'V'),
469 Object_Definition =>
470 New_Occurrence_Of (RTE (RE_Tag), Loc),
471 Expression =>
472 Make_Function_Call (Loc,
473 Name => Fname,
474 Parameter_Associations => New_List (
475 Relocate_Node (Tag_Arg),
476 New_Occurrence_Of
477 (Node (First_Elmt
478 (Access_Disp_Table (Etype (Act_Constr)))),
479 Loc))));
480 Insert_Action (N, Iface_Tag);
481 end;
482 end if;
483 end if;
484
485 -- Create the call to the actual Constructor function
486
487 Cnstr_Call :=
488 Make_Function_Call (Loc,
489 Name => New_Occurrence_Of (Act_Constr, Loc),
490 Parameter_Associations => New_List (Relocate_Node (Param_Arg)));
491
492 -- Establish its controlling tag from the tag passed to the instance
493 -- The tag may be given by a function call, in which case a temporary
494 -- should be generated now, to prevent out-of-order insertions during
495 -- the expansion of that call when stack-checking is enabled.
496
497 if Present (Iface_Tag) then
498 Set_Controlling_Argument (Cnstr_Call,
499 New_Occurrence_Of (Defining_Identifier (Iface_Tag), Loc));
500 else
501 Set_Controlling_Argument (Cnstr_Call,
502 Relocate_Node (Tag_Arg));
503 end if;
504
505 -- Rewrite and analyze the call to the instance as a class-wide
506 -- conversion of the call to the actual constructor.
507
508 Rewrite (N, Convert_To (Result_Typ, Cnstr_Call));
509
510 -- Do not generate a run-time check on the built object if tag
511 -- checks are suppressed for the result type or tagged type expansion
512 -- is disabled.
513
514 if Tag_Checks_Suppressed (Etype (Result_Typ))
515 or else not Tagged_Type_Expansion
516 then
517 null;
518
519 -- Generate a class-wide membership test to ensure that the call's tag
520 -- argument denotes a type within the class. We must keep separate the
521 -- case in which the Result_Type of the constructor function is a tagged
522 -- type from the case in which it is an abstract interface because the
523 -- run-time subprogram required to check these cases differ (and have
524 -- one difference in their parameters profile).
525
526 -- Call CW_Membership if the Result_Type is a tagged type to look for
527 -- the tag in the table of ancestor tags.
528
529 elsif not Is_Interface (Result_Typ) then
530 declare
531 Obj_Tag_Node : Node_Id := New_Copy_Tree (Tag_Arg);
532 CW_Test_Node : Node_Id;
533
534 begin
535 Build_CW_Membership (Loc,
536 Obj_Tag_Node => Obj_Tag_Node,
537 Typ_Tag_Node =>
538 New_Occurrence_Of (
539 Node (First_Elmt (Access_Disp_Table (
540 Root_Type (Result_Typ)))), Loc),
541 Related_Nod => N,
542 New_Node => CW_Test_Node);
543
544 Insert_Action (N,
545 Make_Implicit_If_Statement (N,
546 Condition =>
547 Make_Op_Not (Loc, CW_Test_Node),
548 Then_Statements =>
549 New_List (Make_Raise_Statement (Loc,
550 New_Occurrence_Of (RTE (RE_Tag_Error), Loc)))));
551 end;
552
553 -- Call IW_Membership test if the Result_Type is an abstract interface
554 -- to look for the tag in the table of interface tags.
555
556 else
557 Insert_Action (N,
558 Make_Implicit_If_Statement (N,
559 Condition =>
560 Make_Op_Not (Loc,
561 Make_Function_Call (Loc,
562 Name => New_Occurrence_Of (RTE (RE_IW_Membership), Loc),
563 Parameter_Associations => New_List (
564 Make_Attribute_Reference (Loc,
565 Prefix => New_Copy_Tree (Tag_Arg),
566 Attribute_Name => Name_Address),
567
568 New_Occurrence_Of (
569 Node (First_Elmt (Access_Disp_Table (
570 Root_Type (Result_Typ)))), Loc)))),
571 Then_Statements =>
572 New_List (
573 Make_Raise_Statement (Loc,
574 Name => New_Occurrence_Of (RTE (RE_Tag_Error), Loc)))));
575 end if;
576
577 Analyze_And_Resolve (N, Etype (Act_Constr));
578 end Expand_Dispatching_Constructor_Call;
579
580 ---------------------------
581 -- Expand_Exception_Call --
582 ---------------------------
583
584 -- If the function call is not within an exception handler, then the call
585 -- is replaced by a null string. Otherwise the appropriate routine in
586 -- Ada.Exceptions is called passing the choice parameter specification
587 -- from the enclosing handler. If the enclosing handler lacks a choice
588 -- parameter, then one is supplied.
589
590 procedure Expand_Exception_Call (N : Node_Id; Ent : RE_Id) is
591 Loc : constant Source_Ptr := Sloc (N);
592 P : Node_Id;
593 E : Entity_Id;
594
595 begin
596 -- Climb up parents to see if we are in exception handler
597
598 P := Parent (N);
599 loop
600 -- Case of not in exception handler, replace by null string
601
602 if No (P) then
603 Rewrite (N,
604 Make_String_Literal (Loc,
605 Strval => ""));
606 exit;
607
608 -- Case of in exception handler
609
610 elsif Nkind (P) = N_Exception_Handler then
611
612 -- Handler cannot be used for a local raise, and furthermore, this
613 -- is a violation of the No_Exception_Propagation restriction.
614
615 Set_Local_Raise_Not_OK (P);
616 Check_Restriction (No_Exception_Propagation, N);
617
618 -- If no choice parameter present, then put one there. Note that
619 -- we do not need to put it on the entity chain, since no one will
620 -- be referencing it by normal visibility methods.
621
622 if No (Choice_Parameter (P)) then
623 E := Make_Temporary (Loc, 'E');
624 Set_Choice_Parameter (P, E);
625 Set_Ekind (E, E_Variable);
626 Set_Etype (E, RTE (RE_Exception_Occurrence));
627 Set_Scope (E, Current_Scope);
628 end if;
629
630 Rewrite (N,
631 Make_Function_Call (Loc,
632 Name => New_Occurrence_Of (RTE (Ent), Loc),
633 Parameter_Associations => New_List (
634 New_Occurrence_Of (Choice_Parameter (P), Loc))));
635 exit;
636
637 -- Keep climbing
638
639 else
640 P := Parent (P);
641 end if;
642 end loop;
643
644 Analyze_And_Resolve (N, Standard_String);
645 end Expand_Exception_Call;
646
647 ------------------------
648 -- Expand_Import_Call --
649 ------------------------
650
651 -- The function call must have a static string as its argument. We create
652 -- a dummy variable which uses this string as the external name in an
653 -- Import pragma. The result is then obtained as the address of this
654 -- dummy variable, converted to the appropriate target type.
655
656 procedure Expand_Import_Call (N : Node_Id) is
657 Loc : constant Source_Ptr := Sloc (N);
658 Ent : constant Entity_Id := Entity (Name (N));
659 Str : constant Node_Id := First_Actual (N);
660 Dum : constant Entity_Id := Make_Temporary (Loc, 'D');
661
662 begin
663 Insert_Actions (N, New_List (
664 Make_Object_Declaration (Loc,
665 Defining_Identifier => Dum,
666 Object_Definition =>
667 New_Occurrence_Of (Standard_Character, Loc)),
668
669 Make_Pragma (Loc,
670 Chars => Name_Import,
671 Pragma_Argument_Associations => New_List (
672 Make_Pragma_Argument_Association (Loc,
673 Expression => Make_Identifier (Loc, Name_Ada)),
674
675 Make_Pragma_Argument_Association (Loc,
676 Expression => Make_Identifier (Loc, Chars (Dum))),
677
678 Make_Pragma_Argument_Association (Loc,
679 Chars => Name_Link_Name,
680 Expression => Relocate_Node (Str))))));
681
682 Rewrite (N,
683 Unchecked_Convert_To (Etype (Ent),
684 Make_Attribute_Reference (Loc,
685 Prefix => Make_Identifier (Loc, Chars (Dum)),
686 Attribute_Name => Name_Address)));
687
688 Analyze_And_Resolve (N, Etype (Ent));
689 end Expand_Import_Call;
690
691 ---------------------------
692 -- Expand_Intrinsic_Call --
693 ---------------------------
694
695 procedure Expand_Intrinsic_Call (N : Node_Id; E : Entity_Id) is
696 Nam : Name_Id;
697
698 begin
699 -- If an external name is specified for the intrinsic, it is handled
700 -- by the back-end: leave the call node unchanged for now.
701
702 if Present (Interface_Name (E)) then
703 return;
704 end if;
705
706 -- If the intrinsic subprogram is generic, gets its original name
707
708 if Present (Parent (E))
709 and then Present (Generic_Parent (Parent (E)))
710 then
711 Nam := Chars (Generic_Parent (Parent (E)));
712 else
713 Nam := Chars (E);
714 end if;
715
716 if Nam = Name_Asm then
717 Expand_Asm_Call (N);
718
719 elsif Nam = Name_Divide then
720 Expand_Decimal_Divide_Call (N);
721
722 elsif Nam = Name_Exception_Information then
723 Expand_Exception_Call (N, RE_Exception_Information);
724
725 elsif Nam = Name_Exception_Message then
726 Expand_Exception_Call (N, RE_Exception_Message);
727
728 elsif Nam = Name_Exception_Name then
729 Expand_Exception_Call (N, RE_Exception_Name_Simple);
730
731 elsif Nam = Name_Generic_Dispatching_Constructor then
732 Expand_Dispatching_Constructor_Call (N);
733
734 elsif Nam_In (Nam, Name_Import_Address,
735 Name_Import_Largest_Value,
736 Name_Import_Value)
737 then
738 Expand_Import_Call (N);
739
740 elsif Nam = Name_Is_Negative then
741 Expand_Is_Negative (N);
742
743 elsif Nam = Name_Rotate_Left then
744 Expand_Shift (N, E, N_Op_Rotate_Left);
745
746 elsif Nam = Name_Rotate_Right then
747 Expand_Shift (N, E, N_Op_Rotate_Right);
748
749 elsif Nam = Name_Shift_Left then
750 Expand_Shift (N, E, N_Op_Shift_Left);
751
752 elsif Nam = Name_Shift_Right then
753 Expand_Shift (N, E, N_Op_Shift_Right);
754
755 elsif Nam = Name_Shift_Right_Arithmetic then
756 Expand_Shift (N, E, N_Op_Shift_Right_Arithmetic);
757
758 elsif Nam = Name_Unchecked_Conversion then
759 Expand_Unc_Conversion (N, E);
760
761 elsif Nam = Name_Unchecked_Deallocation then
762 Expand_Unc_Deallocation (N);
763
764 elsif Nam = Name_To_Address then
765 Expand_To_Address (N);
766
767 elsif Nam = Name_To_Pointer then
768 Expand_To_Pointer (N);
769
770 elsif Nam_In (Nam, Name_File,
771 Name_Line,
772 Name_Source_Location,
773 Name_Enclosing_Entity,
774 Name_Compilation_ISO_Date,
775 Name_Compilation_Date,
776 Name_Compilation_Time)
777 then
778 Expand_Source_Info (N, Nam);
779
780 -- If we have a renaming, expand the call to the original operation,
781 -- which must itself be intrinsic, since renaming requires matching
782 -- conventions and this has already been checked.
783
784 elsif Present (Alias (E)) then
785 Expand_Intrinsic_Call (N, Alias (E));
786
787 elsif Nkind (N) in N_Binary_Op then
788 Expand_Binary_Operator_Call (N);
789
790 -- The only other case is where an external name was specified, since
791 -- this is the only way that an otherwise unrecognized name could
792 -- escape the checking in Sem_Prag. Nothing needs to be done in such
793 -- a case, since we pass such a call to the back end unchanged.
794
795 else
796 null;
797 end if;
798 end Expand_Intrinsic_Call;
799
800 ------------------------
801 -- Expand_Is_Negative --
802 ------------------------
803
804 procedure Expand_Is_Negative (N : Node_Id) is
805 Loc : constant Source_Ptr := Sloc (N);
806 Opnd : constant Node_Id := Relocate_Node (First_Actual (N));
807
808 begin
809
810 -- We replace the function call by the following expression
811
812 -- if Opnd < 0.0 then
813 -- True
814 -- else
815 -- if Opnd > 0.0 then
816 -- False;
817 -- else
818 -- Float_Unsigned!(Float (Opnd)) /= 0
819 -- end if;
820 -- end if;
821
822 Rewrite (N,
823 Make_If_Expression (Loc,
824 Expressions => New_List (
825 Make_Op_Lt (Loc,
826 Left_Opnd => Duplicate_Subexpr (Opnd),
827 Right_Opnd => Make_Real_Literal (Loc, Ureal_0)),
828
829 New_Occurrence_Of (Standard_True, Loc),
830
831 Make_If_Expression (Loc,
832 Expressions => New_List (
833 Make_Op_Gt (Loc,
834 Left_Opnd => Duplicate_Subexpr_No_Checks (Opnd),
835 Right_Opnd => Make_Real_Literal (Loc, Ureal_0)),
836
837 New_Occurrence_Of (Standard_False, Loc),
838
839 Make_Op_Ne (Loc,
840 Left_Opnd =>
841 Unchecked_Convert_To
842 (RTE (RE_Float_Unsigned),
843 Convert_To
844 (Standard_Float,
845 Duplicate_Subexpr_No_Checks (Opnd))),
846 Right_Opnd =>
847 Make_Integer_Literal (Loc, 0)))))));
848
849 Analyze_And_Resolve (N, Standard_Boolean);
850 end Expand_Is_Negative;
851
852 ------------------
853 -- Expand_Shift --
854 ------------------
855
856 -- This procedure is used to convert a call to a shift function to the
857 -- corresponding operator node. This conversion is not done by the usual
858 -- circuit for converting calls to operator functions (e.g. "+"(1,2)) to
859 -- operator nodes, because shifts are not predefined operators.
860
861 -- As a result, whenever a shift is used in the source program, it will
862 -- remain as a call until converted by this routine to the operator node
863 -- form which the back end is expecting to see.
864
865 -- Note: it is possible for the expander to generate shift operator nodes
866 -- directly, which will be analyzed in the normal manner by calling Analyze
867 -- and Resolve. Such shift operator nodes will not be seen by Expand_Shift.
868
869 procedure Expand_Shift (N : Node_Id; E : Entity_Id; K : Node_Kind) is
870 Entyp : constant Entity_Id := Etype (E);
871 Left : constant Node_Id := First_Actual (N);
872 Loc : constant Source_Ptr := Sloc (N);
873 Right : constant Node_Id := Next_Actual (Left);
874 Ltyp : constant Node_Id := Etype (Left);
875 Rtyp : constant Node_Id := Etype (Right);
876 Typ : constant Entity_Id := Etype (N);
877 Snode : Node_Id;
878
879 begin
880 Snode := New_Node (K, Loc);
881 Set_Right_Opnd (Snode, Relocate_Node (Right));
882 Set_Chars (Snode, Chars (E));
883 Set_Etype (Snode, Base_Type (Entyp));
884 Set_Entity (Snode, E);
885
886 if Compile_Time_Known_Value (Type_High_Bound (Rtyp))
887 and then Expr_Value (Type_High_Bound (Rtyp)) < Esize (Ltyp)
888 then
889 Set_Shift_Count_OK (Snode, True);
890 end if;
891
892 if Typ = Entyp then
893
894 -- Note that we don't call Analyze and Resolve on this node, because
895 -- it already got analyzed and resolved when it was a function call.
896
897 Set_Left_Opnd (Snode, Relocate_Node (Left));
898 Rewrite (N, Snode);
899 Set_Analyzed (N);
900
901 -- However, we do call the expander, so that the expansion for
902 -- rotates and shift_right_arithmetic happens if Modify_Tree_For_C
903 -- is set.
904
905 if Expander_Active then
906 Expand (N);
907 end if;
908
909 else
910 -- If the context type is not the type of the operator, it is an
911 -- inherited operator for a derived type. Wrap the node in a
912 -- conversion so that it is type-consistent for possible further
913 -- expansion (e.g. within a lock-free protected type).
914
915 Set_Left_Opnd (Snode,
916 Unchecked_Convert_To (Base_Type (Entyp), Relocate_Node (Left)));
917 Rewrite (N, Unchecked_Convert_To (Typ, Snode));
918
919 -- Analyze and resolve result formed by conversion to target type
920
921 Analyze_And_Resolve (N, Typ);
922 end if;
923 end Expand_Shift;
924
925 ------------------------
926 -- Expand_Source_Info --
927 ------------------------
928
929 procedure Expand_Source_Info (N : Node_Id; Nam : Name_Id) is
930 Loc : constant Source_Ptr := Sloc (N);
931 begin
932 -- Integer cases
933
934 if Nam = Name_Line then
935 Rewrite (N,
936 Make_Integer_Literal (Loc,
937 Intval => UI_From_Int (Int (Get_Logical_Line_Number (Loc)))));
938 Analyze_And_Resolve (N, Standard_Positive);
939
940 -- String cases
941
942 else
943 declare
944 Buf : Bounded_String;
945 begin
946 Add_Source_Info (Buf, Loc, Nam);
947 Rewrite (N, Make_String_Literal (Loc, Strval => +Buf));
948 Analyze_And_Resolve (N, Standard_String);
949 end;
950 end if;
951
952 Set_Is_Static_Expression (N);
953 end Expand_Source_Info;
954
955 ---------------------------
956 -- Expand_Unc_Conversion --
957 ---------------------------
958
959 procedure Expand_Unc_Conversion (N : Node_Id; E : Entity_Id) is
960 Func : constant Entity_Id := Entity (Name (N));
961 Conv : Node_Id;
962 Ftyp : Entity_Id;
963 Ttyp : Entity_Id;
964
965 begin
966 -- Rewrite as unchecked conversion node. Note that we must convert
967 -- the operand to the formal type of the input parameter of the
968 -- function, so that the resulting N_Unchecked_Type_Conversion
969 -- call indicates the correct types for Gigi.
970
971 -- Right now, we only do this if a scalar type is involved. It is
972 -- not clear if it is needed in other cases. If we do attempt to
973 -- do the conversion unconditionally, it crashes 3411-018. To be
974 -- investigated further ???
975
976 Conv := Relocate_Node (First_Actual (N));
977 Ftyp := Etype (First_Formal (Func));
978
979 if Is_Scalar_Type (Ftyp) then
980 Conv := Convert_To (Ftyp, Conv);
981 Set_Parent (Conv, N);
982 Analyze_And_Resolve (Conv);
983 end if;
984
985 -- The instantiation of Unchecked_Conversion creates a wrapper package,
986 -- and the target type is declared as a subtype of the actual. Recover
987 -- the actual, which is the subtype indic. in the subtype declaration
988 -- for the target type. This is semantically correct, and avoids
989 -- anomalies with access subtypes. For entities, leave type as is.
990
991 -- We do the analysis here, because we do not want the compiler
992 -- to try to optimize or otherwise reorganize the unchecked
993 -- conversion node.
994
995 Ttyp := Etype (E);
996
997 if Is_Entity_Name (Conv) then
998 null;
999
1000 elsif Nkind (Parent (Ttyp)) = N_Subtype_Declaration then
1001 Ttyp := Entity (Subtype_Indication (Parent (Etype (E))));
1002
1003 elsif Is_Itype (Ttyp) then
1004 Ttyp :=
1005 Entity (Subtype_Indication (Associated_Node_For_Itype (Ttyp)));
1006 else
1007 raise Program_Error;
1008 end if;
1009
1010 Rewrite (N, Unchecked_Convert_To (Ttyp, Conv));
1011 Set_Etype (N, Ttyp);
1012 Set_Analyzed (N);
1013
1014 if Nkind (N) = N_Unchecked_Type_Conversion then
1015 Expand_N_Unchecked_Type_Conversion (N);
1016 end if;
1017 end Expand_Unc_Conversion;
1018
1019 -----------------------------
1020 -- Expand_Unc_Deallocation --
1021 -----------------------------
1022
1023 procedure Expand_Unc_Deallocation (N : Node_Id) is
1024 Arg : constant Node_Id := First_Actual (N);
1025 Loc : constant Source_Ptr := Sloc (N);
1026 Typ : constant Entity_Id := Etype (Arg);
1027 Desig_Typ : constant Entity_Id := Designated_Type (Typ);
1028 Needs_Fin : constant Boolean := Needs_Finalization (Desig_Typ);
1029 Root_Typ : constant Entity_Id := Underlying_Type (Root_Type (Typ));
1030 Pool : constant Entity_Id := Associated_Storage_Pool (Root_Typ);
1031 Stmts : constant List_Id := New_List;
1032
1033 Arg_Known_Non_Null : constant Boolean := Known_Non_Null (N);
1034 -- This captures whether we know the argument to be non-null so that
1035 -- we can avoid the test. The reason that we need to capture this is
1036 -- that we analyze some generated statements before properly attaching
1037 -- them to the tree, and that can disturb current value settings.
1038
1039 Exceptions_OK : constant Boolean :=
1040 not Restriction_Active (No_Exception_Propagation);
1041
1042 Abrt_Blk : Node_Id := Empty;
1043 Abrt_Blk_Id : Entity_Id;
1044 Abrt_HSS : Node_Id;
1045 AUD : Entity_Id;
1046 Fin_Blk : Node_Id;
1047 Fin_Call : Node_Id;
1048 Fin_Data : Finalization_Exception_Data;
1049 Free_Arg : Node_Id;
1050 Free_Nod : Node_Id;
1051 Gen_Code : Node_Id;
1052 Obj_Ref : Node_Id;
1053
1054 begin
1055 -- Nothing to do if we know the argument is null
1056
1057 if Known_Null (N) then
1058 return;
1059 end if;
1060
1061 -- Processing for pointer to controlled types. Generate:
1062
1063 -- Abrt : constant Boolean := ...;
1064 -- Ex : Exception_Occurrence;
1065 -- Raised : Boolean := False;
1066
1067 -- begin
1068 -- Abort_Defer;
1069
1070 -- begin
1071 -- [Deep_]Finalize (Obj_Ref);
1072
1073 -- exception
1074 -- when others =>
1075 -- if not Raised then
1076 -- Raised := True;
1077 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
1078 -- end;
1079 -- at end
1080 -- Abort_Undefer_Direct;
1081 -- end;
1082
1083 -- Depending on whether exception propagation is enabled and/or aborts
1084 -- are allowed, the generated code may lack block statements.
1085
1086 if Needs_Fin then
1087 Obj_Ref :=
1088 Make_Explicit_Dereference (Loc,
1089 Prefix => Duplicate_Subexpr_No_Checks (Arg));
1090
1091 -- If the designated type is tagged, the finalization call must
1092 -- dispatch because the designated type may not be the actual type
1093 -- of the object. If the type is synchronized, the deallocation
1094 -- applies to the corresponding record type.
1095
1096 if Is_Tagged_Type (Desig_Typ) then
1097 if Is_Concurrent_Type (Desig_Typ) then
1098 Obj_Ref :=
1099 Unchecked_Convert_To
1100 (Class_Wide_Type (Corresponding_Record_Type (Desig_Typ)),
1101 Obj_Ref);
1102
1103 elsif not Is_Class_Wide_Type (Desig_Typ) then
1104 Obj_Ref :=
1105 Unchecked_Convert_To (Class_Wide_Type (Desig_Typ), Obj_Ref);
1106 end if;
1107
1108 -- Otherwise the designated type is untagged. Set the type of the
1109 -- dereference explicitly to force a conversion when needed given
1110 -- that [Deep_]Finalize may be inherited from a parent type.
1111
1112 else
1113 Set_Etype (Obj_Ref, Desig_Typ);
1114 end if;
1115
1116 -- Generate:
1117 -- [Deep_]Finalize (Obj_Ref);
1118
1119 Fin_Call := Make_Final_Call (Obj_Ref => Obj_Ref, Typ => Desig_Typ);
1120
1121 -- Generate:
1122 -- Abrt : constant Boolean := ...;
1123 -- Ex : Exception_Occurrence;
1124 -- Raised : Boolean := False;
1125
1126 -- begin
1127 -- <Fin_Call>
1128
1129 -- exception
1130 -- when others =>
1131 -- if not Raised then
1132 -- Raised := True;
1133 -- Save_Occurrence (Ex, Get_Current_Excep.all.all);
1134 -- end;
1135
1136 if Exceptions_OK then
1137 Build_Object_Declarations (Fin_Data, Stmts, Loc);
1138
1139 Fin_Blk :=
1140 Make_Block_Statement (Loc,
1141 Handled_Statement_Sequence =>
1142 Make_Handled_Sequence_Of_Statements (Loc,
1143 Statements => New_List (Fin_Call),
1144 Exception_Handlers => New_List (
1145 Build_Exception_Handler (Fin_Data))));
1146
1147 -- Otherwise exception propagation is not allowed
1148
1149 else
1150 Fin_Blk := Fin_Call;
1151 end if;
1152
1153 -- The finalization action must be protected by an abort defer and
1154 -- undefer pair when aborts are allowed. Generate:
1155
1156 -- begin
1157 -- Abort_Defer;
1158 -- <Fin_Blk>
1159 -- at end
1160 -- Abort_Undefer_Direct;
1161 -- end;
1162
1163 if Abort_Allowed then
1164 AUD := RTE (RE_Abort_Undefer_Direct);
1165
1166 Abrt_HSS :=
1167 Make_Handled_Sequence_Of_Statements (Loc,
1168 Statements => New_List (
1169 Build_Runtime_Call (Loc, RE_Abort_Defer),
1170 Fin_Blk),
1171 At_End_Proc => New_Occurrence_Of (AUD, Loc));
1172
1173 Abrt_Blk :=
1174 Make_Block_Statement (Loc,
1175 Handled_Statement_Sequence => Abrt_HSS);
1176
1177 Add_Block_Identifier (Abrt_Blk, Abrt_Blk_Id);
1178 Expand_At_End_Handler (Abrt_HSS, Abrt_Blk_Id);
1179
1180 -- Present the Abort_Undefer_Direct function to the backend so
1181 -- that it can inline the call to the function.
1182
1183 Add_Inlined_Body (AUD, N);
1184
1185 -- Otherwise aborts are not allowed
1186
1187 else
1188 Abrt_Blk := Fin_Blk;
1189 end if;
1190
1191 Append_To (Stmts, Abrt_Blk);
1192 end if;
1193
1194 -- For a task type, call Free_Task before freeing the ATCB. We used to
1195 -- detect the case of Abort followed by a Free here, because the Free
1196 -- wouldn't actually free if it happens before the aborted task actually
1197 -- terminates. The warning was removed, because Free now works properly
1198 -- (the task will be freed once it terminates).
1199
1200 if Is_Task_Type (Desig_Typ) then
1201 Append_To (Stmts,
1202 Cleanup_Task (N, Duplicate_Subexpr_No_Checks (Arg)));
1203
1204 -- For composite types that contain tasks, recurse over the structure
1205 -- to build the selectors for the task subcomponents.
1206
1207 elsif Has_Task (Desig_Typ) then
1208 if Is_Array_Type (Desig_Typ) then
1209 Append_List_To (Stmts, Cleanup_Array (N, Arg, Desig_Typ));
1210
1211 elsif Is_Record_Type (Desig_Typ) then
1212 Append_List_To (Stmts, Cleanup_Record (N, Arg, Desig_Typ));
1213 end if;
1214 end if;
1215
1216 -- Same for simple protected types. Eventually call Finalize_Protection
1217 -- before freeing the PO for each protected component.
1218
1219 if Is_Simple_Protected_Type (Desig_Typ) then
1220 Append_To (Stmts,
1221 Cleanup_Protected_Object (N, Duplicate_Subexpr_No_Checks (Arg)));
1222
1223 elsif Has_Simple_Protected_Object (Desig_Typ) then
1224 if Is_Array_Type (Desig_Typ) then
1225 Append_List_To (Stmts, Cleanup_Array (N, Arg, Desig_Typ));
1226
1227 elsif Is_Record_Type (Desig_Typ) then
1228 Append_List_To (Stmts, Cleanup_Record (N, Arg, Desig_Typ));
1229 end if;
1230 end if;
1231
1232 -- Normal processing for non-controlled types. The argument to free is
1233 -- a renaming rather than a constant to ensure that the original context
1234 -- is always set to null after the deallocation takes place.
1235
1236 Free_Arg := Duplicate_Subexpr_No_Checks (Arg, Renaming_Req => True);
1237 Free_Nod := Make_Free_Statement (Loc, Empty);
1238 Append_To (Stmts, Free_Nod);
1239 Set_Storage_Pool (Free_Nod, Pool);
1240
1241 -- Attach to tree before analysis of generated subtypes below
1242
1243 Set_Parent (Stmts, Parent (N));
1244
1245 -- Deal with storage pool
1246
1247 if Present (Pool) then
1248
1249 -- Freeing the secondary stack is meaningless
1250
1251 if Is_RTE (Pool, RE_SS_Pool) then
1252 null;
1253
1254 -- If the pool object is of a simple storage pool type, then attempt
1255 -- to locate the type's Deallocate procedure, if any, and set the
1256 -- free operation's procedure to call. If the type doesn't have a
1257 -- Deallocate (which is allowed), then the actual will simply be set
1258 -- to null.
1259
1260 elsif Present
1261 (Get_Rep_Pragma (Etype (Pool), Name_Simple_Storage_Pool_Type))
1262 then
1263 declare
1264 Pool_Typ : constant Entity_Id := Base_Type (Etype (Pool));
1265 Dealloc : Entity_Id;
1266
1267 begin
1268 Dealloc := Get_Name_Entity_Id (Name_Deallocate);
1269 while Present (Dealloc) loop
1270 if Scope (Dealloc) = Scope (Pool_Typ)
1271 and then Present (First_Formal (Dealloc))
1272 and then Etype (First_Formal (Dealloc)) = Pool_Typ
1273 then
1274 Set_Procedure_To_Call (Free_Nod, Dealloc);
1275 exit;
1276 else
1277 Dealloc := Homonym (Dealloc);
1278 end if;
1279 end loop;
1280 end;
1281
1282 -- Case of a class-wide pool type: make a dispatching call to
1283 -- Deallocate through the class-wide Deallocate_Any.
1284
1285 elsif Is_Class_Wide_Type (Etype (Pool)) then
1286 Set_Procedure_To_Call (Free_Nod, RTE (RE_Deallocate_Any));
1287
1288 -- Case of a specific pool type: make a statically bound call
1289
1290 else
1291 Set_Procedure_To_Call
1292 (Free_Nod, Find_Prim_Op (Etype (Pool), Name_Deallocate));
1293 end if;
1294 end if;
1295
1296 if Present (Procedure_To_Call (Free_Nod)) then
1297
1298 -- For all cases of a Deallocate call, the back-end needs to be able
1299 -- to compute the size of the object being freed. This may require
1300 -- some adjustments for objects of dynamic size.
1301 --
1302 -- If the type is class wide, we generate an implicit type with the
1303 -- right dynamic size, so that the deallocate call gets the right
1304 -- size parameter computed by GIGI. Same for an access to
1305 -- unconstrained packed array.
1306
1307 if Is_Class_Wide_Type (Desig_Typ)
1308 or else
1309 (Is_Array_Type (Desig_Typ)
1310 and then not Is_Constrained (Desig_Typ)
1311 and then Is_Packed (Desig_Typ))
1312 then
1313 declare
1314 Deref : constant Node_Id :=
1315 Make_Explicit_Dereference (Loc,
1316 Duplicate_Subexpr_No_Checks (Arg));
1317 D_Subtyp : Node_Id;
1318 D_Type : Entity_Id;
1319
1320 begin
1321 -- Perform minor decoration as it is needed by the side effect
1322 -- removal mechanism.
1323
1324 Set_Etype (Deref, Desig_Typ);
1325 Set_Parent (Deref, Free_Nod);
1326 D_Subtyp := Make_Subtype_From_Expr (Deref, Desig_Typ);
1327
1328 if Nkind (D_Subtyp) in N_Has_Entity then
1329 D_Type := Entity (D_Subtyp);
1330
1331 else
1332 D_Type := Make_Temporary (Loc, 'A');
1333 Insert_Action (Deref,
1334 Make_Subtype_Declaration (Loc,
1335 Defining_Identifier => D_Type,
1336 Subtype_Indication => D_Subtyp));
1337 end if;
1338
1339 -- Force freezing at the point of the dereference. For the
1340 -- class wide case, this avoids having the subtype frozen
1341 -- before the equivalent type.
1342
1343 Freeze_Itype (D_Type, Deref);
1344
1345 Set_Actual_Designated_Subtype (Free_Nod, D_Type);
1346 end;
1347 end if;
1348 end if;
1349
1350 -- Ada 2005 (AI-251): In case of abstract interface type we must
1351 -- displace the pointer to reference the base of the object to
1352 -- deallocate its memory, unless we're targetting a VM, in which case
1353 -- no special processing is required.
1354
1355 -- Generate:
1356 -- free (Base_Address (Obj_Ptr))
1357
1358 if Is_Interface (Directly_Designated_Type (Typ))
1359 and then Tagged_Type_Expansion
1360 then
1361 Set_Expression (Free_Nod,
1362 Unchecked_Convert_To (Typ,
1363 Make_Function_Call (Loc,
1364 Name =>
1365 New_Occurrence_Of (RTE (RE_Base_Address), Loc),
1366 Parameter_Associations => New_List (
1367 Unchecked_Convert_To (RTE (RE_Address), Free_Arg)))));
1368
1369 -- Generate:
1370 -- free (Obj_Ptr)
1371
1372 else
1373 Set_Expression (Free_Nod, Free_Arg);
1374 end if;
1375
1376 -- Only remaining step is to set result to null, or generate a raise of
1377 -- Constraint_Error if the target object is "not null".
1378
1379 if Can_Never_Be_Null (Etype (Arg)) then
1380 Append_To (Stmts,
1381 Make_Raise_Constraint_Error (Loc,
1382 Reason => CE_Access_Check_Failed));
1383
1384 else
1385 declare
1386 Lhs : constant Node_Id := Duplicate_Subexpr_No_Checks (Arg);
1387 begin
1388 Set_Assignment_OK (Lhs);
1389 Append_To (Stmts,
1390 Make_Assignment_Statement (Loc,
1391 Name => Lhs,
1392 Expression => Make_Null (Loc)));
1393 end;
1394 end if;
1395
1396 -- Generate a test of whether any earlier finalization raised an
1397 -- exception, and in that case raise Program_Error with the previous
1398 -- exception occurrence.
1399
1400 -- Generate:
1401 -- if Raised and then not Abrt then
1402 -- raise Program_Error; -- for restricted RTS
1403 -- <or>
1404 -- Raise_From_Controlled_Operation (E); -- all other cases
1405 -- end if;
1406
1407 if Needs_Fin and then Exceptions_OK then
1408 Append_To (Stmts, Build_Raise_Statement (Fin_Data));
1409 end if;
1410
1411 -- If we know the argument is non-null, then make a block statement
1412 -- that contains the required statements, no need for a test.
1413
1414 if Arg_Known_Non_Null then
1415 Gen_Code :=
1416 Make_Block_Statement (Loc,
1417 Handled_Statement_Sequence =>
1418 Make_Handled_Sequence_Of_Statements (Loc,
1419 Statements => Stmts));
1420
1421 -- If the argument may be null, wrap the statements inside an IF that
1422 -- does an explicit test to exclude the null case.
1423
1424 else
1425 Gen_Code :=
1426 Make_Implicit_If_Statement (N,
1427 Condition =>
1428 Make_Op_Ne (Loc,
1429 Left_Opnd => Duplicate_Subexpr (Arg),
1430 Right_Opnd => Make_Null (Loc)),
1431 Then_Statements => Stmts);
1432 end if;
1433
1434 -- Rewrite the call
1435
1436 Rewrite (N, Gen_Code);
1437 Analyze (N);
1438 end Expand_Unc_Deallocation;
1439
1440 -----------------------
1441 -- Expand_To_Address --
1442 -----------------------
1443
1444 procedure Expand_To_Address (N : Node_Id) is
1445 Loc : constant Source_Ptr := Sloc (N);
1446 Arg : constant Node_Id := First_Actual (N);
1447 Obj : Node_Id;
1448
1449 begin
1450 Remove_Side_Effects (Arg);
1451
1452 Obj := Make_Explicit_Dereference (Loc, Relocate_Node (Arg));
1453
1454 Rewrite (N,
1455 Make_If_Expression (Loc,
1456 Expressions => New_List (
1457 Make_Op_Eq (Loc,
1458 Left_Opnd => New_Copy_Tree (Arg),
1459 Right_Opnd => Make_Null (Loc)),
1460 New_Occurrence_Of (RTE (RE_Null_Address), Loc),
1461 Make_Attribute_Reference (Loc,
1462 Prefix => Obj,
1463 Attribute_Name => Name_Address))));
1464
1465 Analyze_And_Resolve (N, RTE (RE_Address));
1466 end Expand_To_Address;
1467
1468 -----------------------
1469 -- Expand_To_Pointer --
1470 -----------------------
1471
1472 procedure Expand_To_Pointer (N : Node_Id) is
1473 Arg : constant Node_Id := First_Actual (N);
1474
1475 begin
1476 Rewrite (N, Unchecked_Convert_To (Etype (N), Arg));
1477 Analyze (N);
1478 end Expand_To_Pointer;
1479
1480 end Exp_Intr;