diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/cd/cdd2a02.a')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/cd/cdd2a02.a | 345 |
1 files changed, 0 insertions, 345 deletions
diff --git a/gcc/testsuite/ada/acats/tests/cd/cdd2a02.a b/gcc/testsuite/ada/acats/tests/cd/cdd2a02.a deleted file mode 100644 index 854431c3488..00000000000 --- a/gcc/testsuite/ada/acats/tests/cd/cdd2a02.a +++ /dev/null @@ -1,345 +0,0 @@ --- 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; |