URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
[/] [openrisc/] [trunk/] [gnu-old/] [gcc-4.2.2/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c7/] [c730002.a] - Rev 149
Go to most recent revision | Compare with Previous | Blame | View Log
-- C730002.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 the full view of a private extension may be derived
-- indirectly from the ancestor type (i.e., the parent type of the full
-- type may be any descendant of the ancestor type). Check that, for
-- a primitive subprogram of the private extension that is inherited from
-- the ancestor type and not overridden, the formal parameter names and
-- default expressions come from the corresponding primitive subprogram
-- of the ancestor type, while the body comes from that of the parent
-- type.
-- Check for a case where the parent type is derived from the ancestor
-- type through a series of types produced by generic instantiations.
-- Examine both the static and dynamic binding cases.
--
-- TEST DESCRIPTION:
-- Consider:
--
-- package P is
-- type Ancestor is tagged ...
-- procedure Op (P1: Ancestor; P2: Boolean := True);
-- end P;
--
-- with P;
-- generic
-- type T is new P.Ancestor with private;
-- package Gen1 is
-- type Enhanced is new T with private;
-- procedure Op (A: Enhanced; B: Boolean := True);
-- -- other specific procedures...
-- private
-- type Enhanced is new T with ...
-- end Gen1;
--
-- with P, Gen1;
-- package N is new Gen1 (P.Ancestor);
--
-- with N;
-- generic
-- type T is new N.Enhanced with private;
-- package Gen2 is
-- type Enhanced_Again is new T with private;
-- procedure Op (X: Enhanced_Again; Y: Boolean := False);
-- -- other specific procedures...
-- private
-- type Enhanced_Again is new T with ...
-- end Gen2;
--
-- with N, Gen2;
-- package Q is new Gen2 (N.Enhanced);
--
-- with P, Q;
-- package R is
-- type Priv_Ext is new P.Ancestor with private; -- (A)
-- -- Inherits procedure Op (P1: Priv_Ext; P2: Boolean := True);
-- -- But body executed is that of Q.Op.
-- private
-- type Priv_Ext is new Q.Enhanced_Again with record ... -- (B)
-- end R;
--
-- The ancestor type in (A) differs from the parent type in (B); the
-- parent of the full type is descended from the ancestor type of the
-- private extension, in this case through a series of types produced
-- by generic instantiations. Gen1 redefines the implementation of Op
-- for any type that has one. N is an instance of Gen1 for the ancestor
-- type. Gen2 again redefines the implementation of Op for any type that
-- has one. Q is an instance of Gen2 for the extension of the P.Ancestor
-- declared in N. Both N and Q could define other operations which we
-- don't want to be available in R. For a call to Op (from outside the
-- scope of the full view) with an operand of type R.Priv_Ext, the body
-- executed will be that of Q.Op (the parent type's version), but the
-- formal parameter names and default expression come from that of P.Op
-- (the ancestor type's version).
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
-- 27 Feb 97 CTA.PWB Added elaboration pragmas.
--!
package C730002_0 is
type Hours_Type is range 0..1000;
type Personnel_Type is range 0..10;
type Specialist_ID is (Manny, Moe, Jack, Curly, Joe, Larry);
type Engine_Type is tagged record
Ave_Repair_Time : Hours_Type := 0; -- Default init. for
Personnel_Required : Personnel_Type := 0; -- component fields.
Specialist : Specialist_ID := Manny;
end record;
procedure Routine_Maintenance (Engine : in out Engine_Type ;
Specialist : in Specialist_ID := Moe);
-- The Routine_Maintenance procedure implements the processing required
-- for an engine.
end C730002_0;
--==================================================================--
package body C730002_0 is
procedure Routine_Maintenance (Engine : in out Engine_Type ;
Specialist : in Specialist_ID := Moe) is
begin
Engine.Ave_Repair_Time := 3;
Engine.Personnel_Required := 1;
Engine.Specialist := Specialist;
end Routine_Maintenance;
end C730002_0;
--==================================================================--
with C730002_0; use C730002_0;
generic
type T is new C730002_0.Engine_Type with private;
package C730002_1 is
-- This generic package contains types/procedures specific to engines
-- of the diesel variety.
type Repair_Facility_Type is (On_Site, Repair_Shop, Factory);
type Diesel_Series is new T with private;
procedure Routine_Maintenance (Eng : in out Diesel_Series;
Spec_Req : in Specialist_ID := Jack);
-- Other diesel specific operations... (not required in this test).
private
type Diesel_Series is new T with record
Repair_Facility_Required : Repair_Facility_Type := On_Site;
end record;
end C730002_1;
--==================================================================--
package body C730002_1 is
procedure Routine_Maintenance (Eng : in out Diesel_Series;
Spec_Req : in Specialist_ID := Jack) is
begin
Eng.Ave_Repair_Time := 6;
Eng.Personnel_Required := 2;
Eng.Specialist := Spec_Req;
Eng.Repair_Facility_Required := On_Site;
end Routine_Maintenance;
end C730002_1;
--==================================================================--
with C730002_0;
with C730002_1;
pragma Elaborate (C730002_1);
package C730002_2 is new C730002_1 (C730002_0.Engine_Type);
--==================================================================--
with C730002_0; use C730002_0;
with C730002_2; use C730002_2;
generic
type T is new C730002_2.Diesel_Series with private;
package C730002_3 is
type Time_Of_Operation_Type is range 0..100_000;
type Electric_Series is new T with private;
procedure Routine_Maintenance (E : in out Electric_Series;
SR : in Specialist_ID := Curly);
-- Other electric specific operations... (not required in this test).
private
type Electric_Series is new T with record
Mean_Time_Between_Repair : Time_Of_Operation_Type := 0;
end record;
end C730002_3;
--==================================================================--
package body C730002_3 is
procedure Routine_Maintenance (E : in out Electric_Series;
SR : in Specialist_ID := Curly) is
begin
E.Ave_Repair_Time := 9;
E.Personnel_Required := 3;
E.Specialist := SR;
E.Mean_Time_Between_Repair := 1000;
end Routine_Maintenance;
end C730002_3;
--==================================================================--
with C730002_2;
with C730002_3;
pragma Elaborate (C730002_3);
package C730002_4 is new C730002_3 (C730002_2.Diesel_Series);
--==================================================================--
with C730002_0; use C730002_0;
with C730002_4; use C730002_4;
package C730002_5 is
type Inspection_Type is (AAA, MIL_STD, NRC);
type Nuclear_Series is new Engine_Type with private; -- (A)
-- Inherits procedure Routine_Maintenance from ancestor; does not override.
-- (Engine : in out Nuclear_Series;
-- Specialist : in Specialist_ID := Moe);
-- But body executed will be that of C730002_4.Routine_Maintenance,
-- the parent type.
function TC_Specialist (E : Nuclear_Series) return Specialist_ID;
function TC_Personnel_Required (E : Nuclear_Series) return Personnel_Type;
function TC_Time_Required (E : Nuclear_Series) return Hours_Type;
-- Dispatching subprogram.
procedure Maintain_The_Engine (The_Engine : in out Engine_Type'Class);
private
type Nuclear_Series is new Electric_Series with record -- (B)
Inspector_Rep : Inspection_Type := NRC;
end record;
-- The ancestor type is used in the type extension (A), while the parent
-- of the full type (B) is a descendent of the ancestor type, through a
-- series of types produced by generic instantiation.
end C730002_5;
--==================================================================--
package body C730002_5 is
function TC_Specialist (E : Nuclear_Series) return Specialist_ID is
begin
return E.Specialist;
end TC_Specialist;
function TC_Personnel_Required (E : Nuclear_Series)
return Personnel_Type is
begin
return E.Personnel_Required;
end TC_Personnel_Required;
function TC_Time_Required (E : Nuclear_Series) return Hours_Type is
begin
return E.Ave_Repair_Time;
end TC_Time_Required;
-- Dispatching subprogram.
procedure Maintain_The_Engine (The_Engine : in out Engine_Type'Class) is
begin
Routine_Maintenance (The_Engine);
end Maintain_The_Engine;
end C730002_5;
--==================================================================--
with Report;
with C730002_0; use C730002_0;
with C730002_2; use C730002_2;
with C730002_4; use C730002_4;
with C730002_5; use C730002_5;
procedure C730002 is
begin
Report.Test ("C730002", "Check that the full view of a private " &
"extension may be derived indirectly from " &
"the ancestor type. Check for a case where " &
"the parent type is derived from the ancestor " &
"type through a series of types produced by " &
"generic instantiations");
Test_Block:
declare
Nuclear_Drive : Nuclear_Series;
Warp_Drive : Nuclear_Series;
begin
-- Non-Dispatching Case:
-- Call Routine_Maintenance using formal parameter name from
-- C730002_0.Routine_Maintenance (ancestor version).
-- Give no second parameter so that the default expression must be
-- used.
Routine_Maintenance (Engine => Nuclear_Drive);
-- The value of the Specialist component should equal "Moe",
-- which is the default value from the ancestor's version of
-- Routine_Maintenance, and not the default value from the parent's
-- version of Routine_Maintenance.
if TC_Specialist (Nuclear_Drive) /= Moe then
Report.Failed
("Default expression for ancestor op not used " &
" - non-dispatching case");
end if;
-- However the value of the Ave_Repair_Time and Personnel_Required
-- components should be those assigned in the parent type's version
-- of the body of Routine_Maintenance.
-- Note: Only components associated with the ancestor type are
-- evaluated for the purposes of this test.
if TC_Personnel_Required (Nuclear_Drive) /= 3 or
TC_Time_Required (Nuclear_Drive) /= 9
then
Report.Failed("Wrong body was executed - non-dispatching case");
end if;
-- Dispatching Case:
-- Use a dispatching subprogram to ensure that the correct body is
-- used at runtime.
Maintain_The_Engine (Warp_Drive);
-- The resulting assignments to the fields of the Warp_Drive variable
-- should be the same as those of the Nuclear_Drive above, indicating
-- that the body of the parent version of the inherited subprogram
-- was used.
if TC_Specialist (Warp_Drive) /= Moe then
Report.Failed
("Default expression for ancestor op not used - dispatching case");
end if;
if TC_Personnel_Required (Nuclear_Drive) /= 3 or
TC_Time_Required (Nuclear_Drive) /= 9
then
Report.Failed("Wrong body was executed - dispatching case");
end if;
exception
when others => Report.Failed("Exception raised in Test_Block");
end Test_Block;
Report.Result;
end C730002;
Go to most recent revision | Compare with Previous | Blame | View Log