OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

restrict.ads (No_Dispatching_Calls): New GNAT restriction. 

2006-02-13  Javier Miranda  <miranda@adacore.com>
	    Gary Dismukes  <dismukes@adacore.com>
	    Robert Dewar  <dewar@adacore.com>

	* restrict.ads (No_Dispatching_Calls): New GNAT restriction.

	* sem_disp.adb (Override_Dispatching_Operation): Traverse the list of
	aliased entities to look for the overriden abstract interface
	subprogram.
	(Is_Interface_Subprogram): Complete documentation.
	(Check_Dispatching_Operation): Do not generate code to register the
	operation in the dispatch table if the source is compiled with
	restriction No_Dispatching_Calls.
	(Override_Dispatching_Operation): Check for illegal attempt to override
	No_Return procedure with procedure that is not No_Return
	(Check_Dispatching_Call): Suppress the check for an abstract operation
	when the original node of an actual is a tag-indeterminate attribute
	call, since the attribute, which must be 'Input, can never be abstract.
	(Is_Tag_Indeterminate): Handle checking of tag indeterminacy of a
	call to the Input attribute (even when rewritten).
	(Propagate_Tag): Augment comment to indicate the possibility of a call
	to an Input attribute.

	* sem_disp.ads (Override_Dispatching_Operation): Moved to spec to allow
	calling it from Exp_Ch3.Make_Controlling_Function_Wrappers.

	* s-rident.ads: (No_Dispatching_Calls): New GNAT restriction.
	No_Wide_Characters is no longer partition-wide
	No_Implementation_Attributes/Pragmas are now Ada 2005 (AI-257)
	rather than GNAT

From-SVN: r111086
This commit is contained in:
Javier Miranda 2006-02-15 10:43:23 +01:00 committed by Arnaud Charlet
parent e4ffa8adc7
commit 3bcd6930a9
4 changed files with 89 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
gcc/ada/restrict.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005, 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- --
@ -106,6 +106,7 @@ package Restrict is
Implementation_Restriction : array (All_Restrictions) of Boolean :=
(Simple_Barriers => True,
No_Calendar => True,
No_Dispatching_Calls => True,
No_Dynamic_Attachment => True,
No_Enumeration_Maps => True,
No_Entry_Calls_In_Elaboration_Code => True,

13
gcc/ada/s-rident.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005, 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- --
@ -66,6 +66,7 @@ package System.Rident is
No_Delay, -- (RM H.4(21))
No_Direct_Boolean_Operators, -- GNAT
No_Dispatch, -- (RM H.4(19))
No_Dispatching_Calls, -- GNAT
No_Dynamic_Attachment, -- GNAT
No_Dynamic_Priorities, -- (RM D.9(9))
No_Enumeration_Maps, -- GNAT
@ -105,18 +106,18 @@ package System.Rident is
No_Unchecked_Access, -- (RM H.4(18))
No_Unchecked_Conversion, -- (RM H.4(16))
No_Unchecked_Deallocation, -- (RM H.4(9))
No_Wide_Characters, -- GNAT
Static_Priorities, -- GNAT
Static_Storage_Size, -- GNAT
-- The following cases do not require partition-wide checks
Immediate_Reclamation, -- (RM H.4(10))
No_Implementation_Attributes, -- GNAT
No_Implementation_Pragmas, -- GNAT
No_Implementation_Attributes, -- Ada 2005 AI-257
No_Implementation_Pragmas, -- Ada 2005 AI-257
No_Implementation_Restrictions, -- GNAT
No_Elaboration_Code, -- GNAT
No_Obsolescent_Features, -- Ada 2005 AI-368
No_Wide_Characters, -- GNAT
-- The following cases require a parameter value
@ -167,7 +168,7 @@ package System.Rident is
-- All restrictions (excluding only Not_A_Restriction_Id)
subtype All_Boolean_Restrictions is Restriction_Id range
Simple_Barriers .. No_Obsolescent_Features;
Simple_Barriers .. No_Wide_Characters;
-- All restrictions which do not take a parameter
subtype Partition_Boolean_Restrictions is All_Boolean_Restrictions range
@ -178,7 +179,7 @@ package System.Rident is
-- case of Boolean restrictions.
subtype Cunit_Boolean_Restrictions is All_Boolean_Restrictions range
Immediate_Reclamation .. No_Obsolescent_Features;
Immediate_Reclamation .. No_Wide_Characters;
-- Boolean restrictions that are not checked for partition consistency
-- and that thus apply only to the current unit. Note that for these
-- restrictions, the compiler does not apply restrictions found in

97
gcc/ada/sem_disp.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2005, 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- --
@ -38,6 +38,8 @@ with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
with Output; use Output;
with Restrict; use Restrict;
with Rident; use Rident;
with Sem; use Sem;
with Sem_Ch6; use Sem_Ch6;
with Sem_Eval; use Sem_Eval;
@ -55,14 +57,6 @@ package body Sem_Disp is
-- Local Subprograms --
-----------------------
procedure Override_Dispatching_Operation
(Tagged_Type : Entity_Id;
Prev_Op : Entity_Id;
New_Op : Entity_Id);
-- Replace an implicit dispatching operation with an explicit one.
-- Prev_Op is an inherited primitive operation which is overridden
-- by the explicit declaration of New_Op.
procedure Add_Dispatching_Operation
(Tagged_Type : Entity_Id;
New_Op : Entity_Id);
@ -406,7 +400,7 @@ package body Sem_Disp is
-- discriminants), the tag of the containing call's associated
-- tagged type is directly used to control the dispatching.
if not Present (Control)
if No (Control)
and then Indeterm_Ancestor_Call
then
Control :=
@ -476,6 +470,15 @@ package body Sem_Disp is
if Nkind (Original_Node (Actual)) = N_Function_Call then
Func := Entity (Name (Original_Node (Actual)));
-- If the actual is an attribute then it can't be abstract
-- (the only current case of a tag-indeterminate attribute
-- is the stream Input attribute).
elsif
Nkind (Original_Node (Actual)) = N_Attribute_Reference
then
Func := Empty;
-- Only other possibility is a qualified expression whose
-- consituent expression is itself a call.
@ -486,7 +489,7 @@ package body Sem_Disp is
(Expression (Original_Node (Actual)))));
end if;
if Is_Abstract (Func) then
if Present (Func) and then Is_Abstract (Func) then
Error_Msg_N (
"call to abstract function must be dispatching", N);
end if;
@ -553,7 +556,7 @@ package body Sem_Disp is
then
-- Protect the frontend against previously detected errors
if not Present (Corresponding_Record_Type (Tagged_Type)) then
if No (Corresponding_Record_Type (Tagged_Type)) then
return;
end if;
@ -661,7 +664,7 @@ package body Sem_Disp is
-- has definitely been frozen already and the body
-- is illegal.
if not Present (Decl_Item) then
if No (Decl_Item) then
Error_Msg_N ("overriding of& is too late!", Subp);
Error_Msg_N
("\spec should appear immediately after the type!",
@ -679,8 +682,11 @@ package body Sem_Disp is
if Present (DTC_Entity (Old_Subp)) then
Set_DTC_Entity (Subp, DTC_Entity (Old_Subp));
Set_DT_Position (Subp, DT_Position (Old_Subp));
Insert_After (
Subp_Body, Fill_DT_Entry (Sloc (Subp_Body), Subp));
if not Restriction_Active (No_Dispatching_Calls) then
Insert_After (Subp_Body,
Fill_DT_Entry (Sloc (Subp_Body), Subp));
end if;
end if;
end if;
end;
@ -739,7 +745,12 @@ package body Sem_Disp is
Override_Dispatching_Operation (Tagged_Type, Old_Subp, Subp);
Set_Is_Overriding_Operation (Subp);
end if;
else
-- If no old subprogram, then we add this as a dispatching operation,
-- but we avoid doing this if an error was posted, to prevent annoying
-- cascaded errors.
elsif not Error_Posted (Subp) then
Add_Dispatching_Operation (Tagged_Type, Subp);
end if;
@ -1139,7 +1150,6 @@ package body Sem_Disp is
else
Actual := First_Actual (Orig_Node);
while Present (Actual) loop
if Is_Controlling_Actual (Actual)
and then not Is_Tag_Indeterminate (Actual)
@ -1151,12 +1161,21 @@ package body Sem_Disp is
end loop;
return True;
end if;
elsif Nkind (Orig_Node) = N_Qualified_Expression then
return Is_Tag_Indeterminate (Expression (Orig_Node));
-- Case of a call to the Input attribute (possibly rewritten), which is
-- always tag-indeterminate except when its prefix is a Class attribute.
elsif Nkind (Orig_Node) = N_Attribute_Reference
and then
Get_Attribute_Id (Attribute_Name (Orig_Node)) = Attribute_Input
and then
Nkind (Prefix (Orig_Node)) /= N_Attribute_Reference
then
return True;
else
return False;
end if;
@ -1174,9 +1193,12 @@ package body Sem_Disp is
Op_Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Tagged_Type));
Elmt : Elmt_Id;
Found : Boolean;
E : Entity_Id;
function Is_Interface_Subprogram (Op : Entity_Id) return Boolean;
-- Comment requjired ???
-- Traverse the list of aliased entities to check if the overriden
-- entity corresponds with a primitive operation of an abstract
-- interface type.
-----------------------------
-- Is_Interface_Subprogram --
@ -1202,6 +1224,14 @@ package body Sem_Disp is
-- Start of processing for Override_Dispatching_Operation
begin
-- Diagnose failure to match No_Return in parent (Ada-2005, AI-414, but
-- we do it unconditionally in Ada 95 now, since this is our pragma!)
if No_Return (Prev_Op) and then not No_Return (New_Op) then
Error_Msg_N ("procedure & must have No_Return pragma", New_Op);
Error_Msg_N ("\since overridden procedure has No_Return", New_Op);
end if;
-- Patch the primitive operation list
while Present (Op_Elmt)
@ -1228,7 +1258,20 @@ package body Sem_Disp is
Set_DT_Position (Prev_Op, DT_Position (Alias (Prev_Op)));
Set_Is_Abstract (Prev_Op, Is_Abstract (New_Op));
Set_Is_Overriding_Operation (Prev_Op);
Set_Abstract_Interface_Alias (Prev_Op, Alias (Prev_Op));
-- Traverse the list of aliased entities to look for the overriden
-- abstract interface subprogram.
E := Alias (Prev_Op);
while Present (Alias (E))
and then Present (DTC_Entity (E))
and then not (Is_Abstract (E))
and then not Is_Interface (Scope (DTC_Entity (E)))
loop
E := Alias (E);
end loop;
Set_Abstract_Interface_Alias (Prev_Op, E);
Set_Alias (Prev_Op, New_Op);
Set_Is_Internal (Prev_Op);
Set_Is_Hidden (Prev_Op);
@ -1256,8 +1299,8 @@ package body Sem_Disp is
if not Found then
Append_Elmt (New_Op, Primitive_Operations (Tagged_Type));
-- Replace_Elmt (Op_Elmt, New_Op); -- why is this commented out???
end if;
return;
else
@ -1274,10 +1317,10 @@ package body Sem_Disp is
else pragma Assert (Is_Inherited_Operation (Prev_Op));
-- Make the overriding operation into an alias of the implicit one.
-- In this fashion a call from outside ends up calling the new
-- body even if non-dispatching, and a call from inside calls the
-- overriding operation because it hides the implicit one.
-- To indicate that the body of Prev_Op is never called, set its
-- In this fashion a call from outside ends up calling the new body
-- even if non-dispatching, and a call from inside calls the
-- overriding operation because it hides the implicit one. To
-- indicate that the body of Prev_Op is never called, set its
-- dispatch table entity to Empty.
Set_Alias (Prev_Op, New_Op);
@ -1307,7 +1350,9 @@ package body Sem_Disp is
Call_Node := Expression (Parent (Entity (Actual)));
-- Only other possibility is parenthesized or qualified expression
-- Only other possibilities are parenthesized or qualified expression,
-- or an expander-generated unchecked conversion of a function call to
-- a stream Input attribute.
else
Call_Node := Expression (Actual);

10
gcc/ada/sem_disp.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005, 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- --
@ -80,6 +80,14 @@ package Sem_Disp is
-- on result, and all controlling operands are also indeterminate.
-- Such a function call may inherit a tag from an enclosing call.
procedure Override_Dispatching_Operation
(Tagged_Type : Entity_Id;
Prev_Op : Entity_Id;
New_Op : Entity_Id);
-- Replace an implicit dispatching operation with an explicit one.
-- Prev_Op is an inherited primitive operation which is overridden
-- by the explicit declaration of New_Op.
procedure Propagate_Tag (Control : Node_Id; Actual : Node_Id);
-- If a function call is tag-indeterminate, its controlling argument is
-- found in the context; either an enclosing call, or the left-hand side