diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c7/c760007.a')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/c7/c760007.a | 247 |
1 files changed, 0 insertions, 247 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c7/c760007.a b/gcc/testsuite/ada/acats/tests/c7/c760007.a deleted file mode 100644 index c1ddfcb9345..00000000000 --- a/gcc/testsuite/ada/acats/tests/c7/c760007.a +++ /dev/null @@ -1,247 +0,0 @@ --- C760007.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 Adjust is called for the execution of a return --- statement for a function returning a result of a (non-limited) --- controlled type. --- --- Check that Adjust is called when evaluating an aggregate --- component association for a controlled component. --- --- Check that Adjust is called for the assignment of the ancestor --- expression of an extension aggregate when the type of the --- aggregate is controlled. --- --- TEST DESCRIPTION: --- A type is derived from Ada.Finalization.Controlled; the dispatching --- procedure Adjust is defined for the new type. Structures and --- subprograms to model the test objectives are used to check that --- Adjust is called at the right time. For the sake of simplicity, --- globally accessible data is used to check that the calls are made. --- --- --- CHANGE HISTORY: --- 06 DEC 94 SAIC ACVC 2.0 --- 14 OCT 95 SAIC Update and repair for ACVC 2.0.1 --- 05 APR 96 SAIC Add RM reference --- 06 NOV 96 SAIC Reduce adjust requirement --- 25 NOV 97 EDS Allowed zero calls to adjust at line 144 ---! - ----------------------------------------------------------------- C760007_0 - -with Ada.Finalization; -package C760007_0 is - - type Controlled is new Ada.Finalization.Controlled with record - TC_ID : Natural := Natural'Last; - end record; - procedure Adjust( Object: in out Controlled ); - - type Structure is record - Controlled_Component : Controlled; - end record; - - type Child is new Controlled with record - TC_XX : Natural := Natural'Last; - end record; - procedure Adjust( Object: in out Child ); - - Adjust_Count : Natural := 0; - Child_Adjust_Count : Natural := 0; - -end C760007_0; - -package body C760007_0 is - - procedure Adjust( Object: in out Controlled ) is - begin - Adjust_Count := Adjust_Count +1; - end Adjust; - - procedure Adjust( Object: in out Child ) is - begin - Child_Adjust_Count := Child_Adjust_Count +1; - end Adjust; - -end C760007_0; - ------------------------------------------------------------------- C760007 - -with Report; -with C760007_0; -procedure C760007 is - - procedure Check_Adjust_Count(Message: String; - Min: Natural := 1; - Max: Natural := 2) is - begin - - -- in order to allow for the anonymous objects referred to in - -- the reference manual, the check for calls to Adjust must be - -- in a range. This number must then be further adjusted - -- to allow for the optimization that does not call for an adjust - -- of an aggregate initial value built directly in the object - - if C760007_0.Adjust_Count not in Min..Max then - Report.Failed(Message - & " = " & Natural'Image(C760007_0.Adjust_Count)); - end if; - C760007_0.Adjust_Count := 0; - end Check_Adjust_Count; - - procedure Check_Child_Adjust_Count(Message: String; - Min: Natural := 1; - Max: Natural := 2) is - begin - -- ditto above - - if C760007_0.Child_Adjust_Count not in Min..Max then - Report.Failed(Message - & " = " & Natural'Image(C760007_0.Child_Adjust_Count)); - end if; - C760007_0.Child_Adjust_Count := 0; - end Check_Child_Adjust_Count; - - Object : C760007_0.Controlled; - --- Check that Adjust is called for the execution of a return --- statement for a function returning a result of a (non-limited) --- controlled type or a result of a noncontrolled type with --- controlled components. - - procedure Subtest_1 is - function Create return C760007_0.Controlled is - New_Object : C760007_0.Controlled; - begin - return New_Object; - end Create; - - procedure Examine( Thing : in C760007_0.Controlled ) is - begin - Check_Adjust_Count("Function call passed as parameter",0); - end Examine; - - begin - -- this assignment must call Adjust: - -- 1: on the value resulting from the function - -- ** unless this is optimized out by building the result directly - -- in the target object. - -- 2: on Object once it's been assigned - -- may call adjust - -- 1: for a anonymous object created in the evaluation of the function - -- 2: for a anonymous object created in the assignment operation - - Object := Create; - - Check_Adjust_Count("Function call",1,4); - - Examine( Create ); - - end Subtest_1; - --- Check that Adjust is called when evaluating an aggregate --- component association for a controlled component. - - procedure Subtest_2 is - S : C760007_0.Structure; - - procedure Examine( Thing : in C760007_0.Structure ) is - begin - Check_Adjust_Count("Aggregate passed as parameter"); - end Examine; - - begin - -- this assignment must call Adjust: - -- 1: on the value resulting from the aggregate - -- ** unless this is optimized out by building the result directly - -- in the target object. - -- 2: on Object once it's been assigned - -- may call adjust - -- 1: for a anonymous object created in the evaluation of the aggregate - -- 2: for a anonymous object created in the assignment operation - S := ( Controlled_Component => Object ); - Check_Adjust_Count("Aggregate and Assignment", 1, 4); - - Examine( C760007_0.Structure'(Controlled_Component => Object) ); - end Subtest_2; - --- Check that Adjust is called for the assignment of the ancestor --- expression of an extension aggregate when the type of the --- aggregate is controlled. - - procedure Subtest_3 is - Bambino : C760007_0.Child; - - procedure Examine( Thing : in C760007_0.Child ) is - begin - Check_Adjust_Count("Extension aggregate as parameter (ancestor)", 0, 2); - Check_Child_Adjust_Count("Extension aggregate as parameter", 0, 4); - end Examine; - - begin - -- implementation permissions make all of the following calls to adjust - -- optional: - -- these assignments may call Adjust: - -- 1: on the value resulting from the aggregate - -- 2: on Object once it's been assigned - -- 3: for a anonymous object created in the evaluation of the aggregate - -- 4: for a anonymous object created in the assignment operation - Bambino := ( Object with TC_XX => 10 ); - Check_Adjust_Count("Ancestor (expression) part of aggregate", 0, 2); - Check_Child_Adjust_Count("Child aggregate assignment 1", 0, 4 ); - - Bambino := ( C760007_0.Controlled with TC_XX => 11 ); - Check_Adjust_Count("Ancestor (subtype_mark) part of aggregate", 0, 2); - Check_Child_Adjust_Count("Child aggregate assignment 2", 0, 4 ); - - Examine( ( Object with TC_XX => 21 ) ); - - Examine( ( C760007_0.Controlled with TC_XX => 37 ) ); - - end Subtest_3; - -begin -- Main test procedure. - - Report.Test ("C760007", "Check that Adjust is called for the " & - "execution of a return statement for a " & - "function returning a result containing a " & - "controlled type. Check that Adjust is " & - "called when evaluating an aggregate " & - "component association for a controlled " & - "component. " & - "Check that Adjust is called for the " & - "assignment of the ancestor expression of an " & - "extension aggregate when the type of the " & - "aggregate is controlled" ); - - Subtest_1; - Subtest_2; - Subtest_3; - - Report.Result; - -end C760007; |