diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c7/c730002.a')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/c7/c730002.a | 383 |
1 files changed, 0 insertions, 383 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c7/c730002.a b/gcc/testsuite/ada/acats/tests/c7/c730002.a deleted file mode 100644 index 9213a7d92d3..00000000000 --- a/gcc/testsuite/ada/acats/tests/c7/c730002.a +++ /dev/null @@ -1,383 +0,0 @@ --- 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; |