diff options
Diffstat (limited to 'gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c460004.a')
| -rw-r--r-- | gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c460004.a | 335 |
1 files changed, 335 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c460004.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c460004.a new file mode 100644 index 000000000..b00428121 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c460004.a @@ -0,0 +1,335 @@ +-- C460004.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- 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 if the operand type of a type conversion is class-wide, +-- Constraint_Error is raised if the tag of the operand does not +-- identify a specific type that is covered by or descended from the +-- target type. +-- +-- TEST DESCRIPTION: +-- View conversions of class-wide operands to specific types are +-- placed on the right and left sides of assignment statements, and +-- conversions of class-wide operands to class-wide types are used +-- as actual parameters to dispatching operations. In all cases, a +-- check is made that Constraint_Error is raised if the tag of the +-- operand does not identify a specific type covered by or descended +-- from the target type, and not raised otherwise. +-- +-- A specific type is descended from itself and from those types it is +-- directly or indirectly derived from. A specific type is covered by +-- itself and each class-wide type to whose class it belongs. +-- +-- A class-wide type T'Class is descended from T and those types which +-- T is descended from. A class-wide type is covered by each class-wide +-- type to whose class it belongs. +-- +-- +-- CHANGE HISTORY: +-- 19 Jul 95 SAIC Initial prerelease version. +-- 18 Apr 96 SAIC ACVC 2.1: Added a check for correct tag. +-- +--! +package C460004_0 is + + type Tag_Type is tagged record + C1 : Natural; + end record; + + procedure Proc (X : in out Tag_Type); + + + type DTag_Type is new Tag_Type with record + C2 : String (1 .. 5); + end record; + + procedure Proc (X : in out DTag_Type); + + + type DDTag_Type is new DTag_Type with record + C3 : String (1 .. 5); + end record; + + procedure Proc (X : in out DDTag_Type); + + procedure NewProc (X : in DDTag_Type); + + function CWFunc (X : Tag_Type'Class) return Tag_Type'Class; + +end C460004_0; + + + --==================================================================-- + +with Report; +package body C460004_0 is + + procedure Proc (X : in out Tag_Type) is + begin + X.C1 := 25; + end Proc; + + ----------------------------------------- + procedure Proc (X : in out DTag_Type) is + begin + Proc ( Tag_Type(X) ); + X.C2 := "Earth"; + end Proc; + + ----------------------------------------- + procedure Proc (X : in out DDTag_Type) is + begin + Proc ( DTag_Type(X) ); + X.C3 := "Orbit"; + end Proc; + + ----------------------------------------- + procedure NewProc (X : in DDTag_Type) is + Y : DDTag_Type := X; + begin + Proc (Y); + exception + when others => + Report.Failed ("Unexpected exception in NewProc"); + end NewProc; + + ----------------------------------------- + function CWFunc (X : Tag_Type'Class) return Tag_Type'Class is + Y : Tag_Type'Class := X; + begin + Proc (Y); + return Y; + end CWFunc; + +end C460004_0; + + + --==================================================================-- + + +with C460004_0; +use C460004_0; + +with Report; +procedure C460004 is + + Tag_Type_Init : constant Tag_Type := (C1 => 0); + DTag_Type_Init : constant DTag_Type := (Tag_Type_Init with "Hello"); + DDTag_Type_Init : constant DDTag_Type := (DTag_Type_Init with "World"); + + Tag_Type_Value : constant Tag_Type := (C1 => 25); + DTag_Type_Value : constant DTag_Type := (Tag_Type_Value with "Earth"); + DDTag_Type_Value : constant DDTag_Type := (DTag_Type_Value with "Orbit"); + +begin + + Report.Test ("C460004", "Check that for a view conversion of a " & + "class-wide operand, Constraint_Error is raised if the " & + "tag of the operand does not identify a specific type " & + "covered by or descended from the target type"); + +-- +-- View conversion to specific type: +-- + + declare + procedure CW_Proc (P : Tag_Type'Class) is + Target : Tag_Type := Tag_Type_Init; + begin + Target := Tag_Type(P); + if (Target /= Tag_Type_Value) then + Report.Failed ("Target has wrong value: #01"); + end if; + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised: #01"); + when others => + Report.Failed ("Unexpected exception: #01"); + end CW_Proc; + + begin + CW_Proc (DDTag_Type_Value); + end; + + ---------------------------------------------------------------------- + + declare + Target : DTag_Type := DTag_Type_Init; + begin + Target := DTag_Type(CWFunc(DDTag_Type_Value)); + if (Target /= DTag_Type_Value) then + Report.Failed ("Target has wrong value: #02"); + end if; + exception + when Constraint_Error => Report.Failed ("Constraint_Error raised: #02"); + when others => Report.Failed ("Unexpected exception: #02"); + end; + + ---------------------------------------------------------------------- + + declare + Target : DDTag_Type; + begin + Target := DDTag_Type(CWFunc(Tag_Type_Value)); + -- CWFunc returns a Tag_Type; its tag is preserved through + -- the view conversion. Constraint_Error should be raised. + + Report.Failed ("Constraint_Error not raised: #03"); + + exception + when Constraint_Error => null; -- expected exception + when others => Report.Failed ("Unexpected exception: #03"); + end; + + ---------------------------------------------------------------------- + + declare + procedure CW_Proc (P : Tag_Type'Class) is + begin + NewProc (DDTag_Type(P)); + Report.Failed ("Constraint_Error not raised: #04"); + + exception + when Constraint_Error => null; -- expected exception + when others => Report.Failed ("Unexpected exception: #04"); + end CW_Proc; + + begin + CW_Proc (DTag_Type_Value); + end; + + ---------------------------------------------------------------------- + + declare + procedure CW_Proc (P : Tag_Type'Class) is + Target : DDTag_Type := DDTag_Type_Init; + begin + Target := DDTag_Type(P); + if (Target /= DDTag_Type_Value) then + Report.Failed ("Target has wrong value: #05"); + end if; + + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised: #05"); + when others + => Report.Failed ("Unexpected exception: #05"); + end CW_Proc; + + begin + CW_Proc (DDTag_Type_Value); + end; + + +-- +-- View conversion to class-wide type: +-- + + declare + procedure CW_Proc (P : Tag_Type'Class) is + Operand : Tag_Type'Class := P; + begin + Proc( DTag_Type'Class(Operand) ); + Report.Failed ("Constraint_Error not raised: #06"); + + exception + when Constraint_Error => null; -- expected exception + when others => Report.Failed ("Unexpected exception: #06"); + end CW_Proc; + + begin + CW_Proc (Tag_Type_Init); + end; + + ---------------------------------------------------------------------- + + declare + procedure CW_Proc (P : Tag_Type'Class) is + Operand : Tag_Type'Class := P; + begin + Proc( DDTag_Type'Class(Operand) ); + Report.Failed ("Constraint_Error not raised: #07"); + + exception + when Constraint_Error => null; -- expected exception + when others => Report.Failed ("Unexpected exception: #07"); + end CW_Proc; + + begin + CW_Proc (Tag_Type_Init); + end; + + ---------------------------------------------------------------------- + + declare + procedure CW_Proc (P : Tag_Type'Class) is + Operand : Tag_Type'Class := P; + begin + Proc( DTag_Type'Class(Operand) ); + if Operand not in DTag_Type then + Report.Failed ("Operand has wrong tag: #08"); + elsif (Operand /= Tag_Type'Class (DTag_Type_Value)) then + Report.Failed ("Operand has wrong value: #08"); + end if; + + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised: #08"); + when others => + Report.Failed ("Unexpected exception: #08"); + end CW_Proc; + + begin + CW_Proc (DTag_Type_Init); + end; + + ---------------------------------------------------------------------- + + declare + procedure CW_Proc (P : Tag_Type'Class) is + Operand : Tag_Type'Class := P; + begin + Proc( Tag_Type'Class(Operand) ); + if Operand not in DDTag_Type then + Report.Failed ("Operand has wrong tag: #09"); + elsif (Operand /= Tag_Type'Class (DDTag_Type_Value)) then + Report.Failed ("Operand has wrong value: #09"); + end if; + + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised: #09"); + when others => + Report.Failed ("Unexpected exception: #09"); + end CW_Proc; + + begin + CW_Proc (DDTag_Type_Init); + end; + + + Report.Result; + +end C460004; |