diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 30110fb3946c..1c548973c67e 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,23 @@ +2010-10-11 Robert Dewar + + * sem_prag.adb, sem_aggr.adb, sprint.adb: Minor reformatting. + +2010-10-11 Javier Miranda + + * exp_ch5.ads, exp_ch6.ads (Expand_N_Extended_Return_Statement): Moved + to exp_ch6. + (Expand_N_Simple_Return_Statement): Moved to exp_ch6. + * exp_ch5.adb, exp_ch6.adb (Expand_Non_Function_Return): Moved to + exp_ch6. + (Expand_Simple_Function_Return): Move to exp_ch6. + (Expand_N_Extended_Return_Statement): Moved to exp_ch6. + (Expand_N_Simple_Return_Statement): Moved to exp_ch6. + +2010-10-11 Robert Dewar + + * snames.ads-tmpl: Add names for aspects. + * aspects.ads, aspects.adb: New. + * gcc-interface/Make-lang.in: Update dependencies. 2010-10-11 Ed Schonberg * exp_ch6.adb (Expand_Actuals): If an actual is the current instance of diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb new file mode 100755 index 000000000000..a0382e788f42 --- /dev/null +++ b/gcc/ada/aspects.adb @@ -0,0 +1,104 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- A S P E C T S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2010, 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 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Snames; use Snames; + +package body Aspects is + + type Aspect_Entry is record + Nam : Name_Id; + Asp : Aspect_Id; + end record; + + Aspect_Names : constant array (Integer range <>) of Aspect_Entry := ( + (Name_Ada_2005, Aspect_Ada_2005), + (Name_Ada_2012, Aspect_Ada_2012), + (Name_Address, Aspect_Address), + (Name_Aliased, Aspect_Aliased), + (Name_Alignment, Aspect_Alignment), + (Name_Atomic, Aspect_Atomic), + (Name_Atomic_Components, Aspect_Atomic_Components), + (Name_Bit_Order, Aspect_Bit_Order), + (Name_C_Pass_By_Copy, Aspect_C_Pass_By_Copy), + (Name_Component_Size, Aspect_Component_Size), + (Name_Discard_Names, Aspect_Discard_Names), + (Name_External_Tag, Aspect_External_Tag), + (Name_Favor_Top_Level, Aspect_Favor_Top_Level), + (Name_Inline, Aspect_Inline), + (Name_Inline_Always, Aspect_Inline_Always), + (Name_Invariant, Aspect_Invariant), + (Name_Machine_Radix, Aspect_Machine_Radix), + (Name_Object_Size, Aspect_Object_Size), + (Name_Pack, Aspect_Pack), + (Name_Persistent_BSS, Aspect_Persistent_BSS), + (Name_Post, Aspect_Post), + (Name_Postcondition, Aspect_Postcondition), + (Name_Pre, Aspect_Pre), + (Name_Precondition, Aspect_Precondition), + (Name_Predicate, Aspect_Predicate), + (Name_Preelaborable_Initialization, Aspect_Preelaborable_Initialization), + (Name_Psect_Object, Aspect_Psect_Object), + (Name_Pure_Function, Aspect_Pure_Function), + (Name_Shared, Aspect_Shared), + (Name_Size, Aspect_Size), + (Name_Storage_Pool, Aspect_Storage_Pool), + (Name_Storage_Size, Aspect_Storage_Size), + (Name_Stream_Size, Aspect_Stream_Size), + (Name_Suppress, Aspect_Suppress), + (Name_Suppress_Debug_Info, Aspect_Suppress_Debug_Info), + (Name_Unchecked_Union, Aspect_Unchecked_Union), + (Name_Universal_Aliasing, Aspect_Universal_Aliasing), + (Name_Unmodified, Aspect_Unmodified), + (Name_Unreferenced, Aspect_Unreferenced), + (Name_Unreferenced_Objects, Aspect_Unreferenced_Objects), + (Name_Unsuppress, Aspect_Unsuppress), + (Name_Value_Size, Aspect_Value_Size), + (Name_Volatile, Aspect_Volatile), + (Name_Volatile_Components, Aspect_Volatile_Components), + (Name_Warnings, Aspect_Warnings), + (Name_Weak_External, Aspect_Weak_External)); + + ------------------- + -- Get_Aspect_Id -- + ------------------- + + function Get_Aspect_Id (Name : Name_Id) return Aspect_Id is + begin + for J in Aspect_Names'Range loop + if Aspect_Names (J).Nam = Name then + return Aspect_Names (J).Asp; + end if; + end loop; + + return No_Aspect; + end Get_Aspect_Id; + +end Aspects; diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads new file mode 100755 index 000000000000..ac9e231de576 --- /dev/null +++ b/gcc/ada/aspects.ads @@ -0,0 +1,161 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- A S P E C T S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2010, 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 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package defines the aspects that are recognized in aspect +-- specifications. We separate this off in its own packages to that +-- it can be accessed by the parser without dragging in Sem_Asp + +with Namet; use Namet; + +package Aspects is + + type Aspect_Id is + (No_Aspect, -- Dummy entry for no aspect + Aspect_Ada_2005, -- GNAT + Aspect_Ada_2012, -- GNAT + Aspect_Address, + Aspect_Aliased, + Aspect_Alignment, + Aspect_Atomic, + Aspect_Atomic_Components, + Aspect_Bit_Order, + Aspect_C_Pass_By_Copy, + Aspect_Component_Size, + Aspect_Discard_Names, + Aspect_External_Tag, + Aspect_Favor_Top_Level, -- GNAT + Aspect_Inline, + Aspect_Inline_Always, -- GNAT + Aspect_Invariant, + Aspect_Machine_Radix, + Aspect_Object_Size, -- GNAT + Aspect_Pack, + Aspect_Persistent_BSS, -- GNAT + Aspect_Post, + Aspect_Postcondition, -- GNAT (equivalent to Post) + Aspect_Pre, + Aspect_Precondition, -- GNAT (equivalent to Pre) + Aspect_Predicate, -- GNAT??? + Aspect_Preelaborable_Initialization, + Aspect_Psect_Object, -- GNAT + Aspect_Pure_Function, -- GNAT + Aspect_Shared, -- GNAT (equivalent to Atomic) + Aspect_Size, + Aspect_Storage_Pool, + Aspect_Storage_Size, + Aspect_Stream_Size, + Aspect_Suppress, + Aspect_Suppress_Debug_Info, -- GNAT + Aspect_Unchecked_Union, + Aspect_Universal_Aliasing, -- GNAT + Aspect_Unmodified, -- GNAT + Aspect_Unreferenced, -- GNAT + Aspect_Unreferenced_Objects, -- GNAT + Aspect_Unsuppress, + Aspect_Value_Size, -- GNAT + Aspect_Volatile, + Aspect_Volatile_Components, + Aspect_Warnings, -- GNAT + Aspect_Weak_External); -- GNAT + + -- The following array indicates aspects that accept 'Class + + Class_Aspect_OK : constant array (Aspect_Id) of Boolean := + (Aspect_Invariant => True, + Aspect_Pre => True, + Aspect_Precondition => True, + Aspect_Post => True, + Aspect_Postcondition => True, + others => False); + + -- The following type is used for indicating allowed expression forms + + type Aspect_Expression is + (Optional, -- Optional boolean expression + Expression, -- Required non-boolean expression + Name); -- Required name + + -- The following array indicates what argument type is required + + Aspect_Argument : constant array (Aspect_Id) of Aspect_Expression := + (No_Aspect => Optional, + Aspect_Ada_2005 => Optional, + Aspect_Ada_2012 => Optional, + Aspect_Address => Expression, + Aspect_Aliased => Optional, + Aspect_Alignment => Expression, + Aspect_Atomic => Optional, + Aspect_Atomic_Components => Optional, + Aspect_Bit_Order => Expression, + Aspect_C_Pass_By_Copy => Optional, + Aspect_Component_Size => Expression, + Aspect_Discard_Names => Optional, + Aspect_External_Tag => Expression, + Aspect_Favor_Top_Level => Optional, + Aspect_Inline => Optional, + Aspect_Inline_Always => Optional, + Aspect_Invariant => Expression, + Aspect_Machine_Radix => Expression, + Aspect_Object_Size => Expression, + Aspect_Pack => Optional, + Aspect_Persistent_BSS => Optional, + Aspect_Post => Expression, + Aspect_Postcondition => Expression, + Aspect_Pre => Expression, + Aspect_Precondition => Expression, + Aspect_Predicate => Expression, + Aspect_Preelaborable_Initialization => Optional, + Aspect_Psect_Object => Optional, + Aspect_Pure_Function => Optional, + Aspect_Shared => Optional, + Aspect_Size => Expression, + Aspect_Storage_Pool => Expression, + Aspect_Storage_Size => Expression, + Aspect_Stream_Size => Expression, + Aspect_Suppress => Name, + Aspect_Suppress_Debug_Info => Optional, + Aspect_Unchecked_Union => Optional, + Aspect_Universal_Aliasing => Optional, + Aspect_Unmodified => Optional, + Aspect_Unreferenced => Optional, + Aspect_Unreferenced_Objects => Optional, + Aspect_Unsuppress => Name, + Aspect_Value_Size => Expression, + Aspect_Volatile => Optional, + Aspect_Volatile_Components => Optional, + Aspect_Warnings => Name, + Aspect_Weak_External => Optional); + + function Get_Aspect_Id (Name : Name_Id) return Aspect_Id; + -- Given a name Nam, returns the corresponding aspect id value. If the name + -- does not match any aspect, then No_Aspect is returned as the result. + +end Aspects; diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index a28c5ab1be0b..6ca2c8c8f3f5 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -27,7 +27,6 @@ with Atree; use Atree; with Checks; use Checks; with Debug; use Debug; with Einfo; use Einfo; -with Exp_Atag; use Exp_Atag; with Exp_Aggr; use Exp_Aggr; with Exp_Ch6; use Exp_Ch6; with Exp_Ch7; use Exp_Ch7; @@ -104,16 +103,6 @@ package body Exp_Ch5 is -- clause (this last case is required because holes in the tagged type -- might be filled with components from child types). - procedure Expand_Non_Function_Return (N : Node_Id); - -- Called by Expand_N_Simple_Return_Statement in case we're returning from - -- a procedure body, entry body, accept statement, or extended return - -- statement. Note that all non-function returns are simple return - -- statements. - - procedure Expand_Simple_Function_Return (N : Node_Id); - -- Expand simple return from function. In the case where we are returning - -- from a function body this is called by Expand_N_Simple_Return_Statement. - function Make_Tag_Ctrl_Assignment (N : Node_Id) return List_Id; -- Generate the necessary code for controlled and tagged assignment, that -- is to say, finalization of the target before, adjustment of the target @@ -2450,728 +2439,6 @@ package body Exp_Ch5 is Adjust_Condition (Condition (N)); end Expand_N_Exit_Statement; - ---------------------------------------- - -- Expand_N_Extended_Return_Statement -- - ---------------------------------------- - - -- If there is a Handled_Statement_Sequence, we rewrite this: - - -- return Result : T := do - -- - -- end return; - - -- to be: - - -- declare - -- Result : T := ; - -- begin - -- - -- return Result; - -- end; - - -- Otherwise (no Handled_Statement_Sequence), we rewrite this: - - -- return Result : T := ; - - -- to be: - - -- return ; - - -- unless it's build-in-place or there's no , in which case - -- we generate: - - -- declare - -- Result : T := ; - -- begin - -- return Result; - -- end; - - -- Note that this case could have been written by the user as an extended - -- return statement, or could have been transformed to this from a simple - -- return statement. - - -- That is, we need to have a reified return object if there are statements - -- (which might refer to it) or if we're doing build-in-place (so we can - -- set its address to the final resting place or if there is no expression - -- (in which case default initial values might need to be set). - - procedure Expand_N_Extended_Return_Statement (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - - Return_Object_Entity : constant Entity_Id := - First_Entity (Return_Statement_Entity (N)); - Return_Object_Decl : constant Node_Id := - Parent (Return_Object_Entity); - Parent_Function : constant Entity_Id := - Return_Applies_To (Return_Statement_Entity (N)); - Parent_Function_Typ : constant Entity_Id := Etype (Parent_Function); - Is_Build_In_Place : constant Boolean := - Is_Build_In_Place_Function (Parent_Function); - - Return_Stm : Node_Id; - Statements : List_Id; - Handled_Stm_Seq : Node_Id; - Result : Node_Id; - Exp : Node_Id; - - function Has_Controlled_Parts (Typ : Entity_Id) return Boolean; - -- Determine whether type Typ is controlled or contains a controlled - -- subcomponent. - - function Move_Activation_Chain return Node_Id; - -- Construct a call to System.Tasking.Stages.Move_Activation_Chain - -- with parameters: - -- From current activation chain - -- To activation chain passed in by the caller - -- New_Master master passed in by the caller - - function Move_Final_List return Node_Id; - -- Construct call to System.Finalization_Implementation.Move_Final_List - -- with parameters: - -- - -- From finalization list of the return statement - -- To finalization list passed in by the caller - - -------------------------- - -- Has_Controlled_Parts -- - -------------------------- - - function Has_Controlled_Parts (Typ : Entity_Id) return Boolean is - begin - return - Is_Controlled (Typ) - or else Has_Controlled_Component (Typ); - end Has_Controlled_Parts; - - --------------------------- - -- Move_Activation_Chain -- - --------------------------- - - function Move_Activation_Chain return Node_Id is - Activation_Chain_Formal : constant Entity_Id := - Build_In_Place_Formal - (Parent_Function, BIP_Activation_Chain); - To : constant Node_Id := - New_Reference_To - (Activation_Chain_Formal, Loc); - Master_Formal : constant Entity_Id := - Build_In_Place_Formal - (Parent_Function, BIP_Master); - New_Master : constant Node_Id := - New_Reference_To (Master_Formal, Loc); - - Chain_Entity : Entity_Id; - From : Node_Id; - - begin - Chain_Entity := First_Entity (Return_Statement_Entity (N)); - while Chars (Chain_Entity) /= Name_uChain loop - Chain_Entity := Next_Entity (Chain_Entity); - end loop; - - From := - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Chain_Entity, Loc), - Attribute_Name => Name_Unrestricted_Access); - -- ??? Not clear why "Make_Identifier (Loc, Name_uChain)" doesn't - -- work, instead of "New_Reference_To (Chain_Entity, Loc)" above. - - return - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (RE_Move_Activation_Chain), Loc), - Parameter_Associations => New_List (From, To, New_Master)); - end Move_Activation_Chain; - - --------------------- - -- Move_Final_List -- - --------------------- - - function Move_Final_List return Node_Id is - Flist : constant Entity_Id := - Finalization_Chain_Entity (Return_Statement_Entity (N)); - - From : constant Node_Id := New_Reference_To (Flist, Loc); - - Caller_Final_List : constant Entity_Id := - Build_In_Place_Formal - (Parent_Function, BIP_Final_List); - - To : constant Node_Id := New_Reference_To (Caller_Final_List, Loc); - - begin - -- Catch cases where a finalization chain entity has not been - -- associated with the return statement entity. - - pragma Assert (Present (Flist)); - - -- Build required call - - return - Make_If_Statement (Loc, - Condition => - Make_Op_Ne (Loc, - Left_Opnd => New_Copy (From), - Right_Opnd => New_Node (N_Null, Loc)), - Then_Statements => - New_List ( - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (RE_Move_Final_List), Loc), - Parameter_Associations => New_List (From, To)))); - end Move_Final_List; - - -- Start of processing for Expand_N_Extended_Return_Statement - - begin - if Nkind (Return_Object_Decl) = N_Object_Declaration then - Exp := Expression (Return_Object_Decl); - else - Exp := Empty; - end if; - - Handled_Stm_Seq := Handled_Statement_Sequence (N); - - -- Build a simple_return_statement that returns the return object when - -- there is a statement sequence, or no expression, or the result will - -- be built in place. Note however that we currently do this for all - -- composite cases, even though nonlimited composite results are not yet - -- built in place (though we plan to do so eventually). - - if Present (Handled_Stm_Seq) - or else Is_Composite_Type (Etype (Parent_Function)) - or else No (Exp) - then - if No (Handled_Stm_Seq) then - Statements := New_List; - - -- If the extended return has a handled statement sequence, then wrap - -- it in a block and use the block as the first statement. - - else - Statements := - New_List (Make_Block_Statement (Loc, - Declarations => New_List, - Handled_Statement_Sequence => Handled_Stm_Seq)); - end if; - - -- If control gets past the above Statements, we have successfully - -- completed the return statement. If the result type has controlled - -- parts and the return is for a build-in-place function, then we - -- call Move_Final_List to transfer responsibility for finalization - -- of the return object to the caller. An alternative would be to - -- declare a Success flag in the function, initialize it to False, - -- and set it to True here. Then move the Move_Final_List call into - -- the cleanup code, and check Success. If Success then make a call - -- to Move_Final_List else do finalization. Then we can remove the - -- abort-deferral and the nulling-out of the From parameter from - -- Move_Final_List. Note that the current method is not quite correct - -- in the rather obscure case of a select-then-abort statement whose - -- abortable part contains the return statement. - - -- Check the type of the function to determine whether to move the - -- finalization list. A special case arises when processing a simple - -- return statement which has been rewritten as an extended return. - -- In that case check the type of the returned object or the original - -- expression. - - if Is_Build_In_Place - and then - (Has_Controlled_Parts (Parent_Function_Typ) - or else (Is_Class_Wide_Type (Parent_Function_Typ) - and then - Has_Controlled_Parts (Root_Type (Parent_Function_Typ))) - or else Has_Controlled_Parts (Etype (Return_Object_Entity)) - or else (Present (Exp) - and then Has_Controlled_Parts (Etype (Exp)))) - then - Append_To (Statements, Move_Final_List); - end if; - - -- Similarly to the above Move_Final_List, if the result type - -- contains tasks, we call Move_Activation_Chain. Later, the cleanup - -- code will call Complete_Master, which will terminate any - -- unactivated tasks belonging to the return statement master. But - -- Move_Activation_Chain updates their master to be that of the - -- caller, so they will not be terminated unless the return statement - -- completes unsuccessfully due to exception, abort, goto, or exit. - -- As a formality, we test whether the function requires the result - -- to be built in place, though that's necessarily true for the case - -- of result types with task parts. - - if Is_Build_In_Place and Has_Task (Etype (Parent_Function)) then - Append_To (Statements, Move_Activation_Chain); - end if; - - -- Build a simple_return_statement that returns the return object - - Return_Stm := - Make_Simple_Return_Statement (Loc, - Expression => New_Occurrence_Of (Return_Object_Entity, Loc)); - Append_To (Statements, Return_Stm); - - Handled_Stm_Seq := - Make_Handled_Sequence_Of_Statements (Loc, Statements); - end if; - - -- Case where we build a block - - if Present (Handled_Stm_Seq) then - Result := - Make_Block_Statement (Loc, - Declarations => Return_Object_Declarations (N), - Handled_Statement_Sequence => Handled_Stm_Seq); - - -- We set the entity of the new block statement to be that of the - -- return statement. This is necessary so that various fields, such - -- as Finalization_Chain_Entity carry over from the return statement - -- to the block. Note that this block is unusual, in that its entity - -- is an E_Return_Statement rather than an E_Block. - - Set_Identifier - (Result, New_Occurrence_Of (Return_Statement_Entity (N), Loc)); - - -- If the object decl was already rewritten as a renaming, then - -- we don't want to do the object allocation and transformation of - -- of the return object declaration to a renaming. This case occurs - -- when the return object is initialized by a call to another - -- build-in-place function, and that function is responsible for the - -- allocation of the return object. - - if Is_Build_In_Place - and then - Nkind (Return_Object_Decl) = N_Object_Renaming_Declaration - then - pragma Assert (Nkind (Original_Node (Return_Object_Decl)) = - N_Object_Declaration - and then Is_Build_In_Place_Function_Call - (Expression (Original_Node (Return_Object_Decl)))); - - Set_By_Ref (Return_Stm); -- Return build-in-place results by ref - - elsif Is_Build_In_Place then - - -- Locate the implicit access parameter associated with the - -- caller-supplied return object and convert the return - -- statement's return object declaration to a renaming of a - -- dereference of the access parameter. If the return object's - -- declaration includes an expression that has not already been - -- expanded as separate assignments, then add an assignment - -- statement to ensure the return object gets initialized. - - -- declare - -- Result : T [:= ]; - -- begin - -- ... - - -- is converted to - - -- declare - -- Result : T renames FuncRA.all; - -- [Result := New_Reference_To (Return_Obj_Id, Loc), - Expression => Relocate_Node (Return_Obj_Expr)); - Set_Etype (Name (Init_Assignment), Etype (Return_Obj_Id)); - Set_Assignment_OK (Name (Init_Assignment)); - Set_No_Ctrl_Actions (Init_Assignment); - - Set_Parent (Name (Init_Assignment), Init_Assignment); - Set_Parent (Expression (Init_Assignment), Init_Assignment); - - Set_Expression (Return_Object_Decl, Empty); - - if Is_Class_Wide_Type (Etype (Return_Obj_Id)) - and then not Is_Class_Wide_Type - (Etype (Expression (Init_Assignment))) - then - Rewrite (Expression (Init_Assignment), - Make_Type_Conversion (Loc, - Subtype_Mark => - New_Occurrence_Of - (Etype (Return_Obj_Id), Loc), - Expression => - Relocate_Node (Expression (Init_Assignment)))); - end if; - - -- In the case of functions where the calling context can - -- determine the form of allocation needed, initialization - -- is done with each part of the if statement that handles - -- the different forms of allocation (this is true for - -- unconstrained and tagged result subtypes). - - if Constr_Result - and then not Is_Tagged_Type (Underlying_Type (Result_Subt)) - then - Insert_After (Return_Object_Decl, Init_Assignment); - end if; - end if; - - -- When the function's subtype is unconstrained, a run-time - -- test is needed to determine the form of allocation to use - -- for the return object. The function has an implicit formal - -- parameter indicating this. If the BIP_Alloc_Form formal has - -- the value one, then the caller has passed access to an - -- existing object for use as the return object. If the value - -- is two, then the return object must be allocated on the - -- secondary stack. Otherwise, the object must be allocated in - -- a storage pool (currently only supported for the global - -- heap, user-defined storage pools TBD ???). We generate an - -- if statement to test the implicit allocation formal and - -- initialize a local access value appropriately, creating - -- allocators in the secondary stack and global heap cases. - -- The special formal also exists and must be tested when the - -- function has a tagged result, even when the result subtype - -- is constrained, because in general such functions can be - -- called in dispatching contexts and must be handled similarly - -- to functions with a class-wide result. - - if not Constr_Result - or else Is_Tagged_Type (Underlying_Type (Result_Subt)) - then - Obj_Alloc_Formal := - Build_In_Place_Formal (Parent_Function, BIP_Alloc_Form); - - declare - Ref_Type : Entity_Id; - Ptr_Type_Decl : Node_Id; - Alloc_Obj_Id : Entity_Id; - Alloc_Obj_Decl : Node_Id; - Alloc_If_Stmt : Node_Id; - SS_Allocator : Node_Id; - Heap_Allocator : Node_Id; - - begin - -- Reuse the itype created for the function's implicit - -- access formal. This avoids the need to create a new - -- access type here, plus it allows assigning the access - -- formal directly without applying a conversion. - - -- Ref_Type := Etype (Object_Access); - - -- Create an access type designating the function's - -- result subtype. - - Ref_Type := Make_Temporary (Loc, 'A'); - - Ptr_Type_Decl := - Make_Full_Type_Declaration (Loc, - Defining_Identifier => Ref_Type, - Type_Definition => - Make_Access_To_Object_Definition (Loc, - All_Present => True, - Subtype_Indication => - New_Reference_To (Return_Obj_Typ, Loc))); - - Insert_Before (Return_Object_Decl, Ptr_Type_Decl); - - -- Create an access object that will be initialized to an - -- access value denoting the return object, either coming - -- from an implicit access value passed in by the caller - -- or from the result of an allocator. - - Alloc_Obj_Id := Make_Temporary (Loc, 'R'); - Set_Etype (Alloc_Obj_Id, Ref_Type); - - Alloc_Obj_Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Alloc_Obj_Id, - Object_Definition => New_Reference_To - (Ref_Type, Loc)); - - Insert_Before (Return_Object_Decl, Alloc_Obj_Decl); - - -- Create allocators for both the secondary stack and - -- global heap. If there's an initialization expression, - -- then create these as initialized allocators. - - if Present (Return_Obj_Expr) - and then not No_Initialization (Return_Object_Decl) - then - -- Always use the type of the expression for the - -- qualified expression, rather than the result type. - -- In general we cannot always use the result type - -- for the allocator, because the expression might be - -- of a specific type, such as in the case of an - -- aggregate or even a nonlimited object when the - -- result type is a limited class-wide interface type. - - Heap_Allocator := - Make_Allocator (Loc, - Expression => - Make_Qualified_Expression (Loc, - Subtype_Mark => - New_Reference_To - (Etype (Return_Obj_Expr), Loc), - Expression => - New_Copy_Tree (Return_Obj_Expr))); - - else - -- If the function returns a class-wide type we cannot - -- use the return type for the allocator. Instead we - -- use the type of the expression, which must be an - -- aggregate of a definite type. - - if Is_Class_Wide_Type (Return_Obj_Typ) then - Heap_Allocator := - Make_Allocator (Loc, - Expression => - New_Reference_To - (Etype (Return_Obj_Expr), Loc)); - else - Heap_Allocator := - Make_Allocator (Loc, - Expression => - New_Reference_To (Return_Obj_Typ, Loc)); - end if; - - -- If the object requires default initialization then - -- that will happen later following the elaboration of - -- the object renaming. If we don't turn it off here - -- then the object will be default initialized twice. - - Set_No_Initialization (Heap_Allocator); - end if; - - -- If the No_Allocators restriction is active, then only - -- an allocator for secondary stack allocation is needed. - -- It's OK for such allocators to have Comes_From_Source - -- set to False, because gigi knows not to flag them as - -- being a violation of No_Implicit_Heap_Allocations. - - if Restriction_Active (No_Allocators) then - SS_Allocator := Heap_Allocator; - Heap_Allocator := Make_Null (Loc); - - -- Otherwise the heap allocator may be needed, so we make - -- another allocator for secondary stack allocation. - - else - SS_Allocator := New_Copy_Tree (Heap_Allocator); - - -- The heap allocator is marked Comes_From_Source - -- since it corresponds to an explicit user-written - -- allocator (that is, it will only be executed on - -- behalf of callers that call the function as - -- initialization for such an allocator). This - -- prevents errors when No_Implicit_Heap_Allocations - -- is in force. - - Set_Comes_From_Source (Heap_Allocator, True); - end if; - - -- The allocator is returned on the secondary stack. We - -- don't do this on VM targets, since the SS is not used. - - if VM_Target = No_VM then - Set_Storage_Pool (SS_Allocator, RTE (RE_SS_Pool)); - Set_Procedure_To_Call - (SS_Allocator, RTE (RE_SS_Allocate)); - - -- The allocator is returned on the secondary stack, - -- so indicate that the function return, as well as - -- the block that encloses the allocator, must not - -- release it. The flags must be set now because the - -- decision to use the secondary stack is done very - -- late in the course of expanding the return - -- statement, past the point where these flags are - -- normally set. - - Set_Sec_Stack_Needed_For_Return (Parent_Function); - Set_Sec_Stack_Needed_For_Return - (Return_Statement_Entity (N)); - Set_Uses_Sec_Stack (Parent_Function); - Set_Uses_Sec_Stack (Return_Statement_Entity (N)); - end if; - - -- Create an if statement to test the BIP_Alloc_Form - -- formal and initialize the access object to either the - -- BIP_Object_Access formal (BIP_Alloc_Form = 0), the - -- result of allocating the object in the secondary stack - -- (BIP_Alloc_Form = 1), or else an allocator to create - -- the return object in the heap (BIP_Alloc_Form = 2). - - -- ??? An unchecked type conversion must be made in the - -- case of assigning the access object formal to the - -- local access object, because a normal conversion would - -- be illegal in some cases (such as converting access- - -- to-unconstrained to access-to-constrained), but the - -- the unchecked conversion will presumably fail to work - -- right in just such cases. It's not clear at all how to - -- handle this. ??? - - Alloc_If_Stmt := - Make_If_Statement (Loc, - Condition => - Make_Op_Eq (Loc, - Left_Opnd => - New_Reference_To (Obj_Alloc_Formal, Loc), - Right_Opnd => - Make_Integer_Literal (Loc, - UI_From_Int (BIP_Allocation_Form'Pos - (Caller_Allocation)))), - Then_Statements => - New_List (Make_Assignment_Statement (Loc, - Name => - New_Reference_To - (Alloc_Obj_Id, Loc), - Expression => - Make_Unchecked_Type_Conversion (Loc, - Subtype_Mark => - New_Reference_To (Ref_Type, Loc), - Expression => - New_Reference_To - (Object_Access, Loc)))), - Elsif_Parts => - New_List (Make_Elsif_Part (Loc, - Condition => - Make_Op_Eq (Loc, - Left_Opnd => - New_Reference_To - (Obj_Alloc_Formal, Loc), - Right_Opnd => - Make_Integer_Literal (Loc, - UI_From_Int ( - BIP_Allocation_Form'Pos - (Secondary_Stack)))), - Then_Statements => - New_List - (Make_Assignment_Statement (Loc, - Name => - New_Reference_To - (Alloc_Obj_Id, Loc), - Expression => - SS_Allocator)))), - Else_Statements => - New_List (Make_Assignment_Statement (Loc, - Name => - New_Reference_To - (Alloc_Obj_Id, Loc), - Expression => - Heap_Allocator))); - - -- If a separate initialization assignment was created - -- earlier, append that following the assignment of the - -- implicit access formal to the access object, to ensure - -- that the return object is initialized in that case. - -- In this situation, the target of the assignment must - -- be rewritten to denote a dereference of the access to - -- the return object passed in by the caller. - - if Present (Init_Assignment) then - Rewrite (Name (Init_Assignment), - Make_Explicit_Dereference (Loc, - Prefix => New_Reference_To (Alloc_Obj_Id, Loc))); - Set_Etype - (Name (Init_Assignment), Etype (Return_Obj_Id)); - - Append_To - (Then_Statements (Alloc_If_Stmt), - Init_Assignment); - end if; - - Insert_Before (Return_Object_Decl, Alloc_If_Stmt); - - -- Remember the local access object for use in the - -- dereference of the renaming created below. - - Object_Access := Alloc_Obj_Id; - end; - end if; - - -- Replace the return object declaration with a renaming of a - -- dereference of the access value designating the return - -- object. - - Obj_Acc_Deref := - Make_Explicit_Dereference (Loc, - Prefix => New_Reference_To (Object_Access, Loc)); - - Rewrite (Return_Object_Decl, - Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => Return_Obj_Id, - Access_Definition => Empty, - Subtype_Mark => New_Occurrence_Of - (Return_Obj_Typ, Loc), - Name => Obj_Acc_Deref)); - - Set_Renamed_Object (Return_Obj_Id, Obj_Acc_Deref); - end; - end if; - - -- Case where we do not build a block - - else - -- We're about to drop Return_Object_Declarations on the floor, so - -- we need to insert it, in case it got expanded into useful code. - -- Remove side effects from expression, which may be duplicated in - -- subsequent checks (see Expand_Simple_Function_Return). - - Insert_List_Before (N, Return_Object_Declarations (N)); - Remove_Side_Effects (Exp); - - -- Build simple_return_statement that returns the expression directly - - Return_Stm := Make_Simple_Return_Statement (Loc, Expression => Exp); - - Result := Return_Stm; - end if; - - -- Set the flag to prevent infinite recursion - - Set_Comes_From_Extended_Return_Statement (Return_Stm); - - Rewrite (N, Result); - Analyze (N); - end Expand_N_Extended_Return_Statement; - ----------------------------- -- Expand_N_Goto_Statement -- ----------------------------- @@ -3671,761 +2938,6 @@ package body Exp_Ch5 is end if; end Expand_N_Loop_Statement; - -------------------------------------- - -- Expand_N_Simple_Return_Statement -- - -------------------------------------- - - procedure Expand_N_Simple_Return_Statement (N : Node_Id) is - begin - -- Defend against previous errors (i.e. the return statement calls a - -- function that is not available in configurable runtime). - - if Present (Expression (N)) - and then Nkind (Expression (N)) = N_Empty - then - return; - end if; - - -- Distinguish the function and non-function cases: - - case Ekind (Return_Applies_To (Return_Statement_Entity (N))) is - - when E_Function | - E_Generic_Function => - Expand_Simple_Function_Return (N); - - when E_Procedure | - E_Generic_Procedure | - E_Entry | - E_Entry_Family | - E_Return_Statement => - Expand_Non_Function_Return (N); - - when others => - raise Program_Error; - end case; - - exception - when RE_Not_Available => - return; - end Expand_N_Simple_Return_Statement; - - -------------------------------- - -- Expand_Non_Function_Return -- - -------------------------------- - - procedure Expand_Non_Function_Return (N : Node_Id) is - pragma Assert (No (Expression (N))); - - Loc : constant Source_Ptr := Sloc (N); - Scope_Id : Entity_Id := - Return_Applies_To (Return_Statement_Entity (N)); - Kind : constant Entity_Kind := Ekind (Scope_Id); - Call : Node_Id; - Acc_Stat : Node_Id; - Goto_Stat : Node_Id; - Lab_Node : Node_Id; - - begin - -- Call _Postconditions procedure if procedure with active - -- postconditions. Here, we use the Postcondition_Proc attribute, which - -- is needed for implicitly-generated returns. Functions never - -- have implicitly-generated returns, and there's no room for - -- Postcondition_Proc in E_Function, so we look up the identifier - -- Name_uPostconditions for function returns (see - -- Expand_Simple_Function_Return). - - if Ekind (Scope_Id) = E_Procedure - and then Has_Postconditions (Scope_Id) - then - pragma Assert (Present (Postcondition_Proc (Scope_Id))); - Insert_Action (N, - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (Postcondition_Proc (Scope_Id), Loc))); - end if; - - -- If it is a return from a procedure do no extra steps - - if Kind = E_Procedure or else Kind = E_Generic_Procedure then - return; - - -- If it is a nested return within an extended one, replace it with a - -- return of the previously declared return object. - - elsif Kind = E_Return_Statement then - Rewrite (N, - Make_Simple_Return_Statement (Loc, - Expression => - New_Occurrence_Of (First_Entity (Scope_Id), Loc))); - Set_Comes_From_Extended_Return_Statement (N); - Set_Return_Statement_Entity (N, Scope_Id); - Expand_Simple_Function_Return (N); - return; - end if; - - pragma Assert (Is_Entry (Scope_Id)); - - -- Look at the enclosing block to see whether the return is from an - -- accept statement or an entry body. - - for J in reverse 0 .. Scope_Stack.Last loop - Scope_Id := Scope_Stack.Table (J).Entity; - exit when Is_Concurrent_Type (Scope_Id); - end loop; - - -- If it is a return from accept statement it is expanded as call to - -- RTS Complete_Rendezvous and a goto to the end of the accept body. - - -- (cf : Expand_N_Accept_Statement, Expand_N_Selective_Accept, - -- Expand_N_Accept_Alternative in exp_ch9.adb) - - if Is_Task_Type (Scope_Id) then - - Call := - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (RE_Complete_Rendezvous), Loc)); - Insert_Before (N, Call); - -- why not insert actions here??? - Analyze (Call); - - Acc_Stat := Parent (N); - while Nkind (Acc_Stat) /= N_Accept_Statement loop - Acc_Stat := Parent (Acc_Stat); - end loop; - - Lab_Node := Last (Statements - (Handled_Statement_Sequence (Acc_Stat))); - - Goto_Stat := Make_Goto_Statement (Loc, - Name => New_Occurrence_Of - (Entity (Identifier (Lab_Node)), Loc)); - - Set_Analyzed (Goto_Stat); - - Rewrite (N, Goto_Stat); - Analyze (N); - - -- If it is a return from an entry body, put a Complete_Entry_Body call - -- in front of the return. - - elsif Is_Protected_Type (Scope_Id) then - Call := - Make_Procedure_Call_Statement (Loc, - Name => - New_Reference_To (RTE (RE_Complete_Entry_Body), Loc), - Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Prefix => - New_Reference_To - (Find_Protection_Object (Current_Scope), Loc), - Attribute_Name => - Name_Unchecked_Access))); - - Insert_Before (N, Call); - Analyze (Call); - end if; - end Expand_Non_Function_Return; - - ----------------------------------- - -- Expand_Simple_Function_Return -- - ----------------------------------- - - -- The "simple" comes from the syntax rule simple_return_statement. - -- The semantics are not at all simple! - - procedure Expand_Simple_Function_Return (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - - Scope_Id : constant Entity_Id := - Return_Applies_To (Return_Statement_Entity (N)); - -- The function we are returning from - - R_Type : constant Entity_Id := Etype (Scope_Id); - -- The result type of the function - - Utyp : constant Entity_Id := Underlying_Type (R_Type); - - Exp : constant Node_Id := Expression (N); - pragma Assert (Present (Exp)); - - Exptyp : constant Entity_Id := Etype (Exp); - -- The type of the expression (not necessarily the same as R_Type) - - Subtype_Ind : Node_Id; - -- If the result type of the function is class-wide and the - -- expression has a specific type, then we use the expression's - -- type as the type of the return object. In cases where the - -- expression is an aggregate that is built in place, this avoids - -- the need for an expensive conversion of the return object to - -- the specific type on assignments to the individual components. - - begin - if Is_Class_Wide_Type (R_Type) - and then not Is_Class_Wide_Type (Etype (Exp)) - then - Subtype_Ind := New_Occurrence_Of (Etype (Exp), Loc); - else - Subtype_Ind := New_Occurrence_Of (R_Type, Loc); - end if; - - -- For the case of a simple return that does not come from an extended - -- return, in the case of Ada 2005 where we are returning a limited - -- type, we rewrite "return ;" to be: - - -- return _anon_ : := - - -- The expansion produced by Expand_N_Extended_Return_Statement will - -- contain simple return statements (for example, a block containing - -- simple return of the return object), which brings us back here with - -- Comes_From_Extended_Return_Statement set. The reason for the barrier - -- checking for a simple return that does not come from an extended - -- return is to avoid this infinite recursion. - - -- The reason for this design is that for Ada 2005 limited returns, we - -- need to reify the return object, so we can build it "in place", and - -- we need a block statement to hang finalization and tasking stuff. - - -- ??? In order to avoid disruption, we avoid translating to extended - -- return except in the cases where we really need to (Ada 2005 for - -- inherently limited). We might prefer to do this translation in all - -- cases (except perhaps for the case of Ada 95 inherently limited), - -- in order to fully exercise the Expand_N_Extended_Return_Statement - -- code. This would also allow us to do the build-in-place optimization - -- for efficiency even in cases where it is semantically not required. - - -- As before, we check the type of the return expression rather than the - -- return type of the function, because the latter may be a limited - -- class-wide interface type, which is not a limited type, even though - -- the type of the expression may be. - - if not Comes_From_Extended_Return_Statement (N) - and then Is_Immutably_Limited_Type (Etype (Expression (N))) - and then Ada_Version >= Ada_05 - and then not Debug_Flag_Dot_L - then - declare - Return_Object_Entity : constant Entity_Id := - Make_Temporary (Loc, 'R', Exp); - Obj_Decl : constant Node_Id := - Make_Object_Declaration (Loc, - Defining_Identifier => Return_Object_Entity, - Object_Definition => Subtype_Ind, - Expression => Exp); - - Ext : constant Node_Id := Make_Extended_Return_Statement (Loc, - Return_Object_Declarations => New_List (Obj_Decl)); - -- Do not perform this high-level optimization if the result type - -- is an interface because the "this" pointer must be displaced. - - begin - Rewrite (N, Ext); - Analyze (N); - return; - end; - end if; - - -- Here we have a simple return statement that is part of the expansion - -- of an extended return statement (either written by the user, or - -- generated by the above code). - - -- Always normalize C/Fortran boolean result. This is not always needed, - -- but it seems a good idea to minimize the passing around of non- - -- normalized values, and in any case this handles the processing of - -- barrier functions for protected types, which turn the condition into - -- a return statement. - - if Is_Boolean_Type (Exptyp) - and then Nonzero_Is_True (Exptyp) - then - Adjust_Condition (Exp); - Adjust_Result_Type (Exp, Exptyp); - end if; - - -- Do validity check if enabled for returns - - if Validity_Checks_On - and then Validity_Check_Returns - then - Ensure_Valid (Exp); - end if; - - -- Check the result expression of a scalar function against the subtype - -- of the function by inserting a conversion. This conversion must - -- eventually be performed for other classes of types, but for now it's - -- only done for scalars. - -- ??? - - if Is_Scalar_Type (Exptyp) then - Rewrite (Exp, Convert_To (R_Type, Exp)); - - -- The expression is resolved to ensure that the conversion gets - -- expanded to generate a possible constraint check. - - Analyze_And_Resolve (Exp, R_Type); - end if; - - -- Deal with returning variable length objects and controlled types - - -- Nothing to do if we are returning by reference, or this is not a - -- type that requires special processing (indicated by the fact that - -- it requires a cleanup scope for the secondary stack case). - - if Is_Immutably_Limited_Type (Exptyp) - or else Is_Limited_Interface (Exptyp) - then - null; - - elsif not Requires_Transient_Scope (R_Type) then - - -- Mutable records with no variable length components are not - -- returned on the sec-stack, so we need to make sure that the - -- backend will only copy back the size of the actual value, and not - -- the maximum size. We create an actual subtype for this purpose. - - declare - Ubt : constant Entity_Id := Underlying_Type (Base_Type (Exptyp)); - Decl : Node_Id; - Ent : Entity_Id; - begin - if Has_Discriminants (Ubt) - and then not Is_Constrained (Ubt) - and then not Has_Unchecked_Union (Ubt) - then - Decl := Build_Actual_Subtype (Ubt, Exp); - Ent := Defining_Identifier (Decl); - Insert_Action (Exp, Decl); - Rewrite (Exp, Unchecked_Convert_To (Ent, Exp)); - Analyze_And_Resolve (Exp); - end if; - end; - - -- Here if secondary stack is used - - else - -- Make sure that no surrounding block will reclaim the secondary - -- stack on which we are going to put the result. Not only may this - -- introduce secondary stack leaks but worse, if the reclamation is - -- done too early, then the result we are returning may get - -- clobbered. - - declare - S : Entity_Id; - begin - S := Current_Scope; - while Ekind (S) = E_Block or else Ekind (S) = E_Loop loop - Set_Sec_Stack_Needed_For_Return (S, True); - S := Enclosing_Dynamic_Scope (S); - end loop; - end; - - -- Optimize the case where the result is a function call. In this - -- case either the result is already on the secondary stack, or is - -- already being returned with the stack pointer depressed and no - -- further processing is required except to set the By_Ref flag to - -- ensure that gigi does not attempt an extra unnecessary copy. - -- (actually not just unnecessary but harmfully wrong in the case - -- of a controlled type, where gigi does not know how to do a copy). - -- To make up for a gcc 2.8.1 deficiency (???), we perform - -- the copy for array types if the constrained status of the - -- target type is different from that of the expression. - - if Requires_Transient_Scope (Exptyp) - and then - (not Is_Array_Type (Exptyp) - or else Is_Constrained (Exptyp) = Is_Constrained (R_Type) - or else CW_Or_Has_Controlled_Part (Utyp)) - and then Nkind (Exp) = N_Function_Call - then - Set_By_Ref (N); - - -- Remove side effects from the expression now so that other parts - -- of the expander do not have to reanalyze this node without this - -- optimization - - Rewrite (Exp, Duplicate_Subexpr_No_Checks (Exp)); - - -- For controlled types, do the allocation on the secondary stack - -- manually in order to call adjust at the right time: - - -- type Anon1 is access R_Type; - -- for Anon1'Storage_pool use ss_pool; - -- Anon2 : anon1 := new R_Type'(expr); - -- return Anon2.all; - - -- We do the same for classwide types that are not potentially - -- controlled (by the virtue of restriction No_Finalization) because - -- gigi is not able to properly allocate class-wide types. - - elsif CW_Or_Has_Controlled_Part (Utyp) then - declare - Loc : constant Source_Ptr := Sloc (N); - Acc_Typ : constant Entity_Id := Make_Temporary (Loc, 'A'); - Alloc_Node : Node_Id; - Temp : Entity_Id; - - begin - Set_Ekind (Acc_Typ, E_Access_Type); - - Set_Associated_Storage_Pool (Acc_Typ, RTE (RE_SS_Pool)); - - -- This is an allocator for the secondary stack, and it's fine - -- to have Comes_From_Source set False on it, as gigi knows not - -- to flag it as a violation of No_Implicit_Heap_Allocations. - - Alloc_Node := - Make_Allocator (Loc, - Expression => - Make_Qualified_Expression (Loc, - Subtype_Mark => New_Reference_To (Etype (Exp), Loc), - Expression => Relocate_Node (Exp))); - - -- We do not want discriminant checks on the declaration, - -- given that it gets its value from the allocator. - - Set_No_Initialization (Alloc_Node); - - Temp := Make_Temporary (Loc, 'R', Alloc_Node); - - Insert_List_Before_And_Analyze (N, New_List ( - Make_Full_Type_Declaration (Loc, - Defining_Identifier => Acc_Typ, - Type_Definition => - Make_Access_To_Object_Definition (Loc, - Subtype_Indication => Subtype_Ind)), - - Make_Object_Declaration (Loc, - Defining_Identifier => Temp, - Object_Definition => New_Reference_To (Acc_Typ, Loc), - Expression => Alloc_Node))); - - Rewrite (Exp, - Make_Explicit_Dereference (Loc, - Prefix => New_Reference_To (Temp, Loc))); - - Analyze_And_Resolve (Exp, R_Type); - end; - - -- Otherwise use the gigi mechanism to allocate result on the - -- secondary stack. - - else - Check_Restriction (No_Secondary_Stack, N); - Set_Storage_Pool (N, RTE (RE_SS_Pool)); - - -- If we are generating code for the VM do not use - -- SS_Allocate since everything is heap-allocated anyway. - - if VM_Target = No_VM then - Set_Procedure_To_Call (N, RTE (RE_SS_Allocate)); - end if; - end if; - end if; - - -- Implement the rules of 6.5(8-10), which require a tag check in the - -- case of a limited tagged return type, and tag reassignment for - -- nonlimited tagged results. These actions are needed when the return - -- type is a specific tagged type and the result expression is a - -- conversion or a formal parameter, because in that case the tag of the - -- expression might differ from the tag of the specific result type. - - if Is_Tagged_Type (Utyp) - and then not Is_Class_Wide_Type (Utyp) - and then (Nkind_In (Exp, N_Type_Conversion, - N_Unchecked_Type_Conversion) - or else (Is_Entity_Name (Exp) - and then Ekind (Entity (Exp)) in Formal_Kind)) - then - -- When the return type is limited, perform a check that the - -- tag of the result is the same as the tag of the return type. - - if Is_Limited_Type (R_Type) then - Insert_Action (Exp, - Make_Raise_Constraint_Error (Loc, - Condition => - Make_Op_Ne (Loc, - Left_Opnd => - Make_Selected_Component (Loc, - Prefix => Duplicate_Subexpr (Exp), - Selector_Name => - Make_Identifier (Loc, Chars => Name_uTag)), - Right_Opnd => - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Base_Type (Utyp), Loc), - Attribute_Name => Name_Tag)), - Reason => CE_Tag_Check_Failed)); - - -- If the result type is a specific nonlimited tagged type, then we - -- have to ensure that the tag of the result is that of the result - -- type. This is handled by making a copy of the expression in the - -- case where it might have a different tag, namely when the - -- expression is a conversion or a formal parameter. We create a new - -- object of the result type and initialize it from the expression, - -- which will implicitly force the tag to be set appropriately. - - else - declare - ExpR : constant Node_Id := Relocate_Node (Exp); - Result_Id : constant Entity_Id := - Make_Temporary (Loc, 'R', ExpR); - Result_Exp : constant Node_Id := - New_Reference_To (Result_Id, Loc); - Result_Obj : constant Node_Id := - Make_Object_Declaration (Loc, - Defining_Identifier => Result_Id, - Object_Definition => - New_Reference_To (R_Type, Loc), - Constant_Present => True, - Expression => ExpR); - - begin - Set_Assignment_OK (Result_Obj); - Insert_Action (Exp, Result_Obj); - - Rewrite (Exp, Result_Exp); - Analyze_And_Resolve (Exp, R_Type); - end; - end if; - - -- Ada 2005 (AI-344): If the result type is class-wide, then insert - -- a check that the level of the return expression's underlying type - -- is not deeper than the level of the master enclosing the function. - -- Always generate the check when the type of the return expression - -- is class-wide, when it's a type conversion, or when it's a formal - -- parameter. Otherwise, suppress the check in the case where the - -- return expression has a specific type whose level is known not to - -- be statically deeper than the function's result type. - - -- Note: accessibility check is skipped in the VM case, since there - -- does not seem to be any practical way to implement this check. - - elsif Ada_Version >= Ada_05 - and then Tagged_Type_Expansion - and then Is_Class_Wide_Type (R_Type) - and then not Scope_Suppress (Accessibility_Check) - and then - (Is_Class_Wide_Type (Etype (Exp)) - or else Nkind_In (Exp, N_Type_Conversion, - N_Unchecked_Type_Conversion) - or else (Is_Entity_Name (Exp) - and then Ekind (Entity (Exp)) in Formal_Kind) - or else Scope_Depth (Enclosing_Dynamic_Scope (Etype (Exp))) > - Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id))) - then - declare - Tag_Node : Node_Id; - - begin - -- Ada 2005 (AI-251): In class-wide interface objects we displace - -- "this" to reference the base of the object --- required to get - -- access to the TSD of the object. - - if Is_Class_Wide_Type (Etype (Exp)) - and then Is_Interface (Etype (Exp)) - and then Nkind (Exp) = N_Explicit_Dereference - then - Tag_Node := - Make_Explicit_Dereference (Loc, - Unchecked_Convert_To (RTE (RE_Tag_Ptr), - Make_Function_Call (Loc, - Name => New_Reference_To (RTE (RE_Base_Address), Loc), - Parameter_Associations => New_List ( - Unchecked_Convert_To (RTE (RE_Address), - Duplicate_Subexpr (Prefix (Exp))))))); - else - Tag_Node := - Make_Attribute_Reference (Loc, - Prefix => Duplicate_Subexpr (Exp), - Attribute_Name => Name_Tag); - end if; - - Insert_Action (Exp, - Make_Raise_Program_Error (Loc, - Condition => - Make_Op_Gt (Loc, - Left_Opnd => - Build_Get_Access_Level (Loc, Tag_Node), - Right_Opnd => - Make_Integer_Literal (Loc, - Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id)))), - Reason => PE_Accessibility_Check_Failed)); - end; - - -- AI05-0073: If function has a controlling access result, check that - -- the tag of the return value, if it is not null, matches designated - -- type of return type. - - -- The "or else True" needs commenting here ??? - - elsif Ekind (R_Type) = E_Anonymous_Access_Type - and then Has_Controlling_Result (Scope_Id) - then - Insert_Action (N, - Make_Raise_Constraint_Error (Loc, - Condition => - Make_And_Then (Loc, - Left_Opnd => - Make_Op_Ne (Loc, - Left_Opnd => Exp, - Right_Opnd => Make_Null (Loc)), - Right_Opnd => Make_Op_Ne (Loc, - Left_Opnd => - Make_Selected_Component (Loc, - Prefix => Duplicate_Subexpr (Exp), - Selector_Name => - Make_Identifier (Loc, Chars => Name_uTag)), - Right_Opnd => - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Designated_Type (R_Type), Loc), - Attribute_Name => Name_Tag))), - Reason => CE_Tag_Check_Failed), - Suppress => All_Checks); - end if; - - -- If we are returning an object that may not be bit-aligned, then copy - -- the value into a temporary first. This copy may need to expand to a - -- loop of component operations. - - if Is_Possibly_Unaligned_Slice (Exp) - or else Is_Possibly_Unaligned_Object (Exp) - then - declare - ExpR : constant Node_Id := Relocate_Node (Exp); - Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', ExpR); - begin - Insert_Action (Exp, - Make_Object_Declaration (Loc, - Defining_Identifier => Tnn, - Constant_Present => True, - Object_Definition => New_Occurrence_Of (R_Type, Loc), - Expression => ExpR), - Suppress => All_Checks); - Rewrite (Exp, New_Occurrence_Of (Tnn, Loc)); - end; - end if; - - -- Generate call to postcondition checks if they are present - - if Ekind (Scope_Id) = E_Function - and then Has_Postconditions (Scope_Id) - then - -- We are going to reference the returned value twice in this case, - -- once in the call to _Postconditions, and once in the actual return - -- statement, but we can't have side effects happening twice, and in - -- any case for efficiency we don't want to do the computation twice. - - -- If the returned expression is an entity name, we don't need to - -- worry since it is efficient and safe to reference it twice, that's - -- also true for literals other than string literals, and for the - -- case of X.all where X is an entity name. - - if Is_Entity_Name (Exp) - or else Nkind_In (Exp, N_Character_Literal, - N_Integer_Literal, - N_Real_Literal) - or else (Nkind (Exp) = N_Explicit_Dereference - and then Is_Entity_Name (Prefix (Exp))) - then - null; - - -- Otherwise we are going to need a temporary to capture the value - - else - declare - ExpR : constant Node_Id := Relocate_Node (Exp); - Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', ExpR); - - begin - -- For a complex expression of an elementary type, capture - -- value in the temporary and use it as the reference. - - if Is_Elementary_Type (R_Type) then - Insert_Action (Exp, - Make_Object_Declaration (Loc, - Defining_Identifier => Tnn, - Constant_Present => True, - Object_Definition => New_Occurrence_Of (R_Type, Loc), - Expression => ExpR), - Suppress => All_Checks); - - Rewrite (Exp, New_Occurrence_Of (Tnn, Loc)); - - -- If we have something we can rename, generate a renaming of - -- the object and replace the expression with a reference - - elsif Is_Object_Reference (Exp) then - Insert_Action (Exp, - Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => Tnn, - Subtype_Mark => New_Occurrence_Of (R_Type, Loc), - Name => ExpR), - Suppress => All_Checks); - - Rewrite (Exp, New_Occurrence_Of (Tnn, Loc)); - - -- Otherwise we have something like a string literal or an - -- aggregate. We could copy the value, but that would be - -- inefficient. Instead we make a reference to the value and - -- capture this reference with a renaming, the expression is - -- then replaced by a dereference of this renaming. - - else - -- For now, copy the value, since the code below does not - -- seem to work correctly ??? - - Insert_Action (Exp, - Make_Object_Declaration (Loc, - Defining_Identifier => Tnn, - Constant_Present => True, - Object_Definition => New_Occurrence_Of (R_Type, Loc), - Expression => Relocate_Node (Exp)), - Suppress => All_Checks); - - Rewrite (Exp, New_Occurrence_Of (Tnn, Loc)); - - -- Insert_Action (Exp, - -- Make_Object_Renaming_Declaration (Loc, - -- Defining_Identifier => Tnn, - -- Access_Definition => - -- Make_Access_Definition (Loc, - -- All_Present => True, - -- Subtype_Mark => New_Occurrence_Of (R_Type, Loc)), - -- Name => - -- Make_Reference (Loc, - -- Prefix => Relocate_Node (Exp))), - -- Suppress => All_Checks); - - -- Rewrite (Exp, - -- Make_Explicit_Dereference (Loc, - -- Prefix => New_Occurrence_Of (Tnn, Loc))); - end if; - end; - end if; - - -- Generate call to _postconditions - - Insert_Action (Exp, - Make_Procedure_Call_Statement (Loc, - Name => Make_Identifier (Loc, Name_uPostconditions), - Parameter_Associations => New_List (Duplicate_Subexpr (Exp)))); - end if; - - -- Ada 2005 (AI-251): If this return statement corresponds with an - -- simple return statement associated with an extended return statement - -- and the type of the returned object is an interface then generate an - -- implicit conversion to force displacement of the "this" pointer. - - if Ada_Version >= Ada_05 - and then Comes_From_Extended_Return_Statement (N) - and then Nkind (Expression (N)) = N_Identifier - and then Is_Interface (Utyp) - and then Utyp /= Underlying_Type (Exptyp) - then - Rewrite (Exp, Convert_To (Utyp, Relocate_Node (Exp))); - Analyze_And_Resolve (Exp); - end if; - end Expand_Simple_Function_Return; - ------------------------------ -- Make_Tag_Ctrl_Assignment -- ------------------------------ diff --git a/gcc/ada/exp_ch5.ads b/gcc/ada/exp_ch5.ads index 0c9948dcd549..7967164729d4 100644 --- a/gcc/ada/exp_ch5.ads +++ b/gcc/ada/exp_ch5.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -32,9 +32,7 @@ package Exp_Ch5 is procedure Expand_N_Block_Statement (N : Node_Id); procedure Expand_N_Case_Statement (N : Node_Id); procedure Expand_N_Exit_Statement (N : Node_Id); - procedure Expand_N_Extended_Return_Statement (N : Node_Id); procedure Expand_N_Goto_Statement (N : Node_Id); procedure Expand_N_If_Statement (N : Node_Id); procedure Expand_N_Loop_Statement (N : Node_Id); - procedure Expand_N_Simple_Return_Statement (N : Node_Id); end Exp_Ch5; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index d94117f41fdd..c439a91e01dd 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -69,6 +69,7 @@ with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; +with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; with Validsw; use Validsw; @@ -202,6 +203,12 @@ package body Exp_Ch6 is -- expressions in the body must be converted to the desired type (which -- is simply not noted in the tree without inline expansion). + procedure Expand_Non_Function_Return (N : Node_Id); + -- Called by Expand_N_Simple_Return_Statement in case we're returning from + -- a procedure body, entry body, accept statement, or extended return + -- statement. Note that all non-function returns are simple return + -- statements. + function Expand_Protected_Object_Reference (N : Node_Id; Scop : Entity_Id) return Node_Id; @@ -219,6 +226,10 @@ package body Exp_Ch6 is -- Predicate to recognize stubbed procedures and null procedures, which -- can be inlined unconditionally in all cases. + procedure Expand_Simple_Function_Return (N : Node_Id); + -- Expand simple return from function. In the case where we are returning + -- from a function body this is called by Expand_N_Simple_Return_Statement. + ---------------------------------------------- -- Add_Access_Actual_To_Build_In_Place_Call -- ---------------------------------------------- @@ -4076,6 +4087,728 @@ package body Exp_Ch6 is end loop; end Expand_Inlined_Call; + ---------------------------------------- + -- Expand_N_Extended_Return_Statement -- + ---------------------------------------- + + -- If there is a Handled_Statement_Sequence, we rewrite this: + + -- return Result : T := do + -- + -- end return; + + -- to be: + + -- declare + -- Result : T := ; + -- begin + -- + -- return Result; + -- end; + + -- Otherwise (no Handled_Statement_Sequence), we rewrite this: + + -- return Result : T := ; + + -- to be: + + -- return ; + + -- unless it's build-in-place or there's no , in which case + -- we generate: + + -- declare + -- Result : T := ; + -- begin + -- return Result; + -- end; + + -- Note that this case could have been written by the user as an extended + -- return statement, or could have been transformed to this from a simple + -- return statement. + + -- That is, we need to have a reified return object if there are statements + -- (which might refer to it) or if we're doing build-in-place (so we can + -- set its address to the final resting place or if there is no expression + -- (in which case default initial values might need to be set). + + procedure Expand_N_Extended_Return_Statement (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + + Return_Object_Entity : constant Entity_Id := + First_Entity (Return_Statement_Entity (N)); + Return_Object_Decl : constant Node_Id := + Parent (Return_Object_Entity); + Parent_Function : constant Entity_Id := + Return_Applies_To (Return_Statement_Entity (N)); + Parent_Function_Typ : constant Entity_Id := Etype (Parent_Function); + Is_Build_In_Place : constant Boolean := + Is_Build_In_Place_Function (Parent_Function); + + Return_Stm : Node_Id; + Statements : List_Id; + Handled_Stm_Seq : Node_Id; + Result : Node_Id; + Exp : Node_Id; + + function Has_Controlled_Parts (Typ : Entity_Id) return Boolean; + -- Determine whether type Typ is controlled or contains a controlled + -- subcomponent. + + function Move_Activation_Chain return Node_Id; + -- Construct a call to System.Tasking.Stages.Move_Activation_Chain + -- with parameters: + -- From current activation chain + -- To activation chain passed in by the caller + -- New_Master master passed in by the caller + + function Move_Final_List return Node_Id; + -- Construct call to System.Finalization_Implementation.Move_Final_List + -- with parameters: + -- + -- From finalization list of the return statement + -- To finalization list passed in by the caller + + -------------------------- + -- Has_Controlled_Parts -- + -------------------------- + + function Has_Controlled_Parts (Typ : Entity_Id) return Boolean is + begin + return + Is_Controlled (Typ) + or else Has_Controlled_Component (Typ); + end Has_Controlled_Parts; + + --------------------------- + -- Move_Activation_Chain -- + --------------------------- + + function Move_Activation_Chain return Node_Id is + Activation_Chain_Formal : constant Entity_Id := + Build_In_Place_Formal + (Parent_Function, BIP_Activation_Chain); + To : constant Node_Id := + New_Reference_To + (Activation_Chain_Formal, Loc); + Master_Formal : constant Entity_Id := + Build_In_Place_Formal + (Parent_Function, BIP_Master); + New_Master : constant Node_Id := + New_Reference_To (Master_Formal, Loc); + + Chain_Entity : Entity_Id; + From : Node_Id; + + begin + Chain_Entity := First_Entity (Return_Statement_Entity (N)); + while Chars (Chain_Entity) /= Name_uChain loop + Chain_Entity := Next_Entity (Chain_Entity); + end loop; + + From := + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Chain_Entity, Loc), + Attribute_Name => Name_Unrestricted_Access); + -- ??? Not clear why "Make_Identifier (Loc, Name_uChain)" doesn't + -- work, instead of "New_Reference_To (Chain_Entity, Loc)" above. + + return + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Move_Activation_Chain), Loc), + Parameter_Associations => New_List (From, To, New_Master)); + end Move_Activation_Chain; + + --------------------- + -- Move_Final_List -- + --------------------- + + function Move_Final_List return Node_Id is + Flist : constant Entity_Id := + Finalization_Chain_Entity (Return_Statement_Entity (N)); + + From : constant Node_Id := New_Reference_To (Flist, Loc); + + Caller_Final_List : constant Entity_Id := + Build_In_Place_Formal + (Parent_Function, BIP_Final_List); + + To : constant Node_Id := New_Reference_To (Caller_Final_List, Loc); + + begin + -- Catch cases where a finalization chain entity has not been + -- associated with the return statement entity. + + pragma Assert (Present (Flist)); + + -- Build required call + + return + Make_If_Statement (Loc, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => New_Copy (From), + Right_Opnd => New_Node (N_Null, Loc)), + Then_Statements => + New_List ( + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Move_Final_List), Loc), + Parameter_Associations => New_List (From, To)))); + end Move_Final_List; + + -- Start of processing for Expand_N_Extended_Return_Statement + + begin + if Nkind (Return_Object_Decl) = N_Object_Declaration then + Exp := Expression (Return_Object_Decl); + else + Exp := Empty; + end if; + + Handled_Stm_Seq := Handled_Statement_Sequence (N); + + -- Build a simple_return_statement that returns the return object when + -- there is a statement sequence, or no expression, or the result will + -- be built in place. Note however that we currently do this for all + -- composite cases, even though nonlimited composite results are not yet + -- built in place (though we plan to do so eventually). + + if Present (Handled_Stm_Seq) + or else Is_Composite_Type (Etype (Parent_Function)) + or else No (Exp) + then + if No (Handled_Stm_Seq) then + Statements := New_List; + + -- If the extended return has a handled statement sequence, then wrap + -- it in a block and use the block as the first statement. + + else + Statements := + New_List (Make_Block_Statement (Loc, + Declarations => New_List, + Handled_Statement_Sequence => Handled_Stm_Seq)); + end if; + + -- If control gets past the above Statements, we have successfully + -- completed the return statement. If the result type has controlled + -- parts and the return is for a build-in-place function, then we + -- call Move_Final_List to transfer responsibility for finalization + -- of the return object to the caller. An alternative would be to + -- declare a Success flag in the function, initialize it to False, + -- and set it to True here. Then move the Move_Final_List call into + -- the cleanup code, and check Success. If Success then make a call + -- to Move_Final_List else do finalization. Then we can remove the + -- abort-deferral and the nulling-out of the From parameter from + -- Move_Final_List. Note that the current method is not quite correct + -- in the rather obscure case of a select-then-abort statement whose + -- abortable part contains the return statement. + + -- Check the type of the function to determine whether to move the + -- finalization list. A special case arises when processing a simple + -- return statement which has been rewritten as an extended return. + -- In that case check the type of the returned object or the original + -- expression. + + if Is_Build_In_Place + and then + (Has_Controlled_Parts (Parent_Function_Typ) + or else (Is_Class_Wide_Type (Parent_Function_Typ) + and then + Has_Controlled_Parts (Root_Type (Parent_Function_Typ))) + or else Has_Controlled_Parts (Etype (Return_Object_Entity)) + or else (Present (Exp) + and then Has_Controlled_Parts (Etype (Exp)))) + then + Append_To (Statements, Move_Final_List); + end if; + + -- Similarly to the above Move_Final_List, if the result type + -- contains tasks, we call Move_Activation_Chain. Later, the cleanup + -- code will call Complete_Master, which will terminate any + -- unactivated tasks belonging to the return statement master. But + -- Move_Activation_Chain updates their master to be that of the + -- caller, so they will not be terminated unless the return statement + -- completes unsuccessfully due to exception, abort, goto, or exit. + -- As a formality, we test whether the function requires the result + -- to be built in place, though that's necessarily true for the case + -- of result types with task parts. + + if Is_Build_In_Place and Has_Task (Etype (Parent_Function)) then + Append_To (Statements, Move_Activation_Chain); + end if; + + -- Build a simple_return_statement that returns the return object + + Return_Stm := + Make_Simple_Return_Statement (Loc, + Expression => New_Occurrence_Of (Return_Object_Entity, Loc)); + Append_To (Statements, Return_Stm); + + Handled_Stm_Seq := + Make_Handled_Sequence_Of_Statements (Loc, Statements); + end if; + + -- Case where we build a block + + if Present (Handled_Stm_Seq) then + Result := + Make_Block_Statement (Loc, + Declarations => Return_Object_Declarations (N), + Handled_Statement_Sequence => Handled_Stm_Seq); + + -- We set the entity of the new block statement to be that of the + -- return statement. This is necessary so that various fields, such + -- as Finalization_Chain_Entity carry over from the return statement + -- to the block. Note that this block is unusual, in that its entity + -- is an E_Return_Statement rather than an E_Block. + + Set_Identifier + (Result, New_Occurrence_Of (Return_Statement_Entity (N), Loc)); + + -- If the object decl was already rewritten as a renaming, then + -- we don't want to do the object allocation and transformation of + -- of the return object declaration to a renaming. This case occurs + -- when the return object is initialized by a call to another + -- build-in-place function, and that function is responsible for the + -- allocation of the return object. + + if Is_Build_In_Place + and then + Nkind (Return_Object_Decl) = N_Object_Renaming_Declaration + then + pragma Assert (Nkind (Original_Node (Return_Object_Decl)) = + N_Object_Declaration + and then Is_Build_In_Place_Function_Call + (Expression (Original_Node (Return_Object_Decl)))); + + Set_By_Ref (Return_Stm); -- Return build-in-place results by ref + + elsif Is_Build_In_Place then + + -- Locate the implicit access parameter associated with the + -- caller-supplied return object and convert the return + -- statement's return object declaration to a renaming of a + -- dereference of the access parameter. If the return object's + -- declaration includes an expression that has not already been + -- expanded as separate assignments, then add an assignment + -- statement to ensure the return object gets initialized. + + -- declare + -- Result : T [:= ]; + -- begin + -- ... + + -- is converted to + + -- declare + -- Result : T renames FuncRA.all; + -- [Result := New_Reference_To (Return_Obj_Id, Loc), + Expression => Relocate_Node (Return_Obj_Expr)); + Set_Etype (Name (Init_Assignment), Etype (Return_Obj_Id)); + Set_Assignment_OK (Name (Init_Assignment)); + Set_No_Ctrl_Actions (Init_Assignment); + + Set_Parent (Name (Init_Assignment), Init_Assignment); + Set_Parent (Expression (Init_Assignment), Init_Assignment); + + Set_Expression (Return_Object_Decl, Empty); + + if Is_Class_Wide_Type (Etype (Return_Obj_Id)) + and then not Is_Class_Wide_Type + (Etype (Expression (Init_Assignment))) + then + Rewrite (Expression (Init_Assignment), + Make_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of + (Etype (Return_Obj_Id), Loc), + Expression => + Relocate_Node (Expression (Init_Assignment)))); + end if; + + -- In the case of functions where the calling context can + -- determine the form of allocation needed, initialization + -- is done with each part of the if statement that handles + -- the different forms of allocation (this is true for + -- unconstrained and tagged result subtypes). + + if Constr_Result + and then not Is_Tagged_Type (Underlying_Type (Result_Subt)) + then + Insert_After (Return_Object_Decl, Init_Assignment); + end if; + end if; + + -- When the function's subtype is unconstrained, a run-time + -- test is needed to determine the form of allocation to use + -- for the return object. The function has an implicit formal + -- parameter indicating this. If the BIP_Alloc_Form formal has + -- the value one, then the caller has passed access to an + -- existing object for use as the return object. If the value + -- is two, then the return object must be allocated on the + -- secondary stack. Otherwise, the object must be allocated in + -- a storage pool (currently only supported for the global + -- heap, user-defined storage pools TBD ???). We generate an + -- if statement to test the implicit allocation formal and + -- initialize a local access value appropriately, creating + -- allocators in the secondary stack and global heap cases. + -- The special formal also exists and must be tested when the + -- function has a tagged result, even when the result subtype + -- is constrained, because in general such functions can be + -- called in dispatching contexts and must be handled similarly + -- to functions with a class-wide result. + + if not Constr_Result + or else Is_Tagged_Type (Underlying_Type (Result_Subt)) + then + Obj_Alloc_Formal := + Build_In_Place_Formal (Parent_Function, BIP_Alloc_Form); + + declare + Ref_Type : Entity_Id; + Ptr_Type_Decl : Node_Id; + Alloc_Obj_Id : Entity_Id; + Alloc_Obj_Decl : Node_Id; + Alloc_If_Stmt : Node_Id; + SS_Allocator : Node_Id; + Heap_Allocator : Node_Id; + + begin + -- Reuse the itype created for the function's implicit + -- access formal. This avoids the need to create a new + -- access type here, plus it allows assigning the access + -- formal directly without applying a conversion. + + -- Ref_Type := Etype (Object_Access); + + -- Create an access type designating the function's + -- result subtype. + + Ref_Type := Make_Temporary (Loc, 'A'); + + Ptr_Type_Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Ref_Type, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Subtype_Indication => + New_Reference_To (Return_Obj_Typ, Loc))); + + Insert_Before (Return_Object_Decl, Ptr_Type_Decl); + + -- Create an access object that will be initialized to an + -- access value denoting the return object, either coming + -- from an implicit access value passed in by the caller + -- or from the result of an allocator. + + Alloc_Obj_Id := Make_Temporary (Loc, 'R'); + Set_Etype (Alloc_Obj_Id, Ref_Type); + + Alloc_Obj_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Alloc_Obj_Id, + Object_Definition => New_Reference_To + (Ref_Type, Loc)); + + Insert_Before (Return_Object_Decl, Alloc_Obj_Decl); + + -- Create allocators for both the secondary stack and + -- global heap. If there's an initialization expression, + -- then create these as initialized allocators. + + if Present (Return_Obj_Expr) + and then not No_Initialization (Return_Object_Decl) + then + -- Always use the type of the expression for the + -- qualified expression, rather than the result type. + -- In general we cannot always use the result type + -- for the allocator, because the expression might be + -- of a specific type, such as in the case of an + -- aggregate or even a nonlimited object when the + -- result type is a limited class-wide interface type. + + Heap_Allocator := + Make_Allocator (Loc, + Expression => + Make_Qualified_Expression (Loc, + Subtype_Mark => + New_Reference_To + (Etype (Return_Obj_Expr), Loc), + Expression => + New_Copy_Tree (Return_Obj_Expr))); + + else + -- If the function returns a class-wide type we cannot + -- use the return type for the allocator. Instead we + -- use the type of the expression, which must be an + -- aggregate of a definite type. + + if Is_Class_Wide_Type (Return_Obj_Typ) then + Heap_Allocator := + Make_Allocator (Loc, + Expression => + New_Reference_To + (Etype (Return_Obj_Expr), Loc)); + else + Heap_Allocator := + Make_Allocator (Loc, + Expression => + New_Reference_To (Return_Obj_Typ, Loc)); + end if; + + -- If the object requires default initialization then + -- that will happen later following the elaboration of + -- the object renaming. If we don't turn it off here + -- then the object will be default initialized twice. + + Set_No_Initialization (Heap_Allocator); + end if; + + -- If the No_Allocators restriction is active, then only + -- an allocator for secondary stack allocation is needed. + -- It's OK for such allocators to have Comes_From_Source + -- set to False, because gigi knows not to flag them as + -- being a violation of No_Implicit_Heap_Allocations. + + if Restriction_Active (No_Allocators) then + SS_Allocator := Heap_Allocator; + Heap_Allocator := Make_Null (Loc); + + -- Otherwise the heap allocator may be needed, so we make + -- another allocator for secondary stack allocation. + + else + SS_Allocator := New_Copy_Tree (Heap_Allocator); + + -- The heap allocator is marked Comes_From_Source + -- since it corresponds to an explicit user-written + -- allocator (that is, it will only be executed on + -- behalf of callers that call the function as + -- initialization for such an allocator). This + -- prevents errors when No_Implicit_Heap_Allocations + -- is in force. + + Set_Comes_From_Source (Heap_Allocator, True); + end if; + + -- The allocator is returned on the secondary stack. We + -- don't do this on VM targets, since the SS is not used. + + if VM_Target = No_VM then + Set_Storage_Pool (SS_Allocator, RTE (RE_SS_Pool)); + Set_Procedure_To_Call + (SS_Allocator, RTE (RE_SS_Allocate)); + + -- The allocator is returned on the secondary stack, + -- so indicate that the function return, as well as + -- the block that encloses the allocator, must not + -- release it. The flags must be set now because the + -- decision to use the secondary stack is done very + -- late in the course of expanding the return + -- statement, past the point where these flags are + -- normally set. + + Set_Sec_Stack_Needed_For_Return (Parent_Function); + Set_Sec_Stack_Needed_For_Return + (Return_Statement_Entity (N)); + Set_Uses_Sec_Stack (Parent_Function); + Set_Uses_Sec_Stack (Return_Statement_Entity (N)); + end if; + + -- Create an if statement to test the BIP_Alloc_Form + -- formal and initialize the access object to either the + -- BIP_Object_Access formal (BIP_Alloc_Form = 0), the + -- result of allocating the object in the secondary stack + -- (BIP_Alloc_Form = 1), or else an allocator to create + -- the return object in the heap (BIP_Alloc_Form = 2). + + -- ??? An unchecked type conversion must be made in the + -- case of assigning the access object formal to the + -- local access object, because a normal conversion would + -- be illegal in some cases (such as converting access- + -- to-unconstrained to access-to-constrained), but the + -- the unchecked conversion will presumably fail to work + -- right in just such cases. It's not clear at all how to + -- handle this. ??? + + Alloc_If_Stmt := + Make_If_Statement (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To (Obj_Alloc_Formal, Loc), + Right_Opnd => + Make_Integer_Literal (Loc, + UI_From_Int (BIP_Allocation_Form'Pos + (Caller_Allocation)))), + Then_Statements => + New_List (Make_Assignment_Statement (Loc, + Name => + New_Reference_To + (Alloc_Obj_Id, Loc), + Expression => + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => + New_Reference_To (Ref_Type, Loc), + Expression => + New_Reference_To + (Object_Access, Loc)))), + Elsif_Parts => + New_List (Make_Elsif_Part (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To + (Obj_Alloc_Formal, Loc), + Right_Opnd => + Make_Integer_Literal (Loc, + UI_From_Int ( + BIP_Allocation_Form'Pos + (Secondary_Stack)))), + Then_Statements => + New_List + (Make_Assignment_Statement (Loc, + Name => + New_Reference_To + (Alloc_Obj_Id, Loc), + Expression => + SS_Allocator)))), + Else_Statements => + New_List (Make_Assignment_Statement (Loc, + Name => + New_Reference_To + (Alloc_Obj_Id, Loc), + Expression => + Heap_Allocator))); + + -- If a separate initialization assignment was created + -- earlier, append that following the assignment of the + -- implicit access formal to the access object, to ensure + -- that the return object is initialized in that case. + -- In this situation, the target of the assignment must + -- be rewritten to denote a dereference of the access to + -- the return object passed in by the caller. + + if Present (Init_Assignment) then + Rewrite (Name (Init_Assignment), + Make_Explicit_Dereference (Loc, + Prefix => New_Reference_To (Alloc_Obj_Id, Loc))); + Set_Etype + (Name (Init_Assignment), Etype (Return_Obj_Id)); + + Append_To + (Then_Statements (Alloc_If_Stmt), + Init_Assignment); + end if; + + Insert_Before (Return_Object_Decl, Alloc_If_Stmt); + + -- Remember the local access object for use in the + -- dereference of the renaming created below. + + Object_Access := Alloc_Obj_Id; + end; + end if; + + -- Replace the return object declaration with a renaming of a + -- dereference of the access value designating the return + -- object. + + Obj_Acc_Deref := + Make_Explicit_Dereference (Loc, + Prefix => New_Reference_To (Object_Access, Loc)); + + Rewrite (Return_Object_Decl, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Return_Obj_Id, + Access_Definition => Empty, + Subtype_Mark => New_Occurrence_Of + (Return_Obj_Typ, Loc), + Name => Obj_Acc_Deref)); + + Set_Renamed_Object (Return_Obj_Id, Obj_Acc_Deref); + end; + end if; + + -- Case where we do not build a block + + else + -- We're about to drop Return_Object_Declarations on the floor, so + -- we need to insert it, in case it got expanded into useful code. + -- Remove side effects from expression, which may be duplicated in + -- subsequent checks (see Expand_Simple_Function_Return). + + Insert_List_Before (N, Return_Object_Declarations (N)); + Remove_Side_Effects (Exp); + + -- Build simple_return_statement that returns the expression directly + + Return_Stm := Make_Simple_Return_Statement (Loc, Expression => Exp); + + Result := Return_Stm; + end if; + + -- Set the flag to prevent infinite recursion + + Set_Comes_From_Extended_Return_Statement (Return_Stm); + + Rewrite (N, Result); + Analyze (N); + end Expand_N_Extended_Return_Statement; + ---------------------------- -- Expand_N_Function_Call -- ---------------------------- @@ -4109,6 +4842,45 @@ package body Exp_Ch6 is Expand_Call (N); end Expand_N_Procedure_Call_Statement; + -------------------------------------- + -- Expand_N_Simple_Return_Statement -- + -------------------------------------- + + procedure Expand_N_Simple_Return_Statement (N : Node_Id) is + begin + -- Defend against previous errors (i.e. the return statement calls a + -- function that is not available in configurable runtime). + + if Present (Expression (N)) + and then Nkind (Expression (N)) = N_Empty + then + return; + end if; + + -- Distinguish the function and non-function cases: + + case Ekind (Return_Applies_To (Return_Statement_Entity (N))) is + + when E_Function | + E_Generic_Function => + Expand_Simple_Function_Return (N); + + when E_Procedure | + E_Generic_Procedure | + E_Entry | + E_Entry_Family | + E_Return_Statement => + Expand_Non_Function_Return (N); + + when others => + raise Program_Error; + end case; + + exception + when RE_Not_Available => + return; + end Expand_N_Simple_Return_Statement; + ------------------------------ -- Expand_N_Subprogram_Body -- ------------------------------ @@ -4619,6 +5391,122 @@ package body Exp_Ch6 is end if; end Expand_N_Subprogram_Declaration; + -------------------------------- + -- Expand_Non_Function_Return -- + -------------------------------- + + procedure Expand_Non_Function_Return (N : Node_Id) is + pragma Assert (No (Expression (N))); + + Loc : constant Source_Ptr := Sloc (N); + Scope_Id : Entity_Id := + Return_Applies_To (Return_Statement_Entity (N)); + Kind : constant Entity_Kind := Ekind (Scope_Id); + Call : Node_Id; + Acc_Stat : Node_Id; + Goto_Stat : Node_Id; + Lab_Node : Node_Id; + + begin + -- Call _Postconditions procedure if procedure with active + -- postconditions. Here, we use the Postcondition_Proc attribute, which + -- is needed for implicitly-generated returns. Functions never + -- have implicitly-generated returns, and there's no room for + -- Postcondition_Proc in E_Function, so we look up the identifier + -- Name_uPostconditions for function returns (see + -- Expand_Simple_Function_Return). + + if Ekind (Scope_Id) = E_Procedure + and then Has_Postconditions (Scope_Id) + then + pragma Assert (Present (Postcondition_Proc (Scope_Id))); + Insert_Action (N, + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (Postcondition_Proc (Scope_Id), Loc))); + end if; + + -- If it is a return from a procedure do no extra steps + + if Kind = E_Procedure or else Kind = E_Generic_Procedure then + return; + + -- If it is a nested return within an extended one, replace it with a + -- return of the previously declared return object. + + elsif Kind = E_Return_Statement then + Rewrite (N, + Make_Simple_Return_Statement (Loc, + Expression => + New_Occurrence_Of (First_Entity (Scope_Id), Loc))); + Set_Comes_From_Extended_Return_Statement (N); + Set_Return_Statement_Entity (N, Scope_Id); + Expand_Simple_Function_Return (N); + return; + end if; + + pragma Assert (Is_Entry (Scope_Id)); + + -- Look at the enclosing block to see whether the return is from an + -- accept statement or an entry body. + + for J in reverse 0 .. Scope_Stack.Last loop + Scope_Id := Scope_Stack.Table (J).Entity; + exit when Is_Concurrent_Type (Scope_Id); + end loop; + + -- If it is a return from accept statement it is expanded as call to + -- RTS Complete_Rendezvous and a goto to the end of the accept body. + + -- (cf : Expand_N_Accept_Statement, Expand_N_Selective_Accept, + -- Expand_N_Accept_Alternative in exp_ch9.adb) + + if Is_Task_Type (Scope_Id) then + + Call := + Make_Procedure_Call_Statement (Loc, + Name => New_Reference_To (RTE (RE_Complete_Rendezvous), Loc)); + Insert_Before (N, Call); + -- why not insert actions here??? + Analyze (Call); + + Acc_Stat := Parent (N); + while Nkind (Acc_Stat) /= N_Accept_Statement loop + Acc_Stat := Parent (Acc_Stat); + end loop; + + Lab_Node := Last (Statements + (Handled_Statement_Sequence (Acc_Stat))); + + Goto_Stat := Make_Goto_Statement (Loc, + Name => New_Occurrence_Of + (Entity (Identifier (Lab_Node)), Loc)); + + Set_Analyzed (Goto_Stat); + + Rewrite (N, Goto_Stat); + Analyze (N); + + -- If it is a return from an entry body, put a Complete_Entry_Body call + -- in front of the return. + + elsif Is_Protected_Type (Scope_Id) then + Call := + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Complete_Entry_Body), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Reference_To + (Find_Protection_Object (Current_Scope), Loc), + Attribute_Name => + Name_Unchecked_Access))); + + Insert_Before (N, Call); + Analyze (Call); + end if; + end Expand_Non_Function_Return; + --------------------------------------- -- Expand_Protected_Object_Reference -- --------------------------------------- @@ -4789,6 +5677,608 @@ package body Exp_Ch6 is end if; end Expand_Protected_Subprogram_Call; + ----------------------------------- + -- Expand_Simple_Function_Return -- + ----------------------------------- + + -- The "simple" comes from the syntax rule simple_return_statement. + -- The semantics are not at all simple! + + procedure Expand_Simple_Function_Return (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + + Scope_Id : constant Entity_Id := + Return_Applies_To (Return_Statement_Entity (N)); + -- The function we are returning from + + R_Type : constant Entity_Id := Etype (Scope_Id); + -- The result type of the function + + Utyp : constant Entity_Id := Underlying_Type (R_Type); + + Exp : constant Node_Id := Expression (N); + pragma Assert (Present (Exp)); + + Exptyp : constant Entity_Id := Etype (Exp); + -- The type of the expression (not necessarily the same as R_Type) + + Subtype_Ind : Node_Id; + -- If the result type of the function is class-wide and the + -- expression has a specific type, then we use the expression's + -- type as the type of the return object. In cases where the + -- expression is an aggregate that is built in place, this avoids + -- the need for an expensive conversion of the return object to + -- the specific type on assignments to the individual components. + + begin + if Is_Class_Wide_Type (R_Type) + and then not Is_Class_Wide_Type (Etype (Exp)) + then + Subtype_Ind := New_Occurrence_Of (Etype (Exp), Loc); + else + Subtype_Ind := New_Occurrence_Of (R_Type, Loc); + end if; + + -- For the case of a simple return that does not come from an extended + -- return, in the case of Ada 2005 where we are returning a limited + -- type, we rewrite "return ;" to be: + + -- return _anon_ : := + + -- The expansion produced by Expand_N_Extended_Return_Statement will + -- contain simple return statements (for example, a block containing + -- simple return of the return object), which brings us back here with + -- Comes_From_Extended_Return_Statement set. The reason for the barrier + -- checking for a simple return that does not come from an extended + -- return is to avoid this infinite recursion. + + -- The reason for this design is that for Ada 2005 limited returns, we + -- need to reify the return object, so we can build it "in place", and + -- we need a block statement to hang finalization and tasking stuff. + + -- ??? In order to avoid disruption, we avoid translating to extended + -- return except in the cases where we really need to (Ada 2005 for + -- inherently limited). We might prefer to do this translation in all + -- cases (except perhaps for the case of Ada 95 inherently limited), + -- in order to fully exercise the Expand_N_Extended_Return_Statement + -- code. This would also allow us to do the build-in-place optimization + -- for efficiency even in cases where it is semantically not required. + + -- As before, we check the type of the return expression rather than the + -- return type of the function, because the latter may be a limited + -- class-wide interface type, which is not a limited type, even though + -- the type of the expression may be. + + if not Comes_From_Extended_Return_Statement (N) + and then Is_Immutably_Limited_Type (Etype (Expression (N))) + and then Ada_Version >= Ada_05 + and then not Debug_Flag_Dot_L + then + declare + Return_Object_Entity : constant Entity_Id := + Make_Temporary (Loc, 'R', Exp); + Obj_Decl : constant Node_Id := + Make_Object_Declaration (Loc, + Defining_Identifier => Return_Object_Entity, + Object_Definition => Subtype_Ind, + Expression => Exp); + + Ext : constant Node_Id := Make_Extended_Return_Statement (Loc, + Return_Object_Declarations => New_List (Obj_Decl)); + -- Do not perform this high-level optimization if the result type + -- is an interface because the "this" pointer must be displaced. + + begin + Rewrite (N, Ext); + Analyze (N); + return; + end; + end if; + + -- Here we have a simple return statement that is part of the expansion + -- of an extended return statement (either written by the user, or + -- generated by the above code). + + -- Always normalize C/Fortran boolean result. This is not always needed, + -- but it seems a good idea to minimize the passing around of non- + -- normalized values, and in any case this handles the processing of + -- barrier functions for protected types, which turn the condition into + -- a return statement. + + if Is_Boolean_Type (Exptyp) + and then Nonzero_Is_True (Exptyp) + then + Adjust_Condition (Exp); + Adjust_Result_Type (Exp, Exptyp); + end if; + + -- Do validity check if enabled for returns + + if Validity_Checks_On + and then Validity_Check_Returns + then + Ensure_Valid (Exp); + end if; + + -- Check the result expression of a scalar function against the subtype + -- of the function by inserting a conversion. This conversion must + -- eventually be performed for other classes of types, but for now it's + -- only done for scalars. + -- ??? + + if Is_Scalar_Type (Exptyp) then + Rewrite (Exp, Convert_To (R_Type, Exp)); + + -- The expression is resolved to ensure that the conversion gets + -- expanded to generate a possible constraint check. + + Analyze_And_Resolve (Exp, R_Type); + end if; + + -- Deal with returning variable length objects and controlled types + + -- Nothing to do if we are returning by reference, or this is not a + -- type that requires special processing (indicated by the fact that + -- it requires a cleanup scope for the secondary stack case). + + if Is_Immutably_Limited_Type (Exptyp) + or else Is_Limited_Interface (Exptyp) + then + null; + + elsif not Requires_Transient_Scope (R_Type) then + + -- Mutable records with no variable length components are not + -- returned on the sec-stack, so we need to make sure that the + -- backend will only copy back the size of the actual value, and not + -- the maximum size. We create an actual subtype for this purpose. + + declare + Ubt : constant Entity_Id := Underlying_Type (Base_Type (Exptyp)); + Decl : Node_Id; + Ent : Entity_Id; + begin + if Has_Discriminants (Ubt) + and then not Is_Constrained (Ubt) + and then not Has_Unchecked_Union (Ubt) + then + Decl := Build_Actual_Subtype (Ubt, Exp); + Ent := Defining_Identifier (Decl); + Insert_Action (Exp, Decl); + Rewrite (Exp, Unchecked_Convert_To (Ent, Exp)); + Analyze_And_Resolve (Exp); + end if; + end; + + -- Here if secondary stack is used + + else + -- Make sure that no surrounding block will reclaim the secondary + -- stack on which we are going to put the result. Not only may this + -- introduce secondary stack leaks but worse, if the reclamation is + -- done too early, then the result we are returning may get + -- clobbered. + + declare + S : Entity_Id; + begin + S := Current_Scope; + while Ekind (S) = E_Block or else Ekind (S) = E_Loop loop + Set_Sec_Stack_Needed_For_Return (S, True); + S := Enclosing_Dynamic_Scope (S); + end loop; + end; + + -- Optimize the case where the result is a function call. In this + -- case either the result is already on the secondary stack, or is + -- already being returned with the stack pointer depressed and no + -- further processing is required except to set the By_Ref flag to + -- ensure that gigi does not attempt an extra unnecessary copy. + -- (actually not just unnecessary but harmfully wrong in the case + -- of a controlled type, where gigi does not know how to do a copy). + -- To make up for a gcc 2.8.1 deficiency (???), we perform + -- the copy for array types if the constrained status of the + -- target type is different from that of the expression. + + if Requires_Transient_Scope (Exptyp) + and then + (not Is_Array_Type (Exptyp) + or else Is_Constrained (Exptyp) = Is_Constrained (R_Type) + or else CW_Or_Has_Controlled_Part (Utyp)) + and then Nkind (Exp) = N_Function_Call + then + Set_By_Ref (N); + + -- Remove side effects from the expression now so that other parts + -- of the expander do not have to reanalyze this node without this + -- optimization + + Rewrite (Exp, Duplicate_Subexpr_No_Checks (Exp)); + + -- For controlled types, do the allocation on the secondary stack + -- manually in order to call adjust at the right time: + + -- type Anon1 is access R_Type; + -- for Anon1'Storage_pool use ss_pool; + -- Anon2 : anon1 := new R_Type'(expr); + -- return Anon2.all; + + -- We do the same for classwide types that are not potentially + -- controlled (by the virtue of restriction No_Finalization) because + -- gigi is not able to properly allocate class-wide types. + + elsif CW_Or_Has_Controlled_Part (Utyp) then + declare + Loc : constant Source_Ptr := Sloc (N); + Acc_Typ : constant Entity_Id := Make_Temporary (Loc, 'A'); + Alloc_Node : Node_Id; + Temp : Entity_Id; + + begin + Set_Ekind (Acc_Typ, E_Access_Type); + + Set_Associated_Storage_Pool (Acc_Typ, RTE (RE_SS_Pool)); + + -- This is an allocator for the secondary stack, and it's fine + -- to have Comes_From_Source set False on it, as gigi knows not + -- to flag it as a violation of No_Implicit_Heap_Allocations. + + Alloc_Node := + Make_Allocator (Loc, + Expression => + Make_Qualified_Expression (Loc, + Subtype_Mark => New_Reference_To (Etype (Exp), Loc), + Expression => Relocate_Node (Exp))); + + -- We do not want discriminant checks on the declaration, + -- given that it gets its value from the allocator. + + Set_No_Initialization (Alloc_Node); + + Temp := Make_Temporary (Loc, 'R', Alloc_Node); + + Insert_List_Before_And_Analyze (N, New_List ( + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Acc_Typ, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + Subtype_Indication => Subtype_Ind)), + + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => New_Reference_To (Acc_Typ, Loc), + Expression => Alloc_Node))); + + Rewrite (Exp, + Make_Explicit_Dereference (Loc, + Prefix => New_Reference_To (Temp, Loc))); + + Analyze_And_Resolve (Exp, R_Type); + end; + + -- Otherwise use the gigi mechanism to allocate result on the + -- secondary stack. + + else + Check_Restriction (No_Secondary_Stack, N); + Set_Storage_Pool (N, RTE (RE_SS_Pool)); + + -- If we are generating code for the VM do not use + -- SS_Allocate since everything is heap-allocated anyway. + + if VM_Target = No_VM then + Set_Procedure_To_Call (N, RTE (RE_SS_Allocate)); + end if; + end if; + end if; + + -- Implement the rules of 6.5(8-10), which require a tag check in the + -- case of a limited tagged return type, and tag reassignment for + -- nonlimited tagged results. These actions are needed when the return + -- type is a specific tagged type and the result expression is a + -- conversion or a formal parameter, because in that case the tag of the + -- expression might differ from the tag of the specific result type. + + if Is_Tagged_Type (Utyp) + and then not Is_Class_Wide_Type (Utyp) + and then (Nkind_In (Exp, N_Type_Conversion, + N_Unchecked_Type_Conversion) + or else (Is_Entity_Name (Exp) + and then Ekind (Entity (Exp)) in Formal_Kind)) + then + -- When the return type is limited, perform a check that the + -- tag of the result is the same as the tag of the return type. + + if Is_Limited_Type (R_Type) then + Insert_Action (Exp, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => + Make_Selected_Component (Loc, + Prefix => Duplicate_Subexpr (Exp), + Selector_Name => + Make_Identifier (Loc, Chars => Name_uTag)), + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Base_Type (Utyp), Loc), + Attribute_Name => Name_Tag)), + Reason => CE_Tag_Check_Failed)); + + -- If the result type is a specific nonlimited tagged type, then we + -- have to ensure that the tag of the result is that of the result + -- type. This is handled by making a copy of the expression in the + -- case where it might have a different tag, namely when the + -- expression is a conversion or a formal parameter. We create a new + -- object of the result type and initialize it from the expression, + -- which will implicitly force the tag to be set appropriately. + + else + declare + ExpR : constant Node_Id := Relocate_Node (Exp); + Result_Id : constant Entity_Id := + Make_Temporary (Loc, 'R', ExpR); + Result_Exp : constant Node_Id := + New_Reference_To (Result_Id, Loc); + Result_Obj : constant Node_Id := + Make_Object_Declaration (Loc, + Defining_Identifier => Result_Id, + Object_Definition => + New_Reference_To (R_Type, Loc), + Constant_Present => True, + Expression => ExpR); + + begin + Set_Assignment_OK (Result_Obj); + Insert_Action (Exp, Result_Obj); + + Rewrite (Exp, Result_Exp); + Analyze_And_Resolve (Exp, R_Type); + end; + end if; + + -- Ada 2005 (AI-344): If the result type is class-wide, then insert + -- a check that the level of the return expression's underlying type + -- is not deeper than the level of the master enclosing the function. + -- Always generate the check when the type of the return expression + -- is class-wide, when it's a type conversion, or when it's a formal + -- parameter. Otherwise, suppress the check in the case where the + -- return expression has a specific type whose level is known not to + -- be statically deeper than the function's result type. + + -- Note: accessibility check is skipped in the VM case, since there + -- does not seem to be any practical way to implement this check. + + elsif Ada_Version >= Ada_05 + and then Tagged_Type_Expansion + and then Is_Class_Wide_Type (R_Type) + and then not Scope_Suppress (Accessibility_Check) + and then + (Is_Class_Wide_Type (Etype (Exp)) + or else Nkind_In (Exp, N_Type_Conversion, + N_Unchecked_Type_Conversion) + or else (Is_Entity_Name (Exp) + and then Ekind (Entity (Exp)) in Formal_Kind) + or else Scope_Depth (Enclosing_Dynamic_Scope (Etype (Exp))) > + Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id))) + then + declare + Tag_Node : Node_Id; + + begin + -- Ada 2005 (AI-251): In class-wide interface objects we displace + -- "this" to reference the base of the object --- required to get + -- access to the TSD of the object. + + if Is_Class_Wide_Type (Etype (Exp)) + and then Is_Interface (Etype (Exp)) + and then Nkind (Exp) = N_Explicit_Dereference + then + Tag_Node := + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (RTE (RE_Tag_Ptr), + Make_Function_Call (Loc, + Name => New_Reference_To (RTE (RE_Base_Address), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Address), + Duplicate_Subexpr (Prefix (Exp))))))); + else + Tag_Node := + Make_Attribute_Reference (Loc, + Prefix => Duplicate_Subexpr (Exp), + Attribute_Name => Name_Tag); + end if; + + Insert_Action (Exp, + Make_Raise_Program_Error (Loc, + Condition => + Make_Op_Gt (Loc, + Left_Opnd => + Build_Get_Access_Level (Loc, Tag_Node), + Right_Opnd => + Make_Integer_Literal (Loc, + Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id)))), + Reason => PE_Accessibility_Check_Failed)); + end; + + -- AI05-0073: If function has a controlling access result, check that + -- the tag of the return value, if it is not null, matches designated + -- type of return type. + -- The return expression is referenced twice in the code below, so + -- it must be made free of side effects. Given that different compilers + -- may evaluate these parameters in different order, both occurrences + -- perform a copy. + + elsif Ekind (R_Type) = E_Anonymous_Access_Type + and then Has_Controlling_Result (Scope_Id) + then + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_And_Then (Loc, + Left_Opnd => + Make_Op_Ne (Loc, + Left_Opnd => Duplicate_Subexpr (Exp), + Right_Opnd => Make_Null (Loc)), + Right_Opnd => Make_Op_Ne (Loc, + Left_Opnd => + Make_Selected_Component (Loc, + Prefix => Duplicate_Subexpr (Exp), + Selector_Name => + Make_Identifier (Loc, Chars => Name_uTag)), + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Designated_Type (R_Type), Loc), + Attribute_Name => Name_Tag))), + Reason => CE_Tag_Check_Failed), + Suppress => All_Checks); + end if; + + -- If we are returning an object that may not be bit-aligned, then copy + -- the value into a temporary first. This copy may need to expand to a + -- loop of component operations. + + if Is_Possibly_Unaligned_Slice (Exp) + or else Is_Possibly_Unaligned_Object (Exp) + then + declare + ExpR : constant Node_Id := Relocate_Node (Exp); + Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', ExpR); + begin + Insert_Action (Exp, + Make_Object_Declaration (Loc, + Defining_Identifier => Tnn, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (R_Type, Loc), + Expression => ExpR), + Suppress => All_Checks); + Rewrite (Exp, New_Occurrence_Of (Tnn, Loc)); + end; + end if; + + -- Generate call to postcondition checks if they are present + + if Ekind (Scope_Id) = E_Function + and then Has_Postconditions (Scope_Id) + then + -- We are going to reference the returned value twice in this case, + -- once in the call to _Postconditions, and once in the actual return + -- statement, but we can't have side effects happening twice, and in + -- any case for efficiency we don't want to do the computation twice. + + -- If the returned expression is an entity name, we don't need to + -- worry since it is efficient and safe to reference it twice, that's + -- also true for literals other than string literals, and for the + -- case of X.all where X is an entity name. + + if Is_Entity_Name (Exp) + or else Nkind_In (Exp, N_Character_Literal, + N_Integer_Literal, + N_Real_Literal) + or else (Nkind (Exp) = N_Explicit_Dereference + and then Is_Entity_Name (Prefix (Exp))) + then + null; + + -- Otherwise we are going to need a temporary to capture the value + + else + declare + ExpR : constant Node_Id := Relocate_Node (Exp); + Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', ExpR); + + begin + -- For a complex expression of an elementary type, capture + -- value in the temporary and use it as the reference. + + if Is_Elementary_Type (R_Type) then + Insert_Action (Exp, + Make_Object_Declaration (Loc, + Defining_Identifier => Tnn, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (R_Type, Loc), + Expression => ExpR), + Suppress => All_Checks); + + Rewrite (Exp, New_Occurrence_Of (Tnn, Loc)); + + -- If we have something we can rename, generate a renaming of + -- the object and replace the expression with a reference + + elsif Is_Object_Reference (Exp) then + Insert_Action (Exp, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Tnn, + Subtype_Mark => New_Occurrence_Of (R_Type, Loc), + Name => ExpR), + Suppress => All_Checks); + + Rewrite (Exp, New_Occurrence_Of (Tnn, Loc)); + + -- Otherwise we have something like a string literal or an + -- aggregate. We could copy the value, but that would be + -- inefficient. Instead we make a reference to the value and + -- capture this reference with a renaming, the expression is + -- then replaced by a dereference of this renaming. + + else + -- For now, copy the value, since the code below does not + -- seem to work correctly ??? + + Insert_Action (Exp, + Make_Object_Declaration (Loc, + Defining_Identifier => Tnn, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (R_Type, Loc), + Expression => Relocate_Node (Exp)), + Suppress => All_Checks); + + Rewrite (Exp, New_Occurrence_Of (Tnn, Loc)); + + -- Insert_Action (Exp, + -- Make_Object_Renaming_Declaration (Loc, + -- Defining_Identifier => Tnn, + -- Access_Definition => + -- Make_Access_Definition (Loc, + -- All_Present => True, + -- Subtype_Mark => New_Occurrence_Of (R_Type, Loc)), + -- Name => + -- Make_Reference (Loc, + -- Prefix => Relocate_Node (Exp))), + -- Suppress => All_Checks); + + -- Rewrite (Exp, + -- Make_Explicit_Dereference (Loc, + -- Prefix => New_Occurrence_Of (Tnn, Loc))); + end if; + end; + end if; + + -- Generate call to _postconditions + + Insert_Action (Exp, + Make_Procedure_Call_Statement (Loc, + Name => Make_Identifier (Loc, Name_uPostconditions), + Parameter_Associations => New_List (Duplicate_Subexpr (Exp)))); + end if; + + -- Ada 2005 (AI-251): If this return statement corresponds with an + -- simple return statement associated with an extended return statement + -- and the type of the returned object is an interface then generate an + -- implicit conversion to force displacement of the "this" pointer. + + if Ada_Version >= Ada_05 + and then Comes_From_Extended_Return_Statement (N) + and then Nkind (Expression (N)) = N_Identifier + and then Is_Interface (Utyp) + and then Utyp /= Underlying_Type (Exptyp) + then + Rewrite (Exp, Convert_To (Utyp, Relocate_Node (Exp))); + Analyze_And_Resolve (Exp); + end if; + end Expand_Simple_Function_Return; + -------------------------------- -- Is_Build_In_Place_Function -- -------------------------------- diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads index 242995f490d2..e04e217e80e7 100644 --- a/gcc/ada/exp_ch6.ads +++ b/gcc/ada/exp_ch6.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -29,11 +29,13 @@ with Types; use Types; package Exp_Ch6 is - procedure Expand_N_Function_Call (N : Node_Id); - procedure Expand_N_Subprogram_Body (N : Node_Id); - procedure Expand_N_Subprogram_Body_Stub (N : Node_Id); - procedure Expand_N_Subprogram_Declaration (N : Node_Id); - procedure Expand_N_Procedure_Call_Statement (N : Node_Id); + procedure Expand_N_Extended_Return_Statement (N : Node_Id); + procedure Expand_N_Function_Call (N : Node_Id); + procedure Expand_N_Procedure_Call_Statement (N : Node_Id); + procedure Expand_N_Simple_Return_Statement (N : Node_Id); + procedure Expand_N_Subprogram_Body (N : Node_Id); + procedure Expand_N_Subprogram_Body_Stub (N : Node_Id); + procedure Expand_N_Subprogram_Declaration (N : Node_Id); procedure Expand_Call (N : Node_Id); -- This procedure contains common processing for Expand_N_Function_Call, diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index 8e6f458907af..c76e17514089 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -126,6 +126,7 @@ GNAT_ADA_OBJS = \ ada/ada.o \ ada/ali.o \ ada/alloc.o \ + ada/aspects.o \ ada/atree.o \ ada/butil.o \ ada/casing.o \ @@ -1346,15 +1347,24 @@ ada/ali.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \ ada/alloc.o : ada/alloc.ads ada/system.ads +ada/aspects.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ + ada/a-uncdea.ads ada/alloc.ads ada/aspects.ads ada/aspects.adb \ + ada/debug.ads ada/hostparm.ads ada/namet.ads ada/opt.ads ada/output.ads \ + ada/snames.ads ada/system.ads ada/s-exctab.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tree_io.ads ada/types.ads ada/unchconv.ads \ + ada/unchdeal.ads + ada/atree.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ ada/casing.ads ada/debug.ads ada/einfo.ads ada/hostparm.ads \ ada/namet.ads ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads \ ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads \ - ada/system.ads ada/s-exctab.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/back_end.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ @@ -1498,13 +1508,13 @@ ada/comperr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/nlists.adb ada/opt.ads ada/osint.ads ada/output.ads ada/output.adb \ ada/rident.ads ada/sdefault.ads ada/sinfo.ads ada/sinfo.adb \ ada/sinput.ads ada/snames.ads ada/sprint.ads ada/system.ads \ - ada/s-exctab.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ - ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ - ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tree_io.ads \ - ada/treepr.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \ + ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ + ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ + ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \ + ada/tree_io.ads ada/treepr.ads ada/types.ads ada/uintp.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/csets.o : ada/ada.ads ada/a-unccon.ads ada/a-uncdea.ads ada/csets.ads \ ada/csets.adb ada/hostparm.ads ada/opt.ads ada/system.ads \ @@ -1546,11 +1556,11 @@ ada/debug_a.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/einfo.ads ada/hostparm.ads ada/namet.ads ada/nlists.ads \ ada/nlists.adb ada/opt.ads ada/output.ads ada/sinfo.ads ada/sinfo.adb \ ada/sinput.ads ada/snames.ads ada/system.ads ada/s-exctab.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/einfo.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -1881,32 +1891,32 @@ ada/exp_ch5.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/casing.ads ada/checks.ads ada/checks.adb ada/csets.ads \ ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads \ ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \ - ada/exp_aggr.ads ada/exp_atag.ads ada/exp_ch11.ads ada/exp_ch2.ads \ - ada/exp_ch4.ads ada/exp_ch5.ads ada/exp_ch5.adb ada/exp_ch6.ads \ - ada/exp_ch7.ads ada/exp_dbug.ads ada/exp_disp.ads ada/exp_pakd.ads \ - ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb ada/fname.ads \ - ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ - ada/g-htable.ads ada/hostparm.ads ada/inline.ads ada/interfac.ads \ - ada/itypes.ads ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb \ - ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ - ada/output.ads ada/restrict.ads ada/restrict.adb ada/rident.ads \ - ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \ - ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads \ - ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch8.ads \ - ada/sem_disp.ads ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads \ - ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ - ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads \ - ada/sprint.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ - ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ - ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ - ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ - ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ - ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ - ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/widechar.ads + ada/exp_aggr.ads ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch4.ads \ + ada/exp_ch5.ads ada/exp_ch5.adb ada/exp_ch6.ads ada/exp_ch7.ads \ + ada/exp_dbug.ads ada/exp_disp.ads ada/exp_pakd.ads ada/exp_tss.ads \ + ada/exp_util.ads ada/exp_util.adb ada/fname.ads ada/fname-uf.ads \ + ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-htable.ads \ + ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/itypes.ads \ + ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ + ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \ + ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \ + ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \ + ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch13.ads \ + ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads \ + ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads ada/sem_type.ads \ + ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads \ + ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/sprint.ads \ + ada/stand.ads ada/stringt.ads ada/stringt.adb ada/style.ads \ + ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \ + ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \ + ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \ + ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \ + ada/urealp.ads ada/validsw.ads ada/widechar.ads ada/exp_ch6.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -2376,12 +2386,12 @@ ada/expander.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads ada/rtsfind.ads \ ada/sem.ads ada/sem_ch8.ads ada/sem_util.ads ada/sinfo.ads \ ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/system.ads \ - ada/s-exctab.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ - ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tree_io.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-soflin.ads ada/s-stache.ads \ + ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ + ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/fmap.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/fmap.ads ada/fmap.adb \ @@ -2811,10 +2821,10 @@ ada/nlists.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/casing.ads ada/debug.ads ada/einfo.ads ada/hostparm.ads \ ada/namet.ads ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads \ ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads \ - ada/system.ads ada/s-exctab.ads ada/s-imenne.ads ada/s-memory.ads \ - ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \ + ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/nmake.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ @@ -2823,11 +2833,11 @@ ada/nmake.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ ada/opt.ads ada/output.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ ada/snames.ads ada/stand.ads ada/system.ads ada/s-exctab.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/opt.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \ ada/gnatvsn.ads ada/hostparm.ads ada/opt.ads ada/opt.adb ada/system.ads \ @@ -3190,11 +3200,11 @@ ada/scil_ll.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/namet.ads ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads \ ada/scil_ll.ads ada/scil_ll.adb ada/sinfo.ads ada/sinfo.adb \ ada/sinput.ads ada/snames.ads ada/system.ads ada/s-exctab.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/scn.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \ ada/alloc.ads ada/atree.ads ada/atree.adb ada/casing.ads ada/csets.ads \ @@ -3506,11 +3516,11 @@ ada/sem_ch2.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/restrict.ads ada/rident.ads ada/sem_ch2.ads ada/sem_ch2.adb \ ada/sem_ch8.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \ ada/snames.ads ada/stand.ads ada/system.ads ada/s-carun8.ads \ - ada/s-exctab.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-rident.ads ada/s-stalib.ads ada/s-string.ads \ - ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ - ada/table.adb ada/tree_io.ads ada/types.ads ada/types.adb ada/uintp.ads \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-stalib.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/types.adb \ + ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/sem_ch3.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -4126,11 +4136,11 @@ ada/sinfo.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/g-htable.ads ada/hostparm.ads ada/namet.ads ada/nlists.ads \ ada/nlists.adb ada/opt.ads ada/output.ads ada/sinfo.ads ada/sinfo.adb \ ada/sinput.ads ada/snames.ads ada/system.ads ada/s-exctab.ads \ - ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads \ - ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ - ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads + ada/s-htable.ads ada/s-htable.adb ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-strhas.ads \ + ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ + ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/sinput-c.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/casing.ads ada/debug.ads \ @@ -4163,12 +4173,12 @@ ada/sinput-l.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/sinput-l.ads ada/sinput-l.adb ada/snames.ads ada/stringt.ads \ ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ ada/system.ads ada/s-crc32.ads ada/s-crc32.adb ada/s-exctab.ads \ - ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ - ada/tree_io.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \ - ada/unchdeal.ads ada/urealp.ads ada/widechar.ads + ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ + ada/s-parame.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \ + ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \ + ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads ada/sinput.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \ @@ -4176,12 +4186,12 @@ ada/sinput.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/interfac.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ ada/nlists.adb ada/opt.ads ada/output.ads ada/sinfo.ads ada/sinfo.adb \ ada/sinput.ads ada/sinput.adb ada/snames.ads ada/system.ads \ - ada/s-exctab.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \ - ada/s-parame.ads ada/s-secsta.ads ada/s-stalib.ads ada/s-stoele.ads \ - ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ - ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \ - ada/urealp.ads ada/widechar.ads + ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \ + ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads ada/s-stalib.ads \ + ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ + ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ + ada/tree_io.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \ + ada/unchdeal.ads ada/urealp.ads ada/widechar.ads ada/snames.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/hostparm.ads \ diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index c634b7fb87df..a3eb1da7eeab 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -529,8 +529,8 @@ package body Sem_Aggr is -- N is an array (sub-)aggregate. Dim is the dimension corresponding -- to (sub-)aggregate N. This procedure collects and removes the side -- effects of the constrained N_Range nodes corresponding to each index - -- dimension of our aggregate itype. - -- These N_Range nodes are collected in Aggr_Range above. + -- dimension of our aggregate itype. These N_Range nodes are collected + -- in Aggr_Range above. -- -- Likewise collect in Aggr_Low & Aggr_High above the low and high -- bounds of each index dimension. If, when collecting, two bounds diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index efd8d8e73b0c..2379a4140547 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -10404,7 +10404,7 @@ package body Sem_Prag is -- pragma Passive [(PASSIVE_FORM)]; - -- PASSIVE_FORM ::= Semaphore | No + -- PASSIVE_FORM ::= Semaphore | No when Pragma_Passive => GNAT_Pragma; @@ -10475,6 +10475,8 @@ package body Sem_Prag is -- Persistent_BSS -- -------------------- + -- pragma Persistent_BSS [(object_NAME)]; + when Pragma_Persistent_BSS => Persistent_BSS : declare Decl : Node_Id; Ent : Entity_Id; diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 0c94966961ef..ad43f3a0e437 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -134,6 +134,14 @@ package Snames is Name_Space : constant Name_Id := N + $; Name_Time : constant Name_Id := N + $; + -- Names of aspects for which there are no matching pragmas or attributes + -- so that they need to be included for aspect specification use. + + Name_Invariant : constant Name_Id := N + $; + Name_Post : constant Name_Id := N + $; + Name_Pre : constant Name_Id := N + $; + Name_Predicate : constant Name_Id := N + $; + -- Some special names used by the expander. Note that the lower case u's -- at the start of these names get translated to extra underscores. These -- names are only referenced internally by expander generated code. diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index 816750c6c19c..c35ef0df0397 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -801,7 +801,6 @@ package body Sprint is -- Select print circuit based on node kind case Nkind (Node) is - when N_Abort_Statement => Write_Indent_Str_Sloc ("abort "); Sprint_Comma_List (Names (Node)); @@ -3091,7 +3090,6 @@ package body Sprint is Write_Char (';'); end if; end if; - end case; if Nkind (Node) in N_Subexpr