| -- 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; |
