-- CC51007.A -- -- Grant of Unlimited Rights -- -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and -- F08630-91-C-0015, 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 a generic formal derived tagged type is a private extension. -- Specifically, check that, for a generic formal derived type whose -- ancestor type has abstract primitive subprograms, neither the formal -- derived type nor its descendants need be abstract. Check that objects -- and components of the formal derived type and its nonabstract -- descendants may be declared and allocated, as may nonabstract -- functions returning these types, and that aggregates of nonabstract -- descendants of the formal derived type are legal. Check that calls to -- the abstract primitive subprograms of the ancestor dispatch to the -- bodies corresponding to the tag of the actual parameters. -- -- TEST DESCRIPTION: -- Although the ancestor type is abstract and has abstract primitive -- subprograms, these subprograms, when inherited by a formal nonabstract -- derived type, are not abstract, since the formal derived type is a -- nonabstract private extension. -- -- Thus, derivatives of the formal derived type need not be abstract, -- and both the formal derived type and its derivatives are considered -- nonabstract types. -- -- This test verifies that the restrictions placed on abstract types do -- not apply to the formal derived type or its derivatives. Specifically, -- objects of, components of, allocators of, and nonabstract functions -- returning the formal derived type or its derivatives are legal. In -- addition, the test verifies that a call within the instance to a -- primitive subprogram of the (abstract) ancestor type dispatches to -- the body corresponding to the tag of the actual parameter. -- -- -- CHANGE HISTORY: -- 06 Dec 94 SAIC ACVC 2.0 -- 23 Dec 94 SAIC Deleted illegal extension aggregate. Corrected -- dispatching call. Editorial changes to commentary. -- 05 Nov 95 SAIC ACVC 2.0.1 fixes: Moved instantiation of CC51007_3 -- to library level. -- 11 Aug 96 SAIC ACVC 2.1: Added pragma Elaborate to context -- clauses of CC51007_1 and CC51007_4. -- --! package CC51007_0 is Max_Length : constant := 10; type Text is new String(1 .. Max_Length); type Alert is abstract tagged record -- Root type of class Message : Text := (others => '*'); -- (abstract). end record; procedure Handle (A: in out Alert) is abstract; -- Abstract dispatching -- operation. end CC51007_0; -- No body for CC51007_0; --===================================================================-- with CC51007_0; with Ada.Calendar; pragma Elaborate (Ada.Calendar); package CC51007_1 is type Low_Alert is new CC51007_0.Alert with record Time_Of_Arrival : Ada.Calendar.Time := Ada.Calendar.Time_Of (1901, 8, 1); end record; procedure Handle (A: in out Low_Alert); -- Overrides parent's -- implementation. Low : Low_Alert; end CC51007_1; --===================================================================-- package body CC51007_1 is procedure Handle (A: in out Low_Alert) is -- Artificial for begin -- testing. A.Time_Of_Arrival := Ada.Calendar.Time_Of (1984, 1, 1); A.Message := "Low Alert!"; end Handle; end CC51007_1; --===================================================================-- with CC51007_1; package CC51007_2 is type Person is (OOD, CO, CinC); type Medium_Alert is new CC51007_1.Low_Alert with record Action_Officer : Person := OOD; end record; procedure Handle (A: in out Medium_Alert); -- Overrides parent's -- implementation. Med : Medium_Alert; end CC51007_2; --===================================================================-- with Ada.Calendar; package body CC51007_2 is procedure Handle (A: in out Medium_Alert) is -- Artificial for begin -- testing. A.Action_Officer := CO; A.Time_Of_Arrival := Ada.Calendar.Time_Of (2001, 1, 1); A.Message := "Med Alert!"; end Handle; end CC51007_2; --===================================================================-- with CC51007_0; generic type Alert_Type is new CC51007_0.Alert with private; Initial_State : in Alert_Type; package CC51007_3 is function Clear_Message (A: Alert_Type) -- Function returning return Alert_Type; -- formal type. Max_Note : Natural := 10; type Note is new String (1 .. Max_Note); type Extended_Alert is new Alert_Type with record Addendum : Note := (others => '*'); end record; -- In instance, inherits version of Handle from -- actual corresponding to formal type. function Annotate_Alert (A: in Alert_Type'Class) -- Function returning return Extended_Alert; -- derived type. Init_Ext_Alert : constant Extended_Alert := -- Object declaration. (Initial_State with Addendum => "----------"); -- Aggregate. type Alert_Type_Ptr is access constant Alert_Type; type Ext_Alert_Ptr is access Extended_Alert; Init_Alert_Ptr : Alert_Type_Ptr := new Alert_Type'(Initial_State); -- Allocator. Init_Ext_Alert_Ptr : Ext_Alert_Ptr := new Extended_Alert'(Init_Ext_Alert); -- Allocator. type Alert_Pair is record A : Alert_Type; -- Component. EA : Extended_Alert; -- Component. end record; end CC51007_3; --===================================================================-- package body CC51007_3 is function Clear_Message (A: Alert_Type) return Alert_Type is Temp : Alert_Type := A; -- Object declaration. begin Temp.Message := (others => '-'); return Temp; end Clear_Message; function Annotate_Alert (A: in Alert_Type'Class) return Extended_Alert is Temp : Alert_Type'Class := A; begin Handle (Temp); -- Dispatching call to -- operation of ancestor. return (Alert_Type(Temp) with Addendum => "No comment"); end Annotate_Alert; end CC51007_3; --===================================================================-- with CC51007_1; with CC51007_3; pragma Elaborate (CC51007_3); package CC51007_4 is new CC51007_3 (CC51007_1.Low_Alert, CC51007_1.Low); --===================================================================-- with CC51007_1; with CC51007_2; with CC51007_3; with CC51007_4; with Ada.Calendar; with Report; procedure CC51007 is package Alert_Support renames CC51007_4; Ext : Alert_Support.Extended_Alert; TC_Result : Alert_Support.Extended_Alert; TC_Low_Expected : constant Alert_Support.Extended_Alert := (Time_Of_Arrival => Ada.Calendar.Time_Of (1984, 1, 1), Message => "Low Alert!", Addendum => "No comment"); TC_Med_Expected : constant Alert_Support.Extended_Alert := (Time_Of_Arrival => Ada.Calendar.Time_Of (2001, 1, 1), Message => "Med Alert!", Addendum => "No comment"); TC_Ext_Expected : constant Alert_Support.Extended_Alert := TC_Low_Expected; use type Alert_Support.Extended_Alert; begin Report.Test ("CC51007", "Check that, for a generic formal derived type " & "whose ancestor type has abstract primitive subprograms, " & "neither the formal derived type nor its descendants need " & "be abstract, and that objects of, components of, " & "allocators of, aggregates of, and nonabstract functions " & "returning these types are legal. Check that calls to the " & "abstract primitive subprograms of the ancestor dispatch " & "to the bodies corresponding to the tag of the actual " & "parameters"); TC_Result := Alert_Support.Annotate_Alert (CC51007_1.Low); -- Dispatching -- call. if TC_Result /= TC_Low_Expected then Report.Failed ("Wrong results from dispatching call (Low_Alert)"); end if; TC_Result := Alert_Support.Annotate_Alert (CC51007_2.Med); -- Dispatching -- call. if TC_Result /= TC_Med_Expected then Report.Failed ("Wrong results from dispatching call (Medium_Alert)"); end if; TC_Result := Alert_Support.Annotate_Alert (Ext); -- Results in dispatching -- call. if TC_Result /= TC_Ext_Expected then Report.Failed ("Wrong results from dispatching call (Extended_Alert)"); end if; Report.Result; end CC51007;