-- CC51007.A
|
-- CC51007.A
|
--
|
--
|
-- Grant of Unlimited Rights
|
-- Grant of Unlimited Rights
|
--
|
--
|
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
|
-- 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
|
-- 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 in the software and documentation contained herein.
|
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
|
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
|
-- this public release, the Government intends to confer upon all
|
-- this public release, the Government intends to confer upon all
|
-- recipients unlimited rights equal to those held by the Government.
|
-- recipients unlimited rights equal to those held by the Government.
|
-- These rights include rights to use, duplicate, release or disclose the
|
-- These rights include rights to use, duplicate, release or disclose the
|
-- released technical data and computer software in whole or in part, in
|
-- 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
|
-- any manner and for any purpose whatsoever, and to have or permit others
|
-- to do so.
|
-- to do so.
|
--
|
--
|
-- DISCLAIMER
|
-- DISCLAIMER
|
--
|
--
|
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
|
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
|
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
|
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
|
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
|
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
|
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
|
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
|
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
|
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
|
-- PARTICULAR PURPOSE OF SAID MATERIAL.
|
-- PARTICULAR PURPOSE OF SAID MATERIAL.
|
--*
|
--*
|
--
|
--
|
-- OBJECTIVE:
|
-- OBJECTIVE:
|
-- Check that a generic formal derived tagged type is a private extension.
|
-- Check that a generic formal derived tagged type is a private extension.
|
-- Specifically, check that, for a generic formal derived type whose
|
-- Specifically, check that, for a generic formal derived type whose
|
-- ancestor type has abstract primitive subprograms, neither the formal
|
-- ancestor type has abstract primitive subprograms, neither the formal
|
-- derived type nor its descendants need be abstract. Check that objects
|
-- derived type nor its descendants need be abstract. Check that objects
|
-- and components of the formal derived type and its nonabstract
|
-- and components of the formal derived type and its nonabstract
|
-- descendants may be declared and allocated, as may nonabstract
|
-- descendants may be declared and allocated, as may nonabstract
|
-- functions returning these types, and that aggregates of nonabstract
|
-- functions returning these types, and that aggregates of nonabstract
|
-- descendants of the formal derived type are legal. Check that calls to
|
-- descendants of the formal derived type are legal. Check that calls to
|
-- the abstract primitive subprograms of the ancestor dispatch to the
|
-- the abstract primitive subprograms of the ancestor dispatch to the
|
-- bodies corresponding to the tag of the actual parameters.
|
-- bodies corresponding to the tag of the actual parameters.
|
--
|
--
|
-- TEST DESCRIPTION:
|
-- TEST DESCRIPTION:
|
-- Although the ancestor type is abstract and has abstract primitive
|
-- Although the ancestor type is abstract and has abstract primitive
|
-- subprograms, these subprograms, when inherited by a formal nonabstract
|
-- subprograms, these subprograms, when inherited by a formal nonabstract
|
-- derived type, are not abstract, since the formal derived type is a
|
-- derived type, are not abstract, since the formal derived type is a
|
-- nonabstract private extension.
|
-- nonabstract private extension.
|
--
|
--
|
-- Thus, derivatives of the formal derived type need not be abstract,
|
-- Thus, derivatives of the formal derived type need not be abstract,
|
-- and both the formal derived type and its derivatives are considered
|
-- and both the formal derived type and its derivatives are considered
|
-- nonabstract types.
|
-- nonabstract types.
|
--
|
--
|
-- This test verifies that the restrictions placed on abstract types do
|
-- This test verifies that the restrictions placed on abstract types do
|
-- not apply to the formal derived type or its derivatives. Specifically,
|
-- not apply to the formal derived type or its derivatives. Specifically,
|
-- objects of, components of, allocators of, and nonabstract functions
|
-- objects of, components of, allocators of, and nonabstract functions
|
-- returning the formal derived type or its derivatives are legal. In
|
-- returning the formal derived type or its derivatives are legal. In
|
-- addition, the test verifies that a call within the instance to a
|
-- addition, the test verifies that a call within the instance to a
|
-- primitive subprogram of the (abstract) ancestor type dispatches to
|
-- primitive subprogram of the (abstract) ancestor type dispatches to
|
-- the body corresponding to the tag of the actual parameter.
|
-- the body corresponding to the tag of the actual parameter.
|
--
|
--
|
--
|
--
|
-- CHANGE HISTORY:
|
-- CHANGE HISTORY:
|
-- 06 Dec 94 SAIC ACVC 2.0
|
-- 06 Dec 94 SAIC ACVC 2.0
|
-- 23 Dec 94 SAIC Deleted illegal extension aggregate. Corrected
|
-- 23 Dec 94 SAIC Deleted illegal extension aggregate. Corrected
|
-- dispatching call. Editorial changes to commentary.
|
-- dispatching call. Editorial changes to commentary.
|
-- 05 Nov 95 SAIC ACVC 2.0.1 fixes: Moved instantiation of CC51007_3
|
-- 05 Nov 95 SAIC ACVC 2.0.1 fixes: Moved instantiation of CC51007_3
|
-- to library level.
|
-- to library level.
|
-- 11 Aug 96 SAIC ACVC 2.1: Added pragma Elaborate to context
|
-- 11 Aug 96 SAIC ACVC 2.1: Added pragma Elaborate to context
|
-- clauses of CC51007_1 and CC51007_4.
|
-- clauses of CC51007_1 and CC51007_4.
|
--
|
--
|
--!
|
--!
|
|
|
package CC51007_0 is
|
package CC51007_0 is
|
|
|
Max_Length : constant := 10;
|
Max_Length : constant := 10;
|
type Text is new String(1 .. Max_Length);
|
type Text is new String(1 .. Max_Length);
|
|
|
type Alert is abstract tagged record -- Root type of class
|
type Alert is abstract tagged record -- Root type of class
|
Message : Text := (others => '*'); -- (abstract).
|
Message : Text := (others => '*'); -- (abstract).
|
end record;
|
end record;
|
|
|
procedure Handle (A: in out Alert) is abstract; -- Abstract dispatching
|
procedure Handle (A: in out Alert) is abstract; -- Abstract dispatching
|
-- operation.
|
-- operation.
|
|
|
end CC51007_0;
|
end CC51007_0;
|
|
|
-- No body for CC51007_0;
|
-- No body for CC51007_0;
|
|
|
|
|
--===================================================================--
|
--===================================================================--
|
|
|
|
|
with CC51007_0;
|
with CC51007_0;
|
|
|
with Ada.Calendar;
|
with Ada.Calendar;
|
pragma Elaborate (Ada.Calendar);
|
pragma Elaborate (Ada.Calendar);
|
|
|
package CC51007_1 is
|
package CC51007_1 is
|
|
|
type Low_Alert is new CC51007_0.Alert with record
|
type Low_Alert is new CC51007_0.Alert with record
|
Time_Of_Arrival : Ada.Calendar.Time := Ada.Calendar.Time_Of (1901, 8, 1);
|
Time_Of_Arrival : Ada.Calendar.Time := Ada.Calendar.Time_Of (1901, 8, 1);
|
end record;
|
end record;
|
|
|
procedure Handle (A: in out Low_Alert); -- Overrides parent's
|
procedure Handle (A: in out Low_Alert); -- Overrides parent's
|
-- implementation.
|
-- implementation.
|
Low : Low_Alert;
|
Low : Low_Alert;
|
|
|
end CC51007_1;
|
end CC51007_1;
|
|
|
|
|
--===================================================================--
|
--===================================================================--
|
|
|
|
|
package body CC51007_1 is
|
package body CC51007_1 is
|
|
|
procedure Handle (A: in out Low_Alert) is -- Artificial for
|
procedure Handle (A: in out Low_Alert) is -- Artificial for
|
begin -- testing.
|
begin -- testing.
|
A.Time_Of_Arrival := Ada.Calendar.Time_Of (1984, 1, 1);
|
A.Time_Of_Arrival := Ada.Calendar.Time_Of (1984, 1, 1);
|
A.Message := "Low Alert!";
|
A.Message := "Low Alert!";
|
end Handle;
|
end Handle;
|
|
|
end CC51007_1;
|
end CC51007_1;
|
|
|
|
|
--===================================================================--
|
--===================================================================--
|
|
|
|
|
with CC51007_1;
|
with CC51007_1;
|
package CC51007_2 is
|
package CC51007_2 is
|
|
|
type Person is (OOD, CO, CinC);
|
type Person is (OOD, CO, CinC);
|
|
|
type Medium_Alert is new CC51007_1.Low_Alert with record
|
type Medium_Alert is new CC51007_1.Low_Alert with record
|
Action_Officer : Person := OOD;
|
Action_Officer : Person := OOD;
|
end record;
|
end record;
|
|
|
procedure Handle (A: in out Medium_Alert); -- Overrides parent's
|
procedure Handle (A: in out Medium_Alert); -- Overrides parent's
|
-- implementation.
|
-- implementation.
|
Med : Medium_Alert;
|
Med : Medium_Alert;
|
|
|
end CC51007_2;
|
end CC51007_2;
|
|
|
|
|
--===================================================================--
|
--===================================================================--
|
|
|
|
|
with Ada.Calendar;
|
with Ada.Calendar;
|
package body CC51007_2 is
|
package body CC51007_2 is
|
|
|
procedure Handle (A: in out Medium_Alert) is -- Artificial for
|
procedure Handle (A: in out Medium_Alert) is -- Artificial for
|
begin -- testing.
|
begin -- testing.
|
A.Action_Officer := CO;
|
A.Action_Officer := CO;
|
A.Time_Of_Arrival := Ada.Calendar.Time_Of (2001, 1, 1);
|
A.Time_Of_Arrival := Ada.Calendar.Time_Of (2001, 1, 1);
|
A.Message := "Med Alert!";
|
A.Message := "Med Alert!";
|
end Handle;
|
end Handle;
|
|
|
end CC51007_2;
|
end CC51007_2;
|
|
|
|
|
--===================================================================--
|
--===================================================================--
|
|
|
|
|
with CC51007_0;
|
with CC51007_0;
|
generic
|
generic
|
type Alert_Type is new CC51007_0.Alert with private;
|
type Alert_Type is new CC51007_0.Alert with private;
|
Initial_State : in Alert_Type;
|
Initial_State : in Alert_Type;
|
package CC51007_3 is
|
package CC51007_3 is
|
|
|
function Clear_Message (A: Alert_Type) -- Function returning
|
function Clear_Message (A: Alert_Type) -- Function returning
|
return Alert_Type; -- formal type.
|
return Alert_Type; -- formal type.
|
|
|
|
|
Max_Note : Natural := 10;
|
Max_Note : Natural := 10;
|
type Note is new String (1 .. Max_Note);
|
type Note is new String (1 .. Max_Note);
|
|
|
type Extended_Alert is new Alert_Type with record
|
type Extended_Alert is new Alert_Type with record
|
Addendum : Note := (others => '*');
|
Addendum : Note := (others => '*');
|
end record;
|
end record;
|
|
|
-- In instance, inherits version of Handle from
|
-- In instance, inherits version of Handle from
|
-- actual corresponding to formal type.
|
-- actual corresponding to formal type.
|
|
|
function Annotate_Alert (A: in Alert_Type'Class) -- Function returning
|
function Annotate_Alert (A: in Alert_Type'Class) -- Function returning
|
return Extended_Alert; -- derived type.
|
return Extended_Alert; -- derived type.
|
|
|
|
|
Init_Ext_Alert : constant Extended_Alert := -- Object declaration.
|
Init_Ext_Alert : constant Extended_Alert := -- Object declaration.
|
(Initial_State with Addendum => "----------"); -- Aggregate.
|
(Initial_State with Addendum => "----------"); -- Aggregate.
|
|
|
|
|
type Alert_Type_Ptr is access constant Alert_Type;
|
type Alert_Type_Ptr is access constant Alert_Type;
|
type Ext_Alert_Ptr is access Extended_Alert;
|
type Ext_Alert_Ptr is access Extended_Alert;
|
|
|
Init_Alert_Ptr : Alert_Type_Ptr :=
|
Init_Alert_Ptr : Alert_Type_Ptr :=
|
new Alert_Type'(Initial_State); -- Allocator.
|
new Alert_Type'(Initial_State); -- Allocator.
|
|
|
Init_Ext_Alert_Ptr : Ext_Alert_Ptr :=
|
Init_Ext_Alert_Ptr : Ext_Alert_Ptr :=
|
new Extended_Alert'(Init_Ext_Alert); -- Allocator.
|
new Extended_Alert'(Init_Ext_Alert); -- Allocator.
|
|
|
|
|
type Alert_Pair is record
|
type Alert_Pair is record
|
A : Alert_Type; -- Component.
|
A : Alert_Type; -- Component.
|
EA : Extended_Alert; -- Component.
|
EA : Extended_Alert; -- Component.
|
end record;
|
end record;
|
|
|
end CC51007_3;
|
end CC51007_3;
|
|
|
|
|
--===================================================================--
|
--===================================================================--
|
|
|
|
|
package body CC51007_3 is
|
package body CC51007_3 is
|
|
|
function Clear_Message (A: Alert_Type) return Alert_Type is
|
function Clear_Message (A: Alert_Type) return Alert_Type is
|
Temp : Alert_Type := A; -- Object declaration.
|
Temp : Alert_Type := A; -- Object declaration.
|
begin
|
begin
|
Temp.Message := (others => '-');
|
Temp.Message := (others => '-');
|
return Temp;
|
return Temp;
|
end Clear_Message;
|
end Clear_Message;
|
|
|
function Annotate_Alert (A: in Alert_Type'Class) return Extended_Alert is
|
function Annotate_Alert (A: in Alert_Type'Class) return Extended_Alert is
|
Temp : Alert_Type'Class := A;
|
Temp : Alert_Type'Class := A;
|
begin
|
begin
|
Handle (Temp); -- Dispatching call to
|
Handle (Temp); -- Dispatching call to
|
-- operation of ancestor.
|
-- operation of ancestor.
|
return (Alert_Type(Temp) with Addendum => "No comment");
|
return (Alert_Type(Temp) with Addendum => "No comment");
|
end Annotate_Alert;
|
end Annotate_Alert;
|
|
|
end CC51007_3;
|
end CC51007_3;
|
|
|
|
|
--===================================================================--
|
--===================================================================--
|
|
|
|
|
with CC51007_1;
|
with CC51007_1;
|
|
|
with CC51007_3;
|
with CC51007_3;
|
pragma Elaborate (CC51007_3);
|
pragma Elaborate (CC51007_3);
|
|
|
package CC51007_4 is new CC51007_3 (CC51007_1.Low_Alert, CC51007_1.Low);
|
package CC51007_4 is new CC51007_3 (CC51007_1.Low_Alert, CC51007_1.Low);
|
|
|
|
|
--===================================================================--
|
--===================================================================--
|
|
|
|
|
with CC51007_1;
|
with CC51007_1;
|
with CC51007_2;
|
with CC51007_2;
|
with CC51007_3;
|
with CC51007_3;
|
with CC51007_4;
|
with CC51007_4;
|
|
|
with Ada.Calendar;
|
with Ada.Calendar;
|
with Report;
|
with Report;
|
procedure CC51007 is
|
procedure CC51007 is
|
|
|
package Alert_Support renames CC51007_4;
|
package Alert_Support renames CC51007_4;
|
|
|
Ext : Alert_Support.Extended_Alert;
|
Ext : Alert_Support.Extended_Alert;
|
|
|
TC_Result : Alert_Support.Extended_Alert;
|
TC_Result : Alert_Support.Extended_Alert;
|
|
|
TC_Low_Expected : constant Alert_Support.Extended_Alert :=
|
TC_Low_Expected : constant Alert_Support.Extended_Alert :=
|
(Time_Of_Arrival => Ada.Calendar.Time_Of (1984, 1, 1),
|
(Time_Of_Arrival => Ada.Calendar.Time_Of (1984, 1, 1),
|
Message => "Low Alert!",
|
Message => "Low Alert!",
|
Addendum => "No comment");
|
Addendum => "No comment");
|
|
|
TC_Med_Expected : constant Alert_Support.Extended_Alert :=
|
TC_Med_Expected : constant Alert_Support.Extended_Alert :=
|
(Time_Of_Arrival => Ada.Calendar.Time_Of (2001, 1, 1),
|
(Time_Of_Arrival => Ada.Calendar.Time_Of (2001, 1, 1),
|
Message => "Med Alert!",
|
Message => "Med Alert!",
|
Addendum => "No comment");
|
Addendum => "No comment");
|
|
|
TC_Ext_Expected : constant Alert_Support.Extended_Alert := TC_Low_Expected;
|
TC_Ext_Expected : constant Alert_Support.Extended_Alert := TC_Low_Expected;
|
|
|
|
|
use type Alert_Support.Extended_Alert;
|
use type Alert_Support.Extended_Alert;
|
|
|
begin
|
begin
|
Report.Test ("CC51007", "Check that, for a generic formal derived type " &
|
Report.Test ("CC51007", "Check that, for a generic formal derived type " &
|
"whose ancestor type has abstract primitive subprograms, " &
|
"whose ancestor type has abstract primitive subprograms, " &
|
"neither the formal derived type nor its descendants need " &
|
"neither the formal derived type nor its descendants need " &
|
"be abstract, and that objects of, components of, " &
|
"be abstract, and that objects of, components of, " &
|
"allocators of, aggregates of, and nonabstract functions " &
|
"allocators of, aggregates of, and nonabstract functions " &
|
"returning these types are legal. Check that calls to the " &
|
"returning these types are legal. Check that calls to the " &
|
"abstract primitive subprograms of the ancestor dispatch " &
|
"abstract primitive subprograms of the ancestor dispatch " &
|
"to the bodies corresponding to the tag of the actual " &
|
"to the bodies corresponding to the tag of the actual " &
|
"parameters");
|
"parameters");
|
|
|
|
|
TC_Result := Alert_Support.Annotate_Alert (CC51007_1.Low); -- Dispatching
|
TC_Result := Alert_Support.Annotate_Alert (CC51007_1.Low); -- Dispatching
|
-- call.
|
-- call.
|
if TC_Result /= TC_Low_Expected then
|
if TC_Result /= TC_Low_Expected then
|
Report.Failed ("Wrong results from dispatching call (Low_Alert)");
|
Report.Failed ("Wrong results from dispatching call (Low_Alert)");
|
end if;
|
end if;
|
|
|
|
|
TC_Result := Alert_Support.Annotate_Alert (CC51007_2.Med); -- Dispatching
|
TC_Result := Alert_Support.Annotate_Alert (CC51007_2.Med); -- Dispatching
|
-- call.
|
-- call.
|
if TC_Result /= TC_Med_Expected then
|
if TC_Result /= TC_Med_Expected then
|
Report.Failed ("Wrong results from dispatching call (Medium_Alert)");
|
Report.Failed ("Wrong results from dispatching call (Medium_Alert)");
|
end if;
|
end if;
|
|
|
|
|
TC_Result := Alert_Support.Annotate_Alert (Ext); -- Results in dispatching
|
TC_Result := Alert_Support.Annotate_Alert (Ext); -- Results in dispatching
|
-- call.
|
-- call.
|
if TC_Result /= TC_Ext_Expected then
|
if TC_Result /= TC_Ext_Expected then
|
Report.Failed ("Wrong results from dispatching call (Extended_Alert)");
|
Report.Failed ("Wrong results from dispatching call (Extended_Alert)");
|
end if;
|
end if;
|
|
|
|
|
Report.Result;
|
Report.Result;
|
end CC51007;
|
end CC51007;
|
|
|
