From patchwork Tue Dec 11 11:36:54 2018 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Pierre-Marie de Rodat X-Patchwork-Id: 1011069 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (mailfrom) smtp.mailfrom=gcc.gnu.org (client-ip=209.132.180.131; helo=sourceware.org; envelope-from=gcc-patches-return-492107-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=none (p=none dis=none) header.from=adacore.com Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="anlEtBl+"; dkim-atps=neutral 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 43DdGD1Bb0z9s3q for ; Tue, 11 Dec 2018 22:37:23 +1100 (AEDT) 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=D5/Gbz9x6aopQ+S295x6mQTGC1NpxdvaJbB2yQlEldSJf53mzr rIJlnJy9X3kiVZGc2HoHloTlwRIL1oNubJ1VJNNjwjc8OlA8UQKa54hZht0NgwcU lljZqjdCiEKzdkb5bzdg46Y6Ns5qh037CmP/lfJEuw11vi2+H7nGM9nms= 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=cfg3gZoIleGOQirqUIAdD7nWh5I=; b=anlEtBl+F6Ic0yV3L3Fm dJapjWEXv6jIGVP2Gt+8uJvSg64J8fG3Khn3r4z0UVhqajTx3ByLaryMJwhBKkMD HFQR35NWUPCqqL7jEAqBK6fb+H+6UrwJocF0p6srUISYgFKAqDGK1X0HHdhGmmef 0LOqkryLnrd3Mx3H4UqFcB8= Received: (qmail 103175 invoked by alias); 11 Dec 2018 11:37:00 -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 103008 invoked by uid 89); 11 Dec 2018 11:36:59 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-11.9 required=5.0 tests=BAYES_00, GIT_PATCH_2, GIT_PATCH_3, RCVD_IN_DNSWL_NONE, SPF_PASS autolearn=ham version=3.3.2 spammy=UD:First 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; Tue, 11 Dec 2018 11:36:55 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 7AD0D56089; Tue, 11 Dec 2018 06:36:54 -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 6-DW54PAQ2Rr; Tue, 11 Dec 2018 06:36:54 -0500 (EST) Received: from tron.gnat.com (tron.gnat.com [IPv6:2620:20:4000:0:46a8:42ff:fe0e:e294]) by rock.gnat.com (Postfix) with ESMTP id 6990F56088; Tue, 11 Dec 2018 06:36:54 -0500 (EST) Received: by tron.gnat.com (Postfix, from userid 4862) id 688CE3573; Tue, 11 Dec 2018 06:36:54 -0500 (EST) Date: Tue, 11 Dec 2018 06:36:54 -0500 From: Pierre-Marie de Rodat To: gcc-patches@gcc.gnu.org Cc: Ed Schonberg Subject: [Ada] Crash on misplaced First operation for GNAT iterable type Message-ID: <20181211113654.GA106038@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) X-IsSubscribed: yes This patch improves the handling of an improper declaaration of aspect First for a GNAT-defined iterable type, Tested on x86_64-pc-linux-gnu, committed on trunk 2018-12-11 Ed Schonberg gcc/ada/ * sem_util.adb (Get_Actual_Subtype): Function can return type mark. (Get_Cursor_Type): Improve recovery and error message on a misplaced First aspect for an iterable type. gcc/testsuite/ * gnat.dg/iter4.adb: New testcase. --- gcc/ada/sem_util.adb +++ gcc/ada/sem_util.adb @@ -9049,6 +9049,13 @@ package body Sem_Util is else Decl := Build_Actual_Subtype (Typ, N); + + -- The call may yield a declaration, or just return the entity + + if Decl = Typ then + return Typ; + end if; + Atyp := Defining_Identifier (Decl); -- If Build_Actual_Subtype generated a new declaration then use it @@ -9162,6 +9169,9 @@ package body Sem_Util is if First_Op = Any_Id then Error_Msg_N ("aspect Iterable must specify First operation", Aspect); return Any_Type; + + elsif not Analyzed (First_Op) then + Analyze (First_Op); end if; Cursor := Any_Type; @@ -9195,7 +9205,8 @@ package body Sem_Util is if Cursor = Any_Type then Error_Msg_N - ("No legal primitive operation First for Iterable type", Aspect); + ("primitive operation for Iterable type must appear " + & "in the same list of declarations as the type", Aspect); end if; return Cursor; --- /dev/null new file mode 100644 +++ gcc/testsuite/gnat.dg/iter4.adb @@ -0,0 +1,36 @@ +-- { dg-do compile } + +procedure Iter4 is + package Root is + type Result is tagged record + B : Boolean; + end record; + + type T is tagged record + I : Integer; + end record + with Iterable => (First => Pkg.First, -- { dg-error "primitive operation for Iterable type must appear in the same list of declarations as the type" } + Next => Pkg.Next, + Has_Element => Pkg.Has_Element, + Element => Pkg.Element); + + package Pkg is + function First (Dummy : T) return Natural is (0); + function Next (Dummy : T; Cursor : Natural) return Natural is + (Cursor + 1); + function Has_Element (Value : T; Cursor : Natural) return Boolean is + (Cursor <= Value.I); + function Element (Dummy : T; Cursor : Natural) return Result is + ((B => Cursor mod 2 = 0)); + end Pkg; + end Root; + + package Derived is + type T is new Root.T with record + C : Character; + end record; + end Derived; + +begin + null; +end;