Subversion Repositories openrisc

-- CC51B03.A

--

--                             Grant of Unlimited Rights

--

--     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,

--     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained

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

--     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making

--     this public release, the Government intends to confer upon all

--     recipients unlimited rights  equal to those held by the Government.

--     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 attribute S'Definite, where S is an indefinite formal

--      private or derived type, returns true if the actual corresponding to

--      S is definite, and returns false otherwise.

--

-- TEST DESCRIPTION:

--      A definite subtype is any subtype which is not indefinite. An

--      indefinite subtype is either:

--         a) An unconstrained array subtype.

--         b) A subtype with unknown discriminants (this includes class-wide

--            types).

--         c) A subtype with unconstrained discriminants without defaults.

--

--      The possible forms of indefinite formal subtype are as follows:

--

--         Formal derived types:

--          X - Ancestor is an unconstrained array type

--          * - Ancestor is a discriminated record type without defaults

--          X - Ancestor is a discriminated tagged type

--          * - Ancestor type has unknown discriminants

--            - Formal type has an unknown discriminant part

--          * - Formal type has a known discriminant part

--

--         Formal private types:

--            - Formal type has an unknown discriminant part

--          * - Formal type has a known discriminant part

--

--      The formal subtypes preceded by an 'X' above are not covered, because

--      other rules prevent a definite subtype from being passed as an actual.

--      The formal subtypes preceded by an '*' above are not covered, because

--      'Definite is less likely to be used for these formals.

--

--      The following kinds of actuals are passed to various of the formal

--      types listed above:

--

--            - Undiscriminated type

--            - Type with defaulted discriminants

--            - Type with undefaulted discriminants

--            - Class-wide type

--

--      A typical usage of S'Definite might be algorithm selection in a

--      generic I/O package, e.g., the use of fixed-length or variable-length

--      records depending on whether the actual is definite or indefinite.

--      In such situations, S'Definite would appear in if conditions or other

--      contexts requiring a boolean expression. This test checks S'Definite

--      in such usage contexts but, for brevity, omits any surrounding

--      usage code.

--

-- TEST FILES:

--      The following files comprise this test:

--

--         FC51B00.A

--      -> CC51B03.A

--

--

-- CHANGE HISTORY:

--      06 Dec 94   SAIC    ACVC 2.0

--

--!

with FC51B00;  -- Indefinite subtype declarations.

package CC51B03_0 is

   --

   -- Formal private type cases:

   --

   generic

      type Formal (<>) is private;              -- Formal has unknown

   package PrivateFormalUnknownDiscriminants is -- discriminant part.

      function Is_Definite return Boolean;

   end PrivateFormalUnknownDiscriminants;

   --

   -- Formal derived type cases:

   --

   generic

      type Formal (<>) is new FC51B00.Vector    -- Formal has an unknown disc.

        with private;                           -- part; ancestor is tagged.

   package TaggedAncestorUnknownDiscriminants is

      function Is_Definite return Boolean;

   end TaggedAncestorUnknownDiscriminants;

end CC51B03_0;

     --==================================================================--

package body CC51B03_0 is

   package body PrivateFormalUnknownDiscriminants is

      function Is_Definite return Boolean is

      begin

         if Formal'Definite then                -- Attribute used in "if"

            -- ...Execute algorithm #1...       -- condition inside subprogram.

            return True;

         else

            -- ...Execute algorithm #2...

            return False;

         end if;

      end Is_Definite;

   end PrivateFormalUnknownDiscriminants;

   package body TaggedAncestorUnknownDiscriminants is

      function Is_Definite return Boolean is

      begin

         return Formal'Definite;                -- Attribute used in return

      end Is_Definite;                          -- statement inside subprogram.

   end TaggedAncestorUnknownDiscriminants;

end CC51B03_0;

     --==================================================================--

with FC51B00;

package CC51B03_1 is

   subtype Spin_Type is Natural range 0 .. 3;

   type Extended_Vector (Spin : Spin_Type) is   -- Tagged type with

     new FC51B00.Vector with null record;       -- discriminant (indefinite).

end CC51B03_1;

     --==================================================================--

with FC51B00;   -- Indefinite subtype declarations.

with CC51B03_0; -- Generic package declarations.

with CC51B03_1;

with Report;

procedure CC51B03 is

   --

   -- Instances for formal private type with unknown discriminants:

   --

   package PrivateFormal_UndiscriminatedTaggedActual is new

     CC51B03_0.PrivateFormalUnknownDiscriminants (FC51B00.Vector);

   package PrivateFormal_ClassWideActual is new

     CC51B03_0.PrivateFormalUnknownDiscriminants (FC51B00.Vector'Class);

   package PrivateFormal_DiscriminatedTaggedActual is new

     CC51B03_0.PrivateFormalUnknownDiscriminants (FC51B00.Square_Pair);

   package PrivateFormal_DiscriminatedUndefaultedRecordActual is new

     CC51B03_0.PrivateFormalUnknownDiscriminants (FC51B00.Square);

   subtype Length is Natural range 0 .. 20;

   type Message (Len : Length := 0) is record   -- Record type with defaulted

      Text : String (1 .. Len);                 -- discriminant (definite).

   end record;

   package PrivateFormal_DiscriminatedDefaultedRecordActual is new

     CC51B03_0.PrivateFormalUnknownDiscriminants (Message);

   --

   -- Instances for formal derived tagged type with unknown discriminants:

   --

   package DerivedFormal_UndiscriminatedTaggedActual is new

     CC51B03_0.TaggedAncestorUnknownDiscriminants (FC51B00.Vector);

   package DerivedFormal_ClassWideActual is new

     CC51B03_0.TaggedAncestorUnknownDiscriminants (FC51B00.Vector'Class);

   package DerivedFormal_DiscriminatedTaggedActual is new

     CC51B03_0.TaggedAncestorUnknownDiscriminants (CC51B03_1.Extended_Vector);

begin

   Report.Test ("CC51B03", "Check that S'Definite returns true if the " &

                "actual corresponding to S is definite, and false otherwise");

   if not PrivateFormal_UndiscriminatedTaggedActual.Is_Definite then

      Report.Failed ("Formal private/unknown discriminants: wrong " &

                     "result for undiscriminated tagged actual");

   end if;

   if PrivateFormal_ClassWideActual.Is_Definite then

      Report.Failed ("Formal private/unknown discriminants: wrong " &

                     "result for class-wide actual");

   end if;

   if PrivateFormal_DiscriminatedTaggedActual.Is_Definite then

      Report.Failed ("Formal private/unknown discriminants: wrong " &

                     "result for discriminated tagged actual");

   end if;

   if PrivateFormal_DiscriminatedUndefaultedRecordActual.Is_Definite then

      Report.Failed ("Formal private/unknown discriminants: wrong result " &

                     "for record actual with undefaulted discriminants");

   end if;

   if not PrivateFormal_DiscriminatedDefaultedRecordActual.Is_Definite then

      Report.Failed ("Formal private/unknown discriminants: wrong result " &

                     "for record actual with defaulted discriminants");

   end if;

   if not DerivedFormal_UndiscriminatedTaggedActual.Is_Definite then

      Report.Failed ("Formal derived/unknown discriminants: wrong result " &

                     "for undiscriminated tagged actual");

   end if;

   if DerivedFormal_ClassWideActual.Is_Definite then

      Report.Failed ("Formal derived/unknown discriminants: wrong result " &

                     "for class-wide actual");

   end if;

   if DerivedFormal_DiscriminatedTaggedActual.Is_Definite then

      Report.Failed ("Formal derived/unknown discriminants: wrong result " &

                     "for discriminated tagged actual");

   end if;

   Report.Result;

end CC51B03;