mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-03-22 22:51:32 +08:00
Code Issues Packages Projects Releases Wiki Activity

einfo.ads, einfo.adb: (First_Component_Or_Discriminant): New function

Browse Source 
2007-04-06  Robert Dewar  <dewar@adacore.com>
	    Thomas Quinot  <quinot@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>
	    Bob Duff  <duff@adacore.com>

	* einfo.ads, einfo.adb: (First_Component_Or_Discriminant): New function
	(Next_Component_Or_Discriminant): New function and procedure
	(First_Index, First_Literal, Master_Id,
	Set_First_Index, Set_First_Literal, Set_Master_Id):
	Add missing Ekind assertions.
	(Is_Access_Protected_Subprogram_Type): New predicate.
	(Has_RACW): New entity flag, set on package entities to indicate that
	the package contains the declaration of a remote accecss-to-classwide
	type.
	(E_Return_Statement): This node type has the Finalization_Chain_Entity
	attribute, in case the result type has controlled parts.
	(Requires_Overriding): Add this new flag, because "requires
	overriding" is subtly different from "is abstract" (see AI-228).
	(Is_Abstract): Split Is_Abstract flag into Is_Abstract_Subprogram and
	Is_Abstract_Type. Make sure these are called only when appropriate.
	(Has_Pragma_Unreferenced_Objects): New flag

	* exp_ch5.adb (Expand_N_Assignment_Statement): If the left-hand side is
	class-wide, the tag of the right-hand side must be an exact match, not
	an ancestor of that of the object on left-hand side.
	(Move_Activation_Chain): New procedure to create the call to
	System.Tasking.Stages.Move_Activation_Chain.
	(Expand_N_Extended_Return_Statement): Generate code to call
	System.Finalization_Implementation.Move_Final_List at the end of a
	return statement if the function's result type has controlled parts.
	Move asserts to Build_In_Place_Formal.
	(Move_Final_List): New function to create the call statement.
	(Expand_N_Assignment_Statement): In case of assignment to a class-wide
	tagged type, replace generation of call to the run-time subprogram
	CW_Membership by call to Build_CW_Membership.
	(Expand_N_Return_Statement): Replace generation of call to the run-time
	subprogram Get_Access_Level by call to Build_Get_Access_Level.
	(Expand_N_Simple_Function_Return): Replace generation of call to the
	run-time subprogram Get_Access_Level by call to Build_Get_Access_Level.

	* exp_ch6.ads, exp_ch6.adb (Expand_Call): Use new predicate
	Is_Access_Protected_Subprogram_Type, to handle both named and anonymous
	access to protected operations.
	(Add_Task_Actuals_To_Build_In_Place_Call): New procedure to add the
	master and chain actual parameters to a build-in-place function call
	involving tasks.
	(BIP_Formal_Suffix): Add new enumeration literals to complete the case
	statement.
	(Make_Build_In_Place_Call_In_Allocator,
	Make_Build_In_Place_Call_In_Anonymous_Context,
	Make_Build_In_Place_Call_In_Assignment,
	Make_Build_In_Place_Call_In_Object_Declaration): Call
	Add_Task_Actuals_To_Build_In_Place_Call with the appropriate master.
	(Expand_Inlined_Call): If the subprogram is a null procedure, or a
	stubbed procedure with a null body, replace the call with a null
	statement without using the full inlining machinery, for efficiency
	and to avoid invalid values in source file table entries.

	* exp_ch8.adb (Expand_N_Object_Renaming_Declaration): Add support for
	renamings of calls to build-in-place functions.

	* rtsfind.adb (RTE_Record_Component_Available): New subprogram that
	provides the functionality of RTE_Available to record components.
	(RTU_Entity): The function Entity has been renamed to RTU_Entity
	to avoid undesired overloading.
	(Entity): New subprogram that returns the entity for the referened
	unit. If this unit has not been loaded, it returns Empty.
	(RE_Activation_Chain_Access, RE_Move_Activation_Chain): New entities.
	Remove no longer used entities.
	(RE_Finalizable_Ptr_Ptr, RE_Move_Final_List): New entities.
	(RE_Type_Specific_Data): New entity.
	(RE_Move_Any_Value): New entity.
	(RE_TA_A, RE_Get_Any_Type): New entities.
	(RE_Access_Level, RE_Dispatch_Table, E_Default_Prim_Op_Count,
	 RE_Prims_Ptr, RE_RC_Offset, RE_Remotely_Callable,
	 RE_DT_Typeinfo_Ptr_Size, RE_Cstring_Ptr, RE_DT_Expanded_Name): Added.
	(Entity): New subprogram that returns the entity for the referened
	unit. If this unit has not been loaded, it returns Empty.
	(RTE): Addition of a new formal that extends the search to the scopes
	of the record types found in the chain of the package.

	* sem_ch6.ads, sem_ch6.adb (Check_Overriding_Indicator): Print
	"abstract subprograms must be visible" message, whether or not the type
	is an interface; that is, remove the special case for interface types.
	(Analyze_Function_Return): Remove error message "return of task objects
	is not yet implemented" because this is now implemented.
	(Create_Extra_Formals): Add the extra master and activation chain
	formals in case the result type has tasks.
	Remove error message "return of limited controlled objects is not yet
	implemented".
	(Create_Extra_Formals): Add the extra caller's finalization list formal
	in case the result type has controlled parts.
	(Process_Formals): In case of access formal types there is no need
	to continue with the analysis of the formals if we already notified
	errors.
	(Check_Overriding_Indicator): Add code to check overriding of predefined
	operators.
	(Create_Extra_Formals): Prevent creation of useless Extra_Constrained
	flags for formals that do not require them,.
	(Enter_Overloaded_Entity): Do not give -gnatwh warning message unless
	hidden entity is use visible or directly visible.
	(Analyze_Abstract_Subprogram_Declaration,Analyze_Subprogram_Body,
	Analyze_Subprogram_Declaration,Analyze_Subprogram_Specification,
	Check_Conventions,Check_Delayed_Subprogram,Make_Inequality_Operator,
	New_Overloaded_Entity): Split Is_Abstract flag into
	Is_Abstract_Subprogram and Is_Abstract_Type.

	* s-finimp.ads, s-finimp.adb (Move_Final_List): New procedure to move
	a return statement's finalization list to the caller's list, used for
	build-in-place functions with result type with controlled parts.
	Remove no longer used entities.

	* s-taskin.ads (Activation_Chain): Remove pragma Volatile. It is no
	longer needed, because the full type is now limited, and therefore a
	pass-by-reference type.
	(Foreign_Task_Level): New constant.

	* s-tassta.ads, s-tassta.adb (Move_Activation_Chain): New procedure to
	move tasks from the activation chain belonging to a return statement to
	the one passed in by the caller, and update the master to the one
	passed in by the caller.
	(Vulnerable_Complete_Master, Check_Unactivated_Tasks): Check the master
	of unactivated tasks, so we don't kill the ones that are being returned
	by a build-in-place function.
	(Create_Task): Ignore AI-280 for foreign threads.

From-SVN: r123558
This commit is contained in:
Robert Dewar 2007-04-06 11:19:10 +02:00 committed by Arnaud Charlet
parent 9dac0a42ea
commit f937473fe9
14 changed files with 4556 additions and 3651 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1637
gcc/ada/einfo.adb
View File

File diff suppressed because it is too large Load Diff

3316
gcc/ada/einfo.ads
View File

File diff suppressed because it is too large Load Diff

1164
gcc/ada/exp_ch5.adb
View File

File diff suppressed because it is too large Load Diff

924
gcc/ada/exp_ch6.adb
View File

File diff suppressed because it is too large Load Diff

80
gcc/ada/exp_ch6.ads
View File

@ -40,21 +40,83 @@ package Exp_Ch6 is
-- This procedure contains common processing for Expand_N_Function_Call,
-- Expand_N_Procedure_Statement, and Expand_N_Entry_Call.
procedure Freeze_Subprogram (N : Node_Id);
-- generate the appropriate expansions related to Subprogram freeze
-- nodes (e. g. the filling of the corresponding Dispatch Table for
-- Primitive Operations)
-- The following type defines the various forms of allocation used for the
-- results of build-in-place function calls.
type BIP_Allocation_Form is
(Unspecified,
Caller_Allocation,
Secondary_Stack,
Global_Heap,
User_Storage_Pool);
type BIP_Formal_Kind is
-- Ada 2005 (AI-318-02): This type defines the kinds of implicit extra
-- formals created for build-in-place functions. The order of the above
-- enumeration literals matches the order in which the formals are
-- declared. See Sem_Ch6.Create_Extra_Formals.
(BIP_Alloc_Form,
-- Present if result subtype is unconstrained. Indicates whether the
-- return object is allocated by the caller or callee, and if the
-- callee, whether to use the secondary stack or the heap. See
-- Create_Extra_Formals.
BIP_Final_List,
-- Present if result type has controlled parts. Pointer to caller's
-- finalization list.
BIP_Master,
-- Present if result type contains tasks. Master associated with
-- calling context.
BIP_Activation_Chain,
-- Present if result type contains tasks. Caller's activation chain.
BIP_Object_Access);
-- Present for all build-in-place functions. Address at which to place
-- the return object, or null if BIP_Alloc_Form indicates
-- allocated by callee.
-- ??? We also need to be able to pass in some way to access a
-- user-defined storage pool at some point. And perhaps a constrained
-- flag.
function BIP_Formal_Suffix (Kind : BIP_Formal_Kind) return String;
-- Ada 2005 (AI-318-02): Returns a string to be used as the suffix of names
-- for build-in-place formal parameters of the given kind.
function Build_In_Place_Formal
(Func : Entity_Id;
Kind : BIP_Formal_Kind) return Entity_Id;
-- Ada 2005 (AI-318-02): Locates and returns the entity for the implicit
-- build-in-place formal parameter of the given kind associated with the
-- function Func, and returns its Entity_Id. It is a bug if not found; the
-- caller should ensure this is called only when the extra formal exists.
function Is_Build_In_Place_Function (E : Entity_Id) return Boolean;
-- Ada 2005 (AI-318-02): Returns True if E denotes a function or an
-- access-to-function type whose result must be built in place; otherwise
-- returns False. Currently this is restricted to the subset of functions
-- whose result subtype is a constrained inherently limited type.
-- Ada 2005 (AI-318-02): Returns True if E denotes a function, generic
-- function, or access-to-function type whose result must be built in
-- place; otherwise returns False. For Ada 2005, this is currently
-- restricted to the set of functions whose result subtype is an inherently
-- limited type. In Ada 95, this must be False for inherently limited
-- result types (but currently returns False for all Ada 95 functions).
-- Eventually we plan to support build-in-place for nonlimited types.
-- Build-in-place is usually more efficient for large things, and less
-- efficient for small things. However, we never use build-in-place if the
-- convention is other than Ada, because that would disturb mixed-language
-- programs. Note that for the non-inherently-limited cases, we must make
-- the same decision for Ada 95 and 2005, so that mixed-dialect programs
-- will work.
function Is_Build_In_Place_Function_Call (N : Node_Id) return Boolean;
-- Ada 2005 (AI-318-02): Returns True if N denotes a call to a function
-- that requires handling as a build-in-place call or is a qualified
-- expression applied to such a call; otherwise returns False.
procedure Freeze_Subprogram (N : Node_Id);
-- generate the appropriate expansions related to Subprogram freeze
-- nodes (e. g. the filling of the corresponding Dispatch Table for
-- Primitive Operations)
function Is_Build_In_Place_Function_Return (N : Node_Id) return Boolean;
-- Ada 2005 (AI-318-02): Returns True if N is an N_Return_Statement or
-- N_Extended_Return_Statement and it applies to a build-in-place function
-- or generic function.
procedure Make_Build_In_Place_Call_In_Allocator
(Allocator : Node_Id;
@ -84,7 +146,7 @@ package Exp_Ch6 is
Function_Call : Node_Id);
-- Ada 2005 (AI-318-02): Handle a call to a build-in-place function that
-- occurs as the right-hand side of an assignment statement by passing
-- access to the left-hand sid as an additional parameter of the function
-- access to the left-hand side as an additional parameter of the function
-- call. Assign must denote a N_Assignment_Statement. Function_Call must
-- denote either an N_Function_Call node for which Is_Build_In_Place_Call
-- is True, or an N_Qualified_Expression node applied to such a function

17
gcc/ada/exp_ch8.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2006, 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- --
@ -26,10 +26,12 @@
with Atree; use Atree;
with Einfo; use Einfo;
with Exp_Ch6; use Exp_Ch6;
with Exp_Dbug; use Exp_Dbug;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with Nlists; use Nlists;
with Opt; use Opt;
with Sem; use Sem;
with Sem_Ch8; use Sem_Ch8;
with Sinfo; use Sinfo;
@ -268,6 +270,19 @@ package body Exp_Ch8 is
end if;
end if;
-- Ada 2005 (AI-318-02): If the renamed object is a call to a build-in-
-- place function, then a temporary return object needs to be created
-- and access to it must be passed to the function. Currently we limit
-- such functions to those with inherently limited result subtypes, but
-- eventually we plan to expand the functions that are treated as
-- build-in-place to include other composite result types.
if Ada_Version >= Ada_05
and then Is_Build_In_Place_Function_Call (Nam)
then
Make_Build_In_Place_Call_In_Anonymous_Context (Nam);
end if;
-- Create renaming entry for debug information
Decl := Debug_Renaming_Declaration (N);

330
gcc/ada/rtsfind.adb
View File

@ -54,8 +54,10 @@ with Uname; use Uname;
package body Rtsfind is
RTE_Available_Call : Boolean := False;
-- Set True during call to RTE from RTE_Available. Tells RTE to set
-- RTE_Is_Available to False rather than generating an error message.
-- Set True during call to RTE from RTE_Available (or from call to
-- RTE_Record_Component from RTE_Record_Component_Available). Tells
-- the called subprogram to set RTE_Is_Available to False rather than
-- generating an error message.
RTE_Is_Available : Boolean;
-- Set True by RTE_Available on entry. When RTE_Available_Call is set
@ -97,6 +99,11 @@ package body Rtsfind is
-- first time, its ID is stored in this array, so that subsequent calls
-- for the same entity can be satisfied immediately.
-- NOTE: In order to avoid conflicts between record components and subprgs
-- that have the same name (ie. subprogram External_Tag and component
-- External_Tag of package Ada.Tags) this table is not used with
-- Record_Components.
RE_Table : array (RE_Id) of Entity_Id;
--------------------------
@ -123,11 +130,20 @@ package body Rtsfind is
-- Local Subprograms --
-----------------------
function Check_CRT (E : RE_Id; Eid : Entity_Id) return Entity_Id;
-- Check entity Eid to ensure that configurable run-time restrictions
-- are met. May generate an error message and raise RE_Not_Available
-- if the entity E does not exist (i.e. Eid is Empty)
procedure Entity_Not_Defined (Id : RE_Id);
-- Outputs error messages for an entity that is not defined in the
-- run-time library (the form of the error message is tailored for
-- no run time/configurable run time mode as required).
function Get_Unit_Name (U_Id : RTU_Id) return Unit_Name_Type;
-- Retrieves the Unit Name given a unit id represented by its
-- enumeration value in RTU_Id.
procedure Load_Fail (S : String; U_Id : RTU_Id; Id : RE_Id);
-- Internal procedure called if we can't sucessfully locate or
-- process a run-time unit. The parameters give information about
@ -144,10 +160,6 @@ package body Rtsfind is
-- a normal situation in configurable run-time mode (and the message in
-- this case is suppressed unless we are operating in All_Errors_Mode).
function Get_Unit_Name (U_Id : RTU_Id) return Unit_Name_Type;
-- Retrieves the Unit Name given a unit id represented by its
-- enumeration value in RTU_Id.
procedure Load_RTU
(U_Id : RTU_Id;
Id : RE_Id := RE_Null;
@ -165,6 +177,10 @@ package body Rtsfind is
-- Id is used only for error message detail, and if it is RE_Null, then
-- the attempt to output the entity name is ignored.
function Make_Unit_Name (E : RE_Id; N : Node_Id) return Node_Id;
-- If the unit is a child unit, build fully qualified name for use in
-- With_Clause.
procedure Output_Entity_Name (Id : RE_Id; Msg : String);
-- Output continuation error message giving qualified name of entity
-- corresponding to Id, appending the string given by Msg. This call
@ -181,6 +197,37 @@ package body Rtsfind is
-- used if you are sure that the message comes directly or indirectly from
-- a call to the RTE function.
---------------
-- Check_CRT --
---------------
function Check_CRT (E : RE_Id; Eid : Entity_Id) return Entity_Id is
U_Id : constant RTU_Id := RE_Unit_Table (E);
begin
if No (Eid) then
Entity_Not_Defined (E);
raise RE_Not_Available;
-- Entity is available
else
-- If in No_Run_Time mode and entity is not in one of the
-- specially permitted units, raise the exception.
if No_Run_Time_Mode
and then not OK_No_Run_Time_Unit (U_Id)
then
Entity_Not_Defined (E);
raise RE_Not_Available;
end if;
-- Otherwise entity is accessible
return Eid;
end if;
end Check_CRT;
------------------------
-- Entity_Not_Defined --
------------------------
@ -658,6 +705,36 @@ package body Rtsfind is
end if;
end Load_RTU;
--------------------
-- Make_Unit_Name --
--------------------
function Make_Unit_Name (E : RE_Id; N : Node_Id) return Node_Id is
U_Id : constant RTU_Id := RE_Unit_Table (E);
U : RT_Unit_Table_Record renames RT_Unit_Table (U_Id);
Nam : Node_Id;
Scop : Entity_Id;
begin
Nam := New_Reference_To (U.Entity, Standard_Location);
Scop := Scope (U.Entity);
if Nkind (N) = N_Defining_Program_Unit_Name then
while Scop /= Standard_Standard loop
Nam :=
Make_Expanded_Name (Standard_Location,
Chars => Chars (U.Entity),
Prefix => New_Reference_To (Scop, Standard_Location),
Selector_Name => Nam);
Set_Entity (Nam, U.Entity);
Scop := Scope (Scop);
end loop;
end if;
return Nam;
end Make_Unit_Name;
-----------------------
-- Output_Entity_Name --
------------------------
@ -763,11 +840,6 @@ package body Rtsfind is
Save_Front_End_Inlining : Boolean;
function Check_CRT (Eid : Entity_Id) return Entity_Id;
-- Check entity Eid to ensure that configurable run-time restrictions
-- are met. May generate an error message and raise RE_Not_Available
-- if the entity E does not exist (i.e. Eid is Empty)
procedure Check_RPC;
-- Reject programs that make use of distribution features not supported
-- on the current target. On such targets (VMS, Vxworks, others?) we
@ -778,39 +850,6 @@ package body Rtsfind is
-- This function is used when entity E is in this compilation's main
-- unit. It gets the value from the already compiled declaration.
function Make_Unit_Name (N : Node_Id) return Node_Id;
-- If the unit is a child unit, build fully qualified name for use
-- in With_Clause.
---------------
-- Check_CRT --
---------------
function Check_CRT (Eid : Entity_Id) return Entity_Id is
begin
if No (Eid) then
Entity_Not_Defined (E);
raise RE_Not_Available;
-- Entity is available
else
-- If in No_Run_Time mode and entity is not in one of the
-- specially permitted units, raise the exception.
if No_Run_Time_Mode
and then not OK_No_Run_Time_Unit (U_Id)
then
Entity_Not_Defined (E);
raise RE_Not_Available;
end if;
-- Otherwise entity is accessible
return Eid;
end if;
end Check_CRT;
---------------
-- Check_RPC --
---------------
@ -847,9 +886,9 @@ package body Rtsfind is
end if;
end Check_RPC;
------------------------
-- Find_System_Entity --
------------------------
-----------------------
-- Find_Local_Entity --
-----------------------
function Find_Local_Entity (E : RE_Id) return Entity_Id is
RE_Str : String renames RE_Id'Image (E);
@ -871,34 +910,6 @@ package body Rtsfind is
return Ent;
end Find_Local_Entity;
--------------------
-- Make_Unit_Name --
--------------------
function Make_Unit_Name (N : Node_Id) return Node_Id is
Nam : Node_Id;
Scop : Entity_Id;
begin
Nam := New_Reference_To (U.Entity, Standard_Location);
Scop := Scope (U.Entity);
if Nkind (N) = N_Defining_Program_Unit_Name then
while Scop /= Standard_Standard loop
Nam :=
Make_Expanded_Name (Standard_Location,
Chars => Chars (U.Entity),
Prefix => New_Reference_To (Scop, Standard_Location),
Selector_Name => Nam);
Set_Entity (Nam, U.Entity);
Scop := Scope (Scop);
end loop;
end if;
return Nam;
end Make_Unit_Name;
-- Start of processing for RTE
begin
@ -917,7 +928,7 @@ package body Rtsfind is
and then Analyzed (Main_Unit_Entity)
and then not Is_Child_Unit (Main_Unit_Entity)
then
return Check_CRT (Find_Local_Entity (E));
return Check_CRT (E, Find_Local_Entity (E));
end if;
Save_Front_End_Inlining := Front_End_Inlining;
@ -947,16 +958,16 @@ package body Rtsfind is
-- First we search the package entity chain
Pkg_Ent := First_Entity (U.Entity);
while Present (Pkg_Ent) loop
if Ename = Chars (Pkg_Ent) then
RE_Table (E) := Pkg_Ent;
Check_RPC;
goto Found;
end if;
Pkg_Ent := First_Entity (U.Entity);
while Present (Pkg_Ent) loop
if Ename = Chars (Pkg_Ent) then
RE_Table (E) := Pkg_Ent;
Check_RPC;
goto Found;
end if;
Next_Entity (Pkg_Ent);
end loop;
Next_Entity (Pkg_Ent);
end loop;
-- If we did not find the entity in the package entity chain,
-- then check if the package entity itself matches. Note that
@ -979,7 +990,7 @@ package body Rtsfind is
-- a WITH if the current unit is part of the extended main code
-- unit, and if we have not already added the with. The WITH is
-- added to the appropriate unit (the current one). We do not need
-- to generate a WITH for an ????
-- to generate a WITH for a call issued from RTE_Available.
<<Found>>
if (not U.Withed)
@ -999,7 +1010,7 @@ package body Rtsfind is
Make_With_Clause (Standard_Location,
Name =>
Make_Unit_Name
(Defining_Unit_Name (Specification (Lib_Unit))));
(E, Defining_Unit_Name (Specification (Lib_Unit))));
Set_Library_Unit (Withn, Cunit (U.Unum));
Set_Corresponding_Spec (Withn, U.Entity);
Set_First_Name (Withn, True);
@ -1012,7 +1023,7 @@ package body Rtsfind is
end if;
Front_End_Inlining := Save_Front_End_Inlining;
return Check_CRT (RE_Table (E));
return Check_CRT (E, RE_Table (E));
end RTE;
-------------------
@ -1047,6 +1058,140 @@ package body Rtsfind is
return False;
end RTE_Available;
--------------------------
-- RTE_Record_Component --
--------------------------
function RTE_Record_Component (E : RE_Id) return Entity_Id is
U_Id : constant RTU_Id := RE_Unit_Table (E);
U : RT_Unit_Table_Record renames RT_Unit_Table (U_Id);
E1 : Entity_Id;
Ename : Name_Id;
Lib_Unit : Node_Id;
Pkg_Ent : Entity_Id;
-- The following flag is used to disable front-end inlining when
-- RTE_Record_Component is invoked. This prevents the analysis of other
-- runtime bodies when a particular spec is loaded through Rtsfind. This
-- is both efficient, and it prevents spurious visibility conflicts
-- between use-visible user entities, and entities in run-time packages.
-- In configurable run-time mode, subprograms marked Inlined_Always must
-- be inlined, so in the case we retain the Front_End_Inlining mode.
Save_Front_End_Inlining : Boolean;
begin
-- Note: Contrary to subprogram RTE, there is no need to do any special
-- management with package system.ads because it has no record type
-- declarations.
Save_Front_End_Inlining := Front_End_Inlining;
Front_End_Inlining := Configurable_Run_Time_Mode;
-- Load unit if unit not previously loaded
if not Present (U.Entity) then
Load_RTU (U_Id, Id => E);
end if;
Lib_Unit := Unit (Cunit (U.Unum));
pragma Assert (Nkind (Lib_Unit) = N_Package_Declaration);
Ename := RE_Chars (E);
-- Search the entity in the components of record type declarations
-- found in the package entity chain.
Pkg_Ent := First_Entity (U.Entity);
Search : while Present (Pkg_Ent) loop
if Is_Record_Type (Pkg_Ent) then
E1 := First_Entity (Pkg_Ent);
while Present (E1) loop
if Ename = Chars (E1) then
exit Search;
end if;
Next_Entity (E1);
end loop;
end if;
Next_Entity (Pkg_Ent);
end loop Search;
-- If we didn't find the entity we want, something is wrong. The
-- appropriate action will be taken by Check_CRT when we exit.
-- Cenerate a with-clause if the current unit is part of the extended
-- main code unit, and if we have not already added the with. The clause
-- is added to the appropriate unit (the current one). We do not need to
-- generate it for a call issued from RTE_Component_Available.
if (not U.Withed)
and then
In_Extended_Main_Code_Unit (Cunit_Entity (Current_Sem_Unit))
and then not RTE_Available_Call
then
U.Withed := True;
declare
Withn : Node_Id;
Lib_Unit : Node_Id;
begin
Lib_Unit := Unit (Cunit (U.Unum));
Withn :=
Make_With_Clause (Standard_Location,
Name =>
Make_Unit_Name
(E, Defining_Unit_Name (Specification (Lib_Unit))));
Set_Library_Unit (Withn, Cunit (U.Unum));
Set_Corresponding_Spec (Withn, U.Entity);
Set_First_Name (Withn, True);
Set_Implicit_With (Withn, True);
Mark_Rewrite_Insertion (Withn);
Append (Withn, Context_Items (Cunit (Current_Sem_Unit)));
Check_Restriction_No_Dependence (Name (Withn), Current_Error_Node);
end;
end if;
Front_End_Inlining := Save_Front_End_Inlining;
return Check_CRT (E, E1);
end RTE_Record_Component;
------------------------------------
-- RTE_Record_Component_Available --
------------------------------------
function RTE_Record_Component_Available (E : RE_Id) return Boolean is
Dummy : Entity_Id;
pragma Warnings (Off, Dummy);
Result : Boolean;
Save_RTE_Available_Call : constant Boolean := RTE_Available_Call;
Save_RTE_Is_Available : constant Boolean := RTE_Is_Available;
-- These are saved recursively because the call to load a unit
-- caused by an upper level call may perform a recursive call
-- to this routine during analysis of the corresponding unit.
begin
RTE_Available_Call := True;
RTE_Is_Available := True;
Dummy := RTE_Record_Component (E);
Result := RTE_Is_Available;
RTE_Available_Call := Save_RTE_Available_Call;
RTE_Is_Available := Save_RTE_Is_Available;
return Result;
exception
when RE_Not_Available =>
RTE_Available_Call := Save_RTE_Available_Call;
RTE_Is_Available := Save_RTE_Is_Available;
return False;
end RTE_Record_Component_Available;
-------------------
-- RTE_Error_Msg --
-------------------
@ -1068,6 +1213,15 @@ package body Rtsfind is
end if;
end RTE_Error_Msg;
----------------
-- RTU_Entity --
----------------
function RTU_Entity (U : RTU_Id) return Entity_Id is
begin
return RT_Unit_Table (U).Entity;
end RTU_Entity;
----------------
-- RTU_Loaded --
----------------

130
gcc/ada/s-finimp.adb
View File

@ -168,7 +168,7 @@ package body System.Finalization_Implementation is
Nb_Link : Short_Short_Integer)
is
begin
-- Simple case: attachement to a one way list
-- Simple case: attachment to a one way list
if Nb_Link = 1 then
Obj.Next := L;
@ -176,7 +176,7 @@ package body System.Finalization_Implementation is
-- Dynamically allocated objects: they are attached to a doubly linked
-- list, so that an element can be finalized at any moment by means of
-- an unchecked deallocation. Attachement is protected against
-- an unchecked deallocation. Attachment is protected against
-- multi-threaded access.
elsif Nb_Link = 2 then
@ -203,7 +203,7 @@ package body System.Finalization_Implementation is
raise;
end Locked_Processing;
-- Attachement of arrays to the final list (used only for objects
-- Attachment of arrays to the final list (used only for objects
-- returned by function). Obj, in this case is the last element,
-- but all other elements are already threaded after it. We just
-- attach the rest of the final list at the end of the array list.
@ -230,32 +230,6 @@ package body System.Finalization_Implementation is
end if;
end Attach_To_Final_List;
---------------------
-- Deep_Tag_Adjust --
---------------------
procedure Deep_Tag_Adjust
(L : in out SFR.Finalizable_Ptr;
A : System.Address;
B : Short_Short_Integer)
is
V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A);
Controller : constant RC_Ptr := Get_Deep_Controller (A);
begin
if Controller /= null then
Adjust (Controller.all);
Attach_To_Final_List (L, Controller.all, B);
end if;
-- Is controlled
if V.all in Finalizable then
Adjust (V.all);
Attach_To_Final_List (L, Finalizable (V.all), 1);
end if;
end Deep_Tag_Adjust;
---------------------
-- Deep_Tag_Attach --
----------------------
@ -280,74 +254,6 @@ package body System.Finalization_Implementation is
end if;
end Deep_Tag_Attach;
-----------------------
-- Deep_Tag_Finalize --
-----------------------
procedure Deep_Tag_Finalize
(L : in out SFR.Finalizable_Ptr;
A : System.Address;
B : Boolean)
is
pragma Warnings (Off, L);
V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A);
Controller : constant RC_Ptr := Get_Deep_Controller (A);
begin
if Controller /= null then
if B then
Finalize_One (Controller.all);
else
Finalize (Controller.all);
end if;
end if;
-- Is controlled
if V.all in Finalizable then
if B then
Finalize_One (V.all);
else
Finalize (V.all);
end if;
end if;
end Deep_Tag_Finalize;
-------------------------
-- Deep_Tag_Initialize --
-------------------------
procedure Deep_Tag_Initialize
(L : in out SFR.Finalizable_Ptr;
A : System.Address;
B : Short_Short_Integer)
is
V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A);
Controller : constant RC_Ptr := Get_Deep_Controller (A);
begin
-- This procedure should not be called if the object has no
-- controlled components
if Controller = null then
raise Program_Error;
-- Has controlled components
else
Initialize (Controller.all);
Attach_To_Final_List (L, Controller.all, B);
end if;
-- Is controlled
if V.all in Finalizable then
Initialize (V.all);
Attach_To_Final_List (Controller.F, Finalizable (Controller.all), 1);
end if;
end Deep_Tag_Initialize;
-----------------------------
-- Detach_From_Final_List --
-----------------------------
@ -441,7 +347,7 @@ package body System.Finalization_Implementation is
-- programs using controlled types heavily.
if System.Restrictions.Abort_Allowed then
X := To_Ptr (System.Soft_Links.Get_Current_Excep.all).Id;
X := To_Ptr (SSL.Get_Current_Excep.all).Id;
end if;
while P /= null loop
@ -554,6 +460,34 @@ package body System.Finalization_Implementation is
Object.My_Address := Object'Address;
end Initialize;
---------------------
-- Move_Final_List --
---------------------
procedure Move_Final_List
(From : in out SFR.Finalizable_Ptr;
To : Finalizable_Ptr_Ptr)
is
begin
-- This is currently called at the end of the return statement, and the
-- caller does NOT defer aborts. We need to defer aborts to prevent
-- mangling the finalization lists.
SSL.Abort_Defer.all;
-- Put the return statement's finalization list onto the caller's one,
-- thus transferring responsibility for finalization of the return
-- object to the caller.
Attach_To_Final_List (To.all, From.all, Nb_Link => 3);
-- Empty the return statement's finalization list, so that when the
-- cleanup code executes, there will be nothing to finalize.
From := null;
SSL.Abort_Undefer.all;
end Move_Final_List;
-------------------------
-- Raise_From_Finalize --
-------------------------

94
gcc/ada/s-finimp.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2006 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2006, 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- --
@ -51,15 +51,15 @@ package System.Finalization_Implementation is
Collection_Finalization_Started : constant SFR.Finalizable_Ptr :=
To_Finalizable_Ptr (SSE.To_Address (1));
-- This is used to implement the rule in RM-4.8(10.2/2) that requires an
-- This is used to implement the rule in RM 4.8(10.2/2) that requires an
-- allocator to raise Program_Error if the collection finalization has
-- already started. See also Ada.Finalization.List_Controller. Finalize on
-- List_Controller first sets the list to Collection_Finalization_Started,
-- to indicate that finalization has started. An allocator will call
-- Attach_To_Final_List, which checks for the special value and raises
-- Program_Error if appropriate. The value of
-- Collection_Finalization_Started must be different from 'Access of any
-- finalizable object, and different from null. See AI-280.
-- Program_Error if appropriate. The Collection_Finalization_Started value
-- must be different from 'Access of any finalizable object, and different
-- from null. See AI-280.
Global_Final_List : SFR.Finalizable_Ptr;
-- This list stores the controlled objects defined in library-level
@ -72,60 +72,52 @@ package System.Finalization_Implementation is
(L : in out SFR.Finalizable_Ptr;
Obj : in out SFR.Finalizable;
Nb_Link : Short_Short_Integer);
-- Attach finalizable object Obj to the linked list L. Nb_Link controls
-- the number of link of the linked_list, and can be either 0 for no
-- attachement, 1 for simple linked lists or 2 for doubly linked lists
-- or even 3 for a simple attachement of a whole array of elements.
-- Attachement to a simply linked list is not protected against
-- concurrent access and should only be used in contexts where it
-- doesn't matter, such as for objects allocated on the stack. In the
-- case of an attachment on a doubly linked list, L must not be null
-- and Obj will be inserted AFTER the first element and the attachment
-- is protected against concurrent call. Typically used to attach to
-- a dynamically allocated object to a List_Controller (whose first
-- element is always a dummy element)
-- Attach finalizable object Obj to the linked list L. Nb_Link controls the
-- number of link of the linked_list, and is one of: 0 for no attachment, 1
-- for simple linked lists or 2 for doubly linked lists or even 3 for a
-- simple attachment of a whole array of elements. Attachment to a simply
-- linked list is not protected against concurrent access and should only
-- be used in contexts where it doesn't matter, such as for objects
-- allocated on the stack. In the case of an attachment on a doubly linked
-- list, L must not be null and Obj will be inserted AFTER the first
-- element and the attachment is protected against concurrent call.
-- Typically used to attach to a dynamically allocated object to a
-- List_Controller (whose first element is always a dummy element)
type Finalizable_Ptr_Ptr is access all SFR.Finalizable_Ptr;
-- A pointer to a finalization list. This is used as the type of the extra
-- implicit formal which are passed to build-in-place functions that return
-- controlled types (see Sem_Ch6). That extra formal is then passed on to
-- Move_Final_List (below).
procedure Move_Final_List
(From : in out SFR.Finalizable_Ptr;
To : Finalizable_Ptr_Ptr);
-- Move all objects on From list to To list. This is used to implement
-- build-in-place function returns. The return object is initially placed
-- on a finalization list local to the return statement, in case the
-- return statement is left prematurely (due to raising an exception,
-- being aborted, or a goto or exit statement). Once the return statement
-- has completed successfully, Move_Final_List is called to move the
-- return object to the caller's finalization list.
procedure Finalize_List (L : SFR.Finalizable_Ptr);
-- Call Finalize on each element of the list L;
procedure Finalize_One (Obj : in out SFR.Finalizable);
-- Call Finalize on Obj and remove its final list.
-- Call Finalize on Obj and remove its final list
---------------------
-- Deep Procedures --
---------------------
procedure Deep_Tag_Initialize
(L : in out SFR.Finalizable_Ptr;
A : System.Address;
B : Short_Short_Integer);
-- Generic initialize for tagged objects with controlled components.
-- A is the address of the object, L the finalization list when it needs
-- to be attached and B the attachement level (see Attach_To_Final_List).
procedure Deep_Tag_Adjust
(L : in out SFR.Finalizable_Ptr;
A : System.Address;
B : Short_Short_Integer);
-- Generic adjust for tagged objects with controlled components.
-- A is the address of the object, L the finalization list when it needs
-- to be attached and B the attachement level (see Attach_To_Final_List).
procedure Deep_Tag_Finalize
(L : in out SFR.Finalizable_Ptr;
A : System.Address;
B : Boolean);
-- Generic finalize for tagged objects with controlled components.
-- A is the address of the object, L the finalization list when it needs
-- to be attached and B the attachement level (see Attach_To_Final_List).
procedure Deep_Tag_Attach
(L : in out SFR.Finalizable_Ptr;
A : System.Address;
B : Short_Short_Integer);
-- Generic attachement for tagged objects with controlled components.
-- Generic attachment for tagged objects with controlled components.
-- A is the address of the object, L the finalization list when it needs
-- to be attached and B the attachement level (see Attach_To_Final_List).
-- to be attached and B the attachment level (see Attach_To_Final_List).
-----------------------------
-- Record Controller Types --
@ -141,11 +133,11 @@ package System.Finalization_Implementation is
end record;
procedure Initialize (Object : in out Limited_Record_Controller);
-- Does nothing.
-- Does nothing currently.
procedure Finalize (Object : in out Limited_Record_Controller);
-- Finalize the controlled components of the enclosing record by
-- following the list starting at Object.F.
-- Finalize the controlled components of the enclosing record by following
-- the list starting at Object.F.
type Record_Controller is
new Limited_Record_Controller with record
@ -156,13 +148,13 @@ package System.Finalization_Implementation is
-- Initialize the field My_Address to the Object'Address
procedure Adjust (Object : in out Record_Controller);
-- Adjust the components and their finalization pointers by subtracting
-- by the offset of the target and the source addresses of the assignment.
-- Adjust the components and their finalization pointers by subtracting by
-- the offset of the target and the source addresses of the assignment.
-- Inherit Finalize from Limited_Record_Controller
procedure Detach_From_Final_List (Obj : in out SFR.Finalizable);
-- Remove the specified object from its Final list, which must be a
-- doubly linked list.
-- Remove the specified object from its Final list, which must be a doubly
-- linked list.
end System.Finalization_Implementation;

23
gcc/ada/s-taskin.ads
View File

@ -364,10 +364,12 @@ package System.Tasking is
------------------------------------
type Activation_Chain is limited private;
-- Comment required ???
-- Linked list of to-be-activated tasks, linked through
-- Activation_Link. The order of tasks on the list is irrelevant, because
-- the priority rules will ensure that they actually start activating in
-- priority order.
type Activation_Chain_Access is access all Activation_Chain;
-- Comment required ???
type Task_Procedure_Access is access procedure (Arg : System.Address);
@ -651,11 +653,14 @@ package System.Tasking is
-- Normally, a task starts out with internal master nesting level one
-- larger than external master nesting level. It is incremented to one by
-- Enter_Master, which is called in the task body only if the compiler
-- thinks the task may have dependent tasks. It is set to for the
-- thinks the task may have dependent tasks. It is set to 1 for the
-- environment task, the level 2 is reserved for server tasks of the
-- run-time system (the so called "independent tasks"), and the level 3 is
-- for the library level tasks.
-- for the library level tasks. Foreign threads which are detected by
-- the run-time have a level of 0, allowing these tasks to be easily
-- distinguished if needed.
Foreign_Task_Level : constant Master_Level := 0;
Environment_Task_Level : constant Master_Level := 1;
Independent_Task_Level : constant Master_Level := 2;
Library_Task_Level : constant Master_Level := 3;
@ -1062,14 +1067,14 @@ package System.Tasking is
private
Null_Task : constant Task_Id := null;
type Activation_Chain is record
type Activation_Chain is limited record
T_ID : Task_Id;
end record;
pragma Volatile (Activation_Chain);
-- Activation_chain is an in-out parameter of initialization procedures
-- and it must be passed by reference because the init proc may terminate
-- Activation_Chain is an in-out parameter of initialization procedures and
-- it must be passed by reference because the init proc may terminate
-- abnormally after creating task components, and these must be properly
-- registered for removal (Expunge_Unactivated_Tasks).
-- registered for removal (Expunge_Unactivated_Tasks). The "limited" forces
-- Activation_Chain to be a by-reference type; see RM-6.2(4).
end System.Tasking;

79
gcc/ada/s-tassta.adb
View File

@ -149,6 +149,9 @@ package body System.Tasking.Stages is
-- trigger an automatic stack alignment suitable for GCC's assumptions if
-- need be.
-- "Vulnerable_..." in the procedure names below means they must be called
-- with abort deferred.
procedure Vulnerable_Complete_Task (Self_ID : Task_Id);
-- Complete the calling task. This procedure must be called with
-- abort deferred. It should only be called by Complete_Task and
@ -520,9 +523,11 @@ package body System.Tasking.Stages is
begin
-- If Master is greater than the current master, it means that Master
-- has already awaited its dependent tasks. This raises Program_Error,
-- by 4.8(10.3/2). See AI-280.
-- by 4.8(10.3/2). See AI-280. Ignore this check for foreign threads.
if Master > Self_ID.Master_Within then
if Self_ID.Master_of_Task /= Foreign_Task_Level
and then Master > Self_ID.Master_Within
then
raise Program_Error with
"create task after awaiting termination";
end if;
@ -877,6 +882,53 @@ package body System.Tasking.Stages is
end if;
end Free_Task;
---------------------------
-- Move_Activation_Chain --
---------------------------
procedure Move_Activation_Chain
(From, To : Activation_Chain_Access;
New_Master : Master_ID)
is
Self_ID : constant Task_Id := STPO.Self;
C : Task_Id;
begin
pragma Debug
(Debug.Trace (Self_ID, "Move_Activation_Chain", 'C'));
-- Nothing to do if From is empty, and we can check that without
-- deferring aborts.
C := From.all.T_ID;
if C = null then
return;
end if;
Initialization.Defer_Abort (Self_ID);
-- Loop through the From chain, changing their Master_of_Task
-- fields, and to find the end of the chain.
loop
C.Master_of_Task := New_Master;
exit when C.Common.Activation_Link = null;
C := C.Common.Activation_Link;
end loop;
-- Hook From in at the start of To
C.Common.Activation_Link := To.all.T_ID;
To.all.T_ID := From.all.T_ID;
-- Set From to empty
From.all.T_ID := null;
Initialization.Undefer_Abort (Self_ID);
end Move_Activation_Chain;
------------------
-- Task_Wrapper --
------------------
@ -1407,7 +1459,7 @@ package body System.Tasking.Stages is
C := All_Tasks_List;
while C /= null loop
if C.Common.Activator = Self_ID then
if C.Common.Activator = Self_ID and then C.Master_of_Task = CM then
return False;
end if;
@ -1449,13 +1501,24 @@ package body System.Tasking.Stages is
-- zero for new tasks, and the task should not exit the
-- sleep-loops that use this count until the count reaches zero.
-- While we're counting, if we run across any unactivated tasks that
-- belong to this master, we summarily terminate them as required by
-- RM-9.2(6).
Lock_RTS;
Write_Lock (Self_ID);
C := All_Tasks_List;
while C /= null loop
if C.Common.Activator = Self_ID then
-- Terminate unactivated (never-to-be activated) tasks
if C.Common.Activator = Self_ID and then C.Master_of_Task = CM then
pragma Assert (C.Common.State = Unactivated);
-- Usually, C.Common.Activator = Self_ID implies C.Master_of_Task
-- = CM. The only case where C is pending activation by this
-- task, but the master of C is not CM is in Ada 2005, when C is
-- part of a return object of a build-in-place function.
Write_Lock (C);
C.Common.Activator := null;
@ -1465,6 +1528,8 @@ package body System.Tasking.Stages is
Unlock (C);
end if;
-- Count it if dependent on this master
if C.Common.Parent = Self_ID and then C.Master_of_Task = CM then
Write_Lock (C);
@ -1733,9 +1798,9 @@ package body System.Tasking.Stages is
-- Complete the calling task
-- This procedure must be called with abort deferred. (That's why the
-- name has "Vulnerable" in it.) It should only be called by Complete_Task
-- and Finalize_Global_Tasks (for the environment task).
-- This procedure must be called with abort deferred. It should only be
-- called by Complete_Task and Finalize_Global_Tasks (for the environment
-- task).
-- The effect is similar to that of Complete_Master. Differences include
-- the closing of entries here, and computation of the number of active

20
gcc/ada/s-tassta.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
@ -143,6 +143,8 @@ package System.Tasking.Stages is
-- it is not needed if priority-based scheduling is supported, since all
-- the activated tasks synchronize on the activators lock before they
-- start activating and so they should start activating in priority order.
-- ??? Actually, the body of this package DOES reverse the chain, so I
-- don't understand the above comment.
procedure Complete_Activation;
-- Compiler interface only. Do not call from within the RTS.
@ -255,6 +257,22 @@ package System.Tasking.Stages is
-- if T has terminated. Do nothing in the other case. It is called from
-- Unchecked_Deallocation, for objects that are or contain tasks.
procedure Move_Activation_Chain
(From, To : Activation_Chain_Access;
New_Master : Master_ID);
-- Compiler interface only. Do not call from within the RTS.
-- Move all tasks on From list to To list, and change their Master_of_Task
-- to be New_Master. This is used to implement build-in-place function
-- returns. Tasks that are part of the return object are initially placed
-- on an activation chain local to the return statement, and their master
-- is the return statement, in case the return statement is left
-- prematurely (due to raising an exception, being aborted, or a goto or
-- exit statement). Once the return statement has completed successfully,
-- Move_Activation_Chain is called to move them to the caller's activation
-- chain, and change their master to the one passed in by the caller. If
-- that doesn't happen, they will never be activated, and will become
-- terminated on leaving the return statement.
function Terminated (T : Task_Id) return Boolean;
-- This is called by the compiler to implement the 'Terminated attribute.
-- Though is not required to be so by the ARM, we choose to synchronize

370
gcc/ada/sem_ch6.adb
View File

@ -124,11 +124,6 @@ package body Sem_Ch6 is
-- If proper warnings are enabled and the subprogram contains a construct
-- that cannot be inlined, the offending construct is flagged accordingly.
type Conformance_Type is
(Type_Conformant, Mode_Conformant, Subtype_Conformant, Fully_Conformant);
-- Conformance type used for following call, meaning matches the
-- RM definitions of the corresponding terms.
procedure Check_Conformance
(New_Id : Entity_Id;
Old_Id : Entity_Id;
@ -177,15 +172,6 @@ package body Sem_Ch6 is
-- True otherwise. Proc is the entity for the procedure case and is used
-- in posting the warning message.
function Conforming_Types
(T1 : Entity_Id;
T2 : Entity_Id;
Ctype : Conformance_Type;
Get_Inst : Boolean := False) return Boolean;
-- Check that two formal parameter types conform, checking both for
-- equality of base types, and where required statically matching
-- subtypes, depending on the setting of Ctype.
procedure Enter_Overloaded_Entity (S : Entity_Id);
-- This procedure makes S, a new overloaded entity, into the first visible
-- entity with that name.
@ -367,7 +353,7 @@ package body Sem_Ch6 is
begin
Generate_Definition (Designator);
Set_Is_Abstract (Designator);
Set_Is_Abstract_Subprogram (Designator);
New_Overloaded_Entity (Designator);
Check_Delayed_Subprogram (Designator);
@ -638,41 +624,6 @@ package body Sem_Ch6 is
end;
end if;
-- ???Check for not-yet-implemented cases of AI-318. Currently we
-- warn, because that's convenient for our own use. We might want to
-- change these warnings to errors at some point. This will go away
-- once AI-318 is fully implemented.
--
-- In the first version, we plan not to implement limited function
-- returns when the result type contains tasks or protected objects,
-- and when the result subtype is unconstrained.
if Ada_Version >= Ada_05
and then not Debug_Flag_Dot_L
and then Is_Inherently_Limited_Type (R_Type)
then
if Has_Task (R_Type) then
Error_Msg_N ("(Ada 2005) return of task objects" &
" is not yet implemented", N);
end if;
if Is_Controlled (R_Type)
or else Has_Controlled_Component (R_Type)
then
Error_Msg_N
("(Ada 2005) return of limited controlled objects" &
" is not yet implemented", N);
end if;
if
Is_Composite_Type (R_Type) and then not Is_Constrained (R_Type)
then
Error_Msg_N
("(Ada 2005) return of unconstrained limited composite objects" &
" is not yet implemented", N);
end if;
end if;
if Present (Expr)
and then Present (Etype (Expr)) -- Could be False in case of errors.
then
@ -1373,7 +1324,9 @@ package body Sem_Ch6 is
-- subprogram declaration for it, in order to attach the body to inline.
procedure Copy_Parameter_List (Plist : List_Id);
-- Comment required ???
-- Utility to create a parameter profile for a new subprogram spec,
-- when the subprogram has a body that acts as spec. This is done for
-- some cases of inlining, and for private protected ops.
procedure Verify_Overriding_Indicator;
-- If there was a previous spec, the entity has been entered in the
@ -1767,7 +1720,7 @@ package body Sem_Ch6 is
Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id));
Set_Is_Child_Unit (Body_Id, Is_Child_Unit (Spec_Id));
if Is_Abstract (Spec_Id) then
if Is_Abstract_Subprogram (Spec_Id) then
Error_Msg_N ("an abstract subprogram cannot have a body", N);
return;
else
@ -1843,36 +1796,6 @@ package body Sem_Ch6 is
(Etype (First_Entity (Spec_Id))));
end if;
-- Ada 2005: A formal that is an access parameter may have a
-- designated type imported through a limited_with clause, while
-- the body has a regular with clause. Update the types of the
-- formals accordingly, so that the non-limited view of each type
-- is available in the body. We have already verified that the
-- declarations are type-conformant.
if Ada_Version >= Ada_05 then
declare
F_Spec : Entity_Id;
F_Body : Entity_Id;
begin
F_Spec := First_Formal (Spec_Id);
F_Body := First_Formal (Body_Id);
while Present (F_Spec) loop
if Ekind (Etype (F_Spec)) = E_Anonymous_Access_Type
and then
From_With_Type (Designated_Type (Etype (F_Spec)))
then
Set_Etype (F_Spec, Etype (F_Body));
end if;
Next_Formal (F_Spec);
Next_Formal (F_Body);
end loop;
end;
end if;
-- Now make the formals visible, and place subprogram
-- on scope stack.
@ -2296,7 +2219,7 @@ package body Sem_Ch6 is
end if;
if Is_Interface (Etyp)
and then not Is_Abstract (Designator)
and then not Is_Abstract_Subprogram (Designator)
and then not (Ekind (Designator) = E_Procedure
and then Null_Present (Specification (N)))
then
@ -2441,7 +2364,7 @@ package body Sem_Ch6 is
-- interface types the following error message will be reported later
-- (see Analyze_Subprogram_Declaration).
if Is_Abstract (Etype (Designator))
if Is_Abstract_Type (Etype (Designator))
and then not Is_Interface (Etype (Designator))
and then Nkind (Parent (N))
/= N_Abstract_Subprogram_Declaration
@ -2449,7 +2372,8 @@ package body Sem_Ch6 is
/= N_Formal_Abstract_Subprogram_Declaration
and then (Nkind (Parent (N)) /= N_Subprogram_Renaming_Declaration
or else not Is_Entity_Name (Name (Parent (N)))
or else not Is_Abstract (Entity (Name (Parent (N)))))
or else not Is_Abstract_Subprogram
(Entity (Name (Parent (N)))))
then
Error_Msg_N
("function that returns abstract type must be abstract", N);
@ -2464,7 +2388,7 @@ package body Sem_Ch6 is
--------------------------
procedure Build_Body_To_Inline (N : Node_Id; Subp : Entity_Id) is
Decl : constant Node_Id := Unit_Declaration_Node (Subp);
Decl : constant Node_Id := Unit_Declaration_Node (Subp);
Original_Body : Node_Id;
Body_To_Analyze : Node_Id;
Max_Size : constant := 10;
@ -2479,24 +2403,24 @@ package body Sem_Ch6 is
-- elementary statements, as a measure of acceptable size.
function Has_Pending_Instantiation return Boolean;
-- If some enclosing body contains instantiations that appear before
-- the corresponding generic body, the enclosing body has a freeze node
-- so that it can be elaborated after the generic itself. This might
-- If some enclosing body contains instantiations that appear before the
-- corresponding generic body, the enclosing body has a freeze node so
-- that it can be elaborated after the generic itself. This might
-- conflict with subsequent inlinings, so that it is unsafe to try to
-- inline in such a case.
function Has_Single_Return return Boolean;
-- In general we cannot inline functions that return unconstrained
-- type. However, we can handle such functions if all return statements
-- return a local variable that is the only declaration in the body
-- of the function. In that case the call can be replaced by that
-- local variable as is done for other inlined calls.
-- In general we cannot inline functions that return unconstrained type.
-- However, we can handle such functions if all return statements return
-- a local variable that is the only declaration in the body of the
-- function. In that case the call can be replaced by that local
-- variable as is done for other inlined calls.
procedure Remove_Pragmas;
-- A pragma Unreferenced that mentions a formal parameter has no
-- meaning when the body is inlined and the formals are rewritten.
-- Remove it from body to inline. The analysis of the non-inlined body
-- will handle the pragma properly.
-- A pragma Unreferenced that mentions a formal parameter has no meaning
-- when the body is inlined and the formals are rewritten. Remove it
-- from body to inline. The analysis of the non-inlined body will handle
-- the pragma properly.
function Uses_Secondary_Stack (Bod : Node_Id) return Boolean;
-- If the body of the subprogram includes a call that returns an
@ -3462,7 +3386,7 @@ package body Sem_Ch6 is
-- are left by an erroneous overriding.
if not Is_Predefined_Dispatching_Operation (Prim_Op)
and then not Is_Abstract (Prim_Op)
and then not Is_Abstract_Subprogram (Prim_Op)
and then Chars (Prim_Op) = Chars (Op)
and then Type_Conformant (Prim_Op, Op)
and then Convention (Prim_Op) /= Convention (Op)
@ -3503,7 +3427,7 @@ package body Sem_Ch6 is
-- of abstract primitives left from an erroneous overriding.
if not Is_Predefined_Dispatching_Operation (Prim_Op)
and then not Is_Abstract (Prim_Op)
and then not Is_Abstract_Subprogram (Prim_Op)
then
Check_Convention
(Op => Prim_Op,
@ -3550,7 +3474,9 @@ package body Sem_Ch6 is
begin
-- Never need to freeze abstract subprogram
if Is_Abstract (Designator) then
if Ekind (Designator) /= E_Subprogram_Type
and then Is_Abstract_Subprogram (Designator)
then
null;
else
-- Need delayed freeze if return type itself needs a delayed
@ -3585,7 +3511,7 @@ package body Sem_Ch6 is
if Is_Inherently_Limited_Type (Typ) then
Set_Returns_By_Ref (Designator);
elsif Present (Utyp) and then Controlled_Type (Utyp) then
elsif Present (Utyp) and then CW_Or_Controlled_Type (Utyp) then
Set_Returns_By_Ref (Designator);
end if;
end;
@ -3801,6 +3727,7 @@ package body Sem_Ch6 is
if Nkind (Decl) = N_Subprogram_Body
or else Nkind (Decl) = N_Subprogram_Body_Stub
or else Nkind (Decl) = N_Subprogram_Declaration
or else Nkind (Decl) = N_Abstract_Subprogram_Declaration
or else Nkind (Decl) = N_Subprogram_Renaming_Declaration
then
Spec := Specification (Decl);
@ -3819,15 +3746,41 @@ package body Sem_Ch6 is
if Ekind (Subp) = E_Entry then
Error_Msg_NE ("entry & overrides inherited operation #",
Spec, Subp);
else
Error_Msg_NE ("subprogram & overrides inherited operation #",
Spec, Subp);
end if;
end if;
-- If Subp is an operator, it may override a predefined operation.
-- In that case overridden_subp is empty because of our implicit
-- representation for predefined operators. We have to check whether
-- the signature of Subp matches that of a predefined operator.
-- Note that first argument provides the name of the operator, and
-- the second argument the signature that may match that of a standard
-- operation.
elsif Nkind (Subp) = N_Defining_Operator_Symbol
and then Must_Not_Override (Spec)
then
if Operator_Matches_Spec (Subp, Subp) then
Error_Msg_NE
("subprogram & overrides predefined operation ",
Spec, Subp);
end if;
else
if Must_Override (Spec) then
if Ekind (Subp) = E_Entry then
Error_Msg_NE ("entry & is not overriding", Spec, Subp);
elsif Nkind (Subp) = N_Defining_Operator_Symbol then
if not Operator_Matches_Spec (Subp, Subp) then
Error_Msg_NE
("subprogram & is not overriding", Spec, Subp);
end if;
else
Error_Msg_NE ("subprogram & is not overriding", Spec, Subp);
end if;
@ -3936,7 +3889,6 @@ package body Sem_Ch6 is
declare
Arg : constant Node_Id :=
Original_Node (First_Actual (Last_Stm));
begin
if Nkind (Arg) = N_Attribute_Reference
and then Attribute_Name (Arg) = Name_Identity
@ -4379,28 +4331,11 @@ package body Sem_Ch6 is
-- treated recursively because they carry a signature.
Are_Anonymous_Access_To_Subprogram_Types :=
-- Case 1: Anonymous access to subprogram types
(Ekind (Type_1) = E_Anonymous_Access_Subprogram_Type
and then Ekind (Type_2) = E_Anonymous_Access_Subprogram_Type)
-- Case 2: Anonymous access to PROTECTED subprogram types. In this
-- case the anonymous type_declaration has been replaced by an
-- occurrence of an internal access to subprogram type declaration
-- available through the Original_Access_Type attribute
or else
(Ekind (Type_1) = E_Access_Protected_Subprogram_Type
and then Ekind (Type_2) = E_Access_Protected_Subprogram_Type
and then not Comes_From_Source (Type_1)
and then not Comes_From_Source (Type_2)
and then Present (Original_Access_Type (Type_1))
and then Present (Original_Access_Type (Type_2))
and then Ekind (Original_Access_Type (Type_1)) =
E_Anonymous_Access_Protected_Subprogram_Type
and then Ekind (Original_Access_Type (Type_2)) =
E_Anonymous_Access_Protected_Subprogram_Type);
Ekind (Type_1) = Ekind (Type_2)
and then
(Ekind (Type_1) = E_Anonymous_Access_Subprogram_Type
or else
Ekind (Type_1) = E_Anonymous_Access_Protected_Subprogram_Type);
-- Test anonymous access type case. For this case, static subtype
-- matching is required for mode conformance (RM 6.3.1(15))
@ -4544,16 +4479,9 @@ package body Sem_Ch6 is
EF : constant Entity_Id :=
Make_Defining_Identifier (Sloc (Assoc_Entity),
Chars => New_External_Name (Chars (Assoc_Entity),
Suffix => Suffix));
Suffix => Suffix));
begin
-- We never generate extra formals if expansion is not active
-- because we don't need them unless we are generating code.
if not Expander_Active then
return Empty;
end if;
-- A little optimization. Never generate an extra formal for the
-- _init operand of an initialization procedure, since it could
-- never be used.
@ -4586,6 +4514,13 @@ package body Sem_Ch6 is
-- Start of processing for Create_Extra_Formals
begin
-- We never generate extra formals if expansion is not active
-- because we don't need them unless we are generating code.
if not Expander_Active then
return;
end if;
-- If this is a derived subprogram then the subtypes of the parent
-- subprogram's formal parameters will be used to to determine the need
-- for extra formals.
@ -4601,7 +4536,7 @@ package body Sem_Ch6 is
Next_Formal (Formal);
end loop;
-- If Extra_formals where already created, don't do it again. This
-- If Extra_formals were already created, don't do it again. This
-- situation may arise for subprogram types created as part of
-- dispatching calls (see Expand_Dispatching_Call)
@ -4642,10 +4577,8 @@ package body Sem_Ch6 is
end if;
if Has_Discriminants (Formal_Type)
and then
((not Is_Constrained (Formal_Type)
and then not Is_Indefinite_Subtype (Formal_Type))
or else Present (Extra_Formal (Formal)))
and then not Is_Constrained (Formal_Type)
and then not Is_Indefinite_Subtype (Formal_Type)
then
Set_Extra_Constrained
(Formal,
@ -4657,7 +4590,7 @@ package body Sem_Ch6 is
-- Create extra formal for supporting accessibility checking
-- This is suppressed if we specifically suppress accessibility
-- checks at the pacage level for either the subprogram, or the
-- checks at the package level for either the subprogram, or the
-- package in which it resides. However, we do not suppress it
-- simply if the scope has accessibility checks suppressed, since
-- this could cause trouble when clients are compiled with a
@ -4687,63 +4620,110 @@ package body Sem_Ch6 is
end if;
end if;
if Present (P_Formal) then
Next_Formal (P_Formal);
end if;
-- This label is required when skipping extra formal generation for
-- Unchecked_Union parameters.
<<Skip_Extra_Formal_Generation>>
if Present (P_Formal) then
Next_Formal (P_Formal);
end if;
Next_Formal (Formal);
end loop;
-- Ada 2005 (AI-318-02): In the case of build-in-place functions, add
-- an extra formal that will be passed the address of the return object
-- within the caller. This is added as the last extra formal, but
-- eventually will be accompanied by other implicit formals related to
-- build-in-place functions (such as allocate/deallocate subprograms,
-- finalization list, constrained flag, task master, task activation
-- list, etc.).
-- appropriate extra formals. See type Exp_Ch6.BIP_Formal_Kind.
if Expander_Active
and then Ada_Version >= Ada_05
and then Is_Build_In_Place_Function (E)
then
if Ada_Version >= Ada_05 and then Is_Build_In_Place_Function (E) then
declare
Formal_Type : constant Entity_Id :=
Create_Itype
(E_Anonymous_Access_Type,
E, Scope_Id => Scope (E));
Result_Subt : constant Entity_Id := Etype (E);
Result_Addr_Formal : Entity_Id;
Result_Subt : constant Entity_Id := Etype (E);
Discard : Entity_Id;
pragma Warnings (Off, Discard);
begin
Set_Directly_Designated_Type (Formal_Type, Result_Subt);
Set_Etype (Formal_Type, Formal_Type);
Init_Size_Align (Formal_Type);
Set_Depends_On_Private
(Formal_Type, Has_Private_Component (Formal_Type));
Set_Is_Public (Formal_Type, Is_Public (Scope (Formal_Type)));
Set_Is_Access_Constant (Formal_Type, False);
Set_Can_Never_Be_Null (Formal_Type);
-- In the case of functions with unconstrained result subtypes,
-- add a 3-state formal indicating whether the return object is
-- allocated by the caller (0), or should be allocated by the
-- callee on the secondary stack (1) or in the global heap (2).
-- For the moment we just use Natural for the type of this formal.
-- Note that this formal isn't needed in the case where the
-- result subtype is constrained.
-- Ada 2005 (AI-50217): Propagate the attribute that indicates
-- the designated type comes from the limited view (for back-end
-- purposes).
if not Is_Constrained (Result_Subt) then
Discard :=
Add_Extra_Formal
(E, Standard_Natural,
E, BIP_Formal_Suffix (BIP_Alloc_Form));
end if;
Set_From_With_Type (Formal_Type, From_With_Type (Result_Subt));
-- In the case of functions whose result type has controlled
-- parts, we have an extra formal of type
-- System.Finalization_Implementation.Finalizable_Ptr_Ptr. That
-- is, we are passing a pointer to a finalization list (which is
-- itself a pointer). This extra formal is then passed along to
-- Move_Final_List in case of successful completion of a return
-- statement. We cannot pass an 'in out' parameter, because we
-- need to update the finalization list during an abort-deferred
-- region, rather than using copy-back after the function
-- returns. This is true even if we are able to get away with
-- having 'in out' parameters, which are normally illegal for
-- functions.
Layout_Type (Formal_Type);
if Is_Controlled (Result_Subt)
or else Has_Controlled_Component (Result_Subt)
then
Discard :=
Add_Extra_Formal
(E, RTE (RE_Finalizable_Ptr_Ptr),
E, BIP_Formal_Suffix (BIP_Final_List));
end if;
Result_Addr_Formal := Add_Extra_Formal (E, Formal_Type, E, "RA");
-- If the result type contains tasks, we have two extra formals:
-- the master of the tasks to be created, and the caller's
-- activation chain.
-- For some reason the following is not effective and the
-- dereference of the formal within the function still gets
-- a check. ???
if Has_Task (Result_Subt) then
Discard :=
Add_Extra_Formal
(E, RTE (RE_Master_Id),
E, BIP_Formal_Suffix (BIP_Master));
Discard :=
Add_Extra_Formal
(E, RTE (RE_Activation_Chain_Access),
E, BIP_Formal_Suffix (BIP_Activation_Chain));
end if;
Set_Can_Never_Be_Null (Result_Addr_Formal);
-- All build-in-place functions get an extra formal that will be
-- passed the address of the return object within the caller.
declare
Formal_Type : constant Entity_Id :=
Create_Itype
(E_Anonymous_Access_Type, E,
Scope_Id => Scope (E));
begin
Set_Directly_Designated_Type (Formal_Type, Result_Subt);
Set_Etype (Formal_Type, Formal_Type);
Init_Size_Align (Formal_Type);
Set_Depends_On_Private
(Formal_Type, Has_Private_Component (Formal_Type));
Set_Is_Public (Formal_Type, Is_Public (Scope (Formal_Type)));
Set_Is_Access_Constant (Formal_Type, False);
-- Ada 2005 (AI-50217): Propagate the attribute that indicates
-- the designated type comes from the limited view (for
-- back-end purposes).
Set_From_With_Type (Formal_Type, From_With_Type (Result_Subt));
Layout_Type (Formal_Type);
Discard :=
Add_Extra_Formal
(E, Formal_Type, E, BIP_Formal_Suffix (BIP_Object_Access));
end;
end;
end if;
end Create_Extra_Formals;
@ -4813,8 +4793,10 @@ package body Sem_Ch6 is
-- Warn unless genuine overloading
if (not Is_Overloadable (E))
or else Subtype_Conformant (E, S)
if (not Is_Overloadable (E) or else Subtype_Conformant (E, S))
and then (Is_Immediately_Visible (E)
or else
Is_Potentially_Use_Visible (S))
then
Error_Msg_Sloc := Sloc (E);
Error_Msg_N ("declaration of & hides one#?", S);
@ -5698,7 +5680,7 @@ package body Sem_Ch6 is
Remove (Decl);
Set_Has_Completion (Op_Name);
Set_Corresponding_Equality (Op_Name, S);
Set_Is_Abstract (Op_Name, Is_Abstract (S));
Set_Is_Abstract_Subprogram (Op_Name, Is_Abstract_Subprogram (S));
end;
end Make_Inequality_Operator;
@ -5827,7 +5809,7 @@ package body Sem_Ch6 is
-- declarations because they don't have interface lists.
if Nkind (Parent (Typ)) /= N_Full_Type_Declaration then
Collect_Synchronized_Interfaces (Typ, Ifaces_List);
Collect_Abstract_Interfaces (Typ, Ifaces_List);
if not Is_Empty_Elmt_List (Ifaces_List) then
Overridden_Subp :=
@ -5900,22 +5882,14 @@ package body Sem_Ch6 is
and then Visible_Part_Type (T)
and then not In_Instance
then
if Is_Abstract (T)
and then Is_Abstract (S)
and then (not Is_Overriding or else not Is_Abstract (E))
if Is_Abstract_Type (T)
and then Is_Abstract_Subprogram (S)
and then (not Is_Overriding
or else not Is_Abstract_Subprogram (E))
then
if not Is_Interface (T) then
Error_Msg_N ("abstract subprograms must be visible "
Error_Msg_N ("abstract subprograms must be visible "
& "('R'M 3.9.3(10))!", S);
-- Ada 2005 (AI-251)
else
Error_Msg_N ("primitive subprograms of interface types "
& "declared in a visible part, must be declared in "
& "the visible part ('R'M 3.9.4)!", S);
end if;
elsif Ekind (S) = E_Function
and then Is_Tagged_Type (T)
and then T = Base_Type (Etype (S))
@ -6609,6 +6583,12 @@ package body Sem_Ch6 is
Formal_Type :=
Access_Definition (Related_Nod, Parameter_Type (Param_Spec));
-- No need to continue if we already notified errors
if not Present (Formal_Type) then
return;
end if;
-- Ada 2005 (AI-254)
declare
@ -6619,7 +6599,7 @@ package body Sem_Ch6 is
if Present (AD) and then Protected_Present (AD) then
Formal_Type :=
Replace_Anonymous_Access_To_Protected_Subprogram
(Param_Spec, Formal_Type);
(Param_Spec);
end if;
end;
end if;

23
gcc/ada/sem_ch6.ads
View File

@ -27,6 +27,12 @@
with Types; use Types;
package Sem_Ch6 is
type Conformance_Type is
(Type_Conformant, Mode_Conformant, Subtype_Conformant, Fully_Conformant);
-- Conformance type used in conformance checks between specs and bodies,
-- and for overriding. The literals match the RM definitions of the
-- corresponding terms.
procedure Analyze_Abstract_Subprogram_Declaration (N : Node_Id);
procedure Analyze_Extended_Return_Statement (N : Node_Id);
procedure Analyze_Function_Call (N : Node_Id);
@ -39,7 +45,8 @@ package Sem_Ch6 is
function Analyze_Subprogram_Specification (N : Node_Id) return Entity_Id;
-- Analyze subprogram specification in both subprogram declarations
-- and body declarations. Returns the defining entity for the spec.
-- and body declarations. Returns the defining entity for the
-- specification N.
procedure Cannot_Inline (Msg : String; N : Node_Id; Subp : Entity_Id);
-- This procedure is called if the node N, an instance of a call to
@ -55,9 +62,9 @@ package Sem_Ch6 is
-- their respective counterparts.
procedure Check_Delayed_Subprogram (Designator : Entity_Id);
-- Designator can be a E_Subrpgram_Type, E_Procedure or E_Function. If a
-- Designator can be a E_Subprogram_Type, E_Procedure or E_Function. If a
-- type in its profile depends on a private type without a full
-- declaration, indicate that the subprogram is delayed.
-- declaration, indicate that the subprogram or type is delayed.
procedure Check_Discriminant_Conformance
(N : Node_Id;
@ -112,6 +119,16 @@ package Sem_Ch6 is
-- the flag being placed on the Err_Loc node if it is specified, and
-- on the appropriate component of the New_Id construct if not.
function Conforming_Types
(T1 : Entity_Id;
T2 : Entity_Id;
Ctype : Conformance_Type;
Get_Inst : Boolean := False) return Boolean;
-- Check that the types of two formal parameters are conforming. In most
-- cases this is just a name comparison, but within an instance it involves
-- generic actual types, and in the presence of anonymous access types
-- it must examine the designated types.
procedure Create_Extra_Formals (E : Entity_Id);
-- For each parameter of a subprogram or entry that requires an additional
-- formal (such as for access parameters and indefinite discriminated