1-- C393A05.A 2 -- 3-- Grant of Unlimited Rights 4-- 5-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, 6-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained 7-- unlimited rights in the software and documentation contained herein. 8-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making 9-- this public release, the Government intends to confer upon all 10-- recipients unlimited rights equal to those held by the Government. 11-- These rights include rights to use, duplicate, release or disclose the 12-- released technical data and computer software in whole or in part, in 13-- any manner and for any purpose whatsoever, and to have or permit others 14-- to do so. 15-- 16-- DISCLAIMER 17-- 18-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR 19-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED 20-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE 21-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE 22-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A 23-- PARTICULAR PURPOSE OF SAID MATERIAL. 24--* 25 -- 26 -- OBJECTIVE: 27 -- Check that for a nonabstract private extension, any inherited 28 -- abstract subprograms can be overridden in the private part of 29 -- the immediately enclosing package and that calls can be made to 30 -- private dispatching operations. 31 -- 32 -- TEST DESCRIPTION: 33 -- This test builds an additional layer upon the foundation code to 34 -- provide the required "hidden" dispatching operation. The procedure 35 -- Swap, a private subprogram, should be called by dispatch. 36 -- 37 -- TEST FILES: 38 -- The following files comprise this test: 39 -- 40 -- F393A00.A (foundation code) 41 -- C393A05.A 42 -- 43 -- 44-- CHANGE HISTORY: 45-- 06 Dec 94 SAIC ACVC 2.0 46-- 47 --! 48 49 with F393A00_4; 50 package C393A05_0 is 51 type Grinder is new F393A00_4.Mill with private; 52 type Coarseness is (Whole_Bean, Coarse, Medium, Fine, Espresso); 53 54 procedure Set_Grind( It: in out Grinder; The_Grind: Coarseness ); 55 function Grind( It: Grinder ) return Coarseness; 56 57 function Create return Grinder; 58 private 59 procedure Swap( A,B: in out Grinder ); 60 type Grinder is new F393A00_4.Mill with 61 record 62 Grind : Coarseness := Whole_Bean; 63 end record; 64 end C393A05_0; 65 66 with F393A00_0; 67 package body C393A05_0 is 68 procedure Set_Grind( It: in out Grinder; The_Grind: Coarseness ) is 69 begin 70 F393A00_0.TC_Touch( 'A' ); 71 It.Grind := The_Grind; 72 end Set_Grind; 73 74 function Grind( It: Grinder ) return Coarseness is 75 begin 76 F393A00_0.TC_Touch( 'B' ); 77 return It.Grind; 78 end Grind; 79 80 procedure Swap( A,B: in out Grinder ) is 81 T : constant Grinder := A; 82 begin 83 F393A00_0.TC_Touch( 'C' ); 84 A := B; 85 B := T; 86 end Swap; 87 88 function Create return Grinder is 89 One: Grinder; 90 begin 91 F393A00_0.TC_Touch( 'D' ); 92 F393A00_4.Initialize( F393A00_4.Mill( One ) ); 93 One.Grind := Fine; 94 return One; 95 end Create; 96 end C393A05_0; 97 98 with Report; 99 with F393A00_0; 100 with C393A05_0; 101 procedure C393A05 is 102 103 package Tracer renames F393A00_0; 104 package Coffee renames C393A05_0; 105 use type Coffee.Coarseness; 106 107 Morning : Coffee.Grinder; 108 Afternoon : Coffee.Grinder; 109 110 Gritty : Coffee.Coarseness; 111 112 procedure Class_Swap( A, B: in out Coffee.Grinder'Class ) is 113 begin 114 Coffee.Swap( A, B ); -- dispatch 115 end Class_Swap; 116 117 begin -- Main test procedure. 118 119 Report.Test ("C393A05", "Check that nonabstract private extensions, " 120 & "inherited abstract subprograms overridden " 121 & "in the private part can be dispatched from " 122 & "outside the package" ); 123 124 Tracer.TC_Validate( "hh", "Declarations" ); 125 126 Morning := Coffee.Create; 127 Tracer.TC_Validate( "hDa", "Creating Morning Coffee" ); 128 Gritty := Coffee.Grind( Morning ); 129 Tracer.TC_Validate( "B", "Finding Morning Grind" ); 130 131 Afternoon := Coffee.Create; 132 Tracer.TC_Validate( "hDa", "Creating Afternoon Coffee" ); 133 Coffee.Set_Grind( Afternoon, Coffee.Medium ); 134 Tracer.TC_Validate( "A", "Setting Afternoon Grind" ); 135 136 Coffee.Swap( Morning, Afternoon ); 137 Tracer.TC_Validate( "C", "Dispatching Swapping Coffees" ); 138 139 if Gritty /= Coffee.Grind( Afternoon ) 140 or Coffee.Grind ( Afternoon ) /= Coffee.Fine then 141 Report.Failed ("Result of Swap"); 142 end if; 143 Tracer.TC_Validate( "BB", "Finding Afternoon Grind" ); 144 145 Sunset: declare 146 Evening : Coffee.Grinder'Class := Coffee.Create; 147 begin 148 Tracer.TC_Validate( "hDa", "Creating Evening Coffee" ); 149 150 Coffee.Set_Grind( Evening, Coffee.Espresso ); 151 Tracer.TC_Validate( "A", "Setting Evening Grind" ); 152 153 Morning := Coffee.Grinder( Evening ); 154 Class_Swap( Morning, Evening ); 155 Tracer.TC_Validate( "C", "Swapping Coffees" ); 156 if Coffee.Grind( Morning ) /= Coffee.Espresso then 157 Report.Failed ("Result of Assignment"); 158 end if; 159 end Sunset; 160 161 Report.Result; 162 163 end C393A05; 164 165 166 167