===================================================================
@@ -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
===================================================================
@@ -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.
===================================================================
@@ -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;
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.