+2010-10-11 Robert Dewar <dewar@adacore.com>
+
+ * sem_prag.adb, sem_aggr.adb, sprint.adb: Minor reformatting.
+
+2010-10-11 Javier Miranda <miranda@adacore.com>
+
+ * 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 <dewar@adacore.com>
+
+ * snames.ads-tmpl: Add names for aspects.
+ * aspects.ads, aspects.adb: New.
+ * gcc-interface/Make-lang.in: Update dependencies.
2010-10-11 Ed Schonberg <schonberg@adacore.com>
* exp_ch6.adb (Expand_Actuals): If an actual is the current instance of
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- 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;
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;
-- 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
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 := <expression> do
- -- <handled_seq_of_stms>
- -- end return;
-
- -- to be:
-
- -- declare
- -- Result : T := <expression>;
- -- begin
- -- <handled_seq_of_stms>
- -- return Result;
- -- end;
-
- -- Otherwise (no Handled_Statement_Sequence), we rewrite this:
-
- -- return Result : T := <expression>;
-
- -- to be:
-
- -- return <expression>;
-
- -- unless it's build-in-place or there's no <expression>, in which case
- -- we generate:
-
- -- declare
- -- Result : T := <expression>;
- -- 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 [:= <expression>];
- -- begin
- -- ...
-
- -- is converted to
-
- -- declare
- -- Result : T renames FuncRA.all;
- -- [Result := <expression;]
- -- begin
- -- ...
-
- declare
- Return_Obj_Id : constant Entity_Id :=
- Defining_Identifier (Return_Object_Decl);
- Return_Obj_Typ : constant Entity_Id := Etype (Return_Obj_Id);
- Return_Obj_Expr : constant Node_Id :=
- Expression (Return_Object_Decl);
- Result_Subt : constant Entity_Id :=
- Etype (Parent_Function);
- Constr_Result : constant Boolean :=
- Is_Constrained (Result_Subt);
- Obj_Alloc_Formal : Entity_Id;
- Object_Access : Entity_Id;
- Obj_Acc_Deref : Node_Id;
- Init_Assignment : Node_Id := Empty;
-
- begin
- -- Build-in-place results must be returned by reference
-
- Set_By_Ref (Return_Stm);
-
- -- Retrieve the implicit access parameter passed by the caller
-
- Object_Access :=
- Build_In_Place_Formal (Parent_Function, BIP_Object_Access);
-
- -- If the return object's declaration includes an expression
- -- and the declaration isn't marked as No_Initialization, then
- -- we need to generate an assignment to the object and insert
- -- it after the declaration before rewriting it as a renaming
- -- (otherwise we'll lose the initialization). The case where
- -- the result type is an interface (or class-wide interface)
- -- is also excluded because the context of the function call
- -- must be unconstrained, so the initialization will always
- -- be done as part of an allocator evaluation (storage pool
- -- or secondary stack), never to a constrained target object
- -- passed in by the caller. Besides the assignment being
- -- unneeded in this case, it avoids problems with trying to
- -- generate a dispatching assignment when the return expression
- -- is a nonlimited descendant of a limited interface (the
- -- interface has no assignment operation).
-
- if Present (Return_Obj_Expr)
- and then not No_Initialization (Return_Object_Decl)
- and then not Is_Interface (Return_Obj_Typ)
- then
- Init_Assignment :=
- Make_Assignment_Statement (Loc,
- Name => 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 --
-----------------------------
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 <expression>;" to be:
-
- -- return _anon_ : <return_subtype> := <expression>
-
- -- 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 --
------------------------------
-- --
-- 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- --
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;
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;
-- 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;
-- 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 --
----------------------------------------------
end loop;
end Expand_Inlined_Call;
+ ----------------------------------------
+ -- Expand_N_Extended_Return_Statement --
+ ----------------------------------------
+
+ -- If there is a Handled_Statement_Sequence, we rewrite this:
+
+ -- return Result : T := <expression> do
+ -- <handled_seq_of_stms>
+ -- end return;
+
+ -- to be:
+
+ -- declare
+ -- Result : T := <expression>;
+ -- begin
+ -- <handled_seq_of_stms>
+ -- return Result;
+ -- end;
+
+ -- Otherwise (no Handled_Statement_Sequence), we rewrite this:
+
+ -- return Result : T := <expression>;
+
+ -- to be:
+
+ -- return <expression>;
+
+ -- unless it's build-in-place or there's no <expression>, in which case
+ -- we generate:
+
+ -- declare
+ -- Result : T := <expression>;
+ -- 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 [:= <expression>];
+ -- begin
+ -- ...
+
+ -- is converted to
+
+ -- declare
+ -- Result : T renames FuncRA.all;
+ -- [Result := <expression;]
+ -- begin
+ -- ...
+
+ declare
+ Return_Obj_Id : constant Entity_Id :=
+ Defining_Identifier (Return_Object_Decl);
+ Return_Obj_Typ : constant Entity_Id := Etype (Return_Obj_Id);
+ Return_Obj_Expr : constant Node_Id :=
+ Expression (Return_Object_Decl);
+ Result_Subt : constant Entity_Id :=
+ Etype (Parent_Function);
+ Constr_Result : constant Boolean :=
+ Is_Constrained (Result_Subt);
+ Obj_Alloc_Formal : Entity_Id;
+ Object_Access : Entity_Id;
+ Obj_Acc_Deref : Node_Id;
+ Init_Assignment : Node_Id := Empty;
+
+ begin
+ -- Build-in-place results must be returned by reference
+
+ Set_By_Ref (Return_Stm);
+
+ -- Retrieve the implicit access parameter passed by the caller
+
+ Object_Access :=
+ Build_In_Place_Formal (Parent_Function, BIP_Object_Access);
+
+ -- If the return object's declaration includes an expression
+ -- and the declaration isn't marked as No_Initialization, then
+ -- we need to generate an assignment to the object and insert
+ -- it after the declaration before rewriting it as a renaming
+ -- (otherwise we'll lose the initialization). The case where
+ -- the result type is an interface (or class-wide interface)
+ -- is also excluded because the context of the function call
+ -- must be unconstrained, so the initialization will always
+ -- be done as part of an allocator evaluation (storage pool
+ -- or secondary stack), never to a constrained target object
+ -- passed in by the caller. Besides the assignment being
+ -- unneeded in this case, it avoids problems with trying to
+ -- generate a dispatching assignment when the return expression
+ -- is a nonlimited descendant of a limited interface (the
+ -- interface has no assignment operation).
+
+ if Present (Return_Obj_Expr)
+ and then not No_Initialization (Return_Object_Decl)
+ and then not Is_Interface (Return_Obj_Typ)
+ then
+ Init_Assignment :=
+ Make_Assignment_Statement (Loc,
+ Name => 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 --
----------------------------
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 --
------------------------------
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 --
---------------------------------------
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 <expression>;" to be:
+
+ -- return _anon_ : <return_subtype> := <expression>
+
+ -- 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 --
--------------------------------
-- --
-- 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- --
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,
ada/ada.o \
ada/ali.o \
ada/alloc.o \
+ ada/aspects.o \
ada/atree.o \
ada/butil.o \
ada/casing.o \
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 \
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 \
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 \
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 \
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 \
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 \
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 \
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 \
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 \
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 \
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 \
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 \
-- 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
-- pragma Passive [(PASSIVE_FORM)];
- -- PASSIVE_FORM ::= Semaphore | No
+ -- PASSIVE_FORM ::= Semaphore | No
when Pragma_Passive =>
GNAT_Pragma;
-- Persistent_BSS --
--------------------
+ -- pragma Persistent_BSS [(object_NAME)];
+
when Pragma_Persistent_BSS => Persistent_BSS : declare
Decl : Node_Id;
Ent : Entity_Id;
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.
-- 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));
Write_Char (';');
end if;
end if;
-
end case;
if Nkind (Node) in N_Subexpr
OSDN Git Service
