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