X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Fada%2Fexp_intr.adb;h=da6cf5a988c8ad4d41af9b60dab678964bb7ae07;hb=17052c8f8f63239deccec6d06ff1d9a9ebfc4640;hp=f688909064529bf7a49bc3c5b1da4dfaabc72611;hpb=9dfe12ae5b94d03c997ea2903022a5d2d5c5f266;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index f6889090645..da6cf5a988c 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -6,18 +6,17 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING. If not, write -- --- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, USA. -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- @@ -25,23 +24,29 @@ ------------------------------------------------------------------------------ with Atree; use Atree; +with Checks; use Checks; with Einfo; use Einfo; +with Elists; use Elists; with Errout; use Errout; +with Exp_Atag; use Exp_Atag; with Exp_Ch4; use Exp_Ch4; with Exp_Ch7; use Exp_Ch7; with Exp_Ch11; use Exp_Ch11; with Exp_Code; use Exp_Code; with Exp_Fixd; use Exp_Fixd; with Exp_Util; use Exp_Util; -with Itypes; use Itypes; +with Freeze; use Freeze; with Namet; use Namet; with Nmake; use Nmake; with Nlists; use Nlists; +with Opt; use Opt; with Restrict; use Restrict; +with Rident; use Rident; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; +with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Sinput; use Sinput; @@ -61,6 +66,13 @@ package body Exp_Intr is procedure Expand_Is_Negative (N : Node_Id); -- Expand a call to the intrinsic Is_Negative function + procedure Expand_Dispatching_Constructor_Call (N : Node_Id); + -- Expand a call to an instantiation of Generic_Dispatching_Constructor + -- into a dispatching call to the actual subprogram associated with the + -- Constructor formal subprogram, passing it the Parameters actual of + -- the call to the instantiation and dispatching based on call's Tag + -- parameter. + procedure Expand_Exception_Call (N : Node_Id; Ent : RE_Id); -- Expand a call to Exception_Information/Message/Name. The first -- parameter, N, is the node for the function call, and Ent is the @@ -72,11 +84,11 @@ package body Exp_Intr is procedure Expand_Shift (N : Node_Id; E : Entity_Id; K : Node_Kind); -- Expand an intrinsic shift operation, N and E are from the call to - -- Expand_Instrinsic_Call (call node and subprogram spec entity) and + -- Expand_Intrinsic_Call (call node and subprogram spec entity) and -- K is the kind for the shift node procedure Expand_Unc_Conversion (N : Node_Id; E : Entity_Id); - -- Expand a call to an instantiation of Unchecked_Convertion into a node + -- Expand a call to an instantiation of Unchecked_Conversion into a node -- N_Unchecked_Type_Conversion. procedure Expand_Unc_Deallocation (N : Node_Id); @@ -86,7 +98,7 @@ package body Exp_Intr is procedure Expand_To_Address (N : Node_Id); procedure Expand_To_Pointer (N : Node_Id); -- Expand a call to corresponding function, declared in an instance of - -- System.Addess_To_Access_Conversions. + -- System.Address_To_Access_Conversions. procedure Expand_Source_Info (N : Node_Id; Nam : Name_Id); -- Rewrite the node by the appropriate string or positive constant. @@ -96,13 +108,187 @@ package body Exp_Intr is -- Name_Source_Location - expand string of form file:line -- Name_Enclosing_Entity - expand string with name of enclosing entity + ----------------------------------------- + -- Expand_Dispatching_Constructor_Call -- + ----------------------------------------- + + -- Transform a call to an instantiation of Generic_Dispatching_Constructor + -- of the form: + + -- GDC_Instance (The_Tag, Parameters'Access) + + -- to a class-wide conversion of a dispatching call to the actual + -- associated with the formal subprogram Construct, designating The_Tag + -- as the controlling tag of the call: + + -- T'Class (Construct'Actual (Params)) -- Controlling tag is The_Tag + + -- which will eventually be expanded to the following: + + -- T'Class (The_Tag.all (Construct'Actual'Index).all (Params)) + + -- A class-wide membership test is also generated, preceding the call, to + -- ensure that the controlling tag denotes a type in T'Class. + + procedure Expand_Dispatching_Constructor_Call (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Tag_Arg : constant Node_Id := First_Actual (N); + Param_Arg : constant Node_Id := Next_Actual (Tag_Arg); + Subp_Decl : constant Node_Id := Parent (Parent (Entity (Name (N)))); + Inst_Pkg : constant Node_Id := Parent (Subp_Decl); + Act_Rename : Node_Id; + Act_Constr : Entity_Id; + Iface_Tag : Node_Id := Empty; + Cnstr_Call : Node_Id; + Result_Typ : Entity_Id; + + begin + -- The subprogram is the third actual in the instantiation, and is + -- retrieved from the corresponding renaming declaration. However, + -- freeze nodes may appear before, so we retrieve the declaration + -- with an explicit loop. + + Act_Rename := First (Visible_Declarations (Inst_Pkg)); + while Nkind (Act_Rename) /= N_Subprogram_Renaming_Declaration loop + Next (Act_Rename); + end loop; + + Act_Constr := Entity (Name (Act_Rename)); + Result_Typ := Class_Wide_Type (Etype (Act_Constr)); + + -- Ada 2005 (AI-251): If the result is an interface type, the function + -- returns a class-wide interface type (otherwise the resulting object + -- would be abstract!) + + if Is_Interface (Etype (Act_Constr)) then + Set_Etype (Act_Constr, Result_Typ); + + -- If the result type is not parent of Tag_Arg then we need to + -- locate the tag of the secondary dispatch table. + + if not Is_Ancestor (Etype (Result_Typ), Etype (Tag_Arg)) then + pragma Assert (not Is_Interface (Etype (Tag_Arg))); + + Iface_Tag := + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, New_Internal_Name ('V')), + Object_Definition => + New_Reference_To (RTE (RE_Tag), Loc), + Expression => + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Secondary_Tag), Loc), + Parameter_Associations => New_List ( + Relocate_Node (Tag_Arg), + New_Reference_To + (Node (First_Elmt (Access_Disp_Table + (Etype (Etype (Act_Constr))))), + Loc)))); + Insert_Action (N, Iface_Tag); + end if; + end if; + + -- Create the call to the actual Constructor function + + Cnstr_Call := + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Act_Constr, Loc), + Parameter_Associations => New_List (Relocate_Node (Param_Arg))); + + -- Establish its controlling tag from the tag passed to the instance + -- The tag may be given by a function call, in which case a temporary + -- should be generated now, to prevent out-of-order insertions during + -- the expansion of that call when stack-checking is enabled. + + if Present (Iface_Tag) then + Set_Controlling_Argument (Cnstr_Call, + New_Occurrence_Of (Defining_Identifier (Iface_Tag), Loc)); + else + Remove_Side_Effects (Tag_Arg); + Set_Controlling_Argument (Cnstr_Call, + Relocate_Node (Tag_Arg)); + end if; + + -- Rewrite and analyze the call to the instance as a class-wide + -- conversion of the call to the actual constructor. + + Rewrite (N, Convert_To (Result_Typ, Cnstr_Call)); + Analyze_And_Resolve (N, Etype (Act_Constr)); + + -- Do not generate a run-time check on the built object if tag + -- checks are suppressed for the result type or VM_Target /= No_VM + + if Tag_Checks_Suppressed (Etype (Result_Typ)) + or else not Tagged_Type_Expansion + then + null; + + -- Generate a class-wide membership test to ensure that the call's tag + -- argument denotes a type within the class. We must keep separate the + -- case in which the Result_Type of the constructor function is a tagged + -- type from the case in which it is an abstract interface because the + -- run-time subprogram required to check these cases differ (and have + -- one difference in their parameters profile). + + -- Call CW_Membership if the Result_Type is a tagged type to look for + -- the tag in the table of ancestor tags. + + elsif not Is_Interface (Result_Typ) then + declare + Obj_Tag_Node : Node_Id := Duplicate_Subexpr (Tag_Arg); + CW_Test_Node : Node_Id; + + begin + Build_CW_Membership (Loc, + Obj_Tag_Node => Obj_Tag_Node, + Typ_Tag_Node => + New_Reference_To ( + Node (First_Elmt (Access_Disp_Table ( + Root_Type (Result_Typ)))), Loc), + Related_Nod => N, + New_Node => CW_Test_Node); + + Insert_Action (N, + Make_Implicit_If_Statement (N, + Condition => + Make_Op_Not (Loc, CW_Test_Node), + Then_Statements => + New_List (Make_Raise_Statement (Loc, + New_Occurrence_Of (RTE (RE_Tag_Error), Loc))))); + end; + + -- Call IW_Membership test if the Result_Type is an abstract interface + -- to look for the tag in the table of interface tags. + + else + Insert_Action (N, + Make_Implicit_If_Statement (N, + Condition => + Make_Op_Not (Loc, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_IW_Membership), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => Duplicate_Subexpr (Tag_Arg), + Attribute_Name => Name_Address), + + New_Reference_To ( + Node (First_Elmt (Access_Disp_Table ( + Root_Type (Result_Typ)))), Loc)))), + Then_Statements => + New_List ( + Make_Raise_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Tag_Error), Loc))))); + end if; + end Expand_Dispatching_Constructor_Call; + --------------------------- -- Expand_Exception_Call -- --------------------------- - -- If the function call is not within an exception handler, then the - -- call is replaced by a null string. Otherwise the appropriate routine - -- in Ada.Exceptions is called passing the choice parameter specification + -- If the function call is not within an exception handler, then the call + -- is replaced by a null string. Otherwise the appropriate routine in + -- Ada.Exceptions is called passing the choice parameter specification -- from the enclosing handler. If the enclosing handler lacks a choice -- parameter, then one is supplied. @@ -110,32 +296,35 @@ package body Exp_Intr is Loc : constant Source_Ptr := Sloc (N); P : Node_Id; E : Entity_Id; - S : String_Id; begin -- Climb up parents to see if we are in exception handler P := Parent (N); loop - -- Case of not in exception handler + -- Case of not in exception handler, replace by null string if No (P) then - Start_String; - S := End_String; Rewrite (N, Make_String_Literal (Loc, - Strval => S)); + Strval => "")); exit; -- Case of in exception handler elsif Nkind (P) = N_Exception_Handler then - if No (Choice_Parameter (P)) then - -- If no choice parameter present, then put one there. Note - -- that we do not need to put it on the entity chain, since - -- no one will be referencing it by normal visibility methods. + -- Handler cannot be used for a local raise, and furthermore, this + -- is a violation of the No_Exception_Propagation restriction. + + Set_Local_Raise_Not_OK (P); + Check_Restriction (No_Exception_Propagation, N); + + -- If no choice parameter present, then put one there. Note that + -- we do not need to put it on the entity chain, since no one will + -- be referencing it by normal visibility methods. + if No (Choice_Parameter (P)) then E := Make_Defining_Identifier (Loc, New_Internal_Name ('E')); Set_Choice_Parameter (P, E); Set_Ekind (E, E_Variable); @@ -200,8 +389,8 @@ package body Exp_Intr is Rewrite (N, Unchecked_Convert_To (Etype (Ent), Make_Attribute_Reference (Loc, - Attribute_Name => Name_Address, - Prefix => Make_Identifier (Loc, Chars (Dum))))); + Prefix => Make_Identifier (Loc, Chars (Dum)), + Attribute_Name => Name_Address))); Analyze_And_Resolve (N, Etype (Ent)); end Expand_Import_Call; @@ -214,7 +403,14 @@ package body Exp_Intr is Nam : Name_Id; begin - -- If the intrinsic subprogram is generic, gets its original name. + -- If an external name is specified for the intrinsic, it is handled + -- by the back-end: leave the call node unchanged for now. + + if Present (Interface_Name (E)) then + return; + end if; + + -- If the intrinsic subprogram is generic, gets its original name if Present (Parent (E)) and then Present (Generic_Parent (Parent (E))) @@ -239,6 +435,9 @@ package body Exp_Intr is elsif Nam = Name_Exception_Name then Expand_Exception_Call (N, RE_Exception_Name_Simple); + elsif Nam = Name_Generic_Dispatching_Constructor then + Expand_Dispatching_Constructor_Call (N); + elsif Nam = Name_Import_Address or else Nam = Name_Import_Largest_Value @@ -284,12 +483,21 @@ package body Exp_Intr is then Expand_Source_Info (N, Nam); - else - -- Only other possibility is a renaming, in which case we expand - -- the call to the original operation (which must be intrinsic). + -- If we have a renaming, expand the call to the original operation, + -- which must itself be intrinsic, since renaming requires matching + -- conventions and this has already been checked. - pragma Assert (Present (Alias (E))); + elsif Present (Alias (E)) then Expand_Intrinsic_Call (N, Alias (E)); + + -- The only other case is where an external name was specified, + -- since this is the only way that an otherwise unrecognized + -- name could escape the checking in Sem_Prag. Nothing needs + -- to be done in such a case, since we pass such a call to the + -- back end unchanged. + + else + null; end if; end Expand_Intrinsic_Call; @@ -401,6 +609,61 @@ package body Exp_Intr is Loc : constant Source_Ptr := Sloc (N); Ent : Entity_Id; + procedure Write_Entity_Name (E : Entity_Id); + -- Recursive procedure to construct string for qualified name of + -- enclosing program unit. The qualification stops at an enclosing + -- scope has no source name (block or loop). If entity is a subprogram + -- instance, skip enclosing wrapper package. + + ----------------------- + -- Write_Entity_Name -- + ----------------------- + + procedure Write_Entity_Name (E : Entity_Id) is + SDef : Source_Ptr; + TDef : constant Source_Buffer_Ptr := + Source_Text (Get_Source_File_Index (Sloc (E))); + + begin + -- Nothing to do if at outer level + + if Scope (E) = Standard_Standard then + null; + + -- If scope comes from source, write its name + + elsif Comes_From_Source (Scope (E)) then + Write_Entity_Name (Scope (E)); + Add_Char_To_Name_Buffer ('.'); + + -- If in wrapper package skip past it + + elsif Is_Wrapper_Package (Scope (E)) then + Write_Entity_Name (Scope (Scope (E))); + Add_Char_To_Name_Buffer ('.'); + + -- Otherwise nothing to output (happens in unnamed block statements) + + else + null; + end if; + + -- Loop to output the name + + -- is this right wrt wide char encodings ??? (no!) + + SDef := Sloc (E); + while TDef (SDef) in '0' .. '9' + or else TDef (SDef) >= 'A' + or else TDef (SDef) = ASCII.ESC + loop + Add_Char_To_Name_Buffer (TDef (SDef)); + SDef := SDef + 1; + end loop; + end Write_Entity_Name; + + -- Start of processing for Expand_Source_Info + begin -- Integer cases @@ -413,6 +676,8 @@ package body Exp_Intr is -- String cases else + Name_Len := 0; + case Nam is when Name_File => Get_Decoded_Name_String @@ -422,12 +687,10 @@ package body Exp_Intr is Build_Location_String (Loc); when Name_Enclosing_Entity => - Name_Len := 0; - - Ent := Current_Scope; - -- Skip enclosing blocks to reach enclosing unit. + -- Skip enclosing blocks to reach enclosing unit + Ent := Current_Scope; while Present (Ent) loop exit when Ekind (Ent) /= E_Block and then Ekind (Ent) /= E_Loop; @@ -436,29 +699,15 @@ package body Exp_Intr is -- Ent now points to the relevant defining entity - declare - SDef : Source_Ptr := Sloc (Ent); - TDef : Source_Buffer_Ptr; - - begin - TDef := Source_Text (Get_Source_File_Index (SDef)); - Name_Len := 0; - - while TDef (SDef) in '0' .. '9' - or else TDef (SDef) >= 'A' - or else TDef (SDef) = ASCII.ESC - loop - Add_Char_To_Name_Buffer (TDef (SDef)); - SDef := SDef + 1; - end loop; - end; + Write_Entity_Name (Ent); when others => raise Program_Error; end case; Rewrite (N, - Make_String_Literal (Loc, Strval => String_From_Name_Buffer)); + Make_String_Literal (Loc, + Strval => String_From_Name_Buffer)); Analyze_And_Resolve (N, Standard_String); end if; @@ -473,6 +722,7 @@ package body Exp_Intr is Func : constant Entity_Id := Entity (Name (N)); Conv : Node_Id; Ftyp : Entity_Id; + Ttyp : Entity_Id; begin -- Rewrite as unchecked conversion node. Note that we must convert @@ -494,12 +744,33 @@ package body Exp_Intr is Analyze_And_Resolve (Conv); end if; + -- The instantiation of Unchecked_Conversion creates a wrapper package, + -- and the target type is declared as a subtype of the actual. Recover + -- the actual, which is the subtype indic. in the subtype declaration + -- for the target type. This is semantically correct, and avoids + -- anomalies with access subtypes. For entities, leave type as is. + -- We do the analysis here, because we do not want the compiler -- to try to optimize or otherwise reorganize the unchecked -- conversion node. - Rewrite (N, Unchecked_Convert_To (Etype (E), Conv)); - Set_Etype (N, Etype (E)); + Ttyp := Etype (E); + + if Is_Entity_Name (Conv) then + null; + + elsif Nkind (Parent (Ttyp)) = N_Subtype_Declaration then + Ttyp := Entity (Subtype_Indication (Parent (Etype (E)))); + + elsif Is_Itype (Ttyp) then + Ttyp := + Entity (Subtype_Indication (Associated_Node_For_Itype (Ttyp))); + else + raise Program_Error; + end if; + + Rewrite (N, Unchecked_Convert_To (Ttyp, Conv)); + Set_Etype (N, Ttyp); Set_Analyzed (N); if Nkind (N) = N_Unchecked_Type_Conversion then @@ -541,24 +812,47 @@ package body Exp_Intr is Free_Cod : List_Id; Blk : Node_Id; + Arg_Known_Non_Null : constant Boolean := Known_Non_Null (N); + -- This captures whether we know the argument to be non-null so that + -- we can avoid the test. The reason that we need to capture this is + -- that we analyze some generated statements before properly attaching + -- them to the tree, and that can disturb current value settings. + begin if No_Pool_Assigned (Rtyp) then - Error_Msg_N ("?deallocation from empty storage pool", N); + Error_Msg_N ("?deallocation from empty storage pool!", N); end if; - if Controlled_Type (Desig_T) then + -- Nothing to do if we know the argument is null + + if Known_Null (N) then + return; + end if; + + -- Processing for pointer to controlled type + + if Needs_Finalization (Desig_T) then Deref := Make_Explicit_Dereference (Loc, Prefix => Duplicate_Subexpr_No_Checks (Arg)); -- If the type is tagged, then we must force dispatching on the -- finalization call because the designated type may not be the - -- actual type of the object + -- actual type of the object. if Is_Tagged_Type (Desig_T) and then not Is_Class_Wide_Type (Desig_T) then Deref := Unchecked_Convert_To (Class_Wide_Type (Desig_T), Deref); + + elsif not Is_Tagged_Type (Desig_T) then + + -- Set type of result, to force a conversion when needed (see + -- exp_ch7, Convert_View), given that Deep_Finalize may be + -- inherited from the parent type, and we need the type of the + -- expression to see whether the conversion is in fact needed. + + Set_Etype (Deref, Desig_T); end if; Free_Cod := @@ -588,6 +882,11 @@ package body Exp_Intr is (Handled_Statement_Sequence (Blk), Entity (Identifier (Blk))); Append (Blk, Stmts); + -- We kill saved current values, since analyzing statements not + -- properly attached to the tree can set wrong current values. + + Kill_Current_Values; + else Append_List_To (Stmts, Free_Cod); end if; @@ -624,7 +923,7 @@ package body Exp_Intr is and then Is_Entity_Name (Nam2) and then Entity (Prefix (Nam1)) = Entity (Nam2) then - Error_Msg_N ("Abort may take time to complete?", N); + Error_Msg_N ("abort may take time to complete?", N); Error_Msg_N ("\deallocation might have no effect?", N); Error_Msg_N ("\safer to wait for termination.?", N); end if; @@ -668,58 +967,6 @@ package body Exp_Intr is Append_To (Stmts, Free_Node); Set_Storage_Pool (Free_Node, Pool); - -- Make implicit if statement. We omit this if we are the then part - -- of a test of the form: - - -- if not (Arg = null) then - - -- i.e. if the test is explicit in the source. Arg must be a simple - -- identifier for the purposes of this special test. Note that the - -- use of /= in the source is always transformed into the above form. - - declare - Test_Needed : Boolean := True; - P : constant Node_Id := Parent (N); - C : Node_Id; - - begin - if Nkind (Arg) = N_Identifier - and then Nkind (P) = N_If_Statement - and then First (Then_Statements (P)) = N - then - if Nkind (Condition (P)) = N_Op_Not then - C := Right_Opnd (Condition (P)); - - if Nkind (C) = N_Op_Eq - and then Nkind (Left_Opnd (C)) = N_Identifier - and then Chars (Arg) = Chars (Left_Opnd (C)) - and then Nkind (Right_Opnd (C)) = N_Null - then - Test_Needed := False; - end if; - end if; - end if; - - -- Generate If_Statement if needed - - if Test_Needed then - Gen_Code := - Make_Implicit_If_Statement (N, - Condition => - Make_Op_Ne (Loc, - Left_Opnd => Duplicate_Subexpr (Arg), - Right_Opnd => Make_Null (Loc)), - Then_Statements => Stmts); - - else - Gen_Code := - Make_Block_Statement (Loc, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Stmts)); - end if; - end; - -- Deal with storage pool if Present (Pool) then @@ -730,52 +977,144 @@ package body Exp_Intr is null; elsif Is_Class_Wide_Type (Etype (Pool)) then + + -- Case of a class-wide pool type: make a dispatching call + -- to Deallocate through the class-wide Deallocate_Any. + Set_Procedure_To_Call (Free_Node, RTE (RE_Deallocate_Any)); + else + -- Case of a specific pool type: make a statically bound call + Set_Procedure_To_Call (Free_Node, Find_Prim_Op (Etype (Pool), Name_Deallocate)); + end if; + end if; + + if Present (Procedure_To_Call (Free_Node)) then + + -- For all cases of a Deallocate call, the back-end needs to be + -- able to compute the size of the object being freed. This may + -- require some adjustments for objects of dynamic size. + -- + -- If the type is class wide, we generate an implicit type with the + -- right dynamic size, so that the deallocate call gets the right + -- size parameter computed by GIGI. Same for an access to + -- unconstrained packed array. + + if Is_Class_Wide_Type (Desig_T) + or else + (Is_Array_Type (Desig_T) + and then not Is_Constrained (Desig_T) + and then Is_Packed (Desig_T)) + then + declare + Deref : constant Node_Id := + Make_Explicit_Dereference (Loc, + Duplicate_Subexpr_No_Checks (Arg)); + D_Subtyp : Node_Id; + D_Type : Entity_Id; + + begin + Set_Etype (Deref, Typ); + Set_Parent (Deref, Free_Node); + D_Subtyp := Make_Subtype_From_Expr (Deref, Desig_T); + + if Nkind (D_Subtyp) in N_Has_Entity then + D_Type := Entity (D_Subtyp); + + else + D_Type := Make_Defining_Identifier (Loc, + New_Internal_Name ('A')); + Insert_Action (Deref, + Make_Subtype_Declaration (Loc, + Defining_Identifier => D_Type, + Subtype_Indication => D_Subtyp)); + + end if; + + -- Force freezing at the point of the dereference. For the + -- class wide case, this avoids having the subtype frozen + -- before the equivalent type. + + Freeze_Itype (D_Type, Deref); + + Set_Actual_Designated_Subtype (Free_Node, D_Type); + end; - -- If the type is class wide, we generate an implicit type - -- with the right dynamic size, so that the deallocate call - -- gets the right size parameter computed by gigi - - if Is_Class_Wide_Type (Desig_T) then - declare - Acc_Type : constant Entity_Id := - Create_Itype (E_Access_Type, N); - Deref : constant Node_Id := - Make_Explicit_Dereference (Loc, - Duplicate_Subexpr_No_Checks (Arg)); - - begin - Set_Etype (Deref, Typ); - Set_Parent (Deref, Free_Node); - - Set_Etype (Acc_Type, Acc_Type); - Set_Size_Info (Acc_Type, Typ); - Set_Directly_Designated_Type - (Acc_Type, Entity (Make_Subtype_From_Expr - (Deref, Desig_T))); - - Free_Arg := Unchecked_Convert_To (Acc_Type, Free_Arg); - end; - end if; end if; end if; - Set_Expression (Free_Node, Free_Arg); + -- Ada 2005 (AI-251): In case of abstract interface type we must + -- displace the pointer to reference the base of the object to + -- deallocate its memory, unless we're targetting a VM, in which case + -- no special processing is required. - declare - Lhs : constant Node_Id := Duplicate_Subexpr_No_Checks (Arg); + -- Generate: + -- free (Base_Address (Obj_Ptr)) - begin - Set_Assignment_OK (Lhs); + if Is_Interface (Directly_Designated_Type (Typ)) + and then Tagged_Type_Expansion + then + Set_Expression (Free_Node, + Unchecked_Convert_To (Typ, + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Base_Address), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Address), Free_Arg))))); + + -- Generate: + -- free (Obj_Ptr) + + else + Set_Expression (Free_Node, Free_Arg); + end if; + + -- Only remaining step is to set result to null, or generate a + -- raise of constraint error if the target object is "not null". + + if Can_Never_Be_Null (Etype (Arg)) then Append_To (Stmts, - Make_Assignment_Statement (Loc, - Name => Lhs, - Expression => Make_Null (Loc))); - end; + Make_Raise_Constraint_Error (Loc, + Reason => CE_Access_Check_Failed)); + + else + declare + Lhs : constant Node_Id := Duplicate_Subexpr_No_Checks (Arg); + begin + Set_Assignment_OK (Lhs); + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => Lhs, + Expression => Make_Null (Loc))); + end; + end if; + + -- If we know the argument is non-null, then make a block statement + -- that contains the required statements, no need for a test. + + if Arg_Known_Non_Null then + Gen_Code := + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts)); + + -- If the argument may be null, wrap the statements inside an IF that + -- does an explicit test to exclude the null case. + + else + Gen_Code := + Make_Implicit_If_Statement (N, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => Duplicate_Subexpr (Arg), + Right_Opnd => Make_Null (Loc)), + Then_Statements => Stmts); + end if; + + -- Rewrite the call Rewrite (N, Gen_Code); Analyze (N); @@ -803,8 +1142,8 @@ package body Exp_Intr is Right_Opnd => Make_Null (Loc)), New_Occurrence_Of (RTE (RE_Null_Address), Loc), Make_Attribute_Reference (Loc, - Attribute_Name => Name_Address, - Prefix => Obj)))); + Prefix => Obj, + Attribute_Name => Name_Address)))); Analyze_And_Resolve (N, RTE (RE_Address)); end Expand_To_Address;