1-- CC51B03.A
2--
3--                             Grant of Unlimited Rights
4--
5--     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
6--     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
7--     unlimited rights in the software and documentation contained herein.
8--     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making
9--     this public release, the Government intends to confer upon all
10--     recipients unlimited rights  equal to those held by the Government.
11--     These rights include rights to use, duplicate, release or disclose the
12--     released technical data and computer software in whole or in part, in
13--     any manner and for any purpose whatsoever, and to have or permit others
14--     to do so.
15--
16--                                    DISCLAIMER
17--
18--     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
19--     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
20--     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
21--     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
22--     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
23--     PARTICULAR PURPOSE OF SAID MATERIAL.
24--*
25--
26-- OBJECTIVE:
27--      Check that the attribute S'Definite, where S is an indefinite formal
28--      private or derived type, returns true if the actual corresponding to
29--      S is definite, and returns false otherwise.
30--
31-- TEST DESCRIPTION:
32--      A definite subtype is any subtype which is not indefinite. An
33--      indefinite subtype is either:
34--         a) An unconstrained array subtype.
35--         b) A subtype with unknown discriminants (this includes class-wide
36--            types).
37--         c) A subtype with unconstrained discriminants without defaults.
38--
39--      The possible forms of indefinite formal subtype are as follows:
40--
41--         Formal derived types:
42--          X - Ancestor is an unconstrained array type
43--          * - Ancestor is a discriminated record type without defaults
44--          X - Ancestor is a discriminated tagged type
45--          * - Ancestor type has unknown discriminants
46--            - Formal type has an unknown discriminant part
47--          * - Formal type has a known discriminant part
48--
49--         Formal private types:
50--            - Formal type has an unknown discriminant part
51--          * - Formal type has a known discriminant part
52--
53--      The formal subtypes preceded by an 'X' above are not covered, because
54--      other rules prevent a definite subtype from being passed as an actual.
55--      The formal subtypes preceded by an '*' above are not covered, because
56--      'Definite is less likely to be used for these formals.
57--
58--      The following kinds of actuals are passed to various of the formal
59--      types listed above:
60--
61--            - Undiscriminated type
62--            - Type with defaulted discriminants
63--            - Type with undefaulted discriminants
64--            - Class-wide type
65--
66--      A typical usage of S'Definite might be algorithm selection in a
67--      generic I/O package, e.g., the use of fixed-length or variable-length
68--      records depending on whether the actual is definite or indefinite.
69--      In such situations, S'Definite would appear in if conditions or other
70--      contexts requiring a boolean expression. This test checks S'Definite
71--      in such usage contexts but, for brevity, omits any surrounding
72--      usage code.
73--
74-- TEST FILES:
75--      The following files comprise this test:
76--
77--         FC51B00.A
78--      -> CC51B03.A
79--
80--
81-- CHANGE HISTORY:
82--      06 Dec 94   SAIC    ACVC 2.0
83--
84--!
85
86with FC51B00;  -- Indefinite subtype declarations.
87package CC51B03_0 is
88
89   --
90   -- Formal private type cases:
91   --
92
93   generic
94      type Formal (<>) is private;              -- Formal has unknown
95   package PrivateFormalUnknownDiscriminants is -- discriminant part.
96      function Is_Definite return Boolean;
97   end PrivateFormalUnknownDiscriminants;
98
99
100   --
101   -- Formal derived type cases:
102   --
103
104   generic
105      type Formal (<>) is new FC51B00.Vector    -- Formal has an unknown disc.
106        with private;                           -- part; ancestor is tagged.
107   package TaggedAncestorUnknownDiscriminants is
108      function Is_Definite return Boolean;
109   end TaggedAncestorUnknownDiscriminants;
110
111
112end CC51B03_0;
113
114
115     --==================================================================--
116
117
118package body CC51B03_0 is
119
120   package body PrivateFormalUnknownDiscriminants is
121      function Is_Definite return Boolean is
122      begin
123         if Formal'Definite then                -- Attribute used in "if"
124            -- ...Execute algorithm #1...       -- condition inside subprogram.
125            return True;
126         else
127            -- ...Execute algorithm #2...
128            return False;
129         end if;
130      end Is_Definite;
131   end PrivateFormalUnknownDiscriminants;
132
133
134   package body TaggedAncestorUnknownDiscriminants is
135      function Is_Definite return Boolean is
136      begin
137         return Formal'Definite;                -- Attribute used in return
138      end Is_Definite;                          -- statement inside subprogram.
139   end TaggedAncestorUnknownDiscriminants;
140
141
142end CC51B03_0;
143
144
145     --==================================================================--
146
147
148with FC51B00;
149package CC51B03_1 is
150
151   subtype Spin_Type is Natural range 0 .. 3;
152
153   type Extended_Vector (Spin : Spin_Type) is   -- Tagged type with
154     new FC51B00.Vector with null record;       -- discriminant (indefinite).
155
156
157end CC51B03_1;
158
159
160     --==================================================================--
161
162
163with FC51B00;   -- Indefinite subtype declarations.
164with CC51B03_0; -- Generic package declarations.
165with CC51B03_1;
166
167with Report;
168procedure CC51B03 is
169
170   --
171   -- Instances for formal private type with unknown discriminants:
172   --
173
174   package PrivateFormal_UndiscriminatedTaggedActual is new
175     CC51B03_0.PrivateFormalUnknownDiscriminants (FC51B00.Vector);
176
177   package PrivateFormal_ClassWideActual is new
178     CC51B03_0.PrivateFormalUnknownDiscriminants (FC51B00.Vector'Class);
179
180   package PrivateFormal_DiscriminatedTaggedActual is new
181     CC51B03_0.PrivateFormalUnknownDiscriminants (FC51B00.Square_Pair);
182
183   package PrivateFormal_DiscriminatedUndefaultedRecordActual is new
184     CC51B03_0.PrivateFormalUnknownDiscriminants (FC51B00.Square);
185
186
187   subtype Length is Natural range 0 .. 20;
188   type Message (Len : Length := 0) is record   -- Record type with defaulted
189      Text : String (1 .. Len);                 -- discriminant (definite).
190   end record;
191
192   package PrivateFormal_DiscriminatedDefaultedRecordActual is new
193     CC51B03_0.PrivateFormalUnknownDiscriminants (Message);
194
195
196   --
197   -- Instances for formal derived tagged type with unknown discriminants:
198   --
199
200   package DerivedFormal_UndiscriminatedTaggedActual is new
201     CC51B03_0.TaggedAncestorUnknownDiscriminants (FC51B00.Vector);
202
203   package DerivedFormal_ClassWideActual is new
204     CC51B03_0.TaggedAncestorUnknownDiscriminants (FC51B00.Vector'Class);
205
206   package DerivedFormal_DiscriminatedTaggedActual is new
207     CC51B03_0.TaggedAncestorUnknownDiscriminants (CC51B03_1.Extended_Vector);
208
209
210begin
211   Report.Test ("CC51B03", "Check that S'Definite returns true if the " &
212                "actual corresponding to S is definite, and false otherwise");
213
214
215   if not PrivateFormal_UndiscriminatedTaggedActual.Is_Definite then
216      Report.Failed ("Formal private/unknown discriminants: wrong " &
217                     "result for undiscriminated tagged actual");
218   end if;
219
220   if PrivateFormal_ClassWideActual.Is_Definite then
221      Report.Failed ("Formal private/unknown discriminants: wrong " &
222                     "result for class-wide actual");
223   end if;
224
225   if PrivateFormal_DiscriminatedTaggedActual.Is_Definite then
226      Report.Failed ("Formal private/unknown discriminants: wrong " &
227                     "result for discriminated tagged actual");
228   end if;
229
230   if PrivateFormal_DiscriminatedUndefaultedRecordActual.Is_Definite then
231      Report.Failed ("Formal private/unknown discriminants: wrong result " &
232                     "for record actual with undefaulted discriminants");
233   end if;
234
235   if not PrivateFormal_DiscriminatedDefaultedRecordActual.Is_Definite then
236      Report.Failed ("Formal private/unknown discriminants: wrong result " &
237                     "for record actual with defaulted discriminants");
238   end if;
239
240
241   if not DerivedFormal_UndiscriminatedTaggedActual.Is_Definite then
242      Report.Failed ("Formal derived/unknown discriminants: wrong result " &
243                     "for undiscriminated tagged actual");
244   end if;
245
246   if DerivedFormal_ClassWideActual.Is_Definite then
247      Report.Failed ("Formal derived/unknown discriminants: wrong result " &
248                     "for class-wide actual");
249   end if;
250
251   if DerivedFormal_DiscriminatedTaggedActual.Is_Definite then
252      Report.Failed ("Formal derived/unknown discriminants: wrong result " &
253                     "for discriminated tagged actual");
254   end if;
255
256
257   Report.Result;
258end CC51B03;
259