1-- C393A02.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 a dispatching call to an abstract subprogram invokes 28-- the correct subprogram body of a descendant type according to 29-- the controlling tag. 30-- Check that a subprogram can be declared with formal parameters 31-- and result that are of an abstract type's associated class-wide 32-- type and that such subprograms can be called. 3.4.1(4) 33-- 34-- TEST DESCRIPTION: 35-- This test declares several objects of types derived from the 36-- abstract type as defined in the foundation F393A00. It then calls 37-- various dispatching and class-wide subprograms using those objects. 38-- The packages in F393A00 are instrumented to trace the flow of 39-- execution. 40-- The test checks for the correct order of execution, as expected 41-- by the various calls. 42-- 43-- TEST FILES: 44-- The following files comprise this test: 45-- 46-- F393A00.A (foundation code) 47-- C393A02.A 48-- 49-- 50-- CHANGE HISTORY: 51-- 06 Dec 94 SAIC ACVC 2.0 52-- 19 Dec 94 SAIC Removed RM references from objective text. 53-- 05 APR 96 SAIC Update RM references for 2.1 54-- 55--! 56 57with Report; 58with F393A00_0; 59with F393A00_1; 60with F393A00_2; 61with F393A00_3; 62with F393A00_4; 63procedure C393A02 is 64 65 A_Windmill : F393A00_2.Windmill; 66 A_Pump : F393A00_3.Pump; 67 A_Mill : F393A00_4.Mill; 68 69 A_Windmill_2 : F393A00_2.Windmill; 70 A_Pump_2 : F393A00_3.Pump; 71 A_Mill_2 : F393A00_4.Mill; 72 73 B_Windmill : F393A00_2.Windmill; 74 B_Pump : F393A00_3.Pump; 75 B_Mill : F393A00_4.Mill; 76 77 procedure Swapem( A,B: in out F393A00_2.Windmill'Class ) is 78 begin 79 F393A00_0.TC_Touch('x'); 80 F393A00_2.Swap( A,B ); 81 end Swapem; 82 83 function Zephyr( A: F393A00_2.Windmill'Class ) 84 return F393A00_2.Windmill'Class is 85 Item : F393A00_2.Windmill'Class := A; 86 begin 87 F393A00_0.TC_Touch('y'); 88 if not F393A00_1.Initialized( Item ) then -- b 89 F393A00_2.Initialize( Item ); -- a 90 end if; 91 F393A00_2.Stop( Item ); -- f / mff 92 F393A00_2.Add_Spin( Item, 10 ); -- e 93 return Item; 94 end Zephyr; 95 96 function Gale( It: F393A00_2.Windmill ) return F393A00_2.Windmill'Class is 97 Item : F393A00_2.Windmill'Class := It; 98 begin 99 F393A00_2.Stop( Item ); -- f 100 F393A00_2.Add_Spin( Item, 40 ); -- e 101 return Item; 102 end Gale; 103 104 function Gale( It: F393A00_3.Pump ) return F393A00_2.Windmill'Class is 105 Item : F393A00_2.Windmill'Class := It; 106 begin 107 F393A00_2.Stop( Item ); -- f 108 F393A00_2.Add_Spin( Item, 50 ); -- e 109 return Item; 110 end Gale; 111 112 function Gale( It: F393A00_4.Mill ) return F393A00_2.Windmill'Class is 113 Item : F393A00_2.Windmill'Class := It; 114 begin 115 F393A00_2.Stop( Item ); -- mff 116 F393A00_2.Add_Spin( Item, 60 ); -- e 117 return Item; 118 end Gale; 119 120begin -- Main test procedure. 121 122 Report.Test ("C393A02", "Check that a dispatching call to an abstract " 123 & "subprogram invokes the correct subprogram body. " 124 & "Check that a subprogram declared with formal " 125 & "parameters/result of an abstract type's " 126 & "associated class-wide can be called" ); 127 128 F393A00_0.TC_Validate( "hhh", "Mill declarations" ); 129 A_Windmill := F393A00_2.Create; 130 F393A00_0.TC_Validate( "d", "Create A_Windmill" ); 131 132 A_Pump := F393A00_3.Create; 133 F393A00_0.TC_Validate( "h", "Create A_Pump" ); 134 135 A_Mill := F393A00_4.Create; 136 F393A00_0.TC_Validate( "hl", "Create A_Mill" ); 137 138 -------------- 139 140 Swapem( A_Windmill, A_Windmill_2 ); 141 F393A00_0.TC_Validate( "xc", "Windmill Swap" ); 142 143 Swapem( A_Pump, A_Pump_2 ); 144 F393A00_0.TC_Validate( "xc", "Pump Swap" ); 145 146 Swapem( A_Mill, A_Mill_2 ); 147 F393A00_0.TC_Validate( "xk", "Pump Swap" ); 148 149 F393A00_2.Initialize( A_Windmill_2 ); 150 F393A00_3.Initialize( A_Pump_2 ); 151 F393A00_4.Initialize( A_Mill_2 ); 152 B_Windmill := A_Windmill_2; 153 B_Pump := A_Pump_2; 154 B_Mill := A_Mill_2; 155 F393A00_2.Add_Spin( B_Windmill, 123 ); 156 F393A00_3.Set_Rate( B_Pump, 12.34 ); 157 F393A00_4.Add_Spin( B_Mill, 321 ); 158 F393A00_0.TC_Validate( "aaaeie", "Setting Values" ); 159 160 declare 161 It : F393A00_2.Windmill'Class := Zephyr( B_Windmill ); -- ybfe 162 XX : F393A00_2.Windmill'Class := Gale( B_Windmill ); -- fe 163 use type F393A00_2.Rotational_Measurement; 164 begin 165 if not F393A00_1.Initialized( It ) or not F393A00_1.Initialized( XX ) 166then 167 Report.Failed( "Copy to class-wide variable" ); 168 end if; -- bb 169 if F393A00_2.Spin( It ) /= 10 -- g 170 or F393A00_2.Spin( XX ) /= 40 then -- g 171 Report.Failed( "Call to class-wide operation" ); 172 end if; 173 174 F393A00_0.TC_Validate( "ybfefebbgg", "Windmill Zephyr" ); 175 end; 176 177 declare 178 It : F393A00_2.Windmill'Class := Zephyr( B_Pump ); -- ybfe 179 XX : F393A00_2.Windmill'Class := Gale( B_Pump ); -- fe 180 use type F393A00_2.Rotational_Measurement; 181 begin 182 if not F393A00_1.Initialized( It ) or not F393A00_1.Initialized( XX ) 183then 184 Report.Failed( "Bad copy to class-wide variable" ); 185 end if; -- bb 186 if F393A00_2.Spin( It ) /= 10 -- g 187 or F393A00_2.Spin( XX ) /= 50 then -- g 188 Report.Failed( "Call to class-wide operation" ); 189 end if; 190 191 F393A00_0.TC_Validate( "ybfefebbgg", "Pump Zephyr" ); 192 end; 193 194 declare 195 It : F393A00_2.Windmill'Class := Zephyr( B_Mill ); -- ybmffe 196 XX : F393A00_2.Windmill'Class := Gale( B_Mill ); -- mffe 197 use type F393A00_2.Rotational_Measurement; 198 begin 199 if not F393A00_1.Initialized( It ) or not F393A00_1.Initialized( XX ) 200then 201 Report.Failed( "Bad copy to class-wide variable" ); 202 end if; -- bb 203 if F393A00_2.Spin( It ) /= 10 -- g 204 or F393A00_2.Spin( XX ) /= 60 then -- g 205 Report.Failed( "Call to class-wide operation" ); 206 end if; 207 208 F393A00_0.TC_Validate( "ybmffemffebbgg", "Mill Zephyr" ); 209 end; 210 211 Report.Result; 212 213end C393A02; 214