diff options
Diffstat (limited to 'gcc-4.9/gcc/testsuite/ada/acats/tests/cd/cdd2a02.a')
| -rw-r--r-- | gcc-4.9/gcc/testsuite/ada/acats/tests/cd/cdd2a02.a | 345 |
1 files changed, 345 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cd/cdd2a02.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/cd/cdd2a02.a new file mode 100644 index 000000000..854431c34 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cd/cdd2a02.a @@ -0,0 +1,345 @@ +-- CDD2A02.A +-- +-- Grant of Unlimited Rights +-- +-- The Ada Conformity Assessment Authority (ACAA) holds unlimited +-- rights in the software and documentation contained herein. Unlimited +-- rights are the same as those granted by the U.S. Government for older +-- parts of the Ada Conformity Assessment Test Suite, and are defined +-- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA +-- intends to confer upon all recipients unlimited rights equal to those +-- held by the ACAA. These rights include rights to use, duplicate, +-- release or disclose the released technical data and computer software +-- in whole or in part, in any manner and for any purpose whatsoever, and +-- to have or permit others to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that the Read, Write, Input, and Output attributes are inherited +-- for untagged derived types. (Defect Report 8652/0040, +-- as reflected in Technical Corrigendum 1, 13.13.2(8.1/1) and +-- 13.13.2(25/1)). +-- +-- CHANGE HISTORY: +-- 30 JUL 2001 PHL Initial version. +-- 5 DEC 2001 RLB Reformatted for ACATS. +-- +--! +with Ada.Streams; +use Ada.Streams; +with FDD2A00; +use FDD2A00; +with Report; +use Report; +procedure CDD2A02 is + + type Int is range 1 .. 10; + type Str is array (Int range <>) of Character; + + procedure Read (Stream : access Root_Stream_Type'Class; + Item : out Int'Base); + procedure Write (Stream : access Root_Stream_Type'Class; Item : Int'Base); + function Input (Stream : access Root_Stream_Type'Class) return Int'Base; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Int'Base); + + for Int'Read use Read; + for Int'Write use Write; + for Int'Input use Input; + for Int'Output use Output; + + + type Parent (D1, D2 : Int; B : Boolean) is + record + S : Str (D1 .. D2); + case B is + when False => + C1 : Integer; + when True => + C2 : Float; + end case; + end record; + + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Parent); + procedure Write (Stream : access Root_Stream_Type'Class; Item : Parent); + function Input (Stream : access Root_Stream_Type'Class) return Parent; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Parent); + + for Parent'Read use Read; + for Parent'Write use Write; + for Parent'Input use Input; + for Parent'Output use Output; + + + procedure Actual_Read + (Stream : access Root_Stream_Type'Class; Item : out Int) is + begin + Integer'Read (Stream, Integer (Item)); + end Actual_Read; + + procedure Actual_Write + (Stream : access Root_Stream_Type'Class; Item : Int) is + begin + Integer'Write (Stream, Integer (Item)); + end Actual_Write; + + function Actual_Input (Stream : access Root_Stream_Type'Class) return Int is + begin + return Int (Integer'Input (Stream)); + end Actual_Input; + + procedure Actual_Output + (Stream : access Root_Stream_Type'Class; Item : Int) is + begin + Integer'Output (Stream, Integer (Item)); + end Actual_Output; + + + procedure Actual_Read + (Stream : access Root_Stream_Type'Class; Item : out Parent) is + begin + case Item.B is + when False => + Item.C1 := 7; + when True => + Float'Read (Stream, Item.C2); + end case; + Str'Read (Stream, Item.S); + end Actual_Read; + + procedure Actual_Write + (Stream : access Root_Stream_Type'Class; Item : Parent) is + begin + case Item.B is + when False => + null; -- Don't write C1 + when True => + Float'Write (Stream, Item.C2); + end case; + Str'Write (Stream, Item.S); + end Actual_Write; + + function Actual_Input + (Stream : access Root_Stream_Type'Class) return Parent is + D1, D2 : Int; + B : Boolean; + begin + Int'Read (Stream, D2); + Boolean'Read (Stream, B); + Int'Read (Stream, D1); + + declare + Item : Parent (D1 => D1, D2 => D2, B => B); + begin + Parent'Read (Stream, Item); + return Item; + end; + + end Actual_Input; + + procedure Actual_Output + (Stream : access Root_Stream_Type'Class; Item : Parent) is + begin + Int'Write (Stream, Item.D2); + Boolean'Write (Stream, Item.B); + Int'Write (Stream, Item.D1); + Parent'Write (Stream, Item); + end Actual_Output; + + package Int_Ops is new Counting_Stream_Ops (T => Int'Base, + Actual_Write => Actual_Write, + Actual_Input => Actual_Input, + Actual_Read => Actual_Read, + Actual_Output => Actual_Output); + + package Parent_Ops is + new Counting_Stream_Ops (T => Parent, + Actual_Write => Actual_Write, + Actual_Input => Actual_Input, + Actual_Read => Actual_Read, + Actual_Output => Actual_Output); + + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Int'Base) + renames Int_Ops.Read; + procedure Write (Stream : access Root_Stream_Type'Class; Item : Int'Base) + renames Int_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Int'Base + renames Int_Ops.Input; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Int'Base) + renames Int_Ops.Output; + + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Parent) + renames Parent_Ops.Read; + procedure Write (Stream : access Root_Stream_Type'Class; Item : Parent) + renames Parent_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Parent + renames Parent_Ops.Input; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Parent) + renames Parent_Ops.Output; + +begin + Test ("CDD2A02", "Check that the Read, Write, Input, and Output " & + "attributes are inherited for untagged derived types"); + + Test1: + declare + type Derived1 is new Parent; + S : aliased My_Stream (1000); + X1 : Derived1 (D1 => Int (Ident_Int (2)), + D2 => Int (Ident_Int (5)), B => Ident_Bool (True)); + Y1 : Derived1 := (D1 => 3, + D2 => 6, + B => False, + S => Str (Ident_Str ("3456")), + C1 => Ident_Int (100)); + X2 : Derived1 (D1 => Int (Ident_Int (2)), + D2 => Int (Ident_Int (5)), B => Ident_Bool (True)); + begin + X1.S := Str (Ident_Str ("bcde")); + X1.C2 := Float (Ident_Int (4)); + + Derived1'Write (S'Access, X1); + if Int_Ops.Get_Counts /= + (Read => 0, Write => 0, Input => 0, Output => 0) then + Failed ("Error writing discriminants - 1"); + end if; + if Parent_Ops.Get_Counts /= + (Read => 0, Write => 1, Input => 0, Output => 0) then + Failed ("Didn't call inherited Write - 1"); + end if; + + Derived1'Read (S'Access, X2); + if Int_Ops.Get_Counts /= + (Read => 0, Write => 0, Input => 0, Output => 0) then + Failed ("Error reading discriminants - 1"); + end if; + if Parent_Ops.Get_Counts /= + (Read => 1, Write => 1, Input => 0, Output => 0) then + Failed ("Didn't call inherited Read - 1"); + end if; + + if X2 /= (D1 => 2, + D2 => 5, + B => True, + S => Str (Ident_Str ("bcde")), + C2 => Float (Ident_Int (4))) then + Failed + ("Inherited Read and Write are not inverses of each other - 1"); + end if; + + Derived1'Output (S'Access, Y1); + if Int_Ops.Get_Counts /= + (Read => 0, Write => 2, Input => 0, Output => 0) then + Failed ("Error writing discriminants - 2"); + end if; + if Parent_Ops.Get_Counts /= + (Read => 1, Write => 2, Input => 0, Output => 1) then + Failed ("Didn't call inherited Output - 2"); + end if; + + declare + Y2 : Derived1 := Derived1'Input (S'Access); + begin + if Int_Ops.Get_Counts /= + (Read => 2, Write => 2, Input => 0, Output => 0) then + Failed ("Error reading discriminants - 2"); + end if; + if Parent_Ops.Get_Counts /= + (Read => 2, Write => 2, Input => 1, Output => 1) then + Failed ("Didn't call inherited Input - 2"); + end if; + + if Y2 /= (D1 => 3, + D2 => 6, + B => False, + S => Str (Ident_Str ("3456")), + C1 => Ident_Int (7)) then + Failed + ("Inherited Input and Output are not inverses of each other - 2"); + end if; + end; + end Test1; + + Test2: + declare + type Derived2 (D : Int) is new Parent (D1 => D, + D2 => D, + B => False); + S : aliased My_Stream (1000); + X1 : Derived2 (D => Int (Ident_Int (7))); + Y1 : Derived2 := (D => 8, + S => Str (Ident_Str ("8")), + C1 => Ident_Int (200)); + X2 : Derived2 (D => Int (Ident_Int (7))); + begin + X1.S := Str (Ident_Str ("g")); + X1.C1 := Ident_Int (4); + + Derived2'Write (S'Access, X1); + if Int_Ops.Get_Counts /= + (Read => 2, Write => 2, Input => 0, Output => 0) then + Failed ("Error writing discriminants - 3"); + end if; + if Parent_Ops.Get_Counts /= + (Read => 2, Write => 3, Input => 1, Output => 1) then + Failed ("Didn't call inherited Write - 3"); + end if; + + Derived2'Read (S'Access, X2); + if Int_Ops.Get_Counts /= + (Read => 2, Write => 2, Input => 0, Output => 0) then + Failed ("Error reading discriminants - 3"); + end if; + if Parent_Ops.Get_Counts /= + (Read => 3, Write => 3, Input => 1, Output => 1) then + Failed ("Didn't call inherited Read - 3"); + end if; + + if X2 /= (D => 7, + S => Str (Ident_Str ("g")), + C1 => Ident_Int (7)) then + Failed + ("Inherited Read and Write are not inverses of each other - 3"); + end if; + + Derived2'Output (S'Access, Y1); + if Int_Ops.Get_Counts /= + (Read => 2, Write => 4, Input => 0, Output => 0) then + Failed ("Error writing discriminants - 4"); + end if; + if Parent_Ops.Get_Counts /= + (Read => 3, Write => 4, Input => 1, Output => 2) then + Failed ("Didn't call inherited Output - 4"); + end if; + + declare + Y2 : Derived2 := Derived2'Input (S'Access); + begin + if Int_Ops.Get_Counts /= + (Read => 4, Write => 4, Input => 0, Output => 0) then + Failed ("Error reading discriminants - 4"); + end if; + if Parent_Ops.Get_Counts /= + (Read => 4, Write => 4, Input => 2, Output => 2) then + Failed ("Didn't call inherited Input - 4"); + end if; + + if Y2 /= (D => 8, + S => Str (Ident_Str ("8")), + C1 => Ident_Int (7)) then + Failed + ("Inherited Input and Output are not inverses of each other - 4"); + end if; + end; + end Test2; + + Result; +end CDD2A02; |