cdd2a02.a

来自「用于进行gcc测试」· A 代码 · 共 346 行

-- CDD2A02.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 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 the Read, Write, Input, and Output attributes are inherited
--    for untagged derived types.  (Defect Report 8652/0040,
--     as reflected in Technical Corrigendum 1, 13.13.2(8.1/1) and
--     13.13.2(25/1)).
--
-- CHANGE HISTORY:
--    30 JUL 2001   PHL   Initial version.
--     5 DEC 2001   RLB   Reformatted for ACATS.
--
--!
with Ada.Streams;
use Ada.Streams;
with FDD2A00;
use FDD2A00;
with Report;
use Report;
procedure CDD2A02 is

    type Int is range 1 .. 10;
    type Str is array (Int range <>) of Character;

    procedure Read (Stream : access Root_Stream_Type'Class;
                    Item : out Int'Base);
    procedure Write (Stream : access Root_Stream_Type'Class; Item : Int'Base);
    function Input (Stream : access Root_Stream_Type'Class) return Int'Base;
    procedure Output (Stream : access Root_Stream_Type'Class; Item : Int'Base);

    for Int'Read use Read;
    for Int'Write use Write;
    for Int'Input use Input;
    for Int'Output use Output;


    type Parent (D1, D2 : Int; B : Boolean) is
        record
            S : Str (D1 .. D2);
            case B is
                when False =>
                    C1 : Integer;
                when True =>
                    C2 : Float;
            end case;
        end record;

    procedure Read (Stream : access Root_Stream_Type'Class; Item : out Parent);
    procedure Write (Stream : access Root_Stream_Type'Class; Item : Parent);
    function Input (Stream : access Root_Stream_Type'Class) return Parent;
    procedure Output (Stream : access Root_Stream_Type'Class; Item : Parent);

    for Parent'Read use Read;
    for Parent'Write use Write;
    for Parent'Input use Input;
    for Parent'Output use Output;


    procedure Actual_Read
                 (Stream : access Root_Stream_Type'Class; Item : out Int) is
    begin
        Integer'Read (Stream, Integer (Item));
    end Actual_Read;

    procedure Actual_Write
                 (Stream : access Root_Stream_Type'Class; Item : Int) is
    begin
        Integer'Write (Stream, Integer (Item));
    end Actual_Write;

    function Actual_Input (Stream : access Root_Stream_Type'Class) return Int is
    begin
        return Int (Integer'Input (Stream));
    end Actual_Input;

    procedure Actual_Output
                 (Stream : access Root_Stream_Type'Class; Item : Int) is
    begin
        Integer'Output (Stream, Integer (Item));
    end Actual_Output;


    procedure Actual_Read
                 (Stream : access Root_Stream_Type'Class; Item : out Parent) is
    begin
        case Item.B is
            when False =>
                Item.C1 := 7;
            when True =>
                Float'Read (Stream, Item.C2);
        end case;
        Str'Read (Stream, Item.S);
    end Actual_Read;

    procedure Actual_Write
                 (Stream : access Root_Stream_Type'Class; Item : Parent) is
    begin
        case Item.B is
            when False =>
                null; -- Don't write C1
            when True =>
                Float'Write (Stream, Item.C2);
        end case;
        Str'Write (Stream, Item.S);
    end Actual_Write;

    function Actual_Input
                (Stream : access Root_Stream_Type'Class) return Parent is
        D1, D2 : Int;
        B : Boolean;
    begin
        Int'Read (Stream, D2);
        Boolean'Read (Stream, B);
        Int'Read (Stream, D1);

        declare
            Item : Parent (D1 => D1, D2 => D2, B => B);
        begin
            Parent'Read (Stream, Item);
            return Item;
        end;

    end Actual_Input;

    procedure Actual_Output
                 (Stream : access Root_Stream_Type'Class; Item : Parent) is
    begin
        Int'Write (Stream, Item.D2);
        Boolean'Write (Stream, Item.B);
        Int'Write (Stream, Item.D1);
        Parent'Write (Stream, Item);
    end Actual_Output;

    package Int_Ops is new Counting_Stream_Ops (T => Int'Base,
                                                Actual_Write => Actual_Write,
                                                Actual_Input => Actual_Input,
                                                Actual_Read => Actual_Read,
                                                Actual_Output => Actual_Output);

    package Parent_Ops is
       new Counting_Stream_Ops (T => Parent,
                                Actual_Write => Actual_Write,
                                Actual_Input => Actual_Input,
                                Actual_Read => Actual_Read,
                                Actual_Output => Actual_Output);

    procedure Read (Stream : access Root_Stream_Type'Class; Item : out Int'Base)
       renames Int_Ops.Read;
    procedure Write (Stream : access Root_Stream_Type'Class; Item : Int'Base)
       renames Int_Ops.Write;
    function Input (Stream : access Root_Stream_Type'Class) return Int'Base
       renames Int_Ops.Input;
    procedure Output (Stream : access Root_Stream_Type'Class; Item : Int'Base)
       renames Int_Ops.Output;

    procedure Read (Stream : access Root_Stream_Type'Class; Item : out Parent)
       renames Parent_Ops.Read;
    procedure Write (Stream : access Root_Stream_Type'Class; Item : Parent)
       renames Parent_Ops.Write;
    function Input (Stream : access Root_Stream_Type'Class) return Parent
       renames Parent_Ops.Input;
    procedure Output (Stream : access Root_Stream_Type'Class; Item : Parent)
       renames Parent_Ops.Output;

begin
    Test ("CDD2A02", "Check that the Read, Write, Input, and Output " &
                     "attributes are inherited for untagged derived types");

    Test1:
        declare
            type Derived1 is new Parent;
            S : aliased My_Stream (1000);
            X1 : Derived1 (D1 => Int (Ident_Int (2)),
                           D2 => Int (Ident_Int (5)), B => Ident_Bool (True));
            Y1 : Derived1 := (D1 => 3,
                              D2 => 6,
                              B => False,
                              S => Str (Ident_Str ("3456")),
                              C1 => Ident_Int (100));
            X2 : Derived1 (D1 => Int (Ident_Int (2)),
                           D2 => Int (Ident_Int (5)), B => Ident_Bool (True));
        begin
            X1.S := Str (Ident_Str ("bcde"));
            X1.C2 := Float (Ident_Int (4));

            Derived1'Write (S'Access, X1);
            if Int_Ops.Get_Counts /=
               (Read => 0, Write => 0, Input => 0, Output => 0) then
                Failed ("Error writing discriminants - 1");
            end if;
            if Parent_Ops.Get_Counts /=
               (Read => 0, Write => 1, Input => 0, Output => 0) then
                Failed ("Didn't call inherited Write - 1");
            end if;

            Derived1'Read (S'Access, X2);
            if Int_Ops.Get_Counts /=
               (Read => 0, Write => 0, Input => 0, Output => 0) then
                Failed ("Error reading discriminants - 1");
            end if;
            if Parent_Ops.Get_Counts /=
               (Read => 1, Write => 1, Input => 0, Output => 0) then
                Failed ("Didn't call inherited Read - 1");
            end if;

            if X2 /= (D1 => 2,
                      D2 => 5,
                      B => True,
                      S => Str (Ident_Str ("bcde")),
                      C2 => Float (Ident_Int (4))) then
                Failed
                   ("Inherited Read and Write are not inverses of each other - 1");
            end if;

            Derived1'Output (S'Access, Y1);
            if Int_Ops.Get_Counts /=
               (Read => 0, Write => 2, Input => 0, Output => 0) then
                Failed ("Error writing discriminants - 2");
            end if;
            if Parent_Ops.Get_Counts /=
               (Read => 1, Write => 2, Input => 0, Output => 1) then
                Failed ("Didn't call inherited Output - 2");
            end if;

            declare
                Y2 : Derived1 := Derived1'Input (S'Access);
            begin
                if Int_Ops.Get_Counts /=
                   (Read => 2, Write => 2, Input => 0, Output => 0) then
                    Failed ("Error reading discriminants - 2");
                end if;
                if Parent_Ops.Get_Counts /=
                   (Read => 2, Write => 2, Input => 1, Output => 1) then
                    Failed ("Didn't call inherited Input - 2");
                end if;

                if Y2 /= (D1 => 3,
                          D2 => 6,
                          B => False,
                          S => Str (Ident_Str ("3456")),
                          C1 => Ident_Int (7)) then
                    Failed
                       ("Inherited Input and Output are not inverses of each other - 2");
                end if;
            end;
        end Test1;

    Test2:
        declare
            type Derived2 (D : Int) is new Parent (D1 => D,
                                                   D2 => D,
                                                   B => False);
            S : aliased My_Stream (1000);
            X1 : Derived2 (D => Int (Ident_Int (7)));
            Y1 : Derived2 := (D => 8,
                              S => Str (Ident_Str ("8")),
                              C1 => Ident_Int (200));
            X2 : Derived2 (D => Int (Ident_Int (7)));
        begin
            X1.S := Str (Ident_Str ("g"));
            X1.C1 := Ident_Int (4);

            Derived2'Write (S'Access, X1);
            if Int_Ops.Get_Counts /=
               (Read => 2, Write => 2, Input => 0, Output => 0) then
                Failed ("Error writing discriminants - 3");
            end if;
            if Parent_Ops.Get_Counts /=
               (Read => 2, Write => 3, Input => 1, Output => 1) then
                Failed ("Didn't call inherited Write - 3");
            end if;

            Derived2'Read (S'Access, X2);
            if Int_Ops.Get_Counts /=
               (Read => 2, Write => 2, Input => 0, Output => 0) then
                Failed ("Error reading discriminants - 3");
            end if;
            if Parent_Ops.Get_Counts /=
               (Read => 3, Write => 3, Input => 1, Output => 1) then
                Failed ("Didn't call inherited Read - 3");
            end if;

            if X2 /= (D => 7,
                      S => Str (Ident_Str ("g")),
                      C1 => Ident_Int (7)) then
                Failed
                   ("Inherited Read and Write are not inverses of each other - 3");
            end if;

            Derived2'Output (S'Access, Y1);
            if Int_Ops.Get_Counts /=
               (Read => 2, Write => 4, Input => 0, Output => 0) then
                Failed ("Error writing discriminants - 4");
            end if;
            if Parent_Ops.Get_Counts /=
               (Read => 3, Write => 4, Input => 1, Output => 2) then
                Failed ("Didn't call inherited Output - 4");
            end if;

            declare
                Y2 : Derived2 := Derived2'Input (S'Access);
            begin
                if Int_Ops.Get_Counts /=
                   (Read => 4, Write => 4, Input => 0, Output => 0) then
                    Failed ("Error reading discriminants - 4");
                end if;
                if Parent_Ops.Get_Counts /=
                   (Read => 4, Write => 4, Input => 2, Output => 2) then
                    Failed ("Didn't call inherited Input - 4");
                end if;

                if Y2 /= (D => 8,
                          S => Str (Ident_Str ("8")),
                          C1 => Ident_Int (7)) then
                    Failed
                       ("Inherited Input and Output are not inverses of each other - 4");
                end if;
            end;
        end Test2;

    Result;
end CDD2A02;