diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/cd/cdd2a01.a')
-rw-r--r-- | gcc/testsuite/ada/acats/tests/cd/cdd2a01.a | 379 |
1 files changed, 0 insertions, 379 deletions
diff --git a/gcc/testsuite/ada/acats/tests/cd/cdd2a01.a b/gcc/testsuite/ada/acats/tests/cd/cdd2a01.a deleted file mode 100644 index 7c8000ce04c..00000000000 --- a/gcc/testsuite/ada/acats/tests/cd/cdd2a01.a +++ /dev/null @@ -1,379 +0,0 @@ --- CDD2A01.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 and Write attributes for a type extension are created --- from the parent type's attribute (which may be user-defined) and those --- for the extension components. Also check that the default Input and --- Output attributes are used for a type extension, even if the parent --- type's attribute is user-defined. (Defect Report 8652/0040, --- as reflected in Technical Corrigendum 1, penultimate sentence of --- 13.13.2(9/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 CDD2A01 is - - Input_Output_Error : exception; - - type Int is range 1 .. 1000; - 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 tagged - 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 - X : Parent (1, 1, True); - begin - raise Input_Output_Error; - return X; - end Actual_Input; - - procedure Actual_Output - (Stream : access Root_Stream_Type'Class; Item : Parent) is - begin - raise Input_Output_Error; - 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; - - type Derived1 is new Parent with - record - C3 : Int; - end record; - - type Derived2 (D : Int) is new Parent (D1 => D, - D2 => D, - B => False) with - record - C3 : Int; - end record; - -begin - Test ("CDD2A01", - "Check that the Read and Write attributes for a type " & - "extension are created from the parent type's " & - "attribute (which may be user-defined) and those for the " & - "extension components; also check that the default input " & - "and output attributes are used for a type extension, even " & - "if the parent type's attribute is user-defined"); - - Test1: - declare - 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), - C3 => Int (Ident_Int (88))); - 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)); - X1.C3 := Int (Ident_Int (99)); - - Derived1'Write (S'Access, X1); - if Int_Ops.Get_Counts /= - (Read => 0, Write => 1, Input => 0, Output => 0) then - Failed ("Error writing extension components - 1"); - end if; - if Parent_Ops.Get_Counts /= - (Read => 0, Write => 1, Input => 0, Output => 0) then - Failed ("Didn't call parent type's Write - 1"); - end if; - - Derived1'Read (S'Access, X2); - if Int_Ops.Get_Counts /= - (Read => 1, Write => 1, Input => 0, Output => 0) then - Failed ("Error reading extension components - 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)), - C3 => Int (Ident_Int (99))) then - Failed - ("Inherited Read and Write are not inverses of each other - 1"); - end if; - - begin - Derived1'Output (S'Access, Y1); - if Int_Ops.Get_Counts /= - (Read => 1, Write => 4, Input => 0, Output => 0) then - Failed ("Error writing extension components - 2"); - end if; - if Parent_Ops.Get_Counts /= - (Read => 1, Write => 2, Input => 0, Output => 0) then - Failed ("Didn't call inherited Write - 2"); - end if; - exception - when Input_Output_Error => - Failed ("Did call inherited Output - 2"); - end; - - begin - declare - Y2 : Derived1 := Derived1'Input (S'Access); - begin - if Int_Ops.Get_Counts /= - (Read => 4, Write => 4, Input => 0, Output => 0) then - Failed ("Error reading extension components - 2"); - end if; - if Parent_Ops.Get_Counts /= - (Read => 2, Write => 2, Input => 0, Output => 0) then - Failed ("Didn't call inherited Read - 2"); - end if; - if Y2 /= (D1 => 3, - D2 => 6, - B => False, - S => Str (Ident_Str ("3456")), - C1 => Ident_Int (7), - C3 => Int (Ident_Int (88))) then - Failed - ("Input and Output are not inverses of each other - 2"); - end if; - end; - exception - when Input_Output_Error => - Failed ("Did call inherited Input - 2"); - end; - - end Test1; - - Test2: - declare - 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), - C3 => Int (Ident_Int (77))); - X2 : Derived2 (D => Int (Ident_Int (7))); - begin - X1.S := Str (Ident_Str ("g")); - X1.C1 := Ident_Int (4); - X1.C3 := Int (Ident_Int (666)); - - Derived2'Write (S'Access, X1); - if Int_Ops.Get_Counts /= - (Read => 4, Write => 5, Input => 0, Output => 0) then - Failed ("Error writing extension components - 3"); - end if; - if Parent_Ops.Get_Counts /= - (Read => 2, Write => 3, Input => 0, Output => 0) then - Failed ("Didn't call inherited Write - 3"); - end if; - - Derived2'Read (S'Access, X2); - if Int_Ops.Get_Counts /= - (Read => 5, Write => 5, Input => 0, Output => 0) then - Failed ("Error reading extension components - 3"); - end if; - if Parent_Ops.Get_Counts /= - (Read => 3, Write => 3, Input => 0, Output => 0) then - Failed ("Didn't call inherited Read - 3"); - end if; - - if X2 /= (D => 7, - S => Str (Ident_Str ("g")), - C1 => Ident_Int (7), - C3 => Int (Ident_Int (666))) then - Failed ("Read and Write are not inverses of each other - 3"); - end if; - - begin - Derived2'Output (S'Access, Y1); - if Int_Ops.Get_Counts /= - (Read => 5, Write => 7, Input => 0, Output => 0) then - Failed ("Error writing extension components - 4"); - end if; - if Parent_Ops.Get_Counts /= - (Read => 3, Write => 4, Input => 0, Output => 0) then - Failed ("Didn't call inherited Write - 4"); - end if; - exception - when Input_Output_Error => - Failed ("Did call inherited Output - 4"); - end; - - begin - declare - Y2 : Derived2 := Derived2'Input (S'Access); - begin - if Int_Ops.Get_Counts /= - (Read => 7, Write => 7, Input => 0, Output => 0) then - Failed ("Error reading extension components - 4"); - end if; - if Parent_Ops.Get_Counts /= - (Read => 4, Write => 4, Input => 0, Output => 0) then - Failed ("Didn't call inherited Read - 4"); - end if; - if Y2 /= (D => 8, - S => Str (Ident_Str ("8")), - C1 => Ident_Int (7), - C3 => Int (Ident_Int (77))) then - Failed - ("Input and Output are not inverses of each other - 4"); - end if; - end; - exception - when Input_Output_Error => - Failed ("Did call inherited Input - 4"); - end; - - end Test2; - - Result; -end CDD2A01; |