c760007.a

来自「linux下编程用 编译软件」· A 代码 · 共 248 行

-- 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;