Subversion Repositories openrisc_me

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