1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
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 Exp_Atag; use Exp_Atag;
32 with Exp_Ch4; use Exp_Ch4;
33 with Exp_Ch7; use Exp_Ch7;
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;
38 with Freeze; use Freeze;
39 with Namet; use Namet;
40 with Nmake; use Nmake;
41 with Nlists; use Nlists;
43 with Restrict; use Restrict;
44 with Rident; use Rident;
45 with Rtsfind; use Rtsfind;
47 with Sem_Eval; use Sem_Eval;
48 with Sem_Res; use Sem_Res;
49 with Sem_Type; use Sem_Type;
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;
60 package body Exp_Intr is
62 -----------------------
63 -- Local Subprograms --
64 -----------------------
66 procedure Expand_Is_Negative (N : Node_Id);
67 -- Expand a call to the intrinsic Is_Negative function
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
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.
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.
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
87 -- Expand_Intrinsic_Call (call node and subprogram spec entity) and
88 -- K is the kind for the shift node
90 procedure Expand_Unc_Conversion (N : Node_Id; E : Entity_Id);
91 -- Expand a call to an instantiation of Unchecked_Conversion into a node
92 -- N_Unchecked_Type_Conversion.
94 procedure Expand_Unc_Deallocation (N : Node_Id);
95 -- Expand a call to an instantiation of Unchecked_Deallocation into a node
96 -- N_Free_Statement and appropriate context.
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
101 -- System.Address_To_Access_Conversions.
103 procedure Expand_Source_Info (N : Node_Id; Nam : Name_Id);
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
111 -----------------------------------------
112 -- Expand_Dispatching_Constructor_Call --
113 -----------------------------------------
115 -- Transform a call to an instantiation of Generic_Dispatching_Constructor
118 -- GDC_Instance (The_Tag, Parameters'Access)
120 -- to a class-wide conversion of a dispatching call to the actual
121 -- associated with the formal subprogram Construct, designating The_Tag
122 -- as the controlling tag of the call:
124 -- T'Class (Construct'Actual (Params)) -- Controlling tag is The_Tag
126 -- which will eventually be expanded to the following:
128 -- T'Class (The_Tag.all (Construct'Actual'Index).all (Params))
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.
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);
139 Act_Rename : Node_Id;
140 Act_Constr : Entity_Id;
141 Iface_Tag : Node_Id := Empty;
142 Cnstr_Call : Node_Id;
143 Result_Typ : Entity_Id;
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.
151 Act_Rename := First (Visible_Declarations (Inst_Pkg));
152 while Nkind (Act_Rename) /= N_Subprogram_Renaming_Declaration loop
156 Act_Constr := Entity (Name (Act_Rename));
157 Result_Typ := Class_Wide_Type (Etype (Act_Constr));
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!)
163 if Is_Interface (Etype (Act_Constr)) then
164 Set_Etype (Act_Constr, Result_Typ);
166 -- If the result type is not parent of Tag_Arg then we need to
167 -- locate the tag of the secondary dispatch table.
169 if not Is_Ancestor (Etype (Result_Typ), Etype (Tag_Arg)) then
170 pragma Assert (not Is_Interface (Etype (Tag_Arg)));
173 Make_Object_Declaration (Loc,
174 Defining_Identifier => Make_Temporary (Loc, 'V'),
176 New_Reference_To (RTE (RE_Tag), Loc),
178 Make_Function_Call (Loc,
179 Name => New_Reference_To (RTE (RE_Secondary_Tag), Loc),
180 Parameter_Associations => New_List (
181 Relocate_Node (Tag_Arg),
183 (Node (First_Elmt (Access_Disp_Table
184 (Etype (Etype (Act_Constr))))),
186 Insert_Action (N, Iface_Tag);
190 -- Create the call to the actual Constructor function
193 Make_Function_Call (Loc,
194 Name => New_Occurrence_Of (Act_Constr, Loc),
195 Parameter_Associations => New_List (Relocate_Node (Param_Arg)));
197 -- Establish its controlling tag from the tag passed to the instance
198 -- The tag may be given by a function call, in which case a temporary
199 -- should be generated now, to prevent out-of-order insertions during
200 -- the expansion of that call when stack-checking is enabled.
202 if Present (Iface_Tag) then
203 Set_Controlling_Argument (Cnstr_Call,
204 New_Occurrence_Of (Defining_Identifier (Iface_Tag), Loc));
206 Remove_Side_Effects (Tag_Arg);
207 Set_Controlling_Argument (Cnstr_Call,
208 Relocate_Node (Tag_Arg));
211 -- Rewrite and analyze the call to the instance as a class-wide
212 -- conversion of the call to the actual constructor.
214 Rewrite (N, Convert_To (Result_Typ, Cnstr_Call));
215 Analyze_And_Resolve (N, Etype (Act_Constr));
217 -- Do not generate a run-time check on the built object if tag
218 -- checks are suppressed for the result type or VM_Target /= No_VM
220 if Tag_Checks_Suppressed (Etype (Result_Typ))
221 or else not Tagged_Type_Expansion
225 -- Generate a class-wide membership test to ensure that the call's tag
226 -- argument denotes a type within the class. We must keep separate the
227 -- case in which the Result_Type of the constructor function is a tagged
228 -- type from the case in which it is an abstract interface because the
229 -- run-time subprogram required to check these cases differ (and have
230 -- one difference in their parameters profile).
232 -- Call CW_Membership if the Result_Type is a tagged type to look for
233 -- the tag in the table of ancestor tags.
235 elsif not Is_Interface (Result_Typ) then
237 Obj_Tag_Node : Node_Id := Duplicate_Subexpr (Tag_Arg);
238 CW_Test_Node : Node_Id;
241 Build_CW_Membership (Loc,
242 Obj_Tag_Node => Obj_Tag_Node,
245 Node (First_Elmt (Access_Disp_Table (
246 Root_Type (Result_Typ)))), Loc),
248 New_Node => CW_Test_Node);
251 Make_Implicit_If_Statement (N,
253 Make_Op_Not (Loc, CW_Test_Node),
255 New_List (Make_Raise_Statement (Loc,
256 New_Occurrence_Of (RTE (RE_Tag_Error), Loc)))));
259 -- Call IW_Membership test if the Result_Type is an abstract interface
260 -- to look for the tag in the table of interface tags.
264 Make_Implicit_If_Statement (N,
267 Make_Function_Call (Loc,
268 Name => New_Occurrence_Of (RTE (RE_IW_Membership), Loc),
269 Parameter_Associations => New_List (
270 Make_Attribute_Reference (Loc,
271 Prefix => Duplicate_Subexpr (Tag_Arg),
272 Attribute_Name => Name_Address),
275 Node (First_Elmt (Access_Disp_Table (
276 Root_Type (Result_Typ)))), Loc)))),
279 Make_Raise_Statement (Loc,
280 Name => New_Occurrence_Of (RTE (RE_Tag_Error), Loc)))));
282 end Expand_Dispatching_Constructor_Call;
284 ---------------------------
285 -- Expand_Exception_Call --
286 ---------------------------
288 -- If the function call is not within an exception handler, then the call
289 -- is replaced by a null string. Otherwise the appropriate routine in
290 -- Ada.Exceptions is called passing the choice parameter specification
291 -- from the enclosing handler. If the enclosing handler lacks a choice
292 -- parameter, then one is supplied.
294 procedure Expand_Exception_Call (N : Node_Id; Ent : RE_Id) is
295 Loc : constant Source_Ptr := Sloc (N);
300 -- Climb up parents to see if we are in exception handler
304 -- Case of not in exception handler, replace by null string
308 Make_String_Literal (Loc,
312 -- Case of in exception handler
314 elsif Nkind (P) = N_Exception_Handler then
316 -- Handler cannot be used for a local raise, and furthermore, this
317 -- is a violation of the No_Exception_Propagation restriction.
319 Set_Local_Raise_Not_OK (P);
320 Check_Restriction (No_Exception_Propagation, N);
322 -- If no choice parameter present, then put one there. Note that
323 -- we do not need to put it on the entity chain, since no one will
324 -- be referencing it by normal visibility methods.
326 if No (Choice_Parameter (P)) then
327 E := Make_Temporary (Loc, 'E');
328 Set_Choice_Parameter (P, E);
329 Set_Ekind (E, E_Variable);
330 Set_Etype (E, RTE (RE_Exception_Occurrence));
331 Set_Scope (E, Current_Scope);
335 Make_Function_Call (Loc,
336 Name => New_Occurrence_Of (RTE (Ent), Loc),
337 Parameter_Associations => New_List (
338 New_Occurrence_Of (Choice_Parameter (P), Loc))));
348 Analyze_And_Resolve (N, Standard_String);
349 end Expand_Exception_Call;
351 ------------------------
352 -- Expand_Import_Call --
353 ------------------------
355 -- The function call must have a static string as its argument. We create
356 -- a dummy variable which uses this string as the external name in an
357 -- Import pragma. The result is then obtained as the address of this
358 -- dummy variable, converted to the appropriate target type.
360 procedure Expand_Import_Call (N : Node_Id) is
361 Loc : constant Source_Ptr := Sloc (N);
362 Ent : constant Entity_Id := Entity (Name (N));
363 Str : constant Node_Id := First_Actual (N);
364 Dum : constant Entity_Id := Make_Temporary (Loc, 'D');
367 Insert_Actions (N, New_List (
368 Make_Object_Declaration (Loc,
369 Defining_Identifier => Dum,
371 New_Occurrence_Of (Standard_Character, Loc)),
374 Chars => Name_Import,
375 Pragma_Argument_Associations => New_List (
376 Make_Pragma_Argument_Association (Loc,
377 Expression => Make_Identifier (Loc, Name_Ada)),
379 Make_Pragma_Argument_Association (Loc,
380 Expression => Make_Identifier (Loc, Chars (Dum))),
382 Make_Pragma_Argument_Association (Loc,
383 Chars => Name_Link_Name,
384 Expression => Relocate_Node (Str))))));
387 Unchecked_Convert_To (Etype (Ent),
388 Make_Attribute_Reference (Loc,
389 Prefix => Make_Identifier (Loc, Chars (Dum)),
390 Attribute_Name => Name_Address)));
392 Analyze_And_Resolve (N, Etype (Ent));
393 end Expand_Import_Call;
395 ---------------------------
396 -- Expand_Intrinsic_Call --
397 ---------------------------
399 procedure Expand_Intrinsic_Call (N : Node_Id; E : Entity_Id) is
403 -- If an external name is specified for the intrinsic, it is handled
404 -- by the back-end: leave the call node unchanged for now.
406 if Present (Interface_Name (E)) then
410 -- If the intrinsic subprogram is generic, gets its original name
412 if Present (Parent (E))
413 and then Present (Generic_Parent (Parent (E)))
415 Nam := Chars (Generic_Parent (Parent (E)));
420 if Nam = Name_Asm then
423 elsif Nam = Name_Divide then
424 Expand_Decimal_Divide_Call (N);
426 elsif Nam = Name_Exception_Information then
427 Expand_Exception_Call (N, RE_Exception_Information);
429 elsif Nam = Name_Exception_Message then
430 Expand_Exception_Call (N, RE_Exception_Message);
432 elsif Nam = Name_Exception_Name then
433 Expand_Exception_Call (N, RE_Exception_Name_Simple);
435 elsif Nam = Name_Generic_Dispatching_Constructor then
436 Expand_Dispatching_Constructor_Call (N);
438 elsif Nam = Name_Import_Address
440 Nam = Name_Import_Largest_Value
442 Nam = Name_Import_Value
444 Expand_Import_Call (N);
446 elsif Nam = Name_Is_Negative then
447 Expand_Is_Negative (N);
449 elsif Nam = Name_Rotate_Left then
450 Expand_Shift (N, E, N_Op_Rotate_Left);
452 elsif Nam = Name_Rotate_Right then
453 Expand_Shift (N, E, N_Op_Rotate_Right);
455 elsif Nam = Name_Shift_Left then
456 Expand_Shift (N, E, N_Op_Shift_Left);
458 elsif Nam = Name_Shift_Right then
459 Expand_Shift (N, E, N_Op_Shift_Right);
461 elsif Nam = Name_Shift_Right_Arithmetic then
462 Expand_Shift (N, E, N_Op_Shift_Right_Arithmetic);
464 elsif Nam = Name_Unchecked_Conversion then
465 Expand_Unc_Conversion (N, E);
467 elsif Nam = Name_Unchecked_Deallocation then
468 Expand_Unc_Deallocation (N);
470 elsif Nam = Name_To_Address then
471 Expand_To_Address (N);
473 elsif Nam = Name_To_Pointer then
474 Expand_To_Pointer (N);
476 elsif Nam = Name_File
477 or else Nam = Name_Line
478 or else Nam = Name_Source_Location
479 or else Nam = Name_Enclosing_Entity
481 Expand_Source_Info (N, Nam);
483 -- If we have a renaming, expand the call to the original operation,
484 -- which must itself be intrinsic, since renaming requires matching
485 -- conventions and this has already been checked.
487 elsif Present (Alias (E)) then
488 Expand_Intrinsic_Call (N, Alias (E));
490 -- The only other case is where an external name was specified,
491 -- since this is the only way that an otherwise unrecognized
492 -- name could escape the checking in Sem_Prag. Nothing needs
493 -- to be done in such a case, since we pass such a call to the
494 -- back end unchanged.
499 end Expand_Intrinsic_Call;
501 ------------------------
502 -- Expand_Is_Negative --
503 ------------------------
505 procedure Expand_Is_Negative (N : Node_Id) is
506 Loc : constant Source_Ptr := Sloc (N);
507 Opnd : constant Node_Id := Relocate_Node (First_Actual (N));
511 -- We replace the function call by the following expression
513 -- if Opnd < 0.0 then
516 -- if Opnd > 0.0 then
519 -- Float_Unsigned!(Float (Opnd)) /= 0
524 Make_Conditional_Expression (Loc,
525 Expressions => New_List (
527 Left_Opnd => Duplicate_Subexpr (Opnd),
528 Right_Opnd => Make_Real_Literal (Loc, Ureal_0)),
530 New_Occurrence_Of (Standard_True, Loc),
532 Make_Conditional_Expression (Loc,
533 Expressions => New_List (
535 Left_Opnd => Duplicate_Subexpr_No_Checks (Opnd),
536 Right_Opnd => Make_Real_Literal (Loc, Ureal_0)),
538 New_Occurrence_Of (Standard_False, Loc),
543 (RTE (RE_Float_Unsigned),
546 Duplicate_Subexpr_No_Checks (Opnd))),
548 Make_Integer_Literal (Loc, 0)))))));
550 Analyze_And_Resolve (N, Standard_Boolean);
551 end Expand_Is_Negative;
557 -- This procedure is used to convert a call to a shift function to the
558 -- corresponding operator node. This conversion is not done by the usual
559 -- circuit for converting calls to operator functions (e.g. "+"(1,2)) to
560 -- operator nodes, because shifts are not predefined operators.
562 -- As a result, whenever a shift is used in the source program, it will
563 -- remain as a call until converted by this routine to the operator node
564 -- form which Gigi is expecting to see.
566 -- Note: it is possible for the expander to generate shift operator nodes
567 -- directly, which will be analyzed in the normal manner by calling Analyze
568 -- and Resolve. Such shift operator nodes will not be seen by Expand_Shift.
570 procedure Expand_Shift (N : Node_Id; E : Entity_Id; K : Node_Kind) is
571 Loc : constant Source_Ptr := Sloc (N);
572 Typ : constant Entity_Id := Etype (N);
573 Left : constant Node_Id := First_Actual (N);
574 Right : constant Node_Id := Next_Actual (Left);
575 Ltyp : constant Node_Id := Etype (Left);
576 Rtyp : constant Node_Id := Etype (Right);
580 Snode := New_Node (K, Loc);
581 Set_Left_Opnd (Snode, Relocate_Node (Left));
582 Set_Right_Opnd (Snode, Relocate_Node (Right));
583 Set_Chars (Snode, Chars (E));
584 Set_Etype (Snode, Base_Type (Typ));
585 Set_Entity (Snode, E);
587 if Compile_Time_Known_Value (Type_High_Bound (Rtyp))
588 and then Expr_Value (Type_High_Bound (Rtyp)) < Esize (Ltyp)
590 Set_Shift_Count_OK (Snode, True);
593 -- Do the rewrite. Note that we don't call Analyze and Resolve on
594 -- this node, because it already got analyzed and resolved when
595 -- it was a function call!
601 ------------------------
602 -- Expand_Source_Info --
603 ------------------------
605 procedure Expand_Source_Info (N : Node_Id; Nam : Name_Id) is
606 Loc : constant Source_Ptr := Sloc (N);
609 procedure Write_Entity_Name (E : Entity_Id);
610 -- Recursive procedure to construct string for qualified name of
611 -- enclosing program unit. The qualification stops at an enclosing
612 -- scope has no source name (block or loop). If entity is a subprogram
613 -- instance, skip enclosing wrapper package.
615 -----------------------
616 -- Write_Entity_Name --
617 -----------------------
619 procedure Write_Entity_Name (E : Entity_Id) is
621 TDef : constant Source_Buffer_Ptr :=
622 Source_Text (Get_Source_File_Index (Sloc (E)));
625 -- Nothing to do if at outer level
627 if Scope (E) = Standard_Standard then
630 -- If scope comes from source, write its name
632 elsif Comes_From_Source (Scope (E)) then
633 Write_Entity_Name (Scope (E));
634 Add_Char_To_Name_Buffer ('.');
636 -- If in wrapper package skip past it
638 elsif Is_Wrapper_Package (Scope (E)) then
639 Write_Entity_Name (Scope (Scope (E)));
640 Add_Char_To_Name_Buffer ('.');
642 -- Otherwise nothing to output (happens in unnamed block statements)
648 -- Loop to output the name
650 -- is this right wrt wide char encodings ??? (no!)
653 while TDef (SDef) in '0' .. '9'
654 or else TDef (SDef) >= 'A'
655 or else TDef (SDef) = ASCII.ESC
657 Add_Char_To_Name_Buffer (TDef (SDef));
660 end Write_Entity_Name;
662 -- Start of processing for Expand_Source_Info
667 if Nam = Name_Line then
669 Make_Integer_Literal (Loc,
670 Intval => UI_From_Int (Int (Get_Logical_Line_Number (Loc)))));
671 Analyze_And_Resolve (N, Standard_Positive);
680 Get_Decoded_Name_String
681 (Reference_Name (Get_Source_File_Index (Loc)));
683 when Name_Source_Location =>
684 Build_Location_String (Loc);
686 when Name_Enclosing_Entity =>
688 -- Skip enclosing blocks to reach enclosing unit
690 Ent := Current_Scope;
691 while Present (Ent) loop
692 exit when Ekind (Ent) /= E_Block
693 and then Ekind (Ent) /= E_Loop;
697 -- Ent now points to the relevant defining entity
699 Write_Entity_Name (Ent);
706 Make_String_Literal (Loc,
707 Strval => String_From_Name_Buffer));
708 Analyze_And_Resolve (N, Standard_String);
711 Set_Is_Static_Expression (N);
712 end Expand_Source_Info;
714 ---------------------------
715 -- Expand_Unc_Conversion --
716 ---------------------------
718 procedure Expand_Unc_Conversion (N : Node_Id; E : Entity_Id) is
719 Func : constant Entity_Id := Entity (Name (N));
725 -- Rewrite as unchecked conversion node. Note that we must convert
726 -- the operand to the formal type of the input parameter of the
727 -- function, so that the resulting N_Unchecked_Type_Conversion
728 -- call indicates the correct types for Gigi.
730 -- Right now, we only do this if a scalar type is involved. It is
731 -- not clear if it is needed in other cases. If we do attempt to
732 -- do the conversion unconditionally, it crashes 3411-018. To be
733 -- investigated further ???
735 Conv := Relocate_Node (First_Actual (N));
736 Ftyp := Etype (First_Formal (Func));
738 if Is_Scalar_Type (Ftyp) then
739 Conv := Convert_To (Ftyp, Conv);
740 Set_Parent (Conv, N);
741 Analyze_And_Resolve (Conv);
744 -- The instantiation of Unchecked_Conversion creates a wrapper package,
745 -- and the target type is declared as a subtype of the actual. Recover
746 -- the actual, which is the subtype indic. in the subtype declaration
747 -- for the target type. This is semantically correct, and avoids
748 -- anomalies with access subtypes. For entities, leave type as is.
750 -- We do the analysis here, because we do not want the compiler
751 -- to try to optimize or otherwise reorganize the unchecked
756 if Is_Entity_Name (Conv) then
759 elsif Nkind (Parent (Ttyp)) = N_Subtype_Declaration then
760 Ttyp := Entity (Subtype_Indication (Parent (Etype (E))));
762 elsif Is_Itype (Ttyp) then
764 Entity (Subtype_Indication (Associated_Node_For_Itype (Ttyp)));
769 Rewrite (N, Unchecked_Convert_To (Ttyp, Conv));
773 if Nkind (N) = N_Unchecked_Type_Conversion then
774 Expand_N_Unchecked_Type_Conversion (N);
776 end Expand_Unc_Conversion;
778 -----------------------------
779 -- Expand_Unc_Deallocation --
780 -----------------------------
782 -- Generate the following Code :
784 -- if Arg /= null then
785 -- <Finalize_Call> (.., T'Class(Arg.all), ..); -- for controlled types
790 -- For a task, we also generate a call to Free_Task to ensure that the
791 -- task itself is freed if it is terminated, ditto for a simple protected
792 -- object, with a call to Finalize_Protection. For composite types that
793 -- have tasks or simple protected objects as components, we traverse the
794 -- structures to find and terminate those components.
796 procedure Expand_Unc_Deallocation (N : Node_Id) is
797 Loc : constant Source_Ptr := Sloc (N);
798 Arg : constant Node_Id := First_Actual (N);
799 Typ : constant Entity_Id := Etype (Arg);
800 Stmts : constant List_Id := New_List;
801 Rtyp : constant Entity_Id := Underlying_Type (Root_Type (Typ));
802 Pool : constant Entity_Id := Associated_Storage_Pool (Rtyp);
804 Desig_T : constant Entity_Id := Designated_Type (Typ);
812 Arg_Known_Non_Null : constant Boolean := Known_Non_Null (N);
813 -- This captures whether we know the argument to be non-null so that
814 -- we can avoid the test. The reason that we need to capture this is
815 -- that we analyze some generated statements before properly attaching
816 -- them to the tree, and that can disturb current value settings.
819 if No_Pool_Assigned (Rtyp) then
820 Error_Msg_N ("?deallocation from empty storage pool!", N);
823 -- Nothing to do if we know the argument is null
825 if Known_Null (N) then
829 -- Processing for pointer to controlled type
831 if Needs_Finalization (Desig_T) then
833 Make_Explicit_Dereference (Loc,
834 Prefix => Duplicate_Subexpr_No_Checks (Arg));
836 -- If the type is tagged, then we must force dispatching on the
837 -- finalization call because the designated type may not be the
838 -- actual type of the object.
840 if Is_Tagged_Type (Desig_T)
841 and then not Is_Class_Wide_Type (Desig_T)
843 Deref := Unchecked_Convert_To (Class_Wide_Type (Desig_T), Deref);
845 elsif not Is_Tagged_Type (Desig_T) then
847 -- Set type of result, to force a conversion when needed (see
848 -- exp_ch7, Convert_View), given that Deep_Finalize may be
849 -- inherited from the parent type, and we need the type of the
850 -- expression to see whether the conversion is in fact needed.
852 Set_Etype (Deref, Desig_T);
859 With_Detach => New_Reference_To (Standard_True, Loc));
861 if Abort_Allowed then
862 Prepend_To (Free_Cod,
863 Build_Runtime_Call (Loc, RE_Abort_Defer));
866 Make_Block_Statement (Loc, Handled_Statement_Sequence =>
867 Make_Handled_Sequence_Of_Statements (Loc,
868 Statements => Free_Cod,
870 New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc)));
872 -- We now expand the exception (at end) handler. We set a
873 -- temporary parent pointer since we have not attached Blk
878 Expand_At_End_Handler
879 (Handled_Statement_Sequence (Blk), Entity (Identifier (Blk)));
882 -- We kill saved current values, since analyzing statements not
883 -- properly attached to the tree can set wrong current values.
888 Append_List_To (Stmts, Free_Cod);
892 -- For a task type, call Free_Task before freeing the ATCB
894 if Is_Task_Type (Desig_T) then
896 Stat : Node_Id := Prev (N);
901 -- An Abort followed by a Free will not do what the user
902 -- expects, because the abort is not immediate. This is
903 -- worth a friendly warning.
906 and then not Comes_From_Source (Original_Node (Stat))
912 and then Nkind (Original_Node (Stat)) = N_Abort_Statement
914 Stat := Original_Node (Stat);
915 Nam1 := First (Names (Stat));
916 Nam2 := Original_Node (First (Parameter_Associations (N)));
918 if Nkind (Nam1) = N_Explicit_Dereference
919 and then Is_Entity_Name (Prefix (Nam1))
920 and then Is_Entity_Name (Nam2)
921 and then Entity (Prefix (Nam1)) = Entity (Nam2)
923 Error_Msg_N ("abort may take time to complete?", N);
924 Error_Msg_N ("\deallocation might have no effect?", N);
925 Error_Msg_N ("\safer to wait for termination.?", N);
931 (Stmts, Cleanup_Task (N, Duplicate_Subexpr_No_Checks (Arg)));
933 -- For composite types that contain tasks, recurse over the structure
934 -- to build the selectors for the task subcomponents.
936 elsif Has_Task (Desig_T) then
937 if Is_Record_Type (Desig_T) then
938 Append_List_To (Stmts, Cleanup_Record (N, Arg, Desig_T));
940 elsif Is_Array_Type (Desig_T) then
941 Append_List_To (Stmts, Cleanup_Array (N, Arg, Desig_T));
945 -- Same for simple protected types. Eventually call Finalize_Protection
946 -- before freeing the PO for each protected component.
948 if Is_Simple_Protected_Type (Desig_T) then
950 Cleanup_Protected_Object (N, Duplicate_Subexpr_No_Checks (Arg)));
952 elsif Has_Simple_Protected_Object (Desig_T) then
953 if Is_Record_Type (Desig_T) then
954 Append_List_To (Stmts, Cleanup_Record (N, Arg, Desig_T));
955 elsif Is_Array_Type (Desig_T) then
956 Append_List_To (Stmts, Cleanup_Array (N, Arg, Desig_T));
960 -- Normal processing for non-controlled types
962 Free_Arg := Duplicate_Subexpr_No_Checks (Arg);
963 Free_Node := Make_Free_Statement (Loc, Empty);
964 Append_To (Stmts, Free_Node);
965 Set_Storage_Pool (Free_Node, Pool);
967 -- Deal with storage pool
969 if Present (Pool) then
971 -- Freeing the secondary stack is meaningless
973 if Is_RTE (Pool, RE_SS_Pool) then
976 elsif Is_Class_Wide_Type (Etype (Pool)) then
978 -- Case of a class-wide pool type: make a dispatching call
979 -- to Deallocate through the class-wide Deallocate_Any.
981 Set_Procedure_To_Call (Free_Node,
982 RTE (RE_Deallocate_Any));
985 -- Case of a specific pool type: make a statically bound call
987 Set_Procedure_To_Call (Free_Node,
988 Find_Prim_Op (Etype (Pool), Name_Deallocate));
992 if Present (Procedure_To_Call (Free_Node)) then
994 -- For all cases of a Deallocate call, the back-end needs to be
995 -- able to compute the size of the object being freed. This may
996 -- require some adjustments for objects of dynamic size.
998 -- If the type is class wide, we generate an implicit type with the
999 -- right dynamic size, so that the deallocate call gets the right
1000 -- size parameter computed by GIGI. Same for an access to
1001 -- unconstrained packed array.
1003 if Is_Class_Wide_Type (Desig_T)
1005 (Is_Array_Type (Desig_T)
1006 and then not Is_Constrained (Desig_T)
1007 and then Is_Packed (Desig_T))
1010 Deref : constant Node_Id :=
1011 Make_Explicit_Dereference (Loc,
1012 Duplicate_Subexpr_No_Checks (Arg));
1017 Set_Etype (Deref, Typ);
1018 Set_Parent (Deref, Free_Node);
1019 D_Subtyp := Make_Subtype_From_Expr (Deref, Desig_T);
1021 if Nkind (D_Subtyp) in N_Has_Entity then
1022 D_Type := Entity (D_Subtyp);
1025 D_Type := Make_Temporary (Loc, 'A');
1026 Insert_Action (Deref,
1027 Make_Subtype_Declaration (Loc,
1028 Defining_Identifier => D_Type,
1029 Subtype_Indication => D_Subtyp));
1032 -- Force freezing at the point of the dereference. For the
1033 -- class wide case, this avoids having the subtype frozen
1034 -- before the equivalent type.
1036 Freeze_Itype (D_Type, Deref);
1038 Set_Actual_Designated_Subtype (Free_Node, D_Type);
1044 -- Ada 2005 (AI-251): In case of abstract interface type we must
1045 -- displace the pointer to reference the base of the object to
1046 -- deallocate its memory, unless we're targetting a VM, in which case
1047 -- no special processing is required.
1050 -- free (Base_Address (Obj_Ptr))
1052 if Is_Interface (Directly_Designated_Type (Typ))
1053 and then Tagged_Type_Expansion
1055 Set_Expression (Free_Node,
1056 Unchecked_Convert_To (Typ,
1057 Make_Function_Call (Loc,
1058 Name => New_Reference_To (RTE (RE_Base_Address), Loc),
1059 Parameter_Associations => New_List (
1060 Unchecked_Convert_To (RTE (RE_Address), Free_Arg)))));
1066 Set_Expression (Free_Node, Free_Arg);
1069 -- Only remaining step is to set result to null, or generate a
1070 -- raise of constraint error if the target object is "not null".
1072 if Can_Never_Be_Null (Etype (Arg)) then
1074 Make_Raise_Constraint_Error (Loc,
1075 Reason => CE_Access_Check_Failed));
1079 Lhs : constant Node_Id := Duplicate_Subexpr_No_Checks (Arg);
1081 Set_Assignment_OK (Lhs);
1083 Make_Assignment_Statement (Loc,
1085 Expression => Make_Null (Loc)));
1089 -- If we know the argument is non-null, then make a block statement
1090 -- that contains the required statements, no need for a test.
1092 if Arg_Known_Non_Null then
1094 Make_Block_Statement (Loc,
1095 Handled_Statement_Sequence =>
1096 Make_Handled_Sequence_Of_Statements (Loc,
1097 Statements => Stmts));
1099 -- If the argument may be null, wrap the statements inside an IF that
1100 -- does an explicit test to exclude the null case.
1104 Make_Implicit_If_Statement (N,
1107 Left_Opnd => Duplicate_Subexpr (Arg),
1108 Right_Opnd => Make_Null (Loc)),
1109 Then_Statements => Stmts);
1114 Rewrite (N, Gen_Code);
1116 end Expand_Unc_Deallocation;
1118 -----------------------
1119 -- Expand_To_Address --
1120 -----------------------
1122 procedure Expand_To_Address (N : Node_Id) is
1123 Loc : constant Source_Ptr := Sloc (N);
1124 Arg : constant Node_Id := First_Actual (N);
1128 Remove_Side_Effects (Arg);
1130 Obj := Make_Explicit_Dereference (Loc, Relocate_Node (Arg));
1133 Make_Conditional_Expression (Loc,
1134 Expressions => New_List (
1136 Left_Opnd => New_Copy_Tree (Arg),
1137 Right_Opnd => Make_Null (Loc)),
1138 New_Occurrence_Of (RTE (RE_Null_Address), Loc),
1139 Make_Attribute_Reference (Loc,
1141 Attribute_Name => Name_Address))));
1143 Analyze_And_Resolve (N, RTE (RE_Address));
1144 end Expand_To_Address;
1146 -----------------------
1147 -- Expand_To_Pointer --
1148 -----------------------
1150 procedure Expand_To_Pointer (N : Node_Id) is
1151 Arg : constant Node_Id := First_Actual (N);
1154 Rewrite (N, Unchecked_Convert_To (Etype (N), Arg));
1156 end Expand_To_Pointer;