1-- C640001.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 the prefix of a subprogram call with an actual parameter 28-- part may be an implicit dereference of an access-to-subprogram value. 29-- Check that, for an access-to-subprogram type whose designated profile 30-- contains parameters of a tagged generic formal type, an access-to- 31-- subprogram value may designate dispatching and non-dispatching 32-- operations, and that dereferences of such a value call the appropriate 33-- subprogram. 34-- 35-- TEST DESCRIPTION: 36-- The test declares a tagged type (Table) with a dispatching operation 37-- (Clear), as well as a derivative (Table2) which overrides that 38-- operation. A subprogram with the same name and profile as Clear is 39-- declared in a separate package -- it is therefore not a dispatching 40-- operation of Table. For the purposes of the test, each version of Clear 41-- modifies the components of its parameter in a unique way. 42-- 43-- Additionally, an operation (Reset) of type Table is declared which 44-- makes a re-dispatching call to Clear, i.e., 45-- 46-- procedure Reset (A: in out Table) is 47-- begin 48-- ... 49-- Clear (Table'Class(A)); -- Re-dispatch based on tag of actual. 50-- ... 51-- end Reset; 52-- 53-- An access-to-subprogram type is declared within a generic package, 54-- with a designated profile which declares a parameter of a generic 55-- formal tagged private type. 56-- 57-- The generic is instantiated with type Table. The instance defines an 58-- array of access-to-subprogram values (which represents a table of 59-- operations to be performed sequentially on a single operand). 60-- Access values designating the dispatching version of Clear, the 61-- non-dispatching version of Clear, and Reset (which re-dispatches to 62-- Clear) are placed in this array. 63-- 64-- In the instance, each subprogram in the array is called by implicitly 65-- dereferencing the corresponding access value. For the dispatching and 66-- non-dispatching versions of Clear, the actual parameter passed is of 67-- type Table. For Reset, the actual parameter passed is a view conversion 68-- of an object of type Table2 to type Table, i.e., Table(Table2_Obj). 69-- Since the tag of the operand never changes, the call to Clear within 70-- Reset should execute Table2's version of Clear. 71-- 72-- The main program verifies that the appropriate version of Clear is 73-- called in each case, by checking that the components of the actual are 74-- updated as expected. 75-- 76-- 77-- CHANGE HISTORY: 78-- 06 Dec 94 SAIC ACVC 2.0 79-- 80--! 81 82package C640001_0 is 83 84 -- Data type artificial for testing purposes. 85 86 Row_Len : constant := 10; 87 88 T : constant Boolean := True; 89 F : constant Boolean := False; 90 91 type Row_Type is array (1 .. Row_Len) of Boolean; 92 93 function Is_True (A : in Row_Type) return Boolean; 94 function Is_False (A : in Row_Type) return Boolean; 95 96 97 Init : constant Row_Type := (T, F, T, F, T, F, T, F, T, F); 98 99 type Table is tagged record -- Tagged type. 100 Row1 : Row_Type := Init; 101 Row2 : Row_Type := Init; 102 end record; 103 104 procedure Clear (A : in out Table); -- Dispatching operation. 105 106 procedure Reset (A : in out Table); -- Re-dispatching operation. 107 108 -- ...Other operations. 109 110 111 type Table2 is new Table with null record; -- Extension of Table (but 112 -- structurally identical). 113 114 procedure Clear (A : in out Table2); -- Overrides parent's op. 115 116 -- ...Other operations. 117 118 119end C640001_0; 120 121 122 --===================================================================-- 123 124 125package body C640001_0 is 126 127 function Is_True (A : in Row_Type) return Boolean is 128 begin 129 for I in A'Range loop 130 if A(I) /= True then -- Return true if all elements 131 return False; -- of A are True. 132 end if; 133 end loop; 134 return True; 135 end Is_True; 136 137 138 function Is_False (A : in Row_Type) return Boolean is 139 begin 140 return A = Row_Type'(others => False); -- Return true if all elements 141 end Is_False; -- of A are False. 142 143 144 procedure Clear (A : in out Table) is 145 begin 146 for I in Row_Type'Range loop -- This version of Clear sets 147 A.Row1(I) := False; -- the elements of Row1 only 148 end loop; -- to False. 149 end Clear; 150 151 152 procedure Reset (A : in out Table) is 153 begin 154 Clear (Table'Class(A)); -- Redispatch to appropriate 155 -- ... Other "reset" activities. -- version of Clear. 156 end Reset; 157 158 159 procedure Clear (A : in out Table2) is 160 begin 161 for I in Row_Type'Range loop -- This version of Clear sets 162 A.Row1(I) := True; -- the elements of Row1 only 163 end loop; -- to True. 164 end Clear; 165 166 167end C640001_0; 168 169 170 --===================================================================-- 171 172 173with C640001_0; 174package C640001_1 is 175 176 procedure Clear (T : in out C640001_0.Table); -- Non-dispatching operation. 177 178end C640001_1; 179 180 181 --===================================================================-- 182 183 184package body C640001_1 is 185 186 procedure Clear (T : in out C640001_0.Table) is 187 begin 188 for I in C640001_0.Row_Type'Range loop -- This version of Clear sets 189 T.Row2(I) := True; -- the elements of Row2 only 190 end loop; -- to True. 191 end Clear; 192 193end C640001_1; 194 195 196 --===================================================================-- 197 198 199-- This unit represents a support package for table-driven processing of 200-- data objects. Process_Operand performs a set of operations are performed 201-- sequentially on a single operand. Note that parameters are provided to 202-- specify which subset of operations in the operations table are to be 203-- performed (ordinarily these might be omitted, but the test requires that 204-- each operation be called individually for a single operand). 205 206generic 207 type Tag is tagged private; 208package C640001_2 is 209 210 type Proc_Ptr is access procedure (P: in out Tag); 211 212 type Op_List is private; 213 214 procedure Add_Op (Op : in Proc_Ptr; -- Add operation to 215 List : in out Op_List); -- to list of ops. 216 217 procedure Process_Operand (Operand : in out Tag; -- Execute a subset 218 List : in Op_List; -- of a list of 219 First_Op : in Positive; -- operations using 220 Last_Op : in Positive); -- a given operand. 221 222 -- ...Other operations. 223 224private 225 type Op_Array is array (1 .. 3) of Proc_Ptr; 226 227 type Op_List is record 228 Top : Natural := 0; 229 Ops : Op_Array; 230 end record; 231end C640001_2; 232 233 234 --===================================================================-- 235 236 237package body C640001_2 is 238 239 procedure Add_Op (Op : in Proc_Ptr; 240 List : in out Op_List) is 241 begin 242 List.Top := List.Top + 1; -- Artificial; no Constraint_Error protection. 243 List.Ops(List.Top) := Op; 244 end Add_Op; 245 246 247 procedure Process_Operand (Operand : in out Tag; 248 List : in Op_List; 249 First_Op : in Positive; 250 Last_Op : in Positive) is 251 begin 252 for I in First_Op .. Last_Op loop 253 List.Ops(I)(Operand); -- Implicit dereference of an 254 end loop; -- access-to-subprogram value. 255 end Process_Operand; 256 257end C640001_2; 258 259 260 --===================================================================-- 261 262 263with C640001_0; 264with C640001_1; 265with C640001_2; 266 267with Report; 268procedure C640001 is 269 270 package Table_Support is new C640001_2 (C640001_0.Table); 271 272 Sub_Ptr : Table_Support.Proc_Ptr; 273 My_List : Table_Support.Op_List; 274 My_Table1 : C640001_0.Table; -- Initial values of both Row1 & 275 -- Row2 are (T,F,T,F,T,F,T,F,T,F). 276 My_Table2 : C640001_0.Table2; -- Initial values of both Row1 & 277 -- Row2 are (T,F,T,F,T,F,T,F,T,F). 278begin 279 Report.Test ("C640001", "Check that, for an access-to-subprogram type " & 280 "whose designated profile contains parameters " & 281 "of a tagged generic formal type, an access-" & 282 "to-subprogram value may designate dispatching " & 283 "and non-dispatching operations"); 284 285 -- 286 -- Add subprogram access values to list: 287 -- 288 289 Sub_Ptr := C640001_0.Clear'Access; -- Designates dispatching op. 290 Table_Support.Add_Op (Sub_Ptr, My_List); -- (1st operation on My_List). 291 292 Sub_Ptr := C640001_1.Clear'Access; -- Designates non-dispatching op. 293 Table_Support.Add_Op (Sub_Ptr, My_List); -- (2nd operation on My_List). 294 295 Sub_Ptr := C640001_0.Reset'Access; -- Designates re-dispatching op. 296 Table_Support.Add_Op (Sub_Ptr, My_List); -- (3rd operation on My_List). 297 298 299 -- 300 -- Call dispatching operation: 301 -- 302 303 Table_Support.Process_Operand (My_Table1, My_List, 1, 1); -- Call 1st op. 304 305 if not C640001_0.Is_False (My_Table1.Row1) then 306 Report.Failed ("Wrong result after calling dispatching operation"); 307 end if; 308 309 310 -- 311 -- Call non-dispatching operation: 312 -- 313 314 Table_Support.Process_Operand (My_Table1, My_List, 2, 2); -- Call 2nd op. 315 316 if not C640001_0.Is_True (My_Table1.Row2) then 317 Report.Failed ("Wrong result after calling non-dispatching operation"); 318 end if; 319 320 321 -- 322 -- Call re-dispatching operation: 323 -- 324 325 Table_Support.Process_Operand (C640001_0.Table(My_Table2), -- View conv. 326 My_List, 3, 3); -- Call 3rd op. 327 328 if not C640001_0.Is_True (My_Table2.Row1) then 329 Report.Failed ("Wrong result after calling re-dispatching operation"); 330 end if; 331 332 333 Report.Result; 334end C640001; 335