Patchwork [Ada] Implementation of AI05-0073

login
register
mail settings
Submitter Arnaud Charlet
Date Oct. 7, 2010, 12:46 p.m.
Message ID <20101007124606.GA20914@adacore.com>
Download mbox | patch
Permalink /patch/67048/
State New
Headers show

Comments

Arnaud Charlet - Oct. 7, 2010, 12:46 p.m.
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.

Patch

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;