This patch modifies the expansion of attribute 'Read to ensure that relevant
checks are properly installed on the return value obtained by calling the
related Read routine. This is done by means of a type conversion to the
target type.
------------
-- Source --
------------
-- types.ads
with Ada.Streams; use Ada.Streams;
package Types is
type Int is new Integer;
procedure Read_Int
(Stream : not null access Root_Stream_Type'Class;
Item : out Int);
procedure Write_Int
(Stream : not null access Root_Stream_Type'Class;
Item : Int);
for Int'Read use Read_Int;
for Int'Write use Write_Int;
type Small_Int is new Int range -5 .. 5;
type Pipe (Capacity : Stream_Element_Offset) is
new Root_Stream_Type with private;
overriding procedure Read
(Stream : in out Pipe;
Item : out Stream_Element_Array;
Last : out Stream_Element_Offset);
overriding procedure Write
(Stream : in out Pipe;
Item : Stream_Element_Array);
private
type Pipe (Capacity : Stream_Element_Offset) is
new Root_Stream_Type with
record
Buffer : Stream_Element_Array (1 .. Capacity);
Cursor : Stream_Element_Offset;
end record;
end Types;
-- types.adb
package body Types is
overriding procedure Read
(Stream : in out Pipe;
Item : out Stream_Element_Array;
Last : out Stream_Element_Offset)
is
begin
Item := Stream.Buffer (1 .. Stream.Cursor);
Last := Stream.Cursor;
end Read;
procedure Read_Int
(Stream : not null access Root_Stream_Type'Class;
Item : out Int)
is
begin
Integer'Read (Stream, Integer (Item));
end Read_Int;
overriding procedure Write
(Stream : in out Pipe;
Item : Stream_Element_Array)
is
Item_Length : constant Stream_Element_Offset := Item'Length;
begin
if Item_Length > Stream.Capacity then
raise Storage_Error;
end if;
Stream.Buffer (1 .. Item_Length) := Item;
Stream.Cursor := Item_Length;
end Write;
procedure Write_Int
(Stream : not null access Root_Stream_Type'Class;
Item : Int)
is
begin
Integer'Write (Stream, Integer (Item));
end Write_Int;
end Types;
-- main.adb
with Types; use Types;
procedure Main is
Small_Obj : Small_Int;
Stream : aliased Pipe (16);
begin
Int'Write (Stream'Access, 16);
Small_Int'Read (Stream'Access, Small_Obj);
end Main;
----------------------------
-- Compilation and output --
----------------------------
$ gnatmake -q main.adb
$ ./main
raised CONSTRAINT_ERROR : main.adb:9 range check failed
Tested on x86_64-pc-linux-gnu, committed on trunk
2017-01-06 Hristian Kirtchev <kirtc...@adacore.com>
* exp_attr.adb (Rewrite_Stream_Proc_Call): Use
an unchecked type conversion when performing a view conversion
to/from a private type. In all other cases use a regular type
conversion to ensure that any relevant checks are properly
installed.
Index: exp_attr.adb
===================================================================
--- exp_attr.adb (revision 244124)
+++ exp_attr.adb (working copy)
@@ -1568,9 +1568,10 @@
procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id) is
Item : constant Node_Id := Next (First (Exprs));
+ Item_Typ : constant Entity_Id := Etype (Item);
Formal : constant Entity_Id := Next_Formal (First_Formal (Pname));
Formal_Typ : constant Entity_Id := Etype (Formal);
- Is_Written : constant Boolean := (Ekind (Formal) /= E_In_Parameter);
+ Is_Written : constant Boolean := Ekind (Formal) /= E_In_Parameter;
begin
-- The expansion depends on Item, the second actual, which is
@@ -1583,7 +1584,7 @@
if Nkind (Item) = N_Indexed_Component
and then Is_Packed (Base_Type (Etype (Prefix (Item))))
- and then Base_Type (Etype (Item)) /= Base_Type (Formal_Typ)
+ and then Base_Type (Item_Typ) /= Base_Type (Formal_Typ)
and then Is_Written
then
declare
@@ -1595,23 +1596,22 @@
Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
- Object_Definition =>
- New_Occurrence_Of (Formal_Typ, Loc));
+ Object_Definition => New_Occurrence_Of (Formal_Typ, Loc));
Set_Etype (Temp, Formal_Typ);
Assn :=
Make_Assignment_Statement (Loc,
- Name => New_Copy_Tree (Item),
+ Name => New_Copy_Tree (Item),
Expression =>
Unchecked_Convert_To
- (Etype (Item), New_Occurrence_Of (Temp, Loc)));
+ (Item_Typ, New_Occurrence_Of (Temp, Loc)));
Rewrite (Item, New_Occurrence_Of (Temp, Loc));
Insert_Actions (N,
New_List (
Decl,
Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (Pname, Loc),
+ Name => New_Occurrence_Of (Pname, Loc),
Parameter_Associations => Exprs),
Assn));
@@ -1626,18 +1626,26 @@
-- operation is not inherited), we are all set, and can use the
-- argument unchanged.
- -- For all other cases we do an unchecked conversion of the second
- -- parameter to the type of the formal of the procedure we are
- -- calling. This deals with the private type cases, and with going
- -- to the root type as required in elementary type case.
-
if not Is_Class_Wide_Type (Entity (Pref))
and then not Is_Class_Wide_Type (Etype (Item))
- and then Base_Type (Etype (Item)) /= Base_Type (Formal_Typ)
+ and then Base_Type (Item_Typ) /= Base_Type (Formal_Typ)
then
- Rewrite (Item,
- Unchecked_Convert_To (Formal_Typ, Relocate_Node (Item)));
+ -- Perform a view conversion when either the argument or the
+ -- formal parameter are of a private type.
+ if Is_Private_Type (Formal_Typ)
+ or else Is_Private_Type (Item_Typ)
+ then
+ Rewrite (Item,
+ Unchecked_Convert_To (Formal_Typ, Relocate_Node (Item)));
+
+ -- Otherwise perform a regular type conversion to ensure that all
+ -- relevant checks are installed.
+
+ else
+ Rewrite (Item, Convert_To (Formal_Typ, Relocate_Node (Item)));
+ end if;
+
-- For untagged derived types set Assignment_OK, to prevent
-- copies from being created when the unchecked conversion
-- is expanded (which would happen in Remove_Side_Effects
@@ -1665,7 +1673,7 @@
Rewrite (N,
Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (Pname, Loc),
+ Name => New_Occurrence_Of (Pname, Loc),
Parameter_Associations => Exprs));
Analyze (N);
