c761010.a

用于进行gcc测试

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