gcc/testsuite/ada/acats/tests/c7/c760007.a

   1 -- C760007.A
   2 --
   3 --                             Grant of Unlimited Rights
   4 --
   5 --     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
   6 --     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
   7 --     unlimited rights in the software and documentation contained herein.
   8 --     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making
   9 --     this public release, the Government intends to confer upon all
  10 --     recipients unlimited rights  equal to those held by the Government.
  11 --     These rights include rights to use, duplicate, release or disclose the
  12 --     released technical data and computer software in whole or in part, in
  13 --     any manner and for any purpose whatsoever, and to have or permit others
  14 --     to do so.
  15 --
  16 --                                    DISCLAIMER
  17 --
  18 --     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
  19 --     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
  20 --     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
  21 --     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
  22 --     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
  23 --     PARTICULAR PURPOSE OF SAID MATERIAL.
  24 --*
  25 --
  26 -- OBJECTIVE:
  27 --      Check that Adjust is called for the execution of a return
  28 --      statement for a function returning a result of a (non-limited)
  29 --      controlled type.
  30 --
  31 --      Check that Adjust is called when evaluating an aggregate
  32 --      component association for a controlled component.
  33 --
  34 --      Check that Adjust is called for the assignment of the ancestor
  35 --      expression of an extension aggregate when the type of the
  36 --      aggregate is controlled.
  37 --
  38 -- TEST DESCRIPTION:
  39 --      A type is derived from Ada.Finalization.Controlled; the dispatching
  40 --      procedure Adjust is defined for the new type.  Structures and
  41 --      subprograms to model the test objectives are used to check that
  42 --      Adjust is called at the right time.  For the sake of simplicity,
  43 --      globally accessible data is used to check that the calls are made.
  44 --
  45 --
  46 -- CHANGE HISTORY:
  47 --      06 DEC 94   SAIC    ACVC 2.0
  48 --      14 OCT 95   SAIC    Update and repair for ACVC 2.0.1
  49 --      05 APR 96   SAIC    Add RM reference
  50 --      06 NOV 96   SAIC    Reduce adjust requirement
  51 --      25 NOV 97   EDS     Allowed zero calls to adjust at line 144
  52 --!
  53
  54 ---------------------------------------------------------------- C760007_0
  55
  56 with Ada.Finalization;
  57 package C760007_0 is
  58
  59   type Controlled is new Ada.Finalization.Controlled with record
  60     TC_ID : Natural := Natural'Last;
  61   end record;
  62   procedure Adjust( Object: in out Controlled );
  63
  64   type Structure is record
  65     Controlled_Component : Controlled;
  66   end record;
  67
  68   type Child is new Controlled with record
  69     TC_XX : Natural := Natural'Last;
  70   end record;
  71   procedure Adjust( Object: in out Child );
  72
  73   Adjust_Count       : Natural := 0;
  74   Child_Adjust_Count : Natural := 0;
  75
  76 end C760007_0;
  77
  78 package body C760007_0 is
  79
  80   procedure Adjust( Object: in out Controlled ) is
  81   begin
  82     Adjust_Count := Adjust_Count +1;
  83   end Adjust;
  84
  85   procedure Adjust( Object: in out Child ) is
  86   begin
  87     Child_Adjust_Count := Child_Adjust_Count +1;
  88   end Adjust;
  89
  90 end C760007_0;
  91
  92 ------------------------------------------------------------------ C760007
  93
  94 with Report;
  95 with C760007_0;
  96 procedure C760007 is
  97
  98   procedure Check_Adjust_Count(Message: String;
  99                                Min: Natural := 1;
 100                                Max: Natural := 2) is
 101   begin
 102
 103      -- in order to allow for the anonymous objects referred to in
 104      -- the reference manual, the check for calls to Adjust must be
 105      -- in a range.  This number must then be further adjusted
 106      -- to allow for the optimization that does not call for an adjust
 107      -- of an aggregate initial value built directly in the object
 108
 109      if C760007_0.Adjust_Count not in Min..Max then
 110        Report.Failed(Message
 111                    & " = " & Natural'Image(C760007_0.Adjust_Count));
 112      end if;
 113      C760007_0.Adjust_Count := 0;
 114   end Check_Adjust_Count;
 115
 116   procedure Check_Child_Adjust_Count(Message: String;
 117                                      Min: Natural := 1;
 118                                      Max: Natural := 2) is
 119   begin
 120      -- ditto above
 121
 122      if C760007_0.Child_Adjust_Count not in Min..Max then
 123        Report.Failed(Message
 124                    & " = " & Natural'Image(C760007_0.Child_Adjust_Count));
 125      end if;
 126      C760007_0.Child_Adjust_Count := 0;
 127   end Check_Child_Adjust_Count;
 128
 129   Object : C760007_0.Controlled;
 130
 131 --      Check that Adjust is called for the execution of a return
 132 --      statement for a function returning a result of a (non-limited)
 133 --      controlled type or a result of a noncontrolled type with
 134 --      controlled components.
 135
 136   procedure Subtest_1 is
 137     function Create return C760007_0.Controlled is
 138       New_Object : C760007_0.Controlled;
 139     begin
 140       return New_Object;
 141     end Create;
 142
 143     procedure Examine( Thing : in C760007_0.Controlled ) is
 144     begin
 145       Check_Adjust_Count("Function call passed as parameter",0);
 146     end Examine;
 147
 148   begin
 149     -- this assignment must call Adjust:
 150     --   1: on the value resulting from the function
 151     --      ** unless this is optimized out by building the result directly
 152     --         in the target object.
 153     --   2: on Object once it's been assigned
 154     -- may call adjust
 155     --   1: for a anonymous object created in the evaluation of the function
 156     --   2: for a anonymous object created in the assignment operation
 157
 158     Object := Create;
 159
 160     Check_Adjust_Count("Function call",1,4);
 161
 162     Examine( Create );
 163
 164   end Subtest_1;
 165
 166 --      Check that Adjust is called when evaluating an aggregate
 167 --      component association for a controlled component.
 168
 169   procedure Subtest_2 is
 170     S : C760007_0.Structure;
 171
 172     procedure Examine( Thing : in C760007_0.Structure ) is
 173     begin
 174       Check_Adjust_Count("Aggregate passed as parameter");
 175     end Examine;
 176
 177   begin
 178     -- this assignment must call Adjust:
 179     --   1: on the value resulting from the aggregate
 180     --      ** unless this is optimized out by building the result directly
 181     --         in the target object.
 182     --   2: on Object once it's been assigned
 183     -- may call adjust
 184     --   1: for a anonymous object created in the evaluation of the aggregate
 185     --   2: for a anonymous object created in the assignment operation
 186     S := ( Controlled_Component => Object );
 187     Check_Adjust_Count("Aggregate and Assignment", 1, 4);
 188
 189     Examine( C760007_0.Structure'(Controlled_Component => Object) );
 190   end Subtest_2;
 191
 192 --      Check that Adjust is called for the assignment of the ancestor
 193 --      expression of an extension aggregate when the type of the
 194 --      aggregate is controlled.
 195
 196   procedure Subtest_3 is
 197     Bambino : C760007_0.Child;
 198
 199     procedure Examine( Thing : in C760007_0.Child ) is
 200     begin
 201       Check_Adjust_Count("Extension aggregate as parameter (ancestor)", 0, 2);
 202       Check_Child_Adjust_Count("Extension aggregate as parameter", 0, 4);
 203     end Examine;
 204
 205   begin
 206     -- implementation permissions make all of the following calls to adjust
 207     -- optional:
 208     -- these assignments may call Adjust:
 209     --   1: on the value resulting from the aggregate
 210     --   2: on Object once it's been assigned
 211     --   3: for a anonymous object created in the evaluation of the aggregate
 212     --   4: for a anonymous object created in the assignment operation
 213     Bambino := ( Object with TC_XX => 10 );
 214     Check_Adjust_Count("Ancestor (expression) part of aggregate", 0, 2);
 215     Check_Child_Adjust_Count("Child aggregate assignment 1", 0, 4 );
 216
 217     Bambino := ( C760007_0.Controlled with TC_XX => 11 );
 218     Check_Adjust_Count("Ancestor (subtype_mark) part of aggregate", 0, 2);
 219     Check_Child_Adjust_Count("Child aggregate assignment 2", 0, 4 );
 220
 221     Examine( ( Object with TC_XX => 21 ) );
 222
 223     Examine( ( C760007_0.Controlled with TC_XX => 37 ) );
 224
 225   end Subtest_3;
 226
 227 begin  -- Main test procedure.
 228
 229   Report.Test ("C760007", "Check that Adjust is called for the " &
 230                           "execution of a return statement for a " &
 231                           "function returning a result containing a " &
 232                           "controlled type.  Check that Adjust is " &
 233                           "called when evaluating an aggregate " &
 234                           "component association for a controlled " &
 235                           "component.  " &
 236                           "Check that Adjust is called for the " &
 237                           "assignment of the ancestor expression of an " &
 238                           "extension aggregate when the type of the " &
 239                           "aggregate is controlled" );
 240
 241   Subtest_1;
 242   Subtest_2;
 243   Subtest_3;
 244
 245   Report.Result;
 246
 247 end C760007;