mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-05 22:11:30 +08:00
Code Issues Packages Projects Releases Wiki Activity

exp_ch3.ads, [...] (Add_Final_Chain): New subprogram.

Browse Source 
2007-08-14  Thomas Quinot  <quinot@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>
	    Javier Miranda  <miranda@adacore.com>
	    Robert Dewar  <dewar@adacore.com>

	* exp_ch3.ads, exp_ch3.adb (Add_Final_Chain): New subprogram.
	(Freeze_Array_Type, Freeze_Record_Type): For the case of a component
	type that is an anonymous access to controlled object, establish
	an associated finalization chain to avoid corrupting the global
	finalization list when a dynamically allocated object designated
	by such a component is deallocated.
	(Make_Controlling_Function_Wrappers): Create wrappers for constructor
	functions that need it, even when not marked Requires_Overriding.
	(Initialize_Tag): Replace call to has_discriminants by call to
	Is_Variable_Size_Record in the circuitry that handles the
	initialization of secondary tags.
	(Is_Variable_Size_Record): New implementation.
	(Expand_N_Object_Declaration): Suppress call to init proc if there is a
	Suppress_Initialization pragma for a derived type.
	(Is_Variable_Size_Record): New subprogram.
	(Build_Offset_To_Top_Functions): New implementation that simplifies the
	initial version of this routine and also fixes problems causing
	incomplete initialization of the table of interfaces.
	(Build_Init_Procedure): Improve the generation of code to initialize the
	the tag components of secondary dispatch tables.
	(Init_Secondary_Tags): New implementation that simplifies the previous
	version of this routine.
	(Make_DT): Add parameter to indicate when type has been frozen by an
	object declaration, for diagnostic purposes.
	(Check_Premature_Freezing): New subsidiary procedure of Make_DT, to
	diagnose attemps to freeze a subprogram when some untagged type of its
	profile is a private type whose full view has not been analyzed yet.
	(Freeze_Array_Type): Generate init proc for packed array if either
	Initialize or Normalize_Scalars is set.
	(Make_Controlling_Function_Wrappers, Make_Null_Procedure_Specs): when
	constructing the new profile, copy the null_exclusion indicator for each
	parameter, to ensure full conformance of the new body with the spec.

	* sem_type.ads, sem_type.adb (Make_Controlling_Function_Wrappers):
	Create wrappers for constructor functions that need it, even when not
	marked Requires_Overriding.
	(Covers): Handle properly designated types of anonymous access types,
	whose non-limited views are themselves incomplete types.
	(Add_Entry): Use an entity to store the abstract operation which hides
	an interpretation.
	(Binary_Op_May_Be_Hidden): Rename to Binary_Op_Interp_Has_Abstract_Op.
	(Collect_Interps): Use Empty as an actual for Abstract_Op in the
	initialization aggregate.
	(Function_Interp_May_Be_Hidden): Rename to
	Function_Interp_Has_Abstract_Op.
	(Has_Compatible_Type): Remove machinery that skips interpretations if
	they are labeled as potentially hidden by an abstract operator.
	(Has_Hidden_Interp): Rename to Has_Abstract_Op.
	(Set_May_Be_Hidden): Rename to Set_Abstract_Op.
	(Write_Overloads): Output the abstract operator if present.
	(Add_Entry): Before inserting a new entry into the interpretation table
	for a node, determine whether the entry will be disabled by an abstract
	operator.
	(Binary_Op_Interp_May_Be_Hidden): New routine.
	(Collect_Interps): Add value for flag May_Be_Hidden in initialization
	aggregate.
	(Function_Interp_May_Be_Hidden): New routine.
	(Has_Compatible_Type): Do not consider interpretations hidden by
	abstract operators when trying to determine whether two types are
	compatible.
	(Has_Hidden_Interp): New routine.
	(Set_May_Be_Hidden_Interp): New routine.
	(Write_Overloads): Write the status of flag May_Be_Hidden.

From-SVN: r127417
This commit is contained in:
Thomas Quinot 2007-08-14 10:38:48 +02:00 committed by Arnaud Charlet
parent 3e8ee849e1
commit 04df6250f6
4 changed files with 836 additions and 548 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1117
gcc/ada/exp_ch3.adb
View File

File diff suppressed because it is too large Load Diff

19
gcc/ada/exp_ch3.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2007, 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- --
@ -111,12 +111,17 @@ package Exp_Ch3 is
-- since it would confuse any remaining processing of the freeze node.
procedure Init_Secondary_Tags
(Typ : Entity_Id;
Target : Node_Id;
Stmts_List : List_Id);
-- Ada 2005 (AI-251): Initialize the tags of all the secondary tables
-- associated with the abstract interfaces of Typ. The generated code
-- referencing tag fields of Target is appended to Stmts_List.
(Typ : Entity_Id;
Target : Node_Id;
Stmts_List : List_Id;
Fixed_Comps : Boolean := True;
Variable_Comps : Boolean := True);
-- Ada 2005 (AI-251): Initialize the tags of the secondary dispatch tables
-- of Typ. The generated code referencing tag fields of Target is appended
-- to Stmts_List. If Fixed_Comps is True then the tag components located at
-- fixed positions of Target are initialized; if Variable_Comps is True
-- then tags components located at variable positions of Target are
-- initialized.
function Needs_Simple_Initialization (T : Entity_Id) return Boolean;
-- Certain types need initialization even though there is no specific

214
gcc/ada/sem_type.adb
View File

@ -161,6 +161,29 @@ package body Sem_Type is
pragma Warnings (Off, All_Overloads);
-- Debugging procedure: list full contents of Overloads table
function Binary_Op_Interp_Has_Abstract_Op
(N : Node_Id;
E : Entity_Id) return Entity_Id;
-- Given the node and entity of a binary operator, determine whether the
-- actuals of E contain an abstract interpretation with regards to the
-- types of their corresponding formals. Return the abstract operation or
-- Empty.
function Function_Interp_Has_Abstract_Op
(N : Node_Id;
E : Entity_Id) return Entity_Id;
-- Given the node and entity of a function call, determine whether the
-- actuals of E contain an abstract interpretation with regards to the
-- types of their corresponding formals. Return the abstract operation or
-- Empty.
function Has_Abstract_Op
(N : Node_Id;
Typ : Entity_Id) return Entity_Id;
-- Subsidiary routine to Binary_Op_Interp_Has_Abstract_Op and Function_
-- Interp_Has_Abstract_Op. Determine whether an overloaded node has an
-- abstract interpretation which yields type Typ.
procedure New_Interps (N : Node_Id);
-- Initialize collection of interpretations for the given node, which is
-- either an overloaded entity, or an operation whose arguments have
@ -183,10 +206,10 @@ package body Sem_Type is
is
Vis_Type : Entity_Id;
procedure Add_Entry (Name : Entity_Id; Typ : Entity_Id);
-- Add one interpretation to node. Node is already known to be
-- overloaded. Add new interpretation if not hidden by previous
-- one, and remove previous one if hidden by new one.
procedure Add_Entry (Name : Entity_Id; Typ : Entity_Id);
-- Add one interpretation to an overloaded node. Add a new entry if
-- not hidden by previous one, and remove previous one if hidden by
-- new one.
function Is_Universal_Operation (Op : Entity_Id) return Boolean;
-- True if the entity is a predefined operator and the operands have
@ -196,12 +219,26 @@ package body Sem_Type is
-- Add_Entry --
---------------
procedure Add_Entry (Name : Entity_Id; Typ : Entity_Id) is
Index : Interp_Index;
It : Interp;
procedure Add_Entry (Name : Entity_Id; Typ : Entity_Id) is
Abstr_Op : Entity_Id := Empty;
I : Interp_Index;
It : Interp;
-- Start of processing for Add_Entry
begin
Get_First_Interp (N, Index, It);
-- Find out whether the new entry references interpretations that
-- are abstract or disabled by abstract operators.
if Ada_Version >= Ada_05 then
if Nkind (N) in N_Binary_Op then
Abstr_Op := Binary_Op_Interp_Has_Abstract_Op (N, Name);
elsif Nkind (N) = N_Function_Call then
Abstr_Op := Function_Interp_Has_Abstract_Op (N, Name);
end if;
end if;
Get_First_Interp (N, I, It);
while Present (It.Nam) loop
-- A user-defined subprogram hides another declared at an outer
@ -254,7 +291,7 @@ package body Sem_Type is
end if;
else
All_Interp.Table (Index).Nam := Name;
All_Interp.Table (I).Nam := Name;
return;
end if;
@ -268,15 +305,12 @@ package body Sem_Type is
-- Otherwise keep going
else
Get_Next_Interp (Index, It);
Get_Next_Interp (I, It);
end if;
end loop;
-- On exit, enter new interpretation. The context, or a preference
-- rule, will resolve the ambiguity on the second pass.
All_Interp.Table (All_Interp.Last) := (Name, Typ);
All_Interp.Table (All_Interp.Last) := (Name, Typ, Abstr_Op);
All_Interp.Increment_Last;
All_Interp.Table (All_Interp.Last) := No_Interp;
end Add_Entry;
@ -501,6 +535,27 @@ package body Sem_Type is
end loop;
end All_Overloads;
--------------------------------------
-- Binary_Op_Interp_Has_Abstract_Op --
--------------------------------------
function Binary_Op_Interp_Has_Abstract_Op
(N : Node_Id;
E : Entity_Id) return Entity_Id
is
Abstr_Op : Entity_Id;
E_Left : constant Node_Id := First_Formal (E);
E_Right : constant Node_Id := Next_Formal (E_Left);
begin
Abstr_Op := Has_Abstract_Op (Left_Opnd (N), Etype (E_Left));
if Present (Abstr_Op) then
return Abstr_Op;
end if;
return Has_Abstract_Op (Right_Opnd (N), Etype (E_Right));
end Binary_Op_Interp_Has_Abstract_Op;
---------------------
-- Collect_Interps --
---------------------
@ -567,7 +622,8 @@ package body Sem_Type is
and then In_Instance
and then not Is_Inherited_Operation (H)
then
All_Interp.Table (All_Interp.Last) := (H, Etype (H));
All_Interp.Table (All_Interp.Last) :=
(H, Etype (H), Empty);
All_Interp.Increment_Last;
All_Interp.Table (All_Interp.Last) := No_Interp;
goto Next_Homograph;
@ -821,9 +877,11 @@ package body Sem_Type is
return True;
-- If the expected type is an anonymous access, the designated type must
-- cover that of the expression.
-- cover that of the expression. Use the base type for this check: even
-- though access subtypes are rare in sources, they are generated for
-- actuals in instantiations.
elsif Ekind (T1) = E_Anonymous_Access_Type
elsif Ekind (BT1) = E_Anonymous_Access_Type
and then Is_Access_Type (T2)
and then Covers (Designated_Type (T1), Designated_Type (T2))
then
@ -987,10 +1045,11 @@ package body Sem_Type is
elsif From_With_Type (T1) then
-- If the expected type is the non-limited view of a type, the
-- expression may have the limited view.
-- expression may have the limited view. If that one in turn is
-- incomplete, get full view if available.
if Is_Incomplete_Type (T1) then
return Covers (Non_Limited_View (T1), T2);
return Covers (Get_Full_View (Non_Limited_View (T1)), T2);
elsif Ekind (T1) = E_Class_Wide_Type then
return
@ -1006,7 +1065,7 @@ package body Sem_Type is
-- verify that the context type is the non-limited view.
if Is_Incomplete_Type (T2) then
return Covers (T1, Non_Limited_View (T2));
return Covers (T1, Get_Full_View (Non_Limited_View (T2)));
elsif Ekind (T2) = E_Class_Wide_Type then
return
@ -1471,7 +1530,7 @@ package body Sem_Type is
-- then we must check whether the user-defined entity hides the prede-
-- fined one.
if Chars (Nam1) in Any_Operator_Name
if Chars (Nam1) in Any_Operator_Name
and then Standard_Operator
then
if Typ = Universal_Integer
@ -1677,7 +1736,7 @@ package body Sem_Type is
end if;
end if;
-- an implicit concatenation operator on a string type cannot be
-- An implicit concatenation operator on a string type cannot be
-- disambiguated from the predefined concatenation. This can only
-- happen with concatenation of string literals.
@ -1687,7 +1746,7 @@ package body Sem_Type is
then
return No_Interp;
-- If the user-defined operator is in an open scope, or in the scope
-- If the user-defined operator is in an open scope, or in the scope
-- of the resulting type, or given by an expanded name that names its
-- scope, it hides the predefined operator for the type. Exponentiation
-- has to be special-cased because the implicit operator does not have
@ -1904,9 +1963,48 @@ package body Sem_Type is
else
return Specific_Type (T, Etype (R));
end if;
end Find_Unique_Type;
-------------------------------------
-- Function_Interp_Has_Abstract_Op --
-------------------------------------
function Function_Interp_Has_Abstract_Op
(N : Node_Id;
E : Entity_Id) return Entity_Id
is
Abstr_Op : Entity_Id;
Act : Node_Id;
Act_Parm : Node_Id;
Form_Parm : Node_Id;
begin
if Is_Overloaded (N) then
Act_Parm := First_Actual (N);
Form_Parm := First_Formal (E);
while Present (Act_Parm)
and then Present (Form_Parm)
loop
Act := Act_Parm;
if Nkind (Act) = N_Parameter_Association then
Act := Explicit_Actual_Parameter (Act);
end if;
Abstr_Op := Has_Abstract_Op (Act, Etype (Form_Parm));
if Present (Abstr_Op) then
return Abstr_Op;
end if;
Next_Actual (Act_Parm);
Next_Formal (Form_Parm);
end loop;
end if;
return Empty;
end Function_Interp_Has_Abstract_Op;
----------------------
-- Get_First_Interp --
----------------------
@ -1916,8 +2014,8 @@ package body Sem_Type is
I : out Interp_Index;
It : out Interp)
is
Map_Ptr : Int;
Int_Ind : Interp_Index;
Map_Ptr : Int;
O_N : Node_Id;
begin
@ -2030,6 +2128,34 @@ package body Sem_Type is
end if;
end Has_Compatible_Type;
---------------------
-- Has_Abstract_Op --
---------------------
function Has_Abstract_Op
(N : Node_Id;
Typ : Entity_Id) return Entity_Id
is
I : Interp_Index;
It : Interp;
begin
if Is_Overloaded (N) then
Get_First_Interp (N, I, It);
while Present (It.Nam) loop
if Present (It.Abstract_Op)
and then Etype (It.Abstract_Op) = Typ
then
return It.Abstract_Op;
end if;
Get_Next_Interp (I, It);
end loop;
end if;
return Empty;
end Has_Abstract_Op;
----------
-- Hash --
----------
@ -2384,18 +2510,17 @@ package body Sem_Type is
then
return False;
else return
Is_Numeric_Type (T)
and then not In_Open_Scopes (Scope (T))
and then not Is_Potentially_Use_Visible (T)
and then not In_Use (T)
and then not In_Use (Scope (T))
and then
else
return Is_Numeric_Type (T)
and then not In_Open_Scopes (Scope (T))
and then not Is_Potentially_Use_Visible (T)
and then not In_Use (T)
and then not In_Use (Scope (T))
and then
(Nkind (Orig_Node) /= N_Function_Call
or else Nkind (Name (Orig_Node)) /= N_Expanded_Name
or else Entity (Prefix (Name (Orig_Node))) /= Scope (T))
and then not In_Instance;
and then not In_Instance;
end if;
end Is_Invisible_Operator;
@ -2866,6 +2991,15 @@ package body Sem_Type is
end if;
end Specific_Type;
---------------------
-- Set_Abstract_Op --
---------------------
procedure Set_Abstract_Op (I : Interp_Index; V : Entity_Id) is
begin
All_Interp.Table (I).Abstract_Op := V;
end Set_Abstract_Op;
-----------------------
-- Valid_Boolean_Arg --
-----------------------
@ -2956,9 +3090,9 @@ package body Sem_Type is
Get_First_Interp (N, I, It);
Write_Str ("Overloaded entity ");
Write_Eol;
Write_Str (" Name Type");
Write_Str (" Name Type Abstract Op");
Write_Eol;
Write_Str ("===============================");
Write_Str ("===============================================");
Write_Eol;
Nam := It.Nam;
@ -2970,6 +3104,14 @@ package body Sem_Type is
Write_Int (Int (It.Typ));
Write_Str (" ");
Write_Name (Chars (It.Typ));
if Present (It.Abstract_Op) then
Write_Str (" ");
Write_Int (Int (It.Abstract_Op));
Write_Str (" ");
Write_Name (Chars (It.Abstract_Op));
end if;
Write_Eol;
Get_Next_Interp (I, It);
Nam := It.Nam;

34
gcc/ada/sem_type.ads
View File

@ -41,13 +41,13 @@ package Sem_Type is
-- the visibility rules find such a potential ambiguity, the set of
-- possible interpretations must be attached to the identifier, and
-- overload resolution must be performed over the innermost enclosing
-- complete context. At the end of the resolution, either a single
-- complete context. At the end of the resolution, either a single
-- interpretation is found for all identifiers in the context, or else a
-- type error (invalid type or ambiguous reference) must be signalled.
-- The set of interpretations of a given name is stored in a data structure
-- that is separate from the syntax tree, because it corresponds to
-- transient information. The interpretations themselves are stored in
-- transient information. The interpretations themselves are stored in
-- table All_Interp. A mapping from tree nodes to sets of interpretations
-- called Interp_Map, is maintained by the overload resolution routines.
-- Both these structures are initialized at the beginning of every complete
@ -64,11 +64,15 @@ package Sem_Type is
-- only one interpretation is present anyway.
type Interp is record
Nam : Entity_Id;
Typ : Entity_Id;
Nam : Entity_Id;
Typ : Entity_Id;
Abstract_Op : Entity_Id := Empty;
end record;
No_Interp : constant Interp := (Empty, Empty);
-- Entity Abstract_Op is set to the abstract operation which potentially
-- disables the interpretation in Ada 2005 mode.
No_Interp : constant Interp := (Empty, Empty, Empty);
subtype Interp_Index is Int;
@ -122,8 +126,9 @@ package Sem_Type is
-- E is an overloadable entity, and T is its type. For constructs such
-- as indexed expressions, the caller sets E equal to T, because the
-- overloading comes from other fields, and the node itself has no name
-- to resolve. Add_One_Interp includes the semantic processing to deal
-- with adding entries that hide one another etc.
-- to resolve. Hidden denotes whether an interpretation has been disabled
-- by an abstract operator. Add_One_Interp includes semantic processing to
-- deal with adding entries that hide one another etc.
-- For operators, the legality of the operation depends on the visibility
-- of T and its scope. If the operator is an equality or comparison, T is
@ -172,7 +177,7 @@ package Sem_Type is
I1, I2 : Interp_Index;
Typ : Entity_Id)
return Interp;
-- If more than one interpretation of a name in a call is legal, apply
-- If more than one interpretation of a name in a call is legal, apply
-- preference rules (universal types first) and operator visibility in
-- order to remove ambiguity. I1 and I2 are the first two interpretations
-- that are compatible with the context, but there may be others.
@ -216,19 +221,22 @@ package Sem_Type is
-- interpretations is universal, choose the non-universal one. If either
-- node is overloaded, find single common interpretation.
function Is_Subtype_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean;
-- Checks whether T1 is any subtype of T2 directly or indirectly. Applies
-- only to scalar subtypes ???
function Is_Ancestor (T1, T2 : Entity_Id) return Boolean;
-- T1 is a tagged type (not class-wide). Verify that it is one of the
-- ancestors of type T2 (which may or not be class-wide)
function Operator_Matches_Spec (Op, New_S : Entity_Id) return Boolean;
function Is_Subtype_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean;
-- Checks whether T1 is any subtype of T2 directly or indirectly. Applies
-- only to scalar subtypes ???
function Operator_Matches_Spec (Op, New_S : Entity_Id) return Boolean;
-- Used to resolve subprograms renaming operators, and calls to user
-- defined operators. Determines whether a given operator Op, matches
-- a specification, New_S.
procedure Set_Abstract_Op (I : Interp_Index; V : Entity_Id);
-- Set the abstract operation field of an interpretation
function Valid_Comparison_Arg (T : Entity_Id) return Boolean;
-- A valid argument to an ordering operator must be a discrete type, a
-- real type, or a one dimensional array with a discrete component type.