From patchwork Mon Oct 14 13:32:09 2013 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 283222 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]) (using TLSv1 with cipher DHE-RSA-AES256-SHA (256/256 bits)) (Client did not present a certificate) by ozlabs.org (Postfix) with ESMTPS id 0608E2C0343 for ; Tue, 15 Oct 2013 00:32:17 +1100 (EST) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; q=dns; s=default; b=vPZwrq4FG6RhFL6XYkLF+llBaIdn5C/bkIxa34Z7oeI3RDYAd9 edSwI+ncXFBz54I8+0BwRfXqTgBq56b2LCm3D24nMpz/iLZu5ishf2GMtldbj1id 61Sft097zDcg29W3nxysRz/6cVzE0fFq9hvadl4YUX9Kh8mqvpmN06EmQ= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; s= default; bh=Lpab9k3onDpFFFAUQ8NAI+U3s4Y=; b=nc7qWv1T6rdQhUmVwRHv IDMfQI81/Sk2sVIq31RTSm04UBoXAmq+m4OrQ7b21vsGKDpQQ2MNV6E1RJs+QZ6G ZT53Pwbjin4SyQpszFrAKHG42NiM/5kjFcZHXl8ffXQL5te8oajURSe4MlBOn/th P3IFlB3W63CWdoXklbJSKc4= Received: (qmail 1735 invoked by alias); 14 Oct 2013 13:32:12 -0000 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 Received: (qmail 1723 invoked by uid 89); 14 Oct 2013 13:32:12 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-1.9 required=5.0 tests=BAYES_00 autolearn=ham version=3.3.2 X-HELO: rock.gnat.com Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES256-SHA encrypted) ESMTPS; Mon, 14 Oct 2013 13:32:11 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id CF93E1165D8; Mon, 14 Oct 2013 09:32:31 -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 cSfHEwihVX2H; Mon, 14 Oct 2013 09:32:31 -0400 (EDT) Received: from kwai.gnat.com (unknown [IPv6:2620:20:4000:0:a6ba:dbff:fe26:1f63]) by rock.gnat.com (Postfix) with ESMTP id C05421164AE; Mon, 14 Oct 2013 09:32:31 -0400 (EDT) Received: by kwai.gnat.com (Postfix, from userid 4192) id 5FF313FB31; Mon, 14 Oct 2013 09:32:09 -0400 (EDT) Date: Mon, 14 Oct 2013 09:32:09 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Ed Schonberg Subject: [Ada] Missing errors in the body of a protected function Message-ID: <20131014133209.GA571@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.20 (2009-06-14) In the body of a protected function, the protected object itself is a constant (not just its components). Compiling p.adb must yield: p.adb:12:20: actual for "It" must be a variable p.adb:18:17: actual for "It" must be a variable procedure P is protected type Prot is function F return integer; private buffer : String (1 .. 100); end; procedure Stack_it (It : in out Prot) is begin null; end; protected body Prot is function F return integer is begin Stack_it (prot); -- ERROR return 15; end; end Prot; procedure Wrapper (It : Prot) is begin Stack_It (It); -- ERROR end; begin null; end; Tested on x86_64-pc-linux-gnu, committed on trunk 2013-10-14 Ed Schonberg * sem_util.adb (Is_Variable, In_Protected_Function): In the body of a protected function, the protected object itself is a constant (not just its components). Index: sem_util.adb =================================================================== --- sem_util.adb (revision 203546) +++ sem_util.adb (working copy) @@ -10198,7 +10198,8 @@ function In_Protected_Function (E : Entity_Id) return Boolean; -- Within a protected function, the private components of the enclosing -- protected type are constants. A function nested within a (protected) - -- procedure is not itself protected. + -- procedure is not itself protected. Within the body of a protected + -- function the current instance of the protected type is a constant. function Is_Variable_Prefix (P : Node_Id) return Boolean; -- Prefixes can involve implicit dereferences, in which case we must @@ -10210,12 +10211,24 @@ --------------------------- function In_Protected_Function (E : Entity_Id) return Boolean is - Prot : constant Entity_Id := Scope (E); + Prot : Entity_Id; S : Entity_Id; begin + if Is_Type (E) then + -- E is the current instance of a type. + + Prot := E; + + else + -- E is an object. + + Prot := Scope (E); + end if; + if not Is_Protected_Type (Prot) then return False; + else S := Current_Scope; while Present (S) and then S /= Prot loop @@ -10336,9 +10349,14 @@ or else K = E_In_Out_Parameter or else K = E_Generic_In_Out_Parameter - -- Current instance of type + -- Current instance of type. If this is a protected type, check + -- that we are not within the body of one of its protected + -- functions. - or else (Is_Type (E) and then In_Open_Scopes (E)) + or else (Is_Type (E) + and then In_Open_Scopes (E) + and then not In_Protected_Function (E)) + or else (Is_Incomplete_Or_Private_Type (E) and then In_Open_Scopes (Full_View (E))); end;