aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.9/gcc/testsuite/ada/acats/tests/c7/c730002.a
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.9/gcc/testsuite/ada/acats/tests/c7/c730002.a')
-rw-r--r--gcc-4.9/gcc/testsuite/ada/acats/tests/c7/c730002.a383
1 files changed, 383 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c7/c730002.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c7/c730002.a
new file mode 100644
index 000000000..9213a7d92
--- /dev/null
+++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c7/c730002.a
@@ -0,0 +1,383 @@
+-- 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;