gcc/testsuite/ada/acats/tests/cd/cdd2a02.a

   1 -- CDD2A02.A
   2 --
   3 --                             Grant of Unlimited Rights
   4 --
   5 --     The Ada Conformity Assessment Authority (ACAA) holds unlimited
   6 --     rights in the software and documentation contained herein. Unlimited
   7 --     rights are the same as those granted by the U.S. Government for older
   8 --     parts of the Ada Conformity Assessment Test Suite, and are defined
   9 --     in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
  10 --     intends to confer upon all recipients unlimited rights equal to those
  11 --     held by the ACAA. These rights include rights to use, duplicate,
  12 --     release or disclose the released technical data and computer software
  13 --     in whole or in part, in any manner and for any purpose whatsoever, and
  14 --     to have or permit others to do so.
  15 --
  16 --                                    DISCLAIMER
  17 --
  18 --     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
  19 --     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
  20 --     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
  21 --     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
  22 --     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
  23 --     PARTICULAR PURPOSE OF SAID MATERIAL.
  24 --*
  25 --
  26 -- OBJECTIVE:
  27 --    Check that the Read, Write, Input, and Output attributes are inherited
  28 --    for untagged derived types.  (Defect Report 8652/0040,
  29 --     as reflected in Technical Corrigendum 1, 13.13.2(8.1/1) and
  30 --     13.13.2(25/1)).
  31 --
  32 -- CHANGE HISTORY:
  33 --    30 JUL 2001   PHL   Initial version.
  34 --     5 DEC 2001   RLB   Reformatted for ACATS.
  35 --
  36 --!
  37 with Ada.Streams;
  38 use Ada.Streams;
  39 with FDD2A00;
  40 use FDD2A00;
  41 with Report;
  42 use Report;
  43 procedure CDD2A02 is
  44
  45     type Int is range 1 .. 10;
  46     type Str is array (Int range <>) of Character;
  47
  48     procedure Read (Stream : access Root_Stream_Type'Class;
  49                     Item : out Int'Base);
  50     procedure Write (Stream : access Root_Stream_Type'Class; Item : Int'Base);
  51     function Input (Stream : access Root_Stream_Type'Class) return Int'Base;
  52     procedure Output (Stream : access Root_Stream_Type'Class; Item : Int'Base);
  53
  54     for Int'Read use Read;
  55     for Int'Write use Write;
  56     for Int'Input use Input;
  57     for Int'Output use Output;
  58
  59
  60     type Parent (D1, D2 : Int; B : Boolean) is
  61         record
  62             S : Str (D1 .. D2);
  63             case B is
  64                 when False =>
  65                     C1 : Integer;
  66                 when True =>
  67                     C2 : Float;
  68             end case;
  69         end record;
  70
  71     procedure Read (Stream : access Root_Stream_Type'Class; Item : out Parent);
  72     procedure Write (Stream : access Root_Stream_Type'Class; Item : Parent);
  73     function Input (Stream : access Root_Stream_Type'Class) return Parent;
  74     procedure Output (Stream : access Root_Stream_Type'Class; Item : Parent);
  75
  76     for Parent'Read use Read;
  77     for Parent'Write use Write;
  78     for Parent'Input use Input;
  79     for Parent'Output use Output;
  80
  81
  82     procedure Actual_Read
  83                  (Stream : access Root_Stream_Type'Class; Item : out Int) is
  84     begin
  85         Integer'Read (Stream, Integer (Item));
  86     end Actual_Read;
  87
  88     procedure Actual_Write
  89                  (Stream : access Root_Stream_Type'Class; Item : Int) is
  90     begin
  91         Integer'Write (Stream, Integer (Item));
  92     end Actual_Write;
  93
  94     function Actual_Input (Stream : access Root_Stream_Type'Class) return Int is
  95     begin
  96         return Int (Integer'Input (Stream));
  97     end Actual_Input;
  98
  99     procedure Actual_Output
 100                  (Stream : access Root_Stream_Type'Class; Item : Int) is
 101     begin
 102         Integer'Output (Stream, Integer (Item));
 103     end Actual_Output;
 104
 105
 106     procedure Actual_Read
 107                  (Stream : access Root_Stream_Type'Class; Item : out Parent) is
 108     begin
 109         case Item.B is
 110             when False =>
 111                 Item.C1 := 7;
 112             when True =>
 113                 Float'Read (Stream, Item.C2);
 114         end case;
 115         Str'Read (Stream, Item.S);
 116     end Actual_Read;
 117
 118     procedure Actual_Write
 119                  (Stream : access Root_Stream_Type'Class; Item : Parent) is
 120     begin
 121         case Item.B is
 122             when False =>
 123                 null; -- Don't write C1
 124             when True =>
 125                 Float'Write (Stream, Item.C2);
 126         end case;
 127         Str'Write (Stream, Item.S);
 128     end Actual_Write;
 129
 130     function Actual_Input
 131                 (Stream : access Root_Stream_Type'Class) return Parent is
 132         D1, D2 : Int;
 133         B : Boolean;
 134     begin
 135         Int'Read (Stream, D2);
 136         Boolean'Read (Stream, B);
 137         Int'Read (Stream, D1);
 138
 139         declare
 140             Item : Parent (D1 => D1, D2 => D2, B => B);
 141         begin
 142             Parent'Read (Stream, Item);
 143             return Item;
 144         end;
 145
 146     end Actual_Input;
 147
 148     procedure Actual_Output
 149                  (Stream : access Root_Stream_Type'Class; Item : Parent) is
 150     begin
 151         Int'Write (Stream, Item.D2);
 152         Boolean'Write (Stream, Item.B);
 153         Int'Write (Stream, Item.D1);
 154         Parent'Write (Stream, Item);
 155     end Actual_Output;
 156
 157     package Int_Ops is new Counting_Stream_Ops (T => Int'Base,
 158                                                 Actual_Write => Actual_Write,
 159                                                 Actual_Input => Actual_Input,
 160                                                 Actual_Read => Actual_Read,
 161                                                 Actual_Output => Actual_Output);
 162
 163     package Parent_Ops is
 164        new Counting_Stream_Ops (T => Parent,
 165                                 Actual_Write => Actual_Write,
 166                                 Actual_Input => Actual_Input,
 167                                 Actual_Read => Actual_Read,
 168                                 Actual_Output => Actual_Output);
 169
 170     procedure Read (Stream : access Root_Stream_Type'Class; Item : out Int'Base)
 171        renames Int_Ops.Read;
 172     procedure Write (Stream : access Root_Stream_Type'Class; Item : Int'Base)
 173        renames Int_Ops.Write;
 174     function Input (Stream : access Root_Stream_Type'Class) return Int'Base
 175        renames Int_Ops.Input;
 176     procedure Output (Stream : access Root_Stream_Type'Class; Item : Int'Base)
 177        renames Int_Ops.Output;
 178
 179     procedure Read (Stream : access Root_Stream_Type'Class; Item : out Parent)
 180        renames Parent_Ops.Read;
 181     procedure Write (Stream : access Root_Stream_Type'Class; Item : Parent)
 182        renames Parent_Ops.Write;
 183     function Input (Stream : access Root_Stream_Type'Class) return Parent
 184        renames Parent_Ops.Input;
 185     procedure Output (Stream : access Root_Stream_Type'Class; Item : Parent)
 186        renames Parent_Ops.Output;
 187
 188 begin
 189     Test ("CDD2A02", "Check that the Read, Write, Input, and Output " &
 190                      "attributes are inherited for untagged derived types");
 191
 192     Test1:
 193         declare
 194             type Derived1 is new Parent;
 195             S : aliased My_Stream (1000);
 196             X1 : Derived1 (D1 => Int (Ident_Int (2)),
 197                            D2 => Int (Ident_Int (5)), B => Ident_Bool (True));
 198             Y1 : Derived1 := (D1 => 3,
 199                               D2 => 6,
 200                               B => False,
 201                               S => Str (Ident_Str ("3456")),
 202                               C1 => Ident_Int (100));
 203             X2 : Derived1 (D1 => Int (Ident_Int (2)),
 204                            D2 => Int (Ident_Int (5)), B => Ident_Bool (True));
 205         begin
 206             X1.S := Str (Ident_Str ("bcde"));
 207             X1.C2 := Float (Ident_Int (4));
 208
 209             Derived1'Write (S'Access, X1);
 210             if Int_Ops.Get_Counts /=
 211                (Read => 0, Write => 0, Input => 0, Output => 0) then
 212                 Failed ("Error writing discriminants - 1");
 213             end if;
 214             if Parent_Ops.Get_Counts /=
 215                (Read => 0, Write => 1, Input => 0, Output => 0) then
 216                 Failed ("Didn't call inherited Write - 1");
 217             end if;
 218
 219             Derived1'Read (S'Access, X2);
 220             if Int_Ops.Get_Counts /=
 221                (Read => 0, Write => 0, Input => 0, Output => 0) then
 222                 Failed ("Error reading discriminants - 1");
 223             end if;
 224             if Parent_Ops.Get_Counts /=
 225                (Read => 1, Write => 1, Input => 0, Output => 0) then
 226                 Failed ("Didn't call inherited Read - 1");
 227             end if;
 228
 229             if X2 /= (D1 => 2,
 230                       D2 => 5,
 231                       B => True,
 232                       S => Str (Ident_Str ("bcde")),
 233                       C2 => Float (Ident_Int (4))) then
 234                 Failed
 235                    ("Inherited Read and Write are not inverses of each other - 1");
 236             end if;
 237
 238             Derived1'Output (S'Access, Y1);
 239             if Int_Ops.Get_Counts /=
 240                (Read => 0, Write => 2, Input => 0, Output => 0) then
 241                 Failed ("Error writing discriminants - 2");
 242             end if;
 243             if Parent_Ops.Get_Counts /=
 244                (Read => 1, Write => 2, Input => 0, Output => 1) then
 245                 Failed ("Didn't call inherited Output - 2");
 246             end if;
 247
 248             declare
 249                 Y2 : Derived1 := Derived1'Input (S'Access);
 250             begin
 251                 if Int_Ops.Get_Counts /=
 252                    (Read => 2, Write => 2, Input => 0, Output => 0) then
 253                     Failed ("Error reading discriminants - 2");
 254                 end if;
 255                 if Parent_Ops.Get_Counts /=
 256                    (Read => 2, Write => 2, Input => 1, Output => 1) then
 257                     Failed ("Didn't call inherited Input - 2");
 258                 end if;
 259
 260                 if Y2 /= (D1 => 3,
 261                           D2 => 6,
 262                           B => False,
 263                           S => Str (Ident_Str ("3456")),
 264                           C1 => Ident_Int (7)) then
 265                     Failed
 266                        ("Inherited Input and Output are not inverses of each other - 2");
 267                 end if;
 268             end;
 269         end Test1;
 270
 271     Test2:
 272         declare
 273             type Derived2 (D : Int) is new Parent (D1 => D,
 274                                                    D2 => D,
 275                                                    B => False);
 276             S : aliased My_Stream (1000);
 277             X1 : Derived2 (D => Int (Ident_Int (7)));
 278             Y1 : Derived2 := (D => 8,
 279                               S => Str (Ident_Str ("8")),
 280                               C1 => Ident_Int (200));
 281             X2 : Derived2 (D => Int (Ident_Int (7)));
 282         begin
 283             X1.S := Str (Ident_Str ("g"));
 284             X1.C1 := Ident_Int (4);
 285
 286             Derived2'Write (S'Access, X1);
 287             if Int_Ops.Get_Counts /=
 288                (Read => 2, Write => 2, Input => 0, Output => 0) then
 289                 Failed ("Error writing discriminants - 3");
 290             end if;
 291             if Parent_Ops.Get_Counts /=
 292                (Read => 2, Write => 3, Input => 1, Output => 1) then
 293                 Failed ("Didn't call inherited Write - 3");
 294             end if;
 295
 296             Derived2'Read (S'Access, X2);
 297             if Int_Ops.Get_Counts /=
 298                (Read => 2, Write => 2, Input => 0, Output => 0) then
 299                 Failed ("Error reading discriminants - 3");
 300             end if;
 301             if Parent_Ops.Get_Counts /=
 302                (Read => 3, Write => 3, Input => 1, Output => 1) then
 303                 Failed ("Didn't call inherited Read - 3");
 304             end if;
 305
 306             if X2 /= (D => 7,
 307                       S => Str (Ident_Str ("g")),
 308                       C1 => Ident_Int (7)) then
 309                 Failed
 310                    ("Inherited Read and Write are not inverses of each other - 3");
 311             end if;
 312
 313             Derived2'Output (S'Access, Y1);
 314             if Int_Ops.Get_Counts /=
 315                (Read => 2, Write => 4, Input => 0, Output => 0) then
 316                 Failed ("Error writing discriminants - 4");
 317             end if;
 318             if Parent_Ops.Get_Counts /=
 319                (Read => 3, Write => 4, Input => 1, Output => 2) then
 320                 Failed ("Didn't call inherited Output - 4");
 321             end if;
 322
 323             declare
 324                 Y2 : Derived2 := Derived2'Input (S'Access);
 325             begin
 326                 if Int_Ops.Get_Counts /=
 327                    (Read => 4, Write => 4, Input => 0, Output => 0) then
 328                     Failed ("Error reading discriminants - 4");
 329                 end if;
 330                 if Parent_Ops.Get_Counts /=
 331                    (Read => 4, Write => 4, Input => 2, Output => 2) then
 332                     Failed ("Didn't call inherited Input - 4");
 333                 end if;
 334
 335                 if Y2 /= (D => 8,
 336                           S => Str (Ident_Str ("8")),
 337                           C1 => Ident_Int (7)) then
 338                     Failed
 339                        ("Inherited Input and Output are not inverses of each other - 4");
 340                 end if;
 341             end;
 342         end Test2;
 343
 344     Result;
 345 end CDD2A02;