1-- C393A03.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 non-abstract primitive subprogram of an abstract 28-- type can be called as a dispatching operation and that the body 29-- of this subprogram can make a dispatching call to an abstract 30-- operation of the corresponding abstract type. 31-- 32-- TEST DESCRIPTION: 33-- This test expands on the class family defined in foundation F393A00 34-- by deriving a new abstract type from the root abstract type "Object". 35-- The subprograms defined for the new abstract type are then 36-- appropriately overridden, and the test ultimately calls various 37-- mixtures of these subprograms to check that the dispatching occurs 38-- correctly. 39-- 40-- TEST FILES: 41-- The following files comprise this test: 42-- 43-- F393A00.A (foundation code) 44-- C393A03.A 45-- 46-- 47-- CHANGE HISTORY: 48-- 06 Dec 94 SAIC ACVC 2.0 49-- 19 Dec 94 SAIC Removed ARM references from objective text. 50-- 23 Oct 95 SAIC Fixed bugs for ACVC 2.0.1 51-- 52--! 53 54------------------------------------------------------------------- C393A03_0 55 56with F393A00_1; 57package C393A03_0 is 58 59 type Counting_Object is abstract new F393A00_1.Object with private; 60 -- inherits Initialize, Swap (abstract) and Create (abstract) 61 62 procedure Bump ( A_Counter: in out Counting_Object ); 63 procedure Clear( A_Counter: in out Counting_Object ) is abstract; 64 procedure Zero ( A_Counter: in out Counting_Object ); 65 function Value( A_Counter: Counting_Object'Class ) return Natural; 66 67private 68 69 type Counting_Object is abstract new F393A00_1.Object with 70 record 71 Tally : Natural :=0; 72 end record; 73 74end C393A03_0; 75 76----------------------------------------------------------------------------- 77 78with F393A00_0; 79package body C393A03_0 is 80 81 procedure Bump ( A_Counter: in out Counting_Object ) is 82 begin 83 F393A00_0.TC_Touch('A'); 84 A_Counter.Tally := A_Counter.Tally +1; 85 end Bump; 86 87 procedure Zero ( A_Counter: in out Counting_Object ) is 88 begin 89 F393A00_0.TC_Touch('B'); 90 91 -- dispatching call to abstract operation of Counting_Object 92 Clear( Counting_Object'Class(A_Counter) ); 93 94 A_Counter.Tally := 0; 95 96 end Zero; 97 98 function Value( A_Counter: Counting_Object'Class ) return Natural is 99 begin 100 F393A00_0.TC_Touch('C'); 101 return A_Counter.Tally; 102 end Value; 103 104end C393A03_0; 105 106------------------------------------------------------------------- C393A03_1 107 108with C393A03_0; 109package C393A03_1 is 110 111 type Modular_Object is new C393A03_0.Counting_Object with private; 112 -- inherits Initialize, Bump, Zero and Value, 113 -- inherits abstract Swap, Create and Clear 114 115 procedure Swap( A,B: in out Modular_Object ); 116 procedure Clear( It: in out Modular_Object ); 117 procedure Set_Max( It : in out Modular_Object; Value : Natural ); 118 function Create return Modular_Object; 119 120private 121 122 type Modular_Object is new C393A03_0.Counting_Object with 123 record 124 Max_Value : Natural; 125 end record; 126 127end C393A03_1; 128 129----------------------------------------------------------------------------- 130 131with F393A00_0; 132package body C393A03_1 is 133 134 procedure Swap( A,B: in out Modular_Object ) is 135 T : constant Modular_Object := B; 136 begin 137 F393A00_0.TC_Touch('1'); 138 B := A; 139 A := T; 140 end Swap; 141 142 procedure Clear( It: in out Modular_Object ) is 143 begin 144 F393A00_0.TC_Touch('2'); 145 null; 146 end Clear; 147 148 procedure Set_Max( It : in out Modular_Object; Value : Natural ) is 149 begin 150 F393A00_0.TC_Touch('3'); 151 It.Max_Value := Value; 152 end Set_Max; 153 154 function Create return Modular_Object is 155 AMO : Modular_Object; 156 begin 157 F393A00_0.TC_Touch('4'); 158 AMO.Max_Value := Natural'Last; 159 return AMO; 160 end Create; 161 162end C393A03_1; 163 164--------------------------------------------------------------------- C393A03 165 166with Report; 167with F393A00_0; 168with F393A00_1; 169with C393A03_0; 170with C393A03_1; 171procedure C393A03 is 172 173 A_Thing : C393A03_1.Modular_Object; 174 Another_Thing : C393A03_1.Modular_Object; 175 176 procedure Initialize( It: in out C393A03_0.Counting_Object'Class ) is 177 begin 178 C393A03_0.Initialize( It ); -- dispatch to inherited procedure 179 end Initialize; 180 181 procedure Bump( It: in out C393A03_0.Counting_Object'Class ) is 182 begin 183 C393A03_0.Bump( It ); -- dispatch to non-abstract procedure 184 end Bump; 185 186 procedure Set_Max( It : in out C393A03_1.Modular_Object'Class; 187 Val : Natural) is 188 begin 189 C393A03_1.Set_Max( It, Val ); -- dispatch to non-abstract procedure 190 end Set_Max; 191 192 procedure Swap( A, B : in out C393A03_0.Counting_Object'Class ) is 193 begin 194 C393A03_0.Swap( A, B ); -- dispatch to inherited abstract procedure 195 end Swap; 196 197 procedure Zero( It: in out C393A03_0.Counting_Object'Class ) is 198 begin 199 C393A03_0.Zero( It ); -- dispatch to non-abstract procedure 200 end Zero; 201 202begin -- Main test procedure. 203 204 Report.Test ("C393A03", "Check that a non-abstract primitive subprogram " 205 & "of an abstract type can be called as a " 206 & "dispatching operation and that the body of this " 207 & "subprogram can make a dispatching call to an " 208 & "abstract operation of the corresponding " 209 & "abstract type" ); 210 211 A_Thing := C393A03_1.Create; -- Max_Value = Natural'Last 212 F393A00_0.TC_Validate( "4", "Overridden primitive layer 2"); 213 214 Initialize( A_Thing ); 215 Initialize( Another_Thing ); 216 F393A00_0.TC_Validate( "aa", "Non-abstract primitive layer 0"); 217 218 Bump( A_Thing ); -- Tally = 1 219 F393A00_0.TC_Validate( "A", "Non-abstract primitive layer 1"); 220 221 Set_Max( A_Thing, 42 ); -- Max_Value = 42 222 F393A00_0.TC_Validate( "3", "Non-abstract normal layer 2"); 223 224 if not F393A00_1.Initialized( A_Thing ) then 225 Report.Failed("Initialize didn't"); 226 end if; 227 F393A00_0.TC_Validate( "b", "Class-wide layer 0"); 228 229 Swap( A_Thing, Another_Thing ); 230 F393A00_0.TC_Validate( "1", "Overridden abstract layer 2"); 231 232 Zero( A_Thing ); 233 F393A00_0.TC_Validate( "B2", "Non-abstract layer 0, calls dispatch"); 234 235 if C393A03_0.Value( A_Thing ) /= 0 then 236 Report.Failed("Zero didn't"); 237 end if; 238 F393A00_0.TC_Validate( "C", "Class-wide normal layer 2"); 239 240 Report.Result; 241 242end C393A03; 243