From patchwork Mon Jan 23 08:30:44 2012 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 137282 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 A3F6BB6F74 for ; Mon, 23 Jan 2012 19:31:06 +1100 (EST) Comment: DKIM? See http://www.dkim.org DKIM-Signature: v=1; a=rsa-sha1; c=relaxed/relaxed; d=gcc.gnu.org; s=default; x=1327912267; h=Comment: DomainKey-Signature:Received:Received:Received:Received:Received: Received:Received:Date:From:To:Cc:Subject:Message-ID: MIME-Version:Content-Type:Content-Disposition:User-Agent: Mailing-List:Precedence:List-Id:List-Unsubscribe:List-Archive: List-Post:List-Help:Sender:Delivered-To; bh=3jhXuDZR0OhogxMZ9Yvx lNriNKc=; b=gxti6S59FJnpLDRHN8UFKrdUfLjmDHkKXtrm6QyYPNTSyr+WjFvL LD0jCPHfLY/JVfJC+F5Ao2x1/gyxt7AzXUEBl/uM5K3OBhgDZf0qDnb45ZfOhvZd DCZ0Bi5RTjnQtF2Edk0nkBG1DVWbZB04C03yUq3x2Kpa7LixZLiEzGk= Comment: DomainKeys? See http://antispam.yahoo.com/domainkeys DomainKey-Signature: a=rsa-sha1; q=dns; c=nofws; s=default; d=gcc.gnu.org; h=Received:Received:X-SWARE-Spam-Status:X-Spam-Check-By:Received:Received:Received:Received:Received:Date:From:To:Cc:Subject:Message-ID:MIME-Version:Content-Type:Content-Disposition:User-Agent:Mailing-List:Precedence:List-Id:List-Unsubscribe:List-Archive:List-Post:List-Help:Sender:Delivered-To; b=WHvtcyvwF9sLLUB/igicAuT3AAjjiOU/uXWzjv3Kg7VYgNToLSTL1Ph1Tin/5v l6GUzvNMVcHmdPMVmVVi0u0oLA1RdskPetmRf7kuNQlvKmtdC/NEfX+UDGA6pJEj 8AuZEwFtfCu2HMe7/zILHHLUdauzAsciD0LjDmKxI7/5Y=; Received: (qmail 32111 invoked by alias); 23 Jan 2012 08:31:01 -0000 Received: (qmail 32086 invoked by uid 22791); 23 Jan 2012 08:30:59 -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, 23 Jan 2012 08:30:45 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id C07BF2BAEBC; Mon, 23 Jan 2012 03:30:44 -0500 (EST) 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 I+1pUqcj9VUk; Mon, 23 Jan 2012 03:30:44 -0500 (EST) Received: from kwai.gnat.com (kwai.gnat.com [205.232.38.4]) by rock.gnat.com (Postfix) with ESMTP id 9150B2BAD92; Mon, 23 Jan 2012 03:30:44 -0500 (EST) Received: by kwai.gnat.com (Postfix, from userid 4192) id 93C0092BF6; Mon, 23 Jan 2012 03:30:44 -0500 (EST) Date: Mon, 23 Jan 2012 03:30:44 -0500 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Hristian Kirtchev Subject: [Ada] Aliased view of a type in various Ada dialects Message-ID: <20120123083044.GA20612@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 This patch corrects the detection of a proper aliased view of a type in the context of attributes Access and Unchecked_Access. Tested on x86_64-pc-linux-gnu, committed on trunk 2012-01-23 Hristian Kirtchev * freeze.adb (Check_Current_Instance): Issue an error when the prefix of 'Unchecked_Access or 'Access does not denote a legal aliased view of a type. (Freeze_Record_Type): Do not halt the processing of record components once the Has_Controlled_Component is set as this bypasses the remaining checks. (Is_Aliased_View_Of_Type): New routine. Index: freeze.adb =================================================================== --- freeze.adb (revision 183406) +++ freeze.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -1592,14 +1592,93 @@ procedure Check_Current_Instance (Comp_Decl : Node_Id) is - Rec_Type : constant Entity_Id := - Scope (Defining_Identifier (Comp_Decl)); + function Is_Aliased_View_Of_Type (Typ : Entity_Id) return Boolean; + -- Determine whether Typ is compatible with the rules for aliased + -- views of types as defined in RM 3.10 in the various dialects. - Decl : constant Node_Id := Parent (Rec_Type); - function Process (N : Node_Id) return Traverse_Result; -- Process routine to apply check to given node + ----------------------------- + -- Is_Aliased_View_Of_Type -- + ----------------------------- + + function Is_Aliased_View_Of_Type (Typ : Entity_Id) return Boolean is + Typ_Decl : constant Node_Id := Parent (Typ); + + begin + -- Common case + + if Nkind (Typ_Decl) = N_Full_Type_Declaration + and then Limited_Present (Type_Definition (Typ_Decl)) + then + return True; + + -- The following paragraphs describe what a legal aliased view of + -- a type is in the various dialects of Ada. + + -- Ada 95 + + -- The current instance of a limited type, and a formal parameter + -- or generic formal object of a tagged type. + + -- Ada 95 limited type + -- * Type with reserved word "limited" + -- * A protected or task type + -- * A composite type with limited component + + elsif Ada_Version <= Ada_95 then + return Is_Limited_Type (Typ); + + -- Ada 2005 + + -- The current instance of a limited tagged type, a protected + -- type, a task type, or a type that has the reserved word + -- "limited" in its full definition ... a formal parameter or + -- generic formal object of a tagged type. + + -- Ada 2005 limited type + -- * Type with reserved word "limited", "synchronized", "task" + -- or "protected" + -- * A composite type with limited component + -- * A derived type whose parent is a non-interface limited type + + elsif Ada_Version = Ada_2005 then + return + (Is_Limited_Type (Typ) and then Is_Tagged_Type (Typ)) + or else + (Is_Derived_Type (Typ) + and then not Is_Interface (Etype (Typ)) + and then Is_Limited_Type (Etype (Typ))); + + -- Ada 2012 and beyond + + -- The current instance of an immutably limited type ... a formal + -- parameter or generic formal object of a tagged type. + + -- Ada 2012 limited type + -- * Type with reserved word "limited", "synchronized", "task" + -- or "protected" + -- * A composite type with limited component + -- * A derived type whose parent is a non-interface limited type + -- * An incomplete view + + -- Ada 2012 immutably limited type + -- * Explicitly limited record type + -- * Record extension with "limited" present + -- * Non-formal limited private type that is either tagged + -- or has at least one access discriminant with a default + -- expression + -- * Task type, protected type or synchronized interface + -- * Type derived from immutably limited type + + else + return + Is_Immutably_Limited_Type (Typ) + or else Is_Incomplete_Type (Typ); + end if; + end Is_Aliased_View_Of_Type; + ------------- -- Process -- ------------- @@ -1628,24 +1707,15 @@ procedure Traverse is new Traverse_Proc (Process); + -- Local variables + + Rec_Type : constant Entity_Id := + Scope (Defining_Identifier (Comp_Decl)); + -- Start of processing for Check_Current_Instance begin - -- In Ada 95, the (imprecise) rule is that the current instance - -- of a limited type is aliased. In Ada 2005, limitedness must be - -- explicit: either a tagged type, or a limited record. - - if Is_Limited_Type (Rec_Type) - and then (Ada_Version < Ada_2005 or else Is_Tagged_Type (Rec_Type)) - then - return; - - elsif Nkind (Decl) = N_Full_Type_Declaration - and then Limited_Present (Type_Definition (Decl)) - then - return; - - else + if not Is_Aliased_View_Of_Type (Rec_Type) then Traverse (Comp_Decl); end if; end Check_Current_Instance; @@ -2158,18 +2228,16 @@ (Etype (Comp))))) then Set_Has_Controlled_Component (Rec); - exit; end if; if Has_Unchecked_Union (Etype (Comp)) then Set_Has_Unchecked_Union (Rec); end if; + -- Scan component declaration for likely misuses of current + -- instance, either in a constraint or a default expression. + if Has_Per_Object_Constraint (Comp) then - - -- Scan component declaration for likely misuses of current - -- instance, either in a constraint or a default expression. - Check_Current_Instance (Parent (Comp)); end if;