diff options
Diffstat (limited to 'gcc-4.9/gcc/testsuite/ada/acats/tests/cc/cc51b03.a')
| -rw-r--r-- | gcc-4.9/gcc/testsuite/ada/acats/tests/cc/cc51b03.a | 258 |
1 files changed, 258 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/cc/cc51b03.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/cc/cc51b03.a new file mode 100644 index 000000000..0cbeeb46f --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/cc/cc51b03.a @@ -0,0 +1,258 @@ +-- 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; |