[Ada] Implementation of AI05-0073
Arnaud Charlet
charlet@adacore.com
Thu Oct 7 12:49:00 GMT 2010
This AI fixes some gaps in the handling of functions with abstract results and
with controlling access results. A series of new legality checks apply to such
functions, and make illegal some constructs that were legal but useless in
Ada2005.
Compiling the program below in Ada2012 mode must yield:
pack.ads:7:04: function whose access result designates abstract type must be abstract
pack.ads:11:04: generic function cannot have abstract result type
pack.ads:15:04: generic function cannot have an access result that designates an abstract type
pack.ads:20:06: function that returns abstract type must be abstract
pack.ads:25:07: function whose access result designates abstract type must be abstract
pack.ads:30:13: private function with controlling access result must override visible-part function
pack.ads:30:13: move subprogram to the visible part (RM 3.9.3(10))
---
-- AI05-0073 : verify that generic functions cannot return an abstract
-- type or an access to an abstract type.
package Pack is
type Real is tagged null record;
type Abstr is abstract tagged null record;
function Wrong (X : integer) return access Abstr; -- ERROR
generic
type T (<>) is abstract tagged private;
function Gft (X : T) return T; -- ERROR
generic
type T (<>) is abstract tagged private;
function Gft2 (X : T) return access T; -- ERROR
generic
type T (<>) is abstract tagged private;
package GP is
function Ft (X : T) return T; -- ERROR
end GP;
package Pkg is
type T (<>) is abstract tagged private;
function Ft (X : in T) return access T; -- ERROR
private
type T (D : Integer) is tagged null record;
end Pkg;
private
function Create (X : Integer) return access Real; -- ERROR
end Pack;
---
In addition, there is now a dynamic check that the return value of a function
with a controlling access result has the same tag as the designated type of
the return specification. The following must compile and execute quietly in
Ada2012 mode:
-- Ada05-0073: rules on controlling results. If a function has a controlling
-- access result, verify that the return value designates an object with the
-- same tag as that of the designated return type,
pragma Ada_2012;
with ada.Tags; use Ada.Tags;
procedure Tag_Test is
package Pack is
type T is tagged null record;
function Func (X : Integer) return Access T;
type T1 is new T with null record;
function Func (X : Integer) return Access T1;
Obj1 : aliased T1;
end Pack;
use Pack;
Obj : aliased T;
Obj1 : aliased T1;
function Get return T'Class is
begin
return T'Class (Obj1);
end;
It : aliased T'class := Get;
package body Pack is
function Func (X : Integer) return Access T is
begin
if X < 10 then
return Obj : access T := It'Access do
null;
end return;
else
return It'Access;
end if;
end Func;
function Func (X : Integer) return access T1 is
begin
return Obj1'access;
end;
end Pack;
Ptr : access T;
begin
begin
Ptr := Func (0);
raise Program_Error; -- should not get here
exception
when Constraint_Error => null;
end;
begin
Ptr := Func (100);
raise Program_Error; -- should not get here
exception
when Constraint_Error => null;
end;
end Tag_Test;
Tested on x86_64-pc-linux-gnu, committed on trunk
2010-10-07 Ed Schonberg <schonberg@adacore.com>
* sem_ch6.adb (Analyze_Subprogram_Specification): Implement Ada2012
checks on functions that return an abstract type or have a controlling
result whose designated type is an abstract type.
(Check_Private_Overriding): Implement Ada2012 checks on functions
declared in the private part, if an abstract type is involved.
* sem_ch12.adb (Analyze_Generic_Subprogram_Declaration): In Ada2012,
reject a generic function that returns an abstract type.
* exp_ch5.adb (Expand_Simple_Function_Return): in Ada2012, if a
function has a controlling access result, check that the tag of the
return value matches the designated type of the return expression.
-------------- next part --------------
Index: exp_ch5.adb
===================================================================
--- exp_ch5.adb (revision 165080)
+++ exp_ch5.adb (working copy)
@@ -4246,6 +4246,29 @@ package body Exp_Ch5 is
Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id)))),
Reason => PE_Accessibility_Check_Failed));
end;
+
+ -- AI05-0073 : if function has a controlling access result, check that
+ -- the tag of the return value matches the designated type.
+
+ elsif Ekind (R_Type) = E_Anonymous_Access_Type
+ and then Has_Controlling_Result (Scope_Id)
+ and then Ada_Version >= Ada_12
+ then
+ Insert_Action (Exp,
+ Make_Raise_Constraint_Error (Loc,
+ Condition =>
+ Make_Op_Ne (Loc,
+ Left_Opnd =>
+ Make_Selected_Component (Loc,
+ Prefix => Duplicate_Subexpr (Exp),
+ Selector_Name =>
+ Make_Identifier (Loc, Chars => Name_uTag)),
+ Right_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Designated_Type (R_Type), Loc),
+ Attribute_Name => Name_Tag)),
+ Reason => CE_Tag_Check_Failed));
end if;
-- If we are returning an object that may not be bit-aligned, then copy
Index: sem_ch12.adb
===================================================================
--- sem_ch12.adb (revision 165081)
+++ sem_ch12.adb (working copy)
@@ -2800,10 +2800,28 @@ package body Sem_Ch12 is
if Nkind (Result_Definition (Spec)) = N_Access_Definition then
Result_Type := Access_Definition (Spec, Result_Definition (Spec));
Set_Etype (Id, Result_Type);
+
+ -- Check restriction imposed by AI05-073 : a generic function
+ -- cannot return an abstract type or an access to such.
+
+ if Is_Abstract_Type (Designated_Type (Result_Type))
+ and then Ada_Version >= Ada_12
+ then
+ Error_Msg_N ("generic function cannot have an access result"
+ & " that designates an abstract type", Spec);
+ end if;
+
else
Find_Type (Result_Definition (Spec));
Typ := Entity (Result_Definition (Spec));
+ if Is_Abstract_Type (Typ)
+ and then Ada_Version >= Ada_12
+ then
+ Error_Msg_N
+ ("generic function cannot have abstract result type", Spec);
+ end if;
+
-- If a null exclusion is imposed on the result type, then create
-- a null-excluding itype (an access subtype) and use it as the
-- function's Etype.
Index: sem_ch6.adb
===================================================================
--- sem_ch6.adb (revision 165098)
+++ sem_ch6.adb (working copy)
@@ -2960,16 +2960,29 @@ package body Sem_Ch6 is
-- In case of primitives associated with abstract interface types
-- the check is applied later (see Analyze_Subprogram_Declaration).
- if Is_Abstract_Type (Etype (Designator))
- and then not Is_Interface (Etype (Designator))
- and then Nkind (Parent (N)) /= N_Subprogram_Renaming_Declaration
- and then Nkind (Parent (N)) /=
- N_Abstract_Subprogram_Declaration
- and then
- (Nkind (Parent (N))) /= N_Formal_Abstract_Subprogram_Declaration
+ if not Nkind_In (Parent (N),
+ N_Subprogram_Renaming_Declaration,
+ N_Abstract_Subprogram_Declaration,
+ N_Formal_Abstract_Subprogram_Declaration)
then
- Error_Msg_N
- ("function that returns abstract type must be abstract", N);
+ if Is_Abstract_Type (Etype (Designator))
+ and then not Is_Interface (Etype (Designator))
+ then
+ Error_Msg_N
+ ("function that returns abstract type must be abstract", N);
+
+ -- Ada 2012 (AI-0073) : extend this test to subprograms with an
+ -- access result whose designated type is abstract.
+
+ elsif Nkind (Result_Definition (N)) = N_Access_Definition
+ and then
+ not Is_Class_Wide_Type (Designated_Type (Etype (Designator)))
+ and then Is_Abstract_Type (Designated_Type (Etype (Designator)))
+ and then Ada_Version >= Ada_12
+ then
+ Error_Msg_N ("function whose access result designates "
+ & "abstract type must be abstract", N);
+ end if;
end if;
end if;
@@ -7029,16 +7042,34 @@ package body Sem_Ch6 is
& "(RM 3.9.3(10))!", S);
elsif Ekind (S) = E_Function
- and then Is_Tagged_Type (T)
- and then T = Base_Type (Etype (S))
and then not Is_Overriding
then
- Error_Msg_N
- ("private function with tagged result must"
- & " override visible-part function", S);
- Error_Msg_N
- ("\move subprogram to the visible part"
- & " (RM 3.9.3(10))", S);
+ if Is_Tagged_Type (T)
+ and then T = Base_Type (Etype (S))
+ then
+ Error_Msg_N
+ ("private function with tagged result must"
+ & " override visible-part function", S);
+ Error_Msg_N
+ ("\move subprogram to the visible part"
+ & " (RM 3.9.3(10))", S);
+
+ -- AI05-0073: extend this test to the case of a function
+ -- with a controlling access result.
+
+ elsif Ekind (Etype (S)) = E_Anonymous_Access_Type
+ and then Is_Tagged_Type (Designated_Type (Etype (S)))
+ and then
+ not Is_Class_Wide_Type (Designated_Type (Etype (S)))
+ and then Ada_Version >= Ada_12
+ then
+ Error_Msg_N
+ ("private function with controlling access result "
+ & "must override visible-part function", S);
+ Error_Msg_N
+ ("\move subprogram to the visible part"
+ & " (RM 3.9.3(10))", S);
+ end if;
end if;
end if;
end Check_Private_Overriding;
More information about the Gcc-patches
mailing list