From patchwork Tue Apr 25 13:05:27 2017 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 754815 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 3wC3P52TzNz9s8Y for ; Tue, 25 Apr 2017 23:06:01 +1000 (AEST) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="cCnIVtPm"; 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=qpXp6MB6PFdGiuOw2qn7CIQ9HFOeG5Tr032BOpBt/0zUQPKPlf /CBpVQo3Jok+8zEHD+Pl/RvdNJLOKJIjWrCznlPpIRvc4mPZiZwUVt2cQjrCcSW8 VAIXEr6JEUcaQc+B6wHh0fwOZGNv6av1xPGLXucG4zDu0n51yY2q3kAmE= 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=NxcgQB5xPNsqSiSW+LnJ+Jhwwq8=; b=cCnIVtPm9ibqMPjRrXeI jLkC/zg+/85bY2Y+ECW46xTx3jIWev7mN30Z6c/1L2bSyAOvwoGcSpTZVJRHfHnG 6zrLLknee8t80VMPK45yYk5Mf96MxzhlermdEJMXKORFMooq0fNLeM2jKbXackbC RXvkCpJhZtFnjn4GAsVaWXI= Received: (qmail 94560 invoked by alias); 25 Apr 2017 13:05:32 -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 94484 invoked by uid 89); 25 Apr 2017 13:05:31 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-15.4 required=5.0 tests=AWL, BAYES_00, GIT_PATCH_1, GIT_PATCH_2, GIT_PATCH_3, RCVD_IN_DNSWL_NONE, SPF_PASS, T_FILL_THIS_FORM_SHORT autolearn=ham version=3.3.2 spammy=Abstract, keys 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, 25 Apr 2017 13:05:27 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 9891729DD4; Tue, 25 Apr 2017 09:05:27 -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 VrSc2JIpAnFF; Tue, 25 Apr 2017 09:05:27 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [205.232.38.10]) by rock.gnat.com (Postfix) with ESMTP id 86B1056358; Tue, 25 Apr 2017 09:05:27 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4192) id 8591B3F0; Tue, 25 Apr 2017 09:05:27 -0400 (EDT) Date: Tue, 25 Apr 2017 09:05:27 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Ed Schonberg Subject: [Ada] Compiler abort on components that are unchecked unions. Message-ID: <20170425130527.GA69430@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) This patch fixes two errors in the handling of unchecked unions used as record components, in cases where such a use a potentially erroneous. The following must ocmpile quietly: gcc -c objects-base.adb --- package body Objects.Base is procedure setClass (self: in out SObject'Class; class : PtrClass) is begin self.class := class; end setClass; function getClass(self: in out SObject'Class) return PtrClass is begin return self.class; end getClass; function getSize(self: in out SObject'Class) return Integer is begin return getSize(self.size); end getSize; function isBinary (self: in out SObject'Class) return Boolean is begin return isBinary(self.size); end isBinary; function isRelocated (self: in out SObject'Class) return Boolean is begin return isRelocated(self.size); end isRelocated; procedure setField (self: in out SObject'Class; index: Positive; obj : PtrObject) is begin if index > self.fields'Last then null; else self.fields(index) := obj; end if; end setField; function getField (self: in out SObject'Class; index: Positive) return PtrObject is begin if index > self.fields'Last then raise Program_Error with "SObject:getField: field index is too high"; return self.fields(self.fields'Last); else return self.fields(index); end if; end getField; function getName (self: in out SDataObject) return String is begin raise Program_Error with "Abstract class SDataObject:getName"; return getName (self); end getName; function getName (self: in out SCharObject) return String is begin return "Char"; end getName; function getName (self: in out SFloatObject) return String is begin return "Float"; end getName; function getName (self: in out SLongIntObject) return String is begin return "LongInt"; end getName; function getName (self: in out SRawObject) return String is begin return "RawData"; end getName; function getName (self: in out SSymbolObject) return String is begin return "Symbol"; end getName; function getName (self: in out SMethod) return String is begin return "Method"; end getName; function getName (self: in out SContext) return String is begin return "Contex"; end getName; function getName (self: in out SBlock) return String is begin return "Block"; end getName; function getName (self: in out SDictionary) return String is begin return "Dict"; end getName; function getName (self: in out SClass) return String is begin return "Class"; end getName; function getName (self: in out SNode) return String is begin return "Node"; end getName; function getName (self: in out SProcess) return String is begin return "Process"; end getName; procedure setByte (self: in out SRawObject; index: Positive; value : Unsigned_8) is begin if index > self.data'Last then raise Program_Error with "SRawObject:setByte: index is too high"; else self.data(index) := value; end if; end setByte; function getByte (self: in out SRawObject; index: Positive) return Unsigned_8 is begin if index > self.data'Last then raise Program_Error with "SRawObject:getByte: index is too high"; else return self.data(index); end if; end getByte; function getAccessToBytes (self: in out SRawObject) return pArrayOfByte is begin return self.data; end getAccessToBytes; end Objects.Base; --- with Objects.Stack; use Objects.Stack; package Objects.Base is type SObject; type SClass; subtype PtrClass is PMClass; type SObject is new SMObject with record fields : pArrayOfObject; end record ; -- for SObject'Alignment use 8; --- SObject methods procedure setClass(self: in out SObject'Class; class : PtrClass); function getClass(self: in out SObject'Class) return PtrClass; function getSize(self: in out SObject'Class) return Integer; function isBinary(self: in out SObject'Class) return Boolean; function isRelocated(self: in out SObject'Class) return Boolean; procedure setField(self: in out SObject'Class; index: Positive; obj : PtrObject); function getField(self: in out SObject'Class; index: Positive) return PtrObject; type SDataObject is new SMObject with null record; function getName(self: in out SDataObject) return String; type PtrSDataObject is access all SDataObject'Class; type SCharObject is new SDataObject with record char : Wide_Character; end record; function getName(self: in out SCharObject) return String; type SFloatObject is new SDataObject with record value : Float; end record; function getName(self: in out SFloatObject) return String; type SLongIntObject is new SDataObject with record value : Long_Integer; end record; function getName(self: in out SLongIntObject) return String; type SRawObject is new SDataObject with record data : pArrayOfByte; end record; function getName(self: in out SRawObject) return String; type SSymbolObject(len : Integer) is new SDataObject with record symbol : String(1 .. len); end record; function getName(self: in out SSymbolObject) return String; type PtrSSymbolObject is access SSymbolObject; -- function getName(self: in out SChar) return String; type SMethod is new SMObject with record stackSize : Positive; temporarySize : Natural; name : PtrSSymbolObject; bytecodes : pArrayOfByte; literals : pArrayOfObject; --text : PtrSStringObject; mPackage : PtrObject(True); end record; function getName(self: in out SMethod) return String; type PtrSMethod is access SMethod'Class; type SContext; type PtrSContext is access SContext; type SContext is new SMObject with record bytePointer : Natural; arguments : pArrayOfObject; temporaries : pArrayOfObject; stack : pArrayOfObject; --FIXME: may be use native Stack? method : PtrSMethod; previousContext : PtrSContext; end record; function getName(self: in out SContext) return String; type SBlock is new SContext with record argumentLocation : Natural; blockBytePointer : Natural; creatingContext : PtrSContext; end record; function getName(self: in out SBlock) return String; type SDictionary is new SObject with record keys : pArrayOfObject; -- elements must be SSymbolObject values : pArrayOfObject; end record; function getName(self: in out SDictionary) return String; type PtrSDictionary is access SDictionary; type SClass is new SMClass with record instanceSize : Positive; variables : pArrayOfObject; -- elements must be SSymbolObject name : PtrSSymbolObject; parentClass : PtrClass; methods : PtrSDictionary; cPackage : PtrObject(True); end record; function getName(self: in out SClass) return String; type SNode; type PtrNode is access SNode'Class; type SNode(desc : Boolean) is new SObject with record value : PtrObject(desc); left : PtrNode; right : PtrNode; end record; function getName(self: in out SNode) return String; type SProcess is new SObject with record context : PtrSContext; state : PtrObject(True); result : PtrObject(True); end record; function getName(self: in out SProcess) return String; procedure setByte(self: in out SRawObject; index: Positive; value : Unsigned_8); function getByte(self: in out SRawObject; index: Positive) return Unsigned_8; function getAccessToBytes(self: in out SRawObject) return pArrayOfByte; end Objects.Base; --- with Interfaces; use Interfaces; with Ada.Unchecked_Conversion; package Objects.Stack is type SStack is private; type PtrStack is access SStack; procedure Push (self : in out SStack; e : in PMObject); procedure CopyAndPush (self : in out SStack; e : in PMObject); procedure Pop (self : in out SStack; e : out PMObject); procedure Top (self : in out SStack; e : out PMObject); procedure Empty (self : in out SStack; dispose : Boolean); function isFull (self : in out SStack) return Boolean; function isEmpty (self : in out SStack) return Boolean; private type ArrayOfSObject is array (Positive range <>) of PMObject; type SStack is record size : Positive; top : Natural; elem : ArrayOfSObject(1 .. 128); end record; end Objects.Stack; --- with Interfaces; use Interfaces; with Ada.Unchecked_Conversion; package Objects is type RSize is new Integer range 0 .. 2**30 - 1; type SSize is record data : RSize; binary : Boolean; relocated : Boolean; end record; for SSize use record data at 0 range 2 .. 31; binary at 0 range 1 .. 1; relocated at 0 range 0 .. 0; end record; for SSize'Size use 32; type RInteger is new Integer range 0 .. 2**31 - 1; type SInteger is record value : RInteger; isInteger : Boolean; end record; for SInteger use record value at 0 range 1 .. 31; isInteger at 0 range 0 .. 0; end record; for SInteger'Size use 32; type SMClass; type PMClass is access all SMClass'Class; type SMObject is abstract tagged record size : SSize; class : PMClass; end record; type SMClass is new SMObject with null record; type PMObject is access all SMObject'Class; type PtrObjectDescriptor is (P_SMI, P_PTR); type PtrObject(ptr : Boolean) is record case ptr is when True => obj : PMObject; when False => smi : SInteger; end case; end record; pragma Unchecked_Union(PtrObject); type tArrayOfObject is array (Positive range <>) of PtrObject(True) ; type pArrayOfObject is access tArrayOfObject; type tArrayOfByte is array (Positive range <>) of Unsigned_8; type pArrayOfByte is access tArrayOfByte; --- SSize methods procedure setSize(self: in out SSize; value: in Integer); -- set new size of object.Dangerous! Only at initialisation function getSize(self: in out SSize) return Integer; procedure setBinary(self: in out SSize); function isBinary(self: in out SSize) return Boolean; procedure setRelocated(self: in out SSize); function isRelocated(self: in out SSize) return Boolean; --- SInteger methods function getInteger is new Ada.Unchecked_Conversion ( Unsigned_32, Integer ) ; function getUnsigned32 is new Ada.Unchecked_Conversion ( Integer, Unsigned_32 ) ; procedure setIntegerValue(self: in out PtrObject; value : Integer); -- NB: this procedure must generate Exception if value is too big -- NB: an using this function can become to a hangling pointers! function getIntegerValue(self: in out PtrObject) return Integer; function isSmallInteger(self: in out PtrObject) return Boolean; end Objects; Tested on x86_64-pc-linux-gnu, committed on trunk 2017-04-25 Ed Schonberg * exp_attr.adb (Expand_Attribute_Reference, case 'Read): If the type is an unchecked_union, replace the attribute with a Raise_Program_Error (rather than inserting such before the attribute reference) to handle properly the case where we are processing a component of a larger record, and we need to prevent further expansion for the unchecked union. (Expand_Attribute_Reference, case 'Write): If the type is an unchecked_union, check whether enclosing scope is a Write subprogram. Replace attribute with a Raise_Program_Error if the discriminants of the unchecked_union type have not default values because such a use is erroneous.. Index: exp_attr.adb =================================================================== --- exp_attr.adb (revision 247202) +++ exp_attr.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -5515,12 +5515,17 @@ -- Ada 2005 (AI-216): Program_Error is raised when executing -- the default implementation of the Read attribute of an - -- Unchecked_Union type. + -- Unchecked_Union type. We replace the attribute with a + -- raise statement (rather than inserting it before) to handle + -- properly the case of an unchecked union that is a record + -- component. if Is_Unchecked_Union (Base_Type (U_Type)) then - Insert_Action (N, + Rewrite (N, Make_Raise_Program_Error (Loc, Reason => PE_Unchecked_Union_Restriction)); + Set_Etype (N, B_Type); + return; end if; if Has_Discriminants (U_Type) @@ -7215,14 +7220,21 @@ -- Unchecked_Union type. However, if the 'Write reference is -- within the generated Output stream procedure, Write outputs -- the components, and the default values of the discriminant - -- are streamed by the Output procedure itself. + -- are streamed by the Output procedure itself. If there are + -- no default values this is also erroneous. - if Is_Unchecked_Union (Base_Type (U_Type)) - and not Is_TSS (Current_Scope, TSS_Stream_Output) - then - Insert_Action (N, - Make_Raise_Program_Error (Loc, - Reason => PE_Unchecked_Union_Restriction)); + if Is_Unchecked_Union (Base_Type (U_Type)) then + if (not Is_TSS (Current_Scope, TSS_Stream_Output) + and not Is_TSS (Current_Scope, TSS_Stream_Write)) + or else No (Discriminant_Default_Value + (First_Discriminant (U_Type))) + then + Rewrite (N, + Make_Raise_Program_Error (Loc, + Reason => PE_Unchecked_Union_Restriction)); + Set_Etype (N, U_Type); + return; + end if; end if; if Has_Discriminants (U_Type)