diff mbox

[Ada] Functions with access result are primitives

Message ID 20101019103032.GA4776@adacore.com
State New
Headers show

Commit Message

Arnaud Charlet Oct. 19, 2010, 10:30 a.m. UTC 
This change fixes a defect in Collect_Primitive_Operations whereby a
function with an anonymous access result type (designating a non-tagged
type) failed to be identified as a primitive operation of the designated
type.

The following compilation must be accepted quietly:

$ gcc -gnatc -c -gnat05 anon_access_prim.ads
package Anon_Access_Prim is
   type T is null record;
   function F return access T is null;
   type TT is new T;
   overriding function F return access TT is null;
end Anon_Access_Prim;

Tested on x86_64-pc-linux-gnu, committed on trunk

2010-10-19  Thomas Quinot  <quinot@adacore.com>

	* sem_util.adb (Collect_Primitive_Operations): A function with an
	anonymous access result designating T is a primitive operation of T.
diff mbox

Patch

Index: sem_util.adb
===================================================================
--- sem_util.adb	(revision 165687)
+++ sem_util.adb	(working copy)
@@ -1693,6 +1693,27 @@  package body Sem_Util is
       Formal_Derived : Boolean := False;
       Id             : Entity_Id;
 
+      function Match (E : Entity_Id) return Boolean;
+      --  True if E's base type is B_Type, or E is of an anonymous access type
+      --  and the base type of its designated type is B_Type.
+
+      -----------
+      -- Match --
+      -----------
+
+      function Match (E : Entity_Id) return Boolean is
+         Etyp : Entity_Id := Etype (E);
+
+      begin
+         if Ekind (Etyp) = E_Anonymous_Access_Type then
+            Etyp := Designated_Type (Etyp);
+         end if;
+
+         return Base_Type (Etyp) = B_Type;
+      end Match;
+
+   --  Start of processing for Collect_Primitive_Operations
+
    begin
       --  For tagged types, the primitive operations are collected as they
       --  are declared, and held in an explicit list which is simply returned.
@@ -1761,19 +1782,13 @@  package body Sem_Util is
             then
                Is_Prim := False;
 
-               if Base_Type (Etype (Id)) = B_Type then
+               if Match (Id) then
                   Is_Prim := True;
+
                else
                   Formal := First_Formal (Id);
                   while Present (Formal) loop
-                     if Base_Type (Etype (Formal)) = B_Type then
-                        Is_Prim := True;
-                        exit;
-
-                     elsif Ekind (Etype (Formal)) = E_Anonymous_Access_Type
-                       and then Base_Type
-                         (Designated_Type (Etype (Formal))) = B_Type
-                     then
+                     if Match (Formal) then
                         Is_Prim := True;
                         exit;
                      end if;