diff options
Diffstat (limited to 'gcc-4.9/gcc/testsuite/ada/acats/tests/cd/cdd2a03.a')
| -rw-r--r-- | gcc-4.9/gcc/testsuite/ada/acats/tests/cd/cdd2a03.a | 325 |
1 files changed, 325 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cd/cdd2a03.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/cd/cdd2a03.a new file mode 100644 index 000000000..b4c291772 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cd/cdd2a03.a @@ -0,0 +1,325 @@ +-- CDD2A03.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 default Read and Write attributes for a limited type +-- extension are created from the parent type's attribute (which may be +-- user-defined) and those for the extension components, if the extension +-- components are non-limited or have user-defined attributes. Check that +-- such limited type extension attributes are callable (Defect Report +-- 8652/0040, as reflected in Technical Corrigendum 1, penultimate sentence +-- of 13.13.2(9/1) and 13.13.2(36/1)). +-- +-- CHANGE HISTORY: +-- 1 AUG 2001 PHL Initial version. +-- 3 DEC 2001 RLB Reformatted for ACATS. +-- +--! +with Ada.Streams; +use Ada.Streams; +with FDD2A00; +use FDD2A00; +with Report; +use Report; +procedure CDD2A03 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 Lim is limited + record + C : Int; + end record; + + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Lim); + procedure Write (Stream : access Root_Stream_Type'Class; Item : Lim); + function Input (Stream : access Root_Stream_Type'Class) return Lim; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Lim); + + for Lim'Read use Read; + for Lim'Write use Write; + for Lim'Input use Input; + for Lim'Output use Output; + + + type Parent (D1, D2 : Int; B : Boolean) is tagged limited + 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 Lim) is + begin + Integer'Read (Stream, Integer (Item.C)); + end Actual_Read; + + procedure Actual_Write + (Stream : access Root_Stream_Type'Class; Item : Lim) is + begin + Integer'Write (Stream, Integer (Item.C)); + end Actual_Write; + + function Actual_Input (Stream : access Root_Stream_Type'Class) return Lim is + Result : Lim; + begin + Result.C := Int (Integer'Input (Stream)); + return Result; + end Actual_Input; + + procedure Actual_Output + (Stream : access Root_Stream_Type'Class; Item : Lim) is + begin + Integer'Output (Stream, Integer (Item.C)); + 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 Lim_Ops is new Counting_Stream_Ops (T => Lim, + 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 Lim) + renames Lim_Ops.Read; + procedure Write (Stream : access Root_Stream_Type'Class; Item : Lim) + renames Lim_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Lim + renames Lim_Ops.Input; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Lim) + renames Lim_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 : Lim; + end record; + +begin + Test ("CDD2A03", + "Check that the default Read and Write attributes for a limited " & + "type extension are created from the parent type's " & + "attribute (which may be user-defined) and those for the " & + "extension components, if the extension components are " & + "non-limited or have user-defined attributes; check that such " & + "limited type extension attributes are callable"); + + Test1: + declare + S : aliased My_Stream (1000); + X1 : Derived1 (D1 => Int (Ident_Int (2)), + D2 => Int (Ident_Int (5)), + B => Ident_Bool (True)); + 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; + end Test1; + + Test2: + declare + S : aliased My_Stream (1000); + X1 : Derived2 (D => Int (Ident_Int (7))); + X2 : Derived2 (D => Int (Ident_Int (7))); + begin + X1.S := Str (Ident_Str ("g")); + X1.C1 := Ident_Int (4); + X1.C3.C := Int (Ident_Int (666)); + + Derived2'Write (S'Access, X1); + if Lim_Ops.Get_Counts /= + (Read => 0, Write => 1, 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; + + Derived2'Read (S'Access, X2); + if Lim_Ops.Get_Counts /= + (Read => 1, Write => 1, 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; + end Test2; + + Result; +end CDD2A03; |