Ada 2012 AI05-0192 is a binding interpretation that makes it clear that when
reading a discriminated value using the Input stream attribute, discriminants
values read from the stream must match any constraint imposed by the subtype
given as the attribute's prefix. These checks are now done by checking each
read discriminant value against the corresponding constrained value of the
subtype immediately after the value is read.
The following test must compile and execute quietly when compiled with -gnat05:
with Ada.Streams; use Ada.Streams;
procedure AI05_0192_Test is
package My_Streams is
type My_Stream_Type is new Root_Stream_Type with record
Buffer : Stream_Element_Array (1 .. 100);
Buffer_Index : Stream_Element_Offset := 1;
end record;
procedure Read
(Stream : in out My_Stream_Type;
Item : out Stream_Element_Array;
Last : out Stream_Element_Offset);
procedure Write
(Stream : in out My_Stream_Type;
Item : in Stream_Element_Array);
end My_Streams;
package body My_Streams is
procedure Read
(Stream : in out My_Stream_Type;
Item : out Stream_Element_Array;
Last : out Stream_Element_Offset)
is
Index : Stream_Element_Offset := Item'First;
begin
while Index <= Item'Last loop
Item (Index) := Stream.Buffer (Stream.Buffer_Index);
Stream.Buffer_Index := Stream.Buffer_Index + 1;
Index := Index + 1;
end loop;
Last := Index - 1;
end Read;
procedure Write
(Stream : in out My_Stream_Type;
Item : in Stream_Element_Array)
is
begin
Stream.Buffer
(Stream.Buffer_Index .. Stream.Buffer_Index + Item'Length - 1)
:= Item;
Stream.Buffer_Index := Stream.Buffer_Index + Item'Length;
end Write;
end My_Streams;
Stream : aliased My_Streams.My_Stream_Type;
type T1 (D : Natural) is null record;
type T2_123 is new T1 (123);
type T2_456 is new T1 (456);
T1_Obj : T1 := (D => 456);
type T3_Dbl_Discr (D1, D2 : Natural) is null record;
type T4_DD is new T3_Dbl_Discr (D1 => 123, D2 => 456);
type T5_DD is new T3_Dbl_Discr (D1 => 123, D2 => 789);
T3_DD_Obj : T3_Dbl_Discr := (D1 => 123, D2 => 789);
begin
T1'Output (Stream'Access, T1_Obj);
begin
Stream.Buffer_Index := 1;
declare
T1_Obj : T1 := T1'Input (Stream'Access); -- OK: no exception
begin
null;
end;
exception
when others => raise Program_Error;
end;
begin
Stream.Buffer_Index := 1;
declare
T1_Obj : T1 := T1 (T2_123'Input (Stream'Access)); -- Constraint_Error
begin
null;
raise Program_Error;
end;
exception
when Constraint_Error =>
null;
when others =>
raise Program_Error;
end;
begin
Stream.Buffer_Index := 1;
declare
T1_Obj : T1 := T1 (T2_456'Input (Stream'Access)); -- OK: no exception
begin
null;
end;
exception
when others =>
raise Program_Error;
end;
Stream.Buffer_Index := 1;
T3_Dbl_Discr'Output (Stream'Access, T3_DD_Obj);
begin
Stream.Buffer_Index := 1;
declare
T3_Obj : T3_Dbl_Discr := T3_Dbl_Discr (T4_DD'Input (Stream'Access));
-- Constraint_Error
begin
raise Program_Error;
end;
exception
when Constraint_Error =>
null;
when others =>
raise Program_Error;
end;
begin
Stream.Buffer_Index := 1;
declare
T3_Obj : T3_Dbl_Discr := T3_Dbl_Discr (T5_DD'Input (Stream'Access));
-- OK: no exception
begin
null;
end;
exception
when others =>
raise Program_Error;
end;
end AI05_0192_Test;
Tested on x86_64-pc-linux-gnu, committed on trunk
2011-09-02 Gary Dismukes <dismu...@adacore.com>
* exp_attr.adb (Expand_N_Attribute_Reference): Pass the
underlying subtype rather than its base type on the call to
Build_Record_Or_Elementary_Input_Function, so that any
constraints on a discriminated subtype will be available for
doing the check required by AI05-0192.
* exp_strm.adb (Build_Record_Or_Elementary_Input_Function):
If the prefix subtype of the 'Input attribute is a constrained
discriminated subtype, then check each constrained discriminant value
against the corresponding value read from the stream.
Index: exp_attr.adb
===================================================================
--- exp_attr.adb (revision 178399)
+++ exp_attr.adb (working copy)
@@ -2531,8 +2531,12 @@
return;
end if;
+ -- Build the type's Input function, passing the subtype rather
+ -- than its base type, because checks are needed in the case of
+ -- constrained discriminants (see Ada 2012 AI05-0192).
+
Build_Record_Or_Elementary_Input_Function
- (Loc, Base_Type (U_Type), Decl, Fname);
+ (Loc, U_Type, Decl, Fname);
Insert_Action (N, Decl);
if Nkind (Parent (N)) = N_Object_Declaration
Index: exp_strm.adb
===================================================================
--- exp_strm.adb (revision 178398)
+++ exp_strm.adb (working copy)
@@ -25,6 +25,7 @@
with Atree; use Atree;
with Einfo; use Einfo;
+with Elists; use Elists;
with Exp_Util; use Exp_Util;
with Namet; use Namet;
with Nlists; use Nlists;
@@ -1106,14 +1107,16 @@
Decl : out Node_Id;
Fnam : out Entity_Id)
is
- Cn : Name_Id;
- Constr : List_Id;
- Decls : List_Id;
- Discr : Entity_Id;
- J : Pos;
- Obj_Decl : Node_Id;
- Odef : Node_Id;
- Stms : List_Id;
+ B_Typ : constant Entity_Id := Base_Type (Typ);
+ Cn : Name_Id;
+ Constr : List_Id;
+ Decls : List_Id;
+ Discr : Entity_Id;
+ Discr_Elmt : Elmt_Id := No_Elmt;
+ J : Pos;
+ Obj_Decl : Node_Id;
+ Odef : Node_Id;
+ Stms : List_Id;
begin
Decls := New_List;
@@ -1121,9 +1124,16 @@
J := 1;
- if Has_Discriminants (Typ) then
- Discr := First_Discriminant (Typ);
+ if Has_Discriminants (B_Typ) then
+ Discr := First_Discriminant (B_Typ);
+ -- If the prefix subtype is constrained, then retrieve the first
+ -- element of its constraint.
+
+ if Is_Constrained (Typ) then
+ Discr_Elmt := First_Elmt (Discriminant_Constraint (Typ));
+ end if;
+
while Present (Discr) loop
Cn := New_External_Name ('C', J);
@@ -1153,13 +1163,30 @@
Append_To (Constr, Make_Identifier (Loc, Cn));
+ -- If the prefix subtype imposes a discriminant constraint, then
+ -- check that each discriminant value equals the value read.
+
+ if Present (Discr_Elmt) then
+ Append_To (Decls,
+ Make_Raise_Constraint_Error (Loc,
+ Condition => Make_Op_Ne (Loc,
+ Left_Opnd =>
+ New_Reference_To
+ (Defining_Identifier (Decl), Loc),
+ Right_Opnd =>
+ New_Copy_Tree (Node (Discr_Elmt))),
+ Reason => CE_Discriminant_Check_Failed));
+
+ Next_Elmt (Discr_Elmt);
+ end if;
+
Next_Discriminant (Discr);
J := J + 1;
end loop;
Odef :=
Make_Subtype_Indication (Loc,
- Subtype_Mark => New_Occurrence_Of (Typ, Loc),
+ Subtype_Mark => New_Occurrence_Of (B_Typ, Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => Constr));
@@ -1167,7 +1194,7 @@
-- If no discriminants, then just use the type with no constraint
else
- Odef := New_Occurrence_Of (Typ, Loc);
+ Odef := New_Occurrence_Of (B_Typ, Loc);
end if;
-- Create an extended return statement encapsulating the result object
@@ -1184,7 +1211,7 @@
-- The object is about to get its value from Read, and if the type is
-- null excluding we do not want spurious warnings on an initial null.
- if Is_Access_Type (Typ) then
+ if Is_Access_Type (B_Typ) then
Set_No_Initialization (Obj_Decl);
end if;
@@ -1195,15 +1222,15 @@
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Typ, Loc),
+ Prefix => New_Occurrence_Of (B_Typ, Loc),
Attribute_Name => Name_Read,
Expressions => New_List (
Make_Identifier (Loc, Name_S),
Make_Identifier (Loc, Name_V)))))));
- Fnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Input);
+ Fnam := Make_Stream_Subprogram_Name (Loc, B_Typ, TSS_Stream_Input);
- Build_Stream_Function (Loc, Typ, Decl, Fnam, Decls, Stms);
+ Build_Stream_Function (Loc, B_Typ, Decl, Fnam, Decls, Stms);
end Build_Record_Or_Elementary_Input_Function;
-------------------------------------------------
