===================================================================
@@ -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);
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 <kirtchev@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.