Subversion Repositories openrisc

-- C761010.A

--

--                             Grant of Unlimited Rights

--

--     The Ada Conformity Assessment Authority (ACAA) holds unlimited

--     rights in the software and documentation contained herein. Unlimited

--     rights are the same as those granted by the U.S. Government for older

--     parts of the Ada Conformity Assessment Test Suite, and are defined

--     in DFAR 252.227-7013(a)(19). By making this public release, the ACAA

--     intends to confer upon all recipients unlimited rights equal to those

--     held by the ACAA. 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 WHATSOVER, 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 the requirements of the new 7.6(17.1/1) from Technical

--     Corrigendum 1 (originally discussed as AI95-00083).

--     This new paragraph requires that the initialization of an object with

--     an aggregate does not involve calls to Adjust.

--

-- TEST DESCRIPTION

--     We include several cases of initialization:

--        - Explicit initialization of an object declared by an

--          object declaration.

--        - Explicit initialization of a heap object.

--        - Default initialization of a record component.

--        - Initialization of a formal parameter during a call.

--        - Initialization of a formal parameter during a call with

--          a defaulted parameter.

--        - Lots of nested records, arrays, and pointers.

--     In this test, Initialize should never be called, because we

--     never declare a default-initialized controlled object (although

--     we do declare default-initialized records containing controlled

--     objects, with default expressions for the components).

--     Adjust should never be called, because every initialization

--     is via an aggregate.  Finalize is called, because the objects

--     themselves need to be finalized.

--     Thus, Initialize and Adjust call Failed.

--     In some of the cases, these procedures will not yet be elaborated,

--     anyway.

--

-- CHANGE HISTORY:

--      29 JUN 1999   RAD   Initial Version

--      23 SEP 1999   RLB   Improved comments, renamed, issued.

--      10 APR 2000   RLB   Corrected errors in comments and text, fixed

--                          discriminant error. Fixed so that Report.Test

--                          is called before any Report.Failed call. Added

--                          a marker so that the failed subtest can be

--                          determined.

--      26 APR 2000   RAD   Try to defeat optimizations.

--      04 AUG 2000   RLB   Corrected error in Check_Equal.

--      18 AUG 2000   RLB   Removed dubious main subprogram renames (see AI-172).

--      19 JUL 2002   RLB   Fixed to avoid calling comment after Report.Result.

--

--!

with Ada; use Ada;

with Report; use Report; pragma Elaborate_All(Report);

with Ada.Finalization;

package C761010_1 is

    pragma Elaborate_Body;

    function Square(X: Integer) return Integer;

private

    type TC_Control is new Ada.Finalization.Limited_Controlled with null record;

    procedure Initialize (Object : in out TC_Control);

    procedure Finalize (Object : in out TC_Control);

    TC_Finalize_Called : Boolean := False;

end C761010_1;

package body C761010_1 is

    function Square(X: Integer) return Integer is

    begin

        return X**2;

    end Square;

    procedure Initialize (Object : in out TC_Control) is

    begin

        Test("C761010_1",

             "Check that Adjust is not called"

              & " when aggregates are used to initialize objects");

    end Initialize;

    procedure Finalize (Object : in out TC_Control) is

    begin

        if not TC_Finalize_Called then

            Failed("Var_Strings Finalize never called");

        end if;

        Result;

    end Finalize;

    TC_Test : TC_Control; -- Starts test; finalization ends test.

end C761010_1;

with Ada.Finalization;

package C761010_1.Var_Strings is

    type Var_String(<>) is private;

    Some_String: constant Var_String;

    function "=" (X, Y: Var_String) return Boolean;

    procedure Check_Equal(X, Y: Var_String);

        -- Calls to this are used to defeat optimizations

        -- that might otherwise defeat the purpose of the

        -- test.  I'm talking about the optimization of removing

        -- unused controlled objects.

private

    type String_Ptr is access constant String;

    type Var_String(Length: Natural) is new Finalization.Controlled with

        record

            Comp_1: String_Ptr := new String'(2..Square(Length)-1 => 'x');

            Comp_2: String_Ptr(1..Length) := null;

            Comp_3: String(Length..Length) := (others => '.');

            TC_Lab: Character := '1';

        end record;

    procedure Initialize(X: in out Var_String);

    procedure Adjust(X: in out Var_String);

    procedure Finalize(X: in out Var_String);

    Some_String: constant Var_String

      := (Finalization.Controlled with Length => 1,

          Comp_1 => null,

          Comp_2 => null,

          Comp_3 => "x",

          TC_Lab => 'A');

    Another_String: constant Var_String

      := (Finalization.Controlled with Length => 10,

          Comp_1 => Some_String.Comp_2,

          Comp_2 => new String'("1234567890"),

          Comp_3 => "x",

          TC_Lab => 'B');

end C761010_1.Var_Strings;

package C761010_1.Var_Strings.Types is

    type Ptr is access all Var_String;

    Ptr_Const: constant Ptr;

    type Ptr_Arr is array(Positive range <>) of Ptr;

    Ptr_Arr_Const: constant Ptr_Arr;

    type Ptr_Rec(N_Strings: Natural) is

        record

            Ptrs: Ptr_Arr(1..N_Strings);

        end record;

    Ptr_Rec_Const: constant Ptr_Rec;

private

    Ptr_Const: constant Ptr := new Var_String'

      (Finalization.Controlled with

       Length => 1,

       Comp_1 => null,

       Comp_2 => null,

       Comp_3 => (others => ' '),

       TC_Lab => 'C');

    Ptr_Arr_Const: constant Ptr_Arr :=

      (1 => new Var_String'

       (Finalization.Controlled with

        Length => 1,

        Comp_1 => new String'("abcdefghij"),

        Comp_2 => null,

        Comp_3 => (2..2 => ' '),

        TC_Lab => 'D'));

    Ptr_Rec_Var: Ptr_Rec :=

      (3,

       (1..2 => null,

        3 => new Var_String'

        (Finalization.Controlled with

         Length => 2,

         Comp_1 => new String'("abcdefghij"),

         Comp_2 => null,

         Comp_3 => (2..2 => ' '),

         TC_Lab => 'E')));

    Ptr_Rec_Const: constant Ptr_Rec :=

      (3,

       (1..2 => null,

        3 => new Var_String'

        (Finalization.Controlled with

         Length => 2,

         Comp_1 => new String'("abcdefghij"),

         Comp_2 => null,

         Comp_3 => (2..2 => ' '),

         TC_Lab => 'F')));

    type Arr is array(Positive range <>) of Var_String(Length => 2);

    Arr_Var: Arr :=

      (1 => (Finalization.Controlled with

         Length => 2,

         Comp_1 => new String'("abcdefghij"),

         Comp_2 => null,

         Comp_3 => (2..2 => ' '),

         TC_Lab => 'G'));

    type Rec(N_Strings: Natural) is

        record

            Ptrs: Ptr_Rec(N_Strings);

            Strings: Arr(1..N_Strings) :=

              (others =>

                 (Finalization.Controlled with

                  Length => 2,

                  Comp_1 => new String'("abcdefghij"),

                  Comp_2 => null,

                  Comp_3 => (2..2 => ' '),

                  TC_Lab => 'H'));

        end record;

    Default_Init_Rec_Var: Rec(N_Strings => 10);

    Empty_Default_Init_Rec_Var: Rec(N_Strings => 0);

    Rec_Var: Rec(N_Strings => 2) :=

      (N_Strings => 2,

       Ptrs =>

         (2,

          (1..1 => null,

           2 => new Var_String'

           (Finalization.Controlled with

            Length => 2,

            Comp_1 => new String'("abcdefghij"),

            Comp_2 => null,

            Comp_3 => (2..2 => ' '),

            TC_Lab => 'J'))),

       Strings =>

         (1 =>

            (Finalization.Controlled with

             Length => 2,

             Comp_1 => new String'("abcdefghij"),

             Comp_2 => null,

             Comp_3 => (2..2 => ' '),

             TC_Lab => 'K'),

          others =>

            (Finalization.Controlled with

             Length => 2,

             Comp_1 => new String'("abcdefghij"),

             Comp_2 => null,

             Comp_3 => (2..2 => ' '),

             TC_Lab => 'L')));

    procedure Check_Equal(X, Y: Rec);

end C761010_1.Var_Strings.Types;

package body C761010_1.Var_Strings.Types is

    -- Check that parameter passing doesn't create new objects,

    -- and therefore doesn't need extra Adjusts or Finalizes.

    procedure Check_Equal(X, Y: Rec) is

        -- We assume that the arguments should be equal.

        -- But we cannot assume that pointer values are the same.

    begin

        if X.N_Strings /= Y.N_Strings then

            Failed("Records should be equal (1)");

        else

            for I in 1 .. X.N_Strings loop

                if X.Ptrs.Ptrs(I) /= Y.Ptrs.Ptrs(I) then

                    if X.Ptrs.Ptrs(I) = null or else

                       Y.Ptrs.Ptrs(I) = null or else

                       X.Ptrs.Ptrs(I).all /= Y.Ptrs.Ptrs(I).all then

                       Failed("Records should be equal (2)");

                    end if;

                end if;

                if X.Strings(I) /= Y.Strings(I) then

                    Failed("Records should be equal (3)");

                end if;

            end loop;

        end if;

    end Check_Equal;

    procedure My_Check_Equal

              (X: Rec := Rec_Var;

               Y: Rec :=

      (N_Strings => 2,

       Ptrs =>

         (2,

          (1..1 => null,

           2 => new Var_String'

           (Finalization.Controlled with

            Length => 2,

            Comp_1 => new String'("abcdefghij"),

            Comp_2 => null,

            Comp_3 => (2..2 => ' '),

            TC_Lab => 'M'))),

       Strings =>

         (1 =>

            (Finalization.Controlled with

             Length => 2,

             Comp_1 => new String'("abcdefghij"),

             Comp_2 => null,

             Comp_3 => (2..2 => ' '),

             TC_Lab => 'N'),

          others =>

            (Finalization.Controlled with

             Length => 2,

             Comp_1 => new String'("abcdefghij"),

             Comp_2 => null,

             Comp_3 => (2..2 => ' '),

             TC_Lab => 'O'))))

              renames Check_Equal;

begin

    My_Check_Equal;

    Check_Equal(Rec_Var,

      (N_Strings => 2,

       Ptrs =>

         (2,

          (1..1 => null,

           2 => new Var_String'

           (Finalization.Controlled with

            Length => 2,

            Comp_1 => new String'("abcdefghij"),

            Comp_2 => null,

            Comp_3 => (2..2 => ' '),

            TC_Lab => 'P'))),

       Strings =>

         (1 =>

            (Finalization.Controlled with

             Length => 2,

             Comp_1 => new String'("abcdefghij"),

             Comp_2 => null,

             Comp_3 => (2..2 => ' '),

             TC_Lab => 'Q'),

          others =>

            (Finalization.Controlled with

             Length => 2,

             Comp_1 => new String'("abcdefghij"),

             Comp_2 => null,

             Comp_3 => (2..2 => ' '),

             TC_Lab => 'R'))));

    -- Use the objects to avoid optimizations.

    Check_Equal(Ptr_Const.all, Ptr_Const.all);

    Check_Equal(Ptr_Arr_Const(1).all, Ptr_Arr_Const(1).all);

    Check_Equal(Ptr_Rec_Const.Ptrs(Ptr_Rec_Const.N_Strings).all,

                Ptr_Rec_Const.Ptrs(Ptr_Rec_Const.N_Strings).all);

    Check_Equal(Ptr_Rec_Var.Ptrs(Ptr_Rec_Var.N_Strings).all,

                Ptr_Rec_Var.Ptrs(Ptr_Rec_Var.N_Strings).all);

    if Report.Equal (3, 2) then

       -- Can't get here.

       Check_Equal (Arr_Var(1), Default_Init_Rec_Var.Strings(1));

       Check_Equal (Arr_Var(1), Empty_Default_Init_Rec_Var.Strings(1));

    end if;

end C761010_1.Var_Strings.Types;

with C761010_1.Var_Strings;

with C761010_1.Var_Strings.Types;

procedure C761010_1.Main is

begin

    -- Report.Test is called by the elaboration of C761010_1, and

    -- Report.Result is called by the finalization of C761010_1.

    -- This will happen before any objects are created, and after any

    -- are finalized.

    null;

end C761010_1.Main;

with C761010_1.Main;

procedure C761010 is

begin

    C761010_1.Main;

end C761010;

package body C761010_1.Var_Strings is

    Some_Error: exception;

    procedure Initialize(X: in out Var_String) is

    begin

        Failed("Initialize should never be called");

        raise Some_Error;

    end Initialize;

    procedure Adjust(X: in out Var_String) is

    begin

        Failed("Adjust should never be called - case " & X.TC_Lab);

        raise Some_Error;

    end Adjust;

    procedure Finalize(X: in out Var_String) is

    begin

        Comment("Finalize called - case " & X.TC_Lab);

        C761010_1.TC_Finalize_Called := True;

    end Finalize;

    function "=" (X, Y: Var_String) return Boolean is

        -- Don't check the TC_Lab component, but do check the contents of the

        -- access values.

    begin

        if X.Length /= Y.Length then

            return False;

        end if;

        if X.Comp_3 /= Y.Comp_3 then

            return False;

        end if;

        if X.Comp_1 /= Y.Comp_1 then

            -- Still OK if the values are the same.

            if X.Comp_1 = null or else

               Y.Comp_1 = null or else

               X.Comp_1.all /= Y.Comp_1.all then

               return False;

            --else OK.

            end if;

        end if;

        if X.Comp_2 /= Y.Comp_2 then

            -- Still OK if the values are the same.

            if X.Comp_2 = null or else

               Y.Comp_2 = null or else

               X.Comp_2.all /= Y.Comp_2.all then

               return False;

            end if;

        end if;

        return True;

    end "=";

    procedure Check_Equal(X, Y: Var_String) is

    begin

        if X /= Y then

            Failed("Check_Equal of Var_String");

        end if;

    end Check_Equal;

begin

    Check_Equal(Another_String, Another_String);

end C761010_1.Var_Strings;