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