diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c4/c460005.a')
-rw-r--r-- | gcc/testsuite/ada/acats/tests/c4/c460005.a | 260 |
1 files changed, 0 insertions, 260 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c4/c460005.a b/gcc/testsuite/ada/acats/tests/c4/c460005.a deleted file mode 100644 index 95b14a9a20a..00000000000 --- a/gcc/testsuite/ada/acats/tests/c4/c460005.a +++ /dev/null @@ -1,260 +0,0 @@ --- C460005.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, for a view conversion of a tagged type that is the left --- side of an assignment statement, the assignment assigns to the --- corresponding part of the object denoted by the operand. --- --- 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. --- --- For the cases where the view conversion is the left side of an --- assignment statement, and Constraint_Error should not be raised, --- an additional check is made that only the corresponding portion --- of the operand is updated by the assignment. For example: --- --- type T is tagged record --- C1 : Integer := 0; --- end record; --- --- type DT is new T with record --- C2 : Integer := 0; --- end record; --- --- A : T := (C1 => 5); --- B : DT := (C1 => 0, C2 => 10); --- CWDT : T'Class := B; --- --- T(CWDT) := A; -- Updates component C1; C2 remains unchanged. --- -- Value of CWDT is (C1 => 5, C2 => 10). --- --- --- CHANGE HISTORY: --- 31 Jul 95 SAIC Initial prerelease version. --- 22 Apr 96 SAIC ACVC 2.1: Added a check for correct tag. --- 08 Sep 96 SAIC ACVC 2.1: Modified Report.Test. --- ---! - -package C460005_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); - -end C460005_0; - - - --==================================================================-- - - -package body C460005_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; - -end C460005_0; - - - --==================================================================-- - - -with C460005_0; -use C460005_0; - -with Report; -procedure C460005 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"); - - Tag_Type_Res : constant Tag_Type := (C1 => 25); - DTag_Type_Res : constant DTag_Type := (Tag_Type_Res with "Hello"); - DDTag_Type_Res : constant DDTag_Type := (DTag_Type_Res with "World"); - -begin - - Report.Test ("C460005", "Check that, for a view conversion of a tagged " & - "type that is the left side of an assignment statement, " & - "the assignment assigns to the corresponding part of the " & - "object denoted by the operand"); - - - declare - procedure CW_Proc (P : Tag_Type'Class) is - Operand : Tag_Type'Class := P; - begin - Tag_Type(Operand) := Tag_Type_Value; - - if (Operand /= Tag_Type'Class (Tag_Type_Value)) then - Report.Failed ("Operand 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 (Tag_Type_Init); - end; - - ---------------------------------------------------------------------- - - declare - procedure CW_Proc (P : Tag_Type'Class) is - Operand : Tag_Type'Class := P; - begin - DTag_Type(Operand) := DTag_Type_Value; - Report.Failed ("Constraint_Error not raised: #02"); - - exception - when Constraint_Error => null; -- expected exception - when others => Report.Failed ("Unexpected exception: #02"); - 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 - DDTag_Type(Operand) := DDTag_Type_Value; - Report.Failed ("Constraint_Error not raised: #03"); - - exception - when Constraint_Error => null; -- expected exception - when others => Report.Failed ("Unexpected exception: #03"); - 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 - Tag_Type(Operand) := Tag_Type_Value; - - if Operand not in DTag_Type then - Report.Failed ("Operand has wrong tag: #04"); - elsif (Operand /= Tag_Type'Class (DTag_Type_Res)) - then -- Check to make - Report.Failed ("Operand has wrong value: #04"); -- sure that C2 was - end if; -- not modified. - - exception - when Constraint_Error => - Report.Failed ("Constraint_Error raised: #04"); - when others => - Report.Failed ("Unexpected exception: #04"); - 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 - Tag_Type(Operand) := Tag_Type_Value; - - if Operand not in DDTag_Type then - Report.Failed ("Operand has wrong tag: #05"); - elsif (Operand /= Tag_Type'Class (DDTag_Type_Res)) - then -- Check to make - Report.Failed ("Operand has wrong value: #05"); -- sure that C2, C3 - end if; -- were not changed. - - 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_Init); - end; - - Report.Result; - -end C460005; |