From patchwork Fri Jan 20 11:55:18 2017 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 717606 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.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 3v4fL12KKHz9sDG for ; Fri, 20 Jan 2017 22:55:53 +1100 (AEDT) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="RJIXuupp"; dkim-atps=neutral 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=xYTcdKl4i4eykJj26up1ACYtq6hh82kba3TIJnUCfOdHaxopX8 /N7rakjNi0CiR0PBJqXsNIyPZafPgtJ6vDWwSsBG/kOy/3oO3ofEp3N72WYWjzW2 aDfNucgNrYJfFKWFzt4GAwNUny8NcYT0hQBRtLlH4g7tZUQJ6m79bxqks= 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=p806kM3+/uNGVxGfYfOb0ud/ZP0=; b=RJIXuuppSF1HeUSlXZZE ezsevmDlWY1rPkoeeODNTpCvp2423Dy5EuI7Q5A0HzYBPU1VMon/0s+3dBysnymj TctcvDwLe7slRosWy1h6IY0zZPUY62carbYoMm+VPAQxbi6E/rZSmANqAx9Oc5Lt GesnISuTh19zRdi52HQvLOc= Received: (qmail 87736 invoked by alias); 20 Jan 2017 11:55:27 -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 87183 invoked by uid 89); 20 Jan 2017 11:55:20 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No 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 ESMTP; Fri, 20 Jan 2017 11:55:20 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id ADF51117AEC; Fri, 20 Jan 2017 06:55:18 -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 cP6LmKNjOqtY; Fri, 20 Jan 2017 06:55:18 -0500 (EST) Received: from tron.gnat.com (tron.gnat.com [205.232.38.10]) by rock.gnat.com (Postfix) with ESMTP id 9E4B1117AB3; Fri, 20 Jan 2017 06:55:18 -0500 (EST) Received: by tron.gnat.com (Postfix, from userid 4192) id 9D54948C; Fri, 20 Jan 2017 06:55:18 -0500 (EST) Date: Fri, 20 Jan 2017 06:55:18 -0500 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Javier Miranda Subject: [Ada] Crash on overloaded function call with limited view Message-ID: <20170120115518.GA64006@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) This patch fixes a compiler abort on a call to a function that returns a limited view of a type. The following sources must compile quietly: limited with Root; package Api is type Object is tagged null record; function Is_Present (Name : in String) return Boolean; function Get (Name : in String) return Root.Object'Class; end Api; with Api; package Root is type Object is new Api.Object with null record; end Root; with Root; package body Api is function Get (Name : in String) return Root.Object'Class is B : Root.Object; begin return B; end Get; function Is_Present (Name : in String) return Boolean is O : constant Object'Class := Object'Class (Get (Name)); begin return True; end Is_Present; end Api; Command: gcc -c api.adb Tested on x86_64-pc-linux-gnu, committed on trunk 2017-01-20 Javier Miranda * sem_res.adb (Resolve_Call): If a function call returns a limited view of a type and at the point of the call the function is not declared in the extended main unit then replace it with the non-limited view, which must be available. If the called function is in the extended main unit then no action is needed since the back-end handles this case. Index: sem_res.adb =================================================================== --- sem_res.adb (revision 244700) +++ sem_res.adb (working copy) @@ -6061,12 +6061,16 @@ end; else - -- If the function returns the limited view of type, the call must - -- appear in a context in which the non-limited view is available. - -- As is done in Try_Object_Operation, use the available view to - -- prevent back-end confusion. + -- If the called function is not declared in the main unit and it + -- returns the limited view of type then use the available view (as + -- is done in Try_Object_Operation) to prevent back-end confusion; + -- the call must appear in a context where the nonlimited view is + -- available. If the called function is in the extended main unit + -- then no action is needed, because the back end handles this case. - if From_Limited_With (Etype (Nam)) then + if not In_Extended_Main_Code_Unit (Nam) + and then From_Limited_With (Etype (Nam)) + then Set_Etype (Nam, Available_View (Etype (Nam))); end if;