This patch does not change the behavior of native compilers. It
adds missing support in VM targets for declarations of class-wide
interface objects.
Tested on x86_64-pc-linux-gnu, committed on trunk
2011-08-03 Javier Miranda <[email protected]>
* exp_intr.adb
(Expand_Dispatching_Constructor_Call): Disable expansion of
code required for native targets. Done to avoid generating
references to unavailable runtime entities in VM targets.
* exp_ch3.adb
(Expand_N_Object_Declaration): Add missing support to handle
the explicit initialization of class-wide interface objects.
Fix documentation.
Index: exp_intr.adb
===================================================================
--- exp_intr.adb (revision 177163)
+++ exp_intr.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, 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- --
@@ -233,6 +233,7 @@
if not Is_Ancestor (Etype (Result_Typ), Etype (Tag_Arg),
Use_Full_View => True)
+ and then Tagged_Type_Expansion
then
-- Obtain the reference to the Ada.Tags service before generating
-- the Object_Declaration node to ensure that if this service is
Index: exp_ch3.adb
===================================================================
--- exp_ch3.adb (revision 177180)
+++ exp_ch3.adb (working copy)
@@ -4477,14 +4477,6 @@
-- Expand_N_Object_Declaration --
---------------------------------
- -- First we do special processing for objects of a tagged type where this
- -- is the point at which the type is frozen. The creation of the dispatch
- -- table and the initialization procedure have to be deferred to this
- -- point, since we reference previously declared primitive subprograms.
-
- -- The above comment is in the wrong place, it should be at the proper
- -- point in this routine ???
-
procedure Expand_N_Object_Declaration (N : Node_Id) is
Def_Id : constant Entity_Id := Defining_Identifier (N);
Expr : constant Node_Id := Expression (N);
@@ -4528,6 +4520,12 @@
return;
end if;
+ -- First we do special processing for objects of a tagged type where
+ -- this is the point at which the type is frozen. The creation of the
+ -- dispatch table and the initialization procedure have to be deferred
+ -- to this point, since we reference previously declared primitive
+ -- subprograms.
+
-- Force construction of dispatch tables of library level tagged types
if Tagged_Type_Expansion
@@ -4993,11 +4991,33 @@
Set_Homonym (Defining_Identifier (N), Homonym (Def_Id));
Exchange_Entities (Defining_Identifier (N), Def_Id);
end;
+
+ -- Handle initialization of class-wide interface object in VM
+ -- targets
+
+ elsif not Tagged_Type_Expansion then
+
+ -- Replace
+ -- CW : I'Class := Obj;
+ -- by
+ -- CW : I'Class;
+ -- CW := I'Class (Obj); [1]
+
+ -- The assignment [1] is later expanded in a dispatching
+ -- call to _assign
+
+ Set_Expression (N, Empty);
+
+ Insert_Action (N,
+ Make_Assignment_Statement (Loc,
+ Name => New_Reference_To (Def_Id, Loc),
+ Expression => Convert_To (Typ,
+ Relocate_Node (Expr))));
end if;
return;
- -- Comment needed here, what case is this???
+ -- Common case of explicit object initialization
else
-- In most cases, we must check that the initial value meets any
