From patchwork Mon Aug 29 10:06:25 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 112009 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 2DCFEB6F90 for ; Mon, 29 Aug 2011 20:06:43 +1000 (EST) Received: (qmail 6559 invoked by alias); 29 Aug 2011 10:06:40 -0000 Received: (qmail 6549 invoked by uid 22791); 29 Aug 2011 10:06:39 -0000 X-SWARE-Spam-Status: No, hits=-1.8 required=5.0 tests=AWL,BAYES_00 X-Spam-Check-By: sourceware.org Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Mon, 29 Aug 2011 10:06:26 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 72A292BB109; Mon, 29 Aug 2011 06:06:25 -0400 (EDT) Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id IMHww48rzCDN; Mon, 29 Aug 2011 06:06:25 -0400 (EDT) Received: from kwai.gnat.com (kwai.gnat.com [205.232.38.4]) by rock.gnat.com (Postfix) with ESMTP id 5AEE92BB105; Mon, 29 Aug 2011 06:06:25 -0400 (EDT) Received: by kwai.gnat.com (Postfix, from userid 4192) id 59E0E3FEE8; Mon, 29 Aug 2011 06:06:25 -0400 (EDT) Date: Mon, 29 Aug 2011 06:06:25 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Ed Schonberg Subject: [Ada] Legality checks on access-to-object types Message-ID: <20110829100625.GA21515@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.20 (2009-06-14) 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 Some checks on illegal uses of class-wide expressions do not apply to access_ to_subprograms. Use base type to determine whether an access subtype belongs to the latter category. The following must compile quietly in Ada205 mode: package T is pragma Elaborate_Body; end T; --- with Ada.Containers.Indefinite_Hashed_Maps; with Ada.Strings.Hash; package body T is type C is tagged null record; type Getter is access function return C'Class; package Getter_Maps is new Ada.Containers.Indefinite_Hashed_Maps (Key_Type => String, Element_Type => Getter, Hash => Ada.Strings.Hash, Equivalent_Keys => "="); use Getter_Maps; M : Getter_Maps.Map := Getter_Maps.Empty_Map; G : Getter; function My_Get return C'Class is D : C; begin return D; end My_Get; begin M.Insert ("foo", My_Get'Access); G := My_Get'Access; M.Insert ("foo", G); end T; Tested on x86_64-pc-linux-gnu, committed on trunk 2011-08-29 Ed Schonberg * sem_res.adb (Resolve_Actuals): Use base type to determine whether an access subtype is access_to_subprogram, when applying checks for RM 3.10.2 (27). Index: sem_res.adb =================================================================== --- sem_res.adb (revision 178155) +++ sem_res.adb (working copy) @@ -3987,14 +3987,17 @@ ("& is not a dispatching operation of &!", A, Nam); end if; + -- Apply the checks described in 3.10.2(27): if the context is a + -- specific access-to-object, the actual cannot be class-wide. + -- Use base type to exclude access_to_subprogram cases. + elsif Is_Access_Type (A_Typ) and then Is_Access_Type (F_Typ) - and then Ekind (F_Typ) /= E_Access_Subprogram_Type - and then Ekind (F_Typ) /= E_Anonymous_Access_Subprogram_Type + and then not Is_Access_Subprogram_Type (Base_Type (F_Typ)) and then (Is_Class_Wide_Type (Designated_Type (A_Typ)) or else (Nkind (A) = N_Attribute_Reference and then - Is_Class_Wide_Type (Etype (Prefix (A))))) + Is_Class_Wide_Type (Etype (Prefix (A))))) and then not Is_Class_Wide_Type (Designated_Type (F_Typ)) and then not Is_Controlling_Formal (F) @@ -4008,9 +4011,7 @@ Error_Msg_N ("access to class-wide argument not allowed here!", A); - if Is_Subprogram (Nam) - and then Comes_From_Source (Nam) - then + if Is_Subprogram (Nam) and then Comes_From_Source (Nam) then Error_Msg_Node_2 := Designated_Type (F_Typ); Error_Msg_NE ("& is not a dispatching operation of &!", A, Nam);