1-- CC51007.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 a generic formal derived tagged type is a private extension. 28-- Specifically, check that, for a generic formal derived type whose 29-- ancestor type has abstract primitive subprograms, neither the formal 30-- derived type nor its descendants need be abstract. Check that objects 31-- and components of the formal derived type and its nonabstract 32-- descendants may be declared and allocated, as may nonabstract 33-- functions returning these types, and that aggregates of nonabstract 34-- descendants of the formal derived type are legal. Check that calls to 35-- the abstract primitive subprograms of the ancestor dispatch to the 36-- bodies corresponding to the tag of the actual parameters. 37-- 38-- TEST DESCRIPTION: 39-- Although the ancestor type is abstract and has abstract primitive 40-- subprograms, these subprograms, when inherited by a formal nonabstract 41-- derived type, are not abstract, since the formal derived type is a 42-- nonabstract private extension. 43-- 44-- Thus, derivatives of the formal derived type need not be abstract, 45-- and both the formal derived type and its derivatives are considered 46-- nonabstract types. 47-- 48-- This test verifies that the restrictions placed on abstract types do 49-- not apply to the formal derived type or its derivatives. Specifically, 50-- objects of, components of, allocators of, and nonabstract functions 51-- returning the formal derived type or its derivatives are legal. In 52-- addition, the test verifies that a call within the instance to a 53-- primitive subprogram of the (abstract) ancestor type dispatches to 54-- the body corresponding to the tag of the actual parameter. 55-- 56-- 57-- CHANGE HISTORY: 58-- 06 Dec 94 SAIC ACVC 2.0 59-- 23 Dec 94 SAIC Deleted illegal extension aggregate. Corrected 60-- dispatching call. Editorial changes to commentary. 61-- 05 Nov 95 SAIC ACVC 2.0.1 fixes: Moved instantiation of CC51007_3 62-- to library level. 63-- 11 Aug 96 SAIC ACVC 2.1: Added pragma Elaborate to context 64-- clauses of CC51007_1 and CC51007_4. 65-- 66--! 67 68package CC51007_0 is 69 70 Max_Length : constant := 10; 71 type Text is new String(1 .. Max_Length); 72 73 type Alert is abstract tagged record -- Root type of class 74 Message : Text := (others => '*'); -- (abstract). 75 end record; 76 77 procedure Handle (A: in out Alert) is abstract; -- Abstract dispatching 78 -- operation. 79 80end CC51007_0; 81 82-- No body for CC51007_0; 83 84 85 --===================================================================-- 86 87 88with CC51007_0; 89 90with Ada.Calendar; 91pragma Elaborate (Ada.Calendar); 92 93package CC51007_1 is 94 95 type Low_Alert is new CC51007_0.Alert with record 96 Time_Of_Arrival : Ada.Calendar.Time := Ada.Calendar.Time_Of (1901, 8, 1); 97 end record; 98 99 procedure Handle (A: in out Low_Alert); -- Overrides parent's 100 -- implementation. 101 Low : Low_Alert; 102 103end CC51007_1; 104 105 106 --===================================================================-- 107 108 109package body CC51007_1 is 110 111 procedure Handle (A: in out Low_Alert) is -- Artificial for 112 begin -- testing. 113 A.Time_Of_Arrival := Ada.Calendar.Time_Of (1984, 1, 1); 114 A.Message := "Low Alert!"; 115 end Handle; 116 117end CC51007_1; 118 119 120 --===================================================================-- 121 122 123with CC51007_1; 124package CC51007_2 is 125 126 type Person is (OOD, CO, CinC); 127 128 type Medium_Alert is new CC51007_1.Low_Alert with record 129 Action_Officer : Person := OOD; 130 end record; 131 132 procedure Handle (A: in out Medium_Alert); -- Overrides parent's 133 -- implementation. 134 Med : Medium_Alert; 135 136end CC51007_2; 137 138 139 --===================================================================-- 140 141 142with Ada.Calendar; 143package body CC51007_2 is 144 145 procedure Handle (A: in out Medium_Alert) is -- Artificial for 146 begin -- testing. 147 A.Action_Officer := CO; 148 A.Time_Of_Arrival := Ada.Calendar.Time_Of (2001, 1, 1); 149 A.Message := "Med Alert!"; 150 end Handle; 151 152end CC51007_2; 153 154 155 --===================================================================-- 156 157 158with CC51007_0; 159generic 160 type Alert_Type is new CC51007_0.Alert with private; 161 Initial_State : in Alert_Type; 162package CC51007_3 is 163 164 function Clear_Message (A: Alert_Type) -- Function returning 165 return Alert_Type; -- formal type. 166 167 168 Max_Note : Natural := 10; 169 type Note is new String (1 .. Max_Note); 170 171 type Extended_Alert is new Alert_Type with record 172 Addendum : Note := (others => '*'); 173 end record; 174 175 -- In instance, inherits version of Handle from 176 -- actual corresponding to formal type. 177 178 function Annotate_Alert (A: in Alert_Type'Class) -- Function returning 179 return Extended_Alert; -- derived type. 180 181 182 Init_Ext_Alert : constant Extended_Alert := -- Object declaration. 183 (Initial_State with Addendum => "----------"); -- Aggregate. 184 185 186 type Alert_Type_Ptr is access constant Alert_Type; 187 type Ext_Alert_Ptr is access Extended_Alert; 188 189 Init_Alert_Ptr : Alert_Type_Ptr := 190 new Alert_Type'(Initial_State); -- Allocator. 191 192 Init_Ext_Alert_Ptr : Ext_Alert_Ptr := 193 new Extended_Alert'(Init_Ext_Alert); -- Allocator. 194 195 196 type Alert_Pair is record 197 A : Alert_Type; -- Component. 198 EA : Extended_Alert; -- Component. 199 end record; 200 201end CC51007_3; 202 203 204 --===================================================================-- 205 206 207package body CC51007_3 is 208 209 function Clear_Message (A: Alert_Type) return Alert_Type is 210 Temp : Alert_Type := A; -- Object declaration. 211 begin 212 Temp.Message := (others => '-'); 213 return Temp; 214 end Clear_Message; 215 216 function Annotate_Alert (A: in Alert_Type'Class) return Extended_Alert is 217 Temp : Alert_Type'Class := A; 218 begin 219 Handle (Temp); -- Dispatching call to 220 -- operation of ancestor. 221 return (Alert_Type(Temp) with Addendum => "No comment"); 222 end Annotate_Alert; 223 224end CC51007_3; 225 226 227 --===================================================================-- 228 229 230with CC51007_1; 231 232with CC51007_3; 233pragma Elaborate (CC51007_3); 234 235package CC51007_4 is new CC51007_3 (CC51007_1.Low_Alert, CC51007_1.Low); 236 237 238 --===================================================================-- 239 240 241with CC51007_1; 242with CC51007_2; 243with CC51007_3; 244with CC51007_4; 245 246with Ada.Calendar; 247with Report; 248procedure CC51007 is 249 250 package Alert_Support renames CC51007_4; 251 252 Ext : Alert_Support.Extended_Alert; 253 254 TC_Result : Alert_Support.Extended_Alert; 255 256 TC_Low_Expected : constant Alert_Support.Extended_Alert := 257 (Time_Of_Arrival => Ada.Calendar.Time_Of (1984, 1, 1), 258 Message => "Low Alert!", 259 Addendum => "No comment"); 260 261 TC_Med_Expected : constant Alert_Support.Extended_Alert := 262 (Time_Of_Arrival => Ada.Calendar.Time_Of (2001, 1, 1), 263 Message => "Med Alert!", 264 Addendum => "No comment"); 265 266 TC_Ext_Expected : constant Alert_Support.Extended_Alert := TC_Low_Expected; 267 268 269 use type Alert_Support.Extended_Alert; 270 271begin 272 Report.Test ("CC51007", "Check that, for a generic formal derived type " & 273 "whose ancestor type has abstract primitive subprograms, " & 274 "neither the formal derived type nor its descendants need " & 275 "be abstract, and that objects of, components of, " & 276 "allocators of, aggregates of, and nonabstract functions " & 277 "returning these types are legal. Check that calls to the " & 278 "abstract primitive subprograms of the ancestor dispatch " & 279 "to the bodies corresponding to the tag of the actual " & 280 "parameters"); 281 282 283 TC_Result := Alert_Support.Annotate_Alert (CC51007_1.Low); -- Dispatching 284 -- call. 285 if TC_Result /= TC_Low_Expected then 286 Report.Failed ("Wrong results from dispatching call (Low_Alert)"); 287 end if; 288 289 290 TC_Result := Alert_Support.Annotate_Alert (CC51007_2.Med); -- Dispatching 291 -- call. 292 if TC_Result /= TC_Med_Expected then 293 Report.Failed ("Wrong results from dispatching call (Medium_Alert)"); 294 end if; 295 296 297 TC_Result := Alert_Support.Annotate_Alert (Ext); -- Results in dispatching 298 -- call. 299 if TC_Result /= TC_Ext_Expected then 300 Report.Failed ("Wrong results from dispatching call (Extended_Alert)"); 301 end if; 302 303 304 Report.Result; 305end CC51007; 306