Patchwork [Ada] Perform required checks on discriminants read from streams using 'Input

login
register
mail settings
Submitter Arnaud Charlet
Date Sept. 2, 2011, 9:32 a.m.
Message ID <20110902093218.GA24187@adacore.com>
Download mbox | patch
Permalink /patch/113068/
State New
Headers show

Comments

Arnaud Charlet - Sept. 2, 2011, 9:32 a.m.
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  <dismukes@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.

Patch

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;
 
    -------------------------------------------------