Subversion Repositories openrisc_me

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