1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2001 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 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree; use Atree;
28 with Einfo; use Einfo;
29 with Errout; use Errout;
30 with Exp_Ch4; use Exp_Ch4;
31 with Exp_Ch7; use Exp_Ch7;
32 with Exp_Ch9; use Exp_Ch9;
33 with Exp_Ch11; use Exp_Ch11;
34 with Exp_Code; use Exp_Code;
35 with Exp_Fixd; use Exp_Fixd;
36 with Exp_Util; use Exp_Util;
37 with Itypes; use Itypes;
38 with Namet; use Namet;
39 with Nmake; use Nmake;
40 with Nlists; use Nlists;
41 with Restrict; use Restrict;
42 with Rtsfind; use Rtsfind;
44 with Sem_Eval; use Sem_Eval;
45 with Sem_Res; use Sem_Res;
46 with Sem_Util; use Sem_Util;
47 with Sinfo; use Sinfo;
48 with Sinput; use Sinput;
49 with Snames; use Snames;
50 with Stand; use Stand;
51 with Stringt; use Stringt;
52 with Tbuild; use Tbuild;
53 with Uintp; use Uintp;
54 with Urealp; use Urealp;
56 package body Exp_Intr is
58 -----------------------
59 -- Local Subprograms --
60 -----------------------
62 procedure Expand_Is_Negative (N : Node_Id);
63 -- Expand a call to the intrinsic Is_Negative function
65 procedure Expand_Exception_Call (N : Node_Id; Ent : RE_Id);
66 -- Expand a call to Exception_Information/Message/Name. The first
67 -- parameter, N, is the node for the function call, and Ent is the
68 -- entity for the corresponding routine in the Ada.Exceptions package.
70 procedure Expand_Import_Call (N : Node_Id);
71 -- Expand a call to Import_Address/Longest_Integer/Value. The parameter
72 -- N is the node for the function call.
74 procedure Expand_Shift (N : Node_Id; E : Entity_Id; K : Node_Kind);
75 -- Expand an intrinsic shift operation, N and E are from the call to
76 -- Expand_Instrinsic_Call (call node and subprogram spec entity) and
77 -- K is the kind for the shift node
79 procedure Expand_Unc_Conversion (N : Node_Id; E : Entity_Id);
80 -- Expand a call to an instantiation of Unchecked_Convertion into a node
81 -- N_Unchecked_Type_Conversion.
83 procedure Expand_Unc_Deallocation (N : Node_Id);
84 -- Expand a call to an instantiation of Unchecked_Deallocation into a node
85 -- N_Free_Statement and appropriate context.
87 procedure Expand_Source_Info (N : Node_Id; Nam : Name_Id);
88 -- Rewrite the node by the appropriate string or positive constant.
89 -- Nam can be one of the following:
90 -- Name_File - expand string that is the name of source file
91 -- Name_Line - expand integer line number
92 -- Name_Source_Location - expand string of form file:line
93 -- Name_Enclosing_Entity - expand string with name of enclosing entity
95 ---------------------------
96 -- Expand_Exception_Call --
97 ---------------------------
99 -- If the function call is not within an exception handler, then the
100 -- call is replaced by a null string. Otherwise the appropriate routine
101 -- in Ada.Exceptions is called passing the choice parameter specification
102 -- from the enclosing handler. If the enclosing handler lacks a choice
103 -- parameter, then one is supplied.
105 procedure Expand_Exception_Call (N : Node_Id; Ent : RE_Id) is
106 Loc : constant Source_Ptr := Sloc (N);
112 -- Climb up parents to see if we are in exception handler
116 -- Case of not in exception handler
122 Make_String_Literal (Loc,
126 -- Case of in exception handler
128 elsif Nkind (P) = N_Exception_Handler then
129 if No (Choice_Parameter (P)) then
131 -- If no choice parameter present, then put one there. Note
132 -- that we do not need to put it on the entity chain, since
133 -- no one will be referencing it by normal visibility methods.
135 E := Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
136 Set_Choice_Parameter (P, E);
137 Set_Ekind (E, E_Variable);
138 Set_Etype (E, RTE (RE_Exception_Occurrence));
139 Set_Scope (E, Current_Scope);
143 Make_Function_Call (Loc,
144 Name => New_Occurrence_Of (RTE (Ent), Loc),
145 Parameter_Associations => New_List (
146 New_Occurrence_Of (Choice_Parameter (P), Loc))));
156 Analyze_And_Resolve (N, Standard_String);
157 end Expand_Exception_Call;
159 ------------------------
160 -- Expand_Import_Call --
161 ------------------------
163 -- The function call must have a static string as its argument. We create
164 -- a dummy variable which uses this string as the external name in an
165 -- Import pragma. The result is then obtained as the address of this
166 -- dummy variable, converted to the appropriate target type.
168 procedure Expand_Import_Call (N : Node_Id) is
169 Loc : constant Source_Ptr := Sloc (N);
170 Ent : constant Entity_Id := Entity (Name (N));
171 Str : constant Node_Id := First_Actual (N);
175 Dum := Make_Defining_Identifier (Loc, New_Internal_Name ('D'));
177 Insert_Actions (N, New_List (
178 Make_Object_Declaration (Loc,
179 Defining_Identifier => Dum,
181 New_Occurrence_Of (Standard_Character, Loc)),
184 Chars => Name_Import,
185 Pragma_Argument_Associations => New_List (
186 Make_Pragma_Argument_Association (Loc,
187 Expression => Make_Identifier (Loc, Name_Ada)),
189 Make_Pragma_Argument_Association (Loc,
190 Expression => Make_Identifier (Loc, Chars (Dum))),
192 Make_Pragma_Argument_Association (Loc,
193 Chars => Name_Link_Name,
194 Expression => Relocate_Node (Str))))));
197 Unchecked_Convert_To (Etype (Ent),
198 Make_Attribute_Reference (Loc,
199 Attribute_Name => Name_Address,
200 Prefix => Make_Identifier (Loc, Chars (Dum)))));
202 Analyze_And_Resolve (N, Etype (Ent));
203 end Expand_Import_Call;
205 ---------------------------
206 -- Expand_Intrinsic_Call --
207 ---------------------------
209 procedure Expand_Intrinsic_Call (N : Node_Id; E : Entity_Id) is
213 -- If the intrinsic subprogram is generic, gets its original name.
215 if Present (Parent (E))
216 and then Present (Generic_Parent (Parent (E)))
218 Nam := Chars (Generic_Parent (Parent (E)));
223 if Nam = Name_Asm then
226 elsif Nam = Name_Divide then
227 Expand_Decimal_Divide_Call (N);
229 elsif Nam = Name_Exception_Information then
230 Expand_Exception_Call (N, RE_Exception_Information);
232 elsif Nam = Name_Exception_Message then
233 Expand_Exception_Call (N, RE_Exception_Message);
235 elsif Nam = Name_Exception_Name then
236 Expand_Exception_Call (N, RE_Exception_Name_Simple);
238 elsif Nam = Name_Import_Address
240 Nam = Name_Import_Largest_Value
242 Nam = Name_Import_Value
244 Expand_Import_Call (N);
246 elsif Nam = Name_Is_Negative then
247 Expand_Is_Negative (N);
249 elsif Nam = Name_Rotate_Left then
250 Expand_Shift (N, E, N_Op_Rotate_Left);
252 elsif Nam = Name_Rotate_Right then
253 Expand_Shift (N, E, N_Op_Rotate_Right);
255 elsif Nam = Name_Shift_Left then
256 Expand_Shift (N, E, N_Op_Shift_Left);
258 elsif Nam = Name_Shift_Right then
259 Expand_Shift (N, E, N_Op_Shift_Right);
261 elsif Nam = Name_Shift_Right_Arithmetic then
262 Expand_Shift (N, E, N_Op_Shift_Right_Arithmetic);
264 elsif Nam = Name_Unchecked_Conversion then
265 Expand_Unc_Conversion (N, E);
267 elsif Nam = Name_Unchecked_Deallocation then
268 Expand_Unc_Deallocation (N);
270 elsif Nam = Name_File
271 or else Nam = Name_Line
272 or else Nam = Name_Source_Location
273 or else Nam = Name_Enclosing_Entity
275 Expand_Source_Info (N, Nam);
278 -- Only other possibility is a renaming, in which case we expand
279 -- the call to the original operation (which must be intrinsic).
281 pragma Assert (Present (Alias (E)));
282 Expand_Intrinsic_Call (N, Alias (E));
285 end Expand_Intrinsic_Call;
287 ------------------------
288 -- Expand_Is_Negative --
289 ------------------------
291 procedure Expand_Is_Negative (N : Node_Id) is
292 Loc : constant Source_Ptr := Sloc (N);
293 Opnd : constant Node_Id := Relocate_Node (First_Actual (N));
297 -- We replace the function call by the following expression
299 -- if Opnd < 0.0 then
302 -- if Opnd > 0.0 then
305 -- Float_Unsigned!(Float (Opnd)) /= 0
310 Make_Conditional_Expression (Loc,
311 Expressions => New_List (
313 Left_Opnd => Duplicate_Subexpr (Opnd),
314 Right_Opnd => Make_Real_Literal (Loc, Ureal_0)),
316 New_Occurrence_Of (Standard_True, Loc),
318 Make_Conditional_Expression (Loc,
319 Expressions => New_List (
321 Left_Opnd => Duplicate_Subexpr (Opnd),
322 Right_Opnd => Make_Real_Literal (Loc, Ureal_0)),
324 New_Occurrence_Of (Standard_False, Loc),
328 Unchecked_Convert_To (RTE (RE_Float_Unsigned),
329 Convert_To (Standard_Float,
330 Duplicate_Subexpr (Opnd))),
332 Make_Integer_Literal (Loc, 0)))))));
334 Analyze_And_Resolve (N, Standard_Boolean);
335 end Expand_Is_Negative;
341 -- This procedure is used to convert a call to a shift function to the
342 -- corresponding operator node. This conversion is not done by the usual
343 -- circuit for converting calls to operator functions (e.g. "+"(1,2)) to
344 -- operator nodes, because shifts are not predefined operators.
346 -- As a result, whenever a shift is used in the source program, it will
347 -- remain as a call until converted by this routine to the operator node
348 -- form which Gigi is expecting to see.
350 -- Note: it is possible for the expander to generate shift operator nodes
351 -- directly, which will be analyzed in the normal manner by calling Analyze
352 -- and Resolve. Such shift operator nodes will not be seen by Expand_Shift.
354 procedure Expand_Shift (N : Node_Id; E : Entity_Id; K : Node_Kind) is
355 Loc : constant Source_Ptr := Sloc (N);
356 Typ : constant Entity_Id := Etype (N);
357 Left : constant Node_Id := First_Actual (N);
358 Right : constant Node_Id := Next_Actual (Left);
359 Ltyp : constant Node_Id := Etype (Left);
360 Rtyp : constant Node_Id := Etype (Right);
364 Snode := New_Node (K, Loc);
365 Set_Left_Opnd (Snode, Relocate_Node (Left));
366 Set_Right_Opnd (Snode, Relocate_Node (Right));
367 Set_Chars (Snode, Chars (E));
368 Set_Etype (Snode, Base_Type (Typ));
369 Set_Entity (Snode, E);
371 if Compile_Time_Known_Value (Type_High_Bound (Rtyp))
372 and then Expr_Value (Type_High_Bound (Rtyp)) < Esize (Ltyp)
374 Set_Shift_Count_OK (Snode, True);
377 -- Do the rewrite. Note that we don't call Analyze and Resolve on
378 -- this node, because it already got analyzed and resolved when
379 -- it was a function call!
386 ------------------------
387 -- Expand_Source_Info --
388 ------------------------
390 procedure Expand_Source_Info (N : Node_Id; Nam : Name_Id) is
391 Loc : constant Source_Ptr := Sloc (N);
397 if Nam = Name_Line then
399 Make_Integer_Literal (Loc,
400 Intval => UI_From_Int (Int (Get_Logical_Line_Number (Loc)))));
401 Analyze_And_Resolve (N, Standard_Positive);
408 Get_Decoded_Name_String
409 (Reference_Name (Get_Source_File_Index (Loc)));
411 when Name_Source_Location =>
412 Build_Location_String (Loc);
414 when Name_Enclosing_Entity =>
417 Ent := Current_Scope;
419 -- Skip enclosing blocks to reach enclosing unit.
421 while Present (Ent) loop
422 exit when Ekind (Ent) /= E_Block
423 and then Ekind (Ent) /= E_Loop;
427 -- Ent now points to the relevant defining entity
430 SDef : Source_Ptr := Sloc (Ent);
431 TDef : Source_Buffer_Ptr;
434 TDef := Source_Text (Get_Source_File_Index (SDef));
437 while TDef (SDef) in '0' .. '9'
438 or else TDef (SDef) >= 'A'
439 or else TDef (SDef) = ASCII.ESC
441 Add_Char_To_Name_Buffer (TDef (SDef));
451 Make_String_Literal (Loc, Strval => String_From_Name_Buffer));
452 Analyze_And_Resolve (N, Standard_String);
455 Set_Is_Static_Expression (N);
456 end Expand_Source_Info;
458 ---------------------------
459 -- Expand_Unc_Conversion --
460 ---------------------------
462 procedure Expand_Unc_Conversion (N : Node_Id; E : Entity_Id) is
463 Func : constant Entity_Id := Entity (Name (N));
468 -- Rewrite as unchecked conversion node. Note that we must convert
469 -- the operand to the formal type of the input parameter of the
470 -- function, so that the resulting N_Unchecked_Type_Conversion
471 -- call indicates the correct types for Gigi.
473 -- Right now, we only do this if a scalar type is involved. It is
474 -- not clear if it is needed in other cases. If we do attempt to
475 -- do the conversion unconditionally, it crashes 3411-018. To be
476 -- investigated further ???
478 Conv := Relocate_Node (First_Actual (N));
479 Ftyp := Etype (First_Formal (Func));
481 if Is_Scalar_Type (Ftyp) then
482 Conv := Convert_To (Ftyp, Conv);
483 Set_Parent (Conv, N);
484 Analyze_And_Resolve (Conv);
487 -- We do the analysis here, because we do not want the compiler
488 -- to try to optimize or otherwise reorganize the unchecked
491 Rewrite (N, Unchecked_Convert_To (Etype (E), Conv));
492 Set_Etype (N, Etype (E));
495 if Nkind (N) = N_Unchecked_Type_Conversion then
496 Expand_N_Unchecked_Type_Conversion (N);
498 end Expand_Unc_Conversion;
500 -----------------------------
501 -- Expand_Unc_Deallocation --
502 -----------------------------
504 -- Generate the following Code :
506 -- if Arg /= null then
507 -- <Finalize_Call> (.., T'Class(Arg.all), ..); -- for controlled types
512 -- For a task, we also generate a call to Free_Task to ensure that the
513 -- task itself is freed if it is terminated, ditto for a simple protected
514 -- object, with a call to Finalize_Protection
516 procedure Expand_Unc_Deallocation (N : Node_Id) is
517 Loc : constant Source_Ptr := Sloc (N);
518 Arg : constant Node_Id := First_Actual (N);
519 Typ : constant Entity_Id := Etype (Arg);
520 Stmts : constant List_Id := New_List;
521 Pool : constant Entity_Id :=
522 Associated_Storage_Pool (Underlying_Type (Root_Type (Typ)));
524 Desig_T : Entity_Id := Designated_Type (Typ);
533 if Controlled_Type (Desig_T) then
535 Deref := Make_Explicit_Dereference (Loc, Duplicate_Subexpr (Arg));
537 -- If the type is tagged, then we must force dispatching on the
538 -- finalization call because the designated type may not be the
539 -- actual type of the object
541 if Is_Tagged_Type (Desig_T)
542 and then not Is_Class_Wide_Type (Desig_T)
544 Deref := Unchecked_Convert_To (Class_Wide_Type (Desig_T), Deref);
551 With_Detach => New_Reference_To (Standard_True, Loc));
553 if Abort_Allowed then
554 Prepend_To (Free_Cod,
555 Build_Runtime_Call (Loc, RE_Abort_Defer));
558 Make_Block_Statement (Loc, Handled_Statement_Sequence =>
559 Make_Handled_Sequence_Of_Statements (Loc,
560 Statements => Free_Cod,
562 New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc)));
564 -- We now expand the exception (at end) handler. We set a
565 -- temporary parent pointer since we have not attached Blk
570 Expand_At_End_Handler
571 (Handled_Statement_Sequence (Blk), Entity (Identifier (Blk)));
575 Append_List_To (Stmts, Free_Cod);
579 -- For a task type, call Free_Task before freeing the ATCB.
581 if Is_Task_Type (Desig_T) then
584 Stat : Node_Id := Prev (N);
589 -- An Abort followed by a Free will not do what the user
590 -- expects, because the abort is not immediate. This is worth
591 -- a friendly warning.
594 and then not Comes_From_Source (Original_Node (Stat))
600 and then Nkind (Original_Node (Stat)) = N_Abort_Statement
602 Stat := Original_Node (Stat);
603 Nam1 := First (Names (Stat));
604 Nam2 := Original_Node (First (Parameter_Associations (N)));
606 if Nkind (Nam1) = N_Explicit_Dereference
607 and then Is_Entity_Name (Prefix (Nam1))
608 and then Is_Entity_Name (Nam2)
609 and then Entity (Prefix (Nam1)) = Entity (Nam2)
611 Error_Msg_N ("Abort may take time to complete?", N);
612 Error_Msg_N ("\deallocation might have no effect?", N);
613 Error_Msg_N ("\safer to wait for termination.?", N);
619 Make_Procedure_Call_Statement (Loc,
620 Name => New_Reference_To (RTE (RE_Free_Task), Loc),
621 Parameter_Associations => New_List (
622 Concurrent_Ref (Duplicate_Subexpr (Arg)))));
625 -- For a protected type with no entries, call Finalize_Protection
626 -- before freeing the PO.
628 if Is_Protected_Type (Desig_T) and then not Has_Entries (Desig_T) then
630 Make_Procedure_Call_Statement (Loc,
631 Name => New_Reference_To (RTE (RE_Finalize_Protection), Loc),
632 Parameter_Associations => New_List (
633 Concurrent_Ref (Duplicate_Subexpr (Arg)))));
636 -- Normal processing for non-controlled types
638 Free_Arg := Duplicate_Subexpr (Arg);
639 Free_Node := Make_Free_Statement (Loc, Empty);
640 Append_To (Stmts, Free_Node);
641 Set_Storage_Pool (Free_Node, Pool);
643 -- Make implicit if statement. We omit this if we are the then part
644 -- of a test of the form:
646 -- if not (Arg = null) then
648 -- i.e. if the test is explicit in the source. Arg must be a simple
649 -- identifier for the purposes of this special test. Note that the
650 -- use of /= in the source is always transformed into the above form.
653 Test_Needed : Boolean := True;
654 P : constant Node_Id := Parent (N);
658 if Nkind (Arg) = N_Identifier
659 and then Nkind (P) = N_If_Statement
660 and then First (Then_Statements (P)) = N
662 if Nkind (Condition (P)) = N_Op_Not then
663 C := Right_Opnd (Condition (P));
665 if Nkind (C) = N_Op_Eq
666 and then Nkind (Left_Opnd (C)) = N_Identifier
667 and then Chars (Arg) = Chars (Left_Opnd (C))
668 and then Nkind (Right_Opnd (C)) = N_Null
670 Test_Needed := False;
675 -- Generate If_Statement if needed
679 Make_Implicit_If_Statement (N,
682 Left_Opnd => Duplicate_Subexpr (Arg),
683 Right_Opnd => Make_Null (Loc)),
684 Then_Statements => Stmts);
688 Make_Block_Statement (Loc,
689 Handled_Statement_Sequence =>
690 Make_Handled_Sequence_Of_Statements (Loc,
691 Statements => Stmts));
695 -- Deal with storage pool
697 if Present (Pool) then
699 -- Freeing the secondary stack is meaningless
701 if Is_RTE (Pool, RE_SS_Pool) then
705 Set_Procedure_To_Call (Free_Node,
706 Find_Prim_Op (Etype (Pool), Name_Deallocate));
708 -- If the type is class wide, we generate an implicit type
709 -- with the right dynamic size, so that the deallocate call
710 -- gets the right size parameter computed by gigi
712 if Is_Class_Wide_Type (Desig_T) then
714 Acc_Type : constant Entity_Id :=
715 Create_Itype (E_Access_Type, N);
716 Deref : constant Node_Id :=
717 Make_Explicit_Dereference (Loc,
718 Duplicate_Subexpr (Arg));
721 Set_Etype (Deref, Typ);
722 Set_Parent (Deref, Free_Node);
724 Set_Etype (Acc_Type, Acc_Type);
725 Set_Size_Info (Acc_Type, Typ);
726 Set_Directly_Designated_Type
727 (Acc_Type, Entity (Make_Subtype_From_Expr
730 Free_Arg := Unchecked_Convert_To (Acc_Type, Free_Arg);
736 Set_Expression (Free_Node, Free_Arg);
739 Lhs : Node_Id := Duplicate_Subexpr (Arg);
742 Set_Assignment_OK (Lhs);
744 Make_Assignment_Statement (Loc,
746 Expression => Make_Null (Loc)));
749 Rewrite (N, Gen_Code);
751 end Expand_Unc_Deallocation;