diff mbox

[Ada] Compiler abort on components that are unchecked unions.

Message ID 20170425130527.GA69430@adacore.com
State New
Headers show

Commit Message

Arnaud Charlet April 25, 2017, 1:05 p.m. UTC 
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  <schonberg@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..
diff mbox

Patch

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)