Commit 2b3d67a5 by Arnaud Charlet

[multiple changes]

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.

From-SVN: r165281
parent fb468a94
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> 2010-10-11 Ed Schonberg <schonberg@adacore.com>
* exp_ch6.adb (Expand_Actuals): If an actual is the current instance of * exp_ch6.adb (Expand_Actuals): If an actual is the current instance of
......
------------------------------------------------------------------------------
-- --
-- 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;
------------------------------------------------------------------------------
-- --
-- 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;
...@@ -27,7 +27,6 @@ with Atree; use Atree; ...@@ -27,7 +27,6 @@ with Atree; use Atree;
with Checks; use Checks; with Checks; use Checks;
with Debug; use Debug; with Debug; use Debug;
with Einfo; use Einfo; with Einfo; use Einfo;
with Exp_Atag; use Exp_Atag;
with Exp_Aggr; use Exp_Aggr; with Exp_Aggr; use Exp_Aggr;
with Exp_Ch6; use Exp_Ch6; with Exp_Ch6; use Exp_Ch6;
with Exp_Ch7; use Exp_Ch7; with Exp_Ch7; use Exp_Ch7;
...@@ -104,16 +103,6 @@ package body Exp_Ch5 is ...@@ -104,16 +103,6 @@ package body Exp_Ch5 is
-- clause (this last case is required because holes in the tagged type -- clause (this last case is required because holes in the tagged type
-- might be filled with components from child types). -- 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; function Make_Tag_Ctrl_Assignment (N : Node_Id) return List_Id;
-- Generate the necessary code for controlled and tagged assignment, that -- Generate the necessary code for controlled and tagged assignment, that
-- is to say, finalization of the target before, adjustment of the target -- is to say, finalization of the target before, adjustment of the target
...@@ -2450,728 +2439,6 @@ package body Exp_Ch5 is ...@@ -2450,728 +2439,6 @@ package body Exp_Ch5 is
Adjust_Condition (Condition (N)); Adjust_Condition (Condition (N));
end Expand_N_Exit_Statement; 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 -- -- Expand_N_Goto_Statement --
----------------------------- -----------------------------
...@@ -3671,761 +2938,6 @@ package body Exp_Ch5 is ...@@ -3671,761 +2938,6 @@ package body Exp_Ch5 is
end if; end if;
end Expand_N_Loop_Statement; 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 -- -- Make_Tag_Ctrl_Assignment --
------------------------------ ------------------------------
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -32,9 +32,7 @@ package Exp_Ch5 is ...@@ -32,9 +32,7 @@ package Exp_Ch5 is
procedure Expand_N_Block_Statement (N : Node_Id); procedure Expand_N_Block_Statement (N : Node_Id);
procedure Expand_N_Case_Statement (N : Node_Id); procedure Expand_N_Case_Statement (N : Node_Id);
procedure Expand_N_Exit_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_Goto_Statement (N : Node_Id);
procedure Expand_N_If_Statement (N : Node_Id); procedure Expand_N_If_Statement (N : Node_Id);
procedure Expand_N_Loop_Statement (N : Node_Id); procedure Expand_N_Loop_Statement (N : Node_Id);
procedure Expand_N_Simple_Return_Statement (N : Node_Id);
end Exp_Ch5; end Exp_Ch5;
...@@ -69,6 +69,7 @@ with Sem_Util; use Sem_Util; ...@@ -69,6 +69,7 @@ with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo; with Sinfo; use Sinfo;
with Snames; use Snames; with Snames; use Snames;
with Stand; use Stand; with Stand; use Stand;
with Targparm; use Targparm;
with Tbuild; use Tbuild; with Tbuild; use Tbuild;
with Uintp; use Uintp; with Uintp; use Uintp;
with Validsw; use Validsw; with Validsw; use Validsw;
...@@ -202,6 +203,12 @@ package body Exp_Ch6 is ...@@ -202,6 +203,12 @@ package body Exp_Ch6 is
-- expressions in the body must be converted to the desired type (which -- expressions in the body must be converted to the desired type (which
-- is simply not noted in the tree without inline expansion). -- 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 function Expand_Protected_Object_Reference
(N : Node_Id; (N : Node_Id;
Scop : Entity_Id) return Node_Id; Scop : Entity_Id) return Node_Id;
...@@ -219,6 +226,10 @@ package body Exp_Ch6 is ...@@ -219,6 +226,10 @@ package body Exp_Ch6 is
-- Predicate to recognize stubbed procedures and null procedures, which -- Predicate to recognize stubbed procedures and null procedures, which
-- can be inlined unconditionally in all cases. -- 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 -- -- Add_Access_Actual_To_Build_In_Place_Call --
---------------------------------------------- ----------------------------------------------
...@@ -4076,6 +4087,728 @@ package body Exp_Ch6 is ...@@ -4076,6 +4087,728 @@ package body Exp_Ch6 is
end loop; end loop;
end Expand_Inlined_Call; 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_N_Function_Call --
---------------------------- ----------------------------
...@@ -4109,6 +4842,45 @@ package body Exp_Ch6 is ...@@ -4109,6 +4842,45 @@ package body Exp_Ch6 is
Expand_Call (N); Expand_Call (N);
end Expand_N_Procedure_Call_Statement; 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 -- -- Expand_N_Subprogram_Body --
------------------------------ ------------------------------
...@@ -4619,6 +5391,122 @@ package body Exp_Ch6 is ...@@ -4619,6 +5391,122 @@ package body Exp_Ch6 is
end if; end if;
end Expand_N_Subprogram_Declaration; 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 -- -- Expand_Protected_Object_Reference --
--------------------------------------- ---------------------------------------
...@@ -4789,6 +5677,608 @@ package body Exp_Ch6 is ...@@ -4789,6 +5677,608 @@ package body Exp_Ch6 is
end if; end if;
end Expand_Protected_Subprogram_Call; 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 -- -- Is_Build_In_Place_Function --
-------------------------------- --------------------------------
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -29,11 +29,13 @@ with Types; use Types; ...@@ -29,11 +29,13 @@ with Types; use Types;
package Exp_Ch6 is package Exp_Ch6 is
procedure Expand_N_Function_Call (N : Node_Id); procedure Expand_N_Extended_Return_Statement (N : Node_Id);
procedure Expand_N_Subprogram_Body (N : Node_Id); procedure Expand_N_Function_Call (N : Node_Id);
procedure Expand_N_Subprogram_Body_Stub (N : Node_Id); procedure Expand_N_Procedure_Call_Statement (N : Node_Id);
procedure Expand_N_Subprogram_Declaration (N : Node_Id); procedure Expand_N_Simple_Return_Statement (N : Node_Id);
procedure Expand_N_Procedure_Call_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); procedure Expand_Call (N : Node_Id);
-- This procedure contains common processing for Expand_N_Function_Call, -- This procedure contains common processing for Expand_N_Function_Call,
......
...@@ -126,6 +126,7 @@ GNAT_ADA_OBJS = \ ...@@ -126,6 +126,7 @@ GNAT_ADA_OBJS = \
ada/ada.o \ ada/ada.o \
ada/ali.o \ ada/ali.o \
ada/alloc.o \ ada/alloc.o \
ada/aspects.o \
ada/atree.o \ ada/atree.o \
ada/butil.o \ ada/butil.o \
ada/casing.o \ ada/casing.o \
...@@ -1346,15 +1347,24 @@ ada/ali.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \ ...@@ -1346,15 +1347,24 @@ ada/ali.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads ada/a-uncdea.ads \
ada/alloc.o : ada/alloc.ads ada/system.ads ada/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/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/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/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/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/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/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \
ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads \ ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \
ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \
ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.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/unchconv.ads ada/unchdeal.ads ada/urealp.ads
ada/back_end.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/back_end.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
...@@ -1498,13 +1508,13 @@ ada/comperr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ...@@ -1498,13 +1508,13 @@ ada/comperr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/nlists.adb ada/opt.ads ada/osint.ads ada/output.ads ada/output.adb \ ada/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/rident.ads ada/sdefault.ads ada/sinfo.ads ada/sinfo.adb \
ada/sinput.ads ada/snames.ads ada/sprint.ads ada/system.ads \ 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-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \
ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads \ ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-secsta.ads \
ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \ ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \ ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \
ada/table.ads ada/table.adb ada/targparm.ads ada/tree_io.ads \ ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \
ada/treepr.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \ ada/tree_io.ads ada/treepr.ads ada/types.ads ada/uintp.ads \
ada/unchdeal.ads ada/urealp.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.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/csets.adb ada/hostparm.ads ada/opt.ads ada/system.ads \
...@@ -1546,11 +1556,11 @@ ada/debug_a.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ...@@ -1546,11 +1556,11 @@ ada/debug_a.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/einfo.ads ada/hostparm.ads ada/namet.ads ada/nlists.ads \ ada/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/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/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-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \
ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads \
ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \ ada/tree_io.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
ada/urealp.ads ada/unchdeal.ads ada/urealp.ads
ada/einfo.o : ada/ada.ads ada/a-except.ads ada/a-unccon.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/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \
...@@ -1881,32 +1891,32 @@ ada/exp_ch5.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ...@@ -1881,32 +1891,32 @@ ada/exp_ch5.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/casing.ads ada/checks.ads ada/checks.adb ada/csets.ads \ ada/casing.ads ada/checks.ads ada/checks.adb ada/csets.ads \
ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.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/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_aggr.ads ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch4.ads \
ada/exp_ch4.ads ada/exp_ch5.ads ada/exp_ch5.adb ada/exp_ch6.ads \ ada/exp_ch5.ads ada/exp_ch5.adb ada/exp_ch6.ads ada/exp_ch7.ads \
ada/exp_ch7.ads ada/exp_dbug.ads ada/exp_disp.ads ada/exp_pakd.ads \ ada/exp_dbug.ads ada/exp_disp.ads ada/exp_pakd.ads ada/exp_tss.ads \
ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb ada/fname.ads \ ada/exp_util.ads ada/exp_util.adb ada/fname.ads ada/fname-uf.ads \
ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \ ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-htable.ads \
ada/g-htable.ads ada/hostparm.ads ada/inline.ads ada/interfac.ads \ ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/itypes.ads \
ada/itypes.ads ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb \ ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/namet.adb ada/nlists.ads \
ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads \ ada/nlists.adb ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads \
ada/output.ads ada/restrict.ads ada/restrict.adb ada/rident.ads \ ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \
ada/rtsfind.ads ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb \ ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \
ada/sem.ads ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads \ ada/sem_attr.ads ada/sem_aux.ads ada/sem_cat.ads ada/sem_ch13.ads \
ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch8.ads \ ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads \
ada/sem_disp.ads ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads \ ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads ada/sem_type.ads \
ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads \ ada/sem_util.ads ada/sem_util.adb ada/sem_warn.ads ada/sinfo.ads \
ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads \ ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/sprint.ads \
ada/sprint.ads ada/stand.ads ada/stringt.ads ada/stringt.adb \ ada/stand.ads ada/stringt.ads ada/stringt.adb ada/style.ads \
ada/style.ads ada/styleg.ads ada/styleg.adb ada/stylesw.ads \ ada/styleg.ads ada/styleg.adb ada/stylesw.ads ada/system.ads \
ada/system.ads ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads \ ada/s-crc32.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \
ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \
ada/s-rident.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \ ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \ ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \
ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \ ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \
ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \ ada/table.adb ada/targparm.ads ada/tbuild.ads ada/tbuild.adb \
ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \ ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \
ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \ ada/uintp.adb ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \
ada/unchdeal.ads ada/urealp.ads ada/validsw.ads ada/widechar.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/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/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \
...@@ -2376,12 +2386,12 @@ ada/expander.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ...@@ -2376,12 +2386,12 @@ ada/expander.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/nlists.adb ada/nmake.ads ada/opt.ads ada/output.ads ada/rtsfind.ads \ ada/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/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/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-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \
ada/s-parame.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \ ada/s-os_lib.ads ada/s-parame.ads ada/s-soflin.ads ada/s-stache.ads \
ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \ ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \
ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
ada/tree_io.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \ ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \
ada/unchdeal.ads ada/urealp.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/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/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/fmap.ads ada/fmap.adb \
...@@ -2811,10 +2821,10 @@ ada/nlists.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ...@@ -2811,10 +2821,10 @@ ada/nlists.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/casing.ads ada/debug.ads ada/einfo.ads ada/hostparm.ads \ ada/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/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/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/system.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads \
ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads \ ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads \
ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \
ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.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/unchconv.ads ada/unchdeal.ads ada/urealp.ads
ada/nmake.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ada/nmake.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
...@@ -2823,11 +2833,11 @@ ada/nmake.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ...@@ -2823,11 +2833,11 @@ ada/nmake.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/namet.ads ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \ ada/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/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/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-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \
ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads \
ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \ ada/tree_io.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
ada/urealp.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/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/gnatvsn.ads ada/hostparm.ads ada/opt.ads ada/opt.adb ada/system.ads \
...@@ -3190,11 +3200,11 @@ ada/scil_ll.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ...@@ -3190,11 +3200,11 @@ ada/scil_ll.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/namet.ads ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads \ ada/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/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/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-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \
ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads \
ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \ ada/tree_io.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
ada/urealp.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/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/alloc.ads ada/atree.ads ada/atree.adb ada/casing.ads ada/csets.ads \
...@@ -3506,11 +3516,11 @@ ada/sem_ch2.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ...@@ -3506,11 +3516,11 @@ ada/sem_ch2.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/restrict.ads ada/rident.ads ada/sem_ch2.ads ada/sem_ch2.adb \ ada/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/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/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-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \
ada/s-parame.ads ada/s-rident.ads ada/s-stalib.ads ada/s-string.ads \ ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-stalib.ads \
ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \ ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \
ada/table.adb ada/tree_io.ads ada/types.ads ada/types.adb ada/uintp.ads \ ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/types.adb \
ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads 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/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/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \
...@@ -4126,11 +4136,11 @@ ada/sinfo.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ...@@ -4126,11 +4136,11 @@ ada/sinfo.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/g-htable.ads ada/hostparm.ads ada/namet.ads ada/nlists.ads \ ada/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/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/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-htable.ads ada/s-htable.adb ada/s-imenne.ads ada/s-memory.ads \
ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads \ ada/s-os_lib.ads ada/s-parame.ads ada/s-stalib.ads ada/s-strhas.ads \
ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \
ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \ 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/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/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/a-uncdea.ads ada/alloc.ads ada/casing.ads ada/debug.ads \
...@@ -4163,12 +4173,12 @@ ada/sinput-l.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ...@@ -4163,12 +4173,12 @@ ada/sinput-l.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/sinput-l.ads ada/sinput-l.adb ada/snames.ads ada/stringt.ads \ ada/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/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/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-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \
ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \ ada/s-parame.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \
ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \ ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads ada/table.ads \
ada/tree_io.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \ ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \
ada/unchdeal.ads ada/urealp.ads ada/widechar.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/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/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \
...@@ -4176,12 +4186,12 @@ ada/sinput.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ ...@@ -4176,12 +4186,12 @@ ada/sinput.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/interfac.ads ada/namet.ads ada/namet.adb ada/nlists.ads \ ada/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/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/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-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \
ada/s-parame.ads ada/s-secsta.ads ada/s-stalib.ads ada/s-stoele.ads \ ada/s-os_lib.ads ada/s-parame.ads ada/s-secsta.ads ada/s-stalib.ads \
ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \
ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \ ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \ ada/tree_io.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
ada/urealp.ads ada/widechar.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/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 \ ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/hostparm.ads \
......
...@@ -529,8 +529,8 @@ package body Sem_Aggr is ...@@ -529,8 +529,8 @@ package body Sem_Aggr is
-- N is an array (sub-)aggregate. Dim is the dimension corresponding -- N is an array (sub-)aggregate. Dim is the dimension corresponding
-- to (sub-)aggregate N. This procedure collects and removes the side -- to (sub-)aggregate N. This procedure collects and removes the side
-- effects of the constrained N_Range nodes corresponding to each index -- effects of the constrained N_Range nodes corresponding to each index
-- dimension of our aggregate itype. -- dimension of our aggregate itype. These N_Range nodes are collected
-- These N_Range nodes are collected in Aggr_Range above. -- in Aggr_Range above.
-- --
-- Likewise collect in Aggr_Low & Aggr_High above the low and high -- Likewise collect in Aggr_Low & Aggr_High above the low and high
-- bounds of each index dimension. If, when collecting, two bounds -- bounds of each index dimension. If, when collecting, two bounds
......
...@@ -10404,7 +10404,7 @@ package body Sem_Prag is ...@@ -10404,7 +10404,7 @@ package body Sem_Prag is
-- pragma Passive [(PASSIVE_FORM)]; -- pragma Passive [(PASSIVE_FORM)];
-- PASSIVE_FORM ::= Semaphore | No -- PASSIVE_FORM ::= Semaphore | No
when Pragma_Passive => when Pragma_Passive =>
GNAT_Pragma; GNAT_Pragma;
...@@ -10475,6 +10475,8 @@ package body Sem_Prag is ...@@ -10475,6 +10475,8 @@ package body Sem_Prag is
-- Persistent_BSS -- -- Persistent_BSS --
-------------------- --------------------
-- pragma Persistent_BSS [(object_NAME)];
when Pragma_Persistent_BSS => Persistent_BSS : declare when Pragma_Persistent_BSS => Persistent_BSS : declare
Decl : Node_Id; Decl : Node_Id;
Ent : Entity_Id; Ent : Entity_Id;
......
...@@ -134,6 +134,14 @@ package Snames is ...@@ -134,6 +134,14 @@ package Snames is
Name_Space : constant Name_Id := N + $; Name_Space : constant Name_Id := N + $;
Name_Time : 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 -- 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 -- at the start of these names get translated to extra underscores. These
-- names are only referenced internally by expander generated code. -- names are only referenced internally by expander generated code.
......
...@@ -801,7 +801,6 @@ package body Sprint is ...@@ -801,7 +801,6 @@ package body Sprint is
-- Select print circuit based on node kind -- Select print circuit based on node kind
case Nkind (Node) is case Nkind (Node) is
when N_Abort_Statement => when N_Abort_Statement =>
Write_Indent_Str_Sloc ("abort "); Write_Indent_Str_Sloc ("abort ");
Sprint_Comma_List (Names (Node)); Sprint_Comma_List (Names (Node));
...@@ -3091,7 +3090,6 @@ package body Sprint is ...@@ -3091,7 +3090,6 @@ package body Sprint is
Write_Char (';'); Write_Char (';');
end if; end if;
end if; end if;
end case; end case;
if Nkind (Node) in N_Subexpr if Nkind (Node) in N_Subexpr
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment