cc51b03.a

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

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