From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: (qmail 30133 invoked by alias); 17 Sep 2019 08:06:40 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Received: (qmail 30038 invoked by uid 89); 17 Sep 2019 08:06:39 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-11.2 required=5.0 tests=AWL,BAYES_00,GIT_PATCH_2,GIT_PATCH_3,RCVD_IN_DNSWL_NONE,SPF_PASS autolearn=ham version=3.3.1 spammy=rec, sem_ch3adb, miranda, Miranda 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, 17 Sep 2019 08:06:37 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 4AAFC117BBD; Tue, 17 Sep 2019 04:06:33 -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 2Fhcd-uSyaSQ; Tue, 17 Sep 2019 04:06:33 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [205.232.38.10]) by rock.gnat.com (Postfix) with ESMTP id 3941B117802; Tue, 17 Sep 2019 04:06:33 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4862) id 380E36AD; Tue, 17 Sep 2019 04:06:33 -0400 (EDT) Date: Tue, 17 Sep 2019 08:07:00 -0000 From: Pierre-Marie de Rodat To: gcc-patches@gcc.gnu.org Cc: Javier Miranda Subject: [Ada] Ada 2020: Raise expressions in limited contexts (AI12-0172) Message-ID: <20190917080633.GA37440@adacore.com> MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="YZ5djTAD1cGYuMQK" Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) X-IsSubscribed: yes X-SW-Source: 2019-09/txt/msg00987.txt.bz2 --YZ5djTAD1cGYuMQK Content-Type: text/plain; charset=us-ascii Content-Disposition: inline Content-length: 829 This patch adds support for the use of raise expressions in more limited contexts (as described in the Ada Isssue AI12-0172). Tested on x86_64-pc-linux-gnu, committed on trunk 2019-09-17 Javier Miranda gcc/ada/ * exp_ch3.adb (Build_Record_Init_Proc): Do not generate code to adjust the tag component when the record is initialized with a raise expression. * sem_aggr.adb (Valid_Limited_Ancestor): Return True for N_Raise_Expression nodes. (Valid_Ancestor_Type): Return True for raise expressions. * sem_ch3.adb (Analyze_Component_Declaration): Do not report an error when a component is initialized with a raise expression. * sem_ch4.adb (Analyze_Qualified_Expression): Do not report an error when the aggregate has a raise expression. gcc/testsuite/ * gnat.dg/limited4.adb: New testcase. --YZ5djTAD1cGYuMQK Content-Type: text/x-diff; charset=us-ascii Content-Disposition: attachment; filename="patch.diff" Content-length: 4923 --- gcc/ada/exp_ch3.adb +++ gcc/ada/exp_ch3.adb @@ -1922,9 +1922,15 @@ package body Exp_Ch3 is -- Adjust the tag if tagged (because of possible view conversions). -- Suppress the tag adjustment when not Tagged_Type_Expansion because - -- tags are represented implicitly in objects. + -- tags are represented implicitly in objects, and when the record is + -- initialized with a raise expression. - if Is_Tagged_Type (Typ) and then Tagged_Type_Expansion then + if Is_Tagged_Type (Typ) + and then Tagged_Type_Expansion + and then Nkind (Exp) /= N_Raise_Expression + and then (Nkind (Exp) /= N_Qualified_Expression + or else Nkind (Expression (Exp)) /= N_Raise_Expression) + then Append_To (Res, Make_Assignment_Statement (Default_Loc, Name => --- gcc/ada/sem_aggr.adb +++ gcc/ada/sem_aggr.adb @@ -3158,6 +3158,9 @@ package body Sem_Aggr is elsif Nkind (Anc) = N_Qualified_Expression then return Valid_Limited_Ancestor (Expression (Anc)); + elsif Nkind (Anc) = N_Raise_Expression then + return True; + else return False; end if; @@ -3199,6 +3202,13 @@ package body Sem_Aggr is then return True; + -- The parent type may be a raise expression (which is legal in + -- any expression context). + + elsif A_Type = Raise_Type then + A_Type := Etype (Imm_Type); + return True; + else Imm_Type := Etype (Base_Type (Imm_Type)); end if; --- gcc/ada/sem_ch3.adb +++ gcc/ada/sem_ch3.adb @@ -2047,10 +2047,23 @@ package body Sem_Ch3 is end if; end if; + -- Avoid reporting spurious errors if the component is initialized with + -- a raise expression (which is legal in any expression context) + + if Present (E) + and then + (Nkind (E) = N_Raise_Expression + or else (Nkind (E) = N_Qualified_Expression + and then Nkind (Expression (E)) = N_Raise_Expression)) + then + null; + -- The parent type may be a private view with unknown discriminants, -- and thus unconstrained. Regular components must be constrained. - if not Is_Definite_Subtype (T) and then Chars (Id) /= Name_uParent then + elsif not Is_Definite_Subtype (T) + and then Chars (Id) /= Name_uParent + then if Is_Class_Wide_Type (T) then Error_Msg_N ("class-wide subtype with unknown discriminants" & --- gcc/ada/sem_ch4.adb +++ gcc/ada/sem_ch4.adb @@ -4001,7 +4001,9 @@ package body Sem_Ch4 is if Is_Class_Wide_Type (T) then if not Is_Overloaded (Expr) then - if Base_Type (Etype (Expr)) /= Base_Type (T) then + if Base_Type (Etype (Expr)) /= Base_Type (T) + and then Etype (Expr) /= Raise_Type + then if Nkind (Expr) = N_Aggregate then Error_Msg_N ("type of aggregate cannot be class-wide", Expr); else --- /dev/null new file mode 100644 +++ gcc/testsuite/gnat.dg/limited4.adb @@ -0,0 +1,58 @@ +-- { dg-do compile } +procedure Limited4 is + TBD_Error : exception; + + type Lim_Rec is limited record + A : Integer; + B : Boolean; + end record; + + type Lim_Tagged is tagged limited record + R : Lim_Rec; + N : Natural; + end record; + + type Lim_Ext is new Lim_Tagged with record + G : Natural; + end record; + + -- a) initialization expression of a CW object_declaration + + Obj1 : Lim_Tagged'Class := (raise TBD_Error); + Obj2 : Lim_Tagged'Class := Lim_Tagged'Class'(raise TBD_Error); + + -- b) initialization expression of a CW component_declaration + + type Rec is record + Comp01 : Lim_Tagged'Class := (raise TBD_Error); + Comp02 : Lim_Tagged'Class := Lim_Tagged'Class'((raise TBD_Error)); + end record; + + -- c) the expression of a record_component_association + + Obj : Lim_Tagged := (R => raise TBD_Error, N => 4); + + -- d) the expression for an ancestor_part of an extension_aggregate + + Ext1 : Lim_Ext := ((raise TBD_Error) with G => 0); + Ext2 : Lim_Ext := (Lim_Tagged'(raise TBD_Error) with G => 0); + + -- e) default_expression or actual parameter for a formal object of + -- mode in + + function Do_Test1 (Obj : Lim_Tagged) return Boolean is + begin + return True; + end; + + function Do_Test2 + (Obj : Lim_Tagged := (raise TBD_Error)) return Boolean is + begin + return True; + end; + + Check : Boolean; +begin + Check := Do_Test1 (raise TBD_Error); + Check := Do_Test2; +end; \ No newline at end of file --YZ5djTAD1cGYuMQK--