From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: (qmail 7337 invoked by alias); 20 Oct 2014 14:32:37 -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 7291 invoked by uid 89); 20 Oct 2014 14:32:37 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-1.7 required=5.0 tests=AWL,BAYES_00 autolearn=ham version=3.3.2 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 (AES256-SHA encrypted) ESMTPS; Mon, 20 Oct 2014 14:32:31 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 5BDD411621F; Mon, 20 Oct 2014 10:32:29 -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 NMaOKzVds9tL; Mon, 20 Oct 2014 10:32:29 -0400 (EDT) Received: from kwai.gnat.com (kwai.gnat.com [205.232.38.4]) by rock.gnat.com (Postfix) with ESMTP id 4BB1D116198; Mon, 20 Oct 2014 10:32:29 -0400 (EDT) Received: by kwai.gnat.com (Postfix, from userid 4192) id 4740A91A7D; Mon, 20 Oct 2014 10:32:29 -0400 (EDT) Date: Mon, 20 Oct 2014 14:33:00 -0000 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Ed Schonberg Subject: [Ada] Crash on unconstrained unchecked union declaration Message-ID: <20141020143229.GA15103@adacore.com> MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="NzB8fVQJ5HfG6fxh" Content-Disposition: inline User-Agent: Mutt/1.5.21 (2010-09-15) X-SW-Source: 2014-10/txt/msg01930.txt.bz2 --NzB8fVQJ5HfG6fxh Content-Type: text/plain; charset=us-ascii Content-Disposition: inline Content-length: 1822 When an object declaration as an indefinite type, the actual subtype of the object is constructed from the expression itself. If the type is an unchecked union such a subtype cannot be constructed because discriminants cannot be retrieved from the expression. In this case, rewrite declaration as a renaming declaration, where the back-end does not require a definite subtype. Compiling and executing foo.adb must yield:: TRUE FALSE TRUE 'A' 11 100 --- with Text_IO; use Text_IO; procedure Foo is type Rec_Type (I : Integer ) is record B : Boolean; case I is when 0 => null; when 1 .. 10 => C : Character; when others => N : Natural; end case; end record; pragma Unchecked_Union (Rec_Type); function Get (I : Integer) return Rec_Type is begin case I is when 0 => return (I => 0, B => True); when 1 .. 10 => return (I => 1, B => False, C => 'A'); when others => return (I => 11, B => True, N => abs I); end case; end Get; procedure Nop (R : Rec_Type) is begin Put_Line (Boolean'Image (R.B)); end Nop; R0 : constant Rec_Type := Get (0); R1 : constant Rec_Type := Get (1); R11 : constant Rec_Type := Get (11); R100 : Rec_Type := Get (100); begin Nop (R0); Nop (R1); Nop (R11); Put_Line (Character'Image (R1.C)); Put_Line (Integer'Image (R11.N)); Put_Line (Integer'Image (R100.N)); end Foo; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-10-20 Ed Schonberg * sem_ch3.adb (Analyze_Object_Declaration): If the type is an unconstrained unchecked_union type, rewrite declaration as a renaming to prevent attempt to retrieve non- existent discriminants from expression. --NzB8fVQJ5HfG6fxh Content-Type: text/plain; charset=us-ascii Content-Disposition: attachment; filename=difs Content-length: 1466 Index: sem_ch3.adb =================================================================== --- sem_ch3.adb (revision 216476) +++ sem_ch3.adb (working copy) @@ -3839,6 +3839,32 @@ elsif GNATprove_Mode then null; + -- If the type is an unchecked union, no subtype can be built from + -- the expression. Rewrite declaration as a renaming, which the + -- back-end can handle properly. This is a rather unusual case, + -- because most unchecked_union declarations have default values + -- for discriminants and are thus unconstrained. + + elsif Is_Unchecked_Union (T) then + if Constant_Present (N) + or else Nkind (E) = N_Function_Call + then + Set_Ekind (Id, E_Constant); + else + Set_Ekind (Id, E_Variable); + end if; + + Rewrite (N, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Id, + Subtype_Mark => New_Occurrence_Of (T, Loc), + Name => E)); + + Set_Renamed_Object (Id, E); + Freeze_Before (N, T); + Set_Is_Frozen (Id); + return; + else Expand_Subtype_From_Expr (N, T, Object_Definition (N), E); Act_T := Find_Type_Of_Object (Object_Definition (N), N); --NzB8fVQJ5HfG6fxh--