From patchwork Tue Oct 19 10:30:32 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 68305 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 1B5B2B70DE for ; Tue, 19 Oct 2010 21:30:42 +1100 (EST) Received: (qmail 6355 invoked by alias); 19 Oct 2010 10:30:41 -0000 Received: (qmail 6346 invoked by uid 22791); 19 Oct 2010 10:30:40 -0000 X-SWARE-Spam-Status: No, hits=-1.2 required=5.0 tests=AWL, BAYES_00, T_RP_MATCHES_RCVD X-Spam-Check-By: sourceware.org Received: from mel.act-europe.fr (HELO mel.act-europe.fr) (194.98.77.210) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Tue, 19 Oct 2010 10:30:34 +0000 Received: from localhost (localhost [127.0.0.1]) by filtered-smtp.eu.adacore.com (Postfix) with ESMTP id 999E6CB02DA; Tue, 19 Oct 2010 12:30:32 +0200 (CEST) Received: from mel.act-europe.fr ([127.0.0.1]) by localhost (smtp.eu.adacore.com [127.0.0.1]) (amavisd-new, port 10024) with ESMTP id mMKKMbGcjjye; Tue, 19 Oct 2010 12:30:32 +0200 (CEST) Received: from saumur.act-europe.fr (saumur.act-europe.fr [10.10.0.183]) by mel.act-europe.fr (Postfix) with ESMTP id 86DB8CB0286; Tue, 19 Oct 2010 12:30:32 +0200 (CEST) Received: by saumur.act-europe.fr (Postfix, from userid 525) id 69C9CD9BB5; Tue, 19 Oct 2010 12:30:32 +0200 (CEST) Date: Tue, 19 Oct 2010 12:30:32 +0200 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Thomas Quinot Subject: [Ada] Functions with access result are primitives Message-ID: <20101019103032.GA4776@adacore.com> Mime-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.9i X-IsSubscribed: yes Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org 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 * sem_util.adb (Collect_Primitive_Operations): A function with an anonymous access result designating T is a primitive operation of T. 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;