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