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 <schonb...@adacore.com>
* 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)
