path: root/gcc/testsuite/ada/acats/tests/cd/cdd2a03.a

-- CDD2A03.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 default Read and Write attributes for a limited type
--    extension are created from the parent type's attribute (which may be
--    user-defined) and those for the extension components, if the extension
--    components are non-limited or have user-defined attributes.  Check that
--    such limited type extension attributes are callable (Defect Report
--    8652/0040, as reflected in Technical Corrigendum 1, penultimate sentence
--     of 13.13.2(9/1) and 13.13.2(36/1)).
--
-- CHANGE HISTORY:
--     1 AUG 2001   PHL   Initial version.
--     3 DEC 2001   RLB   Reformatted for ACATS.
--
--!
with Ada.Streams;
use Ada.Streams;
with FDD2A00;
use FDD2A00;
with Report;
use Report;
procedure CDD2A03 is

    Input_Output_Error : exception;

    type Int is range 1 .. 1000;
    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 Lim is limited
        record
            C : Int;
        end record;

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

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


    type Parent (D1, D2 : Int; B : Boolean) is tagged limited
        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 Lim) is
    begin
        Integer'Read (Stream, Integer (Item.C));
    end Actual_Read;

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

    function Actual_Input (Stream : access Root_Stream_Type'Class) return Lim is
        Result : Lim;
    begin
        Result.C := Int (Integer'Input (Stream));
        return Result;
    end Actual_Input;

    procedure Actual_Output
                 (Stream : access Root_Stream_Type'Class; Item : Lim) is
    begin
        Integer'Output (Stream, Integer (Item.C));
    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
        X : Parent (1, 1, True);
    begin
        raise Input_Output_Error;
        return X;
    end Actual_Input;

    procedure Actual_Output
                 (Stream : access Root_Stream_Type'Class; Item : Parent) is
    begin
        raise Input_Output_Error;
    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 Lim_Ops is new Counting_Stream_Ops (T => Lim,
                                                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 Lim)
       renames Lim_Ops.Read;
    procedure Write (Stream : access Root_Stream_Type'Class; Item : Lim)
       renames Lim_Ops.Write;
    function Input (Stream : access Root_Stream_Type'Class) return Lim
       renames Lim_Ops.Input;
    procedure Output (Stream : access Root_Stream_Type'Class; Item : Lim)
       renames Lim_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;

    type Derived1 is new Parent with
        record
            C3 : Int;
        end record;

    type Derived2 (D : Int) is new Parent (D1 => D,
                                           D2 => D,
                                           B => False) with
        record
            C3 : Lim;
        end record;

begin
    Test ("CDD2A03",
          "Check that the default Read and Write attributes for a limited " &
             "type extension are created from the parent type's " &
             "attribute (which may be user-defined) and those for the " &
             "extension components, if the extension components are " &
             "non-limited or have user-defined attributes; check that such " &
             "limited type extension attributes are callable");

    Test1:
        declare
            S : aliased My_Stream (1000);
            X1 : Derived1 (D1 => Int (Ident_Int (2)),
                           D2 => Int (Ident_Int (5)),
                           B => Ident_Bool (True));
            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));
            X1.C3 := Int (Ident_Int (99));

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

            Derived1'Read (S'Access, X2);
            if Int_Ops.Get_Counts /=
               (Read => 1, Write => 1, Input => 0, Output => 0) then
                Failed ("Error reading extension components - 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;
        end Test1;

    Test2:
        declare
            S : aliased My_Stream (1000);
            X1 : Derived2 (D => Int (Ident_Int (7)));
            X2 : Derived2 (D => Int (Ident_Int (7)));
        begin
            X1.S := Str (Ident_Str ("g"));
            X1.C1 := Ident_Int (4);
            X1.C3.C := Int (Ident_Int (666));

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

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

    Result;
end CDD2A03;