From patchwork Thu Sep 19 13:28:19 2019 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: 1164629 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-509290-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="D5vv0M2M"; 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 46YyTH4wR0z9sN1 for ; Thu, 19 Sep 2019 23:32:50 +1000 (AEST) 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=SmZk+rRQ7EXv+obfg6ycvvESkusoc6Vd7EAd/zhyFtTnOZHwbF igrMpYvm1KtD/Br8hcfVZ31p+9PGFl6D1Fg8ljxznTtTIzC2vmjZROxfQr8yFvcH WP3jWdRxBt/eT5NYDi/B3JaysIQlUrM8ayah8cVLG4yY5x/dYmDLG1X/Y= 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=caXNOKj54iPzSL2sIkXhqPmSQzs=; b=D5vv0M2MHE01pzTCdJ9k vVKjKpsLlcyPmtmCaI+jdOk2lNTiOBhiNq0zG3RDK16pvAkwME61EaGVCoZER7GR Fnjph/4xp/YHCVAmh7pvTlIfLKKDXXAxk6F8uQKb9hkzE5p1vxoU2fwxuVOrSrzs 7b0S8i2C6NspL4sIZ998ObA= Received: (qmail 6104 invoked by alias); 19 Sep 2019 13:29: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 3058 invoked by uid 89); 19 Sep 2019 13:28:37 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-11.1 required=5.0 tests=BAYES_00, GIT_PATCH_2, GIT_PATCH_3, SPF_NEUTRAL autolearn=ham version=3.3.1 spammy=Crash, schonbergadacorecom, schonberg@adacore.com, schonberg X-HELO: eggs.gnu.org Received: from eggs.gnu.org (HELO eggs.gnu.org) (209.51.188.92) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Thu, 19 Sep 2019 13:28:35 +0000 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1iAwTx-0001O2-8M for gcc-patches@gcc.gnu.org; Thu, 19 Sep 2019 09:28:27 -0400 Received: from rock.gnat.com ([205.232.38.15]:48671) by eggs.gnu.org with esmtps (TLS1.0:DHE_RSA_AES_256_CBC_SHA1:32) (Exim 4.71) (envelope-from ) id 1iAwTv-0001KA-Si for gcc-patches@gcc.gnu.org; Thu, 19 Sep 2019 09:28:24 -0400 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 64C7556020; Thu, 19 Sep 2019 09:28:19 -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 rA9PhNXmuyjD; Thu, 19 Sep 2019 09:28:19 -0400 (EDT) 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 538065601D; Thu, 19 Sep 2019 09:28:19 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4862) id 529136B4; Thu, 19 Sep 2019 09:28:19 -0400 (EDT) Date: Thu, 19 Sep 2019 09:28:19 -0400 From: Pierre-Marie de Rodat To: gcc-patches@gcc.gnu.org Cc: Ed Schonberg Subject: [Ada] Crash on predicate in full view in a generic unit Message-ID: <20190919132819.GA41731@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) X-detected-operating-system: by eggs.gnu.org: GNU/Linux 3.x X-Received-From: 205.232.38.15 X-IsSubscribed: yes This patch fixes a compiler abort on a dynamic predicate applied to the full view of a type in a generic package declaration, when the expression for the predicate is a conditionql expression that contains references to components of the full view of the type. Tested on x86_64-pc-linux-gnu, committed on trunk 2019-09-19 Ed Schonberg gcc/ada/ * sem_ch13.adb (Check_Aspect_At_End_Of_Declarations): Simplify handling of expressions in predicates when the context is a generic unit. gcc/testsuite/ * gnat.dg/predicate14.adb, gnat.dg/predicate14.ads: New testcase. --- gcc/ada/sem_ch13.adb +++ gcc/ada/sem_ch13.adb @@ -9374,17 +9374,22 @@ package body Sem_Ch13 is else -- In a generic context freeze nodes are not always generated, so - -- analyze the expression now. If the aspect is for a type, this - -- makes its potential components accessible. + -- analyze the expression now. If the aspect is for a type, we must + -- also make its potential components accessible. if not Analyzed (Freeze_Expr) and then Inside_A_Generic then if A_Id = Aspect_Dynamic_Predicate or else A_Id = Aspect_Predicate - or else A_Id = Aspect_Priority then Push_Type (Ent); - Preanalyze_Spec_Expression (Freeze_Expr, T); + Preanalyze_Spec_Expression (Freeze_Expr, Standard_Boolean); + Pop_Type (Ent); + + elsif A_Id = Aspect_Priority then + Push_Type (Ent); + Preanalyze_Spec_Expression (Freeze_Expr, Any_Integer); Pop_Type (Ent); + else Preanalyze (Freeze_Expr); end if; @@ -9395,12 +9400,23 @@ package body Sem_Ch13 is Set_Parent (End_Decl_Expr, ASN); - -- In a generic context the aspect expressions have not been - -- preanalyzed, so do it now. There are no conformance checks - -- to perform in this case. + -- In a generic context the original aspect expressions have not + -- been preanalyzed, so do it now. There are no conformance checks + -- to perform in this case. As before, we have to make components + -- visible for aspects that may reference them. if No (T) then - Check_Aspect_At_Freeze_Point (ASN); + if A_Id = Aspect_Dynamic_Predicate + or else A_Id = Aspect_Predicate + or else A_Id = Aspect_Priority + then + Push_Type (Ent); + Check_Aspect_At_Freeze_Point (ASN); + Pop_Type (Ent); + + else + Check_Aspect_At_Freeze_Point (ASN); + end if; return; -- The default values attributes may be defined in the private part, --- /dev/null new file mode 100644 +++ gcc/testsuite/gnat.dg/predicate14.adb @@ -0,0 +1,4 @@ +-- { dg-do compile } +package body Predicate14 is + procedure Dummy is null; +end Predicate14; --- /dev/null new file mode 100644 +++ gcc/testsuite/gnat.dg/predicate14.ads @@ -0,0 +1,56 @@ +generic +package Predicate14 with + SPARK_Mode +is + + type Field_Type is (F_Initial, F_Payload, F_Final); + + type State_Type is (S_Valid, S_Invalid); + + type Cursor_Type (State : State_Type := S_Invalid) is private; + + type Cursors_Type is array (Field_Type) of Cursor_Type; + + type Context_Type is private; + + type Result_Type (Field : Field_Type := F_Initial) is + record + case Field is + when F_Initial | F_Final => + null; + when F_Payload => + Value : Integer; + end case; + end record; + + function Valid_Context (Context : Context_Type) return Boolean; + +private + + function Valid_Type (Result : Result_Type) return Boolean is + (Result.Field = F_Initial); + + type Cursor_Type (State : State_Type := S_Invalid) is + record + case State is + when S_Valid => + Value : Result_Type; + when S_Invalid => + null; + end case; + end record + with Dynamic_Predicate => + (if State = S_Valid then Valid_Type (Value)); + + type Context_Type is + record + Field : Field_Type := F_Initial; + Cursors : Cursors_Type := (others => (State => S_Invalid)); + end record; + + function Valid_Context (Context : Context_Type) return Boolean is + (for all F in Context.Cursors'Range => + (Context.Cursors (F).Value.Field = F)); + + procedure Dummy; +end Predicate14; \ No newline at end of file